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

#
# 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: PTCA.pm 3 2007-10-18 16:20:19Z root $
#
# Class to implement print object
#

package AFPDS::PTCA;

use strict;
use Encode 'from_to';
use A2P::Globals ;
use A2P::Syslog;
use A2P::Tools qw(debugbuffer compute);
use A2P::Common qw(validate);

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

# Doc ref. from 'Data Stream and Object Architectures -
# Presentation Text Object Content Architecture Reference.pdf'
my %command = (
    0xE6 => 'DBR' , # Draw B-axis Rule, p. 58
    0xE4 => 'DIR' , # Draw I-axis Rule, p. 60
    0xD2 => 'AMB' , # Absolute Move Baseline, p. 51
    0xD4 => 'RMB' , # Relative Move Baseline, p. 69
    0xC6 => 'AMI' , # Absolute Move Inline, p. 53
    0xC8 => 'RMI' , # Relative Move Inline, p. 71
    0xF0 => 'SCFL', # Set Coded Font Local, p. 77
    );

# Update table to avoid eval compilation at runtime
my @keys = keys( %command );
foreach my $key ( @keys ) {
    $command{$key+0x100} = eval '\&' . $command{$key} ;
}

sub new {
    &Debug("new AFPDS::PTCA v$VERSION");
    my $class  = shift ;

    my $self = {
        BUFFER => shift,
        FONT  =>  ""
        };

    return bless $self , $class ;
}

sub isValid {
    my $self = shift ;
    # Return validity cached value
    return $self->{VALIDITY} if (defined($self->{VALIDITY}));

    my $check = &compute( \$self->{BUFFER} , 0 , 1 );
    # PTX prefix+class pair = 0x2BD3
    if ( $check != 0x2B or length( $self->{BUFFER} ) < 1 ) {
        # Skip not used PTX
        if ( length( $self->{BUFFER} ) == 0 or
        ( $check == 0 and length( $self->{BUFFER} ) == 1 )) {
            &Debug("PTX field seems not used");
            return $self->{VALIDITY} = -1 ;

        } else {
            &Warn("PTX Field is badly formated (should begin with 0x2B)");
        }
        return $self->{VALIDITY} = 0 ;
    }

    $check = &compute( \$self->{BUFFER} , 1 , 1 );
    if ( $check != 0xD3 ) {# PTX prefix+class pair
        &Error("PTX Field is badly formated (should begin with 0x2BD3)");
        return $self->{VALIDITY} = 0 ;
    }

    return $self->{VALIDITY} = 1 ;
}

sub getTex {
    my $self = shift ;
    my $TeXCode = "\\PAGEPUT{\\XX}{\\YY}{\\xCP=0pt\\yCP=0pt% PTCA Object\n" ;

    my $cmdlong = 1 ;
    my $text = 0 ;
    for ( my $i = 2 ; $i < length( $self->{BUFFER} ) ; $i += $cmdlong ) {
        if ( $text ) {
            my $j ;
            # Found the next operation as end of text
            for ( $j = $i ; $j < length( $self->{BUFFER} ) ; $j ++ ) {
                last if ( &compute( \$self->{BUFFER} , $j , 2 ) == 0x2BD3 ) ;
            }
            $cmdlong = $j - $i ;
            my $buffer = substr( $self->{BUFFER} , $i , $cmdlong ) ;
            &debugbuffer( $buffer );
            &from_to( $buffer , $FROM_CONVERT , $TO_CONVERT ) if ($DO_CONVERT);
            # Second argument is used to disable space stripping in &validate
            &validate( \$buffer , 1 );
            &Debug("Got text '$buffer'");
            $TeXCode .= "\\PTCATEXT{$buffer}%\n" ;
            $cmdlong += 2 ; # To skip the prefix+class pair
            $text = 0 ;
            next ;
        }
        $cmdlong = &compute( \$self->{BUFFER} , $i   , 1 );
        my $type = &compute( \$self->{BUFFER} , $i+1 , 1 );
        if ( defined($command{$type & 0xFE})) {
            my $Type = $type & 0xFE ;
            &Debug("Got command type $command{$Type} with length $cmdlong");
            $TeXCode .= $command{$Type + 0x100}( $self, $i+2, $cmdlong);
            $TeXCode .= "%\tis PTCA $command{$Type}\n" ;
        } else {
            &Warn(sprintf(
                "Got unsupported PTCA command type 0x%02X with length %d",
                $type, $cmdlong ));
        }
        # End of command: Maybe some text is comming
        $text = 1 if ($type & 1) == 0 ;
    }

    return $TeXCode . "}%" ;
}

sub DBR {
    my ( $self , $k , $long ) = @_ ;
    my $rlength = $self->getlen( $k ) ;
    my $rwidth  = 1 ;
    if ( $long == 7 ) {
        $rwidth = $self->getlen( $k + 2 ) ;
        $rwidth /= 2 ^ &compute( \$self->{BUFFER} , $k+4 , 1 );
    }
    my $offset = "" ;
    my $correction = "\\advance\\xCP by" . $self->PELS( abs($rwidth) ) ;
    if ( $rlength < 0 ) {
        $rlength = abs($rlength) ;
        $offset .= "\\advance\\yCP by-" . $self->PELS( $rlength ) . "%\n" ;
        $correction .= "\\advance\\yCP by" . $self->PELS( abs($rlength) ) ;
    }
    if ( $rwidth < 0 ) {
        $rwidth = abs($rwidth) ;
        $offset .= "\\advance\\xCP by-" . $self->PELS( $rwidth ) . "%\n" ;
    }
    &Debug("Draw B-axis Rule with length $rlength PELS and width $rwidth PELS");
    return $offset . "\\PTCAPUT{\\vrule height" . $self->PELS( $rlength )
        . " depth0pt width" . $self->PELS( $rwidth ) . "}" . $correction ;
}

sub DIR {
    my ( $self , $k , $long ) = @_ ;
    my $rlength = $self->getlen( $k ) ;
    my $rwidth  = 1 ;
    if ( $long == 7 ) {
        $rwidth = $self->getlen( $k + 2 ) ;
        $rwidth /= 2 ^ &compute( \$self->{BUFFER} , $k+4 , 1 );
    }
    my $offset = "" ;
    my $correction = "\\advance\\yCP by" . $self->PELS( abs($rwidth) ) ;
    if ( $rlength < 0 ) {
        $rlength = abs($rlength) ;
        $offset .= "\\advance\\xCP by-" . $self->PELS( $rlength ) . "%\n" ;
        $correction .= "\\advance\\xCP by" . $self->PELS( $rlength ) ;
    }
    if ( $rwidth < 0 ) {
        $rwidth = abs($rwidth) ;
        $offset .= "\\advance\\yCP by-" . $self->PELS( $rwidth ) . "%\n" ;
    }
    &Debug("Draw I-axis Rule with length $rlength PELS and width $rwidth PELS");
    return $offset . "\\PTCAPUT{\\vrule height" . $self->PELS( $rwidth )
        . " depth0pt width" . $self->PELS( $rlength ) . "}" . $correction ;
}

sub AMB {
    my ( $self , $k , $long ) = @_ ;
    my $pos = $self->getlen( $k ) ;
    &Debug("Set position along B-axis to $pos PELS");
    return "\\yCP=" . $self->PELS( $pos ) ;
}

sub RMB {
    my ( $self , $k , $long ) = @_ ;
    my $move = $self->getlen( $k ) ;
    &Debug("Move along B-axis for $move PELS");
    return "\\advance\\yCP by" . $self->PELS( $move ) ;
}

sub AMI {
    my ( $self , $k , $long ) = @_ ;
    my $pos = $self->getlen( $k ) ;
    &Debug("Set position along I-axis to $pos PELS");
    return "\\xCP=" . $self->PELS( $pos ) ;
}

sub RMI {
    my ( $self , $k , $long ) = @_ ;
    my $move = $self->getlen( $k ) ;
    &Debug("Move along I-axis for $move PELS");
    return "\\advance\\xCP by" . $self->PELS( $move ) ;
}

sub getFont {
    my $self = shift ;
    return $self->{FONT} ;
}

sub SCFL {
    my ( $self , $k , $long ) = @_ ;
    my $FontRef = "" ;
    my $font = &compute( \$self->{BUFFER} , $k , 1 ) ;

    unless ( -- $font =~ /^\d+$/ ) {
        &Error("Unsupported '$font' SCFL PTCA object");
        $font = 0 ;
    }

    for ( split( // , $font ) ) {
        $FontRef .= chr( 65 + $_ ) ;
    }

    &Debug("PTCA SCFL selects font TRC '$FontRef'");

    return $self->{FONT} = "\\FONtTrc" . $FontRef ;
}

sub PELS {
    my ( $self , $PELS ) = @_ ;
    # PEL size: 0.501875 for 72.27/144, 0.301125 for 72.27/240, 0.3 for 72/240
    my $pt_by_PELS = 0.301125 ; # units = pt/pels
    my $P = 6 ; # Precision: how many numbers after point
    my $value = sprintf("%.${P}f" , $PELS * $pt_by_PELS );
    $value =~ s/.0{$P}$// ;
    $value =~ s/0+$// if ( $value != 0 );
    &Debug("${PELS} PELS converted to ${value} pt");
    return $value . "pt" ;
}

sub getlen {
    my ( $self , $index ) = @_ ;
    my ( $first , $second ) = (
        ord( substr($self->{BUFFER} , $index     , 1 )) ,
        ord( substr($self->{BUFFER} , $index + 1 , 1 ))
        );

    my $len = $first * 256 + $second;

    $len -= 0x10000 if ( $len > 0x7FFF ); # This is a signed number
    &Debug(sprintf("Len %X%X converted to $len",$first,$second));

    return $len ;
}

sub DESTROY {
    my $self = shift;
    my $err  = shift;

    # Free arrays memory
    map { $self->{$_} = () if (ref($self->{$_}) eq 'ARRAY' ) } keys(%{$self});

    if (defined($err)) {
        &Error("PTCA object $self->{OUTFILE} destroyed with error #" . $err);
    } else {
        &Debug("PTCA object $self->{OUTFILE} destroyed");
    }
}

&Debug("Module " . __PACKAGE__ . " v$VERSION loaded");

1;