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