source: A2P/a2p/AFPDS/Flux.pm @ 5

Last change on this file since 5 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: 29.0 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: Flux.pm 3 2007-10-18 16:20:19Z g $
21#
22# Class to implement print object
23#
24
25package AFPDS::Flux;
26
27use strict ;
28use Encode 'from_to' ;
29use A2P::Globals ;
30use A2P::Syslog;
31use AFPDS::MODCA ;
32use A2P::Common qw( validate );
33use A2P::Com    qw( GetCom comINF );
34
35BEGIN {
36    our $VERSION = sprintf "%s", q$Rev: 1023 $ =~ /([0-9.]+)\s+/ ;
37}
38our $VERSION ;
39
40sub new {
41    &Debug("new AFPDS::Flux v$VERSION");
42    my $class = shift ;
43    my $self = {
44        AFPDSFILE       =>  shift   ,   PAGEFORMATs =>  {}        ,
45        LogoLines       =>    []    ,   COPYGROUPs  =>  {}        ,
46        PAGES           =>    0     ,   FORMDEF     =>  ""        ,
47        LANDSCAPE       =>    0     ,   PAGEDEF     =>  ""        ,
48        LastChannel     =>    1     ,   OUTFILE     =>  "none"    ,
49        CHANNELNUMBER   =>    1     ,   CHANNEL     =>  'A'       ,
50        MaxRepeat       =>    1     ,   LOGOS       =>  []        ,
51        LINE            =>    0     ,   LINES       =>  []        ,
52        PrintLineTab    =>    []    ,   PrintLine   =>  {}        ,
53        PCLCOND         =>    0     ,   INSERT_LOGO =>  0         ,
54        StartNewPage    =>    0     ,   ROTSEGMENT  =>  0         ,
55        CurrentPAGEFORMAT =>  ""    ,   THREAD      =>  shift     ,
56        BADCHANNELALERT =>    0     ,   JOB         =>  shift     ,
57        ERROR           =>    []    ,   LOGOs       =>  {}        ,
58        OPENEDCHANNEL   =>    0     ,   COPYGROUP   =>  ""        ,
59        OPENEDPFORMAT   =>    0     ,   LOGO_INDEX  =>  0         ,
60        HAS_LOGO        =>    0     ,   PAGEFORMAT  =>  ""        ,
61        RESOURCE        =>    {}    , SELECTED_RESOURCE => ""     ,
62        DefaultTRC      =>    "\\FONtTrcA",
63        LastDefaultTRC  =>    "\\FONtTrcA",
64        texpackages     =>    [ 'afp2print' ]
65    };
66
67    return bless $self , $class ;
68}
69
70sub Return {
71    # Used to call Return member to be able to provide info to JobManager
72    my $self = shift ;
73    my $this = $self->{THREAD} ;
74    $this->Return( $self->{JOB} => &GetCom( comINF, Conversion => @_ ));
75}
76
77sub getlineindex {
78    my $self = shift ;
79    return $self->{LINE} ;
80}
81
82sub afpline {
83    my $self    = shift ;
84    my $cctrl   = shift ;
85    my $buffer  = shift ;
86
87    my ( $comment , $lsp ) = ( "none" , 0 );
88
89    # If no PageFormat still has been requested, we must load the first one
90    # as default before output any line
91    unless ($self->{PAGEFORMAT}) {
92        $self->{COPYGROUP}   = "%\n% No COPYGROUP defined"
93            unless ($self->{COPYGROUP});
94        $self->{PAGEFORMAT}  = "\\pageformatA{%" ;
95        # This is simulating printing on channel 1, so $cctrl = 1 is implicite
96        $cctrl = '1' ;
97    }
98
99    if ( $cctrl eq " " ) {
100        $comment = "Space one line then print (single spacing)";
101        $lsp = 1 ;
102
103    } elsif ( $cctrl eq "0" ) {
104        $comment = "Space 2 lines then print (double spacing)";
105        $lsp = 2 ;
106
107    } elsif ( $cctrl eq "-" ) {
108        $comment = "Space 3 lines then print (triple spacing)";
109        $lsp = 3 ;
110
111    } elsif ( $cctrl eq "+" ) {
112        $comment = "Suppress spacing, then print (overstrike previous line)";
113        $lsp = 0 ;
114        if ($self->LastLineMatch(qr/^\\PrintLineChannel/,2)
115        and $self->{LINE} == $self->{MaxRepeat} and $self->{MaxRepeat} > 0) {
116            $comment .= ", selecting new channel" ;
117            my @insertlines = pop( @{$self->{LINES}} );
118            unshift @insertlines , pop( @{$self->{LINES}} );
119            $self->nextChannel();
120            $self->addline( @insertlines );
121        }
122
123    } elsif ( $cctrl =~ /^[1-9ABC]$/i ) {
124        if ($self->nextChannel($cctrl)) {
125            $comment = "Print data to Channel #" . $self->{CHANNELNUMBER} ;
126
127        } else {
128            # Work around for bad channel selection
129            $comment = "Space one line then print (single spacing)";
130            $lsp = 1 ;
131        }
132
133    } else {# Not an ANSI Carriage Control Character,
134            # see table 1. p7 of Advanced Function Presentation:
135            #     Programming Guide and Line Data Reference
136        &Error(sprintf("Got '$cctrl' (%Xh) not supported control char",$cctrl));
137        return undef;
138    }
139    &Debug("cctrl=[$cctrl], $comment");
140
141    # Compute Line Max repetition and switch to next channel if needed
142    $self->{LINE} += $lsp ;
143
144    # Start new channel when required
145    $self->nextChannel()
146        if (( $self->{LINE} > $self->{MaxRepeat} and $self->{MaxRepeat} > 0 )
147        or $self->{StartNewPage} );
148
149    # Insert Line spacing if necessary
150    if ($lsp > 0) {
151
152        # Update previous line spacing if exists
153        if ( $self->LastLineMatch( qr/\\LineSpacing\{\d+\}%$/ ) ) {
154            # We prefer update last Linespacing
155            my $index   = $#{$self->{LINES}} ;
156            ${$self->{LINES}}[$index] =~ /\{(\d+)\}%$/ ;
157            $lsp += $1 ;
158            ${$self->{LINES}}[$index] =~ s/\{\d+\}%$/\{$lsp\}%/ ;
159
160        } else {
161            $self->newline( "\\LineSpacing{$lsp}%" );
162        }
163    }
164
165    # Is fieldAA is defined ? If no, just print the line as is
166    if (defined($self->{PrintLine}->{'fieldAAstart'})) {
167        my $buflen = length( $buffer );
168        my @fields = grep( /^field..start$/ , keys(%{$self->{PrintLine}}) ) ;
169        map s/start$//, @fields ; # Just keep indexes which are in upper case
170        for my $field ( @fields ) {
171
172            my ( $start , $len ) = ( $field . "start" , $field . "length" );
173
174            # Check field definition from auto-generated library, needed to
175            # detect bad converted Perl library
176            if (!( defined($self->{PrintLine}->{$start})
177            and defined($self->{PrintLine}->{$len}))) {
178                &Error("Found incomplete field for field $field");
179                next ;
180            }
181
182            my $readlen   = $self->{PrintLine}->{$len} ;
183            my $readstart = $self->{PrintLine}->{$start} - 1 ;
184
185            # Check there is enough text in buffer to extract field value
186            if ( $readstart >= $buflen ) {
187                #&Debug("text for field $field starts out of buffer, skip it" );
188                next ;
189            }
190
191            # Check available text length from buffer for that field
192            if ( $readstart + $readlen > $buflen ) {
193                &Debug("Available text for field " . $field .
194                    " is not as long as expected ($readlen chars)");
195                $readlen = $buflen - ( $self->{PrintLine}->{$start} - 1 ) ;
196                &Debug("Will read only $readlen chars from buffer");
197            }
198
199            # Extract text from buffer and validate it
200            my $text = substr( $buffer , $readstart , $readlen ) ;
201            &validate( \$text ) ;
202
203            # Don't print this text if there's only white spaces
204            if ( $text =~ /\S/ ) {
205                &Debug("Print new $field: length=$readlen, text='$text')");
206                $self->newline( "\\" . $field . "{$text}%" ) ;
207            }
208        }
209    } else {
210
211        &validate( \$buffer );
212        # Print a non formatted line if not empty
213        $self->newline("\\PrintLine{" . $buffer . "}%") if (length($buffer));
214    }
215
216    # Remember which channel is defined next time
217    $self->{LastChannel} = $self->{CHANNELNUMBER};
218}
219
220sub nextChannel {
221    my $self    = shift ;
222    my $channel = shift ;
223    my $startnewpage = 0 ;
224
225    if (defined($channel)) {
226        $self->{CHANNELNUMBER} = eval("0x$channel"); # Hex evaluation is correct
227
228        # Start a new page on that channel if asking the same channel as
229        # previous (default to 1), so this activate also the first page
230        # (LastChannel default to 1) or if new channel is lower than previous
231        $startnewpage ++
232            if ( $self->{LastChannel} >= $self->{CHANNELNUMBER}
233            or $self->{StartNewPage} );
234
235    } else {
236        &Debug("No channel selection defined");
237        # Use next channel on the pagedef (or next FCB in old logic)
238        $self->{CHANNELNUMBER} ++ ;
239
240        # Start a new page on channel 1 if no more channel in PAGEDEF available
241        if ( $self->{StartNewPage}
242        or ! defined(${$self->{PrintLineTab}}[$self->{CHANNELNUMBER}]) ) {
243            $startnewpage ++ ;
244            $self->{CHANNELNUMBER} = 1 ;
245        }
246    }
247
248    $channel = $self->{CHANNELNUMBER} ;
249    &Debug("Selecting channel #" . $channel );
250
251    # Check channel has been defined in library unless it's the first channel
252    # (default)
253    if ( $channel > 1 ) {
254        unless (defined(${$self->{PrintLineTab}}[$channel])
255            and ${$self->{PrintLineTab}}[$channel])
256        {
257            # If channel is defined, {PrintLine} must a hash, otherwise don't
258            # select TeX not defined channel
259            $self->addline("% Bad channel #$channel selection here");
260            $self->Return("Bad channel #$channel selection found");
261            &Warn("Bad channel #$channel on P1" . $self->{PAGEDEF});
262            # Only warn with max informations one time
263            &Warn("Tried to select bad printline channel with pageformat " .
264                $self->{CurrentPAGEFORMAT} . "during processing on " .
265                $self->{OUTFILE})
266                    unless ($self->{BADCHANNELALERT} ++);
267            return 0 ;
268        }
269    }
270
271    # Start new page if required
272    $self->startnewpage() if $startnewpage ;
273
274    # Del the previous line if not needed and fix channel block
275    if ($self->LastLineMatch( qr/^\\PrintLineChannel/ )) {
276        $self->deloneline();
277
278    } elsif ($self->{OPENEDCHANNEL}) {
279        # Close previous channel
280        $self->closeblock();
281
282        # Select default font if it has changed
283        $self->{TRCFONT} = $self->{DefaultTRC}
284            unless (defined($self->{TRCFONT}) or
285                $self->{LastDefaultTRC} eq $self->{DefaultTRC});
286    }
287
288    # Skip font selection when it has not changed
289    undef ($self->{TRCFONT})
290        if (defined($self->{TRCFONT})
291        and $self->{TRCFONT} eq $self->{LastDefaultTRC});
292
293    # Open this channel TeX block
294    $self->openblock() unless ($self->LastLineMatch( qr/{%$/ ));
295    $self->{LastDefaultTRC} = $self->{DefaultTRC} ;
296
297    # Authorize TeX to load corresponding channel definitions
298    $self->newline( "\\PrintLineChannel" . chr( 64 + $channel ) . "%" );
299
300    # Initialize new known channel
301    $self->{PrintLine} = ${$self->{PrintLineTab}}[$channel];
302
303    # Reset line repetition control
304    $self->{MaxRepeat} = $self->{PrintLine}->{'REPEAT'} ;
305    $self->{LINE} = 1 ;
306}
307
308sub addline {
309    my $self = shift ;
310    push @{$self->{LINES}} , @_ if @_;
311}
312
313sub openblock {
314    # It's better to select font before opening the block
315    defined($_[0]->{TRCFONT}) ? $_[0]->newline( "{%" ) : $_[0]->addline( "{%" );
316    $_[0]->{OPENEDCHANNEL} = 1 ;
317}
318
319sub closeblock {
320    $_[0]->addline( "}%" );
321    $_[0]->{OPENEDCHANNEL} = 0 ;
322}
323
324sub newline {
325    my $self = shift ;
326    my $line = shift ;
327
328    # Insert TRC font selection if defined
329    if (defined($self->{TRCFONT})) {
330        # Del the previous line if also and only a font selection
331        $self->deloneline() if ($self->LastLineMatch( qr/^\\FONtTrc\w+%$/ ));
332
333        # Insert TRC font selection
334        if ( $line !~ /^\\/ ) {
335            $self->addline( $self->{TRCFONT} . "%" );
336
337        } else {
338            $line = $self->{TRCFONT} . $line ;
339        }
340
341        # undefine it to not select font next call
342        undef $self->{TRCFONT} ;
343    }
344
345    $self->addline( $line );
346}
347
348sub newlogo {
349    my $self = shift ;
350    my $logo = shift ;
351
352    # Current document has logos
353    $self->{HAS_LOGO} ++ ;
354
355    push @{$self->{LogoLines}} , $logo ;
356}
357
358sub tex_logo_tag { "%%INSERT LOGO HERE" }
359
360sub addsegpath {
361    my $self = shift ;
362    my ( $path, $name ) = @_ ;
363
364    # Add path only if logo is still not in our list
365    push @{$self->{LOGOS}}, $path . $name . '.def'
366        unless (exists($self->{LOGOs}->{$name}));
367}
368
369sub insertLogos {
370    my $self = shift ;
371    my $logo = $self->{LOGO_INDEX} ;
372
373    &Debug("Inserting " . @{$self->{LogoLines}} . " lines for logos");
374
375    if ( ! @{$self->{LogoLines}} or $self->{INSERT_LOGO} > 0 ) {
376        # Insert current logos
377        if ( $self->{INSERT_LOGO} and $logo ) {
378            local $" = "\n" ;
379
380            if ( $self->{LINES}->[$logo] eq tex_logo_tag ) {
381                &Debug("Inserting logos at previous position tag");
382                $self->{LINES}->[$logo] = @{$self->{LogoLines}} ?
383                    "@{$self->{LogoLines}}" : "% No logo inserted" ;
384
385                # Fix logo insertion index
386                $self->addline( tex_logo_tag );
387
388                # Keep logo index
389                $self->{LOGO_INDEX} = $#{$self->{LINES}} ;
390
391            } else {
392                # TODO Check if this case happens some time
393                &Warn("Not expected logo insertion detected (case #1)");
394
395                # Append logo lines to last inserted logo
396                $self->{LINES}->[$logo] .= "\n@{$self->{LogoLines}}" ;
397            }
398
399        } elsif ($self->{HAS_LOGO} or ($self->{LINE} and $self->{PAGES})) {
400
401            &Debug("Inserting logos position tag");
402            # Fix logo insertion index
403            $self->addline( tex_logo_tag );
404
405            $self->{INSERT_LOGO} ++ ;
406
407            # Keep logo index
408            $self->{LOGO_INDEX} = $#{$self->{LINES}} ;
409
410        } else {
411            &Debug("Nothing to insert");
412        }
413
414    } else {
415        if (@_ and $_[0] =~ /^LASTINSERT$/) {
416            # Called from the end: it's a very bad case
417            # TODO Check if this case happens some time
418            &Warn("Not expected logo insertion detected (case #2)");
419
420            # Append logo lines to last inserted logo
421            local $" = "\n" ;
422            $self->{LINES}->[$logo] .= "\n@{$self->{LogoLines}}" ;
423
424        } else {
425            &Debug("Inserting logos at current position");
426            # Normal case, just add logo lines to lines buffer
427            $self->addline( @{$self->{LogoLines}} );
428
429            # Keep logo index
430            $self->{LOGO_INDEX} = $#{$self->{LINES}} ;
431        }
432    }
433
434    $self->{LogoLines} = [] ;
435    # Reset flag rotsegment to default
436    $self->{ROTSEGMENT} = 0 ;
437}
438
439sub selectDefaultTRC {
440    # Set current default TRC
441    $_[0]->addline( $_[0]->{DefaultTRC} ."%" );
442}
443
444sub selectTRCfont {
445    # This function analyses the second binary value from linedata
446    # It is given as ascii code of a char
447    my $self = shift ;
448    my $TRC  = shift ;
449    my $font = "" ;
450
451    &Debug("TRC font selection byte is $TRC " . sprintf("(0x%X)",$TRC));
452    # Ignore left most bits if higher or equal to 0xF0
453    $TRC &= 0x0F if ($TRC >= 0xF0);
454
455    &Debug("Font still selected") , return if ( $self->{CurrentTRC} == $TRC );
456    $self->{CurrentTRC} = $TRC ;
457
458    # We should not need more TRC fonts, and this skip considering 0x40
459    # often found and invalid value
460    if ( $TRC < 20 ) { # Must be adapted as needed
461    #if ( $TRC < 128 ) {
462        #if ( $TRC > 25 ) {
463        #    $font = chr( 65 + $TRC / 26 );
464        #    $TRC %= 26 ;
465        #}
466        $font .= chr( 65 + $TRC );
467        $self->{TRCFONT} = "\\FONtTrc$font" ;
468        &Debug("Selecting Trc{$font} font");
469    } else {
470        &Debug("Forcing default TrcA font selection as TRC byte is '$TRC'");
471        $self->{TRCFONT} = "\\FONtTrcA" ;
472    }
473
474    # Redefine default TRC when selecting TRC at the base document
475    $self->{DefaultTRC} = $self->{TRCFONT} ;
476}
477
478sub startnewpage {
479    my $self = shift ;
480    $self->{LINE} = 1 ;
481
482    # Remove any unuseful line spacing
483    while ( $self->LastLineMatch( qr/LineSpacing/ ) ) {
484        $self->deloneline();
485    }
486
487    # Close current Page and open new one
488    if ($self->{OPENEDCHANNEL}) {
489        # Close previous channel if one opened
490        $self->closeblock();
491    }
492
493    # Check if we are closing the first page reaching the linemax limit
494    # (COPYGROUP still not set to close a TeX block)
495    if ( $self->{COPYGROUP} !~ /^}%/ and $self->{PAGES} > 0 ) {
496        $self->addline( "}%\n" );
497
498    } else {
499        $self->addline( $self->{COPYGROUP} );
500    }
501    $self->addline( $self->{PAGEFORMAT} );
502    $self->insertLogos();
503    $self->{PAGES} ++ ;
504
505    # Select last used font for this pageformat
506    $self->selectDefaultTRC();
507
508    &UPSTAT('GETJOBPAGE');
509
510    &Debug("Composing page number $self->{PAGES}");
511    $self->{LastChannel}  = 1 ;
512    $self->{StartNewPage} = 0 ;
513
514    # To close last pageformat as at least one is inserted
515    $self->{OPENEDPFORMAT}= 1 ;
516}
517
518sub updateFlux {
519    my $self = shift ;
520    my $hashref = shift ;
521    map {
522        if ( ref($hashref->{$_}) =~ /^HASH/ ) {
523            my $key = $_ ;
524            map {
525                $self->{$key}->{$_} = $hashref->{$key}->{$_}
526            } keys(%{$hashref->{$key}}) ;
527
528        } else {
529            $self->{$_} = $hashref->{$_}
530        }
531    } keys(%{$hashref}) ;
532}
533
534sub updateEnv {
535    my $self = shift ;
536    my $hashref = shift ;
537    map { $self->{JOBENV}->{$_} = $hashref->{$_} } keys(%{$hashref}) ;
538}
539
540sub toclean {
541    my $self = shift ;
542    my $toclean = $self->{JOBENV}->{TOCLEAN} ;
543    $toclean .= ';' if $toclean ;
544    $toclean .= shift ;
545    $self->{JOBENV}->{TOCLEAN} = $toclean ;
546}
547
548sub has_pageformat {
549    my $self = shift ;
550    return ( defined($self->{PAGEFORMAT}) and $self->{PAGEFORMAT} ) ? 1 : 0 ;
551}
552
553sub orientations {
554    my $self = shift ;
555    return ( $self->{LANDSCAPE}, $self->{ROTSEGMENT} ) ;
556}
557
558sub issplitted {
559    my $self = shift ;
560    return exists($self->{JOBENV}->{SPLIT_TAG}) ;
561}
562
563sub getEnv {
564    my $self = shift ;
565
566    my $JobEnv = $self->{JOBENV} ;
567
568    # Only return the requested argument value if exists
569    return $JobEnv->{$_[0]} || 0 if ( @_ and defined($_[0]) );
570
571    # Update COPIES as it's not including first print
572    $JobEnv->{COPIES} = scalar($JobEnv->{COPIES}) + 1 ;
573
574    return join('',
575        map {
576            qq|<env key='$_'>| . $JobEnv->{$_} . qq|</env>|
577        } keys(%{$JobEnv}) );
578}
579
580my $yes = qr/^yes$/i ;
581sub getstat {
582    my $self = shift ;
583
584    my $kind = 'P' ; # By default, it's a print
585    my $env = $self->{JOBENV} ;
586
587    if ( defined($env->{ISPRINT}) and ! $env->{ISPRINT} ) {
588        if ( defined($env->{DO_ARCH}) and $env->{DO_ARCH} =~ $yes ) {
589            $kind = 'A' ;
590        }
591        if ( defined($env->{DO_ESERVICE}) and $env->{DO_ESERVICE} =~ $yes ) {
592            $kind = ( $kind eq 'A' )? 'E' : 'S' ;
593        }
594    }
595
596    return ( $env->{JOBNAME}, $env->{DESTID}, $env->{PAGEDEF}, $env->{FORMDEF},
597        $env->{DOCNAME}, join('+',keys(%{$self->{PAGEFORMATs}})),
598        join('+',keys(%{$self->{COPYGROUPs}})),
599        join('+',keys(%{$self->{LOGOs}})),
600        $self->{PAGES} * $env->{COPIES}, $kind, $LOCKID );
601}
602
603sub deloneline {
604    my $self = shift ;
605    return defined( pop( @{$self->{LINES}} ) ) ;
606}
607
608sub LastLineMatch {
609    my $self    = shift ;
610    my $pattern = shift ;
611    my $index   = $#{$self->{LINES}} ;
612    $index -= $_[0] if ($_[0]);
613    return 0 if ( $index < 0 ); # $#{} gives -1 when array is empty or undefined
614    return ${$self->{LINES}}[$index] =~ $pattern ;
615}
616
617sub getoutbase {
618    my $self = shift ;
619    return $self->{OUTFILE} || '' ;
620}
621
622sub setoutfile {
623    my $self    = shift ;
624    my $outfile = shift ;
625    &Debug("Updating OUTFILE='$self->{OUTFILE}' with '$outfile'");
626    $self->{OUTFILE} = $outfile ;
627}
628
629sub setTRCforTeX {
630    my $self    = shift ;
631    my $texcode = shift ;
632    return if (!defined($texcode));
633    return if (length($texcode) == 0);
634    $self->{TRCTeXCode} = "\n" . $texcode . "\n" ;
635    &Debug("TRCTeXCode initialized");
636}
637
638sub setpagedef {
639    my $self    = shift ;
640    my $pagedef = shift ;
641    &Debug("Updating PAGEDEF='$self->{PAGEDEF}' with '$pagedef'");
642    $self->{PAGEDEF} = $pagedef ;
643}
644
645sub pagedef {
646    my $self = shift ;
647    return $self->{PAGEDEF} || "" ;
648}
649
650sub setformdef {
651    my $self    = shift ;
652    my $formdef = shift ;
653    &Debug("Updating FORMDEF='$self->{FORMDEF}' with '$formdef'");
654    $self->{FORMDEF} = $formdef ;
655}
656
657sub setpclcond {
658    my $self = shift ;
659    my $cond = shift ;
660    $cond = 0 if (!defined($cond));
661    &Debug("Updating PCLCOND='$self->{PCLCOND}' with '$cond'");
662    $self->{PCLCOND} = $cond ;
663}
664
665sub gentex {
666    my $self = shift ;
667    my $file = shift ;
668    my $line ;
669    my $index = 0 ;
670    my $pclspecial = "" ;
671
672    # Add automatically EOL to each print command
673    local $\ = "\n" ;
674
675    # Set a localtime mark up
676    $self->{TeXGenTime} = localtime() ;
677
678    # Flush LogoLines if empty new page still exists
679    $self->insertLogos('LASTINSERT') if ( $#{$self->{LogoLines}} >= 0 );
680
681    # PageDef and FormDef should right at that time
682    push @{$self->{texpackages}} , "p1" . lc( $self->{PAGEDEF} ) ;
683    push @{$self->{texpackages}} , "f1" . lc( $self->{FORMDEF} ) ;
684
685    # Check if PCL5 will be generated to define some TeX special command
686    # 1. \pclportrait and \pcllandscape must be set to insert usefull PCL5
687    #    commands
688    # 2. Bin/tray support, define the right \special commands to include
689    #    print specific settings
690    if ($self->{PCLCOND} and ! $USE_PCLCMD ) {
691        my $pcl5cmdpath = "/apps/afp2print/printlib/texlib" ;
692        # PCL5 commands files path can be overided using PCL5CMDPATH ENV
693        $pcl5cmdpath = $ENV{PCL5CMDPATH} if (defined( $ENV{PCL5CMDPATH} ));
694        $pcl5cmdpath =~ s/\/+$// ;
695        $pclspecial =
696            "\\def\\SelectBinTrayA{\\special{" . $self->{OUTFILE} .
697                ".trayone}}\n" .
698            "\\def\\SelectBinTrayB{\\special{" . $self->{OUTFILE} .
699                ".traytwo}}\n\n" .
700            "\\def\\pclportrait{\\special{" .
701                $pcl5cmdpath . "/afp2print_portrait.pcl5}}\n" .
702            "\\def\\pcllandscape{\\special{" .
703                $pcl5cmdpath . "/afp2print_landscape.pcl5}}\n\n" ;
704    }
705
706    # Check LOGO files are existing
707    my $segment_libraries = "" ;
708    foreach my $logo ( @{$self->{LOGOS}} ) {
709        my $thisone = "\\input{$logo}\n" ;
710        if ( -e $logo ) {
711            $logo =~ s/\.def$// ;
712            # Define image base if one exists as .def need it
713            # TODO Add this to test "or -e $logo . '.tif'" when
714            # TIFF will be supported for PCL
715            if ( -e $logo . '.png' ) {
716                $thisone = "\\def\\segbase{$logo}\n" . $thisone ;
717                &Debug("TeX code added to enable PNG image loading");
718            }
719            $segment_libraries .= $thisone ;
720
721        } else {
722            $logo =~ $1 if ( $logo =~ m|([^/]+)$| );
723            &Warn("Won't load $logo segment as not found in library");
724        }
725    }
726
727    # TeX debugging to be used in validation only
728    my $TeXDEBUG = "" ;
729    if ( $ADDTEX_DEBUG ) {
730        $TeXDEBUG .= "\\def\\DEBUG{$ADDTEX_DEBUG}\n" .
731            "\\def\\DEBUGPAGEDEF{$TEX_PAGEDEF_DEBUG}\n" .
732            "\\def\\DEBUGOVERLAY{$TEX_OVERLAY_DEBUG}\n" .
733            "\\def\\DEBUGSEGMENT{$TEX_SEGMENT_DEBUG}\n" .
734            "\\def\\SHOWSEGMENT{$TEX_SHOW_SEGMENT}\n" ;
735    }
736
737    # TeX info
738    my $DocInfo = "" ;
739    if ( $ADDTEX_DOCINFO ) {
740        $DocInfo .= "/Title   (" . $self->{JOBENV}->{JOBNAME} . ")\n"
741            if ($self->{JOBENV}->{JOBNAME});
742        $DocInfo .= "/Author  (" . $self->{JOBENV}->{USERNAME} . ")\n"
743            if ($self->{JOBENV}->{USERNAME});
744        $DocInfo .= "/Creator (A2P v" . A2P_RPM_VERSION . ")\n"
745            if (A2P_RPM_VERSION);
746        $DocInfo = "\n\\ifpdf\n\\pdfinfo{" . $DocInfo . "}\\fi\n" if $DocInfo ;
747    }
748
749    # Insert in first position default definitions package to load for archivage
750    if (defined($self->{JOBENV}->{ISPRINT}) and ! $self->{JOBENV}->{ISPRINT}) {
751        unshift @{$self->{texpackages}}, 'afp2print_archi_pre_def' ;
752    }
753
754    if ( print( $file
755        "\\documentclass{minimal}\n",
756        $self->{PCLCOND} ? "\\def\\pcloutput{1}\n" : "" ,
757        map( "\\usepackage{" . $_ . "}\n" , @{$self->{texpackages}} ) ,
758        $segment_libraries,
759        "\\listfiles\n" ,
760        "%% \n%% AFPDS File: " . $self ->{AFPDSFILE} ,
761        "\n%% FormDef   : "    . $self ->{FORMDEF} ,
762        "\n%% PageDef   : "    . $self ->{PAGEDEF} ,
763        "\n%% TexGenTime: "    . $self ->{TeXGenTime} ,
764        "\n%% \n" ,
765        "\\ResetLength\n" ,$TeXDEBUG , $DocInfo ,
766        $self->{TRCTeXCode} , $pclspecial ,
767        "\\begin{document}\\FONtTrcA% Default font") )
768    {
769        &Debug("Output TeX header done") ;
770    } else {
771        return &Error("Can't output TeX header") ;
772    }
773
774    # Output all lines stripping and compressing some unuseful patterns
775    if ( join('',map { print $file $_ } @{$self->{LINES}}) !~ /^0+$/ ) {
776        &Debug("Output TeX Content done") ;
777    } else {
778        return &Error("Can't output TeX Content") ;
779    }
780
781    # ErAl008w fix support when only close last Pageformat is one opened
782    if ( $self->{OPENEDPFORMAT} ) {
783        print( $file "}%" ) if ($self->{OPENEDCHANNEL});
784        print( $file "}%" );
785    }
786
787    # And add TeX end block to the output
788    if ( print( $file "\\end{document}" )) {
789        &Debug("Output TeX Footer done") ;
790    } else {
791        return &Error("Can't output TeX Footer") ;
792    }
793    return 1 ;
794}
795
796sub got5Achar {
797    my $self = shift ;
798
799    # Create MODCA object
800    my $afpobject = new AFPDS::MODCA( $self, @_ );
801
802    # Check object
803    my @err = $afpobject->check ;
804
805    # Create object on no check error
806    @err = $afpobject->create unless ( @err and defined($err[0]) and $err[0] );
807
808    # Report error as ABTERM if present or return 0
809    return ( @err and defined($err[0]) and $err[0] ) ? $self->ABTERM(@err) : 0 ;
810}
811
812sub setjobindex {
813    my $self = shift ;
814    # Index is starting at 0
815    $self->{JOBINDEX} = ( shift || 1 ) - 1 ;
816}
817
818sub set_resource {
819    my $self = shift ;
820    my $object = shift ;
821
822    # Resource must be a MO:DCA object
823    return $self->{SELECTED_RESOURCE} = ""
824        unless ( ref($object) =~ /^AFPDS::MODCA/ );
825
826    # Keep a uniq TeX/LaTeX name if still not set
827    my $texname = exists($self->{RESOURCE}->{$object->name}) ?
828        $self->{RESOURCE}->{$object->name}->[1] : '' ;
829
830    # Keep a resource number as expected for PCL macro ID
831    my $number = exists($self->{RESOURCE_NUMBER}) ?
832        $self->{RESOURCE_NUMBER} + 1 : 0 ;
833
834    unless ( $texname ) {
835        my $texbase = "JOB" . ( $self->{JOBINDEX} || 0 ) . $object->name ;
836        $texbase =~ y/0-9/a-j/ ;
837        $texname = $texbase ;
838
839        my %existing = map { $self->{RESOURCE}->{$_}->[1] => 1 }
840            keys(%{$self->{RESOURCE}}) ;
841
842        my $index = 0 ;
843        while (++$index) {
844            my $tag = sprintf("%02d",$index);
845            $tag =~ y/0-9/a-j/ ;
846            $texname = $texbase . $tag ;
847            last unless (exists($existing{$texname}));
848        }
849    }
850
851    # Keep buffer reference
852    $self->{RESOURCE}->{$object->name} = [ $object, $texname, $number ] ;
853
854    # Select it as current resource
855    $self->{SELECTED_RESOURCE} = $object->name ;
856
857    # Update resource number for next resource
858    $self->{RESOURCE_NUMBER} = $number ;
859}
860
861sub get_resource {
862    my $self = shift ;
863    my $name = shift || $self->{SELECTED_RESOURCE} ;
864
865    return 0 unless ($name and exists($self->{RESOURCE}->{$name}));
866
867    # Resource must be a MO:DCA object
868    my $object = $self->{RESOURCE}->{$name}->[0] ;
869    return ref($object) =~ /^AFPDS::MODCA/ ? $object : 0 ;
870}
871
872sub resource_texname {
873    my $self = shift ;
874    my $name = shift || $self->{SELECTED_RESOURCE} ;
875
876    return 0 unless ($name and exists($self->{RESOURCE}->{$name}));
877
878    return "InlineResource" . $self->{RESOURCE}->{$name}->[1] ;
879}
880
881sub resource_number {
882    my $self = shift ;
883    my $name = shift || $self->{SELECTED_RESOURCE} ;
884    my $reso = shift || 240 ;
885
886    return undef unless ($name and exists($self->{RESOURCE}->{$name}));
887
888    my $number = $self->{RESOURCE}->{$name}->[2] ;
889    # if a scalar, ref is false
890    if (ref($number)) {
891        if (exists($number->{$reso})) {
892            $number = $number->{$reso} ;
893
894        } else {
895            # Set a new number
896            $number->{$reso} = $self->{RESOURCE_NUMBER} ;
897            $number = $self->{RESOURCE_NUMBER} ++ ;
898        }
899    } else {
900        # Just initialize the number list by resolution
901        $self->{RESOURCE}->{$name}->[2] = { $reso => $number } ;
902    }
903    return $number ;
904}
905
906sub ABTERM {
907    my $self = shift ;
908    @{$self->{ERROR}} = @_ ;
909    &Error($self->{ERROR}->[1]);
910    return - $self->{ERROR}->[0] ;
911}
912
913sub geterror {
914    return @{$_[0]->{ERROR}} ;
915}
916
917sub DESTROY {
918    my $self = shift;
919    my @err  = @{$self->{ERROR}};
920
921    # Free arrays memory
922    map { $self->{$_} = () if (ref($self->{$_}) eq 'ARRAY' ) } keys(%{$self});
923
924    if (@err) {
925        &UPSTAT('GETFLUXERROR');
926        &UPSTAT('GETFLUXERROR-' . $err[0] );
927        &Debug("Conversion object for $self->{JOB} destroyed with error #" .
928            $err[0]);
929
930    } else {
931        &UPSTAT('GETGOODAFPDS');
932        &Debug("Conversion object for $self->{JOB} destroyed");
933    }
934}
935
936&Debug("Module " . __PACKAGE__ . " v$VERSION loaded");
937
9381;
Note: See TracBrowser for help on using the repository browser.