#
# Copyright (c) 2004-2007 - Consultas, PKG.fr
#
# This file is part of A2P.
#
# A2P is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# A2P is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with A2P; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
#
# $Id: MODCA.pm 3 2007-10-18 16:20:19Z guillaume $
#
################################################################################
#
# Class to select the right AFP objects
#
################################################################################
# Management of $ident tag, cf doc folder:
# ref #1:
#   see "Advanced Function Presentation - Programming Guide and Line
#   Data Reference" pdf file
# ref #2:
#   see "Data Stream and Object Architectures - Mixed Object Document
#   Content Architecture Reference" pdf file
################################################################################

package AFPDS::MODCA ;

use strict ;
use Encode 'from_to' ;
use A2P::Globals ;
use A2P::Syslog ;
use A2P::Tools  qw( ms compute );

# Known MO:DCA objects as library
use AFPDS::MODCA::Common ;
use AFPDS::MODCA::BAD ;
use AFPDS::MODCA::BOC ;
use AFPDS::MODCA::EOC ;
use AFPDS::MODCA::IDM ;
use AFPDS::MODCA::IMM ;
use AFPDS::MODCA::IOB ;
use AFPDS::MODCA::IPS ;
use AFPDS::MODCA::NOP ;
use AFPDS::MODCA::OCD ;
use AFPDS::MODCA::PTX ;

BEGIN {
    our $VERSION = sprintf "%s", q$Rev: 1015 $ =~ /([0-9.]+)\s+/ ;
}
our $VERSION ;
our $IDENTS ;

sub new {
    my $class = shift ;
    &Debug("new " . __PACKAGE__ . " v$VERSION object");

    my $self = {
        FLUX     => shift || 0 , # Associated flux
        IDENT    => shift || 0 , # MO:DCA identity
        FLAG     => shift || 0 , # MO:DCA flags
        RESERVED => shift || 0 , # MO:DCA reserved
        LONG     => shift || 0 , # MO:DCA length
        BUFFER   => shift || '', # MO:DCA content buffer
        TEXBASE  => shift || '', # TeX/LaTeX conversion base folder
        SUBCLASS => 'unknown',
        BORN     => ms
    };

    # Keep MO:DCA object count statistics
    &UPSTAT('MODCA-OBJECT-USED');
    &UPSTAT('MODCA-IN-MEM');

    return bless $self , $class ;
}

sub check {
    my $self = shift ;

    return ( 250, sprintf("MO:DCA X'%06X' identity not known", $self->{IDENT}) )
        unless (exists($IDENTS->{$self->{IDENT}}));

    # Update sub class identity
    $self->{SUBCLASS} = ref($self) . '::' . $IDENTS->{$self->{IDENT}} ;

    # Auto derivation of ourself to expected AFP object
    bless $self, $self->{SUBCLASS} ;

    # Analyse flags and reserved fields
    return $self->check_flags    if $self->check_flags ;
    return $self->check_reserved if $self->check_reserved ;

    # Really validate from validate member ob derivated object
    return $self->validate ;
}

sub check_flags {
    my $self = shift ;
    my $flags = $self->{FLAGS} || 0 ;

    # By default, flags is null with nothing to do
    return 0 unless $flags ;

    # Bit 4 set padding indicator, cf ref #2, p. 69-70
    return ( 251, "Found unsupported MO:DCA padding format requirement" )
        if ( $flags & 0x40 );

    &Warn(sprintf( "Nothing to do with %08bb flags field on %s object",
        $flags, $self->{SUBCLASS} ));

    return 0 ;
}

sub check_reserved {
    my $self = shift ;
    my $reserved = $self->{RESERVED} || 0 ;

    # By default, reserved is null with nothing to do
    return 0 unless $reserved ;

    &Debug(sprintf( "Nothing to do with 0x%04X reserved field on %s object",
        $reserved, $self->{SUBCLASS} ));

    return 0 ;
}

my %triplets_length = (
    0x10    =>  [ 24, 56, 64, 96 ],
    0x4B    =>  [ 8 ]
    );
my %supported_oid = (
    '06072B120004010116' => [ 'GIF', '89a' ]
    );

sub check_triplets {
    my $self = shift ;
    my $buffer = shift || $self->{BUFFER} ;

    my ( $index, $len ) = ( 0, length($buffer) );
    while ( $index < $len ) {
        # Get triplet length
        my $tlen = &compute( \$buffer, $index, 1 );
        my $next = $index + $tlen ;
        return ( 253, "Empty triplet found" ) unless ( ++$index < $len );

        # Get triplet ID
        my $triplet = &compute( \$buffer, $index++, 1 );
        my $id = sprintf("%02X",$triplet);
        return ( 253, "Unsupported X'$id' triplet found" )
            unless ( exists($triplets_length{$triplet}) );

        &Debug("Found X'$id' triplet in " . $self->{SUBCLASS});
        return ( 253, "Bad X'$id' triplet $tlen length" )
            unless ( grep { $_ == $tlen } @{$triplets_length{$triplet}} );
        return ( 253, "Found truncated X'$id' triplet, missing " . ($next-$len)
            . " bytes" )
            unless ( $next <= $len );

        # Here we are sure triplet is complete
        if ( $triplet == 0x10 ) {
            my $zero     = &compute( \$buffer, $index++, 1 );
            my $class    = &compute( \$buffer, $index++, 1 );
            my $reserved = &compute( \$buffer, $index++, 2 ); $index++ ;
            my $struct   = &compute( \$buffer, $index++, 2 ); $index++ ;
            my @oid = map { &compute( \$buffer, $index++, 1 ) } 1..16 ;
            while ( ! $oid[$#oid] ) { pop @oid }; # Strip last zeros
            my $oid = join( '', map { sprintf("%02X",$_) } @oid ) ;
            return ( 253, "Unsupported $oid OID found in X'$id' triplet for " .
                $self->{SUBCLASS} . " object" )
                unless (exists($supported_oid{$oid}));
            my ( $format, $version ) = @{$supported_oid{$oid}} ;
            if ( $tlen > 24 ) {
                # Just log given format resource, revision and owner as debug
                my $thisformat = substr( $buffer, $index, 32 );
                my ( $revision, $owner ) = ( $version, 'unknown' );
                $thisformat = $self->convert( $thisformat );
                $index += 32 ;
                if ( $tlen > 56 ) {
                    $revision = substr( $buffer, $index, 8 );
                    $revision = $self->convert( $revision );
                    $index += 8 ;
                    if ( $tlen > 64 ) {
                        $owner = substr( $buffer, $index, 32 );
                        $owner = $self->convert( $owner );
                        $index += 32 ;
                    }
                }
                &Debug("Found $thisformat resource rev$revision from " . $owner
                    . " with $oid OID");
            }

            # Check values
            return ( 253, "Byte at offset 2 must be zero in X'$id' triplet" )
                if ($zero);
            return ( 253, "Bytes at offset 4-5 must be zero in X'$id' triplet" )
                if ($reserved);
            return ( 253, "Unsupported $class class in X'$id' triplet" )
                unless ( $class == 0x01 );
            return ( 253, "Unsupported $struct structure in X'$id' triplet" )
                unless ( $struct == 0xDC00 or $struct == 0xA800 );

            # Update ourself
            $self->{OID}     = $oid     ;
            $self->{CLASS}   = $class   ;
            $self->{STRUCT}  = $struct  ;
            $self->{FORMAT}  = $format  ;
            $self->{VERSION} = $version ;

        } elsif ( $triplet == 0x4B ) {
            my $xbase = &compute( \$buffer, $index++, 1 );
            my $ybase = &compute( \$buffer, $index++, 1 );
            my $xunit = &compute( \$buffer, $index++, 2 ); $index++ ;
            my $yunit = &compute( \$buffer, $index++, 2 ); $index++ ;

            # Check values
            return ( 253, "Only 0x00 or 0x01 are supported as X base unit in X'"
                . $id . "' triplet, but found 0x" . sprintf("%02X",$xbase) )
                if ( $xbase < 0 or $xbase > 1 );
            return ( 253, "Only 0x00 or 0x01 are supported as Y base unit in X'"
                . $id . "' triplet, but found 0x" . sprintf("%02X",$ybase) )
                if ( $ybase < 0 or $ybase > 1 );
            return ( 253, "X units not in range [1-32767] in X'$id' triplet" )
                if ( $xunit < 1 or $xunit > 32767 );
            return ( 253, "Y units not in range [1-32767] in X'$id' triplet" )
                if ( $yunit < 1 or $yunit > 32767 );

            # Calculate resolutions in 'dpi' as TeX/LaTeX unit
            my $ptbyteninch = 722.7      ; # Number of TeX Points in 10 inch
            my $ptbytencm   = 284.527559 ; # result of ptbyteninch/ '2.54 cm/in'

            # Found the number of inch as specified in base
            # 10 cm = 10 / 2.54 = 3.937008 inches
            $xbase = $xbase ? 3.937008 : 10 ;
            $ybase = $ybase ? 3.937008 : 10 ;

            # Get resolutions
            $xunit /= $xbase ;
            $yunit /= $ybase ;

            return ( 253,
                "Doesn't support X,Y different resolutions in X'$id' triplet" )
                unless ( $xunit == $yunit );

            # Keep results
            $self->{RESOLUTION} = int($xunit) ;

        } else {
            return ( 253, "Can't analyse X'$id' triplet" );
        }

        # Control analysis is correct
        return ( 253, "Bad analysis of X'$id' triplet ($index vs $next)" )
            unless ( $index == $next );
    }

    return () ;
}

# Private member to override to specify supported triplets
sub _supported_triplets {
    # Return 2 array refs of supported triplets, first is mandatory, then not
    return [], [] ;
}

sub get_from_buffer {
    my $self = shift ;
    return &compute( \$self->{BUFFER}, @_ );
}

sub convert {
    my $self = shift ;
    my $buffer = shift || $self->{BUFFER} ;
    &from_to( $buffer , $FROM_CONVERT , $TO_CONVERT ) if ($DO_CONVERT);
    $buffer =~ s/\s+$// ;
    return $buffer ;
}

sub folder {
    my $self = shift ;
    return $self->{TEXBASE} || '' ;
}

sub name {
    # Can be set by X'02' triplet
    my $self = shift ;
    $self->{NAME} = shift if @_ ;
    $self->{NAME} = "NONAME" unless (exists($self->{NAME}));
    return $self->{NAME} ;
}

sub validate {
    my $self = ref($_[0]) ;
    return ( 251, "MO:DCA $self object can't be validated" );
}

sub create {
    my $self = ref($_[0]) ;
    return ( 252, "MO:DCA $self object can't be created" );
}

sub DESTROY {
    &DOWNSTAT('MODCA-IN-MEM');
    &MAXMINSTAT('MODCA-AGE',&ms() - $_[0]->{BORN});
}

&Debug("Module " . __PACKAGE__ . " v$VERSION loaded");
&Debug(__PACKAGE__."->IDENTS: ".join(", ",keys(%{$IDENTS})));

1;