1 | # |
---|
2 | # Copyright (c) 2004-2007 - Consultas, PKG.fr |
---|
3 | # |
---|
4 | # This file is part of A2P. |
---|
5 | # |
---|
6 | # A2P is free software; you can redistribute it and/or modify |
---|
7 | # it under the terms of the GNU General Public License as published by |
---|
8 | # the Free Software Foundation; either version 2 of the License, or |
---|
9 | # (at your option) any later version. |
---|
10 | # |
---|
11 | # A2P is distributed in the hope that it will be useful, |
---|
12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | # GNU General Public License for more details. |
---|
15 | # |
---|
16 | # You should have received a copy of the GNU General Public License |
---|
17 | # along with A2P; if not, write to the Free Software |
---|
18 | # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA |
---|
19 | # |
---|
20 | # $Id: PTCA.pm 3 2007-10-18 16:20:19Z guillaume $ |
---|
21 | # |
---|
22 | # Class to implement print object |
---|
23 | # |
---|
24 | |
---|
25 | package AFPDS::PTCA; |
---|
26 | |
---|
27 | use strict; |
---|
28 | use Encode 'from_to'; |
---|
29 | use A2P::Globals ; |
---|
30 | use A2P::Syslog; |
---|
31 | use A2P::Tools qw(debugbuffer compute); |
---|
32 | use A2P::Common qw(validate); |
---|
33 | |
---|
34 | BEGIN { |
---|
35 | our $VERSION = sprintf "%s", q$Rev: 986 $ =~ /(\d[0-9.]+)\s+/ ; |
---|
36 | } |
---|
37 | our $VERSION ; |
---|
38 | |
---|
39 | # Doc ref. from 'Data Stream and Object Architectures - |
---|
40 | # Presentation Text Object Content Architecture Reference.pdf' |
---|
41 | my %command = ( |
---|
42 | 0xE6 => 'DBR' , # Draw B-axis Rule, p. 58 |
---|
43 | 0xE4 => 'DIR' , # Draw I-axis Rule, p. 60 |
---|
44 | 0xD2 => 'AMB' , # Absolute Move Baseline, p. 51 |
---|
45 | 0xD4 => 'RMB' , # Relative Move Baseline, p. 69 |
---|
46 | 0xC6 => 'AMI' , # Absolute Move Inline, p. 53 |
---|
47 | 0xC8 => 'RMI' , # Relative Move Inline, p. 71 |
---|
48 | 0xF0 => 'SCFL', # Set Coded Font Local, p. 77 |
---|
49 | ); |
---|
50 | |
---|
51 | # Update table to avoid eval compilation at runtime |
---|
52 | my @keys = keys( %command ); |
---|
53 | foreach my $key ( @keys ) { |
---|
54 | $command{$key+0x100} = eval '\&' . $command{$key} ; |
---|
55 | } |
---|
56 | |
---|
57 | sub new { |
---|
58 | &Debug("new AFPDS::PTCA v$VERSION"); |
---|
59 | my $class = shift ; |
---|
60 | |
---|
61 | my $self = { |
---|
62 | BUFFER => shift, |
---|
63 | FONT => "" |
---|
64 | }; |
---|
65 | |
---|
66 | return bless $self , $class ; |
---|
67 | } |
---|
68 | |
---|
69 | sub isValid { |
---|
70 | my $self = shift ; |
---|
71 | # Return validity cached value |
---|
72 | return $self->{VALIDITY} if (defined($self->{VALIDITY})); |
---|
73 | |
---|
74 | my $check = &compute( \$self->{BUFFER} , 0 , 1 ); |
---|
75 | # PTX prefix+class pair = 0x2BD3 |
---|
76 | if ( $check != 0x2B or length( $self->{BUFFER} ) < 1 ) { |
---|
77 | # Skip not used PTX |
---|
78 | if ( length( $self->{BUFFER} ) == 0 or |
---|
79 | ( $check == 0 and length( $self->{BUFFER} ) == 1 )) { |
---|
80 | &Debug("PTX field seems not used"); |
---|
81 | return $self->{VALIDITY} = -1 ; |
---|
82 | |
---|
83 | } else { |
---|
84 | &Warn("PTX Field is badly formated (should begin with 0x2B)"); |
---|
85 | } |
---|
86 | return $self->{VALIDITY} = 0 ; |
---|
87 | } |
---|
88 | |
---|
89 | $check = &compute( \$self->{BUFFER} , 1 , 1 ); |
---|
90 | if ( $check != 0xD3 ) {# PTX prefix+class pair |
---|
91 | &Error("PTX Field is badly formated (should begin with 0x2BD3)"); |
---|
92 | return $self->{VALIDITY} = 0 ; |
---|
93 | } |
---|
94 | |
---|
95 | return $self->{VALIDITY} = 1 ; |
---|
96 | } |
---|
97 | |
---|
98 | sub getTex { |
---|
99 | my $self = shift ; |
---|
100 | my $TeXCode = "\\PAGEPUT{\\XX}{\\YY}{\\xCP=0pt\\yCP=0pt% PTCA Object\n" ; |
---|
101 | |
---|
102 | my $cmdlong = 1 ; |
---|
103 | my $text = 0 ; |
---|
104 | for ( my $i = 2 ; $i < length( $self->{BUFFER} ) ; $i += $cmdlong ) { |
---|
105 | if ( $text ) { |
---|
106 | my $j ; |
---|
107 | # Found the next operation as end of text |
---|
108 | for ( $j = $i ; $j < length( $self->{BUFFER} ) ; $j ++ ) { |
---|
109 | last if ( &compute( \$self->{BUFFER} , $j , 2 ) == 0x2BD3 ) ; |
---|
110 | } |
---|
111 | $cmdlong = $j - $i ; |
---|
112 | my $buffer = substr( $self->{BUFFER} , $i , $cmdlong ) ; |
---|
113 | &debugbuffer( $buffer ); |
---|
114 | &from_to( $buffer , $FROM_CONVERT , $TO_CONVERT ) if ($DO_CONVERT); |
---|
115 | # Second argument is used to disable space stripping in &validate |
---|
116 | &validate( \$buffer , 1 ); |
---|
117 | &Debug("Got text '$buffer'"); |
---|
118 | $TeXCode .= "\\PTCATEXT{$buffer}%\n" ; |
---|
119 | $cmdlong += 2 ; # To skip the prefix+class pair |
---|
120 | $text = 0 ; |
---|
121 | next ; |
---|
122 | } |
---|
123 | $cmdlong = &compute( \$self->{BUFFER} , $i , 1 ); |
---|
124 | my $type = &compute( \$self->{BUFFER} , $i+1 , 1 ); |
---|
125 | if ( defined($command{$type & 0xFE})) { |
---|
126 | my $Type = $type & 0xFE ; |
---|
127 | &Debug("Got command type $command{$Type} with length $cmdlong"); |
---|
128 | $TeXCode .= $command{$Type + 0x100}( $self, $i+2, $cmdlong); |
---|
129 | $TeXCode .= "%\tis PTCA $command{$Type}\n" ; |
---|
130 | } else { |
---|
131 | &Warn(sprintf( |
---|
132 | "Got unsupported PTCA command type 0x%02X with length %d", |
---|
133 | $type, $cmdlong )); |
---|
134 | } |
---|
135 | # End of command: Maybe some text is comming |
---|
136 | $text = 1 if ($type & 1) == 0 ; |
---|
137 | } |
---|
138 | |
---|
139 | return $TeXCode . "}%" ; |
---|
140 | } |
---|
141 | |
---|
142 | sub DBR { |
---|
143 | my ( $self , $k , $long ) = @_ ; |
---|
144 | my $rlength = $self->getlen( $k ) ; |
---|
145 | my $rwidth = 1 ; |
---|
146 | if ( $long == 7 ) { |
---|
147 | $rwidth = $self->getlen( $k + 2 ) ; |
---|
148 | $rwidth /= 2 ^ &compute( \$self->{BUFFER} , $k+4 , 1 ); |
---|
149 | } |
---|
150 | my $offset = "" ; |
---|
151 | my $correction = "\\advance\\xCP by" . $self->PELS( abs($rwidth) ) ; |
---|
152 | if ( $rlength < 0 ) { |
---|
153 | $rlength = abs($rlength) ; |
---|
154 | $offset .= "\\advance\\yCP by-" . $self->PELS( $rlength ) . "%\n" ; |
---|
155 | $correction .= "\\advance\\yCP by" . $self->PELS( abs($rlength) ) ; |
---|
156 | } |
---|
157 | if ( $rwidth < 0 ) { |
---|
158 | $rwidth = abs($rwidth) ; |
---|
159 | $offset .= "\\advance\\xCP by-" . $self->PELS( $rwidth ) . "%\n" ; |
---|
160 | } |
---|
161 | &Debug("Draw B-axis Rule with length $rlength PELS and width $rwidth PELS"); |
---|
162 | return $offset . "\\PTCAPUT{\\vrule height" . $self->PELS( $rlength ) |
---|
163 | . " depth0pt width" . $self->PELS( $rwidth ) . "}" . $correction ; |
---|
164 | } |
---|
165 | |
---|
166 | sub DIR { |
---|
167 | my ( $self , $k , $long ) = @_ ; |
---|
168 | my $rlength = $self->getlen( $k ) ; |
---|
169 | my $rwidth = 1 ; |
---|
170 | if ( $long == 7 ) { |
---|
171 | $rwidth = $self->getlen( $k + 2 ) ; |
---|
172 | $rwidth /= 2 ^ &compute( \$self->{BUFFER} , $k+4 , 1 ); |
---|
173 | } |
---|
174 | my $offset = "" ; |
---|
175 | my $correction = "\\advance\\yCP by" . $self->PELS( abs($rwidth) ) ; |
---|
176 | if ( $rlength < 0 ) { |
---|
177 | $rlength = abs($rlength) ; |
---|
178 | $offset .= "\\advance\\xCP by-" . $self->PELS( $rlength ) . "%\n" ; |
---|
179 | $correction .= "\\advance\\xCP by" . $self->PELS( $rlength ) ; |
---|
180 | } |
---|
181 | if ( $rwidth < 0 ) { |
---|
182 | $rwidth = abs($rwidth) ; |
---|
183 | $offset .= "\\advance\\yCP by-" . $self->PELS( $rwidth ) . "%\n" ; |
---|
184 | } |
---|
185 | &Debug("Draw I-axis Rule with length $rlength PELS and width $rwidth PELS"); |
---|
186 | return $offset . "\\PTCAPUT{\\vrule height" . $self->PELS( $rwidth ) |
---|
187 | . " depth0pt width" . $self->PELS( $rlength ) . "}" . $correction ; |
---|
188 | } |
---|
189 | |
---|
190 | sub AMB { |
---|
191 | my ( $self , $k , $long ) = @_ ; |
---|
192 | my $pos = $self->getlen( $k ) ; |
---|
193 | &Debug("Set position along B-axis to $pos PELS"); |
---|
194 | return "\\yCP=" . $self->PELS( $pos ) ; |
---|
195 | } |
---|
196 | |
---|
197 | sub RMB { |
---|
198 | my ( $self , $k , $long ) = @_ ; |
---|
199 | my $move = $self->getlen( $k ) ; |
---|
200 | &Debug("Move along B-axis for $move PELS"); |
---|
201 | return "\\advance\\yCP by" . $self->PELS( $move ) ; |
---|
202 | } |
---|
203 | |
---|
204 | sub AMI { |
---|
205 | my ( $self , $k , $long ) = @_ ; |
---|
206 | my $pos = $self->getlen( $k ) ; |
---|
207 | &Debug("Set position along I-axis to $pos PELS"); |
---|
208 | return "\\xCP=" . $self->PELS( $pos ) ; |
---|
209 | } |
---|
210 | |
---|
211 | sub RMI { |
---|
212 | my ( $self , $k , $long ) = @_ ; |
---|
213 | my $move = $self->getlen( $k ) ; |
---|
214 | &Debug("Move along I-axis for $move PELS"); |
---|
215 | return "\\advance\\xCP by" . $self->PELS( $move ) ; |
---|
216 | } |
---|
217 | |
---|
218 | sub getFont { |
---|
219 | my $self = shift ; |
---|
220 | return $self->{FONT} ; |
---|
221 | } |
---|
222 | |
---|
223 | sub SCFL { |
---|
224 | my ( $self , $k , $long ) = @_ ; |
---|
225 | my $FontRef = "" ; |
---|
226 | my $font = &compute( \$self->{BUFFER} , $k , 1 ) ; |
---|
227 | |
---|
228 | unless ( -- $font =~ /^\d+$/ ) { |
---|
229 | &Error("Unsupported '$font' SCFL PTCA object"); |
---|
230 | $font = 0 ; |
---|
231 | } |
---|
232 | |
---|
233 | for ( split( // , $font ) ) { |
---|
234 | $FontRef .= chr( 65 + $_ ) ; |
---|
235 | } |
---|
236 | |
---|
237 | &Debug("PTCA SCFL selects font TRC '$FontRef'"); |
---|
238 | |
---|
239 | return $self->{FONT} = "\\FONtTrc" . $FontRef ; |
---|
240 | } |
---|
241 | |
---|
242 | sub PELS { |
---|
243 | my ( $self , $PELS ) = @_ ; |
---|
244 | # PEL size: 0.501875 for 72.27/144, 0.301125 for 72.27/240, 0.3 for 72/240 |
---|
245 | my $pt_by_PELS = 0.301125 ; # units = pt/pels |
---|
246 | my $P = 6 ; # Precision: how many numbers after point |
---|
247 | my $value = sprintf("%.${P}f" , $PELS * $pt_by_PELS ); |
---|
248 | $value =~ s/.0{$P}$// ; |
---|
249 | $value =~ s/0+$// if ( $value != 0 ); |
---|
250 | &Debug("${PELS} PELS converted to ${value} pt"); |
---|
251 | return $value . "pt" ; |
---|
252 | } |
---|
253 | |
---|
254 | sub getlen { |
---|
255 | my ( $self , $index ) = @_ ; |
---|
256 | my ( $first , $second ) = ( |
---|
257 | ord( substr($self->{BUFFER} , $index , 1 )) , |
---|
258 | ord( substr($self->{BUFFER} , $index + 1 , 1 )) |
---|
259 | ); |
---|
260 | |
---|
261 | my $len = $first * 256 + $second; |
---|
262 | |
---|
263 | $len -= 0x10000 if ( $len > 0x7FFF ); # This is a signed number |
---|
264 | &Debug(sprintf("Len %X%X converted to $len",$first,$second)); |
---|
265 | |
---|
266 | return $len ; |
---|
267 | } |
---|
268 | |
---|
269 | sub DESTROY { |
---|
270 | my $self = shift; |
---|
271 | my $err = shift; |
---|
272 | |
---|
273 | # Free arrays memory |
---|
274 | map { $self->{$_} = () if (ref($self->{$_}) eq 'ARRAY' ) } keys(%{$self}); |
---|
275 | |
---|
276 | if (defined($err)) { |
---|
277 | &Error("PTCA object $self->{OUTFILE} destroyed with error #" . $err); |
---|
278 | } else { |
---|
279 | &Debug("PTCA object $self->{OUTFILE} destroyed"); |
---|
280 | } |
---|
281 | } |
---|
282 | |
---|
283 | &Debug("Module " . __PACKAGE__ . " v$VERSION loaded"); |
---|
284 | |
---|
285 | 1; |
---|