File Coverage

blib/lib/PostScript/DecodeGlyphName.pm

Criterion	Covered	Total	%
statement	22	40	55.0
branch	6	12	50.0
condition			n/a
subroutine	7	13	53.8
pod	2	2	100.0
total	37	67	55.2

use 5.008001; use strict; use warnings;

package PostScript::DecodeGlyphName;

our $VERSION = '0.002';

use Exporter::Tidy all => [qw( decode_glyph parse_adobeglyphlist )];

sub _croak { require Carp; goto &Carp::croak }

sub _utf8ify { no warnings 'utf8'; map { pack "U", hex } @_ }

my $uni_notation = qr{
	\A uni
	(
		(?:
			[0-9ABCEF] [\dA-F] {3}
			|
			D [0-7] [\dA-F] {2}
		)+
	)
	\z
}x;

# this is a sexeger
my $u_notation = qr{
	\A
	(
		[\dA-F] {2}
		(?:
			[0-7] D 0? 0?
			|
			[\dA-F] [\dABCEF] [\dA-F] {0,2}
		)
	)
	u \z
}x;

my %agl;

sub decode_glyph {
	my $digits;
	return join '', map {
		exists $agl{ $_ }
			? $agl{ $_ }
			: ( ( $digits ) =            m/$uni_notation/ ) ? _utf8ify $digits =~ /(....)/g
			: ( ( $digits ) = reverse =~ m/$u_notation/   ) ? _utf8ify scalar reverse $digits
			: '';
	}
	map { split /_/ }
	map { /\A(.+?)\./ ? $1 : $_ }
	map { split } @_;
}

sub parse_adobeglyphlist {
	my ( $input_method, $data ) = @_;

	my %reader = (
		array => sub { $_[0] },
		data  => sub { [ split /^/m, shift ] },
		fh    => sub { [ <$_[0]> ] },
		file  => sub {
			open my $fh, '<', $_[0]
				or _croak( "Error opening $_[0]: $!" );
			[ <$fh> ];
		},
	);

	_croak( "No such input type '$input_method'" )
		unless exists $reader{ $input_method };

	my $lines = $reader{ $input_method }->( $data );

	@$lines = grep !/\A \s* (?: \# | \z)/x, @$lines;

	chomp @$lines;

	%agl = map {
		my ( $code_pt, $glyph ) = split /;/;
		( $glyph => _utf8ify $code_pt );
	} @$lines;

	delete $agl{ '.notdef' };

	return 1;
}

1;

__END__