| Current File : //usr/bin/pstops |
#!/usr/bin/perl
# -*- perl -*-
my $version_banner = <<END;
pstops 2.07
Copyright (c) Reuben Thomas 2017-2020.
Released under the GPL version 3, or (at your option) any later version.
END
use v5.14;
use warnings;
use strict;
BEGIN {
# Relocatable header
# The functions in this file provide support for relocatability of
# Perl scripts. They should be included near the beginning of each
# Perl script in a relocatable program, by adding @relocatable_pl@
# and causing the script to be expanded with AC_CONFIG_FILES. A
# small amount of additional code must be added and adapted to the
# package by hand; see doc/relocatable-maint.texi (in Gnulib) for
# details.
#
# This code is based on relocatable.sh.in, and design changes (and
# bugs) should probably be cross-checked with it.
#
# Copyright (C) 2013, 2015-2022 Free Software Foundation, Inc.
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# 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 the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <https://www.gnu.org/licenses/>.
#
use Config;
use File::Basename;
use File::Spec::Functions;
use Cwd 'realpath';
# Support for relocatability.
sub find_curr_installdir {
# Determine curr_installdir, even taking into account symlinks.
my $curr_executable = $0;
my $basename = basename($0);
if ($curr_executable eq $basename) {
LOOP: for my $dir (split /$Config{path_sep}/, $ENV{PATH}) {
$dir = "." unless $dir;
for my $ext ('') {
my $filename = catfile($dir, "$curr_executable$ext");
if (-f $filename) {
$curr_executable = $filename;
last LOOP;
}
}
}
}
# Resolve symlinks and canonicalize.
return realpath(dirname($curr_executable));
}
sub find_prefixes {
# Compute the original/current installation prefixes by stripping the
# trailing directories off the original/current installation directories.
my ($orig_installprefix, $curr_installprefix) = @_;
my $orig_last = basename($orig_installprefix);
my $curr_last = basename($curr_installprefix);
if ($orig_last && $curr_last && $orig_last eq $curr_last) {
$orig_installprefix = dirname($orig_installprefix);
$curr_installprefix = dirname($curr_installprefix);
}
return $orig_installprefix, $curr_installprefix;
}
if ("no" eq "yes") {
my $exec_prefix = "/usr";
my $orig_installdir = "/usr/bin"; # see Makefile.am's *_SCRIPTS variables
my ($orig_installprefix, $curr_installprefix) = find_prefixes($orig_installdir, find_curr_installdir());
sub relocate { # the subroutine is defined whether or not the enclosing block is executed
my ($dir) = @_;
if ("no" eq "yes") {
$dir =~ s%^$orig_installprefix/%$curr_installprefix/%;
$dir =~ s,/$,,;
}
return $dir;
}
}
# Relocate the directory variables that we use.
my $pkgdatadir = &relocate("/usr/share/psutils");
# End of relocatable header; "real" Perl starts here.
unshift (@INC, $pkgdatadir) unless $ENV{PSUTILS_UNINSTALLED};
}
use File::Basename;
use Fcntl qw(:seek);
use Getopt::Long;
use List::Util qw(min max);
use POSIX qw(BUFSIZ);
use PSUtils;
our $program_name = basename($0);
my ($help_flag, $version_flag);
my ($specs, $pagerange);
my $nobinding = 0;
my $even = 0;
my $odd = 0;
my $reverse = 0;
my $draw = 0;
my ($width, $height); # output paper size
my ($iwidth, $iheight);
my $flipping = 0; # any spec includes page flip
my $modulo = 1;
my $pagesperspec = 1;
my $verbose = 1;
my $pagelabel;
my $pageno;
my $outputpage = 0;
my $scale = 1.0; # global scale factor
my $rotate = 0; # global rotation
my $procset = # PStoPS procset
# Wrap these up with our own versions. We have to.
"userdict begin\
[/showpage/erasepage/copypage]{dup where{pop dup load\
type/operatortype eq{ /PStoPSenablepage cvx 1 index\
load 1 array astore cvx {} bind /ifelse cvx 4 array\
astore cvx def}{pop}ifelse}{pop}ifelse}forall\
/PStoPSenablepage true def\
[/letter/legal/executivepage/a4/a4small/b5/com10envelope\n" . # nullify
" /monarchenvelope/c5envelope/dlenvelope/lettersmall/note\n" . # paper
" /folio/quarto/a5]{dup where{dup wcheck{exch{}put}\n" . # operators
" {pop{}def}ifelse}{pop}ifelse}forall\
/setpagedevice {pop}bind 1 index where{dup wcheck{3 1 roll put}\
{pop def}ifelse}{def}ifelse\
/PStoPSmatrix matrix currentmatrix def\
/PStoPSxform matrix def/PStoPSclip{clippath}def\
/defaultmatrix{PStoPSmatrix exch PStoPSxform exch concatmatrix}bind def\
/initmatrix{matrix defaultmatrix setmatrix}bind def\
/initclip[{matrix currentmatrix PStoPSmatrix setmatrix\
[{currentpoint}stopped{\$error/newerror false put{newpath}}\
{/newpath cvx 3 1 roll/moveto cvx 4 array astore cvx}ifelse]\
{[/newpath cvx{/moveto cvx}{/lineto cvx}\
{/curveto cvx}{/closepath cvx}pathforall]cvx exch pop}\
stopped{\$error/errorname get/invalidaccess eq{cleartomark\
\$error/newerror false put cvx exec}{stop}ifelse}if}bind aload pop\
/initclip dup load dup type dup/operatortype eq{pop exch pop}\
{dup/arraytype eq exch/packedarraytype eq or\
{dup xcheck{exch pop aload pop}{pop cvx}ifelse}\
{pop cvx}ifelse}ifelse\
{newpath PStoPSclip clip newpath exec setmatrix} bind aload pop]cvx def\
/initgraphics{initmatrix newpath initclip 1 setlinewidth\
0 setlinecap 0 setlinejoin []0 setdash 0 setgray\
10 setmiterlimit}bind def\
end\n";
my $pagespecs_syntax = " PAGESPECS = [MODULO:]SPEC\
SPEC = [-]PAGENO[\@SCALE][L|R|U|H|V][(XOFF,YOFF)][,SPEC|+SPEC]\
MODULO >= 1; 0 <= PAGENO < MODULO";
sub usage {
my ($exit_code) = @_;
print STDERR <<END;
Usage: $program_name [OPTION...] [INFILE [OUTFILE]]
Rearrange pages of a PostScript document.
-S, --specs=SPECS page specifications (see below)
-R, --pages=PAGES select the given page ranges
-e, --even select even-numbered output pages
-o, --odd select odd-numbered output pages
-r, --reverse reverse the order of the output pages
-p, --paper=PAPER output paper name or dimensions (WIDTHxHEIGHT)
-P, --inpaper=PAPER input paper name or dimensions (WIDTHxHEIGHT)
-d, --draw[=DIMENSION] draw a line of given width (relative to original
page) around each page [argument defaults to 1;
default is 0]
-b, --nobind disable PostScript bind operators in prolog;
may be needed for complex page rearrangements
-q, --quiet don't show page numbers being output
--help display this help and exit
--version display version information and exit
PAGES is a comma-separated list of pages and page ranges.
PAGESPECS is a list of page specifications [default is "0", which
selects each page in its normal order].
END
exit $exit_code;
}
sub specerror {
Die("bad page specification:
$pagespecs_syntax");
}
sub parsespecs {
my ($str) = @_;
return undef unless $str =~ m/(?:([^:]+):)?(.*)/;
my $specs_text;
($modulo, $specs_text) = ($1 || 1, $2);
# Split on commas but not inside parentheses: https://stackoverflow.com/questions/8481345/perl-split-and-regular-expression
my @pages_text = split /,(?![^()]*\))/, $specs_text;
$pagesperspec = $#pages_text + 1;
my @pages = ();
my %angle = (l => 90, r => -90, u => 180);
foreach my $page (@pages_text) {
my @specs = ();
my @specs_text = split /\+/, $page;
foreach my $spec_text (@specs_text) {
return undef unless $spec_text =~ m/^(-)?(\d+)([LRUHV]+)?(?:@([^()]+))?(?:\((-?[\d.a-z]+),(-?[\d.a-z]+)\))?$/i;
my $spec = {
reversed => defined($1) ? 1 : 0,
pageno => $2,
rotate => 0,
hflip => 0,
vflip => 0,
scale => defined($4) ? $4 : 1.0,
xoff => defined($5) ? singledimen($5, $width, $height) : undef, yoff => defined($6) ? singledimen($6, $width, $height) : undef
};
return undef if $spec->{pageno} >= $modulo;
if (defined($3)) {
foreach (split '', $3) {
$spec->{rotate} += $angle{lc($_)} if /[LRU]/i;
$spec->{hflip} ^= 1 if /H/i;
$spec->{vflip} ^= 1 if /V/i;
}
}
# Normalize rotation and flips
if ($spec->{hflip} == 1 && $spec->{vflip} == 1) {
$spec->{hflip} = $spec->{vflip} = 0;
$spec->{rotate} += 180;
}
$spec->{rotate} %= 360;
$flipping = 1 if $spec->{hflip} == 1 || $spec->{vflip} == 1;
push @specs, $spec;
}
push @pages, \@specs;
}
return \@pages;
}
# Parse PAGESPECS starting with a -, which Getopt::Long can't easily be made to understand
for (my $i = 0; $i <= $#ARGV; ) {
if ($ARGV[$i] =~ /^-\d+/) { # looks like an option starting with a digit
if (!defined($specs)) {
$specs = parsespecs($ARGV[$i]);
specerror() unless defined($specs);
splice(@ARGV, $i, 1);
} else {
usage(1);
}
}
$i++;
}
# Get arguments
Getopt::Long::Configure("bundling");
# Having configured bundling, must give short options explicitly
my @pstops_args = ();
GetOptions(
"specs|S=s" => sub { $specs = parsespecs($_[1]);
specerror() if !defined($specs); },
"pages|R=s" => sub { $pagerange = parserange($_[1]); },
"even|e" => \$even,
"odd|o" => \$odd,
"reverse|r" => \$reverse,
"paper|p=s" => sub { ($width, $height) = parsepaper($_[1]); },
"width|w=s" => sub { $width = singledimen($_[1], $width, $height); },
"height|h=s" => sub { $height = singledimen($_[1], $width, $height); },
"inpaper|P=s" => sub { ($iwidth, $iheight) = parsepaper($_[1]); },
"inwidth|W=s" => sub { $iwidth = singledimen($_[1], $width, $height); },
"inheight|H=s" => sub { $iheight = singledimen($_[1], $width, $height); },
"draw|d:s" => sub { $draw = singledimen($_[1] || "1", $width, $height); },
"nobind|b" => \$nobinding,
"quiet|q" => sub { $verbose = 0; },
"help" => \$help_flag,
"version" => \$version_flag,
) or usage(1);
if ($version_flag) {
print STDERR $version_banner;
exit 0;
}
usage(0) if $help_flag;
Die("output page width and height must both be set, or neither")
if !defined($width) xor !defined($height);
Die("input page width and height must both be set, or neither")
if !defined($iwidth) xor !defined($iheight);
# Get pagespecs if we don't have them yet
if (!defined($specs)) {
# If there's another command-line argument, try parsing it
$specs = parsespecs($ARGV[0]) if $#ARGV > -1;
shift if defined ($specs);
# Otherwise, default to "0"
$specs = parsespecs("0") unless defined($specs);
}
my ($infile, $outfile) = setup_input_and_output(1);
usage(1) if $#ARGV != -1; # Check no more arguments were given
($iwidth, $iheight) = ($width, $height) if !defined($iwidth) && defined($width);
Die("input page size must be set when flipping the page")
if !defined($iwidth) and $flipping;
# Parse input
my $psinfo = parse_file($infile, defined($width));
# Output the pages
pstops($pagerange, $modulo, $pagesperspec, $odd, $even, $reverse, $nobinding, $specs, $draw, @{$psinfo->{sizeheaders}});
# Copy input file from current position up to new position to output file,
# ignoring the lines starting at something ignorelist points to.
# Updates ignorelist.
sub fcopy {
my ($upto, @ignorelist) = @_;
my $here = tell $infile;
while ($#ignorelist >= 0 && $ignorelist[0] < $upto) {
shift @ignorelist while $#ignorelist >= 0 && $ignorelist[0] < $here;
fcopy($ignorelist[0]) if defined($ignorelist[0]);
Die("I/O error", 2) if !<$infile>;
shift @ignorelist;
$here = tell $infile;
}
my ($numtocopy, $buffer);
for (my $bytes_left = $upto - $here; $bytes_left > 0; $bytes_left -= $numtocopy) {
$numtocopy = min($bytes_left, BUFSIZ);
Die("I/O error", 2)
if ((read $infile, $buffer, $numtocopy) < $numtocopy ||
!(print $outfile $buffer));
}
}
# Page spec routines for page rearrangement
sub parserange {
my ($ranges_text) = @_;
my @ranges = ();
foreach my $range_text (split /,/, $ranges_text) {
my $range;
if ($range_text eq "_") {
$range = { from => 0, to => 0 }; # so &$page_to_real_page returns -1
} else {
Die("`$range_text' is not a page range") unless $range_text =~ m/^(_?\d+)?(?:(-)(_?\d+))?$/;
$range = { from => $1 || 1, to => $2 ? ($3 || -1) : $1 };
$range->{from} =~ s/^_/-/;
$range->{to} =~ s/^_/-/;
}
$range->{text} = $range_text;
push @ranges, $range;
}
return \@ranges;
}
sub abs_page {
my ($n) = @_;
if ($n < 0) {
$n += $psinfo->{pages} + 1;
$n = max($n, 1);
}
return $n;
}
sub page_index_to_page_number {
my ($ps, $maxpage, $modulo, $pagebase) = @_;
my $page_number = ($ps->{reversed} ? $maxpage - $pagebase - $modulo : $pagebase) + $ps->{pageno};
return $page_number;
}
sub ps_transform {
my ($ps) = @_;
return $ps->{rotate} != 0 || $ps->{hflip} != 0 || $ps->{vflip} != 0 || $ps->{scale} != 1.0 || defined($ps->{xoff});
}
sub pstops {
my ($pagerange, $modulo, $pps, $odd, $even, $reverse,
$nobind, $specs, $draw, @ignorelist) = @_;
# If no page range given, select all pages
$pagerange = parserange("1-_1") unless defined($pagerange);
# Normalize end-relative pageranges
foreach my $range (@$pagerange) {
$range->{from} = abs_page($range->{from});
$range->{to} = abs_page($range->{to});
}
# Get list of pages
my @page_to_real_page = ();
my $page_to_real_page = sub {
# Returns -1 for an inserted blank page (page number '_')
return $page_to_real_page[$_[0]] || 0;
};
foreach my $range (@$pagerange) {
my $inc = $range->{to} < $range->{from} ? -1 : 1;
for (my $currentpg = $range->{from}; $range->{to} - $currentpg != -$inc; $currentpg += $inc) {
Die("page range $range->{text} is invalid", 2) if $currentpg > $psinfo->{pages};
if (!($odd && !$even && $currentpg % 2 == 0) && !($even && !$odd && $currentpg % 2 == 1)) {
push @page_to_real_page, $currentpg - 1;
}
}
}
my $pages_to_output = $#page_to_real_page + 1;
# Calculate highest page number output (including any blanks)
my $maxpage = $pages_to_output + ($modulo - $pages_to_output % $modulo) % $modulo;
# Reverse page list if reversing pages
@page_to_real_page = reverse @page_to_real_page if $reverse;
# Work out whether we need procset
my $global_transform = $scale != 1.0 || $rotate != 0;
my $use_procset = $global_transform;
if ($use_procset == 0) {
PAGE: foreach my $page (@$specs) {
if ($#{$page} > 0) {
$use_procset = 1;
last PAGE;
}
foreach my $ps (@$page) {
$use_procset |= ps_transform($ps);
last PAGE if $use_procset;
}
}
}
# Rearrange pages
# FIXME: doesn't cope properly with loaded definitions
my $p = int($maxpage / $modulo) * $pps;
seek $infile, 0, SEEK_SET;
if ($psinfo->{pagescmt}) {
fcopy($psinfo->{pagescmt}, @ignorelist);
my $line;
Die("I/O error in header", 2) if !($line = <$infile>);
if (defined($width)) {
say $outfile "%%DocumentMedia: plain " . int($width) . " " . int($height) . " 0 () ()";
say $outfile "%%BoundingBox: 0 0 " . int($width) . " " . int($height);
}
say $outfile "%%Pages: $p 0";
}
fcopy($psinfo->{headerpos}, @ignorelist);
say $outfile "%%BeginProcSet: PStoPS" . ($nobind ? "-nobind" : "") . " 1 15\n" .
$procset . ($nobind ? "/bind{}def\n" : "") . # desperation measures
"%%EndProcSet"
if $use_procset;
# Write prologue to end of setup section, skipping our procset if present
# and we're outputting it (this allows us to upgrade our procset)
if ($psinfo->{endprocset} && $use_procset) {
fcopy($psinfo->{beginprocset});
seek $infile, $psinfo->{endprocset}, SEEK_SET;
}
fcopy($psinfo->{endsetup});
# Save transformation from original to current matrix
say $outfile "userdict/PStoPSxform PStoPSmatrix matrix currentmatrix\
matrix invertmatrix matrix concatmatrix\
matrix invertmatrix put" if !$psinfo->{beginprocset} && $use_procset;
# Write from end of setup to start of pages
fcopy(${$psinfo->{pageptr}}[0]);
my $pageindex = 0;
for (my $pagebase = 0; $pagebase < $maxpage; $pagebase += $modulo) {
foreach my $page (@$specs) {
my $spec_page_number = 0;
foreach my $ps (@$page) {
my $page_number = page_index_to_page_number($ps, $maxpage, $modulo, $pagebase);
my $real_page = &$page_to_real_page($page_number);
if ($page_number < $pages_to_output && $real_page >= 0 && $real_page < $psinfo->{pages}) {
# Seek the page
my $p = $real_page;
seek $infile, ${$psinfo->{pageptr}}[$p], SEEK_SET;
my $line = <$infile>;
Die("I/O error seeking page $p", 2) unless $line && (comment($line))[0] eq "Page:";
$line =~ /%%Page:[[:space:]]*(?:\((\d+)\)?[[:space:]]*(\d+))/;
$pageno = $2;
$pagelabel = defined($1) ? $1 : $pageno;
}
if ($spec_page_number == 0) { # page label contains original pages
my @pagelabels = ();
foreach my $spec (@$page) {
push @pagelabels, &$page_to_real_page(page_index_to_page_number($spec, $maxpage, $modulo, $pagebase)) + 1;
}
$pagelabel = "(" . (join ",", @pagelabels) . ")";
# Write page comment
my $page_label_number = $page_number < $pages_to_output && $real_page < $psinfo->{pages} ? ++$pageindex : -1;
print STDERR "[" . ($page_label_number < 0 ? "*" : $page_label_number) . "] " if $verbose;
say $outfile sprintf("%%%%Page: %s %d", $page_label_number < 0 ? "*" : $pagelabel, ++$outputpage);
}
say $outfile "userdict/PStoPSsaved save put" if $use_procset;
if ($global_transform || ps_transform($ps)) {
say $outfile "PStoPSmatrix setmatrix";
say $outfile (sprintf "%f", $ps->{xoff}) . " " . (sprintf "%f", $ps->{yoff}) . " translate"
if defined($ps->{xoff});
say $outfile ($ps->{rotate} + $rotate) % 360 . " rotate"
if $ps->{rotate} != 0;
say $outfile "[ -1 0 0 1 " . $iwidth * $ps->{scale} * $scale . " 0 ] concat"
if $ps->{hflip} == 1;
say $outfile "[ 1 0 0 -1 0 " . $iheight * $ps->{scale} * $scale . " ] concat"
if $ps->{vflip} == 1;
say $outfile (sprintf "%f", $ps->{scale} * $scale) . " dup scale"
if $ps->{scale} != 1.0;
say $outfile "userdict/PStoPSmatrix matrix currentmatrix put";
if (defined($iwidth)) {
say $outfile "userdict/PStoPSclip{0 0 moveto\
" . (sprintf "%f", $iwidth) . " 0 rlineto 0 " . (sprintf "%f", $iheight) . " rlineto " . (sprintf "%f", -$iwidth) . " 0 rlineto\
closepath}put initclip";
say $outfile "gsave clippath 0 setgray $draw setlinewidth stroke grestore" if $draw > 0;
}
}
say $outfile "/PStoPSenablepage false def" if $spec_page_number < $#{$page};
if ($psinfo->{beginprocset} && $page_number < $pages_to_output && $real_page < $psinfo->{pages}) {
# Search for page setup
for (;;) {
my $line = <$infile>;
Die("I/O error reading page setup $outputpage", 2) if !defined($line);
last if $line !~ /^PStoPSxform/;
print $outfile $line or Die("I/O error writing page setup $outputpage", 2);
}
}
say $outfile "PStoPSxform concat" if !$psinfo->{beginprocset} && $use_procset;
if ($page_number < $pages_to_output && $real_page >= 0 && $real_page < $psinfo->{pages}) {
# Write the body of a page
fcopy(${$psinfo->{pageptr}}[$real_page + 1]);
} else {
say $outfile "showpage";
}
say $outfile "PStoPSsaved restore" if $use_procset;
$spec_page_number++;
}
}
}
# Write trailer
seek $infile, ${$psinfo->{pageptr}}[$psinfo->{pages}], SEEK_SET;
while (<$infile>) { print $outfile $_; }
say STDERR "Wrote $outputpage pages" if $verbose;
}