File Coverage

blib/lib/Color/Swatch/ASE/Reader.pm

Criterion	Covered	Total	%
statement	97	113	85.8
branch	27	46	58.7
condition	1	3	33.3
subroutine	21	25	84.0
pod	3	3	100.0
total	149	190	78.4

use 5.010;    # unpack >
use strict;
use warnings;

package Color::Swatch::ASE::Reader;

our $VERSION = '0.001004';

# ABSTRACT: Low-Level ASE (Adobe Swatch Exchange) File decoder

our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY

use Encode qw( decode );

## no critic (ValuesAndExpressions::ProhibitEscapedCharacters)
my $BLOCK_GROUP_START = "\x{c0}\x{01}";
my $BLOCK_GROUP_END   = "\x{c0}\x{02}";
my $BLOCK_COLOR       = "\x{00}\x{01}";
my $UTF16NULL         = "\x{00}\x{00}";
## use critic







sub read_file {
  my ( $class, $file ) = @_;
  require Path::Tiny;
  return $class->read_string( Path::Tiny::path($file)->slurp_raw );
}







sub read_filehandle {
  my ( $class, $filehandle ) = @_;
  return $class->read_string( scalar <$filehandle> );
}







sub read_string {
  my ( $class, $string ) = @_;
  my $clone = "$string";

  my $signature = $class->_read_signature( \$clone );
  my $version   = $class->_read_version( \$clone );
  my $numblocks = $class->_read_numblocks( \$clone );

  my @blocks;

  for my $id ( 1 .. $numblocks ) {
    push @blocks, $class->_read_block( \$clone, $id, );
  }

  if ( length $clone ) {
    warn +( ( length $clone ) . ' bytes of unhandled data' );
  }

  return { signature => $signature, version => $version, blocks => \@blocks, };

}

sub _read_bytes {
  my ( undef, $string, $num, $decode ) = @_;
  return if ( length ${$string} ) < $num;
  my $chars = substr ${$string}, 0, $num, q[];
  return unpack $decode, $chars if $decode;
  return $chars;
}

sub _read_signature {
  my ( $class, $string ) = @_;
  my $signature = $class->_read_bytes( $string, 4 );
  die 'No ASEF signature' if not defined $signature or q[ASEF] ne $signature;
  return $signature;
}

sub _read_version {
  my ( $class, $string ) = @_;
  my (@version) = $class->_read_bytes( $string, 4, q[nn] );
  die 'No VERSION header' if @version != 2;
  return \@version;
}

sub _read_numblocks {
  my ( $class, $string ) = @_;
  my $blocks = $class->_read_bytes( $string, 4, q[N] );
  die 'No NUM BLOCKS header' if not defined $blocks;
  return $blocks;
}

sub _read_block_group {
  my ( $class, $string ) = @_;
  return $class->_read_bytes( $string, 2, q[n] );
}

sub _read_group_end {
  my ( undef, $group, $label ) = @_;
  return {
    type => 'group_end',
    ( $group ? ( group => $group ) : () ),
    ( $label ? ( label => $label ) : () ),
  };
}

sub _read_group_start {
  my ( undef, $group, $label ) = @_;
  return {
    type => 'group_start',
    ( $group ? ( group => $group ) : () ),
    ( $label ? ( label => $label ) : () ),
  };
}

sub _read_rgb {
  my ( $class, $block_body ) = @_;
  return $class->_read_bytes( $block_body, 12, 'f>f>f>' );
}

sub _read_lab {
  my ( $class, $block_body ) = @_;
  return $class->_read_bytes( $block_body, 12, 'f>f>f>' );
}

sub _read_cmyk {
  my ( $class, $block_body ) = @_;
  return $class->_read_bytes( $block_body, 16, 'f>f>f>f>' );
}

sub _read_gray {
  my ( $class, $block_body ) = @_;
  return $class->_read_bytes( $block_body, 4, 'f>' );
}

my $color_table = {
  q[RGB ] => '_read_rgb',
  q[LAB ] => '_read_lab',
  q[CMYK] => '_read_cymk',
  q[Gray] => '_read_gray',
};

sub _read_color_model {
  my ( $class, $id, $block_body ) = @_;
  my $model = $class->_read_bytes( $block_body, 4 );
  if ( not defined $model ) {
    die "No COLOR MODEL for block $id";
  }
  if ( not exists $color_table->{$model} ) {
    die "Unsupported model $model";
  }
  return $model;
}

sub _read_color_type {
  my ( $class, $block_body ) = @_;
  my $type = $class->_read_bytes( $block_body, 2, q[n] );
  return $type;
}

sub _read_color {
  my ( $class, $id, $group, $label, $block_body ) = @_;

  my $model = $class->_read_color_model( $id, $block_body );

  my @values;

  my $method = $class->can( $color_table->{$model} );
  @values = $class->$method($block_body);

  my $type = $class->_read_color_type($block_body);
  return {
    type => 'color',
    ( $group ? ( group => $group ) : () ),
    ( $label ? ( label => $label ) : () ),
    ( $model ? ( model => $model ) : () ),
    values     => \@values,
    color_type => $type,
  };

}

sub _read_block_label {
  my ( undef,  $string ) = @_;
  my ( $label, $rest )   = ( ${$string} =~ /\A(.*?)${UTF16NULL}(.*\z)/msx );
  if ( defined $rest ) {
    ${$string} = "$rest";
  }
  else {
    ${$string} = q[];
  }
  return decode( 'UTF-16BE', $label, Encode::FB_CROAK );
}

sub _read_block_type {
  my ( $class, $string, $id ) = @_;
  my $type = $class->_read_bytes( $string, 2 );
  die "No BLOCK TYPE for block $id" if not defined $type;
  return $type;
}

sub _read_block_length {
  my ( $class, $string, $id ) = @_;
  my $length = $class->_read_bytes( $string, 4, q[N] );
  die "No BLOCK LENGTH for block $id" if not defined $length;
  if ( ( length ${$string} ) < $length ) {
    warn "Possibly corrupt file, EOF before length $length in block $id";
  }
  return $length;
}

sub _read_block {
  my ( $class, $string, $id, ) = @_;
  my $type   = $class->_read_block_type($string);
  my $length = $class->_read_block_length($string);
  my $block_body;
  my $group;
  my $label;
  if ( $length > 0 ) {
    $block_body = $class->_read_bytes( $string, $length );
    $group      = $class->_read_block_group( \$block_body );
    $label      = $class->_read_block_label( \$block_body );
  }

  if ( $BLOCK_GROUP_END eq $type ) {
    return $class->_read_group_end( $group, $label, );
  }
  if ( $BLOCK_GROUP_START eq $type ) {
    return $class->_read_group_start( $group, $label, );
  }
  if ( $BLOCK_COLOR eq $type ) {
    return $class->_read_color( $id, $group, $label, \$block_body, );
  }
  die "Unknown type $type";

}

1;

__END__