source: A2P/a2p/AFPDS/PTCA.pm

Last change on this file was 3, checked in by guillaume, 17 years ago
  • AUTHORS: Ajout des différents contributeurs
  • COPYING: Ajout de la licence GPL v3
  • a2p: Préparation des sources pour leur publication sous GPL
  • Property svn:keywords set to Id
File size: 8.7 KB
Line 
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
25package AFPDS::PTCA;
26
27use strict;
28use Encode 'from_to';
29use A2P::Globals ;
30use A2P::Syslog;
31use A2P::Tools qw(debugbuffer compute);
32use A2P::Common qw(validate);
33
34BEGIN {
35    our $VERSION = sprintf "%s", q$Rev: 986 $ =~ /(\d[0-9.]+)\s+/ ;
36}
37our $VERSION ;
38
39# Doc ref. from 'Data Stream and Object Architectures -
40# Presentation Text Object Content Architecture Reference.pdf'
41my %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
52my @keys = keys( %command );
53foreach my $key ( @keys ) {
54    $command{$key+0x100} = eval '\&' . $command{$key} ;
55}
56
57sub 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
69sub 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
98sub 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
142sub 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
166sub 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
190sub 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
197sub 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
204sub 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
211sub 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
218sub getFont {
219    my $self = shift ;
220    return $self->{FONT} ;
221}
222
223sub 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
242sub 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
254sub 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
269sub 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
2851;
Note: See TracBrowser for help on using the repository browser.