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 2     2   858 use strict;
  2         5  
  2         68  
3 2     2   10 use warnings;
  2         5  
  2         57  
4 2     2   20 use Exporter 'import';
  2         4  
  2         751  
5              
6             require TeX::DVI::Parse;
7              
8             $TeX::XDV::Parse::VERSION = '0.02';
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 2     2   12 use constant XDV_FLAG_FONTTYPE_ATSUI => 0x0001;
  2         2  
  2         117  
41 2     2   9 use constant XDV_FLAG_FONTTYPE_ICU => 0x0002;
  2         3  
  2         84  
42 2     2   9 use constant XDV_FLAG_VERTICAL => 0x0100;
  2         3  
  2         71  
43 2     2   8 use constant XDV_FLAG_COLORED => 0x0200;
  2         3  
  2         77  
44 2     2   9 use constant XDV_FLAG_FEATURES => 0x0400;
  2         3  
  2         77  
45 2     2   9 use constant XDV_FLAG_VARIATIONS => 0x0800;
  2         3  
  2         100  
46 2     2   10 use constant XDV_FLAG_EXTEND => 0x1000;
  2         2  
  2         86  
47 2     2   17 use constant XDV_FLAG_SLANT => 0x2000;
  2         4  
  2         97  
48 2     2   10 use constant XDV_FLAG_EMBOLDEN => 0x4000;
  2         2  
  2         1823  
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             sub make_glyph_thingy {
70 5     5 0 11 my $is_array = shift;
71 5         10 my $buff = pop @_;
72              
73             # width, count
74 5         31 my @list =
75             unpack "lna*",
76             pack "Lna*",
77             unpack "Nna*",
78             $buff;
79 5         12 $buff = pop @list;
80              
81             # locations, glyphs
82 5         7 my $c = $list[-1];
83 5 50       12 my $z = $is_array ? $c<<1 : $c;
84 5         50 push @list,
85             unpack "l${z}n${c}a*",
86             pack "L${z}n${c}a*",
87             unpack "N${z}n${c}a*",
88             $buff;
89 5         12 $buff = pop @list;
90              
91 5         44 return @_, @list, $buff;
92             }
93              
94 5     5 0 477 sub make_glyph_string { make_glyph_thingy( 0, @_ ) }
95 0     0 0 0 sub make_glyph_array { make_glyph_thingy( 1, @_ ) }
96              
97             sub make_pic_file {
98 3     3 0 674 my $buff = pop @_;
99 3         32 my @list =
100             unpack "CllllllsSa*",
101             pack "CLLLLLLSSa*",
102             unpack "CNNNNNNnna*",
103             $buff;
104 3         8 $buff = pop @list;
105 3         4 my $file;
106 3         14 ($file,$buff) = unpack "A$list[-1]a*", $buff;
107 3         25 return @_, @list, $file , $buff;
108             }
109              
110             sub make_native_font_def {
111 2     2 0 1742 my $buff = pop @_;
112              
113             # font_id, point_size, flags
114 2         21 my @list =
115             unpack "lLna*",
116             pack "LLna*",
117             unpack "NNna*",
118             $buff;
119 2         6 $buff = pop @list;
120              
121 2         5 my $f = $list[-1];
122              
123 2 50 33     37 die "invalid signature"
124             unless $f & XDV_FLAG_FONTTYPE_ICU || $f & XDV_FLAG_FONTTYPE_ATSUI;
125              
126             # plen, flen, slen
127 2         9 push @list, unpack "CCCa*", $buff;
128 2         4 $buff = pop @list;
129              
130             # font_name, family_name, style_name
131 2         14 push @list, unpack "A$list[-3]A$list[-2]A$list[-1]a*", $buff;
132 2         5 $buff = pop @list;
133              
134             # rgba_color
135 2 50       9 if ($f & XDV_FLAG_COLORED) {
136 0         0 push @list, unpack "Na*", $buff;
137 0         0 $buff = pop @list;
138             }
139              
140             # variations
141 2 50       7 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 2 50       5 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 2 50       6 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 2 50       6 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 2         26 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__