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

#---------------------------------------------------------------------
package PostScript::File;
#
# Copyright 2002, 2003 Christopher P Willmot.
# Copyright 2011 Christopher J. Madsen
#
# Author: Chris Willmot
#         Christopher J. Madsen
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl 5 itself.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either the
# GNU General Public License or the Artistic License for more details.
#
# ABSTRACT: Class for creating Adobe PostScript files
#---------------------------------------------------------------------

use 5.008;
our $VERSION = '2.23';          ## no critic
# This file is part of PostScript-File 2.23 (October 10, 2015)

use strict;
use warnings;
use Carp 'croak';
use File::Spec ();
use Scalar::Util 'openhandle';
use Exporter 5.57 'import';

our %EXPORT_TAGS = (metrics_methods => [qw(
  encode_text decode_text convert_hyphens set_auto_hyphen
)]);

our @EXPORT_OK = (qw(check_tilde check_file incpage_label incpage_roman
                    array_as_string pstr quote_text str),
                  # These are only for PostScript::File::Metrics:
                  @{ $EXPORT_TAGS{metrics_methods} });

# Prototypes for functions only
 ## no critic (ProhibitSubroutinePrototypes)
 sub incpage_label ($);
 sub incpage_roman ($);
 sub check_tilde ($);
 sub check_file ($;$$);
 ## use critic

# global constants
our %encoding_def; # defined near _set_reencode

our ($t1ascii, $ttftotype42);
BEGIN {
  # Program to convert .pfb fonts to .pfa on STDOUT:
  $t1ascii     = 't1ascii'     unless defined $t1ascii;
  # Program to convert .ttf fonts to .pfa on STDOUT:
  $ttftotype42 = 'ttftotype42' unless defined $ttftotype42;
}


# define page sizes here (a4, letter, etc)
# should be Properly Cased
our %size = (
    a0                    => '2384 3370',
    a1                    => '1684 2384',
    a2                    => '1191 1684',
    a3                    => "841.88976 1190.5512",
    a4                    => "595.27559 841.88976",
    a5                    => "420.94488 595.27559",
    a6                    => '297 420',
    a7                    => '210 297',
    a8                    => '148 210',
    a9                    => '105 148',

    b0                    => '2920 4127',
    b1                    => '2064 2920',
    b2                    => '1460 2064',
    b3                    => '1032 1460',
    b4                    => '729 1032',
    b5                    => '516 729',
    b6                    => '363 516',
    b7                    => '258 363',
    b8                    => '181 258',
    b9                    => '127 181 ',
    b10                   => '91 127',

    executive             => '522 756',
    folio                 => '595 935',
    'half-letter'         => '612 397',
    letter                => "612 792",
    'us-letter'           => '612 792',
    legal                 => '612 1008',
    'us-legal'            => '612 1008',
    tabloid               => '792 1224',
    'superb'              => '843 1227',
    ledger                => '1224 792',

    'comm #10 envelope'   => '297 684',
    'envelope-monarch'    => '280 542',
    'envelope-dl'         => '312 624',
    'envelope-c5'         => '461 648',

    'europostcard'        => '298 420',
);


# The 13 standard fonts that are available on all PS 1 implementations:
our @fonts = qw(
    Courier
    Courier-Bold
    Courier-BoldOblique
    Courier-Oblique
    Helvetica
    Helvetica-Bold
    Helvetica-BoldOblique
    Helvetica-Oblique
    Times-Roman
    Times-Bold
    Times-BoldItalic
    Times-Italic
    Symbol
);

# 5.008-compatible version of defined-or:
sub _def { for (@_) { return $_ if defined $_ } undef }

sub new {
    my ($class, @options) = @_;
    my $opt = {};
    if (@options == 1) {
        $opt = $options[0];
    } else {
        %$opt = @options;
    }

    ## Initialization
    my $o = {
        # PostScript DSC sections
        Comments    => "",  # must include leading '%%' and end with '\n'
        DocSupplied => "",
        Preview     => "",
        Defaults    => "",
        Fonts       => "",
        Resources   => "",
        Functions   => "",
        Setup       => "",
        PageSetup   => "",
        Pages       => [],  # indexed by $o->{p}, 0 based
        PageTrailer => "",
        Trailer     => "",

        # internal
        p           => 0,   # current page (0 based)
        pagecount   => 0,   # number of pages
        page        => [],  # array of labels, indexed by $o->{p}
        pagelandsc  => [],  # orientation of each page individually
        pageclip    => [],  # clip to pagebbox
        pagebbox    => [],  # array of bbox, indexed by $o->{p}
        bbox        => [],  # [ x0, y0, x1, y1 ]
        embed_fonts => [],  # fonts that have been embedded
        needed      => {},  # DocumentNeededResources

        vars        => {},  # permanent user variables
        pagevars    => {},  # user variables reset with each new page
    };
    bless $o, $class;

    ## Paper layout
    croak "PNG output is no longer supported.  Use PostScript::Convert instead"
        if $opt->{png};
    $o->{eps}      = !!$opt->{eps} + 0;
    $o->{file_ext} = $opt->{file_ext};
    $o->set_filename(@$opt{qw(file dir)});
    $o->set_paper( $opt->{paper} );
    $o->set_width( $opt->{width} );
    $o->set_height( $opt->{height} );
    $o->set_landscape( $opt->{landscape} );

    ## Debug options
    $o->{debug} = $opt->{debug};        # undefined is an option
    if ($o->{debug}) {
        $o->{db_active}   = _def($opt->{db_active},   1);
        $o->{db_bufsize}  = _def($opt->{db_bufsize},  256);
        $o->{db_font}     = _def($opt->{db_font},     "Courier");
        $o->{db_fontsize} = _def($opt->{db_fontsize}, 10);
        $o->{db_ytop}     = _def($opt->{db_ytop},     ($o->{bbox}[3] - $o->{db_fontsize} - 6));
        $o->{db_ybase}    = _def($opt->{db_ybase},    6);
        $o->{db_xpos}     = _def($opt->{db_xpos},     6);
        $o->{db_xtab}     = _def($opt->{db_xtab},     10);
        $o->{db_xgap}     = _def($opt->{db_xgap},     ($o->{bbox}[2] - $o->{bbox}[0] - $o->{db_xpos})/4);
        $o->{db_color}    = _def($opt->{db_color},    "0 setgray");
    }

    ## Bounding box
    my $x0 = $o->{bbox}[0] + _def($opt->{left},  28);
    my $y0 = $o->{bbox}[1] + _def($opt->{bottom},  28);
    my $x1 = $o->{bbox}[2] - _def($opt->{right},  28);
    my $y1 = $o->{bbox}[3] - _def($opt->{top},  28);
    $o->set_bounding_box( $x0, $y0, $x1, $y1 );
    $o->set_clipping( $opt->{clipping} );

    ## Other options
    $o->{title}      = $opt->{title};
    $o->{version}    = $opt->{version};
    $o->{langlevel}  = $opt->{langlevel};
    $o->{extensions} = $opt->{extensions};
    $o->{order}      = defined($opt->{order}) ? ucfirst lc $opt->{order} : undef;
    $o->set_page_label( $opt->{page} );
    $o->set_incpage_handler( $opt->{incpage_handler} );

    $o->{errx}        = _def($opt->{errx},         72);
    $o->{erry}        = _def($opt->{erry},         72);
    $o->{errmsg}      = _def($opt->{errmsg},       "ERROR:");
    $o->{errfont}     = _def($opt->{errfont},      "Courier-Bold");
    $o->{errsize}     = _def($opt->{errsize},      12);

    $o->{font_suffix} = _def($opt->{font_suffix},  "-iso");
    $o->{clipcmd}     = _def($opt->{clip_command}, "clip");
    $o->{errors}      = _def($opt->{errors},       1);
    $o->{headings}    = _def($opt->{headings},     0);
    $o->set_strip( $opt->{strip} );
    $o->_set_reencode( $opt->{reencode} );
    $o->set_auto_hyphen(_def($opt->{auto_hyphen}, 1));
    $o->need_resource(font => @{ $opt->{need_fonts} }) if $opt->{need_fonts};

    $o->newpage if _def($opt->{newpage}, 1);

    ## Finish
    return $o;
}


sub newpage {
    my ($o, $page) = @_;
    my $oldpage = $o->{page}[$o->{p}];
    # Don't use _def here, because we don't want to call
    # incpage_handler if the user supplied a page label:
    my $newpage = defined $page
        ? $page
        # If this is the very first page, don't increment the page number:
        : ($o->{pagecount}
           ? $o->{incpage}->($oldpage)
           : $oldpage);
    my $p = $o->{p} = $o->{pagecount}++;
    $o->{page}[$p] = $newpage;
    $o->{pagebbox}[$p] = [ @{$o->{bbox}} ];
    $o->{pageclip}[$p] = $o->{clipping};
    $o->{pagelandsc}[$p] = $o->{landscape};
    $o->{Pages}->[$p] = "";
    $o->{pagevars} = {};
}


sub _pre_pages
{
    my ($o, $landscape, $clipping, $filename) = @_;

    if (my $use_functions = $o->{use_functions}) {
      $use_functions->add_to_file($o);
    }

    my $docSupplied = $o->{DocSupplied};
    ## Thanks to Johan Vromans for the ISOLatin1Encoding.
    my $fonts = "";
    if ($o->{reencode}) {
        my $encoding = $o->{reencode};
        my $ext = $o->{font_suffix};
        $fonts = "% Handle font encoding:\n";
        $fonts .= $o->_here_doc(<<"END_FONTS");
            /STARTDIFFENC { mark } bind def
            /ENDDIFFENC {

            % /NewEnc BaseEnc STARTDIFFENC number or glyphname ... ENDDIFFENC -
                counttomark 2 add -1 roll 256 array copy
                /TempEncode exch def

                % pointer for sequential encodings
                /EncodePointer 0 def
                {
                    % Get the bottom object
                    counttomark -1 roll
                    % Is it a mark?
                    dup type dup /marktype eq {
                        % End of encoding
                        pop pop exit
                    } {
                        /nametype eq {
                        % Insert the name at EncodePointer

                        % and increment the pointer.
                        TempEncode EncodePointer 3 -1 roll put
                        /EncodePointer EncodePointer 1 add def
                        } {
                        % Set the EncodePointer to the number
                        /EncodePointer exch def
                        } ifelse
                    } ifelse
                } loop

                TempEncode def
            } bind def
            \n$encoding_def{$encoding}
            % Name: Re-encode Font
            % Description: Creates a new font using the named encoding.

            /REENCODEFONT { % /Newfont NewEncoding /Oldfont
                findfont dup length 4 add dict
                begin
                    { % forall
                        1 index /FID ne
                        2 index /UniqueID ne and
                        2 index /XUID ne and
                        { def } { pop pop } ifelse
                    } forall
                    /Encoding exch def
                    % defs for DPS
                    /BitmapWidths false def
                    /ExactSize 0 def
                    /InBetweenSize 0 def
                    /TransformedChar 0 def
                    currentdict
                end
                definefont pop
            } bind def
END_FONTS
        $fonts .= "\n% Reencode the fonts:\n";
        # If no fonts listed, assume the standard ones:
        $o->{needed}{font} ||= { map { $_ => 1 } @fonts };

        for my $font (sort(keys(%{ $o->{needed}{font} }),
                           @{ $o->{embed_fonts} })) {
            next if $font eq 'Symbol'; # doesn't use StandardEncoding
            $fonts .= "/${font}$ext $encoding /$font REENCODEFONT\n";
        }
        $fonts .= "% end font encoding\n";
    } # end if reencode

    # Prepare the PostScript file
    my $postscript = $o->{eps} ? "\%!PS-Adobe-3.0 EPSF-3.0\n" : "\%!PS-Adobe-3.0\n";
    if ($o->{eps}) {
        $postscript .= $o->_bbox_comment('', $o->{bbox});
    }
    if ($o->{headings}) {
        require Sys::Hostname;
        my $user = getlogin() || (getpwuid($<))[0] || "Unknown";
        my $hostname = Sys::Hostname::hostname();
        $postscript .= $o->_here_doc(<
        \%\%For: $user\@$hostname
        \%\%Creator: Perl module ${\( ref $o )} v$PostScript::File::VERSION
        \%\%CreationDate: ${\( scalar localtime )}
END_TITLES
        $postscript .= $o->_here_doc(<{eps});
        \%\%DocumentMedia: $o->{paper} $o->{width} $o->{height} 80 ( ) ( )
END_PS_ONLY
    }

    my $landscapefn = "";
    $landscapefn .= $o->_here_doc(<
                % Rotate page 90 degrees
                % _ => _
                /landscape {
                    $o->{width} 0 translate
                    90 rotate
                } bind def
END_LANDSCAPE

    my $clipfn = "";
    if ($clipping) {
      my $clipcmd = $o->{clipcmd};
      $clipcmd = "gsave 0 setgray 0.5 setlinewidth $clipcmd grestore newpath"
          if $clipcmd eq 'stroke';

      $clipfn .= $o->_here_doc(<
                % Draw box as clipping path
                % x0 y0 x1 y1 => _
                /cliptobox {
                    4 dict begin
                    /y1 exch def /x1 exch def /y0 exch def /x0 exch def
                    newpath
                    x0 y0 moveto x0 y1 lineto x1 y1 lineto x1 y0 lineto
                    closepath
                    $clipcmd
                    end
                } bind def
END_CLIPPING
    } # end if $clipping

    my $errorfn = "";
    if ($o->{errors}) {
      $o->need_resource(font => $o->{errfont});
      $errorfn .= $o->_here_doc(<
        /errx $o->{errx} def
        /erry $o->{erry} def
        /errmsg ($o->{errmsg}) def
        /errfont /$o->{errfont} def
        /errsize $o->{errsize} def
        % Report fatal error on page
        % _ str => _
        /report_error {
            0 setgray
            errfont findfont errsize scalefont setfont
            errmsg errx erry moveto show
            80 string cvs errx erry errsize sub moveto show
            stop
        } bind def

        % PostScript errors printed on page
        % not called directly
        errordict begin
            /handleerror {
                \$error begin
                false binary
                0 setgray
                errfont findfont errsize scalefont setfont
                errx erry moveto
                errmsg show
                errx erry errsize sub moveto
                errorname 80 string cvs show
                stop
            } def
        end
END_ERRORS
    } # end if $o->{errors}

    my $debugfn = "";
    if ($o->{debug}) {
      $o->need_resource(font => $o->{db_font});
      $debugfn .= $o->_here_doc(<
        /debugdict 25 dict def
        debugdict begin

        /db_newcol {
            debugdict begin
                /db_ypos db_ytop def
                /db_xpos db_xpos db_xgap add def
            end
        } bind def
        % _ db_newcol => _

        /db_down {
            debugdict begin
                db_ypos db_ybase gt {
                    /db_ypos db_ypos db_ygap sub def
                }{
                    db_newcol
                } ifelse
            end
        } bind def
        % _ db_down => _

        /db_indent {
            debug_dict begin
                /db_xpos db_xpos db_xtab add def
            end
        } bind def
        % _ db_indent => _

        /db_unindent {
            debugdict begin
                /db_xpos db_xpos db_xtab sub def
            end
        } bind def
        % _ db_unindent => _

        /db_show {
            debugdict begin
                db_active 0 ne {
                    gsave
                    newpath
                    $o->{db_color}
                    /$o->{db_font} findfont $o->{db_fontsize} scalefont setfont
                    db_xpos db_ypos moveto
                    dup type
                    dup (arraytype) eq {
                        pop db_array
                    }{
                        dup (marktype) eq {
                            pop pop (--mark--) $o->{db_bufsize} string cvs show
                        }{
                            pop $o->{db_bufsize} string cvs show
                        } ifelse
                        db_down
                    } ifelse
                    stroke
                    grestore
                }{ pop } ifelse
            end
        } bind def
        % _ (msg) db_show => _

        /db_nshow {
            debugdict begin
                db_show
                /db_num exch def
                db_num count gt {
                    (Not enough on stack) db_show
                }{
                    db_num {
                        dup db_show
                        db_num 1 roll
                    } repeat
                    (----------) db_show
                } ifelse
            end
        } bind def
        % _ n (str) db_nshow => _

        /db_stack {
            count 0 gt {
                count
                $o->{debug} 2 ge {
                    1 sub
                } if
                (The stack holds...) db_nshow
            } {
                (Empty stack) db_show
            } ifelse
        } bind def
        % _ db_stack => _

        /db_one {
            debugdict begin
                db_temp cvs
                dup length exch
                db_buf exch db_bpos exch putinterval
                /db_bpos exch db_bpos add def
            end
        } bind def
        % _ any db_one => _

        /db_print {
            debugdict begin
                /db_temp $o->{db_bufsize} string def
                /db_buf $o->{db_bufsize} string def
                0 1 $o->{db_bufsize} sub 1 { db_buf exch 32 put } for
                /db_bpos 0 def
                {
                    db_one
                    ( ) db_one
                } forall
                db_buf db_show
            end
        } bind def
        % _ [array] db_print => _

        /db_array {
            mark ([) 2 index aload pop (]) ] db_print pop
        } bind def
        % _ [array] db_array => _

        /db_point {
            [ 1 index (\\() 5 index (,) 6 index (\\)) ] db_print
            pop
        } bind def
        % _ x y (str) db_point => _ x y

        /db_where {
            where {
                pop (found) db_show
            }{
                (not found) db_show
            } ifelse
        } bind def
        % _ var db_where => _

        /db_on {
            debugdict begin
            /db_active 1 def
            end
        } bind def
        % _ db_on => _

        /db_off {
            debugdict begin
            /db_active 0 def
            end
        } bind def
        % _ db_on => _

        /db_active $o->{db_active} def
        /db_ytop  $o->{db_ytop} def
        /db_ybase $o->{db_ybase} def
        /db_xpos  $o->{db_xpos} def
        /db_xtab  $o->{db_xtab} def
        /db_xgap  $o->{db_xgap} def
        /db_ygap  $o->{db_fontsize} def
        /db_ypos  $o->{db_ytop} def
        end
END_DEBUG_ON
    } # end if $o->{debug}

    $debugfn .= $o->_here_doc(<{debug}) and not $o->{debug});
        % Define out the db_ functions
        /debugdict 25 dict def
        debugdict begin
        /db_newcol { } bind def
        /db_down { } bind def
        /db_indent { } bind def
        /db_unindent { } bind def
        /db_show { pop } bind def
        /db_nshow { pop pop } bind def
        /db_stack { } bind def
        /db_print { pop } bind def
        /db_array { pop } bind def
        /db_point { pop pop pop } bind def
        end
END_DEBUG_OFF

    my $ver = sprintf('%g', $VERSION);
    my $supplied = "";
    if ($landscapefn or $clipfn or $errorfn or $debugfn) {
        $docSupplied .= "\%\%+ procset PostScript_File $ver 0\n";
        $supplied .= $o->_here_doc(<
            \%\%BeginResource: procset PostScript_File $ver 0
            $landscapefn
            $clipfn
            $errorfn
            $debugfn
            \%\%EndResource
END_DOC_SUPPLIED
    }

    my $docNeeded = $o->_build_needed;

    my $title = $o->{title};
    $title = $o->quote_text($filename)
        if not defined $title and defined $filename;

    $postscript .= $o->{Comments} if ($o->{Comments});
    $postscript .= "\%\%Orientation: ${\( $o->{landscape} ? 'Landscape' : 'Portrait' )}\n";
    $postscript .= $docNeeded if $docNeeded;
    $postscript .= "\%\%DocumentSuppliedResources:\n$docSupplied" if $docSupplied;
    $postscript .= $o->encode_text("\%\%Title: $title\n") if defined $title;
    $postscript .= "\%\%Version: $o->{version}\n" if ($o->{version});
    $postscript .= "\%\%Pages: $o->{pagecount}\n" if ((not $o->{eps}) and ($o->{pagecount} > 1));
    $postscript .= "\%\%PageOrder: $o->{order}\n" if ((not $o->{eps}) and ($o->{order}));
    $postscript .= "\%\%Extensions: $o->{extensions}\n" if ($o->{extensions});
    $postscript .= "\%\%LanguageLevel: $o->{langlevel}\n" if ($o->{langlevel});
    $postscript .= "\%\%EndComments\n";

    $postscript .= $o->{Preview} if ($o->{Preview});

    $postscript .= $o->_here_doc(<{Defaults});
        \%\%BeginDefaults
        $o->{Defaults}
        \%\%EndDefaults
END_DEFAULTS

    $postscript .= $o->_here_doc(<
        \%\%BeginProlog
        $supplied
        $o->{Functions}
        \%\%EndProlog
END_PROLOG

    my $setup = "$o->{Fonts}$fonts$o->{Resources}$o->{Setup}";
    $postscript .= "%%BeginSetup\n$setup%%EndSetup\n" if $setup;

    return $postscript;
}
# Internal method, used by output()

sub _build_needed
{
  my $o = shift;

  my $needed = $o->{needed};

  return unless %$needed;

  my $comment = "%%DocumentNeededResources:\n";

  foreach my $type (sort keys %$needed) {
    if ($type eq 'font') {
      # Remove any embedded fonts from the needed fonts:
      delete $needed->{$type}{$_} for @{ $o->{embed_fonts} };
    } # end if fonts

    next unless %{ $needed->{$type} };

    my $prefix = "%%+ $type";
    my $maxLen = 79 - length $prefix;
    my @list   = '';

    foreach my $resource (sort keys %{ $needed->{$type} }) {
      push @list, ''
          if length $list[-1]
             and length($resource) + length($list[-1]) >= $maxLen;
      $list[-1] .= " $resource";
    } # end foreach $resource

    $comment .= "$prefix$_\n" for @list;
  } # end foreach $type

  $comment;
} # end _build_needed

sub _post_pages
{
    my $o = shift;
    my $postscript = "";

    my $trailer = $o->{Trailer};
    $trailer .= "% Local\ Variables:\n% coding: " .
                $o->{encoding}->mime_name . "\n% End:\n"
        if $o->{encoding};

    $postscript .= "%%Trailer\n$trailer" if $trailer;
    $postscript .= "\%\%EOF\n";

    return $postscript;
}
# Internal method, used by output()

sub output {
    my ($o, $filename, $dir) = @_;
    my $fh = openhandle $filename;
    # Don't permanently change filename:
    local $o->{filename} = $o->{filename};
    $o->set_filename($filename, $dir) if @_ > 1 and not $fh;

    my ($debugbegin, $debugend) = ("", "");
    if (defined $o->{debug}) {
        $debugbegin = "debugdict begin\nuserdict begin";
        $debugend   = "end\nend";
        if ($o->{debug} >= 2) {
            $debugbegin = $o->_here_doc(<
                debugdict begin
                    userdict begin
                        mark
                        (Start of page) db_show
END_DEBUG_BEGIN
            $debugend = $o->_here_doc(<
                        (End of page) db_show
                        db_stack
                        cleartomark
                    end
                end
END_DEBUG_END
        }
    } else {
        $debugbegin = "userdict begin";
        $debugend   = "end";
    }

    if ($o->{eps}) {
        my @pages;
        my $p = 0;
        do {
            my $epsfile;
            if (defined $o->{filename}) {
                $epsfile = ($o->{pagecount} > 1) ? "$o->{filename}-$o->{page}[$p]"
                                           : "$o->{filename}";
                $epsfile .= defined($o->{file_ext}) ? $o->{file_ext}
                            : ($o->{Preview} ? ".epsi" : ".epsf");
            }
            my $postscript = "";
            my $page = $o->{page}->[$p];
            my @pbox = $o->get_page_bounding_box($page);
            $o->set_bounding_box(@pbox);
            $postscript .= $o->_pre_pages($o->{pagelandsc}[$p], $o->{pageclip}[$p], $epsfile);
            $postscript .= "landscape\n" if ($o->{pagelandsc}[$p]);
            $postscript .= "$pbox[0] $pbox[1] $pbox[2] $pbox[3] cliptobox\n" if ($o->{pageclip}[$p]);
            $postscript .= "$debugbegin\n";
            $postscript .= $o->{Pages}->[$p];
            $postscript .= "$debugend\n";
            $postscript .= $o->_post_pages();

            push @pages, $o->_print_file( $fh || $epsfile, $postscript );

            $p++;
        } while ($p < $o->{pagecount});
        return wantarray ? @pages : $pages[0];
    } else {
        my $landscape = $o->{landscape};
        foreach my $pl (@{$o->{pagelandsc}}) {
            $landscape |= $pl;
        }
        my $clipping = $o->{clipping};
        foreach my $cl (@{$o->{pageclip}}) {
            $clipping |= $cl;
        }
        my $psfile = $o->{filename};
        $psfile .= defined($o->{file_ext}) ? $o->{file_ext} : '.ps'
            if defined $psfile;
        my $postscript = $o->_pre_pages($landscape, $clipping, $psfile);
        for (my $p = 0; $p < $o->{pagecount}; $p++) {
            my $page = $o->{page}->[$p];
            my @pbox = $o->get_page_bounding_box($page);
            my ($landscape, $pagebb);
            if ($o->{pagelandsc}[$p]) {
                $landscape = "landscape";
                $pagebb = $o->_bbox_comment(Page => [ @pbox[1,0,3,2] ]);
            } else {
                $landscape = "";
                $pagebb = $o->_bbox_comment(Page => \@pbox);
            }
            my $cliptobox = $o->{pageclip}[$p] ? "$pbox[0] $pbox[1] $pbox[2] $pbox[3] cliptobox" : "";
            $postscript .= $o->_here_doc(<
                \%\%Page: $o->{page}->[$p] ${\($p+1)}
                $pagebb\%\%BeginPageSetup
                    /pagelevel save def
                    $landscape
                    $cliptobox
                    $debugbegin
                    $o->{PageSetup}
                \%\%EndPageSetup
END_PAGE_SETUP
            $postscript .= $o->{Pages}->[$p];
            $postscript =~ s/\n?\z/\n/; # Ensure LF at end
            $postscript .= $o->_here_doc(<
                \%\%PageTrailer
                    $o->{PageTrailer}
                    $debugend
                    pagelevel restore
                    showpage
END_PAGE_TRAILER
        }
        $postscript .= $o->_post_pages();
        return $o->_print_file( $fh || $psfile, $postscript );
    }
}


sub as_string { shift->output(undef) }

sub testable_output
{
  my ($o, $verbatim) = @_;

  my $ps = $o->output(undef);

  unless ($verbatim) {
    # Remove PostScript::File generated code:
    $ps =~ s/^%%BeginResource: procset PostScript_File.*?^%%EndResource\n//msg;
    $ps =~ s/^%%\+ procset PostScript_File.*\n//mg;
    $ps =~ s/^% Handle font encoding:\n.*?^% end font encoding\n//ms;
    $ps =~ s/^% Local Variables:\n.*?^% End:\n//ms;
    $ps =~ s/^%%Trailer\n(?=%%EOF\n)//m;
  } # end unless $verbatim

  $ps;
} # end testable_output

#---------------------------------------------------------------------
# Create a BoundingBox: comment,
# and a HiRes version if the box has a fractional part:

sub _bbox_comment
{
  my ($o, $type, $bbox) = @_;

  my $comment = join(' ', @$bbox);

  if ($comment =~ /\./) {
    $comment = sprintf("%d %d %d %d\n%%%%%sHiResBoundingBox: %s",
                       (map { $_ + 0.999999 } @$bbox),
                       $type, $comment);
  } # end if fractional bbox

  "%%${type}BoundingBox: $comment\n";
} # end _bbox_comment

sub _print_file
{
  my $o        = shift;
  my $filename = shift;

  if (defined $filename) {
    my $outfile = openhandle $filename;
    if ($outfile) {
      print $outfile $_[0];
      return;
    } # end if passed a filehandle

    open($outfile, ">", $filename)
        or die "Unable to write to \'$filename\' : $!\nStopped";

    print $outfile $_[0];

    close $outfile;

    return $filename;
  } else {
    return $_[0];
  } # end else no filename
} # end _print_file
# Internal method, used by output()
# Expects file name and contents
#---------------------------------------------------------------------


sub get_auto_hyphen {
    my $o = shift;
    return $o->{auto_hyphen};
}

sub set_auto_hyphen {
    my ($o, $translate) = @_;
    $o->{auto_hyphen} = $o->{encoding} && $translate;
}

sub get_filename {
    my $o = shift;
    return $o->{filename};
}

sub set_filename {
    my ($o, $filename, $dir) = @_;
    $o->{filename} = ((defined($filename) and length($filename))
                      ? check_file($filename, $dir)
                      : undef);
}


sub get_file_ext {
    shift->{file_ext};
}

sub set_file_ext {
    my ($o, $ext) = @_;
    $o->{file_ext} = $ext;
}

sub get_eps { my $o = shift; return $o->{eps}; }


sub get_paper {
    my $o = shift;
    return $o->{paper};
}

sub set_paper {
    my $o = shift;
    my $paper = shift || "A4";
    my ($width, $height) = split(/\s+/, $size{lc($paper)} || '');

    if (not $height and $paper =~ /^(\d+(?:\.\d+)?)\s*x\s*(\d+(?:\.\d+)?)$/i) {
      $width  = $1;
      $height = $2;
      $paper  = 'Custom';
    } # end if $paper is 'WIDTH x HEIGHT'

    if ($height) {
        $o->{paper} = $paper;
        $o->{width} = $width;
        $o->{height} = $height;
        if ($o->{landscape}) {
            $o->{bbox}[0] = 0;
            $o->{bbox}[1] = 0;
            $o->{bbox}[2] = $height;
            $o->{bbox}[3] = $width;
        } else {
            $o->{bbox}[0] = 0;
            $o->{bbox}[1] = 0;
            $o->{bbox}[2] = $width;
            $o->{bbox}[3] = $height;
        }
    }
}


sub get_width {
    my $o = shift;
    return $o->{width};
}

sub set_width {
    my ($o, $width) = @_;
    if (defined($width) and ($width+0)) {
        $o->{width} = $width;
        $o->{paper} = "Custom";
        if ($o->{landscape}) {
            $o->{bbox}[1] = 0;
            $o->{bbox}[3] = $width;
        } else {
            $o->{bbox}[0] = 0;
            $o->{bbox}[2] = $width;
        }
    }
}


sub get_height {
    my $o = shift;
    return $o->{height};
}
sub set_height {
    my ($o, $height) = @_;
    if (defined($height) and ($height+0)) {
        $o->{height} = $height;
        $o->{paper} = "Custom";
        if ($o->{landscape}) {
            $o->{bbox}[0] = 0;
            $o->{bbox}[2] = $height;
        } else {
            $o->{bbox}[1] = 0;
            $o->{bbox}[3] = $height;
        }
    }
}


sub get_landscape {
    my $o = shift;
    return $o->{landscape};
}

sub set_landscape {
    my $o = shift;
    my $landscape = (!!shift) + 0;
    $o->{landscape} = 0 unless (defined $o->{landscape});
    if ($o->{landscape} != $landscape) {
        $o->{landscape} = $landscape;
        ($o->{bbox}[0], $o->{bbox}[1]) = ($o->{bbox}[1], $o->{bbox}[0]);
        ($o->{bbox}[2], $o->{bbox}[3]) = ($o->{bbox}[3], $o->{bbox}[2]);
    }
}


sub get_clipping {
    my $o = shift;
    return $o->{clipping};
}

sub set_clipping {
    my $o = shift;
    $o->{clipping} = (!!shift) + 0;
}

our %encoding_name = qw(
  iso-8859-1 ISOLatin1Encoding
  cp1252     Win1252Encoding
);

%encoding_def = (
  ISOLatin1Encoding => <<'END ISOLatin1Encoding',
% Define ISO Latin1 encoding if it doesnt exist
/ISOLatin1Encoding where {
%   (ISOLatin1 exists!) =
    pop
} {
    (ISOLatin1 does not exist, creating...) =
    /ISOLatin1Encoding StandardEncoding STARTDIFFENC
        45 /minus
        144 /dotlessi /grave /acute /circumflex /tilde
        /macron /breve /dotaccent /dieresis /.notdef /ring
        /cedilla /.notdef /hungarumlaut /ogonek /caron /space
        /exclamdown /cent /sterling /currency /yen /brokenbar
        /section /dieresis /copyright /ordfeminine
        /guillemotleft /logicalnot /hyphen /registered
        /macron /degree /plusminus /twosuperior
        /threesuperior /acute /mu /paragraph /periodcentered
        /cedilla /onesuperior /ordmasculine /guillemotright
        /onequarter /onehalf /threequarters /questiondown
        /Agrave /Aacute /Acircumflex /Atilde /Adieresis
        /Aring /AE /Ccedilla /Egrave /Eacute /Ecircumflex
        /Edieresis /Igrave /Iacute /Icircumflex /Idieresis
        /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde
        /Odieresis /multiply /Oslash /Ugrave /Uacute
        /Ucircumflex /Udieresis /Yacute /Thorn /germandbls
        /agrave /aacute /acircumflex /atilde /adieresis
        /aring /ae /ccedilla /egrave /eacute /ecircumflex
        /edieresis /igrave /iacute /icircumflex /idieresis
        /eth /ntilde /ograve /oacute /ocircumflex /otilde
        /odieresis /divide /oslash /ugrave /uacute
        /ucircumflex /udieresis /yacute /thorn /ydieresis
    ENDDIFFENC
} ifelse
END ISOLatin1Encoding

  Win1252Encoding => <<'END Win1252Encoding',
% Define Windows Latin1 encoding
/Win1252Encoding StandardEncoding STARTDIFFENC
    % LanguageLevel 1 may require these to be mapped somewhere:
    17 /dotlessi /dotaccent /ring /caron
    % Restore glyphs for standard ASCII characters:
    45 /minus
    96 /grave
    % Here are the CP1252 extensions to ISO-8859-1:
    128 /Euro /.notdef /quotesinglbase /florin /quotedblbase
    /ellipsis /dagger /daggerdbl /circumflex /perthousand
    /Scaron /guilsinglleft /OE /.notdef /Zcaron /.notdef
    /.notdef /quoteleft /quoteright /quotedblleft /quotedblright
    /bullet /endash /emdash /tilde /trademark /scaron
    /guilsinglright /oe /.notdef /zcaron /Ydieresis
    % We now return you to your ISO-8859-1 character set:
    /space
    /exclamdown /cent /sterling /currency /yen /brokenbar
    /section /dieresis /copyright /ordfeminine
    /guillemotleft /logicalnot /hyphen /registered
    /macron /degree /plusminus /twosuperior
    /threesuperior /acute /mu /paragraph /periodcentered
    /cedilla /onesuperior /ordmasculine /guillemotright
    /onequarter /onehalf /threequarters /questiondown
    /Agrave /Aacute /Acircumflex /Atilde /Adieresis
    /Aring /AE /Ccedilla /Egrave /Eacute /Ecircumflex
    /Edieresis /Igrave /Iacute /Icircumflex /Idieresis
    /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde
    /Odieresis /multiply /Oslash /Ugrave /Uacute
    /Ucircumflex /Udieresis /Yacute /Thorn /germandbls
    /agrave /aacute /acircumflex /atilde /adieresis
    /aring /ae /ccedilla /egrave /eacute /ecircumflex
    /edieresis /igrave /iacute /icircumflex /idieresis
    /eth /ntilde /ograve /oacute /ocircumflex /otilde
    /odieresis /divide /oslash /ugrave /uacute
    /ucircumflex /udieresis /yacute /thorn /ydieresis
ENDDIFFENC
END Win1252Encoding
); # end %encoding_def

sub _set_reencode
{
  my ($o, $encoding) = @_;

  return unless $encoding;

  if ($encoding eq 'ISOLatin1Encoding') {
    $o->{reencode} = $encoding;
    return;
  } # end if backwards compatible ISOLatin1Encoding

  $o->{reencode} = $encoding_name{$encoding}
      or croak "Invalid reencode setting $encoding";

  require Encode;  Encode->VERSION(2.21); # Need mime_name method
  $o->{encoding} = Encode::find_encoding($encoding)
      or croak "Can't find encoding $encoding";
} # end _set_reencode

our %encode_char = (
  8208 => pack(C => 0xAD), # U+2010 HYPHEN
  8209 => pack(C => 0xAD), # U+2011 NON-BREAKING HYPHEN
  8722 => pack(C => 0x2D), # U+2212 MINUS SIGN
 65533 => pack(C => 0x3F), # U+FFFD REPLACEMENT CHARACTER
);


sub encode_text
{
  my $o = shift;

  my $encoding = $o->{encoding};

  if ($encoding and Encode::is_utf8( $_[0] )) {
    $encoding->encode($_[0], sub {
      $encode_char{$_[0]} || do {
        if ($_[0] < 0x100) {
          pack C => $_[0];      # Unmapped chars stay themselves
        } else {
          warn sprintf("PostScript::File can't convert U+%04X to %s\n",
                       $_[0], $encoding->name);
          '?'
        }
      }; # end invalid character
    });
  } else {
    $_[0];
  }
} # end encode_text


sub decode_text
{
  my $o = shift; # $text, $preserve_minus

  my $encoding = $o->{encoding};

  if ($encoding and not Encode::is_utf8( $_[0] )) {
    my $text = $encoding->decode($_[0], sub { pack U => shift });
    # Protect - from hyphen-minus processing if $preserve_minus:
    $text =~ s/-/\x{2212}/g if $_[1];
    $text;
  } else {
    $_[0];
  }
} # end decode_text


sub convert_hyphens
{
  my $o = shift;
  if ($_[0] =~ /-/) {
    # Text contains at least one hyphen-minus character:
    my $text = $o->decode_text(shift);

    # If it's surrounded by whitespace, or
    # it's preceded by whitespace and followed by a digit,
    # it's a minus sign (U+2212):
    $text =~ s/(?: ^ | (?<=\s) ) - (?= \d | \s | $ ) /\x{2212}/gx;

    # If it's surrounded by digits, or
    # it's preceded by punctuation and followed by a digit,
    # it's a minus sign (U+2212):
    $text =~ s/ (?<=[\d[:punct:]]) - (?=\d) /\x{2212}/gx;

    # If it's followed by a currency symbol, it's a minus sign (U+2212):
    $text =~ s/ - (?=\p{Sc}) /\x{2212}/gx;

    # Otherwise, it's a hyphen (U+2010):
    $text =~ s/-/\x{2010}/gx;

    $text;
  } else {
    shift;                      # Return text unmodified
  }
} # end convert_hyphens


sub get_metrics
{
  my ($o, $font, $size, $encoding) = @_;

  # Figure out what encoding to ask for:
  unless ($encoding) {
    if ($font eq 'Symbol') {
      $encoding = 'sym';
    }
    elsif ($o->{reencode} and $font =~ s/\Q$o->{font_suffix}\E$//) {
      $encoding = $o->{encoding}->name || 'iso-8859-1';
    } else {
      $encoding = 'std';
    }
  } # end unless $encoding supplied as parameter

  # Create the Metrics object:
  require PostScript::File::Metrics;
  my $metrics = PostScript::File::Metrics->new($font, $size, $encoding);

  # Whatever encoding they asked for, make sure that the
  # auto-translation matches what we're doing:
  $metrics->{encoding} = $o->{encoding};
  $metrics->{auto_hyphen} = $o->{auto_hyphen};

  $metrics;
} # end get_metrics
#---------------------------------------------------------------------


sub get_strip {
    my $o = shift;
    return $o->{strip_type};
}

my $eolRE   = qr/(?>\r\n?|\n)/;
my $noeolRE = qr/[^\r\n]/;
my $nonwsRE = qr/[^ \t\r\n]/;

my %strip_re = (
  none     => 0,                             # remove nothing
  space    => qr{\G^\s+}m,                   # remove leading spaces
  # remove leading spaces and single line comments (except %% and %!):
  comments => qr{\G^(?:\s+|%(?![!%])(?:$noeolRE)*(?:$eolRE))}mo,
  # remove leading spaces and all comments (except %% and %!):
  all_comments => qr{\G (?: ^\s+
                          | ^% (?![!%]) (?:$noeolRE)* (?:$eolRE)
                          | [ \t]*%(?![!%]) (?:$noeolRE)* )
                    }mox,
); # end strip_re

sub set_strip {
    my ($o, $strip) = @_;

    if (not defined $strip) { $strip = 'space'   }
    else                    { $strip = lc $strip }

    defined($o->{strip} = $strip_re{$strip})
        or croak "Invalid strip type $strip";
    $o->{strip_type} = $strip;
}

#sub chkpt
#{
#  my $at = substr($_, pos(), 5);
#  $at =~ s/([^ -~])/sprintf '\x%02X', ord $1 /eg;
#  printf "%d: %s\n", pos(), $at;
#} # end chkpt

sub strip
{
  my $o = shift;

  my $re;
  if (@_ > 1) {
    my $strip = shift;
    defined($re = $strip_re{$strip})
        or croak "Invalid strip type $strip";
  } else {
    $re = $o->{strip};
  }

  return unless $re;

  my $pos;

  for (@_) {
    next unless defined $_;
    pos() = 0;
    while (pos() < length) {
      next if m/\G<~[^~]*~>/gc
           or m/\G\( (?: [^\\)]+ | \\. )* \)/sgcx;
      $pos = pos();
      if (s/$re//m) {
        pos() = $pos;
      } else {
        pos() = $pos;
        m/\G[ \t]*(?:$eolRE|(?:$nonwsRE)+(?:$eolRE)?)/ogc;
        die "Infinite loop" if pos() == $pos;
      }
    }
  } # end for @_

  return;
} # end strip
#---------------------------------------------------------------------


sub get_page_landscape {
    my $o = shift;
    my $p = $o->_get_ordinal( shift );
    return $o->{pagelandsc}[$p];
}

sub set_page_landscape {
    my $o = shift;
    my $p = (@_ == 2) ? $o->_get_ordinal(shift) : $o->{p};
    my $landscape = (!!shift) + 0;
    $o->{pagelandsc}[$p] = 0 unless (defined $o->{pagelandsc}[$p]);
    if ($o->{pagelandsc}[$p] != $landscape) {
        ($o->{pagebbox}[$p][0], $o->{pagebbox}[$p][1]) = ($o->{pagebbox}[$p][1], $o->{pagebbox}[$p][0]);
        ($o->{pagebbox}[$p][2], $o->{pagebbox}[$p][3]) = ($o->{pagebbox}[$p][3], $o->{pagebbox}[$p][2]);
    }
    $o->{pagelandsc}[$p] = $landscape;
}

#---------------------------------------------------------------------


sub get_page_clipping {
    my $o = shift;
    my $p = $o->_get_ordinal( shift );
    return $o->{pageclip}[$p];
}

sub set_page_clipping {
    my $o = shift;
    my $p = (@_ == 2) ? $o->_get_ordinal(shift) : $o->{p};
    $o->{pageclip}[$p] = (!!shift) + 0;
}


sub get_page_label {
    my $o = shift;
    return $o->{page}[$o->{p}];
}

sub set_page_label {
    my $o = shift;
    my $page = shift || 1;
    $o->{page}[$o->{p}] = $page;
}


sub get_incpage_handler {
    my $o = shift;
    return $o->{incpage};
}

sub set_incpage_handler {
    my $o = shift;
    $o->{incpage} = shift || \&incpage_label;
}


sub get_order {
    my $o = shift;
    return $o->{order};
}


sub get_title {
    my $o = shift;
    return $o->{title};
}


sub get_version {
    my $o = shift;
    return $o->{version};
}


sub get_langlevel {
    my $o = shift;
    return $o->{langlevel};
}

sub set_min_langlevel
{
  my ($o, $level) = @_;
  $o->{langlevel} = $level unless ($o->{langlevel} || 0) >= $level;
  return $o->{langlevel};
}


sub get_extensions {
    my $o = shift;
    return $o->{extensions};
}


sub get_bounding_box {
    my $o = shift;
    return @{$o->{bbox}};
}

sub set_bounding_box {
    my ($o, $x0, $y0, $x1, $y1) = @_;
    $o->{bbox} = [ $x0, $y0, $x1, $y1 ] if (defined $y1);
    $o->set_clipping(1);
}


sub get_printable_width
{
  my $bb = shift->{bbox};
  return $bb->[2] - $bb->[0];
} # end get_printable_width

sub get_printable_height
{
  my $bb = shift->{bbox};
  return $bb->[3] - $bb->[1];
} # end get_printable_height


sub get_page_bounding_box {
    my $o = shift;
    my $p = $o->_get_ordinal( shift );
    return @{$o->{pagebbox}[$p]};
}

sub set_page_bounding_box {
    my $o = shift;
    my $page = (@_ == 5) ? shift : "";
    if (@_ == 4) {
        my $p = $o->_get_ordinal($page);
        $o->{pagebbox}[$p] = [ @_ ];
        $o->set_page_clipping($page, 1);
    }
}


sub get_page_printable_width
{
  my $o = shift;
  my $bb = $o->{pagebbox}[$o->_get_ordinal( shift )];
  return $bb->[2] - $bb->[0];
} # end get_page_printable_width

sub get_page_printable_height
{
  my $o = shift;
  my $bb = $o->{pagebbox}[$o->_get_ordinal( shift )];
  return $bb->[3] - $bb->[1];
} # end get_page_printable_height


sub set_page_margins {
    my $o = shift;
    my $page = (@_ == 5) ? shift : "";
    if (@_ == 4) {
        my ($left, $bottom, $right, $top) = @_;
        my $p = $o->_get_ordinal($page);
        if ($o->{pagelandsc}[$p]) {
            $o->{pagebbox}[$p] = [ $left, $bottom, $o->{height}-$right, $o->{width}-$top ];
        } else {
            $o->{pagebbox}[$p] = [ $left, $bottom, $o->{width}-$right, $o->{height}-$top ];
        }
        $o->set_page_clipping($page, 1);
    }
}

# =method-access get_ordinal
#
#   $index = $ps->get_ordinal( [$page] )
#
# Returns the internal number for the page label specified.  (Default:
# current page)
#
# Example
#
# Say pages are labeled "i", "ii", "iii, "iv", "1", "2", "3".
#
#     get_ordinal("i") == 0
#     get_ordinal("iv") == 3
#     get_ordinal("1") == 4
#
# =cut

sub _get_ordinal
{
    my ($o, $page) = @_;
    if ($page) {
        for (my $i = 0; $i <= $o->{pagecount}; $i++) {
            my $here = $o->{page}->[$i] || "";
            return $i if ($here eq $page);
        }
    }
    return $o->{p};
}


sub get_pagecount {
    my $o = shift;
    return $o->{pagecount};
}


sub set_variable {
    my ($o, $key, $value) = @_;
    $o->{vars}{$key} = $value;
}


sub get_variable {
    my ($o, $key) = @_;
    return $o->{vars}{$key};
}


sub set_page_variable {
    my ($o, $key, $value) = @_;
    $o->{pagevars}{$key} = $value;
}


sub get_page_variable {
    my ($o, $key) = @_;
    return $o->{pagevars}{$key};
}


sub get_comments {
    my $o = shift;
    return $o->{Comments};
}


sub add_comment {
    my ($o, $entry) = @_;
    $o->{Comments} .= "\%\%$entry\n" if defined($entry);
}


sub get_preview {
    my $o = shift;
    return $o->{Preview};
}


sub add_preview {
  my ($o, $width, $height, $depth, $lines, $entry) = @_;
  if (defined $entry) {
    $entry .= "\n";
    $o->strip(space => $entry);
    $o->{Preview} =
      "%%BeginPreview: $width $height $depth $lines\n$entry%%EndPreview\n";
  }
} # end add_preview


sub get_defaults {
    my $o = shift;
    return $o->{Defaults};
}


sub add_default {
    my ($o, $entry) = @_;
    $o->{Defaults} .= "\%\%$entry\n" if defined($entry);
}


sub get_resources {
    my $o = shift;
    return $o->{Fonts} . $o->{Resources};
}

our %supplied_type = (qw(
  Document  file
  Feature) => ''
);

our %add_resource_accepts = map { $_ => 1 } qw(
  encoding file font form pattern
);
# add_resource does not accept procset, but need_resource does:
$add_resource_accepts{procset} = undef;

sub add_resource {
    my ($o, $type, $name, $params, $resource) = @_;

    my $suptype = $supplied_type{$type};
    my $restype = '';

    croak "add_resource does not accept type $type"
        unless defined($suptype) or $add_resource_accepts{lc $type};

    unless (defined $suptype) {
      $suptype = lc $type;
      $restype = "$suptype ";
      $type    = 'Resource';
    } # end unless Document or Feature

    if (defined($resource)) {
        $o->strip($resource);
        $name = $o->quote_text($name);
        $o->{DocSupplied} .= $o->encode_text("\%\%+ $suptype $name\n")
            if $suptype;

        # Store fonts separately, because they need to come first:
        my $storage = 'Resources';

        if ($suptype eq 'font') {
          $storage = 'Fonts';
          push @{ $o->{embed_fonts} }, $name; # Remember to reencode it
        } # end if adding Font

        $name .= " $params" if defined $params and length $params;

        $o->{$storage} .= $o->_here_doc(<
            \%\%Begin${type}: $restype$name
            $resource
            \%\%End$type
END_USER_RESOURCE
    }
}



sub get_procsets
{
    my $o = shift;
    return $o->{Functions};
}

sub add_procset
{
    my ($o, $name, $entry, $version, $revision) = @_;
    if (defined($name) and defined($entry)) {
        return if $o->has_procset($name);
        $o->strip($entry);
        $name = sprintf('%s %g %d', $o->quote_text($name),
                        $version||0, $revision||0);
        $o->{DocSupplied} .= $o->encode_text("\%\%+ procset $name\n");
        $o->{Functions} .= $o->_here_doc(<
            \%\%BeginResource: procset $name
            $entry
            \%\%EndResource
END_USER_FUNCTIONS
        return 1;
    }
    return;
}


sub has_procset
{
    my ($o, $name) = @_;
    $name = $o->quote_text($name);
    return ($o->{DocSupplied} =~ /^\%\%\+ procset \Q$name\E /m);
}

# Retain the old names for backwards compatibility:
*add_function  = \&add_procset;
*get_functions = \&get_procsets;
*has_function  = \&has_procset;


sub use_functions
{
  my $o = shift;

  (
    $o->{use_functions} ||= do {
      require PostScript::File::Functions;

      PostScript::File::Functions->new;
    }
  )->add(@_);

  return $o;
} # end use_functions


sub embed_document
{
  my ($o, $filename) = @_;

  my $id = $o->quote_text(substr($filename, -234)); # in case it's long
  my $supplied = $o->encode_text("%%+ file $id\n");
  $o->{DocSupplied} .= $supplied
      unless index($o->{DocSupplied}, $supplied) >= 0;

  local $/;                     # Read entire file
  open(my $in, '<:raw', $filename) or croak "Unable to open $filename: $!";
  my $content = <$in>;
  close $in;

  # Remove TIFF or WMF preview image:
  if ($content =~ /^\xC5\xD0\xD3\xC6/) {
    my ($pos, $len) = unpack('V2', substr($content, 4, 8));
    $content = substr($content, $pos, $len);
  } # end if EPS file with TIFF or WMF preview image

  # Do CR or CRLF -> LF processing, since we read in RAW mode:
  $content =~ s/\r\n?/\n/g;

  # Remove EPSI preview:
  $content =~ s/^\s*%%BeginPreview:.*\n
                (?:\s*%(?!%).*\n)*
                \s*%%EndPreview.*\n//gmx;

  return "\%\%BeginDocument: $id\n$content\n\%\%EndDocument\n";
} # end embed_document


sub embed_font
{
  my ($o, $filename, $type) = @_;

  unless ($type) {
    $filename =~ /\.([^\\\/.]+)$/ or croak "No extension in $filename";
    $type = $1;
  }
  $type = uc $type;

  my $in;
  if ($type eq 'PFA') {
    open($in, '<:raw', $filename) or croak "Unable to open $filename: $!";
  } elsif ($type eq 'PFB') {
    open($in, '-|:raw', $t1ascii, $filename)
        or croak "Unable to run $t1ascii $filename: $!";
  } elsif ($type eq 'TTF') {
    open($in, '-|:raw', $ttftotype42, $filename)
        or croak "Unable to run $ttftotype42 $filename: $!";
    # Type 42 was introduced in LanguageLevel 2:
    $o->set_min_langlevel(2);
  }

  my $content = do { local $/; <$in> }; # Read entire file
  close $in;

  $content =~ s/\r\n?/\n/g;     # CR or CRLF to LF

  $content =~ m!/FontName\s+/(\S+)\s+def\b!
      or croak "Unable to find font name in $filename";
  my $fontName = $1;

  $o->add_resource(Font => $fontName, undef, $content);

  return $fontName;
} # end embed_font


sub need_resource
{
  my $o    = shift;
  my $type = shift;

  croak "Unknown resource type $type"
      unless exists $add_resource_accepts{$type};

  my $hash = $o->{needed}{$type} ||= {};

  foreach my $res (@_) {

    $hash->{ $o->encode_text(
      join(' ', map { $o->quote_text($_) } (ref $res ? @$res : $res))
    )} = 1;
  } # end foreach $res
} # end need_resource


sub get_setup {
    my $o = shift;
    return $o->{Setup};
}


sub add_setup {
    my ($o, $entry) = @_;
    $o->strip($entry);
    $o->{Setup} .= $o->encode_text($entry) if (defined $entry);
}


sub get_page_setup {
    my $o = shift;
    return $o->{PageSetup};
}


sub add_page_setup {
    my ($o, $entry) = @_;
    $o->strip($entry);
    $o->{PageSetup} .= $o->encode_text($entry) if (defined $entry);
}


sub get_page {
    my $o = shift;
    my $page = shift || $o->get_page_label();
    my $ord = $o->_get_ordinal($page);
    return $o->{Pages}->[$ord];
}


sub add_to_page {
    my $o = shift;
    my $page = (@_ == 2) ? shift : "";
    my $entry = shift || "";
    if ($page) {
        my $ord = $o->_get_ordinal($page);
        if (($ord == $o->{p}) and ($page ne $o->{page}[$ord])) {
            $o->newpage($page);
        } else {
            $o->{p} = $ord;
        }
    }
    $o->strip($entry);
    $o->{Pages}[$o->{p}] .= $o->encode_text($entry);
}


sub get_page_trailer {
    my $o = shift;
    return $o->{PageTrailer};
}


sub add_page_trailer {
    my ($o, $entry) = @_;
    $o->strip($entry);
    $o->{PageTrailer} .= $o->encode_text($entry) if (defined $entry);
}


sub get_trailer {
    my $o = shift;
    return $o->{Trailer};
}


sub add_trailer {
    my ($o, $entry) = @_;
    $o->strip($entry);
    $o->{Trailer} .= $o->encode_text($entry) if (defined $entry);
}

#=============================================================================


sub draw_bounding_box {
    my $o = shift;
    $o->{clipcmd} = "stroke";
}

sub clip_bounding_box {
    my $o = shift;
    $o->{clipcmd} = "clip";
}

# Strip leading spaces off a here document:

sub _here_doc
{
  my ($o, $text) = @_;

  if ($o->{strip_type} ne 'none') {
    $o->strip($text);
  } elsif ($text =~ /^([ \t]+)/) {
    my $space = $1;

    $text =~ s/^$space//gm;
    $text =~ s/^[ \t]+\n/\n/gm;
  } # end elsif no strip but $text is indented

  $o->encode_text($text);
} # end _here_doc


sub incpage_label ($) { ## no critic (ProhibitSubroutinePrototypes)
    my $page = shift;
    return ++$page;
}
#---------------------------------------------------------------------


our $roman_max = 40;
our @roman = qw(0 i ii iii iv v vi vii viii ix x xi xii xiii xiv xv xvi xvii xviii xix
                xx xi xxii xxii xxiii xxiv xxv xxvi xxvii xxviii xxix
                xxx xxi xxxii xxxii xxxiii xxxiv xxxv xxxvi xxxvii xxxviii xxxix );
our %roman = ();
for (my $i = 1; $i <= $roman_max; $i++) {
    $roman{$roman[$i]} = $i;
}

sub incpage_roman ($) { ## no critic (ProhibitSubroutinePrototypes)
    my $page = shift;
    my $pos = $roman{$page};
    return $roman[++$pos];
}
#---------------------------------------------------------------------


sub check_file ($;$$) { ## no critic (ProhibitSubroutinePrototypes)
    my ($filename, $dir, $create) = @_;
    $create = 0 unless (defined $create);

    if (not defined $filename or not length $filename) {
        $filename = File::Spec->devnull();
    } else {
        $filename = check_tilde($filename);
        $filename = File::Spec->canonpath($filename);
        unless (File::Spec->file_name_is_absolute($filename)) {
            if (defined($dir)) {
                $dir = check_tilde($dir);
                $dir = File::Spec->canonpath($dir);
                $dir = File::Spec->rel2abs($dir) unless (File::Spec->file_name_is_absolute($dir));
                $filename = File::Spec->catfile($dir, $filename);
            } else {
                $filename = File::Spec->rel2abs($filename);
            }
        }

        my @subdirs = ();
        my ($volume, $directories, $file) = File::Spec->splitpath($filename);
        @subdirs = File::Spec->splitdir( $directories );

        my $path = $volume;
        foreach my $dir (@subdirs) {
            $path = File::Spec->catdir( $path, $dir );
            mkdir $path unless (-d $path);
        }

        $filename = File::Spec->catfile($path, $file);
        if ($create) {
            unless (-e $filename) {
                open(my $file, ">", $filename)
                    or die "Unable to open \'$filename\' for writing : $!\nStopped";
                close $file;
            }
        }
    }

    return $filename;
}


sub check_tilde ($) { ## no critic (ProhibitSubroutinePrototypes)
    my ($dir) = @_;
    $dir = "" unless defined $dir;
    $dir =~ s{^~([^/]*)}{$1 ? (getpwnam($1))[7] : ($ENV{HOME} || $ENV{LOGDIR} || (getpwuid($>))[7]) }ex;
    return $dir;
}


sub array_as_string (@) { ## no critic (ProhibitSubroutinePrototypes)
    my $array = "[ ";
    foreach my $f (@_) { $array .= "$f "; }
    $array .= "]";
    return $array;
}


sub str ($) { ## no critic (ProhibitSubroutinePrototypes)
    my $arg = shift;
    if (ref($arg) eq "ARRAY") {
        return array_as_string( @$arg );
    } else {
        return $arg;
    }
}
#---------------------------------------------------------------------

my %special = (
  "\n" => '\n', "\r" => '\r', "\t" => '\t', "\b" => '\b',
  "\f" => '\f', "\\" => "\\\\", "("  => '\(', ")"  => '\)',
);
my $specialKeys = join '', keys %special;
$specialKeys =~ s/\\/\\\\/;     # Have to quote backslash

sub pstr {
  my $o;
  $o = shift if @_ > 1;         # We were called as a method
  my $string = shift;
  my $nowrap = shift;           # Pass this ONLY when method call

  # Possibly convert \x2D (hyphen-minus) to hyphen or minus sign:
  $string = $o->convert_hyphens($string)
      if ref $o and $o->{auto_hyphen} and $string =~ /-/;

  # Now form the parenthesized string:
  $string =~ s/([$specialKeys])/$special{$1}/go;
  $string = "($string)";
  # A PostScript file should not have more than 255 chars per line:
  $string =~ s/(.{240}[^\\])/$1\\\n/g unless $nowrap;
  $string =~ s/^([ %])/\\$1/mg; # Make sure it doesn't get stripped

  $string;
} # end pstr


sub quote_text
{
  my $o;
  $o = shift if @_ > 1;         # We were called as a method

  my $string = shift;

  return $string if $string =~ m(^[-+_./*A-Za-z0-9]+\z);

  __PACKAGE__->pstr($string, 1);
} # end quote_text

#=============================================================================
1;

__END__