1package Prima::PS::PostScript; 2use strict; 3use warnings; 4use Prima; 5use Prima::PS::Type1; 6use Prima::PS::TempFile; 7use base qw(Prima::PS::Drawable); 8 9sub profile_default 10{ 11 my $def = $_[ 0]-> SUPER::profile_default; 12 my %prf = ( 13 copies => 1, 14 pageDevice => undef, 15 isEPS => 0, 16 ); 17 @$def{keys %prf} = values %prf; 18 return $def; 19} 20 21sub init 22{ 23 my $self = shift; 24 $self-> {isEPS} = 0; 25 $self-> {copies} = 1; 26 my %profile = $self-> SUPER::init(@_); 27 $self-> $_( $profile{$_}) for qw( copies pageDevice isEPS); 28 return %profile; 29} 30 31# internal routines 32 33sub cmd_rgb 34{ 35 my ( $r, $g, $b) = ( 36 int((($_[1] & 0xff0000) >> 16) * 100 / 256 + 0.5) / 100, 37 int((($_[1] & 0xff00) >> 8) * 100 / 256 + 0.5) / 100, 38 int(($_[1] & 0xff)*100/256 + 0.5) / 100); 39 unless ( $_[0]-> {grayscale}) { 40 return "$r $g $b A"; 41 } else { 42 my $i = int( 100 * ( 0.31 * $r + 0.5 * $g + 0.18 * $b) + 0.5) / 100; 43 return "$i G"; 44 } 45} 46 47sub defer_emission 48{ 49 my ($self, $defer) = @_; 50 if ( $defer ) { 51 return if defined $self->{deferred}; 52 if ( length($self-> {ps_data})) { 53 my $d = $self->{ps_data}; 54 $self-> {ps_data} = ''; 55 return $self-> abort_doc unless $self-> spool($d); 56 } 57 58 $self->abort_doc unless $self->{deferred} = Prima::PS::TempFile->new; 59 } else { 60 return unless defined $self->{deferred}; 61 $self-> abort_doc unless delete($self->{deferred})->evacuate( sub { $self-> spool($_[0]) } ); 62 } 63} 64 65sub emit 66{ 67 my $self = $_[0]; 68 return 0 unless $self-> {can_draw}; 69 if ( defined $self->{deferred} ) { 70 unless ($self->{deferred}->write($_[1] . "\n")) { 71 $self->abort_doc; 72 return 0; 73 } 74 } else { 75 $self-> {ps_data} .= $_[1] . "\n"; 76 if ( length($self-> {ps_data}) > 10240) { 77 $self-> abort_doc unless $self-> spool( $self-> {ps_data}); 78 $self-> {ps_data} = ''; 79 } 80 } 81 return 1; 82} 83 84sub change_transform 85{ 86 my ( $self, $gsave ) = @_; 87 return if $self-> {delay}; 88 89 my @tp = $self-> translate; 90 my @cr = $self-> clipRect; 91 my @sc = $self-> scale; 92 my $ro = $self-> rotate; 93 my $rg = $self-> region; 94 $cr[2] -= $cr[0]; 95 $cr[3] -= $cr[1]; 96 my $doClip = grep { $_ != 0 } @cr; 97 my $doTR = grep { $_ != 0 } @tp; 98 my $doSC = grep { $_ != 0 } @sc; 99 100 if ( !$doClip && !$doTR && !$doSC && !$ro) { 101 $self-> emit(':') if $gsave; 102 return; 103 } 104 105 @cr = $self-> pixel2point( @cr); 106 @tp = $self-> pixel2point( @tp); 107 my $mcr3 = -$cr[3]; 108 109 $self-> emit(';') unless $gsave; 110 $self-> emit(':'); 111 $self-> emit(<<CLIP) if $doClip; 112N $cr[0] $cr[1] M 0 $cr[3] L $cr[2] 0 L 0 $mcr3 L X C 113CLIP 114 $self-> emit("@tp T") if $doTR; 115 $self-> emit($rg-> apply_offset) if $rg && !$doClip; 116 $self-> emit("@sc Z") if $doSC; 117 $self-> emit("$ro R") if $ro != 0; 118 $self-> {changed}-> {$_} = 1 for qw(fill linePattern lineWidth lineJoin lineEnd miterLimit font); 119} 120 121sub fill 122{ 123 my ( $self, $code) = @_; 124 my ( $r1, $r2) = ( $self-> rop, $self-> rop2); 125 return if 126 $r1 == rop::NoOper && 127 $r2 == rop::NoOper; 128 129 if ( $r2 != rop::NoOper && $self-> {fpType} ne 'F') { 130 my $bk = 131 ( $r2 == rop::Blackness) ? 0 : 132 ( $r2 == rop::Whiteness) ? 0xffffff : $self-> backColor; 133 134 $self-> {changed}-> {fill} = 1; 135 $self-> emit( $self-> cmd_rgb( $bk)); 136 $self-> emit( $code); 137 } 138 if ( $r1 != rop::NoOper && $self-> {fpType} ne 'B') { 139 my $c = 140 ( $r1 == rop::Blackness) ? 0 : 141 ( $r1 == rop::Whiteness) ? 0xffffff : $self-> color; 142 if ($self-> {changed}-> {fill}) { 143 if ( $self-> {fpType} eq 'F') { 144 $self-> emit( $self-> cmd_rgb( $c)); 145 } else { 146 my ( $r, $g, $b) = ( 147 int((($c & 0xff0000) >> 16) * 100 / 256 + 0.5) / 100, 148 int((($c & 0xff00) >> 8) * 100 / 256 + 0.5) / 100, 149 int(($c & 0xff)*100/256 + 0.5) / 100); 150 if ( $self-> {grayscale}) { 151 my $i = int( 100 * ( 0.31 * $r + 0.5 * $g + 0.18 * $b) + 0.5) / 100; 152 $self-> emit(<<GRAYPAT); 153[\/Pattern \/DeviceGray] SS 154$i Pat_$self->{fpType} SC 155GRAYPAT 156 } else { 157 $self-> emit(<<RGBPAT); 158[\/Pattern \/DeviceRGB] SS 159$r $g $b Pat_$self->{fpType} SC 160RGBPAT 161 } 162 } 163 $self-> {changed}-> {fill} = 0; 164 } 165 $self-> emit( $code); 166 } 167} 168 169sub stroke 170{ 171 my ( $self, $code) = @_; 172 173 my ( $r1, $r2) = ( $self-> rop, $self-> rop2); 174 my $lp = $self-> linePattern; 175 return if 176 $r1 == rop::NoOper && 177 $r2 == rop::NoOper; 178 179 if ( $self-> {changed}-> {lineWidth}) { 180 my ($lw) = $self-> pixel2point($self-> lineWidth); 181 $self-> emit( $lw . ' SW'); 182 $self-> {changed}-> {lineWidth} = 0; 183 } 184 185 if ( $self-> {changed}-> {lineEnd}) { 186 my $le = $self-> lineEnd; 187 my $id = ( $le == le::Round) ? 1 : (( $le == le::Square) ? 2 : 0); 188 $self-> emit( "$id SL"); 189 $self-> {changed}-> {lineEnd} = 0; 190 } 191 192 if ( $self-> {changed}-> {lineJoin}) { 193 my $lj = $self-> lineJoin; 194 my $id = ( $lj == lj::Round) ? 1 : (( $lj == lj::Bevel) ? 2 : 0); 195 $self-> emit( "$id SJ"); 196 $self-> {changed}-> {lineJoin} = 0; 197 } 198 199 if ( $self-> {changed}-> {miterLimit}) { 200 my $ml = $self-> miterLimit; 201 $self-> emit( "$ml ML"); 202 $self-> {changed}-> {miterLimit} = 0; 203 } 204 205 if ( $r2 != rop::NoOper && $lp ne lp::Solid ) { 206 my $bk = 207 ( $r2 == rop::Blackness) ? 0 : 208 ( $r2 == rop::Whiteness) ? 0xffffff : $self-> backColor; 209 210 $self-> {changed}-> {linePattern} = 1; 211 $self-> {changed}-> {fill} = 1; 212 $self-> emit('[] 0 SD'); 213 $self-> emit( $self-> cmd_rgb( $bk)); 214 $self-> emit( $code); 215 } 216 217 if ( $r1 != rop::NoOper && length( $lp)) { 218 my $fk = 219 ( $r1 == rop::Blackness) ? 0 : 220 ( $r1 == rop::Whiteness) ? 0xffffff : $self-> color; 221 222 if ( $self-> {changed}-> {linePattern}) { 223 if ( length( $lp) == 1) { 224 $self-> emit('[] 0 SD'); 225 } else { 226 my @x = split('', $lp); 227 push( @x, 0) if scalar(@x) % 1; 228 @x = map { ord($_) } @x; 229 $self-> emit("[@x] 0 SD"); 230 } 231 $self-> {changed}-> {linePattern} = 0; 232 } 233 234 if ( $self-> {changed}-> {fill}) { 235 $self-> emit( $self-> cmd_rgb( $fk)); 236 $self-> {changed}-> {fill} = 0; 237 } 238 $self-> emit( $code); 239 } 240} 241 242# Prima::Printer interface 243 244sub begin_doc 245{ 246 my ( $self, $docName) = @_; 247 return 0 if $self-> get_paint_state; 248 $self-> {ps_data} = ''; 249 $self-> {can_draw} = 1; 250 251 $docName = $::application ? $::application-> name : "Prima::PS::PostScript" 252 unless defined $docName; 253 my $data = scalar localtime; 254 my @b2 = ( 255 int($self-> {pageSize}-> [0] - $self-> {pageMargins}-> [2] + .5), 256 int($self-> {pageSize}-> [1] - $self-> {pageMargins}-> [3] + .5) 257 ); 258 259 $self-> {fp_hash} = {}; 260 $self-> {pages} = 1; 261 262 my ($x,$y) = ( 263 $self-> {pageSize}-> [0] - $self-> {pageMargins}-> [0] - $self-> {pageMargins}-> [2], 264 $self-> {pageSize}-> [1] - $self-> {pageMargins}-> [1] - $self-> {pageMargins}-> [3] 265 ); 266 267 my $extras = ''; 268 my $setup = ''; 269 my %pd = defined( $self-> {pageDevice}) ? %{$self-> {pageDevice}} : (); 270 271 if ( $self-> {copies} > 1) { 272 $pd{NumCopies} = $self-> {copies}; 273 $extras .= "\%\%Requirements: numcopies($self->{copies})\n"; 274 } 275 276 if ( scalar keys %pd) { 277 my $jd = join( "\n", map { "/$_ $pd{$_}"} keys %pd); 278 $setup .= <<NUMPAGES; 279%%BeginFeature 280<< $jd >> SPD 281%%EndFeature 282NUMPAGES 283 } 284 285 my $header = "%!PS-Adobe-2.0"; 286 $header .= " EPSF-2.0" if $self->isEPS; 287 288 $self-> emit( <<PSHEADER); 289$header 290%%Title: $docName 291%%Creator: Prima::PS::PostScript 292%%CreationDate: $data 293%%Pages: (atend) 294%%BoundingBox: @{$self->{pageMargins}}[0,1] @b2 295$extras 296%%LanguageLevel: 2 297%%DocumentNeededFonts: (atend) 298%%DocumentSuppliedFonts: (atend) 299%%EndComments 300 301/d/def load def/,/load load d/~/exch , d/S/show , d/:/gsave , d/;/grestore , 302d/N/newpath , d/M/moveto , d/L/rlineto , d/X/closepath , d/C/clip , d/U/curveto , 303d/T/translate , d/R/rotate , d/Y/glyphshow , d/P/showpage , d/Z/scale , d/I/imagemask , 304d/@/dup , d/G/setgray , d/A/setrgbcolor , d/l/lineto , d/F/fill , 305d/FF/findfont , d/XF/scalefont , d/SF/setfont , 306d/O/stroke , d/SD/setdash , d/SL/setlinecap , d/SW/setlinewidth , 307d/SJ/setlinejoin , d/E/eofill , d/ML/setmiterlimit , 308d/SS/setcolorspace , d/SC/setcolor , d/SM/setmatrix , d/SPD/setpagedevice , 309d/SP/setpattern , d/CP/currentpoint , d/MX/matrix , d/MP/makepattern , 310d/b/begin , d/e/end , d/t/true , d/f/false , d/?/ifelse , d/a/arc , 311d/dummy/_dummy 312 313%%BeginSetup 314$setup 315%%EndSetup 316 317PSHEADER 318 $self->defer_emission(1); 319 $self->emit("%%Page: 1 1\n"); 320 321 $self-> {page_prefix} = <<PREFIX; 322@{$self->{pageMargins}}[0,1] T 323N 0 0 M 0 $y L $x 0 L 0 -$y L X C 324PREFIX 325 326 $self-> {page_prefix} .= "0 0 M 90 R 0 -$x T\n" if $self-> {reversed}; 327 328 $self-> {changed} = { map { $_ => 0 } qw( 329 fill lineEnd linePattern lineWidth lineJoin miterLimit font)}; 330 $self-> SUPER::begin_paint; 331 $self-> save_state; 332 333 $self-> {delay} = 1; 334 $self-> restore_state; 335 $self-> {delay} = 0; 336 337 $self-> emit( $self-> {page_prefix}); 338 $self-> change_transform( 1); 339 $self-> {changed}-> {linePattern} = 0; 340 341 return 1; 342} 343 344sub abort_doc 345{ 346 my $self = $_[0]; 347 return unless $self-> {can_draw}; 348 $self-> {can_draw} = 0; 349 $self-> SUPER::end_paint; 350 $self-> restore_state; 351 delete $self-> {$_} for 352 qw (save_state ps_data changed page_prefix); 353} 354 355sub end_doc 356{ 357 my $self = $_[0]; 358 return 0 unless $self-> {can_draw}; 359 $self-> {can_draw} = 0; 360 361 $self->{glyph_keeper}-> evacuate( sub { $self->spool( $_[0] ) } ) 362 if $self-> {glyph_keeper}; 363 $self-> defer_emission(0); 364 my $ret = $self-> spool($self->{ps_data} . <<PSFOOTER); 365; P 366 367%%Trailer 368%%DocumentNeededFonts: 369%%DocumentSuppliedFonts: 370%%Pages: $_[0]->{pages} 371%%EOF 372PSFOOTER 373 374 $self-> {can_draw} = 0; 375 $self-> SUPER::end_paint; 376 $self-> restore_state; 377 delete $self-> {$_} for 378 qw (save_state changed ps_data page_prefix glyph_keeper glyph_font); 379 return $ret; 380} 381 382sub begin_paint { return $_[0]-> begin_doc; } 383sub end_paint { $_[0]-> abort_doc; } 384 385 386sub new_page 387{ 388 return 0 unless $_[0]-> {can_draw}; 389 my $self = $_[0]; 390 $self-> {pages}++; 391 $self-> emit("; P\n%%Page: $self->{pages} $self->{pages}\n"); 392 { 393 local $self->{delay} = 1; 394 $self-> $_( @{$self-> {save_state}-> {$_}}) for qw( translate clipRect); 395 } 396 $self-> emit( $self-> {page_prefix}); 397 $self-> change_transform(1); 398 $self-> {changed}->{font} = 1; 399 return 1; 400} 401 402sub pages { $_[0]-> {pages} } 403 404 405# properties 406 407sub fillPattern 408{ 409 return $_[0]-> SUPER::fillPattern unless $#_; 410 $_[0]-> SUPER::fillPattern( $_[1]); 411 return unless $_[0]-> {can_draw}; 412 413 my $self = $_[0]; 414 my @fp = @{$self-> SUPER::fillPattern}; 415 my $solidBack = ! grep { $_ != 0 } @fp; 416 my $solidFore = ! grep { $_ != 0xff } @fp; 417 my $fpid; 418 my @scaleto = $self-> pixel2point( 8, 8); 419 if ( !$solidBack && !$solidFore) { 420 $fpid = join( '', map { sprintf("%02x", $_)} @fp); 421 unless ( exists $self-> {fp_hash}-> {$fpid}) { 422 $self-> emit( <<PATTERNDEF); 423<< 424\/PatternType 1 \% Tiling pattern 425\/PaintType 2 \% Uncolored 426\/TilingType 1 427\/BBox [ 0 0 @scaleto] 428\/XStep $scaleto[0] 429\/YStep $scaleto[1] 430\/PaintProc { b 431: 432@scaleto Z 4338 8 t 434[8 0 0 8 0 0] 435< $fpid > I 436; 437e 438} bind 439>> MX MP 440\/Pat_$fpid ~ d 441 442PATTERNDEF 443 $self-> {fp_hash}-> {$fpid} = 1; 444 } 445 } 446 $self-> {fpType} = $solidBack ? 'B' : ( $solidFore ? 'F' : $fpid); 447 $self-> {changed}-> {fill} = 1; 448} 449 450sub isEPS { $#_ ? $_[0]-> {isEPS} = $_[1] : $_[0]-> {isEPS} } 451 452sub copies 453{ 454 return $_[0]-> {copies} unless $#_; 455 $_[0]-> {copies} = $_[1] unless $_[0]-> get_paint_state; 456} 457 458sub pageDevice 459{ 460 return $_[0]-> {pageDevice} unless $#_; 461 $_[0]-> {pageDevice} = $_[1] unless $_[0]-> get_paint_state; 462} 463 464# primitives 465 466sub arc 467{ 468 my ( $self, $x, $y, $dx, $dy, $start, $end) = @_; 469 my $try = $dy / $dx; 470 ( $x, $y, $dx, $dy) = $self-> pixel2point( $x, $y, $dx, $dy); 471 my $rx = $dx / 2; 472 $end -= $start; 473 $self-> stroke( <<ARC ); 474$x $y M : $x $y T 1 $try Z $start R 475N $rx 0 M 0 0 $rx 0 $end a O ; 476ARC 477} 478 479sub chord 480{ 481 my ( $self, $x, $y, $dx, $dy, $start, $end) = @_; 482 my $try = $dy / $dx; 483 ( $x, $y, $dx, $dy) = $self-> pixel2point( $x, $y, $dx, $dy); 484 my $rx = $dx / 2; 485 $end -= $start; 486 $self-> stroke(<<CHORD); 487$x $y M : $x $y T 1 $try Z $start R 488N $rx 0 M 0 0 $rx 0 $end a X O ; 489CHORD 490} 491 492sub ellipse 493{ 494 my ( $self, $x, $y, $dx, $dy) = @_; 495 my $try = $dy / $dx; 496 ( $x, $y, $dx, $dy) = $self-> pixel2point( $x, $y, $dx, $dy); 497 my $rx = $dx / 2; 498 $self-> stroke(<<ELLIPSE); 499$x $y M : $x $y T 1 $try Z 500N $rx 0 M 0 0 $rx 0 360 a O ; 501ELLIPSE 502} 503 504sub fill_chord 505{ 506 my ( $self, $x, $y, $dx, $dy, $start, $end) = @_; 507 my $try = $dy / $dx; 508 ( $x, $y, $dx, $dy) = $self-> pixel2point( $x, $y, $dx, $dy); 509 my $rx = $dx / 2; 510 $end -= $start; 511 my $F = (($self-> fillMode & fm::Winding) == fm::Alternate) ? 'E' : 'F'; 512 $self-> fill( <<CHORD ); 513$x $y M : $x $y T 1 $try Z 514N $rx 0 M 0 0 $rx 0 $end a X $F ; 515CHORD 516} 517 518sub fill_ellipse 519{ 520 my ( $self, $x, $y, $dx, $dy) = @_; 521 my $try = $dy / $dx; 522 ( $x, $y, $dx, $dy) = $self-> pixel2point( $x, $y, $dx, $dy); 523 my $rx = $dx / 2; 524 $self-> fill(<<ELLIPSE); 525$x $y M : $x $y T 1 $try Z 526N $rx 0 M 0 0 $rx 0 360 a F ; 527ELLIPSE 528} 529 530sub sector 531{ 532 my ( $self, $x, $y, $dx, $dy, $start, $end) = @_; 533 my $try = $dy / $dx; 534 ( $x, $y, $dx, $dy) = $self-> pixel2point( $x, $y, $dx, $dy); 535 my $rx = $dx / 2; 536 $end -= $start; 537 $self-> stroke(<<SECTOR); 538$x $y M : $x $y T 1 $try Z $start R 539N 0 0 M 0 0 $rx 0 $end a 0 0 l O ; 540SECTOR 541} 542 543sub fill_sector 544{ 545 my ( $self, $x, $y, $dx, $dy, $start, $end) = @_; 546 my $try = $dy / $dx; 547 ( $x, $y, $dx, $dy) = $self-> pixel2point( $x, $y, $dx, $dy); 548 my $rx = $dx / 2; 549 $end -= $start; 550 my $F = (($self-> fillMode & fm::Winding) == fm::Alternate) ? 'E' : 'F'; 551 $self-> fill(<<SECTOR); 552$x $y M : $x $y T 1 $try Z $start R 553N 0 0 M 0 0 $rx 0 $end a 0 0 l $F ; 554SECTOR 555} 556 557sub text_out_outline 558{ 559 my ( $self, $text ) = @_; 560 my $shaped = $self->text_shape($text, level => ts::Glyphs ) or return; 561 $self-> glyph_out_outline($shaped, 0, scalar @{$shaped->glyphs}); 562} 563 564sub glyph_out_outline 565{ 566 my ( $self, $text, $from, $len ) = @_; 567 568 my $glyphs = $text-> glyphs; 569 my $indexes = $text-> indexes; 570 my $advances = $text-> advances; 571 my $positions = $text-> positions; 572 my $fonts = $text-> fonts; 573 my $plaintext = $text-> [Prima::Drawable::Glyphs::CUSTOM()]; 574 my @ix_lengths = defined($plaintext) ? $text-> index_lengths : (); 575 my $adv = 0; 576 my $canvas = $self->glyph_canvas; 577 my $resolution = 72.27 / $self->{resolution}->[0]; 578 my $keeper = $self->{glyph_keeper}; 579 my $font = $self->{glyph_font}; 580 my $div = $self->{font_scale}; 581 my $restore_font; 582 583 $len += $from; 584 my $emit = ''; 585 my $fid = 0; 586 my $ff = $canvas->font; 587 for ( my $i = $from; $i < $len; $i++) { 588 my $advance; 589 my $glyph = $glyphs->[$i]; 590 my ($x2, $y2) = ($adv, 0); 591 my $nfid = $fonts ? $fonts->[$i] : 0; 592 if ( $nfid != $fid ) { 593 my $newfont; 594 if ( $nfid == 0 ) { 595 $newfont = $self->{font}; 596 $restore_font = 0; 597 } else { 598 my $src = $self-> fontMapperPalette($nfid); 599 my $dst = \%{$self->{font}}; 600 $newfont = Prima::Drawable->font_match( $src, $dst ); 601 $restore_font = 1; 602 } 603 $self-> glyph_canvas_set_font( %$newfont ); 604 $font = $nfid ? $keeper->get_font($canvas->font) : $self->{glyph_font}; 605 $emit .= "/$font FF $self->{font}->{size} XF SF\n"; 606 $fid = $nfid; 607 } 608 my $char = defined($plaintext) ? 609 substr( $plaintext, $indexes->[$i] & ~to::RTL, $ix_lengths[$i]) : 610 undef; 611 my $gid = $keeper-> use_char($canvas, $font, $glyph, $char); 612 if ( $advances) { 613 $advance = $advances->[$i]; 614 $x2 += $positions->[$i*2]; 615 $y2 += $positions->[$i*2 + 1]; 616 } else { 617 my $xr = $canvas->get_font_abc($glyph, $glyph, to::Glyphs); 618 $advance = ($$xr[0] + $$xr[1] + $$xr[2]) * $div; 619 } 620 $adv += $advance; 621 if ( defined $gid ) { 622 ($x2, $y2) = map { int( $_ * 100 + 0.5) / 100 } $self->pixel2point($x2, $y2); 623 $emit .= "$x2 $y2 M " if $x2 != 0 || $y2 != 0; 624 } else { 625 # not a single vector font found 626 $gid //= $Prima::PS::Unicode->{$char} // 'question'; 627 } 628 $emit .= "/$gid Y\n"; 629 } 630 631 if ($restore_font) { 632 $emit .= "/$self->{glyph_font} FF $self->{font}->{size} XF SF\n"; 633 $self-> glyph_canvas_set_font( %{ $self->{font} }); 634 } 635 $self-> emit($emit); 636} 637 638sub text_out 639{ 640 my ( $self, $text, $x, $y, $from, $len) = @_; 641 642 $from //= 0; 643 my $glyphs; 644 if ( ref($text) eq 'Prima::Drawable::Glyphs') { 645 $glyphs = $text->glyphs; 646 $len = @$glyphs if !defined($len) || $len < 0 || $len > @$glyphs; 647 } elsif (ref($text)) { 648 $len //= -1; 649 return $text->text_out($self, $x, $y, $from, $len); 650 } else { 651 $len = length($text) if !defined($len) || $len < 0 || $len > length($text); 652 $text = substr($text, $from, $len); 653 $from = 0; 654 $len = length($text); 655 } 656 return 0 unless $self-> {can_draw} and $len > 0; 657 658 $y += $self-> {font}-> {descent} if !$self-> textOutBaseline; 659 ( $x, $y) = $self-> pixel2point( $x, $y); 660 661 if ( $self-> {changed}-> {font}) { 662 my $fn = $self->{glyph_font}; 663 $self-> emit( "/$fn FF $self->{font}->{size} XF SF"); 664 $self-> {changed}-> {font} = 0; 665 } 666 667 my $wmul = $self-> {font_x_scale}; 668 $self-> emit(": $x $y T"); 669 $self-> emit("$wmul 1 Z") if $wmul != 1; 670 $self-> emit("0 0 M"); 671 if ( $self-> {font}-> {direction} != 0) { 672 my $r = $self-> {font}-> {direction}; 673 $self-> emit("$r R"); 674 } 675 676 my @rb; 677 if ( $self-> textOpaque || $self-> {font}-> {style} & (fs::Underlined|fs::StruckOut)) { 678 my ( $ds, $bs) = ( $self-> {font}-> {direction}, $self-> textOutBaseline); 679 $self-> {font}-> {direction} = 0; 680 $self-> textOutBaseline(1) unless $bs; 681 @rb = $self-> pixel2point( @{$self-> get_text_box( $text, $from, $len)}); 682 $self-> {font}-> {direction} = $ds; 683 $self-> textOutBaseline($bs) unless $bs; 684 } 685 if ( $self-> textOpaque) { 686 $self-> emit( $self-> cmd_rgb( $self-> backColor)); 687 $self-> emit( ": N @rb[0,1] M @rb[2,3] l @rb[6,7] l @rb[4,5] l X F ;"); 688 } 689 690 $self-> emit( $self-> cmd_rgb( $self-> color)); 691 692 if ( $glyphs ) { 693 $self->glyph_out_outline($text, $from, $len); 694 } else { 695 $self->text_out_outline($text); 696 } 697 698 if ( $self-> {font}-> {style} & (fs::Underlined|fs::StruckOut)) { 699 my $lw = int($self-> {font}-> {size} / 40 + .5); # XXX empiric 700 $lw ||= 1; 701 $self-> emit("[] 0 SD 0 SL $lw SW"); 702 if ( $self-> {font}-> {style} & fs::Underlined) { 703 $self-> emit("N @rb[0,3] M $rb[4] 0 L O"); 704 } 705 if ( $self-> {font}-> {style} & fs::StruckOut) { 706 $rb[3] += $rb[1]/2; 707 $self-> emit("N @rb[0,3] M $rb[4] 0 L O"); 708 } 709 } 710 $self-> emit(";"); 711 return 1; 712} 713 714sub bar 715{ 716 my ( $self, $x1, $y1, $x2, $y2) = @_; 717 ( $x1, $y1, $x2, $y2) = $self-> pixel2point( $x1, $y1, $x2, $y2); 718 $self-> fill( "N $x1 $y1 M $x1 $y2 l $x2 $y2 l $x2 $y1 l X F"); 719} 720 721sub bars 722{ 723 my ( $self, $array) = @_; 724 my $i; 725 my $c = scalar @$array; 726 my @a = $self-> pixel2point( @$array); 727 $c = int( $c / 4) * 4; 728 my $z = ''; 729 for ( $i = 0; $i < $c; $i += 4) { 730 $z .= "N @a[$i,$i+1] M @a[$i,$i+3] l @a[$i+2,$i+3] l @a[$i+2,$i+1] l X F "; 731 } 732 $self-> stroke( $z); 733} 734 735sub rectangle 736{ 737 my ( $self, $x1, $y1, $x2, $y2) = @_; 738 ( $x1, $y1, $x2, $y2) = $self-> pixel2point( $x1, $y1, $x2, $y2); 739 $self-> stroke( "N $x1 $y1 M $x1 $y2 l $x2 $y2 l $x2 $y1 l X O"); 740} 741 742sub clear 743{ 744 my ( $self, $x1, $y1, $x2, $y2) = @_; 745 if ( grep { ! defined } $x1, $y1, $x2, $y2) { 746 ($x1, $y1, $x2, $y2) = $self-> clipRect; 747 unless ( grep { $_ != 0 } $x1, $y1, $x2, $y2) { 748 ($x1, $y1, $x2, $y2) = (0,0,@{$self-> {size}}); 749 } 750 } 751 ( $x1, $y1, $x2, $y2) = $self-> pixel2point( $x1, $y1, $x2, $y2); 752 my $c = $self-> cmd_rgb( $self-> backColor); 753 $self-> emit(<<CLEAR); 754$c 755N $x1 $y1 M $x1 $y2 l $x2 $y2 l $x2 $y1 l X F 756CLEAR 757 $self-> {changed}-> {fill} = 1; 758} 759 760sub line 761{ 762 my ( $self, $x1, $y1, $x2, $y2) = @_; 763 ( $x1, $y1, $x2, $y2) = $self-> pixel2point( $x1, $y1, $x2, $y2); 764 $self-> stroke("N $x1 $y1 M $x2 $y2 l O"); 765} 766 767sub lines 768{ 769 my ( $self, $array) = @_; 770 my $i; 771 my $c = scalar @$array; 772 my @a = $self-> pixel2point( @$array); 773 $c = int( $c / 4) * 4; 774 my $z = ''; 775 for ( $i = 0; $i < $c; $i += 4) { 776 $z .= "N @a[$i,$i+1] M @a[$i+2,$i+3] l O "; 777 } 778 $self-> stroke( $z); 779} 780 781sub polyline 782{ 783 my ( $self, $array) = @_; 784 my $i; 785 my $c = scalar @$array; 786 my @a = $self-> pixel2point( @$array); 787 $c = int( $c / 2) * 2; 788 return if $c < 2; 789 my $z = "N @a[0,1] M "; 790 for ( $i = 2; $i < $c; $i += 2) { 791 $z .= "@a[$i,$i+1] l "; 792 } 793 $z .= "O"; 794 $self-> stroke( $z); 795} 796 797sub fillpoly 798{ 799 my ( $self, $array) = @_; 800 my $i; 801 my $c = scalar @$array; 802 $c = int( $c / 2) * 2; 803 return if $c < 2; 804 my @a = $self-> pixel2point( @$array); 805 my $x = "N @a[0,1] M "; 806 for ( $i = 2; $i < $c; $i += 2) { 807 $x .= "@a[$i,$i+1] l "; 808 } 809 $x .= 'X ' . ((($self-> fillMode & fm::Winding) == fm::Alternate) ? 'E' : 'F'); 810 $self-> fill( $x); 811} 812 813sub pixel 814{ 815 my ( $self, $x, $y, $pix) = @_; 816 return cl::Invalid unless defined $pix; 817 my $c = $self-> cmd_rgb( $pix); 818 ($x, $y) = $self-> pixel2point( $x, $y); 819 $self-> emit(<<PIXEL); 820: 821$c 822N $x $y M 0 0 L F 823; 824PIXEL 825 $self-> {changed}-> {fill} = 1; 826} 827 828sub put_image_indirect 829{ 830 return 0 unless $_[0]-> {can_draw}; 831 my ( $self, $image, $x, $y, $xFrom, $yFrom, $xDestLen, $yDestLen, $xLen, $yLen) = @_; 832 833 my $touch; 834 $touch = 1, $image = $image-> image if $image-> isa('Prima::DeviceBitmap'); 835 836 unless ( $xFrom == 0 && $yFrom == 0 && $xLen == $image-> width && $yLen == $image-> height) { 837 $image = $image-> extract( $xFrom, $yFrom, $xLen, $yLen); 838 $touch = 1; 839 } 840 841 my $ib = $image-> get_bpp; 842 if ( $ib != $self-> get_bpp) { 843 $image = $image-> dup unless $touch; 844 if ( $self-> {grayscale} || $image-> type & im::GrayScale) { 845 $image-> type( im::Byte); 846 } else { 847 $image-> type( im::RGB); 848 } 849 $touch = 1; 850 } elsif ( $self-> {grayscale} || $image-> type & im::GrayScale) { 851 $image = $image-> dup unless $touch; 852 $image-> type( im::Byte); 853 $touch = 1; 854 } 855 856 $ib = $image-> get_bpp; 857 if ($ib != 8 && $ib != 24) { 858 $image = $image-> dup unless $touch; 859 $image-> type( im::RGB); 860 $touch = 1; 861 } 862 863 if ( $image-> type == im::RGB ) { 864 # invert BGR -> RGB 865 $image = $image-> dup unless $touch; 866 $image-> set(data => $image->data, type => im::fmtBGR | im::RGB); 867 $touch = 1; 868 } 869 870 my @is = $image-> size; 871 ($x, $y, $xDestLen, $yDestLen) = $self-> pixel2point( $x, $y, $xDestLen, $yDestLen); 872 my @fullScale = ( 873 $is[0] / $xLen * $xDestLen, 874 $is[1] / $yLen * $yDestLen, 875 ); 876 877 my $g = $image-> data; 878 my $bt = ( $image-> type & im::BPP) * $is[0] / 8; 879 my $ls = $image->lineSize; 880 my ( $i, $j); 881 882 $self-> emit(": $x $y T @fullScale Z"); 883 $self-> emit("/scanline $bt string d"); 884 $self-> emit("@is 8 [$is[0] 0 0 $is[1] 0 0]"); 885 $self-> emit('{currentfile scanline readhexstring pop}'); 886 $self-> emit(( $image-> type & im::GrayScale) ? "image" : "false 3 colorimage"); 887 888 for ( $i = 0; $i < $is[1]; $i++) { 889 $self-> emit(unpack('H*', substr( $g, $ls * $i, $bt))); 890 } 891 $self-> emit(';'); 892 return 1; 893} 894 895sub apply_canvas_font 896{ 897 my ( $self, $f1000) = @_; 898 899 if ($f1000->{vector} == fv::Outline) { 900 $self-> {glyph_keeper} //= Prima::PS::Type1->new; 901 $self-> {glyph_font} = $self-> {glyph_keeper}->get_font($f1000); # it wants size=1000 902 } else { 903 $self-> {glyph_font} = ($f1000->{pitch} == fp::Fixed) ? 'Courier' : 'Helvetica' 904 } 905} 906 907sub new_path 908{ 909 return Prima::PS::PostScript::Path->new(@_); 910} 911 912sub region 913{ 914 return $_[0]->{region} unless $#_; 915 my ( $self, $region ) = @_; 916 if ( $region && !UNIVERSAL::isa($region, "Prima::PS::PostScript::Region")) { 917 warn "Region is not a Prima::PS::PostScript::Region"; 918 return undef; 919 } 920 $self->{clipRect} = [0,0,0,0]; 921 $self->{region} = $region; 922 $self-> change_transform; 923} 924 925package 926 Prima::PS::PostScript::Path; 927use base qw(Prima::PS::Drawable::Path); 928 929my %dict = ( 930 lineto => 'l', 931 moveto => 'M', 932 curveto => 'U', 933 stroke => 'O', 934 closepath => 'X', 935 fill_alt => 'E', 936 fill_wind => 'F', 937); 938 939sub dict { \%dict } 940 941sub set_current_point 942{ 943 my ( $self, $x, $y ) = @_; 944 $self-> emit('N') unless $self->{move_is_line}; 945 $self-> emit($x, $y, $self->{move_is_line} ? 'l' : 'M'); 946 $self-> {move_is_line} = 1; 947} 948 949sub region 950{ 951 my ($self, $mode) = @_; 952 my $path = join "\n", @{$self-> entries}; 953 $path .= ' X' unless $path =~ /X$/; 954 $path .= ' C'; 955 return Prima::PS::PostScript::Region->new( $path ); 956} 957 958package 959 Prima::PS::PostScript::Region; 960use base qw(Prima::PS::Drawable::Region); 961 962sub other { UNIVERSAL::isa($_[0], "Prima::PS::PostScript::Region") ? $_[0] : () } 963 964sub equals 965{ 966 my $self = shift; 967 my $other = other(shift) or return; 968 return $self->{path} eq $other->{path}; 969} 970 971sub combine 972{ 973 my $self = shift; 974 my $other = other(shift) or return; 975 $self->{path} .= "\n" . $other->apply_offset; 976} 977 978sub is_empty { shift->{path} !~ /[OF]/ } 979 9801; 981 982__END__ 983 984=pod 985 986=head1 NAME 987 988Prima::PS::PostScript - PostScript interface to Prima::Drawable 989 990=head1 SYNOPSIS 991 992 use Prima; 993 use Prima::PS::PostScript; 994 995 my $x = Prima::PS::PostScript-> create( onSpool => sub { 996 open F, ">> ./test.ps"; 997 print F $_[1]; 998 close F; 999 }); 1000 die "error:$@" unless $x-> begin_doc; 1001 $x-> font-> size( 30); 1002 $x-> text_out( "hello!", 100, 100); 1003 $x-> end_doc; 1004 1005 1006=head1 DESCRIPTION 1007 1008Realizes the Prima library interface to PostScript level 2 document language. 1009The module is designed to be compliant with Prima::Drawable interface. 1010All properties' behavior is as same as Prima::Drawable's, except those 1011described below. 1012 1013=head2 Inherited properties 1014 1015=over 1016 1017=item ::resolution 1018 1019Can be set while object is in normal stage - cannot be changed if document 1020is opened. Applies to fillPattern realization and general pixel-to-point 1021and vice versa calculations 1022 1023=item ::region 1024 1025- ::region is not realized ( yet?) 1026 1027=back 1028 1029=head2 Specific properties 1030 1031=over 1032 1033=item ::copies 1034 1035amount of copies that PS interpreter should print 1036 1037=item ::grayscale 1038 1039could be 0 or 1 1040 1041=item ::pageSize 1042 1043physical page dimension, in points 1044 1045=item ::pageMargins 1046 1047non-printable page area, an array of 4 integers: 1048left, bottom, right and top margins in points. 1049 1050=item ::reversed 1051 1052if 1, a 90 degrees rotated document layout is assumed 1053 1054=item ::rotate and ::scale 1055 1056along with Prima::Drawable::translate provide PS-specific 1057transformation matrix manipulations. ::rotate is number, 1058measured in degrees, counter-clockwise. ::scale is array of 1059two numbers, respectively x- and y-scale. 1 is 100%, 2 is 200% 1060etc. 1061 1062=back 1063 1064=head2 Internal methods 1065 1066=over 1067 1068=item emit 1069 1070Can be called for direct PostScript code injection. Example: 1071 1072 $x-> emit('0.314159 setgray'); 1073 $x-> bar( 10, 10, 20, 20); 1074 1075=item pixel2point and point2pixel 1076 1077Helpers for translation from pixel to points and vice versa. 1078 1079=item fill & stroke 1080 1081Wrappers for PS outline that is expected to be filled or stroked. 1082Apply colors, line and fill styles if necessary. 1083 1084=item spool 1085 1086Prima::PS::PostScript is not responsible for output of 1087generated document, it just calls ::spool when document 1088is closed through ::end_doc. By default just skips data. 1089Prima::PS::Printer handles spooling logic. 1090 1091=item fonts 1092 1093Returns Prima::Application::fonts, however with C<iso10646-1> encoding only. 1094That effectively allows only unicode output. 1095 1096=back 1097 1098=cut 1099 1100