File Coverage

blib/lib/PostScript/File.pm
Criterion Covered Total %
statement 542 720 75.2
branch 206 322 63.9
condition 74 116 63.7
subroutine 62 112 55.3
pod 54 92 58.7
total 938 1362 68.8


line stmt bran cond sub pod time code
1             #---------------------------------------------------------------------
2             package PostScript::File;
3             #
4             # Copyright 2002, 2003 Christopher P Willmot.
5             # Copyright 2011 Christopher J. Madsen
6             #
7             # Author: Chris Willmot
8             # Christopher J. Madsen
9             #
10             # This program is free software; you can redistribute it and/or modify
11             # it under the same terms as Perl 5 itself.
12             #
13             # This program is distributed in the hope that it will be useful,
14             # but WITHOUT ANY WARRANTY; without even the implied warranty of
15             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the
16             # GNU General Public License or the Artistic License for more details.
17             #
18             # ABSTRACT: Class for creating Adobe PostScript files
19             #---------------------------------------------------------------------
20              
21 22     22   8429412 use 5.008;
  22         77  
22             our $VERSION = '2.23'; ## no critic
23             # This file is part of PostScript-File 2.23 (October 10, 2015)
24              
25 22     22   121 use strict;
  22         1166  
  22         1630  
26 22     22   105 use warnings;
  22         1151  
  22         604  
27 22     22   1329 use Carp 'croak';
  22         46  
  22         2345  
28 22     22   111 use File::Spec ();
  22         37  
  22         393  
29 22     22   104 use Scalar::Util 'openhandle';
  22         32  
  22         1921  
30 22     22   105 use Exporter 5.57 'import';
  22         308  
  22         4214  
31              
32             our %EXPORT_TAGS = (metrics_methods => [qw(
33             encode_text decode_text convert_hyphens set_auto_hyphen
34             )]);
35              
36             our @EXPORT_OK = (qw(check_tilde check_file incpage_label incpage_roman
37             array_as_string pstr quote_text str),
38             # These are only for PostScript::File::Metrics:
39             @{ $EXPORT_TAGS{metrics_methods} });
40              
41             # Prototypes for functions only
42             ## no critic (ProhibitSubroutinePrototypes)
43             sub incpage_label ($);
44             sub incpage_roman ($);
45             sub check_tilde ($);
46             sub check_file ($;$$);
47             ## use critic
48              
49             # global constants
50             our %encoding_def; # defined near _set_reencode
51              
52             our ($t1ascii, $ttftotype42);
53             BEGIN {
54             # Program to convert .pfb fonts to .pfa on STDOUT:
55 22 50   22   135 $t1ascii = 't1ascii' unless defined $t1ascii;
56             # Program to convert .ttf fonts to .pfa on STDOUT:
57 22 50       127375 $ttftotype42 = 'ttftotype42' unless defined $ttftotype42;
58             }
59              
60              
61             # define page sizes here (a4, letter, etc)
62             # should be Properly Cased
63             our %size = (
64             a0 => '2384 3370',
65             a1 => '1684 2384',
66             a2 => '1191 1684',
67             a3 => "841.88976 1190.5512",
68             a4 => "595.27559 841.88976",
69             a5 => "420.94488 595.27559",
70             a6 => '297 420',
71             a7 => '210 297',
72             a8 => '148 210',
73             a9 => '105 148',
74              
75             b0 => '2920 4127',
76             b1 => '2064 2920',
77             b2 => '1460 2064',
78             b3 => '1032 1460',
79             b4 => '729 1032',
80             b5 => '516 729',
81             b6 => '363 516',
82             b7 => '258 363',
83             b8 => '181 258',
84             b9 => '127 181 ',
85             b10 => '91 127',
86              
87             executive => '522 756',
88             folio => '595 935',
89             'half-letter' => '612 397',
90             letter => "612 792",
91             'us-letter' => '612 792',
92             legal => '612 1008',
93             'us-legal' => '612 1008',
94             tabloid => '792 1224',
95             'superb' => '843 1227',
96             ledger => '1224 792',
97              
98             'comm #10 envelope' => '297 684',
99             'envelope-monarch' => '280 542',
100             'envelope-dl' => '312 624',
101             'envelope-c5' => '461 648',
102              
103             'europostcard' => '298 420',
104             );
105              
106              
107             # The 13 standard fonts that are available on all PS 1 implementations:
108             our @fonts = qw(
109             Courier
110             Courier-Bold
111             Courier-BoldOblique
112             Courier-Oblique
113             Helvetica
114             Helvetica-Bold
115             Helvetica-BoldOblique
116             Helvetica-Oblique
117             Times-Roman
118             Times-Bold
119             Times-BoldItalic
120             Times-Italic
121             Symbol
122             );
123              
124             # 5.008-compatible version of defined-or:
125 680 100   680   1206 sub _def { for (@_) { return $_ if defined $_ } undef }
  1315         3788  
  0         0  
126              
127             sub new {
128 45     45 1 28316 my ($class, @options) = @_;
129 45         241 my $opt = {};
130 45 100       132 if (@options == 1) {
131 1         2 $opt = $options[0];
132             } else {
133 44         222 %$opt = @options;
134             }
135              
136             ## Initialization
137 45         748 my $o = {
138             # PostScript DSC sections
139             Comments => "", # must include leading '%%' and end with '\n'
140             DocSupplied => "",
141             Preview => "",
142             Defaults => "",
143             Fonts => "",
144             Resources => "",
145             Functions => "",
146             Setup => "",
147             PageSetup => "",
148             Pages => [], # indexed by $o->{p}, 0 based
149             PageTrailer => "",
150             Trailer => "",
151              
152             # internal
153             p => 0, # current page (0 based)
154             pagecount => 0, # number of pages
155             page => [], # array of labels, indexed by $o->{p}
156             pagelandsc => [], # orientation of each page individually
157             pageclip => [], # clip to pagebbox
158             pagebbox => [], # array of bbox, indexed by $o->{p}
159             bbox => [], # [ x0, y0, x1, y1 ]
160             embed_fonts => [], # fonts that have been embedded
161             needed => {}, # DocumentNeededResources
162              
163             vars => {}, # permanent user variables
164             pagevars => {}, # user variables reset with each new page
165             };
166 45         123 bless $o, $class;
167              
168             ## Paper layout
169             croak "PNG output is no longer supported. Use PostScript::Convert instead"
170 45 100       353 if $opt->{png};
171 44         144 $o->{eps} = !!$opt->{eps} + 0;
172 44         88 $o->{file_ext} = $opt->{file_ext};
173 44         192 $o->set_filename(@$opt{qw(file dir)});
174 44         157 $o->set_paper( $opt->{paper} );
175 44         171 $o->set_width( $opt->{width} );
176 44         180 $o->set_height( $opt->{height} );
177 44         164 $o->set_landscape( $opt->{landscape} );
178              
179             ## Debug options
180 44         110 $o->{debug} = $opt->{debug}; # undefined is an option
181 44 100       107 if ($o->{debug}) {
182 2         10 $o->{db_active} = _def($opt->{db_active}, 1);
183 2         9 $o->{db_bufsize} = _def($opt->{db_bufsize}, 256);
184 2         8 $o->{db_font} = _def($opt->{db_font}, "Courier");
185 2         8 $o->{db_fontsize} = _def($opt->{db_fontsize}, 10);
186 2         14 $o->{db_ytop} = _def($opt->{db_ytop}, ($o->{bbox}[3] - $o->{db_fontsize} - 6));
187 2         9 $o->{db_ybase} = _def($opt->{db_ybase}, 6);
188 2         8 $o->{db_xpos} = _def($opt->{db_xpos}, 6);
189 2         12 $o->{db_xtab} = _def($opt->{db_xtab}, 10);
190 2         16 $o->{db_xgap} = _def($opt->{db_xgap}, ($o->{bbox}[2] - $o->{bbox}[0] - $o->{db_xpos})/4);
191 2         9 $o->{db_color} = _def($opt->{db_color}, "0 setgray");
192             }
193              
194             ## Bounding box
195 44         154 my $x0 = $o->{bbox}[0] + _def($opt->{left}, 28);
196 44         160 my $y0 = $o->{bbox}[1] + _def($opt->{bottom}, 28);
197 44         152 my $x1 = $o->{bbox}[2] - _def($opt->{right}, 28);
198 44         154 my $y1 = $o->{bbox}[3] - _def($opt->{top}, 28);
199 44         174 $o->set_bounding_box( $x0, $y0, $x1, $y1 );
200 44         140 $o->set_clipping( $opt->{clipping} );
201              
202             ## Other options
203 44         105 $o->{title} = $opt->{title};
204 44         84 $o->{version} = $opt->{version};
205 44         75 $o->{langlevel} = $opt->{langlevel};
206 44         75 $o->{extensions} = $opt->{extensions};
207 44 100       124 $o->{order} = defined($opt->{order}) ? ucfirst lc $opt->{order} : undef;
208 44         177 $o->set_page_label( $opt->{page} );
209 44         188 $o->set_incpage_handler( $opt->{incpage_handler} );
210              
211 44         152 $o->{errx} = _def($opt->{errx}, 72);
212 44         135 $o->{erry} = _def($opt->{erry}, 72);
213 44         136 $o->{errmsg} = _def($opt->{errmsg}, "ERROR:");
214 44         141 $o->{errfont} = _def($opt->{errfont}, "Courier-Bold");
215 44         135 $o->{errsize} = _def($opt->{errsize}, 12);
216              
217 44         136 $o->{font_suffix} = _def($opt->{font_suffix}, "-iso");
218 44         141 $o->{clipcmd} = _def($opt->{clip_command}, "clip");
219 44         132 $o->{errors} = _def($opt->{errors}, 1);
220 44         131 $o->{headings} = _def($opt->{headings}, 0);
221 44         176 $o->set_strip( $opt->{strip} );
222 44         188 $o->_set_reencode( $opt->{reencode} );
223 44         3908264 $o->set_auto_hyphen(_def($opt->{auto_hyphen}, 1));
224 44 100       132 $o->need_resource(font => @{ $opt->{need_fonts} }) if $opt->{need_fonts};
  2         8  
225              
226 44 100       127 $o->newpage if _def($opt->{newpage}, 1);
227              
228             ## Finish
229 44         231 return $o;
230             }
231              
232              
233             sub newpage {
234 47     47 1 244 my ($o, $page) = @_;
235 47         103 my $oldpage = $o->{page}[$o->{p}];
236             # Don't use _def here, because we don't want to call
237             # incpage_handler if the user supplied a page label:
238             my $newpage = defined $page
239             ? $page
240             # If this is the very first page, don't increment the page number:
241             : ($o->{pagecount}
242 47 100       173 ? $o->{incpage}->($oldpage)
    100          
243             : $oldpage);
244 47         104 my $p = $o->{p} = $o->{pagecount}++;
245 47         155 $o->{page}[$p] = $newpage;
246 47         64 $o->{pagebbox}[$p] = [ @{$o->{bbox}} ];
  47         161  
247 47         109 $o->{pageclip}[$p] = $o->{clipping};
248 47         95 $o->{pagelandsc}[$p] = $o->{landscape};
249 47         103 $o->{Pages}->[$p] = "";
250 47         132 $o->{pagevars} = {};
251             }
252              
253              
254             sub _pre_pages
255             {
256 104     104   169 my ($o, $landscape, $clipping, $filename) = @_;
257              
258 104 100       261 if (my $use_functions = $o->{use_functions}) {
259 6         20 $use_functions->add_to_file($o);
260             }
261              
262 104         182 my $docSupplied = $o->{DocSupplied};
263             ## Thanks to Johan Vromans for the ISOLatin1Encoding.
264 104         155 my $fonts = "";
265 104 100       234 if ($o->{reencode}) {
266 6         17 my $encoding = $o->{reencode};
267 6         13 my $ext = $o->{font_suffix};
268 6         15 $fonts = "% Handle font encoding:\n";
269 6         69 $fonts .= $o->_here_doc(<<"END_FONTS");
270             /STARTDIFFENC { mark } bind def
271             /ENDDIFFENC {
272              
273             % /NewEnc BaseEnc STARTDIFFENC number or glyphname ... ENDDIFFENC -
274             counttomark 2 add -1 roll 256 array copy
275             /TempEncode exch def
276              
277             % pointer for sequential encodings
278             /EncodePointer 0 def
279             {
280             % Get the bottom object
281             counttomark -1 roll
282             % Is it a mark?
283             dup type dup /marktype eq {
284             % End of encoding
285             pop pop exit
286             } {
287             /nametype eq {
288             % Insert the name at EncodePointer
289              
290             % and increment the pointer.
291             TempEncode EncodePointer 3 -1 roll put
292             /EncodePointer EncodePointer 1 add def
293             } {
294             % Set the EncodePointer to the number
295             /EncodePointer exch def
296             } ifelse
297             } ifelse
298             } loop
299              
300             TempEncode def
301             } bind def
302             \n$encoding_def{$encoding}
303             % Name: Re-encode Font
304             % Description: Creates a new font using the named encoding.
305              
306             /REENCODEFONT { % /Newfont NewEncoding /Oldfont
307             findfont dup length 4 add dict
308             begin
309             { % forall
310             1 index /FID ne
311             2 index /UniqueID ne and
312             2 index /XUID ne and
313             { def } { pop pop } ifelse
314             } forall
315             /Encoding exch def
316             % defs for DPS
317             /BitmapWidths false def
318             /ExactSize 0 def
319             /InBetweenSize 0 def
320             /TransformedChar 0 def
321             currentdict
322             end
323             definefont pop
324             } bind def
325             END_FONTS
326 6         19 $fonts .= "\n% Reencode the fonts:\n";
327             # If no fonts listed, assume the standard ones:
328 6   100     37 $o->{needed}{font} ||= { map { $_ => 1 } @fonts };
  39         111  
329              
330 6         13 for my $font (sort(keys(%{ $o->{needed}{font} }),
  6         33  
331 6         58 @{ $o->{embed_fonts} })) {
332 78 100       153 next if $font eq 'Symbol'; # doesn't use StandardEncoding
333 72         156 $fonts .= "/${font}$ext $encoding /$font REENCODEFONT\n";
334             }
335 6         20 $fonts .= "% end font encoding\n";
336             } # end if reencode
337              
338             # Prepare the PostScript file
339 104 100       231 my $postscript = $o->{eps} ? "\%!PS-Adobe-3.0 EPSF-3.0\n" : "\%!PS-Adobe-3.0\n";
340 104 100       229 if ($o->{eps}) {
341 7         20 $postscript .= $o->_bbox_comment('', $o->{bbox});
342             }
343 104 100       233 if ($o->{headings}) {
344 3         2500 require Sys::Hostname;
345 3   50     6311 my $user = getlogin() || (getpwuid($<))[0] || "Unknown";
346 3         18 my $hostname = Sys::Hostname::hostname();
347 3         40 $postscript .= $o->_here_doc(<
348             \%\%For: $user\@$hostname
349 3         47 \%\%Creator: Perl module ${\( ref $o )} v$PostScript::File::VERSION
350 3         265 \%\%CreationDate: ${\( scalar localtime )}
351             END_TITLES
352 3 100       25 $postscript .= $o->_here_doc(<{eps});
353             \%\%DocumentMedia: $o->{paper} $o->{width} $o->{height} 80 ( ) ( )
354             END_PS_ONLY
355             }
356              
357 104         160 my $landscapefn = "";
358 104 100       291 $landscapefn .= $o->_here_doc(<
359             % Rotate page 90 degrees
360             % _ => _
361             /landscape {
362             $o->{width} 0 translate
363             90 rotate
364             } bind def
365             END_LANDSCAPE
366              
367 104         154 my $clipfn = "";
368 104 100       215 if ($clipping) {
369 10         15 my $clipcmd = $o->{clipcmd};
370 10 100       38 $clipcmd = "gsave 0 setgray 0.5 setlinewidth $clipcmd grestore newpath"
371             if $clipcmd eq 'stroke';
372              
373 10         35 $clipfn .= $o->_here_doc(<
374             % Draw box as clipping path
375             % x0 y0 x1 y1 => _
376             /cliptobox {
377             4 dict begin
378             /y1 exch def /x1 exch def /y0 exch def /x0 exch def
379             newpath
380             x0 y0 moveto x0 y1 lineto x1 y1 lineto x1 y0 lineto
381             closepath
382             $clipcmd
383             end
384             } bind def
385             END_CLIPPING
386             } # end if $clipping
387              
388 104         141 my $errorfn = "";
389 104 100       249 if ($o->{errors}) {
390 65         200 $o->need_resource(font => $o->{errfont});
391 65         481 $errorfn .= $o->_here_doc(<
392             /errx $o->{errx} def
393             /erry $o->{erry} def
394             /errmsg ($o->{errmsg}) def
395             /errfont /$o->{errfont} def
396             /errsize $o->{errsize} def
397             % Report fatal error on page
398             % _ str => _
399             /report_error {
400             0 setgray
401             errfont findfont errsize scalefont setfont
402             errmsg errx erry moveto show
403             80 string cvs errx erry errsize sub moveto show
404             stop
405             } bind def
406              
407             % PostScript errors printed on page
408             % not called directly
409             errordict begin
410             /handleerror {
411             \$error begin
412             false binary
413             0 setgray
414             errfont findfont errsize scalefont setfont
415             errx erry moveto
416             errmsg show
417             errx erry errsize sub moveto
418             errorname 80 string cvs show
419             stop
420             } def
421             end
422             END_ERRORS
423             } # end if $o->{errors}
424              
425 104         181 my $debugfn = "";
426 104 100       238 if ($o->{debug}) {
427 2         8 $o->need_resource(font => $o->{db_font});
428 2         92 $debugfn .= $o->_here_doc(<
429             /debugdict 25 dict def
430             debugdict begin
431              
432             /db_newcol {
433             debugdict begin
434             /db_ypos db_ytop def
435             /db_xpos db_xpos db_xgap add def
436             end
437             } bind def
438             % _ db_newcol => _
439              
440             /db_down {
441             debugdict begin
442             db_ypos db_ybase gt {
443             /db_ypos db_ypos db_ygap sub def
444             }{
445             db_newcol
446             } ifelse
447             end
448             } bind def
449             % _ db_down => _
450              
451             /db_indent {
452             debug_dict begin
453             /db_xpos db_xpos db_xtab add def
454             end
455             } bind def
456             % _ db_indent => _
457              
458             /db_unindent {
459             debugdict begin
460             /db_xpos db_xpos db_xtab sub def
461             end
462             } bind def
463             % _ db_unindent => _
464              
465             /db_show {
466             debugdict begin
467             db_active 0 ne {
468             gsave
469             newpath
470             $o->{db_color}
471             /$o->{db_font} findfont $o->{db_fontsize} scalefont setfont
472             db_xpos db_ypos moveto
473             dup type
474             dup (arraytype) eq {
475             pop db_array
476             }{
477             dup (marktype) eq {
478             pop pop (--mark--) $o->{db_bufsize} string cvs show
479             }{
480             pop $o->{db_bufsize} string cvs show
481             } ifelse
482             db_down
483             } ifelse
484             stroke
485             grestore
486             }{ pop } ifelse
487             end
488             } bind def
489             % _ (msg) db_show => _
490              
491             /db_nshow {
492             debugdict begin
493             db_show
494             /db_num exch def
495             db_num count gt {
496             (Not enough on stack) db_show
497             }{
498             db_num {
499             dup db_show
500             db_num 1 roll
501             } repeat
502             (----------) db_show
503             } ifelse
504             end
505             } bind def
506             % _ n (str) db_nshow => _
507              
508             /db_stack {
509             count 0 gt {
510             count
511             $o->{debug} 2 ge {
512             1 sub
513             } if
514             (The stack holds...) db_nshow
515             } {
516             (Empty stack) db_show
517             } ifelse
518             } bind def
519             % _ db_stack => _
520              
521             /db_one {
522             debugdict begin
523             db_temp cvs
524             dup length exch
525             db_buf exch db_bpos exch putinterval
526             /db_bpos exch db_bpos add def
527             end
528             } bind def
529             % _ any db_one => _
530              
531             /db_print {
532             debugdict begin
533             /db_temp $o->{db_bufsize} string def
534             /db_buf $o->{db_bufsize} string def
535             0 1 $o->{db_bufsize} sub 1 { db_buf exch 32 put } for
536             /db_bpos 0 def
537             {
538             db_one
539             ( ) db_one
540             } forall
541             db_buf db_show
542             end
543             } bind def
544             % _ [array] db_print => _
545              
546             /db_array {
547             mark ([) 2 index aload pop (]) ] db_print pop
548             } bind def
549             % _ [array] db_array => _
550              
551             /db_point {
552             [ 1 index (\\() 5 index (,) 6 index (\\)) ] db_print
553             pop
554             } bind def
555             % _ x y (str) db_point => _ x y
556              
557             /db_where {
558             where {
559             pop (found) db_show
560             }{
561             (not found) db_show
562             } ifelse
563             } bind def
564             % _ var db_where => _
565              
566             /db_on {
567             debugdict begin
568             /db_active 1 def
569             end
570             } bind def
571             % _ db_on => _
572              
573             /db_off {
574             debugdict begin
575             /db_active 0 def
576             end
577             } bind def
578             % _ db_on => _
579              
580             /db_active $o->{db_active} def
581             /db_ytop $o->{db_ytop} def
582             /db_ybase $o->{db_ybase} def
583             /db_xpos $o->{db_xpos} def
584             /db_xtab $o->{db_xtab} def
585             /db_xgap $o->{db_xgap} def
586             /db_ygap $o->{db_fontsize} def
587             /db_ypos $o->{db_ytop} def
588             end
589             END_DEBUG_ON
590             } # end if $o->{debug}
591              
592 104 50 66     319 $debugfn .= $o->_here_doc(<{debug}) and not $o->{debug});
593             % Define out the db_ functions
594             /debugdict 25 dict def
595             debugdict begin
596             /db_newcol { } bind def
597             /db_down { } bind def
598             /db_indent { } bind def
599             /db_unindent { } bind def
600             /db_show { pop } bind def
601             /db_nshow { pop pop } bind def
602             /db_stack { } bind def
603             /db_print { pop } bind def
604             /db_array { pop } bind def
605             /db_point { pop pop pop } bind def
606             end
607             END_DEBUG_OFF
608              
609 104         839 my $ver = sprintf('%g', $VERSION);
610 104         145 my $supplied = "";
611 104 100 100     769 if ($landscapefn or $clipfn or $errorfn or $debugfn) {
      100        
      66        
612 80         145 $docSupplied .= "\%\%+ procset PostScript_File $ver 0\n";
613 80         440 $supplied .= $o->_here_doc(<
614             \%\%BeginResource: procset PostScript_File $ver 0
615             $landscapefn
616             $clipfn
617             $errorfn
618             $debugfn
619             \%\%EndResource
620             END_DOC_SUPPLIED
621             }
622              
623 104         368 my $docNeeded = $o->_build_needed;
624              
625 104         189 my $title = $o->{title};
626 104 100 66     487 $title = $o->quote_text($filename)
627             if not defined $title and defined $filename;
628              
629 104 100       299 $postscript .= $o->{Comments} if ($o->{Comments});
630 104 100       140 $postscript .= "\%\%Orientation: ${\( $o->{landscape} ? 'Landscape' : 'Portrait' )}\n";
  104         368  
631 104 100       262 $postscript .= $docNeeded if $docNeeded;
632 104 100       305 $postscript .= "\%\%DocumentSuppliedResources:\n$docSupplied" if $docSupplied;
633 104 100       260 $postscript .= $o->encode_text("\%\%Title: $title\n") if defined $title;
634 104 50       237 $postscript .= "\%\%Version: $o->{version}\n" if ($o->{version});
635 104 100 100     493 $postscript .= "\%\%Pages: $o->{pagecount}\n" if ((not $o->{eps}) and ($o->{pagecount} > 1));
636 104 100 66     381 $postscript .= "\%\%PageOrder: $o->{order}\n" if ((not $o->{eps}) and ($o->{order}));
637 104 50       216 $postscript .= "\%\%Extensions: $o->{extensions}\n" if ($o->{extensions});
638 104 50       207 $postscript .= "\%\%LanguageLevel: $o->{langlevel}\n" if ($o->{langlevel});
639 104         160 $postscript .= "\%\%EndComments\n";
640              
641 104 100       240 $postscript .= $o->{Preview} if ($o->{Preview});
642              
643 104 100       230 $postscript .= $o->_here_doc(<{Defaults});
644             \%\%BeginDefaults
645             $o->{Defaults}
646             \%\%EndDefaults
647             END_DEFAULTS
648              
649 104         475 $postscript .= $o->_here_doc(<
650             \%\%BeginProlog
651             $supplied
652             $o->{Functions}
653             \%\%EndProlog
654             END_PROLOG
655              
656 104         356 my $setup = "$o->{Fonts}$fonts$o->{Resources}$o->{Setup}";
657 104 100       309 $postscript .= "%%BeginSetup\n$setup%%EndSetup\n" if $setup;
658              
659 104         359 return $postscript;
660             }
661             # Internal method, used by output()
662              
663             sub _build_needed
664             {
665 104     104   163 my $o = shift;
666              
667 104         157 my $needed = $o->{needed};
668              
669 104 100       280 return unless %$needed;
670              
671 65         89 my $comment = "%%DocumentNeededResources:\n";
672              
673 65         254 foreach my $type (sort keys %$needed) {
674 90 100       211 if ($type eq 'font') {
675             # Remove any embedded fonts from the needed fonts:
676 65         75 delete $needed->{$type}{$_} for @{ $o->{embed_fonts} };
  65         194  
677             } # end if fonts
678              
679 90 50       108 next unless %{ $needed->{$type} };
  90         233  
680              
681 90         168 my $prefix = "%%+ $type";
682 90         159 my $maxLen = 79 - length $prefix;
683 90         174 my @list = '';
684              
685 90         110 foreach my $resource (sort keys %{ $needed->{$type} }) {
  90         300  
686 193 100 100     683 push @list, ''
687             if length $list[-1]
688             and length($resource) + length($list[-1]) >= $maxLen;
689 193         407 $list[-1] .= " $resource";
690             } # end foreach $resource
691              
692 90         438 $comment .= "$prefix$_\n" for @list;
693             } # end foreach $type
694              
695 65         160 $comment;
696             } # end _build_needed
697              
698             sub _post_pages
699             {
700 104     104   134 my $o = shift;
701 104         149 my $postscript = "";
702              
703 104         153 my $trailer = $o->{Trailer};
704             $trailer .= "% Local\ Variables:\n% coding: " .
705             $o->{encoding}->mime_name . "\n% End:\n"
706 104 100       577 if $o->{encoding};
707              
708 104 100       1431 $postscript .= "%%Trailer\n$trailer" if $trailer;
709 104         164 $postscript .= "\%\%EOF\n";
710              
711 104         215 return $postscript;
712             }
713             # Internal method, used by output()
714              
715             sub output {
716 104     104 1 5035 my ($o, $filename, $dir) = @_;
717 104         279 my $fh = openhandle $filename;
718             # Don't permanently change filename:
719 104         277 local $o->{filename} = $o->{filename};
720 104 100 100     504 $o->set_filename($filename, $dir) if @_ > 1 and not $fh;
721              
722 104         184 my ($debugbegin, $debugend) = ("", "");
723 104 100       265 if (defined $o->{debug}) {
724 2         4 $debugbegin = "debugdict begin\nuserdict begin";
725 2         4 $debugend = "end\nend";
726 2 50       18 if ($o->{debug} >= 2) {
727 2         11 $debugbegin = $o->_here_doc(<
728             debugdict begin
729             userdict begin
730             mark
731             (Start of page) db_show
732             END_DEBUG_BEGIN
733 2         7 $debugend = $o->_here_doc(<
734             (End of page) db_show
735             db_stack
736             cleartomark
737             end
738             end
739             END_DEBUG_END
740             }
741             } else {
742 102         160 $debugbegin = "userdict begin";
743 102         166 $debugend = "end";
744             }
745              
746 104 100       225 if ($o->{eps}) {
747 7         10 my @pages;
748 7         9 my $p = 0;
749             do {
750 7         9 my $epsfile;
751 7 100       32 if (defined $o->{filename}) {
752 1 50       5 $epsfile = ($o->{pagecount} > 1) ? "$o->{filename}-$o->{page}[$p]"
753             : "$o->{filename}";
754             $epsfile .= defined($o->{file_ext}) ? $o->{file_ext}
755 1 50       7 : ($o->{Preview} ? ".epsi" : ".epsf");
    50          
756             }
757 7         10 my $postscript = "";
758 7         17 my $page = $o->{page}->[$p];
759 7         30 my @pbox = $o->get_page_bounding_box($page);
760 7         22 $o->set_bounding_box(@pbox);
761 7         24 $postscript .= $o->_pre_pages($o->{pagelandsc}[$p], $o->{pageclip}[$p], $epsfile);
762 7 50       24 $postscript .= "landscape\n" if ($o->{pagelandsc}[$p]);
763 7 50       19 $postscript .= "$pbox[0] $pbox[1] $pbox[2] $pbox[3] cliptobox\n" if ($o->{pageclip}[$p]);
764 7         17 $postscript .= "$debugbegin\n";
765 7         10 $postscript .= $o->{Pages}->[$p];
766 7         12 $postscript .= "$debugend\n";
767 7         17 $postscript .= $o->_post_pages();
768              
769 7   100     38 push @pages, $o->_print_file( $fh || $epsfile, $postscript );
770              
771 7         28 $p++;
772 7         10 } while ($p < $o->{pagecount});
773 7 50       43 return wantarray ? @pages : $pages[0];
774             } else {
775 97         156 my $landscape = $o->{landscape};
776 97         122 foreach my $pl (@{$o->{pagelandsc}}) {
  97         252  
777 104         208 $landscape |= $pl;
778             }
779 97         165 my $clipping = $o->{clipping};
780 97         132 foreach my $cl (@{$o->{pageclip}}) {
  97         201  
781 104         181 $clipping |= $cl;
782             }
783 97         162 my $psfile = $o->{filename};
784 97 50       207 $psfile .= defined($o->{file_ext}) ? $o->{file_ext} : '.ps'
    100          
785             if defined $psfile;
786 97         239 my $postscript = $o->_pre_pages($landscape, $clipping, $psfile);
787 97         326 for (my $p = 0; $p < $o->{pagecount}; $p++) {
788 104         192 my $page = $o->{page}->[$p];
789 104         258 my @pbox = $o->get_page_bounding_box($page);
790 104         176 my ($landscape, $pagebb);
791 104 100       275 if ($o->{pagelandsc}[$p]) {
792 10         19 $landscape = "landscape";
793 10         43 $pagebb = $o->_bbox_comment(Page => [ @pbox[1,0,3,2] ]);
794             } else {
795 94         127 $landscape = "";
796 94         251 $pagebb = $o->_bbox_comment(Page => \@pbox);
797             }
798 104 100       307 my $cliptobox = $o->{pageclip}[$p] ? "$pbox[0] $pbox[1] $pbox[2] $pbox[3] cliptobox" : "";
799 104         232 $postscript .= $o->_here_doc(<
800 104         552 \%\%Page: $o->{page}->[$p] ${\($p+1)}
801             $pagebb\%\%BeginPageSetup
802             /pagelevel save def
803             $landscape
804             $cliptobox
805             $debugbegin
806             $o->{PageSetup}
807             \%\%EndPageSetup
808             END_PAGE_SETUP
809 104         353 $postscript .= $o->{Pages}->[$p];
810 104         590 $postscript =~ s/\n?\z/\n/; # Ensure LF at end
811 104         446 $postscript .= $o->_here_doc(<
812             \%\%PageTrailer
813             $o->{PageTrailer}
814             $debugend
815             pagelevel restore
816             showpage
817             END_PAGE_TRAILER
818             }
819 97         235 $postscript .= $o->_post_pages();
820 97   100     485 return $o->_print_file( $fh || $psfile, $postscript );
821             }
822             }
823              
824              
825 0     0 1 0 sub as_string { shift->output(undef) }
826              
827             sub testable_output
828             {
829 28     28 1 168 my ($o, $verbatim) = @_;
830              
831 28         64 my $ps = $o->output(undef);
832              
833 28 50       65 unless ($verbatim) {
834             # Remove PostScript::File generated code:
835 28         728 $ps =~ s/^%%BeginResource: procset PostScript_File.*?^%%EndResource\n//msg;
836 28         155 $ps =~ s/^%%\+ procset PostScript_File.*\n//mg;
837 28         251 $ps =~ s/^% Handle font encoding:\n.*?^% end font encoding\n//ms;
838 28         56 $ps =~ s/^% Local Variables:\n.*?^% End:\n//ms;
839 28         73 $ps =~ s/^%%Trailer\n(?=%%EOF\n)//m;
840             } # end unless $verbatim
841              
842 28         120 $ps;
843             } # end testable_output
844              
845             #---------------------------------------------------------------------
846             # Create a BoundingBox: comment,
847             # and a HiRes version if the box has a fractional part:
848              
849             sub _bbox_comment
850             {
851 111     111   193 my ($o, $type, $bbox) = @_;
852              
853 111         576 my $comment = join(' ', @$bbox);
854              
855 111 100       361 if ($comment =~ /\./) {
856             $comment = sprintf("%d %d %d %d\n%%%%%sHiResBoundingBox: %s",
857 24         57 (map { $_ + 0.999999 } @$bbox),
  96         326  
858             $type, $comment);
859             } # end if fractional bbox
860              
861 111         391 "%%${type}BoundingBox: $comment\n";
862             } # end _bbox_comment
863              
864             sub _print_file
865             {
866 104     104   142 my $o = shift;
867 104         132 my $filename = shift;
868              
869 104 100       198 if (defined $filename) {
870 28         79 my $outfile = openhandle $filename;
871 28 100       77 if ($outfile) {
872 24         90 print $outfile $_[0];
873 24         97 return;
874             } # end if passed a filehandle
875              
876 4 50       487 open($outfile, ">", $filename)
877             or die "Unable to write to \'$filename\' : $!\nStopped";
878              
879 4         84 print $outfile $_[0];
880              
881 4         334 close $outfile;
882              
883 4         40 return $filename;
884             } else {
885 76         521 return $_[0];
886             } # end else no filename
887             } # end _print_file
888             # Internal method, used by output()
889             # Expects file name and contents
890             #---------------------------------------------------------------------
891              
892              
893             sub get_auto_hyphen {
894 0     0 0 0 my $o = shift;
895 0         0 return $o->{auto_hyphen};
896             }
897              
898             sub set_auto_hyphen {
899 57     57 0 108 my ($o, $translate) = @_;
900 57   66     285 $o->{auto_hyphen} = $o->{encoding} && $translate;
901             }
902              
903             sub get_filename {
904 4     4 0 1456 my $o = shift;
905 4         22 return $o->{filename};
906             }
907              
908             sub set_filename {
909 76     76 0 125 my ($o, $filename, $dir) = @_;
910 76 100 66     353 $o->{filename} = ((defined($filename) and length($filename))
911             ? check_file($filename, $dir)
912             : undef);
913             }
914              
915              
916             sub get_file_ext {
917 0     0 0 0 shift->{file_ext};
918             }
919              
920             sub set_file_ext {
921 0     0 0 0 my ($o, $ext) = @_;
922 0         0 $o->{file_ext} = $ext;
923             }
924              
925 0     0 0 0 sub get_eps { my $o = shift; return $o->{eps}; }
  0         0  
926              
927              
928             sub get_paper {
929 0     0 0 0 my $o = shift;
930 0         0 return $o->{paper};
931             }
932              
933             sub set_paper {
934 44     44 0 70 my $o = shift;
935 44   100     156 my $paper = shift || "A4";
936 44   100     380 my ($width, $height) = split(/\s+/, $size{lc($paper)} || '');
937              
938 44 100 66     170 if (not $height and $paper =~ /^(\d+(?:\.\d+)?)\s*x\s*(\d+(?:\.\d+)?)$/i) {
939 2         5 $width = $1;
940 2         6 $height = $2;
941 2         4 $paper = 'Custom';
942             } # end if $paper is 'WIDTH x HEIGHT'
943              
944 44 50       113 if ($height) {
945 44         100 $o->{paper} = $paper;
946 44         94 $o->{width} = $width;
947 44         90 $o->{height} = $height;
948 44 50       103 if ($o->{landscape}) {
949 0         0 $o->{bbox}[0] = 0;
950 0         0 $o->{bbox}[1] = 0;
951 0         0 $o->{bbox}[2] = $height;
952 0         0 $o->{bbox}[3] = $width;
953             } else {
954 44         92 $o->{bbox}[0] = 0;
955 44         73 $o->{bbox}[1] = 0;
956 44         74 $o->{bbox}[2] = $width;
957 44         112 $o->{bbox}[3] = $height;
958             }
959             }
960             }
961              
962              
963             sub get_width {
964 0     0 0 0 my $o = shift;
965 0         0 return $o->{width};
966             }
967              
968             sub set_width {
969 44     44 0 105 my ($o, $width) = @_;
970 44 100 66     148 if (defined($width) and ($width+0)) {
971 1         2 $o->{width} = $width;
972 1         2 $o->{paper} = "Custom";
973 1 50       4 if ($o->{landscape}) {
974 0         0 $o->{bbox}[1] = 0;
975 0         0 $o->{bbox}[3] = $width;
976             } else {
977 1         1 $o->{bbox}[0] = 0;
978 1         3 $o->{bbox}[2] = $width;
979             }
980             }
981             }
982              
983              
984             sub get_height {
985 0     0 0 0 my $o = shift;
986 0         0 return $o->{height};
987             }
988             sub set_height {
989 44     44 0 119 my ($o, $height) = @_;
990 44 100 66     145 if (defined($height) and ($height+0)) {
991 1         3 $o->{height} = $height;
992 1         2 $o->{paper} = "Custom";
993 1 50       3 if ($o->{landscape}) {
994 0         0 $o->{bbox}[0] = 0;
995 0         0 $o->{bbox}[2] = $height;
996             } else {
997 1         2 $o->{bbox}[1] = 0;
998 1         2 $o->{bbox}[3] = $height;
999             }
1000             }
1001             }
1002              
1003              
1004             sub get_landscape {
1005 0     0 0 0 my $o = shift;
1006 0         0 return $o->{landscape};
1007             }
1008              
1009             sub set_landscape {
1010 44     44 0 65 my $o = shift;
1011 44         103 my $landscape = (!!shift) + 0;
1012 44 50       162 $o->{landscape} = 0 unless (defined $o->{landscape});
1013 44 100       190 if ($o->{landscape} != $landscape) {
1014 4         8 $o->{landscape} = $landscape;
1015 4         11 ($o->{bbox}[0], $o->{bbox}[1]) = ($o->{bbox}[1], $o->{bbox}[0]);
1016 4         17 ($o->{bbox}[2], $o->{bbox}[3]) = ($o->{bbox}[3], $o->{bbox}[2]);
1017             }
1018             }
1019              
1020              
1021             sub get_clipping {
1022 0     0 0 0 my $o = shift;
1023 0         0 return $o->{clipping};
1024             }
1025              
1026             sub set_clipping {
1027 95     95 0 153 my $o = shift;
1028 95         325 $o->{clipping} = (!!shift) + 0;
1029             }
1030              
1031             our %encoding_name = qw(
1032             iso-8859-1 ISOLatin1Encoding
1033             cp1252 Win1252Encoding
1034             );
1035              
1036             %encoding_def = (
1037             ISOLatin1Encoding => <<'END ISOLatin1Encoding',
1038             % Define ISO Latin1 encoding if it doesnt exist
1039             /ISOLatin1Encoding where {
1040             % (ISOLatin1 exists!) =
1041             pop
1042             } {
1043             (ISOLatin1 does not exist, creating...) =
1044             /ISOLatin1Encoding StandardEncoding STARTDIFFENC
1045             45 /minus
1046             144 /dotlessi /grave /acute /circumflex /tilde
1047             /macron /breve /dotaccent /dieresis /.notdef /ring
1048             /cedilla /.notdef /hungarumlaut /ogonek /caron /space
1049             /exclamdown /cent /sterling /currency /yen /brokenbar
1050             /section /dieresis /copyright /ordfeminine
1051             /guillemotleft /logicalnot /hyphen /registered
1052             /macron /degree /plusminus /twosuperior
1053             /threesuperior /acute /mu /paragraph /periodcentered
1054             /cedilla /onesuperior /ordmasculine /guillemotright
1055             /onequarter /onehalf /threequarters /questiondown
1056             /Agrave /Aacute /Acircumflex /Atilde /Adieresis
1057             /Aring /AE /Ccedilla /Egrave /Eacute /Ecircumflex
1058             /Edieresis /Igrave /Iacute /Icircumflex /Idieresis
1059             /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde
1060             /Odieresis /multiply /Oslash /Ugrave /Uacute
1061             /Ucircumflex /Udieresis /Yacute /Thorn /germandbls
1062             /agrave /aacute /acircumflex /atilde /adieresis
1063             /aring /ae /ccedilla /egrave /eacute /ecircumflex
1064             /edieresis /igrave /iacute /icircumflex /idieresis
1065             /eth /ntilde /ograve /oacute /ocircumflex /otilde
1066             /odieresis /divide /oslash /ugrave /uacute
1067             /ucircumflex /udieresis /yacute /thorn /ydieresis
1068             ENDDIFFENC
1069             } ifelse
1070             END ISOLatin1Encoding
1071              
1072             Win1252Encoding => <<'END Win1252Encoding',
1073             % Define Windows Latin1 encoding
1074             /Win1252Encoding StandardEncoding STARTDIFFENC
1075             % LanguageLevel 1 may require these to be mapped somewhere:
1076             17 /dotlessi /dotaccent /ring /caron
1077             % Restore glyphs for standard ASCII characters:
1078             45 /minus
1079             96 /grave
1080             % Here are the CP1252 extensions to ISO-8859-1:
1081             128 /Euro /.notdef /quotesinglbase /florin /quotedblbase
1082             /ellipsis /dagger /daggerdbl /circumflex /perthousand
1083             /Scaron /guilsinglleft /OE /.notdef /Zcaron /.notdef
1084             /.notdef /quoteleft /quoteright /quotedblleft /quotedblright
1085             /bullet /endash /emdash /tilde /trademark /scaron
1086             /guilsinglright /oe /.notdef /zcaron /Ydieresis
1087             % We now return you to your ISO-8859-1 character set:
1088             /space
1089             /exclamdown /cent /sterling /currency /yen /brokenbar
1090             /section /dieresis /copyright /ordfeminine
1091             /guillemotleft /logicalnot /hyphen /registered
1092             /macron /degree /plusminus /twosuperior
1093             /threesuperior /acute /mu /paragraph /periodcentered
1094             /cedilla /onesuperior /ordmasculine /guillemotright
1095             /onequarter /onehalf /threequarters /questiondown
1096             /Agrave /Aacute /Acircumflex /Atilde /Adieresis
1097             /Aring /AE /Ccedilla /Egrave /Eacute /Ecircumflex
1098             /Edieresis /Igrave /Iacute /Icircumflex /Idieresis
1099             /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde
1100             /Odieresis /multiply /Oslash /Ugrave /Uacute
1101             /Ucircumflex /Udieresis /Yacute /Thorn /germandbls
1102             /agrave /aacute /acircumflex /atilde /adieresis
1103             /aring /ae /ccedilla /egrave /eacute /ecircumflex
1104             /edieresis /igrave /iacute /icircumflex /idieresis
1105             /eth /ntilde /ograve /oacute /ocircumflex /otilde
1106             /odieresis /divide /oslash /ugrave /uacute
1107             /ucircumflex /udieresis /yacute /thorn /ydieresis
1108             ENDDIFFENC
1109             END Win1252Encoding
1110             ); # end %encoding_def
1111              
1112             sub _set_reencode
1113             {
1114 44     44   95 my ($o, $encoding) = @_;
1115              
1116 44 100       145 return unless $encoding;
1117              
1118 5 100       20 if ($encoding eq 'ISOLatin1Encoding') {
1119 1         10 $o->{reencode} = $encoding;
1120 1         2 return;
1121             } # end if backwards compatible ISOLatin1Encoding
1122              
1123 4 50       27 $o->{reencode} = $encoding_name{$encoding}
1124             or croak "Invalid reencode setting $encoding";
1125              
1126 4         4183 require Encode; Encode->VERSION(2.21); # Need mime_name method
  4         42200  
1127 4 50       26 $o->{encoding} = Encode::find_encoding($encoding)
1128             or croak "Can't find encoding $encoding";
1129             } # end _set_reencode
1130              
1131             our %encode_char = (
1132             8208 => pack(C => 0xAD), # U+2010 HYPHEN
1133             8209 => pack(C => 0xAD), # U+2011 NON-BREAKING HYPHEN
1134             8722 => pack(C => 0x2D), # U+2212 MINUS SIGN
1135             65533 => pack(C => 0x3F), # U+FFFD REPLACEMENT CHARACTER
1136             );
1137              
1138              
1139             sub encode_text
1140             {
1141 684     684 1 954 my $o = shift;
1142              
1143 684         1110 my $encoding = $o->{encoding};
1144              
1145 684 100 100     2005 if ($encoding and Encode::is_utf8( $_[0] )) {
1146             $encoding->encode($_[0], sub {
1147 22 50   22   168 $encode_char{$_[0]} || do {
1148 0 0       0 if ($_[0] < 0x100) {
1149 0         0 pack C => $_[0]; # Unmapped chars stay themselves
1150             } else {
1151 0         0 warn sprintf("PostScript::File can't convert U+%04X to %s\n",
1152             $_[0], $encoding->name);
1153 0         0 '?'
1154             }
1155             }; # end invalid character
1156 9         115 });
1157             } else {
1158 675         3201 $_[0];
1159             }
1160             } # end encode_text
1161              
1162              
1163             sub decode_text
1164             {
1165 84     84 1 109 my $o = shift; # $text, $preserve_minus
1166              
1167 84         141 my $encoding = $o->{encoding};
1168              
1169 84 100 66     445 if ($encoding and not Encode::is_utf8( $_[0] )) {
1170 80     0   404 my $text = $encoding->decode($_[0], sub { pack U => shift });
  0         0  
1171             # Protect - from hyphen-minus processing if $preserve_minus:
1172 80 100       317 $text =~ s/-/\x{2212}/g if $_[1];
1173 80         270 $text;
1174             } else {
1175 4         10 $_[0];
1176             }
1177             } # end decode_text
1178              
1179              
1180             sub convert_hyphens
1181             {
1182 38     38 1 6236 my $o = shift;
1183 38 100       120 if ($_[0] =~ /-/) {
1184             # Text contains at least one hyphen-minus character:
1185 27         65 my $text = $o->decode_text(shift);
1186              
1187             # If it's surrounded by whitespace, or
1188             # it's preceded by whitespace and followed by a digit,
1189             # it's a minus sign (U+2212):
1190 27         173 $text =~ s/(?: ^ | (?<=\s) ) - (?= \d | \s | $ ) /\x{2212}/gx;
1191              
1192             # If it's surrounded by digits, or
1193             # it's preceded by punctuation and followed by a digit,
1194             # it's a minus sign (U+2212):
1195 27         113 $text =~ s/ (?<=[\d[:punct:]]) - (?=\d) /\x{2212}/gx;
1196              
1197             # If it's followed by a currency symbol, it's a minus sign (U+2212):
1198 21     21   19579 $text =~ s/ - (?=\p{Sc}) /\x{2212}/gx;
  21         216  
  21         377  
  27         75  
1199              
1200             # Otherwise, it's a hyphen (U+2010):
1201 27         81 $text =~ s/-/\x{2010}/gx;
1202              
1203 27         108 $text;
1204             } else {
1205 11         31 shift; # Return text unmodified
1206             }
1207             } # end convert_hyphens
1208              
1209              
1210             sub get_metrics
1211             {
1212 0     0 1 0 my ($o, $font, $size, $encoding) = @_;
1213              
1214             # Figure out what encoding to ask for:
1215 0 0       0 unless ($encoding) {
1216 0 0 0     0 if ($font eq 'Symbol') {
    0          
1217 0         0 $encoding = 'sym';
1218             }
1219             elsif ($o->{reencode} and $font =~ s/\Q$o->{font_suffix}\E$//) {
1220 0   0     0 $encoding = $o->{encoding}->name || 'iso-8859-1';
1221             } else {
1222 0         0 $encoding = 'std';
1223             }
1224             } # end unless $encoding supplied as parameter
1225              
1226             # Create the Metrics object:
1227 0         0 require PostScript::File::Metrics;
1228 0         0 my $metrics = PostScript::File::Metrics->new($font, $size, $encoding);
1229              
1230             # Whatever encoding they asked for, make sure that the
1231             # auto-translation matches what we're doing:
1232 0         0 $metrics->{encoding} = $o->{encoding};
1233 0         0 $metrics->{auto_hyphen} = $o->{auto_hyphen};
1234              
1235 0         0 $metrics;
1236             } # end get_metrics
1237             #---------------------------------------------------------------------
1238              
1239              
1240             sub get_strip {
1241 0     0 0 0 my $o = shift;
1242 0         0 return $o->{strip_type};
1243             }
1244              
1245             my $eolRE = qr/(?>\r\n?|\n)/;
1246             my $noeolRE = qr/[^\r\n]/;
1247             my $nonwsRE = qr/[^ \t\r\n]/;
1248              
1249             my %strip_re = (
1250             none => 0, # remove nothing
1251             space => qr{\G^\s+}m, # remove leading spaces
1252             # remove leading spaces and single line comments (except %% and %!):
1253             comments => qr{\G^(?:\s+|%(?![!%])(?:$noeolRE)*(?:$eolRE))}mo,
1254             # remove leading spaces and all comments (except %% and %!):
1255             all_comments => qr{\G (?: ^\s+
1256             | ^% (?![!%]) (?:$noeolRE)* (?:$eolRE)
1257             | [ \t]*%(?![!%]) (?:$noeolRE)* )
1258             }mox,
1259             ); # end strip_re
1260              
1261             sub set_strip {
1262 44     44 0 90 my ($o, $strip) = @_;
1263              
1264 44 100       104 if (not defined $strip) { $strip = 'space' }
  27         51  
1265 17         32 else { $strip = lc $strip }
1266              
1267 44 50       196 defined($o->{strip} = $strip_re{$strip})
1268             or croak "Invalid strip type $strip";
1269 44         112 $o->{strip_type} = $strip;
1270             }
1271              
1272             #sub chkpt
1273             #{
1274             # my $at = substr($_, pos(), 5);
1275             # $at =~ s/([^ -~])/sprintf '\x%02X', ord $1 /eg;
1276             # printf "%d: %s\n", pos(), $at;
1277             #} # end chkpt
1278              
1279             sub strip
1280             {
1281 555     555 1 752 my $o = shift;
1282              
1283 555         599 my $re;
1284 555 100       1073 if (@_ > 1) {
1285 26         41 my $strip = shift;
1286 26 50       105 defined($re = $strip_re{$strip})
1287             or croak "Invalid strip type $strip";
1288             } else {
1289 529         848 $re = $o->{strip};
1290             }
1291              
1292 555 50       2238 return unless $re;
1293              
1294 555         619 my $pos;
1295              
1296 555         1041 for (@_) {
1297 555 50       1089 next unless defined $_;
1298 555         1251 pos() = 0;
1299 555         1596 while (pos() < length) {
1300 33329 100 66     191908 next if m/\G<~[^~]*~>/gc
1301             or m/\G\( (?: [^\\)]+ | \\. )* \)/sgcx;
1302 33268         41489 $pos = pos();
1303 33268 100       212835 if (s/$re//m) {
1304 4828         16489 pos() = $pos;
1305             } else {
1306 28440         48255 pos() = $pos;
1307 28440         77301 m/\G[ \t]*(?:$eolRE|(?:$nonwsRE)+(?:$eolRE)?)/ogc;
1308 28440 50       92719 die "Infinite loop" if pos() == $pos;
1309             }
1310             }
1311             } # end for @_
1312              
1313 555         1096 return;
1314             } # end strip
1315             #---------------------------------------------------------------------
1316              
1317              
1318             sub get_page_landscape {
1319 0     0 0 0 my $o = shift;
1320 0         0 my $p = $o->_get_ordinal( shift );
1321 0         0 return $o->{pagelandsc}[$p];
1322             }
1323              
1324             sub set_page_landscape {
1325 0     0 0 0 my $o = shift;
1326 0 0       0 my $p = (@_ == 2) ? $o->_get_ordinal(shift) : $o->{p};
1327 0         0 my $landscape = (!!shift) + 0;
1328 0 0       0 $o->{pagelandsc}[$p] = 0 unless (defined $o->{pagelandsc}[$p]);
1329 0 0       0 if ($o->{pagelandsc}[$p] != $landscape) {
1330 0         0 ($o->{pagebbox}[$p][0], $o->{pagebbox}[$p][1]) = ($o->{pagebbox}[$p][1], $o->{pagebbox}[$p][0]);
1331 0         0 ($o->{pagebbox}[$p][2], $o->{pagebbox}[$p][3]) = ($o->{pagebbox}[$p][3], $o->{pagebbox}[$p][2]);
1332             }
1333 0         0 $o->{pagelandsc}[$p] = $landscape;
1334             }
1335              
1336             #---------------------------------------------------------------------
1337              
1338              
1339             sub get_page_clipping {
1340 0     0 0 0 my $o = shift;
1341 0         0 my $p = $o->_get_ordinal( shift );
1342 0         0 return $o->{pageclip}[$p];
1343             }
1344              
1345             sub set_page_clipping {
1346 0     0 0 0 my $o = shift;
1347 0 0       0 my $p = (@_ == 2) ? $o->_get_ordinal(shift) : $o->{p};
1348 0         0 $o->{pageclip}[$p] = (!!shift) + 0;
1349             }
1350              
1351              
1352             sub get_page_label {
1353 6     6 0 477 my $o = shift;
1354 6         25 return $o->{page}[$o->{p}];
1355             }
1356              
1357             sub set_page_label {
1358 44     44 0 69 my $o = shift;
1359 44   100     224 my $page = shift || 1;
1360 44         138 $o->{page}[$o->{p}] = $page;
1361             }
1362              
1363              
1364             sub get_incpage_handler {
1365 0     0 0 0 my $o = shift;
1366 0         0 return $o->{incpage};
1367             }
1368              
1369             sub set_incpage_handler {
1370 44     44 0 66 my $o = shift;
1371 44   100     269 $o->{incpage} = shift || \&incpage_label;
1372             }
1373              
1374              
1375             sub get_order {
1376 0     0 0 0 my $o = shift;
1377 0         0 return $o->{order};
1378             }
1379              
1380              
1381             sub get_title {
1382 0     0 0 0 my $o = shift;
1383 0         0 return $o->{title};
1384             }
1385              
1386              
1387             sub get_version {
1388 0     0 0 0 my $o = shift;
1389 0         0 return $o->{version};
1390             }
1391              
1392              
1393             sub get_langlevel {
1394 0     0 0 0 my $o = shift;
1395 0         0 return $o->{langlevel};
1396             }
1397              
1398             sub set_min_langlevel
1399             {
1400 0     0 1 0 my ($o, $level) = @_;
1401 0 0 0     0 $o->{langlevel} = $level unless ($o->{langlevel} || 0) >= $level;
1402 0         0 return $o->{langlevel};
1403             }
1404              
1405              
1406             sub get_extensions {
1407 0     0 0 0 my $o = shift;
1408 0         0 return $o->{extensions};
1409             }
1410              
1411              
1412             sub get_bounding_box {
1413 0     0 0 0 my $o = shift;
1414 0         0 return @{$o->{bbox}};
  0         0  
1415             }
1416              
1417             sub set_bounding_box {
1418 51     51 0 100 my ($o, $x0, $y0, $x1, $y1) = @_;
1419 51 50       230 $o->{bbox} = [ $x0, $y0, $x1, $y1 ] if (defined $y1);
1420 51         178 $o->set_clipping(1);
1421             }
1422              
1423              
1424             sub get_printable_width
1425             {
1426 0     0 1 0 my $bb = shift->{bbox};
1427 0         0 return $bb->[2] - $bb->[0];
1428             } # end get_printable_width
1429              
1430             sub get_printable_height
1431             {
1432 0     0 1 0 my $bb = shift->{bbox};
1433 0         0 return $bb->[3] - $bb->[1];
1434             } # end get_printable_height
1435              
1436              
1437             sub get_page_bounding_box {
1438 111     111 0 155 my $o = shift;
1439 111         281 my $p = $o->_get_ordinal( shift );
1440 111         135 return @{$o->{pagebbox}[$p]};
  111         458  
1441             }
1442              
1443             sub set_page_bounding_box {
1444 0     0 0 0 my $o = shift;
1445 0 0       0 my $page = (@_ == 5) ? shift : "";
1446 0 0       0 if (@_ == 4) {
1447 0         0 my $p = $o->_get_ordinal($page);
1448 0         0 $o->{pagebbox}[$p] = [ @_ ];
1449 0         0 $o->set_page_clipping($page, 1);
1450             }
1451             }
1452              
1453              
1454             sub get_page_printable_width
1455             {
1456 0     0 1 0 my $o = shift;
1457 0         0 my $bb = $o->{pagebbox}[$o->_get_ordinal( shift )];
1458 0         0 return $bb->[2] - $bb->[0];
1459             } # end get_page_printable_width
1460              
1461             sub get_page_printable_height
1462             {
1463 0     0 1 0 my $o = shift;
1464 0         0 my $bb = $o->{pagebbox}[$o->_get_ordinal( shift )];
1465 0         0 return $bb->[3] - $bb->[1];
1466             } # end get_page_printable_height
1467              
1468              
1469             sub set_page_margins {
1470 0     0 1 0 my $o = shift;
1471 0 0       0 my $page = (@_ == 5) ? shift : "";
1472 0 0       0 if (@_ == 4) {
1473 0         0 my ($left, $bottom, $right, $top) = @_;
1474 0         0 my $p = $o->_get_ordinal($page);
1475 0 0       0 if ($o->{pagelandsc}[$p]) {
1476 0         0 $o->{pagebbox}[$p] = [ $left, $bottom, $o->{height}-$right, $o->{width}-$top ];
1477             } else {
1478 0         0 $o->{pagebbox}[$p] = [ $left, $bottom, $o->{width}-$right, $o->{height}-$top ];
1479             }
1480 0         0 $o->set_page_clipping($page, 1);
1481             }
1482             }
1483              
1484             # =method-access get_ordinal
1485             #
1486             # $index = $ps->get_ordinal( [$page] )
1487             #
1488             # Returns the internal number for the page label specified. (Default:
1489             # current page)
1490             #
1491             # Example
1492             #
1493             # Say pages are labeled "i", "ii", "iii, "iv", "1", "2", "3".
1494             #
1495             # get_ordinal("i") == 0
1496             # get_ordinal("iv") == 3
1497             # get_ordinal("1") == 4
1498             #
1499             # =cut
1500              
1501             sub _get_ordinal
1502             {
1503 113     113   177 my ($o, $page) = @_;
1504 113 50       236 if ($page) {
1505 113         335 for (my $i = 0; $i <= $o->{pagecount}; $i++) {
1506 120   50     346 my $here = $o->{page}->[$i] || "";
1507 120 100       430 return $i if ($here eq $page);
1508             }
1509             }
1510 0         0 return $o->{p};
1511             }
1512              
1513              
1514             sub get_pagecount {
1515 0     0 1 0 my $o = shift;
1516 0         0 return $o->{pagecount};
1517             }
1518              
1519              
1520             sub set_variable {
1521 0     0 1 0 my ($o, $key, $value) = @_;
1522 0         0 $o->{vars}{$key} = $value;
1523             }
1524              
1525              
1526             sub get_variable {
1527 0     0 1 0 my ($o, $key) = @_;
1528 0         0 return $o->{vars}{$key};
1529             }
1530              
1531              
1532             sub set_page_variable {
1533 0     0 1 0 my ($o, $key, $value) = @_;
1534 0         0 $o->{pagevars}{$key} = $value;
1535             }
1536              
1537              
1538             sub get_page_variable {
1539 0     0 1 0 my ($o, $key) = @_;
1540 0         0 return $o->{pagevars}{$key};
1541             }
1542              
1543              
1544             sub get_comments {
1545 0     0 1 0 my $o = shift;
1546 0         0 return $o->{Comments};
1547             }
1548              
1549              
1550             sub add_comment {
1551 4     4 1 180 my ($o, $entry) = @_;
1552 4 50       42 $o->{Comments} .= "\%\%$entry\n" if defined($entry);
1553             }
1554              
1555              
1556             sub get_preview {
1557 0     0 1 0 my $o = shift;
1558 0         0 return $o->{Preview};
1559             }
1560              
1561              
1562             sub add_preview {
1563 2     2 1 131 my ($o, $width, $height, $depth, $lines, $entry) = @_;
1564 2 50       8 if (defined $entry) {
1565 2         5 $entry .= "\n";
1566 2         6 $o->strip(space => $entry);
1567             $o->{Preview} =
1568 2         26 "%%BeginPreview: $width $height $depth $lines\n$entry%%EndPreview\n";
1569             }
1570             } # end add_preview
1571              
1572              
1573             sub get_defaults {
1574 0     0 1 0 my $o = shift;
1575 0         0 return $o->{Defaults};
1576             }
1577              
1578              
1579             sub add_default {
1580 4     4 1 155 my ($o, $entry) = @_;
1581 4 50       39 $o->{Defaults} .= "\%\%$entry\n" if defined($entry);
1582             }
1583              
1584              
1585             sub get_resources {
1586 0     0 1 0 my $o = shift;
1587 0         0 return $o->{Fonts} . $o->{Resources};
1588             }
1589              
1590             our %supplied_type = (qw(
1591             Document file
1592             Feature) => ''
1593             );
1594              
1595             our %add_resource_accepts = map { $_ => 1 } qw(
1596             encoding file font form pattern
1597             );
1598             # add_resource does not accept procset, but need_resource does:
1599             $add_resource_accepts{procset} = undef;
1600              
1601             sub add_resource {
1602 4     4 1 226 my ($o, $type, $name, $params, $resource) = @_;
1603              
1604 4         8 my $suptype = $supplied_type{$type};
1605 4         10 my $restype = '';
1606              
1607             croak "add_resource does not accept type $type"
1608 4 50 33     28 unless defined($suptype) or $add_resource_accepts{lc $type};
1609              
1610 4 50       12 unless (defined $suptype) {
1611 4         7 $suptype = lc $type;
1612 4         8 $restype = "$suptype ";
1613 4         8 $type = 'Resource';
1614             } # end unless Document or Feature
1615              
1616 4 50       11 if (defined($resource)) {
1617 4         11 $o->strip($resource);
1618 4         12 $name = $o->quote_text($name);
1619 4 50       25 $o->{DocSupplied} .= $o->encode_text("\%\%+ $suptype $name\n")
1620             if $suptype;
1621              
1622             # Store fonts separately, because they need to come first:
1623 4         9 my $storage = 'Resources';
1624              
1625 4 100       12 if ($suptype eq 'font') {
1626 2         4 $storage = 'Fonts';
1627 2         4 push @{ $o->{embed_fonts} }, $name; # Remember to reencode it
  2         6  
1628             } # end if adding Font
1629              
1630 4 50 33     24 $name .= " $params" if defined $params and length $params;
1631              
1632 4         21 $o->{$storage} .= $o->_here_doc(<
1633             \%\%Begin${type}: $restype$name
1634             $resource
1635             \%\%End$type
1636             END_USER_RESOURCE
1637             }
1638             }
1639              
1640              
1641              
1642             sub get_procsets
1643             {
1644 0     0 1 0 my $o = shift;
1645 0         0 return $o->{Functions};
1646             }
1647              
1648             sub add_procset
1649             {
1650 6     6 1 13 my ($o, $name, $entry, $version, $revision) = @_;
1651 6 50 33     30 if (defined($name) and defined($entry)) {
1652 6 100       11 return if $o->has_procset($name);
1653 2         7 $o->strip($entry);
1654 2   50     6 $name = sprintf('%s %g %d', $o->quote_text($name),
      50        
1655             $version||0, $revision||0);
1656 2         11 $o->{DocSupplied} .= $o->encode_text("\%\%+ procset $name\n");
1657 2         10 $o->{Functions} .= $o->_here_doc(<
1658             \%\%BeginResource: procset $name
1659             $entry
1660             \%\%EndResource
1661             END_USER_FUNCTIONS
1662 2         7 return 1;
1663             }
1664 0         0 return;
1665             }
1666              
1667              
1668             sub has_procset
1669             {
1670 6     6 1 12 my ($o, $name) = @_;
1671 6         14 $name = $o->quote_text($name);
1672 6         73 return ($o->{DocSupplied} =~ /^\%\%\+ procset \Q$name\E /m);
1673             }
1674              
1675             # Retain the old names for backwards compatibility:
1676             *add_function = \&add_procset;
1677             *get_functions = \&get_procsets;
1678             *has_function = \&has_procset;
1679              
1680              
1681             sub use_functions
1682             {
1683 3     3 1 157 my $o = shift;
1684              
1685             (
1686 3   66     14 $o->{use_functions} ||= do {
1687 2         728 require PostScript::File::Functions;
1688              
1689 2         11 PostScript::File::Functions->new;
1690             }
1691             )->add(@_);
1692              
1693 3         21 return $o;
1694             } # end use_functions
1695              
1696              
1697             sub embed_document
1698             {
1699 8     8 1 483 my ($o, $filename) = @_;
1700              
1701 8         31 my $id = $o->quote_text(substr($filename, -234)); # in case it's long
1702 8         37 my $supplied = $o->encode_text("%%+ file $id\n");
1703             $o->{DocSupplied} .= $supplied
1704 8 50       46 unless index($o->{DocSupplied}, $supplied) >= 0;
1705              
1706 8         28 local $/; # Read entire file
1707 8 50       394 open(my $in, '<:raw', $filename) or croak "Unable to open $filename: $!";
1708 8         316 my $content = <$in>;
1709 8         125 close $in;
1710              
1711             # Remove TIFF or WMF preview image:
1712 8 100       37 if ($content =~ /^\xC5\xD0\xD3\xC6/) {
1713 4         49 my ($pos, $len) = unpack('V2', substr($content, 4, 8));
1714 4         17 $content = substr($content, $pos, $len);
1715             } # end if EPS file with TIFF or WMF preview image
1716              
1717             # Do CR or CRLF -> LF processing, since we read in RAW mode:
1718 8         48 $content =~ s/\r\n?/\n/g;
1719              
1720             # Remove EPSI preview:
1721 8         154 $content =~ s/^\s*%%BeginPreview:.*\n
1722             (?:\s*%(?!%).*\n)*
1723             \s*%%EndPreview.*\n//gmx;
1724              
1725 8         88 return "\%\%BeginDocument: $id\n$content\n\%\%EndDocument\n";
1726             } # end embed_document
1727              
1728              
1729             sub embed_font
1730             {
1731 0     0 1 0 my ($o, $filename, $type) = @_;
1732              
1733 0 0       0 unless ($type) {
1734 0 0       0 $filename =~ /\.([^\\\/.]+)$/ or croak "No extension in $filename";
1735 0         0 $type = $1;
1736             }
1737 0         0 $type = uc $type;
1738              
1739 0         0 my $in;
1740 0 0       0 if ($type eq 'PFA') {
    0          
    0          
1741 0 0       0 open($in, '<:raw', $filename) or croak "Unable to open $filename: $!";
1742             } elsif ($type eq 'PFB') {
1743 0 0       0 open($in, '-|:raw', $t1ascii, $filename)
1744             or croak "Unable to run $t1ascii $filename: $!";
1745             } elsif ($type eq 'TTF') {
1746 0 0       0 open($in, '-|:raw', $ttftotype42, $filename)
1747             or croak "Unable to run $ttftotype42 $filename: $!";
1748             # Type 42 was introduced in LanguageLevel 2:
1749 0         0 $o->set_min_langlevel(2);
1750             }
1751              
1752 0         0 my $content = do { local $/; <$in> }; # Read entire file
  0         0  
  0         0  
1753 0         0 close $in;
1754              
1755 0         0 $content =~ s/\r\n?/\n/g; # CR or CRLF to LF
1756              
1757 0 0       0 $content =~ m!/FontName\s+/(\S+)\s+def\b!
1758             or croak "Unable to find font name in $filename";
1759 0         0 my $fontName = $1;
1760              
1761 0         0 $o->add_resource(Font => $fontName, undef, $content);
1762              
1763 0         0 return $fontName;
1764             } # end embed_font
1765              
1766              
1767             sub need_resource
1768             {
1769 81     81 1 633 my $o = shift;
1770 81         113 my $type = shift;
1771              
1772             croak "Unknown resource type $type"
1773 81 50       211 unless exists $add_resource_accepts{$type};
1774              
1775 81   100     324 my $hash = $o->{needed}{$type} ||= {};
1776              
1777 81         156 foreach my $res (@_) {
1778              
1779             $hash->{ $o->encode_text(
1780 89 100       234 join(' ', map { $o->quote_text($_) } (ref $res ? @$res : $res))
  93         217  
1781             )} = 1;
1782             } # end foreach $res
1783             } # end need_resource
1784              
1785              
1786             sub get_setup {
1787 0     0 1 0 my $o = shift;
1788 0         0 return $o->{Setup};
1789             }
1790              
1791              
1792             sub add_setup {
1793 4     4 1 205 my ($o, $entry) = @_;
1794 4         11 $o->strip($entry);
1795 4 50       20 $o->{Setup} .= $o->encode_text($entry) if (defined $entry);
1796             }
1797              
1798              
1799             sub get_page_setup {
1800 0     0 1 0 my $o = shift;
1801 0         0 return $o->{PageSetup};
1802             }
1803              
1804              
1805             sub add_page_setup {
1806 4     4 1 188 my ($o, $entry) = @_;
1807 4         11 $o->strip($entry);
1808 4 50       21 $o->{PageSetup} .= $o->encode_text($entry) if (defined $entry);
1809             }
1810              
1811              
1812             sub get_page {
1813 2     2 1 998 my $o = shift;
1814 2   33     13 my $page = shift || $o->get_page_label();
1815 2         10 my $ord = $o->_get_ordinal($page);
1816 2         10 return $o->{Pages}->[$ord];
1817             }
1818              
1819              
1820             sub add_to_page {
1821 27     27 1 2439 my $o = shift;
1822 27 50       82 my $page = (@_ == 2) ? shift : "";
1823 27   50     85 my $entry = shift || "";
1824 27 50       72 if ($page) {
1825 0         0 my $ord = $o->_get_ordinal($page);
1826 0 0 0     0 if (($ord == $o->{p}) and ($page ne $o->{page}[$ord])) {
1827 0         0 $o->newpage($page);
1828             } else {
1829 0         0 $o->{p} = $ord;
1830             }
1831             }
1832 27         67 $o->strip($entry);
1833 27         106 $o->{Pages}[$o->{p}] .= $o->encode_text($entry);
1834             }
1835              
1836              
1837             sub get_page_trailer {
1838 0     0 1 0 my $o = shift;
1839 0         0 return $o->{PageTrailer};
1840             }
1841              
1842              
1843             sub add_page_trailer {
1844 4     4 1 184 my ($o, $entry) = @_;
1845 4         12 $o->strip($entry);
1846 4 50       19 $o->{PageTrailer} .= $o->encode_text($entry) if (defined $entry);
1847             }
1848              
1849              
1850             sub get_trailer {
1851 0     0 1 0 my $o = shift;
1852 0         0 return $o->{Trailer};
1853             }
1854              
1855              
1856             sub add_trailer {
1857 4     4 1 179 my ($o, $entry) = @_;
1858 4         12 $o->strip($entry);
1859 4 50       28 $o->{Trailer} .= $o->encode_text($entry) if (defined $entry);
1860             }
1861              
1862             #=============================================================================
1863              
1864              
1865             sub draw_bounding_box {
1866 0     0 0 0 my $o = shift;
1867 0         0 $o->{clipcmd} = "stroke";
1868             }
1869              
1870             sub clip_bounding_box {
1871 0     0 0 0 my $o = shift;
1872 0         0 $o->{clipcmd} = "clip";
1873             }
1874              
1875             # Strip leading spaces off a here document:
1876              
1877             sub _here_doc
1878             {
1879 505     505   812 my ($o, $text) = @_;
1880              
1881 505 100       1219 if ($o->{strip_type} ne 'none') {
    50          
1882 480         999 $o->strip($text);
1883             } elsif ($text =~ /^([ \t]+)/) {
1884 25         50 my $space = $1;
1885              
1886 25         479 $text =~ s/^$space//gm;
1887 25         217 $text =~ s/^[ \t]+\n/\n/gm;
1888             } # end elsif no strip but $text is indented
1889              
1890 505         1158 $o->encode_text($text);
1891             } # end _here_doc
1892              
1893              
1894             sub incpage_label ($) { ## no critic (ProhibitSubroutinePrototypes)
1895 1     1 1 2 my $page = shift;
1896 1         2 return ++$page;
1897             }
1898             #---------------------------------------------------------------------
1899              
1900              
1901             our $roman_max = 40;
1902             our @roman = qw(0 i ii iii iv v vi vii viii ix x xi xii xiii xiv xv xvi xvii xviii xix
1903             xx xi xxii xxii xxiii xxiv xxv xxvi xxvii xxviii xxix
1904             xxx xxi xxxii xxxii xxxiii xxxiv xxxv xxxvi xxxvii xxxviii xxxix );
1905             our %roman = ();
1906             for (my $i = 1; $i <= $roman_max; $i++) {
1907             $roman{$roman[$i]} = $i;
1908             }
1909              
1910             sub incpage_roman ($) { ## no critic (ProhibitSubroutinePrototypes)
1911 1     1 1 2 my $page = shift;
1912 1         4 my $pos = $roman{$page};
1913 1         3 return $roman[++$pos];
1914             }
1915             #---------------------------------------------------------------------
1916              
1917              
1918             sub check_file ($;$$) { ## no critic (ProhibitSubroutinePrototypes)
1919 8     8 1 21 my ($filename, $dir, $create) = @_;
1920 8 50       29 $create = 0 unless (defined $create);
1921              
1922 8 50 33     54 if (not defined $filename or not length $filename) {
1923 0         0 $filename = File::Spec->devnull();
1924             } else {
1925 8         28 $filename = check_tilde($filename);
1926 8         33 $filename = File::Spec->canonpath($filename);
1927 8 50       53 unless (File::Spec->file_name_is_absolute($filename)) {
1928 8 50       22 if (defined($dir)) {
1929 8         17 $dir = check_tilde($dir);
1930 8         30 $dir = File::Spec->canonpath($dir);
1931 8 50       64 $dir = File::Spec->rel2abs($dir) unless (File::Spec->file_name_is_absolute($dir));
1932 8         92 $filename = File::Spec->catfile($dir, $filename);
1933             } else {
1934 0         0 $filename = File::Spec->rel2abs($filename);
1935             }
1936             }
1937              
1938 8         22 my @subdirs = ();
1939 8         115 my ($volume, $directories, $file) = File::Spec->splitpath($filename);
1940 8         54 @subdirs = File::Spec->splitdir( $directories );
1941              
1942 8         22 my $path = $volume;
1943 8         16 foreach my $dir (@subdirs) {
1944 32         161 $path = File::Spec->catdir( $path, $dir );
1945 32 50       475 mkdir $path unless (-d $path);
1946             }
1947              
1948 8         101 $filename = File::Spec->catfile($path, $file);
1949 8 50       39 if ($create) {
1950 0 0       0 unless (-e $filename) {
1951 0 0       0 open(my $file, ">", $filename)
1952             or die "Unable to open \'$filename\' for writing : $!\nStopped";
1953 0         0 close $file;
1954             }
1955             }
1956             }
1957              
1958 8         25 return $filename;
1959             }
1960              
1961              
1962             sub check_tilde ($) { ## no critic (ProhibitSubroutinePrototypes)
1963 16     16 1 27 my ($dir) = @_;
1964 16 50       44 $dir = "" unless defined $dir;
1965 16 0 0     28 $dir =~ s{^~([^/]*)}{$1 ? (getpwnam($1))[7] : ($ENV{HOME} || $ENV{LOGDIR} || (getpwuid($>))[7]) }ex;
  0         0  
1966 16         35 return $dir;
1967             }
1968              
1969              
1970             sub array_as_string (@) { ## no critic (ProhibitSubroutinePrototypes)
1971 0     0 1 0 my $array = "[ ";
1972 0         0 foreach my $f (@_) { $array .= "$f "; }
  0         0  
1973 0         0 $array .= "]";
1974 0         0 return $array;
1975             }
1976              
1977              
1978             sub str ($) { ## no critic (ProhibitSubroutinePrototypes)
1979 0     0 1 0 my $arg = shift;
1980 0 0       0 if (ref($arg) eq "ARRAY") {
1981 0         0 return array_as_string( @$arg );
1982             } else {
1983 0         0 return $arg;
1984             }
1985             }
1986             #---------------------------------------------------------------------
1987              
1988             my %special = (
1989             "\n" => '\n', "\r" => '\r', "\t" => '\t', "\b" => '\b',
1990             "\f" => '\f', "\\" => "\\\\", "(" => '\(', ")" => '\)',
1991             );
1992             my $specialKeys = join '', keys %special;
1993             $specialKeys =~ s/\\/\\\\/; # Have to quote backslash
1994              
1995             sub pstr {
1996 53     53 1 29040 my $o;
1997 53 100       188 $o = shift if @_ > 1; # We were called as a method
1998 53         79 my $string = shift;
1999 53         67 my $nowrap = shift; # Pass this ONLY when method call
2000              
2001             # Possibly convert \x2D (hyphen-minus) to hyphen or minus sign:
2002             $string = $o->convert_hyphens($string)
2003 53 100 66     287 if ref $o and $o->{auto_hyphen} and $string =~ /-/;
      66        
2004              
2005             # Now form the parenthesized string:
2006 53         354 $string =~ s/([$specialKeys])/$special{$1}/go;
2007 53         125 $string = "($string)";
2008             # A PostScript file should not have more than 255 chars per line:
2009 53 100       175 $string =~ s/(.{240}[^\\])/$1\\\n/g unless $nowrap;
2010 53         121 $string =~ s/^([ %])/\\$1/mg; # Make sure it doesn't get stripped
2011              
2012 53         206 $string;
2013             } # end pstr
2014              
2015              
2016             sub quote_text
2017             {
2018 117     117 1 122 my $o;
2019 117 50       294 $o = shift if @_ > 1; # We were called as a method
2020              
2021 117         177 my $string = shift;
2022              
2023 117 100       870 return $string if $string =~ m(^[-+_./*A-Za-z0-9]+\z);
2024              
2025 2         10 __PACKAGE__->pstr($string, 1);
2026             } # end quote_text
2027              
2028             #=============================================================================
2029             1;
2030              
2031             __END__