File Coverage

blib/lib/TeX/XDV/Parse.pm
Criterion Covered Total %
statement 67 87 77.0
branch 7 16 43.7
condition 1 3 33.3
subroutine 16 19 84.2
pod 2 7 28.5
total 93 132 70.4


line stmt bran cond sub pod time code
1             package TeX::XDV::Parse;
2 3     3   1189 use strict;
  3         6  
  3         127  
3 3     3   16 use warnings;
  3         6  
  3         98  
4 3     3   32 use Exporter 'import';
  3         6  
  3         1547  
5              
6             require TeX::DVI::Parse;
7              
8             $TeX::XDV::Parse::VERSION = '0.04';
9              
10             @TeX::XDV::Parse::ISA = qw/TeX::DVI::Parse/;
11              
12             @TeX::XDV::Parse::EXPORT_OK = qw(
13             XDV_FLAG_FONTTYPE_ATSUI
14             XDV_FLAG_FONTTYPE_ICU
15             XDV_FLAG_VERTICAL
16             XDV_FLAG_COLORED
17             XDV_FLAG_FEATURES
18             XDV_FLAG_VARIATIONS
19             XDV_FLAG_EXTEND
20             XDV_FLAG_SLANT
21             XDV_FLAG_EMBOLDEN
22             );
23              
24             %TeX::XDV::Parse::EXPORT_TAGS = (
25             'constants' => [qw/
26             XDV_FLAG_FONTTYPE_ATSUI
27             XDV_FLAG_FONTTYPE_ICU
28             XDV_FLAG_VERTICAL
29             XDV_FLAG_COLORED
30             XDV_FLAG_FEATURES
31             XDV_FLAG_VARIATIONS
32             XDV_FLAG_EXTEND
33             XDV_FLAG_SLANT
34             XDV_FLAG_EMBOLDEN
35             /],
36             );
37              
38             # from xdvipdfmx
39             # no hash interface before 5.8 for constant
40 3     3   25 use constant XDV_FLAG_FONTTYPE_ATSUI => 0x0001;
  3         5  
  3         284  
41 3     3   15 use constant XDV_FLAG_FONTTYPE_ICU => 0x0002;
  3         4  
  3         138  
42 3     3   13 use constant XDV_FLAG_VERTICAL => 0x0100;
  3         5  
  3         122  
43 3     3   14 use constant XDV_FLAG_COLORED => 0x0200;
  3         5  
  3         132  
44 3     3   14 use constant XDV_FLAG_FEATURES => 0x0400;
  3         5  
  3         123  
45 3     3   12 use constant XDV_FLAG_VARIATIONS => 0x0800;
  3         6  
  3         117  
46 3     3   12 use constant XDV_FLAG_EXTEND => 0x1000;
  3         5  
  3         148  
47 3     3   23 use constant XDV_FLAG_SLANT => 0x2000;
  3         4  
  3         168  
48 3     3   15 use constant XDV_FLAG_EMBOLDEN => 0x4000;
  3         5  
  3         2802  
49              
50             # Hmm.. either way we do this, the dispatcher in DVI::Parse
51             # sees the same thing. Either way, it ends up calling either
52             # DVI's handler or the one here. Since we're not trying to
53             # override anything, it doesn't really matter. The end result
54             # is the same as seen from the superclassing module.
55              
56             #our @COMMANDS;
57             #*COMMANDS = *TeX::DVI::Parse::COMMANDS;
58              
59             push @TeX::DVI::Parse::COMMANDS, (
60             # opcode 250 is still unused, as in TeX::DVI::Parse
61             [ 'pic_file', \&make_pic_file ], # 251
62             [ 'native_font_def', \&make_native_font_def ], # 252
63             [ 'glyph_array', \&make_glyph_array ], # 253
64             [ 'glyph_string', \&make_glyph_string ], # 254
65             [ 'dir', \&dir ], # 255
66             'undefined_command' # 256, not possible
67             );
68              
69 41     41 0 2965 sub make_glyph_string { make_glyph_thingy( 0, @_ ) }
70 0     0 0 0 sub make_glyph_array { make_glyph_thingy( 1, @_ ) }
71              
72             sub make_glyph_thingy {
73 41     41 0 58 my $is_array = shift;
74 41         47 my $buff = pop @_;
75              
76             # width, count
77 41         294 my @list =
78             unpack "lna*",
79             pack "Lna*",
80             unpack "Nna*",
81             $buff;
82 41         76 $buff = pop @list;
83              
84             # locations, glyphs
85 41         50 my $c = $list[-1];
86 41 50       74 my $z = $is_array ? $c<<1 : $c;
87 41         329 push @list,
88             unpack "l${z}n${c}a*",
89             pack "L${z}n${c}a*",
90             unpack "N${z}n${c}a*",
91             $buff;
92 41         77 $buff = pop @list;
93              
94 41         253 return @_, @list, $buff;
95             }
96              
97             sub make_pic_file {
98 3     3 0 530 my $buff = pop @_;
99 3         28 my @list =
100             unpack "CllllllsSa*",
101             pack "CLLLLLLSSa*",
102             unpack "CNNNNNNnna*",
103             $buff;
104 3         6 $buff = pop @list;
105 3         4 my $file;
106 3         11 ($file,$buff) = unpack "A$list[-1]a*", $buff;
107 3         20 return @_, @list, $file , $buff;
108             }
109              
110             sub make_native_font_def {
111 4     4 0 4966 my $buff = pop @_;
112              
113             # font_id, point_size, flags
114 4         53 my @list =
115             unpack "lLna*",
116             pack "LLna*",
117             unpack "NNna*",
118             $buff;
119 4         10 $buff = pop @list;
120              
121 4         8 my $f = $list[-1];
122              
123 4 50 33     65 die "invalid signature"
124             unless $f & XDV_FLAG_FONTTYPE_ICU || $f & XDV_FLAG_FONTTYPE_ATSUI;
125              
126             # plen, flen, slen
127 4         17 push @list, unpack "CCCa*", $buff;
128 4         7 $buff = pop @list;
129              
130             # font_name, family_name, style_name
131 4         26 push @list, unpack "A$list[-3]A$list[-2]A$list[-1]a*", $buff;
132 4         7 $buff = pop @list;
133              
134             # rgba_color
135 4 50       17 if ($f & XDV_FLAG_COLORED) {
136 0         0 push @list, unpack "Na*", $buff;
137 0         0 $buff = pop @list;
138             }
139              
140             # variations
141 4 50       13 if ($f & XDV_FLAG_VARIATIONS) {
142 0         0 push @list, unpack "na*", $buff;
143 0         0 $buff = pop @list;
144 0         0 my $n = $list[-1];
145 0         0 push @list,
146             unpack "l${n}N${n}a*", # need to make sure first is signed
147             pack "L${n}N${n}a*",
148             unpack "N${n}N${n}a*",
149             $buff;
150 0         0 $buff = pop @list;
151             }
152              
153             # extend ?
154 4 50       12 if ($f & XDV_FLAG_EXTEND) {
155 0         0 push @list,
156             unpack "la*",
157             pack "La*",
158             unpack "Na*",
159             $buff;
160 0         0 $buff = pop @list;
161             }
162              
163             # slant ?
164 4 50       12 if ($f & XDV_FLAG_SLANT) {
165 0         0 push @list,
166             unpack "la*",
167             pack "La*",
168             unpack "Na*",
169             $buff;
170 0         0 $buff = pop @list;
171             }
172              
173             # bold ?
174 4 50       10 if ($f & XDV_FLAG_EMBOLDEN) {
175 0         0 push @list,
176             unpack "la*",
177             pack "La*",
178             unpack "Na*",
179             $buff;
180 0         0 $buff = pop @list;
181             }
182              
183 4         43 return @_, @list, $buff;
184             }
185              
186             sub dir {
187 0     0 1   my $buff = pop @_;
188 0           my @list = unpack "Ca*", $buff;
189 0           $buff = pop @list;
190 0 0         $list[-1] = $list[-1] ? 1 : 0; # 0=horizontal 1=vertical
191 0           return @_, @list, $buff;
192             }
193              
194             sub undefined_command {
195 0     0 1   die "undefined_command: @_\n";
196             }
197              
198             1;
199              
200             __END__