#!/usr/bin/perl
# -*- perl -*-
my $version_banner = <<END;
pstops 2.04
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

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;
      $spec->{rotate} -= 180 if $spec->{rotate} > 180;
      $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;
}