| 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 g $ |
|---|
| 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 | |
|---|
| 36 | package AFPDS::MODCA ; |
|---|
| 37 | |
|---|
| 38 | use strict ; |
|---|
| 39 | use Encode 'from_to' ; |
|---|
| 40 | use A2P::Globals ; |
|---|
| 41 | use A2P::Syslog ; |
|---|
| 42 | use A2P::Tools qw( ms compute ); |
|---|
| 43 | |
|---|
| 44 | # Known MO:DCA objects as library |
|---|
| 45 | use AFPDS::MODCA::Common ; |
|---|
| 46 | use AFPDS::MODCA::BAD ; |
|---|
| 47 | use AFPDS::MODCA::BOC ; |
|---|
| 48 | use AFPDS::MODCA::EOC ; |
|---|
| 49 | use AFPDS::MODCA::IDM ; |
|---|
| 50 | use AFPDS::MODCA::IMM ; |
|---|
| 51 | use AFPDS::MODCA::IOB ; |
|---|
| 52 | use AFPDS::MODCA::IPS ; |
|---|
| 53 | use AFPDS::MODCA::NOP ; |
|---|
| 54 | use AFPDS::MODCA::OCD ; |
|---|
| 55 | use AFPDS::MODCA::PTX ; |
|---|
| 56 | |
|---|
| 57 | BEGIN { |
|---|
| 58 | our $VERSION = sprintf "%s", q$Rev: 1015 $ =~ /([0-9.]+)\s+/ ; |
|---|
| 59 | } |
|---|
| 60 | our $VERSION ; |
|---|
| 61 | our $IDENTS ; |
|---|
| 62 | |
|---|
| 63 | sub 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 | |
|---|
| 86 | sub 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 | |
|---|
| 106 | sub 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 | |
|---|
| 123 | sub 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 | |
|---|
| 136 | my %triplets_length = ( |
|---|
| 137 | 0x10 => [ 24, 56, 64, 96 ], |
|---|
| 138 | 0x4B => [ 8 ] |
|---|
| 139 | ); |
|---|
| 140 | my %supported_oid = ( |
|---|
| 141 | '06072B120004010116' => [ 'GIF', '89a' ] |
|---|
| 142 | ); |
|---|
| 143 | |
|---|
| 144 | sub 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 |
|---|
| 269 | sub _supported_triplets { |
|---|
| 270 | # Return 2 array refs of supported triplets, first is mandatory, then not |
|---|
| 271 | return [], [] ; |
|---|
| 272 | } |
|---|
| 273 | |
|---|
| 274 | sub get_from_buffer { |
|---|
| 275 | my $self = shift ; |
|---|
| 276 | return &compute( \$self->{BUFFER}, @_ ); |
|---|
| 277 | } |
|---|
| 278 | |
|---|
| 279 | sub 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 | |
|---|
| 287 | sub folder { |
|---|
| 288 | my $self = shift ; |
|---|
| 289 | return $self->{TEXBASE} || '' ; |
|---|
| 290 | } |
|---|
| 291 | |
|---|
| 292 | sub 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 | |
|---|
| 300 | sub validate { |
|---|
| 301 | my $self = ref($_[0]) ; |
|---|
| 302 | return ( 251, "MO:DCA $self object can't be validated" ); |
|---|
| 303 | } |
|---|
| 304 | |
|---|
| 305 | sub create { |
|---|
| 306 | my $self = ref($_[0]) ; |
|---|
| 307 | return ( 252, "MO:DCA $self object can't be created" ); |
|---|
| 308 | } |
|---|
| 309 | |
|---|
| 310 | sub 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 | |
|---|
| 318 | 1; |
|---|
