source: A2P/a2p/AFPDS/MODCA.pm @ 8

Last change on this file since 8 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: 10.5 KB
RevLine 
[3]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: MODCA.pm 3 2007-10-18 16:20:19Z root $
21#
22################################################################################
23#
24# Class to select the right AFP objects
25#
26################################################################################
27# Management of $ident tag, cf doc folder:
28# ref #1:
29#   see "Advanced Function Presentation - Programming Guide and Line
30#   Data Reference" pdf file
31# ref #2:
32#   see "Data Stream and Object Architectures - Mixed Object Document
33#   Content Architecture Reference" pdf file
34################################################################################
35
36package AFPDS::MODCA ;
37
38use strict ;
39use Encode 'from_to' ;
40use A2P::Globals ;
41use A2P::Syslog ;
42use A2P::Tools  qw( ms compute );
43
44# Known MO:DCA objects as library
45use AFPDS::MODCA::Common ;
46use AFPDS::MODCA::BAD ;
47use AFPDS::MODCA::BOC ;
48use AFPDS::MODCA::EOC ;
49use AFPDS::MODCA::IDM ;
50use AFPDS::MODCA::IMM ;
51use AFPDS::MODCA::IOB ;
52use AFPDS::MODCA::IPS ;
53use AFPDS::MODCA::NOP ;
54use AFPDS::MODCA::OCD ;
55use AFPDS::MODCA::PTX ;
56
57BEGIN {
58    our $VERSION = sprintf "%s", q$Rev: 1015 $ =~ /([0-9.]+)\s+/ ;
59}
60our $VERSION ;
61our $IDENTS ;
62
63sub new {
64    my $class = shift ;
65    &Debug("new " . __PACKAGE__ . " v$VERSION object");
66
67    my $self = {
68        FLUX     => shift || 0 , # Associated flux
69        IDENT    => shift || 0 , # MO:DCA identity
70        FLAG     => shift || 0 , # MO:DCA flags
71        RESERVED => shift || 0 , # MO:DCA reserved
72        LONG     => shift || 0 , # MO:DCA length
73        BUFFER   => shift || '', # MO:DCA content buffer
74        TEXBASE  => shift || '', # TeX/LaTeX conversion base folder
75        SUBCLASS => 'unknown',
76        BORN     => ms
77    };
78
79    # Keep MO:DCA object count statistics
80    &UPSTAT('MODCA-OBJECT-USED');
81    &UPSTAT('MODCA-IN-MEM');
82
83    return bless $self , $class ;
84}
85
86sub check {
87    my $self = shift ;
88
89    return ( 250, sprintf("MO:DCA X'%06X' identity not known", $self->{IDENT}) )
90        unless (exists($IDENTS->{$self->{IDENT}}));
91
92    # Update sub class identity
93    $self->{SUBCLASS} = ref($self) . '::' . $IDENTS->{$self->{IDENT}} ;
94
95    # Auto derivation of ourself to expected AFP object
96    bless $self, $self->{SUBCLASS} ;
97
98    # Analyse flags and reserved fields
99    return $self->check_flags    if $self->check_flags ;
100    return $self->check_reserved if $self->check_reserved ;
101
102    # Really validate from validate member ob derivated object
103    return $self->validate ;
104}
105
106sub check_flags {
107    my $self = shift ;
108    my $flags = $self->{FLAGS} || 0 ;
109
110    # By default, flags is null with nothing to do
111    return 0 unless $flags ;
112
113    # Bit 4 set padding indicator, cf ref #2, p. 69-70
114    return ( 251, "Found unsupported MO:DCA padding format requirement" )
115        if ( $flags & 0x40 );
116
117    &Warn(sprintf( "Nothing to do with %08bb flags field on %s object",
118        $flags, $self->{SUBCLASS} ));
119
120    return 0 ;
121}
122
123sub check_reserved {
124    my $self = shift ;
125    my $reserved = $self->{RESERVED} || 0 ;
126
127    # By default, reserved is null with nothing to do
128    return 0 unless $reserved ;
129
130    &Debug(sprintf( "Nothing to do with 0x%04X reserved field on %s object",
131        $reserved, $self->{SUBCLASS} ));
132
133    return 0 ;
134}
135
136my %triplets_length = (
137    0x10    =>  [ 24, 56, 64, 96 ],
138    0x4B    =>  [ 8 ]
139    );
140my %supported_oid = (
141    '06072B120004010116' => [ 'GIF', '89a' ]
142    );
143
144sub check_triplets {
145    my $self = shift ;
146    my $buffer = shift || $self->{BUFFER} ;
147
148    my ( $index, $len ) = ( 0, length($buffer) );
149    while ( $index < $len ) {
150        # Get triplet length
151        my $tlen = &compute( \$buffer, $index, 1 );
152        my $next = $index + $tlen ;
153        return ( 253, "Empty triplet found" ) unless ( ++$index < $len );
154
155        # Get triplet ID
156        my $triplet = &compute( \$buffer, $index++, 1 );
157        my $id = sprintf("%02X",$triplet);
158        return ( 253, "Unsupported X'$id' triplet found" )
159            unless ( exists($triplets_length{$triplet}) );
160
161        &Debug("Found X'$id' triplet in " . $self->{SUBCLASS});
162        return ( 253, "Bad X'$id' triplet $tlen length" )
163            unless ( grep { $_ == $tlen } @{$triplets_length{$triplet}} );
164        return ( 253, "Found truncated X'$id' triplet, missing " . ($next-$len)
165            . " bytes" )
166            unless ( $next <= $len );
167
168        # Here we are sure triplet is complete
169        if ( $triplet == 0x10 ) {
170            my $zero     = &compute( \$buffer, $index++, 1 );
171            my $class    = &compute( \$buffer, $index++, 1 );
172            my $reserved = &compute( \$buffer, $index++, 2 ); $index++ ;
173            my $struct   = &compute( \$buffer, $index++, 2 ); $index++ ;
174            my @oid = map { &compute( \$buffer, $index++, 1 ) } 1..16 ;
175            while ( ! $oid[$#oid] ) { pop @oid }; # Strip last zeros
176            my $oid = join( '', map { sprintf("%02X",$_) } @oid ) ;
177            return ( 253, "Unsupported $oid OID found in X'$id' triplet for " .
178                $self->{SUBCLASS} . " object" )
179                unless (exists($supported_oid{$oid}));
180            my ( $format, $version ) = @{$supported_oid{$oid}} ;
181            if ( $tlen > 24 ) {
182                # Just log given format resource, revision and owner as debug
183                my $thisformat = substr( $buffer, $index, 32 );
184                my ( $revision, $owner ) = ( $version, 'unknown' );
185                $thisformat = $self->convert( $thisformat );
186                $index += 32 ;
187                if ( $tlen > 56 ) {
188                    $revision = substr( $buffer, $index, 8 );
189                    $revision = $self->convert( $revision );
190                    $index += 8 ;
191                    if ( $tlen > 64 ) {
192                        $owner = substr( $buffer, $index, 32 );
193                        $owner = $self->convert( $owner );
194                        $index += 32 ;
195                    }
196                }
197                &Debug("Found $thisformat resource rev$revision from " . $owner
198                    . " with $oid OID");
199            }
200
201            # Check values
202            return ( 253, "Byte at offset 2 must be zero in X'$id' triplet" )
203                if ($zero);
204            return ( 253, "Bytes at offset 4-5 must be zero in X'$id' triplet" )
205                if ($reserved);
206            return ( 253, "Unsupported $class class in X'$id' triplet" )
207                unless ( $class == 0x01 );
208            return ( 253, "Unsupported $struct structure in X'$id' triplet" )
209                unless ( $struct == 0xDC00 or $struct == 0xA800 );
210
211            # Update ourself
212            $self->{OID}     = $oid     ;
213            $self->{CLASS}   = $class   ;
214            $self->{STRUCT}  = $struct  ;
215            $self->{FORMAT}  = $format  ;
216            $self->{VERSION} = $version ;
217
218        } elsif ( $triplet == 0x4B ) {
219            my $xbase = &compute( \$buffer, $index++, 1 );
220            my $ybase = &compute( \$buffer, $index++, 1 );
221            my $xunit = &compute( \$buffer, $index++, 2 ); $index++ ;
222            my $yunit = &compute( \$buffer, $index++, 2 ); $index++ ;
223
224            # Check values
225            return ( 253, "Only 0x00 or 0x01 are supported as X base unit in X'"
226                . $id . "' triplet, but found 0x" . sprintf("%02X",$xbase) )
227                if ( $xbase < 0 or $xbase > 1 );
228            return ( 253, "Only 0x00 or 0x01 are supported as Y base unit in X'"
229                . $id . "' triplet, but found 0x" . sprintf("%02X",$ybase) )
230                if ( $ybase < 0 or $ybase > 1 );
231            return ( 253, "X units not in range [1-32767] in X'$id' triplet" )
232                if ( $xunit < 1 or $xunit > 32767 );
233            return ( 253, "Y units not in range [1-32767] in X'$id' triplet" )
234                if ( $yunit < 1 or $yunit > 32767 );
235
236            # Calculate resolutions in 'dpi' as TeX/LaTeX unit
237            my $ptbyteninch = 722.7      ; # Number of TeX Points in 10 inch
238            my $ptbytencm   = 284.527559 ; # result of ptbyteninch/ '2.54 cm/in'
239
240            # Found the number of inch as specified in base
241            # 10 cm = 10 / 2.54 = 3.937008 inches
242            $xbase = $xbase ? 3.937008 : 10 ;
243            $ybase = $ybase ? 3.937008 : 10 ;
244
245            # Get resolutions
246            $xunit /= $xbase ;
247            $yunit /= $ybase ;
248
249            return ( 253,
250                "Doesn't support X,Y different resolutions in X'$id' triplet" )
251                unless ( $xunit == $yunit );
252
253            # Keep results
254            $self->{RESOLUTION} = int($xunit) ;
255
256        } else {
257            return ( 253, "Can't analyse X'$id' triplet" );
258        }
259
260        # Control analysis is correct
261        return ( 253, "Bad analysis of X'$id' triplet ($index vs $next)" )
262            unless ( $index == $next );
263    }
264
265    return () ;
266}
267
268# Private member to override to specify supported triplets
269sub _supported_triplets {
270    # Return 2 array refs of supported triplets, first is mandatory, then not
271    return [], [] ;
272}
273
274sub get_from_buffer {
275    my $self = shift ;
276    return &compute( \$self->{BUFFER}, @_ );
277}
278
279sub convert {
280    my $self = shift ;
281    my $buffer = shift || $self->{BUFFER} ;
282    &from_to( $buffer , $FROM_CONVERT , $TO_CONVERT ) if ($DO_CONVERT);
283    $buffer =~ s/\s+$// ;
284    return $buffer ;
285}
286
287sub folder {
288    my $self = shift ;
289    return $self->{TEXBASE} || '' ;
290}
291
292sub name {
293    # Can be set by X'02' triplet
294    my $self = shift ;
295    $self->{NAME} = shift if @_ ;
296    $self->{NAME} = "NONAME" unless (exists($self->{NAME}));
297    return $self->{NAME} ;
298}
299
300sub validate {
301    my $self = ref($_[0]) ;
302    return ( 251, "MO:DCA $self object can't be validated" );
303}
304
305sub create {
306    my $self = ref($_[0]) ;
307    return ( 252, "MO:DCA $self object can't be created" );
308}
309
310sub DESTROY {
311    &DOWNSTAT('MODCA-IN-MEM');
312    &MAXMINSTAT('MODCA-AGE',&ms() - $_[0]->{BORN});
313}
314
315&Debug("Module " . __PACKAGE__ . " v$VERSION loaded");
316&Debug(__PACKAGE__."->IDENTS: ".join(", ",keys(%{$IDENTS})));
317
3181;
Note: See TracBrowser for help on using the repository browser.