File Coverage

blib/lib/PDF/API3/Compat/API2/Content.pm
Criterion Covered Total %
statement 35 920 3.8
branch 0 286 0.0
condition 0 108 0.0
subroutine 12 123 9.7
pod 72 80 90.0
total 119 1517 7.8


line stmt bran cond sub pod time code
1             #=======================================================================
2             # ____ ____ _____ _ ____ ___ ____
3             # | _ \| _ \| ___| _ _ / \ | _ \_ _| |___ \
4             # | |_) | | | | |_ (_) (_) / _ \ | |_) | | __) |
5             # | __/| |_| | _| _ _ / ___ \| __/| | / __/
6             # |_| |____/|_| (_) (_) /_/ \_\_| |___| |_____|
7             #
8             # A Perl Module Chain to faciliate the Creation and Modification
9             # of High-Quality "Portable Document Format (PDF)" Files.
10             #
11             # Copyright 1999-2005 Alfred Reibenschuh .
12             #
13             #=======================================================================
14             #
15             # This library is free software; you can redistribute it and/or
16             # modify it under the terms of the GNU Lesser General Public
17             # License as published by the Free Software Foundation; either
18             # version 2 of the License, or (at your option) any later version.
19             #
20             # This library is distributed in the hope that it will be useful,
21             # but WITHOUT ANY WARRANTY; without even the implied warranty of
22             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
23             # Lesser General Public License for more details.
24             #
25             # You should have received a copy of the GNU Lesser General Public
26             # License along with this library; if not, write to the
27             # Free Software Foundation, Inc., 59 Temple Place - Suite 330,
28             # Boston, MA 02111-1307, USA.
29             #
30             # $Id: Content.pm,v 2.10 2008/02/15 15:22:41 areibens Exp $
31             #
32             #=======================================================================
33            
34             package PDF::API3::Compat::API2::Content;
35            
36             BEGIN {
37            
38 1     1   8 use strict;
  1         2  
  1         50  
39 1     1   7 use vars qw(@ISA $VERSION);
  1         2  
  1         57  
40 1     1   6 use PDF::API3::Compat::API2::Basic::PDF::Dict;
  1         3  
  1         21  
41 1     1   6 use PDF::API3::Compat::API2::Basic::PDF::Utils;
  1         2  
  1         127  
42 1     1   6 use PDF::API3::Compat::API2::Util;
  1         2  
  1         371  
43 1     1   660 use PDF::API3::Compat::API2::Matrix;
  1         3  
  1         34  
44 1     1   8 use Math::Trig;
  1         2  
  1         281  
45 1     1   5 use Encode;
  1         3  
  1         89  
46 1     1   6 use Compress::Zlib qw[];
  1         2  
  1         63  
47            
48 1     1   19 @ISA = qw(PDF::API3::Compat::API2::Basic::PDF::Dict);
49            
50 1         30 ( $VERSION ) = sprintf '%i.%03i', split(/\./,('$Revision: 2.10 $' =~ /Revision: (\S+)\s/)[0]); # $Date: 2008/02/15 15:22:41 $
51            
52             }
53            
54 1     1   5 no warnings qw[ deprecated recursion uninitialized ];
  1         2  
  1         10749  
55            
56             =head1 $co = PDF::API3::Compat::API2::Content->new @parameters
57            
58             Returns a new content object (called from $page->text/gfx).
59            
60             =cut
61            
62             sub new {
63 0     0 1   my ($class)=@_;
64 0           my $self = $class->SUPER::new(@_);
65 0           $self->{' stream'}='';
66 0           $self->{' poststream'}='';
67 0           $self->{' font'}=undef;
68 0           $self->{' fontset'}=0;
69 0           $self->{' fontsize'}=0;
70 0           $self->{' charspace'}=0;
71 0           $self->{' hspace'}=100;
72 0           $self->{' wordspace'}=0;
73 0           $self->{' lead'}=0;
74 0           $self->{' rise'}=0;
75 0           $self->{' render'}=0;
76 0           $self->{' matrix'}=[1,0,0,1,0,0];
77 0           $self->{' textmatrix'}=[1,0,0,1,0,0];
78 0           $self->{' textlinematrix'}=[0,0];
79 0           $self->{' fillcolor'}=[0];
80 0           $self->{' strokecolor'}=[0];
81 0           $self->{' translate'}=[0,0];
82 0           $self->{' scale'}=[1,1];
83 0           $self->{' skew'}=[0,0];
84 0           $self->{' rotate'}=0;
85 0           $self->{' apiistext'}=0;
86             # $self->save;
87 0           return($self);
88             }
89            
90             sub outobjdeep {
91 0     0 1   my $self = shift @_;
92 0           $self->textend;
93 0           foreach my $k (qw[ api apipdf apiistext apipage font fontset fontsize
94             charspace hspace wordspace lead rise render matrix textmatrix textlinematrix
95             fillcolor strokecolor translate scale skew rotate ])
96             {
97 0           $self->{" $k"}=undef;
98 0           delete($self->{" $k"});
99             }
100 0 0 0       if($self->{-docompress}==1 && $self->{Filter})
101             {
102 0           $self->{' stream'}=Compress::Zlib::compress($self->{' stream'});
103 0           $self->{' nofilt'}=1;
104 0           delete $self->{-docompress};
105             }
106 0           $self->SUPER::outobjdeep(@_);
107             }
108            
109             =item $co->add @content
110            
111             Adds @content to the object.
112            
113             =cut
114            
115             sub add_post
116             {
117 0     0 0   my $self=shift @_;
118 0 0         if(scalar @_>0)
119             {
120 0 0         $self->{' poststream'}.=($self->{' poststream'}=~m|\s$|o?'':' ').join(' ',@_).' ';
121             }
122 0           $self;
123             }
124             sub add
125             {
126 0     0 1   my $self=shift @_;
127 0 0         if(scalar @_>0)
128             {
129 0 0         $self->{' stream'}.=encode("iso-8859-1",($self->{' stream'}=~m|\s$|o?'':' ').join(' ',@_).' ');
130             }
131 0           $self;
132             }
133            
134             =item $co->save
135            
136             Saves the state of the object.
137            
138             =cut
139            
140             sub _save
141             {
142 0     0     return('q');
143             }
144            
145             sub save
146             {
147 0     0 1   my $self=shift @_;
148 0 0 0       unless(defined($self->{' apiistext'}) && $self->{' apiistext'} == 1)
149             {
150 0           $self->add(_save());
151             }
152             }
153            
154             =item $co->restore
155            
156             Restores the state of the object.
157            
158             =cut
159            
160             sub _restore
161             {
162 0     0     return('Q');
163             }
164            
165             sub restore
166             {
167 0     0 1   my $self=shift @_;
168 0 0 0       unless(defined($self->{' apiistext'}) && $self->{' apiistext'} == 1) {
169 0           $self->add(_restore());
170             }
171             }
172            
173             =item $co->compressFlate
174            
175             Marks content for compression on output.
176            
177             =cut
178            
179             sub compressFlate
180             {
181 0     0 1   my $self=shift @_;
182 0           $self->{'Filter'}=PDFArray(PDFName('FlateDecode'));
183 0           $self->{-docompress}=1;
184 0           return($self);
185             }
186            
187             sub metaStart
188             {
189 0     0 0   my $self=shift @_;
190 0           my $tag=shift @_;
191 0           my $obj=shift @_;
192 0           $self->add("/$tag");
193 0 0         if(defined $obj)
194             {
195 0           my $dict=PDFDict();
196 0           $dict->{Metadata}=$obj;
197 0           $self->resource('Properties',$obj->name,$dict);
198 0           $self->add('/'.($obj->name));
199 0           $self->add('BDC');
200             }
201             else
202             {
203 0           $self->add('BMC');
204             }
205 0           return($self);
206             }
207            
208             sub metaEnd
209             {
210 0     0 0   my $self=shift @_;
211 0           $self->add('EMC');
212 0           return($self);
213             }
214            
215             =item $co->flatness $flat
216            
217             Sets flatness.
218            
219             =cut
220            
221             sub _flatness
222             {
223 0     0     my ($flatness)=@_;
224 0           return($flatness,'i');
225             }
226             sub flatness
227             {
228 0     0 1   my ($self,$flatness)=@_;
229 0           $self->add(_flatness($flatness));
230             }
231            
232             =item $co->linecap $cap
233            
234             Sets linecap.
235            
236             =cut
237            
238             sub _linecap
239             {
240 0     0     my ($linecap)=@_;
241 0           return($linecap,'J');
242             }
243             sub linecap
244             {
245 0     0 1   my ($self,$linecap)=@_;
246 0           $self->add(_linecap($linecap));
247             }
248            
249             =item $co->linedash @dash
250            
251             Sets linedash.
252            
253             =cut
254            
255             sub _linedash
256             {
257 0     0     my (@a)=@_;
258 0 0         if(scalar @a < 1)
259             {
260 0           return('[',']','0','d');
261             }
262             else
263             {
264 0 0         if($a[0]=~/^\-/)
265             {
266 0           my %a=@a;
267 0 0 0       $a{-pattern}=[$a{-full}||0,$a{-clear}||0] unless(ref $a{-pattern});
      0        
268 0   0       return('[',floats(@{$a{-pattern}}),']',($a{-shift}||0),'d');
  0            
269             }
270             else
271             {
272 0           return('[',floats(@a),'] 0 d');
273             }
274             }
275             }
276             sub linedash
277             {
278 0     0 1   my ($self,@a)=@_;
279 0           $self->add(_linedash(@a));
280             }
281            
282             =item $co->linejoin $join
283            
284             Sets linejoin.
285            
286             =cut
287            
288             sub _linejoin
289             {
290 0     0     my ($linejoin)=@_;
291 0           return($linejoin,'j');
292             }
293             sub linejoin
294             {
295 0     0 1   my ($this,$linejoin)=@_;
296 0           $this->add(_linejoin($linejoin));
297             }
298            
299             =item $co->linewidth $width
300            
301             Sets linewidth.
302            
303             =cut
304            
305             sub _linewidth
306             {
307 0     0     my ($linewidth)=@_;
308 0           return($linewidth,'w');
309             }
310             sub linewidth
311             {
312 0     0 1   my ($this,$linewidth)=@_;
313 0           $this->add(_linewidth($linewidth));
314             }
315            
316             =item $co->meterlimit $limit
317            
318             Sets meterlimit.
319            
320             =cut
321            
322             sub _meterlimit
323             {
324 0     0     my ($limit)=@_;
325 0           return($limit,'M');
326             }
327             sub meterlimit
328             {
329 0     0 1   my ($this, $limit)=@_;
330 0           $this->add(_meterlimit($limit));
331             }
332            
333             =item $co->matrix $a,$b,$c,$d,$e,$f
334            
335             Sets matrix transformation.
336            
337             =cut
338            
339             sub _matrix_text
340             {
341 0     0     my ($a,$b,$c,$d,$e,$f)=@_;
342 0           return(floats($a,$b,$c,$d,$e,$f),'Tm');
343             }
344             sub _matrix_gfx
345             {
346 0     0     my ($a,$b,$c,$d,$e,$f)=@_;
347 0           return(floats($a,$b,$c,$d,$e,$f),'cm');
348             }
349             sub matrix
350             {
351 0     0 1   my $self=shift @_;
352 0           my ($a,$b,$c,$d,$e,$f)=@_;
353 0 0         if(defined $a)
354             {
355 0 0 0       if(defined($self->{' apiistext'}) && $self->{' apiistext'} == 1)
356             {
357 0           $self->add(_matrix_text($a,$b,$c,$d,$e,$f));
358 0           @{$self->{' textmatrix'}}=($a,$b,$c,$d,$e,$f);
  0            
359 0           @{$self->{' textlinematrix'}}=(0,0);
  0            
360             }
361             else
362             {
363 0           $self->add(_matrix_gfx($a,$b,$c,$d,$e,$f));
364             }
365             }
366 0 0 0       if(defined($self->{' apiistext'}) && $self->{' apiistext'} == 1)
367             {
368 0           return(@{$self->{' textmatrix'}});
  0            
369             }
370             else
371             {
372 0           return($self);
373             }
374             }
375            
376             =item $co->translate $x,$y
377            
378             Sets translation transformation.
379            
380             =cut
381            
382             sub _translate
383             {
384 0     0     my ($x,$y)=@_;
385 0           return(1,0,0,1,$x,$y);
386             }
387             sub translate
388             {
389 0     0 1   my ($self,$x,$y)=@_;
390 0           $self->transform(-translate=>[$x,$y]);
391             }
392            
393             =item $co->scale $sx,$sy
394            
395             Sets scaleing transformation.
396            
397             =cut
398            
399             sub _scale
400             {
401 0     0     my ($x,$y)=@_;
402 0           return($x,0,0,$y,0,0);
403             }
404             sub scale
405             {
406 0     0 1   my ($self,$sx,$sy)=@_;
407 0           $self->transform(-scale=>[$sx,$sy]);
408             }
409            
410             =item $co->skew $sa,$sb
411            
412             Sets skew transformation.
413            
414             =cut
415            
416             sub _skew
417             {
418 0     0     my ($a,$b)=@_;
419 0           return(1, tan(deg2rad($a)),tan(deg2rad($b)),1,0,0);
420             }
421             sub skew
422             {
423 0     0 1   my ($self,$a,$b)=@_;
424 0           $self->transform(-skew=>[$a,$b]);
425             }
426            
427             =item $co->rotate $rot
428            
429             Sets rotation transformation.
430            
431             =cut
432            
433             sub _rotate
434             {
435 0     0     my ($a)=@_;
436 0           return(cos(deg2rad($a)), sin(deg2rad($a)),-sin(deg2rad($a)), cos(deg2rad($a)),0,0);
437             }
438             sub rotate
439             {
440 0     0 1   my ($self,$a)=@_;
441 0           $self->transform(-rotate=>$a);
442             }
443            
444             =item $co->transform %opts
445            
446             Sets transformations (eg. translate, rotate, scale, skew) in pdf-canonical order.
447            
448             B
449            
450             $co->transform(
451             -translate => [$x,$y],
452             -rotate => $rot,
453             -scale => [$sx,$sy],
454             -skew => [$sa,$sb],
455             )
456            
457             =cut
458            
459             sub _transform
460             {
461 0     0     my (%opt)=@_;
462 0           my $mtx=PDF::API3::Compat::API2::Matrix->new([1,0,0],[0,1,0],[0,0,1]);
463 0           foreach my $o (qw( -matrix -skew -scale -rotate -translate )) {
464 0 0         next unless(defined($opt{$o}));
465 0 0         if($o eq '-translate') {
    0          
    0          
    0          
    0          
466 0           my @mx=_translate(@{$opt{$o}});
  0            
467 0           $mtx=$mtx->multiply(PDF::API3::Compat::API2::Matrix->new(
468             [$mx[0],$mx[1],0],
469             [$mx[2],$mx[3],0],
470             [$mx[4],$mx[5],1]
471             ));
472             } elsif($o eq '-rotate') {
473 0           my @mx=_rotate($opt{$o});
474 0           $mtx=$mtx->multiply(PDF::API3::Compat::API2::Matrix->new(
475             [$mx[0],$mx[1],0],
476             [$mx[2],$mx[3],0],
477             [$mx[4],$mx[5],1]
478             ));
479             } elsif($o eq '-scale') {
480 0           my @mx=_scale(@{$opt{$o}});
  0            
481 0           $mtx=$mtx->multiply(PDF::API3::Compat::API2::Matrix->new(
482             [$mx[0],$mx[1],0],
483             [$mx[2],$mx[3],0],
484             [$mx[4],$mx[5],1]
485             ));
486             } elsif($o eq '-skew') {
487 0           my @mx=_skew(@{$opt{$o}});
  0            
488 0           $mtx=$mtx->multiply(PDF::API3::Compat::API2::Matrix->new(
489             [$mx[0],$mx[1],0],
490             [$mx[2],$mx[3],0],
491             [$mx[4],$mx[5],1]
492             ));
493             } elsif($o eq '-matrix') {
494 0           my @mx=@{$opt{$o}};
  0            
495 0           $mtx=$mtx->multiply(PDF::API3::Compat::API2::Matrix->new(
496             [$mx[0],$mx[1],0],
497             [$mx[2],$mx[3],0],
498             [$mx[4],$mx[5],1]
499             ));
500             }
501             }
502 0 0         if($opt{-point})
503             {
504 0           my $mp=PDF::API3::Compat::API2::Matrix->new([$opt{-point}->[0],$opt{-point}->[1],1]);
505 0           $mp=$mp->multiply($mtx);
506 0           return($mp->[0][0],$mp->[0][1]);
507             }
508             return(
509 0           $mtx->[0][0],$mtx->[0][1],
510             $mtx->[1][0],$mtx->[1][1],
511             $mtx->[2][0],$mtx->[2][1]
512             );
513             }
514             sub transform {
515 0     0 1   my ($self,%opt)=@_;
516 0           $self->matrix(_transform(%opt));
517 0 0         if($opt{-translate}) {
518 0           @{$self->{' translate'}}=@{$opt{-translate}};
  0            
  0            
519             } else {
520 0           @{$self->{' translate'}}=(0,0);
  0            
521             }
522 0 0         if($opt{-rotate}) {
523 0           $self->{' rotate'}=$opt{-rotate};
524             } else {
525 0           $self->{' rotate'}=0;
526             }
527 0 0         if($opt{-scale}) {
528 0           @{$self->{' scale'}}=@{$opt{-scale}};
  0            
  0            
529             } else {
530 0           @{$self->{' scale'}}=(1,1);
  0            
531             }
532 0 0         if($opt{-skew}) {
533 0           @{$self->{' skew'}}=@{$opt{-skew}};
  0            
  0            
534             } else {
535 0           @{$self->{' skew'}}=(0,0);
  0            
536             }
537 0           return($self);
538             }
539            
540             =item $co->fillcolor @colors
541            
542             =item $co->strokecolor @colors
543            
544             Sets fill-/strokecolor, see PDF::API3::Compat::API2::Util for a list of possible color specifiers.
545            
546             B
547            
548             $co->fillcolor('blue'); # blue
549             $co->strokecolor('#FF0000'); # red
550             $co->fillcolor('%FFF000000'); # cyan
551            
552             =cut
553            
554             # default colorspaces: rgb/hsv/named cmyk/hsl lab
555             # ... only one text string
556             #
557             # pattern or shading space
558             # ... only one object
559             #
560             # legacy greylevel
561             # ... only one value
562             #
563             #
564            
565             sub _makecolor {
566 0     0     my ($self,$sf,@clr)=@_;
567 0 0 0       if($clr[0]=~/^[a-z\#\!]+/) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
568             # colorname or #! specifier
569             # with rgb target colorspace
570             # namecolor returns always a RGB
571 0 0         return(namecolor($clr[0]),($sf?'rg':'RG'));
572             } elsif($clr[0]=~/^[\%]+/) {
573             # % specifier
574             # with cmyk target colorspace
575 0 0         return(namecolor_cmyk($clr[0]),($sf?'k':'K'));
576             } elsif($clr[0]=~/^[\$\&]/) {
577             # &$ specifier
578             # with L*a*b target colorspace
579 0 0         if(!defined $self->resource('ColorSpace','LabS')) {
580 0           my $dc=PDFDict();
581 0           my $cs=PDFArray(PDFName('Lab'),$dc);
582 0           $dc->{WhitePoint}=PDFArray(map { PDFNum($_) } qw(1 1 1));
  0            
583 0           $dc->{Range}=PDFArray(map { PDFNum($_) } qw(-128 127 -128 127));
  0            
584 0           $dc->{Gamma}=PDFArray(map { PDFNum($_) } qw(2.2 2.2 2.2));
  0            
585 0           $self->resource('ColorSpace','LabS',$cs);
586             }
587 0 0         return('/LabS',($sf?'cs':'CS'),namecolor_lab($clr[0]),($sf?'sc':'SC'));
    0          
588             } elsif((scalar @clr == 1) && ref($clr[0])) {
589             # pattern or shading space
590 0 0         return('/Pattern',($sf?'cs':'CS'),'/'.($clr[0]->name),($sf?'scn':'SCN'));
    0          
591             } elsif(scalar @clr == 1) {
592             # grey color spec.
593 0 0         return($clr[0],($sf?'g':'G'));
594             } elsif(scalar @clr > 1 && ref($clr[0])) {
595             # indexed colorspace plus color-index
596             # or custom colorspace plus param
597 0           my $cs=shift @clr;
598 0 0         return('/'.($cs->name),($sf?'cs':'CS'),$cs->param(@clr),($sf?'sc':'SC'));
    0          
599             } elsif(scalar @clr == 2) {
600             # indexed colorspace plus color-index
601             # or custom colorspace plus param
602 0 0         return('/'.($clr[0]->name),($sf?'cs':'CS'),$clr[0]->param($clr[1]),($sf?'sc':'SC'));
    0          
603             } elsif(scalar @clr == 3) {
604             # legacy rgb color-spec (0 <= x <= 1)
605 0 0         return(floats($clr[0],$clr[1],$clr[2]),($sf?'rg':'RG'));
606             } elsif(scalar @clr == 4) {
607             # legacy cmyk color-spec (0 <= x <= 1)
608 0 0         return(floats($clr[0],$clr[1],$clr[2],$clr[3]),($sf?'k':'K'));
609             } else {
610 0           die 'invalid color specification.';
611             }
612             }
613            
614             sub _fillcolor
615             {
616 0     0     my ($self,@clrs)=@_;
617 0 0         if(ref($clrs[0]) =~ m|^PDF::API3::Compat::API2::Resource::ColorSpace|)
    0          
618             {
619 0           $self->resource('ColorSpace',$clrs[0]->name,$clrs[0]);
620             }
621             elsif(ref($clrs[0]) =~ m|^PDF::API3::Compat::API2::Resource::Pattern|)
622             {
623 0           $self->resource('Pattern',$clrs[0]->name,$clrs[0]);
624             }
625 0           return($self->_makecolor(1,@clrs));
626             }
627             sub fillcolor
628             {
629 0     0 1   my $self=shift @_;
630 0 0         if(scalar @_)
631             {
632 0           @{$self->{' fillcolor'}}=@_;
  0            
633 0           $self->add($self->_fillcolor(@_));
634             }
635 0           return(@{$self->{' fillcolor'}});
  0            
636             }
637            
638             sub _strokecolor
639             {
640 0     0     my ($self,@clrs)=@_;
641 0 0         if(ref($clrs[0]) =~ m|^PDF::API3::Compat::API2::Resource::ColorSpace|)
    0          
642             {
643 0           $self->resource('ColorSpace',$clrs[0]->name,$clrs[0]);
644             }
645             elsif(ref($clrs[0]) =~ m|^PDF::API3::Compat::API2::Resource::Pattern|)
646             {
647 0           $self->resource('Pattern',$clrs[0]->name,$clrs[0]);
648             }
649 0           return($self->_makecolor(0,@clrs));
650             }
651             sub strokecolor
652             {
653 0     0 1   my $self=shift @_;
654 0 0         if(scalar @_)
655             {
656 0           @{$self->{' strokecolor'}}=@_;
  0            
657 0           $self->add($self->_strokecolor(@_));
658             }
659 0           return(@{$self->{' strokecolor'}});
  0            
660             }
661            
662             =head1 GRAPHICS METHODS
663            
664             =over 4
665            
666             =item $gfx->move $x, $y
667            
668             =cut
669            
670             sub _move
671             {
672 0     0     my($x,$y)=@_;
673 0           return(floats($x,$y),'m');
674             }
675             sub move
676             { # x,y ...
677 0     0 1   my $self=shift @_;
678 0           my($x,$y);
679 0           while(defined($x=shift @_))
680             {
681 0           $y=shift @_;
682 0           $self->{' x'}=$x;
683 0           $self->{' y'}=$y;
684 0           $self->{' mx'}=$x;
685 0           $self->{' my'}=$y;
686 0 0 0       if(defined($self->{' apiistext'}) && $self->{' apiistext'} == 1)
687             {
688 0           $self->add_post(floats($x,$y),'m');
689             }
690             else
691             {
692 0           $self->add(floats($x,$y),'m');
693             }
694             }
695 0           return($self);
696             }
697            
698             =item $gfx->line $x, $y
699            
700             =cut
701            
702             sub _line
703             {
704 0     0     my($x,$y)=@_;
705 0           return(floats($x,$y),'l');
706             }
707             sub line
708             { # x,y ...
709 0     0 1   my $self=shift @_;
710 0           my($x,$y);
711 0           while(defined($x=shift @_))
712             {
713 0           $y=shift @_;
714 0           $self->{' x'}=$x;
715 0           $self->{' y'}=$y;
716 0 0 0       if(defined($self->{' apiistext'}) && $self->{' apiistext'} == 1)
717             {
718 0           $self->add_post(floats($x,$y),'l');
719             }
720             else
721             {
722 0           $self->add(floats($x,$y),'l');
723             }
724             }
725 0           return($self);
726             }
727            
728             =item $gfx->hline $x
729            
730             =cut
731            
732             sub hline
733             {
734 0     0 1   my($self,$x)=@_;
735 0 0 0       if(defined($self->{' apiistext'}) && $self->{' apiistext'} == 1)
736             {
737 0           $self->add_post(floats($x,$self->{' y'}),'l');
738             }
739             else
740             {
741 0           $self->add(floats($x,$self->{' y'}),'l');
742             }
743 0           $self->{' x'}=$x;
744 0           return($self);
745             }
746            
747             =item $gfx->vline $y
748            
749             =cut
750            
751             sub vline
752             {
753 0     0 1   my($self,$y)=@_;
754 0 0 0       if(defined($self->{' apiistext'}) && $self->{' apiistext'} == 1)
755             {
756 0           $self->add_post(floats($self->{' x'},$y),'l');
757             }
758             else
759             {
760 0           $self->add(floats($self->{' x'},$y),'l');
761             }
762 0           $self->{' y'}=$y;
763 0           return($self);
764             }
765            
766             =item $gfx->curve $cx1, $cy1, $cx2, $cy2, $x, $y
767            
768             =cut
769            
770             sub curve
771             { # x1,y1,x2,y2,x3,y3 ...
772 0     0 1   my $self=shift @_;
773 0           my($x1,$y1,$x2,$y2,$x3,$y3);
774 0           while(defined($x1=shift @_))
775             {
776 0           $y1=shift @_;
777 0           $x2=shift @_;
778 0           $y2=shift @_;
779 0           $x3=shift @_;
780 0           $y3=shift @_;
781 0 0 0       if(defined($self->{' apiistext'}) && $self->{' apiistext'} == 1)
782             {
783 0           $self->add_post(floats($x1,$y1,$x2,$y2,$x3,$y3),'c');
784             }
785             else
786             {
787 0           $self->add(floats($x1,$y1,$x2,$y2,$x3,$y3),'c');
788             }
789 0           $self->{' x'}=$x3;
790 0           $self->{' y'}=$y3;
791             }
792 0           return($self);
793             }
794            
795             =item $gfx->spline $cx1, $cy1, $x, $y
796            
797             =cut
798            
799             sub spline
800             {
801 0     0 1   my $self=shift @_;
802            
803 0           while(scalar @_ >= 4)
804             {
805 0           my $cx=shift @_;
806 0           my $cy=shift @_;
807 0           my $x=shift @_;
808 0           my $y=shift @_;
809 0           my $c1x=(2*$cx+$self->{' x'})/3;
810 0           my $c1y=(2*$cy+$self->{' y'})/3;
811 0           my $c2x=(2*$cx+$x)/3;
812 0           my $c2y=(2*$cy+$y)/3;
813 0           $self->curve($c1x,$c1y,$c2x,$c2y,$x,$y);
814             }
815             }
816            
817             sub arctocurve
818             {
819 0     0 0   my ($a,$b,$alpha,$beta)=@_;
820 0 0         if(abs($beta-$alpha) > 30)
821             {
822             return (
823 0           arctocurve($a,$b,$alpha,($beta+$alpha)/2),
824             arctocurve($a,$b,($beta+$alpha)/2,$beta)
825             );
826             }
827             else
828             {
829 0           $alpha = ($alpha * pi / 180);
830 0           $beta = ($beta * pi / 180);
831            
832 0           my $bcp = (4.0/3 * (1 - cos(($beta - $alpha)/2)) / sin(($beta - $alpha)/2));
833 0           my $sin_alpha = sin($alpha);
834 0           my $sin_beta = sin($beta);
835 0           my $cos_alpha = cos($alpha);
836 0           my $cos_beta = cos($beta);
837            
838 0           my $p0_x = $a * $cos_alpha;
839 0           my $p0_y = $b * $sin_alpha;
840 0           my $p1_x = $a * ($cos_alpha - $bcp * $sin_alpha);
841 0           my $p1_y = $b * ($sin_alpha + $bcp * $cos_alpha);
842 0           my $p2_x = $a * ($cos_beta + $bcp * $sin_beta);
843 0           my $p2_y = $b * ($sin_beta - $bcp * $cos_beta);
844 0           my $p3_x = $a * $cos_beta;
845 0           my $p3_y = $b * $sin_beta;
846 0           return($p0_x,$p0_y,$p1_x,$p1_y,$p2_x,$p2_y,$p3_x,$p3_y);
847             }
848             }
849            
850             =item $gfx->arc $x, $y, $a, $b, $alfa, $beta, $move
851            
852             will draw an arc centered at x,y with minor/major-axis
853             given by a,b from alfa to beta (degrees). move must be
854             set to 1, unless you want to continue an existing path.
855            
856             =cut
857            
858             sub arc
859             { # x,y,a,b,alf,bet[,mov]
860 0     0 1   my ($self,$x,$y,$a,$b,$alpha,$beta,$move)=@_;
861 0           my @points=arctocurve($a,$b,$alpha,$beta);
862 0           my ($p0_x,$p0_y,$p1_x,$p1_y,$p2_x,$p2_y,$p3_x,$p3_y);
863            
864 0           $p0_x= $x + shift @points;
865 0           $p0_y= $y + shift @points;
866            
867 0 0         $self->move($p0_x,$p0_y) if($move);
868            
869 0           while(scalar @points > 0)
870             {
871 0           $p1_x= $x + shift @points;
872 0           $p1_y= $y + shift @points;
873 0           $p2_x= $x + shift @points;
874 0           $p2_y= $y + shift @points;
875 0           $p3_x= $x + shift @points;
876 0           $p3_y= $y + shift @points;
877 0           $self->curve($p1_x,$p1_y,$p2_x,$p2_y,$p3_x,$p3_y);
878 0           shift @points;
879 0           shift @points;
880 0           $self->{' x'}=$p3_x;
881 0           $self->{' y'}=$p3_y;
882             }
883 0           return($self);
884             }
885            
886             =item $gfx->ellipse $x, $y, $a, $b
887            
888             =cut
889            
890             sub ellipse
891             {
892 0     0 1   my ($self,$x,$y,$a,$b) = @_;
893 0           $self->arc($x,$y,$a,$b,0,360,1);
894 0           $self->close;
895 0           return($self);
896             }
897            
898             =item $gfx->circle $x, $y, $r
899            
900             =cut
901            
902             sub circle
903             {
904 0     0 1   my ($self,$x,$y,$r) = @_;
905 0           $self->arc($x,$y,$r,$r,0,360,1);
906 0           $self->close;
907 0           return($self);
908             }
909            
910             =item $gfx->bogen $x1, $y1, $x2, $y2, $r, $move, $larc, $span
911            
912             will draw an arc of a circle from x1,y1 to x2,y2 with radius r.
913             move must be set to 1, unless you want to continue an existing path.
914             larc can be set to 1, if you want to draw the larger instead of the
915             shorter arc. span can be set to 1, if you want to draw the arc
916             on the other side. NOTE: 2*r cannot be smaller than the distance
917             from x1,y1 to x2,y2.
918            
919             =cut
920            
921             sub bogen
922             { # x1,y1,x2,y2,r[,move[,large-arc[,span-factor]]]
923 0     0 1   my ($self,$x1,$y1,$x2,$y2,$r,$move,$larc,$spf) = @_;
924 0           my ($p0_x,$p0_y,$p1_x,$p1_y,$p2_x,$p2_y,$p3_x,$p3_y);
925 0           my $x=$x2-$x1;
926 0           my $y=$y2-$y1;
927 0           my $z=sqrt($x**2+$y**2);
928 0           my $alfa_rad=asin($y/$z);
929            
930 0 0 0       $alfa_rad+=pi/2 if($x<0 and $y>0);
931 0 0 0       $alfa_rad-=pi/2 if($x<0 and $y<0);
932            
933 0           my $alfa=rad2deg($alfa_rad);
934             # use the complement angle for span
935 0 0         $alfa -= 180 if($spf>0);
936            
937 0           my $d=2*$r;
938 0           my ($beta,$beta_rad,@points);
939            
940 0           $beta=rad2deg(2*asin($z/$d));
941 0 0         $beta=360-$beta if($larc>0);
942            
943 0           $beta_rad=deg2rad($beta);
944            
945 0           @points=arctocurve($r,$r,90+$alfa+$beta/2,90+$alfa-$beta/2);
946            
947 0 0         if($spf>0)
948             {
949 0           my @pts=@points;
950 0           @points=();
951 0           while($y=pop @pts){
952 0           $x=pop @pts;
953 0           push(@points,$x,$y);
954             }
955             }
956            
957 0           $p0_x=shift @points;
958 0           $p0_y=shift @points;
959 0           $x=$x1-$p0_x;
960 0           $y=$y1-$p0_y;
961            
962 0 0         $self->move($x,$y) if($move);
963            
964 0           while(scalar @points > 0)
965             {
966 0           $p1_x= $x + shift @points;
967 0           $p1_y= $y + shift @points;
968 0           $p2_x= $x + shift @points;
969 0           $p2_y= $y + shift @points;
970             # if we run out of data points, use the end point instead
971 0 0         if (scalar @points == 0) {
972 0           $p3_x = $x2;
973 0           $p3_y = $y2;
974             } else {
975 0           $p3_x= $x + shift @points;
976 0           $p3_y= $y + shift @points;
977             }
978 0           $self->curve($p1_x,$p1_y,$p2_x,$p2_y,$p3_x,$p3_y);
979 0           shift @points;
980 0           shift @points;
981             }
982 0           return($self);
983             }
984            
985             =item $gfx->pie $x, $y, $a, $b, $alfa, $beta
986            
987             =cut
988            
989             sub pie
990             {
991 0     0 1   my $self=shift @_;
992 0           my ($x,$y,$a,$b,$alfa,$beta)=@_;
993 0           my ($p0_x,$p0_y)=arctocurve($a,$b,$alfa,$beta);
994 0           $self->move($x,$y);
995 0           $self->line($p0_x+$x,$p0_y+$y);
996 0           $self->arc($x,$y,$a,$b,$alfa,$beta);
997 0           $self->close;
998             }
999            
1000             =item $gfx->rect $x1,$y1, $w1,$h1, ..., $xn,$yn, $wn,$hn
1001            
1002             =cut
1003            
1004             sub rect
1005             { # x,y,w,h ...
1006 0     0 1   my $self=shift @_;
1007 0           my($x,$y,$w,$h);
1008 0           while(defined($x=shift @_))
1009             {
1010 0           $y=shift @_;
1011 0           $w=shift @_;
1012 0           $h=shift @_;
1013 0           $self->add(floats($x,$y,$w,$h),'re');
1014             }
1015 0           $self->{' x'}=$x;
1016 0           $self->{' y'}=$y;
1017 0           return($self);
1018             }
1019            
1020             =item $gfx->rectxy $x1,$y1, $x2,$y2
1021            
1022             =cut
1023            
1024             sub rectxy
1025             {
1026 0     0 1   my ($self,$x,$y,$x2,$y2)=@_;
1027 0           $self->rect($x,$y,($x2-$x),($y2-$y));
1028 0           return($self);
1029             }
1030            
1031             =item $gfx->poly $x1,$y1, ..., $xn,$yn
1032            
1033             =cut
1034            
1035             sub poly
1036             {
1037 0     0 1   my $self=shift @_;
1038 0           my($x,$y);
1039 0           $x=shift @_;
1040 0           $y=shift @_;
1041 0           $self->move($x,$y);
1042 0           $self->line(@_);
1043 0           return($self);
1044             }
1045            
1046             =item $gfx->close
1047            
1048             =cut
1049            
1050             sub close
1051             {
1052 0     0 1   my $self=shift @_;
1053 0           $self->add('h');
1054 0           $self->{' x'}=$self->{' mx'};
1055 0           $self->{' y'}=$self->{' my'};
1056 0           return($self);
1057             }
1058            
1059             =item $gfx->endpath
1060            
1061             =cut
1062            
1063             sub endpath
1064             {
1065 0     0 1   my $self=shift @_;
1066 0           $self->add('n');
1067 0           return($self);
1068             }
1069            
1070             =item $gfx->clip $nonzero
1071            
1072             =cut
1073            
1074             sub clip
1075             { # nonzero
1076 0     0 1   my $self=shift @_;
1077 0 0         $self->add(!(shift @_)?'W':'W*');
1078 0           return($self);
1079             }
1080            
1081             =item $gfx->stroke
1082            
1083             =cut
1084            
1085             sub _stroke
1086             {
1087 0     0     return('S');
1088             }
1089             sub stroke
1090             {
1091 0     0 1   my $self=shift @_;
1092 0           $self->add(_stroke);
1093 0           return($self);
1094             }
1095            
1096             =item $gfx->fill $nonzero
1097            
1098             =cut
1099            
1100             sub fill
1101             { # nonzero
1102 0     0 1   my $self=shift @_;
1103 0 0         $self->add(!(shift @_)?'f':'f*');
1104 0           return($self);
1105             }
1106            
1107             =item $gfx->fillstroke $nonzero
1108            
1109             =cut
1110            
1111             sub fillstroke
1112             { # nonzero
1113 0     0 1   my $self=shift @_;
1114 0 0         $self->add(!(shift @_)?'B':'B*');
1115 0           return($self);
1116             }
1117            
1118             =item $gfx->image $imgobj, $x,$y, $w,$h
1119            
1120             =item $gfx->image $imgobj, $x,$y, $scale
1121            
1122             =item $gfx->image $imgobj, $x,$y
1123            
1124             B The width/height or scale given
1125             is in user-space coordinates which is subject to
1126             transformations which may have been specified beforehand.
1127            
1128             Per default this has a 72dpi resolution, so if you want an
1129             image to have a 150 or 300dpi resolution, you should specify
1130             a scale of 72/150 (or 72/300) or adjust width/height accordingly.
1131            
1132             =cut
1133            
1134             sub image
1135             {
1136 0     0 1   my $self=shift @_;
1137 0           my $img=shift @_;
1138 0           my ($x,$y,$w,$h)=@_;
1139 0 0         if(defined $img->{Metadata})
1140             {
1141 0           $self->metaStart('PPAM:PlacedImage',$img->{Metadata});
1142             }
1143 0           $self->save;
1144 0 0         if(!defined $w)
    0          
1145             {
1146 0           $h=$img->height;
1147 0           $w=$img->width;
1148             }
1149             elsif(!defined $h)
1150             {
1151 0           $h=$img->height*$w;
1152 0           $w=$img->width*$w;
1153             }
1154 0           $self->matrix($w,0,0,$h,$x,$y);
1155 0           $self->add("/".$img->name,'Do');
1156 0           $self->restore;
1157 0           $self->{' x'}=$x;
1158 0           $self->{' y'}=$y;
1159 0           $self->resource('XObject',$img->name,$img);
1160 0 0         if(defined $img->{Metadata})
1161             {
1162 0           $self->metaEnd;
1163             }
1164 0           return($self);
1165             }
1166            
1167             =item $gfx->formimage $imgobj, $x, $y, $scale
1168            
1169             =item $gfx->formimage $imgobj, $x, $y
1170            
1171             Places the X-Object (or XO-Form) at x/y with optional scale.
1172            
1173             =cut
1174            
1175             sub formimage
1176             {
1177 0     0 1   my $self=shift @_;
1178 0           my $img=shift @_;
1179 0           my ($x,$y,$s)=@_;
1180 0           $self->save;
1181 0 0         if(!defined $s)
1182             {
1183 0           $self->matrix(1,0,0,1,$x,$y);
1184             }
1185             else
1186             {
1187 0           $self->matrix($s,0,0,$s,$x,$y);
1188             }
1189 0           $self->add("/".$img->name,'Do');
1190 0           $self->restore;
1191 0           $self->resource('XObject',$img->name,$img);
1192 0           return($self);
1193             }
1194            
1195             =item $gfx->shade $shadeobj, $x1,$y1, $x2,$y2
1196            
1197             =cut
1198            
1199             sub shade
1200             {
1201 0     0 1   my $self=shift @_;
1202 0           my $shade=shift @_;
1203 0           my @cord=@_;
1204 0           my @tm=(
1205             $cord[2]-$cord[0] , 0,
1206             0 , $cord[3]-$cord[1],
1207             $cord[0] , $cord[1]
1208             );
1209 0           $self->save;
1210 0           $self->matrix(@tm);
1211 0           $self->add("/".$shade->name,'sh');
1212            
1213 0           $self->resource('Shading',$shade->name,$shade);
1214            
1215 0           $self->restore;
1216 0           return($self);
1217             }
1218            
1219             =item $gfx->egstate $egsobj
1220            
1221             =cut
1222            
1223             sub egstate
1224             {
1225 0     0 1   my $self=shift @_;
1226 0           my $egs=shift @_;
1227 0           $self->add("/".$egs->name,'gs');
1228 0           $self->resource('ExtGState',$egs->name,$egs);
1229 0           return($self);
1230             }
1231            
1232             =item $hyb->textstart
1233            
1234             =cut
1235            
1236             sub textstart
1237             {
1238 0     0 1   my ($self)=@_;
1239 0 0 0       if(!defined($self->{' apiistext'}) || $self->{' apiistext'} != 1)
1240             {
1241 0           $self->add(' BT ');
1242 0           $self->{' apiistext'}=1;
1243 0           $self->{' font'}=undef;
1244 0           $self->{' fontset'}=0;
1245 0           $self->{' fontsize'}=0;
1246 0           $self->{' charspace'}=0;
1247 0           $self->{' hspace'}=100;
1248 0           $self->{' wordspace'}=0;
1249 0           $self->{' lead'}=0;
1250 0           $self->{' rise'}=0;
1251 0           $self->{' render'}=0;
1252 0           @{$self->{' matrix'}}=(1,0,0,1,0,0);
  0            
1253 0           @{$self->{' textmatrix'}}=(1,0,0,1,0,0);
  0            
1254 0           @{$self->{' textlinematrix'}}=(0,0);
  0            
1255 0           @{$self->{' fillcolor'}}=(0);
  0            
1256 0           @{$self->{' strokecolor'}}=(0);
  0            
1257 0           @{$self->{' translate'}}=(0,0);
  0            
1258 0           @{$self->{' scale'}}=(1,1);
  0            
1259 0           @{$self->{' skew'}}=(0,0);
  0            
1260 0           $self->{' rotate'}=0;
1261             }
1262 0           return($self);
1263             }
1264            
1265             =item %state = $txt->textstate %state
1266            
1267             Sets or gets the current text-object state.
1268            
1269             =cut
1270            
1271             sub textstate
1272             {
1273 0     0 1   my $self=shift @_;
1274 0           my %state;
1275 0 0         if(scalar @_)
1276             {
1277 0           %state=@_;
1278 0           foreach my $k (qw( charspace hspace wordspace lead rise render ))
1279             {
1280 0 0         next unless($state{$k});
1281 0           $self->can($k)->($self, $state{$k});
1282             }
1283 0 0 0       if($state{font} && $state{fontsize})
1284             {
1285 0           $self->font($state{font},$state{fontsize});
1286             }
1287 0 0         if($state{textmatrix})
1288             {
1289 0           $self->matrix(@{$state{textmatrix}});
  0            
1290 0           @{$self->{' translate'}}=@{$state{translate}};
  0            
  0            
1291 0           $self->{' rotate'}=$state{rotate};
1292 0           @{$self->{' scale'}}=@{$state{scale}};
  0            
  0            
1293 0           @{$self->{' skew'}}=@{$state{skew}};
  0            
  0            
1294             }
1295 0 0         if($state{fillcolor})
1296             {
1297 0           $self->fillcolor(@{$state{fillcolor}});
  0            
1298             }
1299 0 0         if($state{strokecolor})
1300             {
1301 0           $self->strokecolor(@{$state{strokecolor}});
  0            
1302             }
1303 0           %state=();
1304             }
1305             else
1306             {
1307 0           foreach my $k (qw( font fontsize charspace hspace wordspace lead rise render ))
1308             {
1309 0           $state{$k}=$self->{" $k"};
1310             }
1311 0           $state{matrix}=[@{$self->{" matrix"}}];
  0            
1312 0           $state{textmatrix}=[@{$self->{" textmatrix"}}];
  0            
1313 0           $state{textlinematrix}=[@{$self->{" textlinematrix"}}];
  0            
1314 0           $state{rotate}=$self->{" rotate"};
1315 0           $state{scale}=[@{$self->{" scale"}}];
  0            
1316 0           $state{skew}=[@{$self->{" skew"}}];
  0            
1317 0           $state{translate}=[@{$self->{" translate"}}];
  0            
1318 0           $state{fillcolor}=[@{$self->{" fillcolor"}}];
  0            
1319 0           $state{strokecolor}=[@{$self->{" strokecolor"}}];
  0            
1320             }
1321 0           return(%state);
1322             }
1323            
1324             sub textstate2
1325             {
1326 0     0 0   my $self=shift @_;
1327 0           my %state;
1328 0 0         if(scalar @_)
1329             {
1330 0           %state=@_;
1331 0           foreach my $k (qw[ charspace hspace wordspace lead rise render ])
1332             {
1333 0 0         next unless($state{$k});
1334 0 0         if($self->{" $k"} ne $state{$k})
1335             {
1336 0           $self->can($k)->($self, $state{$k});
1337             }
1338             }
1339 0 0 0       if($state{font} && $state{fontsize})
1340             {
1341 0 0 0       if($self->{" font"} ne $state{font} || $self->{" fontsize"} ne $state{fontsize})
1342             {
1343 0           $self->font($state{font},$state{fontsize});
1344             }
1345             }
1346 0 0         if($state{fillcolor})
1347             {
1348 0           $self->fillcolor(@{$state{fillcolor}});
  0            
1349             }
1350 0 0         if($state{strokecolor})
1351             {
1352 0           $self->strokecolor(@{$state{strokecolor}});
  0            
1353             }
1354 0           %state=();
1355             }
1356             else
1357             {
1358 0           foreach my $k (qw[ font fontsize charspace hspace wordspace lead rise render ])
1359             {
1360 0           $state{$k}=$self->{" $k"};
1361             }
1362 0           $state{fillcolor}=[@{$self->{" fillcolor"}}];
  0            
1363 0           $state{strokecolor}=[@{$self->{" strokecolor"}}];
  0            
1364             }
1365 0           return(%state);
1366             }
1367            
1368             =item ($tx,$ty) = $txt->textpos
1369            
1370             Gets the current estimated text position.
1371            
1372             B This is relative to text-space.
1373            
1374             =cut
1375            
1376             sub _textpos
1377             {
1378 0     0     my ($self,@xy)=@_;
1379 0           my ($x,$y)=(0,0);
1380 0           while(scalar @xy > 0)
1381             {
1382 0           $x+=shift @xy;
1383 0           $y+=shift @xy;
1384             }
1385 0           my (@m)=_transform(
1386             -matrix=>$self->{" textmatrix"},
1387             -point=>[$x,$y]
1388             );
1389 0           return($m[0],$m[1]);
1390             }
1391             sub textpos
1392             {
1393 0     0 1   my $self=shift @_;
1394 0           return($self->_textpos(@{$self->{" textlinematrix"}}));
  0            
1395             }
1396             sub textpos2
1397             {
1398 0     0 0   my $self=shift @_;
1399 0           return(@{$self->{" textlinematrix"}});
  0            
1400             }
1401            
1402             =item $txt->transform_rel %opts
1403            
1404             Sets transformations (eg. translate, rotate, scale, skew) in pdf-canonical order,
1405             but relative to the previously set values.
1406            
1407             B
1408            
1409             $txt->transform_rel(
1410             -translate => [$x,$y],
1411             -rotate => $rot,
1412             -scale => [$sx,$sy],
1413             -skew => [$sa,$sb],
1414             )
1415            
1416             =cut
1417            
1418             sub transform_rel {
1419 0     0 1   my ($self,%opt)=@_;
1420 0 0         my ($sa1,$sb1)=@{$opt{-skew} ? $opt{-skew} : [0,0]};
  0            
1421 0           my ($sa0,$sb0)=@{$self->{" skew"}};
  0            
1422            
1423            
1424 0 0         my ($sx1,$sy1)=@{$opt{-scale} ? $opt{-scale} : [1,1]};
  0            
1425 0           my ($sx0,$sy0)=@{$self->{" scale"}};
  0            
1426            
1427 0   0       my $rot1=$opt{"-rotate"} || 0;
1428 0           my $rot0=$self->{" rotate"};
1429            
1430 0 0         my ($tx1,$ty1)=@{$opt{-translate} ? $opt{-translate} : [0,0]};
  0            
1431 0           my ($tx0,$ty0)=@{$self->{" translate"}};
  0            
1432            
1433 0           $self->transform(
1434             -skew=>[$sa0+$sa1,$sb0+$sb1],
1435             -scale=>[$sx0*$sx1,$sy0*$sy1],
1436             -rotate=>$rot0+$rot1,
1437             -translate=>[$tx0+$tx1,$ty0+$ty1],
1438             );
1439 0           return($self);
1440             }
1441            
1442             sub matrix_update {
1443 1     1   16 use PDF::API3::Compat::API2::Matrix;
  1         2  
  1         3569  
1444 0     0 0   my ($self,$tx,$ty)=@_;
1445 0           $self->{' textlinematrix'}->[0]+=$tx;
1446 0           $self->{' textlinematrix'}->[1]+=$ty;
1447 0           return($self);
1448             }
1449            
1450             =item $txt->font $fontobj,$size
1451            
1452             =item $txt->fontset $fontobj,$size
1453            
1454             I
1455             which will later be done by the text-methods.>
1456            
1457             B
1458            
1459             =cut
1460            
1461             sub _font
1462             {
1463 0     0     my ($font,$size)=@_;
1464 0 0         if($font->isvirtual == 1)
1465             {
1466 0           return('/'.$font->fontlist->[0]->name.' '.float($size).' Tf');
1467             }
1468             else
1469             {
1470 0           return('/'.$font->name.' '.float($size).' Tf');
1471             }
1472             }
1473             sub font
1474             {
1475 0     0 1   my ($self,$font,$size)=@_;
1476 0           $self->fontset($font,$size);
1477 0           $self->add(_font($font,$size));
1478 0           $self->{' fontset'}=1;
1479 0           return($self);
1480             }
1481            
1482             sub fontset {
1483 0     0 1   my ($self,$font,$size)=@_;
1484 0           $self->{' font'}=$font;
1485 0           $self->{' fontsize'}=$size;
1486 0           $self->{' fontset'}=0;
1487            
1488 0 0         if($font->isvirtual == 1)
1489             {
1490 0           foreach my $f (@{$font->fontlist})
  0            
1491             {
1492 0           $self->resource('Font',$f->name,$f);
1493             }
1494             }
1495             else
1496             {
1497 0           $self->resource('Font',$font->name,$font);
1498             }
1499            
1500 0           return($self);
1501             }
1502            
1503             =item $spacing = $txt->charspace $spacing
1504            
1505             =cut
1506            
1507             sub _charspace
1508             {
1509 0     0     my ($para)=@_;
1510 0           return(float($para,6).' Tc');
1511             }
1512             sub charspace
1513             {
1514 0     0 1   my ($self,$para)=@_;
1515 0 0         if(defined $para)
1516             {
1517 0           $self->{' charspace'}=$para;
1518 0           $self->add(_charspace($para));
1519             }
1520 0           return $self->{' charspace'};
1521             }
1522            
1523             =item $spacing = $txt->wordspace $spacing
1524            
1525             =cut
1526            
1527             sub _wordspace
1528             {
1529 0     0     my ($para)=@_;
1530 0           return(float($para,6).' Tw');
1531             }
1532             sub wordspace {
1533 0     0 1   my ($self,$para)=@_;
1534 0 0         if(defined $para)
1535             {
1536 0           $self->{' wordspace'}=$para;
1537 0           $self->add(_wordspace($para));
1538             }
1539 0           return $self->{' wordspace'};
1540             }
1541            
1542             =item $spacing = $txt->hspace $spacing
1543            
1544             =cut
1545            
1546             sub _hspace
1547             {
1548 0     0     my ($para)=@_;
1549 0           return(float($para,6).' Tz');
1550             }
1551             sub hspace
1552             {
1553 0     0 1   my ($self,$para)=@_;
1554 0 0         if(defined $para)
1555             {
1556 0           $self->{' hspace'}=$para;
1557 0           $self->add(_hspace($para));
1558             }
1559 0           return $self->{' hspace'};
1560             }
1561            
1562             =item $leading = $txt->lead $leading
1563            
1564             =cut
1565            
1566             sub _lead
1567             {
1568 0     0     my ($para)=@_;
1569 0           return(float($para).' TL');
1570             }
1571             sub lead
1572             {
1573 0     0 1   my ($self,$para)=@_;
1574 0 0         if (defined ($para))
1575             {
1576 0           $self->{' lead'} = $para;
1577 0           $self->add(_lead($para));
1578             }
1579 0           return $self->{' lead'};
1580             }
1581            
1582             =item $rise = $txt->rise $rise
1583            
1584             =cut
1585            
1586             sub _rise
1587             {
1588 0     0     my ($para)=@_;
1589 0           return(float($para).' Ts');
1590             }
1591             sub rise
1592             {
1593 0     0 1   my ($self,$para)=@_;
1594 0 0         if (defined ($para))
1595             {
1596 0           $self->{' rise'} = $para;
1597 0           $self->add(_rise($para));
1598             }
1599 0           return $self->{' rise'};
1600             }
1601            
1602             =item $rendering = $txt->render $rendering
1603            
1604             =cut
1605            
1606             sub _render
1607             {
1608 0     0     my ($para)=@_;
1609 0           return(intg($para).' Tr');
1610             }
1611             sub render
1612             {
1613 0     0 1   my ($self,$para)=@_;
1614 0 0         if (defined ($para))
1615             {
1616 0           $self->{' render'} = $para;
1617 0           $self->add(_render($para));
1618             }
1619 0           return $self->{' render'};
1620             }
1621            
1622             =item $txt->cr $linesize
1623            
1624             takes an optional argument giving a custom leading between lines.
1625            
1626             =cut
1627            
1628             sub cr
1629             {
1630 0     0 1   my ($self,$para)=@_;
1631 0 0         if(defined($para))
1632             {
1633 0           $self->add(0,float($para),'Td');
1634 0           $self->matrix_update(0,$para);
1635             }
1636             else
1637             {
1638 0           $self->add('T*');
1639 0           $self->matrix_update(0,$self->lead);
1640             }
1641 0           $self->{' textlinematrix'}->[0]=0;
1642             }
1643            
1644             =item $txt->nl
1645            
1646             =cut
1647            
1648             sub nl
1649             {
1650 0     0 1   my ($self,$width)=@_;
1651 0           $self->add('T*');
1652 0   0       $self->matrix_update(-($width||0),-$self->lead);
1653 0           $self->{' textlinematrix'}->[0]=0;
1654             }
1655            
1656             =item $txt->distance $dx,$dy
1657            
1658             =cut
1659            
1660             sub distance
1661             {
1662 0     0 1   my ($self,$dx,$dy)=@_;
1663 0           $self->add(float($dx),float($dy),'Td');
1664 0           $self->matrix_update($dx,$dy);
1665 0           $self->{' textlinematrix'}->[0]=$dx;
1666             }
1667            
1668             =item $width = $txt->advancewidth $string [, %textstate]
1669            
1670             Returns the width of the string based on all currently set text-attributes
1671             or on those overridden by %textstate.
1672            
1673             =cut
1674            
1675             sub advancewidth
1676             {
1677 0     0 1   my ($self,$text,@opts)=@_;
1678 0 0         if(scalar @opts > 1)
1679             {
1680 0           my %opts=@opts;
1681 0           foreach my $k (qw[ font fontsize wordspace charspace hspace])
1682             {
1683 0 0         $opts{$k}=$self->{" $k"} unless(defined $opts{$k});
1684             }
1685 0           my $glyph_width=$opts{font}->width($text)*$opts{fontsize};
1686 0           my $num_space = $text =~ y/\x20/\x20/;
1687 0           my $num_char=length($text);
1688 0           my $word_spaces=$opts{wordspace}*$num_space;
1689 0           my $char_spaces=$opts{charspace}*$num_char;
1690 0           my $advance=($glyph_width+$word_spaces+$char_spaces)*$opts{hspace}/100;
1691 0           return $advance;
1692             }
1693             else
1694             {
1695 0           my $glyph_width=$self->{' font'}->width($text)*$self->{' fontsize'};
1696 0           my $num_space = $text =~ y/\x20/\x20/;
1697 0           my $num_char=length($text);
1698 0           my $word_spaces=$self->wordspace*$num_space;
1699 0           my $char_spaces=$self->charspace*$num_char;
1700 0           my $advance=($glyph_width+$word_spaces+$char_spaces)*$self->hspace/100;
1701 0           return $advance;
1702             }
1703             }
1704            
1705             =item $width = $txt->text $text, %options
1706            
1707             Applys text to the content and optionally returns the width of the given text.
1708            
1709             Options
1710            
1711             =ovar 4
1712            
1713             =item -indent
1714            
1715             Indent the text by the number of points.
1716            
1717             =item -underline
1718            
1719             If this is a scalar, it is the distance, in points, below the baseline where
1720             the line is drawn. The line thickness is one point. If it is a reference to an
1721             array, each pair is the distance below the baseline and the thickness of the
1722             line (ie., C<-underline=E[2,1,4,2]> will draw a double underline
1723             with the lower twice as thick as the upper).
1724            
1725             If thickness is a reference to an array, the first value is the thickness
1726             and the second value is the color of the line (ie.,
1727             C<-underline=E[2,[1,'red'],4,[2,'#0000ff']]> will draw a "red" and a
1728             "blue" line).
1729            
1730             You can also use the string C<'auto'> for either or both distance and thickness
1731             values to auto-magically calculate best values from the font-definition.
1732            
1733             =back
1734            
1735             =cut
1736            
1737             sub _text_underline
1738             {
1739 0     0     my ($self,$xy1,$xy2,$underline,$color)=@_;
1740 0   0       $color||='black';
1741 0           my @underline=();
1742 0 0         if(ref($underline) eq 'ARRAY')
1743             {
1744 0           @underline=@{$underline};
  0            
1745             }
1746             else
1747             {
1748 0           @underline=($underline,1);
1749             }
1750 0 0         push @underline,1 if(@underline%2);
1751            
1752 0   0       my $underlineposition=(-$self->{' font'}->underlineposition()*$self->{' fontsize'}/1000||1);
1753 0   0       my $underlinethickness=($self->{' font'}->underlinethickness()*$self->{' fontsize'}/1000||1);
1754 0           my $pos=1;
1755            
1756 0           while(@underline)
1757             {
1758 0           $self->add_post(_save);
1759            
1760 0           my $distance=shift @underline;
1761 0           my $thickness=shift @underline;
1762 0           my $scolor=$color;
1763 0 0         if(ref $thickness)
1764             {
1765 0           ($thickness,$scolor)=@{$thickness};
  0            
1766             }
1767            
1768 0 0         if($distance eq 'auto')
1769             {
1770 0           $distance=$pos*$underlineposition;
1771             }
1772 0 0         if($thickness eq 'auto')
1773             {
1774 0           $thickness=$underlinethickness;
1775             }
1776            
1777 0           my ($x1,$y1)=$self->_textpos(@{$xy1},0,-($distance+($thickness/2)));
  0            
1778 0           my ($x2,$y2)=$self->_textpos(@{$xy2},0,-($distance+($thickness/2)));
  0            
1779            
1780 0           $self->add_post($self->_strokecolor($scolor));
1781 0           $self->add_post(_linewidth($thickness));
1782 0           $self->add_post(_move($x1,$y1));
1783 0           $self->add_post(_line($x2,$y2));
1784 0           $self->add_post(_stroke);
1785            
1786 0           $self->add_post(_restore);
1787 0           $pos++;
1788             }
1789             }
1790            
1791             sub text
1792             {
1793 0     0 1   my ($self,$text,%opt)=@_;
1794 0           my $wd=0;
1795 0 0         if($self->{' fontset'}==0)
1796             {
1797 0           $self->font($self->{' font'},$self->{' fontsize'});
1798 0           $self->{' fontset'}=1;
1799             }
1800 0 0         if(defined $opt{-indent})
1801             {
1802 0           $wd+=$opt{-indent};
1803 0           $self->matrix_update($wd,0);
1804             }
1805 0           my $ulxy1=[$self->textpos2];
1806            
1807 0 0         if(defined $opt{-indent})
1808             {
1809             # changed fot acrobat 8 and possible others
1810             # $self->add('[',(-$opt{-indent}*(1000/$self->{' fontsize'})*(100/$self->hspace)),']','TJ');
1811 0           $self->add($self->{' font'}->text($text, $self->{' fontsize'}, (-$opt{-indent}*(1000/$self->{' fontsize'})*(100/$self->hspace))));
1812             }
1813             else
1814             {
1815 0           $self->add($self->{' font'}->text($text,$self->{' fontsize'}));
1816             }
1817            
1818 0           $wd=$self->advancewidth($text);
1819 0           $self->matrix_update($wd,0);
1820            
1821 0           my $ulxy2=[$self->textpos2];
1822            
1823 0 0         if(defined $opt{-underline})
1824             {
1825 0           $self->_text_underline($ulxy1,$ulxy2,$opt{-underline},$opt{-strokecolor});
1826             }
1827            
1828 0           return($wd);
1829             }
1830            
1831             =item $txt->text_center $text
1832            
1833             =cut
1834            
1835             sub text_center
1836             {
1837 0     0 1   my ($self,$text,@opts)=@_;
1838 0           my $width=$self->advancewidth($text);
1839 0           return $self->text($text,-indent=>-($width/2),@opts);
1840             }
1841            
1842             =item $txt->text_right $text, %options
1843            
1844             =cut
1845            
1846             sub text_right
1847             {
1848 0     0 1   my ($self,$text,@opts)=@_;
1849 0           my $width=$self->advancewidth($text);
1850 0           return $self->text($text,-indent=>-$width,@opts);
1851             }
1852            
1853             =item $width = $txt->text_justified $text, $width, %options
1854            
1855             ** DEVELOPER METHOD **
1856            
1857             =cut
1858            
1859             sub text_justified
1860             {
1861 0     0 1   my ($self,$text,$width,%opts)=@_;
1862 0           my $hs=$self->hspace;
1863 0           $self->hspace($hs*($width/$self->advancewidth($text)));
1864 0           $self->text($text,%opts);
1865 0           $self->hspace($hs);
1866 0           return($width);
1867             }
1868            
1869             sub _text_fill_line
1870             {
1871 0     0     my ($self,$text,$width,$over)=@_;
1872 0           my @txt=split(/\x20/,$text);
1873 0           my @line=();
1874 0           local $";
1875 0           $"=' ';
1876 0           while(@txt)
1877             {
1878 0           push @line,(shift @txt);
1879 0 0         last if($self->advancewidth("@line")>$width);
1880             }
1881 0 0 0       if(!$over && (scalar @line > 1) && ($self->advancewidth("@line") > $width))
      0        
1882             {
1883 0           unshift @txt,pop @line;
1884             }
1885 0           my $ret="@txt";
1886 0           my $line="@line";
1887 0           return($line,$ret);
1888             }
1889            
1890            
1891             =item ($width,$chunktext) = $txt->text_fill_left $text, $width
1892            
1893             ** DEVELOPER METHOD **
1894            
1895             =cut
1896            
1897             sub text_fill_left
1898             {
1899 0     0 1   my ($self,$text,$width,%opts)=@_;
1900 0   0       my $over=(not(defined($opts{-spillover}) and $opts{-spillover} == 0));
1901 0           my ($line,$ret)=$self->_text_fill_line($text,$width,$over);
1902 0           $width=$self->text($line,%opts);
1903 0           return($width,$ret);
1904             }
1905            
1906             =item ($width,$chunktext) = $txt->text_fill_center $text, $width, %options
1907            
1908             ** DEVELOPER METHOD **
1909            
1910             =cut
1911            
1912             sub text_fill_center
1913             {
1914 0     0 1   my ($self,$text,$width,%opts)=@_;
1915 0   0       my $over=(not(defined($opts{-spillover}) and $opts{-spillover} == 0));
1916 0           my ($line,$ret)=$self->_text_fill_line($text,$width,$over);
1917 0           $width=$self->text_center($line,%opts);
1918 0           return($width,$ret);
1919             }
1920            
1921             =item ($width,$chunktext) = $txt->text_fill_right $text, $width
1922            
1923             ** DEVELOPER METHOD **
1924            
1925             =cut
1926            
1927             sub text_fill_right
1928             {
1929 0     0 1   my ($self,$text,$width,%opts)=@_;
1930 0   0       my $over=(not(defined($opts{-spillover}) and $opts{-spillover} == 0));
1931 0           my ($line,$ret)=$self->_text_fill_line($text,$width,$over);
1932 0           $width=$self->text_right($line,%opts);
1933 0           return($width,$ret);
1934             }
1935            
1936             =item ($width,$chunktext) = $txt->text_fill_justified $text, $width
1937            
1938             ** DEVELOPER METHOD **
1939            
1940             =cut
1941            
1942             sub text_fill_justified
1943             {
1944 0     0 1   my ($self,$text,$width,%opts)=@_;
1945 0   0       my $over=(not(defined($opts{-spillover}) and $opts{-spillover} == 0));
1946 0           my ($line,$ret)=$self->_text_fill_line($text,$width,$over);
1947 0           my $hs=$self->hspace;
1948 0           my $w=$self->advancewidth($line);
1949 0 0 0       if($ret||$w>=$width)
1950             {
1951 0           $self->hspace($hs*($width/$w));
1952             }
1953 0           $width=$self->text($line,%opts);
1954 0           $self->hspace($hs);
1955 0           return($width,$ret);
1956             }
1957            
1958             =item $overflow_text = $txt->paragraph $text, $width, $height, %options
1959            
1960             ** DEVELOPER METHOD **
1961            
1962             Apply the text within the rectangle and return any leftover text.
1963            
1964             B
1965            
1966             =over 4
1967            
1968             =item -align => $choice
1969            
1970             Choice is 'justified', 'right', 'center', 'left'
1971             Default is 'left'
1972            
1973             =item -underline => $distance
1974            
1975             =item -underline => [ $distance, $thickness, ... ]
1976            
1977             If a scalar, distance below baseline,
1978             else array reference with pairs of distance and line thickness.
1979            
1980             =item -spillover => $over
1981            
1982             Controls if words in a line which exceed the given width should be "spilled over" the bounds or if a new line should be used for this word.
1983            
1984             Over is 1 or 0
1985             Default is 1
1986            
1987             =back
1988            
1989             B
1990            
1991             $txt->font($font,$fontsize);
1992             $txt->lead($lead);
1993             $txt->translate($x,$y);
1994             $overflow = $txt->paragraph( 'long paragraph here ...',
1995             $width,
1996             $y+$lead-$bottom_margin );
1997            
1998             =cut
1999            
2000             sub paragraph
2001             {
2002 0     0 1   my ($self,$text,$width,$height,%opts)=@_;
2003 0           my @line=();
2004 0           my $nwidth=0;
2005 0           my $lead=$self->lead();
2006 0           while(length($text)>0)
2007             {
2008 0 0         last if(($height-=$lead)<0);
2009 0 0         if($opts{-align}=~/^j/i)
    0          
    0          
2010             {
2011 0           ($nwidth,$text)=$self->text_fill_justified($text,$width,%opts);
2012             }
2013             elsif($opts{-align}=~/^r/i)
2014             {
2015 0           ($nwidth,$text)=$self->text_fill_right($text,$width,%opts);
2016             }
2017             elsif($opts{-align}=~/^c/i)
2018             {
2019 0           ($nwidth,$text)=$self->text_fill_center($text,$width,%opts);
2020             }
2021             else
2022             {
2023 0           ($nwidth,$text)=$self->text_fill_left($text,$width,%opts);
2024             }
2025 0           $self->nl;
2026             }
2027            
2028 0 0         if(wantarray)
2029             {
2030 0           return($text,$height);
2031             }
2032 0           return($text);
2033             }
2034            
2035             =item $overflow_text = $txt->section $text, $width, $height, %options
2036            
2037             ** DEVELOPER METHOD **
2038            
2039             Split paragraphs by newline and loop over them, reassemble leftovers
2040             when box is full and apply the text within the rectangle and return
2041             any leftover text.
2042            
2043             =cut
2044            
2045             sub section
2046             {
2047 0     0 1   my ($self,$text,$width,$height,%opts)=@_;
2048 0           my ($para,$overflow) = ("","");
2049            
2050 0           foreach $para (split(/\n/,$text))
2051             {
2052 0 0         if(length($overflow) > 0)
2053             {
2054 0           $overflow .= "\n" . $para;
2055 0           next;
2056             }
2057 0           ($para,$height) = $self->paragraph($para,$width,$height,%opts);
2058 0 0         $overflow .= $para if (length($para) > 0);
2059             }
2060            
2061 0 0         if(wantarray)
2062             {
2063 0           return($overflow,$height);
2064             }
2065 0           return($overflow);
2066             }
2067            
2068             =item $hyb->textend
2069            
2070             =cut
2071            
2072             sub textend {
2073 0     0 1   my ($self)=@_;
2074 0 0         if($self->{' apiistext'} == 1) {
2075 0           $self->add(' ET ',$self->{' poststream'});
2076 0           $self->{' apiistext'}=0;
2077 0           $self->{' poststream'}='';
2078             }
2079 0           return($self);
2080             }
2081            
2082             =item $width = $txt->textlabel $x, $y, $font, $size, $text, %options
2083            
2084             Applys text with options, but without teststart/end
2085             and optionally returns the width of the given text.
2086            
2087             B
2088            
2089             $t = $page->gfx;
2090             $t->textlabel(300,700,$myfont,20,'Page Header',
2091             -rotate => -30,
2092             -color => '#FF0000',
2093             -hspace => 120,
2094             -align => 'center',
2095             );
2096             $t->textlabel(500,500,$myfont,20,'Page Header',
2097             -rotate => 30,
2098             -color => '#0000FF',
2099             -hspace => 80,
2100             -align => 'right',
2101             );
2102            
2103             =cut
2104            
2105             sub textlabel
2106             {
2107 0     0 1   my ($self,$x,$y,$font,$size,$text,%opts,$wht) = @_;
2108 0           my %trans_opts=( -translate => [$x,$y] );
2109 0           my %text_state=();
2110 0 0         $trans_opts{-rotate} = $opts{-rotate} if($opts{-rotate});
2111            
2112 0           my $wastext = $self->{' apiistext'};
2113 0 0         if($wastext) {
2114 0           %text_state=$self->textstate;
2115 0           $self->textend;
2116             }
2117 0           $self->save;
2118 0           $self->textstart;
2119            
2120 0           $self->transform(%trans_opts);
2121            
2122 0 0         $self->fillcolor(ref($opts{-color}) ? @{$opts{-color}} : $opts{-color}) if($opts{-color});
  0 0          
2123 0 0         $self->strokecolor(ref($opts{-strokecolor}) ? @{$opts{-strokecolor}} : $opts{-strokecolor}) if($opts{-strokecolor});
  0 0          
2124            
2125 0           $self->font($font,$size);
2126            
2127 0 0         $self->charspace($opts{-charspace}) if($opts{-charspace});
2128 0 0         $self->hspace($opts{-hspace}) if($opts{-hspace});
2129 0 0         $self->wordspace($opts{-wordspace}) if($opts{-wordspace});
2130 0 0         $self->render($opts{-render}) if($opts{-render});
2131            
2132 0 0 0       if($opts{-right} || $opts{-align}=~/^r/i)
    0 0        
2133             {
2134 0           $wht = $self->text_right($text,%opts);
2135             }
2136             elsif($opts{-center} || $opts{-align}=~/^c/i)
2137             {
2138 0           $wht = $self->text_center($text,%opts);
2139             }
2140             else
2141             {
2142 0           $wht = $self->text($text,%opts);
2143             }
2144            
2145 0           $self->textend;
2146 0           $self->restore;
2147            
2148 0 0         if($wastext) {
2149 0           $self->textstart;
2150 0           $self->textstate(%text_state);
2151             }
2152 0           return($wht);
2153             }
2154            
2155             sub resource
2156             {
2157 0     0 0   my ($self, $type, $key, $obj, $force) = @_;
2158 0 0         if($self->{' apipage'})
2159             {
2160             # we are a content stream on a page.
2161 0           return( $self->{' apipage'}->resource($type, $key, $obj, $force) );
2162             }
2163             else
2164             {
2165             # we are a self-contained content stream.
2166 0   0       $self->{Resources}||=PDFDict();
2167            
2168 0           my $dict=$self->{Resources};
2169 0 0         $dict->realise if(ref($dict)=~/Objind$/);
2170            
2171 0   0       $dict->{$type}||= PDFDict();
2172 0 0         $dict->{$type}->realise if(ref($dict->{$type})=~/Objind$/);
2173 0 0         unless (defined $obj)
2174             {
2175 0   0       return($dict->{$type}->{$key} || undef);
2176             }
2177             else
2178             {
2179 0 0         if($force)
2180             {
2181 0           $dict->{$type}->{$key}=$obj;
2182             }
2183             else
2184             {
2185 0   0       $dict->{$type}->{$key}||=$obj;
2186             }
2187 0           return($dict);
2188             }
2189             }
2190             }
2191            
2192             1;
2193            
2194             __END__