source: A2P/a2p/AFPDS/MODCA/IOB.pm @ 15

Last change on this file since 15 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: 15.1 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: IOB.pm 3 2007-10-18 16:20:19Z guillaume $
21#
22# Class to export Include Object members
23#
24# cf ref #1, p. 92 & ref #2, p. 180
25#
26
27package AFPDS::MODCA::IOB ;
28
29use strict ;
30use GD ;
31use A2P::Globals ;
32use A2P::Syslog ;
33use AFPDS::MODCA::Common ;
34
35BEGIN {
36    our $VERSION = sprintf "%s", q$Rev: 1172 $ =~ /([0-9.]+)\s+/ ;
37}
38our $VERSION ;
39our @ISA = ("AFPDS::MODCA");
40our $IDENTS ;
41
42sub _ID { 0xD3AFC3 }
43
44sub _supported_triplets {
45    return [], [
46            0x10, # Mandatory object classification only if object type is 0x92
47            0x4B, # Measurement units mandatory if coordinates are overrided
48            # 0x01, # Coded charset GID
49            # 0x02, # FQN
50            # 0x04, # Mapping option
51            # 0x4C, # object area size
52            # 0x4E, # color specs
53            # 0x70, # presentation space reset mixing
54            # 0x71, # presentation space mixing rules
55        ];
56}
57
58sub new {
59    my $class = shift ;
60    &Debug("new " . __PACKAGE__ . " v$VERSION object");
61
62    my $self = {
63        FLUX     => 0,        # Associated flux
64        IDENT    => _ID,      # MO:DCA identity
65        FLAG     => 0,        # MO:DCA flags
66        RESERVED => 0,        # MO:DCA reserved
67        LONG     => 0,        # MO:DCA buffer length
68        BUFFER   => ''        # MO:DCA content buffer
69    };
70
71    return bless $self , $class ;
72}
73
74sub validate {
75    my $self = shift ;
76
77    &Debug("Found IOB to include object");
78    &UPSTAT('GET-RESOURCE-INCLUSION');
79
80    # Check minimal buffer size
81    return ( 251, "IOB is malformed as too short (" . $self->{LONG} . "<28)" )
82        if ( $self->{LONG} < 28 );
83
84    # Check FLUX is a Flux object
85    return ( 251, "IOB needs to be used with Flux object" )
86        unless ( ref($self->{FLUX}) =~ /^AFPDS::Flux$/ );
87
88    return () ;
89}
90
91sub create {
92    my $self = shift ;
93
94    # Set resource name
95    my $resname = substr( $self->{BUFFER}, 0, 8 );
96    $resname = $self->convert( $resname );
97    return ( 252, "Invalid resource name found" ) unless $resname ;
98
99    # Set resource name as member as it can be later overrided by X'02' triplet
100    $self->name( $resname );
101
102    # Extract values
103    my $zero     = $self->get_from_buffer(  8, 1 );
104    my $ObjType  = $self->get_from_buffer(  9, 1 );
105    my $XoaOset  = $self->get_from_buffer( 10, 3 );
106    my $YoaOset  = $self->get_from_buffer( 13, 3 );
107    my $XoaOrent = $self->get_from_buffer( 16, 2 );
108    my $YoaOrent = $self->get_from_buffer( 18, 2 );
109    my $XocaOset = $self->get_from_buffer( 20, 3 );
110    my $YocaOset = $self->get_from_buffer( 23, 3 );
111    my $RefCSys  = $self->get_from_buffer( 26, 1 );
112
113    # Analyse offsets
114    unless ( $XoaOset == 0xFFFFFF ) {
115        # This is a signed number
116        $XoaOset -= 0x1000000 if ( $XoaOset > 0x7FFFFF );
117
118        # Check and set X off-set
119        return ( 252, "Found bad IOB XoaOset ($XoaOset)" )
120            if ( $XoaOset < -32768 or $XoaOset > 32767 );
121    }
122    unless ( $YoaOset == 0xFFFFFF ) {
123        # This is a signed number
124        $YoaOset -= 0x1000000 if ( $YoaOset > 0x7FFFFF );
125
126        # Check and set X off-set
127        return ( 252, "Found bad IOB YoaOset ($YoaOset)" )
128            if ( $YoaOset < -32768 or $YoaOset > 32767 );
129    }
130    unless ( $XocaOset == 0xFFFFFF ) {
131        # This is a signed number
132        $XocaOset -= 0x1000000 if ( $XocaOset > 0x7FFFFF );
133
134        # Check and set X off-set
135        return ( 252, "Found bad IOB XocaOset ($XocaOset)" )
136            if ( $XocaOset < -32768 or $XocaOset > 32767 );
137    }
138    unless ( $YocaOset == 0xFFFFFF ) {
139        # This is a signed number
140        $YocaOset -= 0x1000000 if ( $YocaOset > 0x7FFFFF );
141
142        # Check and set X off-set
143        return ( 252, "Found bad IOB YocaOset ($YocaOset)" )
144            if ( $YocaOset < -32768 or $YocaOset > 32767 );
145    }
146
147    # Check invalid values
148    return ( 252, "Invalid reserved value in IOB ($zero)" )
149        if ( $zero );
150    return ( 252, "Invalid object type in IOB ($ObjType)" )
151        unless ( $ObjType == 0x92 or $ObjType == 0x5F or $ObjType == 0xBB
152        or $ObjType == 0xEB or $ObjType == 0xFB );
153
154    # Check supported orientation
155    return ( 252, "Unsupported orientation found in IOB ($XoaOrent;$YoaOrent)" )
156        unless ( $XoaOrent == 0x0000 and $YoaOrent == 0x2D00 );
157
158    # Check supported system reference
159    return ( 252, "Unsupported RefCSys found in IOB ($RefCSys)" )
160        unless ( $RefCSys == 0x01 );
161
162    # Analyse now authorized triplets as it is mandatory
163    my @err = $self->check_triplets(substr( $self->{BUFFER}, 27 ));
164    return @err if @err ;
165
166    # Set a default resolution if not set
167    $self->{RESOLUTION} = 240 unless (exists($self->{RESOLUTION}));
168
169    # Get current resolution
170    my $reso = $self->{RESOLUTION} ;
171
172    # Update resname if update by triplet X'02', and set it with resolution
173    $resname = $self->name ;
174
175    # Check container is opened in flux
176    my $flux = $self->{FLUX} ;
177    my $container = $flux->get_resource($resname);
178    return ( 252, "Resource '$resname' not available" )
179        unless ( $container and ref($container) =~ /^AFPDS::MODCA/ );
180
181    # Validate the expected structure of BOC
182    my $struct = $container->{STRUCT} || 0 ;
183    return ( 253, "Unexpected '$struct' structure found for BOC object" )
184        unless ( $struct == 0xDC00 );
185
186    # Validate the expected structure of ourself
187    $struct = $self->{STRUCT} || 0 ;
188    return ( 253, "Unexpected '$struct' structure found for IOB object" )
189        unless ( $struct == 0xA800 );
190
191    if ( $ObjType == 0x92 ) {
192        return ( 252, "No OID found in object container for IOB" )
193            unless ( exists($container->{OID}) and $container->{OID} );
194
195        # Check triplet X'10' has been set as mandatory here and match container
196        return ( 252, "No OID found in object inclusion with IOB" )
197            unless ( exists($self->{OID}) and $self->{OID} );
198        return ( 253, "OID included is different from container" )
199            unless ( $container->{OID} eq $self->{OID} );
200
201        # Check specified class in triplet X'10'
202        my $class = $self->{CLASS} || 0 ;
203        return ( 253, "Unexpected '$class' class found for IOB object" )
204            unless ( $class == 0x01 );
205
206        # Check origins are not set for the object
207        return ( 253, "Origin offset not allowed for this IOB object" )
208            if ( $XocaOset or $YocaOset );
209
210        # Reset to default offsets for the object if not set
211        $XoaOset = 0 if ( $XoaOset == 0xFFFFFF );
212        $YoaOset = 0 if ( $YoaOset == 0xFFFFFF );
213
214        # OID is validated, now we only need to handle supported format
215
216        # Get eventually still converted image
217        my $teximage = $container->teximage( $reso ) ;
218
219        # Cancel convertion if image is still converted
220        unless ( $teximage ) {
221            &Debug("Converting $resname resource from $self->{FORMAT} format");
222
223            return ( 254, "Can't process empty $self->{FORMAT} for $resname" )
224                unless ( defined($container->{RESOURCE_BUFFER})
225                and length($container->{RESOURCE_BUFFER}) > 0 );
226
227            my $image = $self->get_image( \$container->{RESOURCE_BUFFER} );
228
229            return ( 254, "Unsupported $self->{FORMAT} format for $resname" )
230                unless ( defined($image) );
231
232            return ( 254, "Can't convert $resname resource" )
233                unless ( $image );
234
235            # Get the TeX name for the inclusion directive
236            my $texname = $flux->resource_texname($resname);
237            return ( 254, "TeX compatible name not set for $resname resource" )
238                unless ( defined($texname) and $texname );
239
240            # Tag texname with resolution
241            my $tag = $reso ;
242            $tag =~ y/0-9/A-J/ ;
243            $texname .= 'at' . $tag ;
244
245            # Get the resource number for the PCL inclusion macro
246            my $number = $flux->resource_number( $resname, $reso ) ;
247            return ( 254, "PCL number not set for $resname resource" )
248                unless ( defined($number) );
249            return ( 254, "Bad $number PCL number for $resname resource" )
250                unless ( $number > -1 and $number < 32768 );
251
252            # Convert image for TeX/LaTeX inclusion
253            $teximage = $self->convert_image( $texname, $image,
254                \$container->{RESOURCE_BUFFER}, $number, $reso );
255            return ( 254, "Can't convert $resname resource for TeX/LaTeX" )
256                unless ( defined($teximage) and $teximage and @{$teximage} );
257
258            # Insert TeX/LaTeX directive definitions to allow inclusion
259            $flux->addline( '{%', @{$teximage}, '}%' ) ;
260
261            # Keep converted image inclusion in container
262            $teximage = $container->teximage( $reso, $texname );
263        }
264
265        # Prepare array of Tex/LaTeX lines
266        my @texlines = ( "{% $teximage inclusion as $resname at $reso dpi" ) ;
267
268        # TODO Offset should be absolute in the AFP standard
269        push @texlines,
270            "\\PAGEPUT{\\XX\\kern$XoaOset\\Xunit}{\\YY\\kern$YoaOset\\Yunit}{" .
271            "\\$teximage}%",
272            "}%" ;
273
274        # Add TeX/LaTeX code to flux for the inclusion
275        $flux->addline(@texlines) ;
276
277    } elsif ( $ObjType == 0x5F ) {
278        return ( 252, "Unsupported Page Segment ObjType found in IOB" );
279
280    } elsif ( $ObjType == 0xBB ) {
281        return ( 252, "Unsupported GOCA Graphics ObjType found in IOB" );
282
283    } elsif ( $ObjType == 0xEB ) {
284        return ( 252, "Unsupported BCOCA Bar Code ObjType found in IOB" );
285
286    } elsif ( $ObjType == 0xFB ) {
287        return ( 252, "Unsupported IOCA Image ObjType found in IOB" );
288
289    } else {
290        return ( 252, "Unsupported ObjType found in IOB ($ObjType)" );
291    }
292
293    return () ;
294}
295
296sub get_image {
297    my $self = shift ;
298    return 0 unless ( exists($self->{FORMAT}) and $self->{FORMAT} );
299
300    my $dataref = shift ;
301    return 0 unless ( defined($dataref) and $dataref );
302
303    if ( $self->{FORMAT} eq 'GIF' ) {
304         return GD::Image->newFromGifData( $$dataref );
305    }
306
307    # No supported format
308    return undef ;
309}
310
311###################### Image convertion to TeX/LaTeX inclusion code
312sub convert_image {
313    my $self = shift ;
314    # We must be called with 4 defined arguments
315    return undef unless ( map { defined($_) and $_ } @_[0..3] == 4 );
316    my $name = shift ;
317    my $image = shift ;
318    my $gifref = shift ;
319    my $number = shift ;
320    my $reso = shift ;
321
322    my ( $width , $height ) = ( $image->width, $image->height );
323
324    # Open TeX/LaTeX global directive declaration with given name
325    my @lines = (
326        "\\global\\def\\" . $name . "{% as " . $self->name . " at $reso dpi"
327        ) ;
328
329    # In case of PDF, we could prepare the resource as PNG image to include
330    my $flux = $self->{FLUX} ;
331    my $pdf = $flux->getEnv('DO_PDF') =~ /^yes$/i ? 1 : 0 ;
332    if ( $pdf ) {
333        # Get the image as PNG with compression
334        my $png = $image->png($PNGCOMPRESSION);
335
336        # Create the PNG file
337        my ( $pngname ) = $flux->getoutbase =~ m|^(.*)/[^/]+$| ;
338        $pngname .= '/' . $name . '.png' ;
339
340        # Add PNG image to resource to clean
341        $flux->toclean( $pngname );
342
343        unless ( open PNG, '>', $pngname ) {
344            &Error("Can't open file $pngname for writing: $!");
345            return 0 ;
346        }
347        binmode(PNG);
348        print PNG $png ;
349        close(PNG);
350
351        # Insert TeX/LaTeX code for PDF image inclusion
352        unshift @lines,
353            "\\ifpdf%",
354            "\\pdfimageresolution" . $reso . "%",
355            "\\pdfximage{$name.png}%",
356            "\\newcount\\ximage$name%",
357            "\\global\\ximage$name=\\pdflastximage%",
358            "\\fi% End pdf inclusion preparation" ;
359
360        # Add TeX/LaTeX for PDF inclusion
361        push @lines,
362            "\\if\\pcloutput0%",
363            "\\ifpdf%",
364            "\\ifx\\ximage$name\\undefined\\else%",
365            "\\message{PNG[" . $self->name . "]}%",
366            "\\pdfrefximage\\ximage$name%",
367            "\\fi\\fi%",
368            "\\else% End pdf case" ;
369    }
370
371    # Handle PCL case
372    my $pcl = $flux->getEnv('DO_PCL') =~ /^yes$/i ? 1 : 0 ;
373    $pcl = $flux->getEnv('DO_VPCL') =~ /^yes$/i ? 1 : 0
374        unless $pcl ;
375
376    if ( $pcl and ! $ONLY_DO_PDF ) {
377        # Create the PCL file
378        my ( $pclname ) = $flux->getoutbase =~ m|^(.*)/[^/]+$| ;
379        $pclname .= '/' . $name . '.pcl' ;
380
381        # Add PCL resource as to be cleaned
382        $flux->toclean( $pclname );
383
384        # Check PCL_RESOLUTION environment with a configuration default
385        my $resolution = $flux->getEnv('PCL_RESOLUTION') || $PCL_RESOLUTION ;
386
387        # Update the width/height resource expected with the defined resolution
388        my $newwidth  = int( $width  * $resolution / $reso ) ;
389        my $newheight = int( $height * $resolution / $reso ) ;
390
391        # Prepare the command to start for PCL resource generation
392        &Debug("Scaling resource from $width to $newwidth in PCL conversion");
393        my $command = sprintf( $GIFTOPCL, $newwidth, $resolution );
394        &Debug("Scaling resource with '$command' command")
395            if $ADVANCED_DEBUGGING ;
396
397        # Finally the PCL flux is output in a file to be included later
398        $command .= " > '$pclname'" ;
399
400        unless ( open PCL, '|' . $command ) {
401            &Error("Can't use '$command' for execution: $!");
402            return 0 ;
403        }
404        print PCL $$gifref ;
405        close(PCL);
406
407        # Insert TeX/LaTeX code for RAW image inclusion
408        unshift @lines,
409            "\\if\\pcloutput1%",
410            # Specify the macro ID to use and start the macro
411            '\\special{pcl5="&f' . $number . 'y0X" ' .
412            # Set the raster resource width/height
413            'pcl5="*r'. $newwidth .'s'. $newheight .'T" ' .
414            "$name.pcl}%", # Include PCL code for the resource
415            '\\special{pcl5="&f1X"}%', # Stop the macro
416            # Set the global TeX/LaTeX definition
417            '\\global\\def\\pclimage' . $name . "{%",
418            '\\special{pcl5="&f0s' . # Store the PCL current position
419            # Specify the macro ID to use, call it and restore the PCL position
420            $number . 'y3x1S"}%',
421            "}\\fi% End pcl inclusion preparation" ;
422
423        # Add TeX/LaTeX for PCL inclusion
424        push @lines,
425            "\\message{PCL[" . $self->name . "]}%",
426            "\\pclimage" . $name . "%" ;
427    }
428
429    # Close TeX/LaTeX if condition if pdf required
430    push @lines, "\\fi% End pcl case" if $pdf ;
431
432    push @lines, "}% End of $name as " . $self->name . " resource" ;
433
434    return \@lines ;
435}
436
437&Debug("Module " . __PACKAGE__ . " v$VERSION loaded");
438
439( $IDENTS->{&_ID} ) = __PACKAGE__ =~ /(\w+)$/ ;
Note: See TracBrowser for help on using the repository browser.