#!/usr/bin/env perl
my $version_banner = <<END;
pstops 1.90
Copyright (c) Reuben Thomas 2017-2019
Released under the GPL version 3, or (at your option) any later version.
END

use v5.14;
use warnings;
use strict;
no if $] >= 5.018, warnings => "experimental::smartmatch";

use File::Basename;
use File::Temp qw(tempfile);
use File::Copy;
use Fcntl qw(:seek);
use Getopt::Long;
use List::Util qw(min max);
use POSIX qw(BUFSIZ);

use PSUtils;

my $prog = 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 $signature = 1;
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;
$prog [OPTION...] PAGESPECS [INFILE [OUTFILE]]

Rearrange pages of a PostScript file.

  --pages=PAGES        select the given page ranges
  --even               select even-numbered pages
  --odd                select odd-numbered pages
  --reverse            reverse the order of the pages
  --paper=PAPER        output paper name or dimensions
  --inpaper=PAPER      input paper name or dimensions
  --draw[=DIMENSION]   draw a line of given width around each page
                       [argument defaults to 1; default is 0]
  --signature=N        number of pages per signature
                       0 = all pages in one signature [default]
                       1 = one page per signature
                       otherwise, a multiple of 4
  --nobind             disable PostScript bind operators in prolog
  --quiet              don't show page numbers being output
  --help               display this help and exit
  --version            display version information and exit

PAGESPECS is a list of page specifications:

$pagespecs_syntax

PAGES is a comma-separated list of pages and page ranges.

See pstops(1) for more details.
END
  exit $exit_code;
}

sub specerror {
  $verbose = 0; # We won't be in the middle of a line during argument parsing
  die("page specification error:\
$pagespecs_syntax");
}

sub parsespecs {
  my ($str) = @_;
  specerror() unless $str =~ m/(?:([^:]+):)?(.*)/;
  my $specs_text;
  ($modulo, $specs_text) = ($1 || 1, $2);
  # Split on commas but not inside brackets: https://stackoverflow.com/questions/9435564/perl-split-list-on-commas-except-when-within-brackets
  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) {
      specerror() unless $spec_text =~ m/(-)?(\d+)([LRUlru])?([HVhv])?(?:@([^()]+))?(?:\(([\d.]+),([\d.]+)\))?/;
      my $spec = {
        reversed => defined($1) ? 1 : 0,
        pageno => $2,
        rotate => defined($3) ? $angle{lc($3)} : 0,
        flip => defined($4) ? lc($4) : "",
        scale => defined($5) ? $5 : undef,
        xoff => defined($6) ? singledimen($6) : undef, yoff => defined($7) ? singledimen($7) : undef
      };
      specerror() if $spec->{pageno} >= $modulo;
      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]);
      splice(@ARGV, $i, 1)
    } else {
      usage(1);
    }
  }
  $i++;
}

sub iscomment {
  my ($x, $y) = @_;
  return substr($x, 2, length($y)) eq $y;
}

# Make a file seekable, using temporary files if necessary
sub seekable {
  my ($fp) = @_;

  # If fp is seekable, we're OK
  return $fp if seek $fp, 0, SEEK_CUR;

  # Otherwise, copy fp to a temporary file
  my $ft = tempfile() or return;
  copy($fp, $ft) or return;

  # Discard the input file, and rewind the temporary
  close $fp;
  return $ft if seek $ft, 0, SEEK_SET;
}


# Get arguments
Getopt::Long::Configure("bundling");
# Having configured bundling, must give short options explicitly
my @pstops_args = ();
GetOptions(
  "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); },
  "signature|s=i" => sub { $signature = $_[1];
                           usage(1) if $signature > 1 && $signature % 4 != 0; },
  "draw|d:s" => sub { $draw = singledimen($_[1] || "1"); },
  "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);

if (!defined($specs)) {
  usage(1) if $#ARGV == -1;
  $specs = parsespecs(shift);
}

my ($infile, $outfile) = setup_input_and_output();

$infile = seekable($infile) or die("cannot make input seekable");

($iwidth, $iheight) = ($width, $height) if !defined($iwidth) && defined($width);


# Build array of pointers to start/end of pages
my @sizeheaders = ();
my $nesting = 0;
my $headerpos = 0;
my $pagescmt = 0;
my $endsetup = 0;
my $beginprocset = 0;		# start of pstops procset
my $endprocset = 0;
my @pageptr = ();
my $pages;
seek $infile, 0, SEEK_SET;
for (my $record = 0; my $buffer = <$infile>; $record = tell $infile) {
  if ($buffer =~ /^%%/) {
    if ($nesting == 0 && iscomment($buffer, "Page:")) {
      push @pageptr, $record;
    } elsif ($headerpos == 0 && defined($iwidth) && (iscomment($buffer, "BoundingBox:") ||
                                                       iscomment($buffer, "HiResBoundingBox:") ||
                                                       iscomment($buffer, "DocumentPaperSizes:") ||
                                                       iscomment($buffer, "DocumentMedia:"))) {
      push @sizeheaders, $record;
    } elsif ($headerpos == 0 && iscomment($buffer, "Pages:")) {
      $pagescmt = $record;
    } elsif ($headerpos == 0 && iscomment($buffer, "EndComments")) {
      $headerpos = tell $infile;
    } elsif (iscomment($buffer, "BeginDocument") ||
             iscomment($buffer, "BeginBinary") ||
             iscomment($buffer, "BeginFile")) {
      $nesting++;
    } elsif (iscomment($buffer, "EndDocument") ||
             iscomment($buffer, "EndBinary") ||
             iscomment($buffer, "EndFile")) {
      $nesting--;
    } elsif ($nesting == 0 && iscomment($buffer, "EndSetup")) {
      $endsetup = $record;
    } elsif ($nesting == 0 && iscomment($buffer, "BeginProlog")) {
      $headerpos = tell $infile;
    } elsif ($nesting == 0 && iscomment($buffer, "BeginProcSet: PStoPS")) {
      $beginprocset = $record;
    } elsif ($beginprocset && !$endprocset && iscomment($buffer, "EndProcSet")) {
      $endprocset = tell $infile;
    } elsif ($nesting == 0 && (iscomment($buffer, "Trailer") ||
                               iscomment($buffer, "EOF"))) {
      seek $infile, $record, SEEK_SET;
      last;
    }
  } elsif ($headerpos == 0) {
    $headerpos = $record;
  }
}
push @pageptr, tell $infile;
$pages = $#pageptr;
$endsetup = $pageptr[0] if $endsetup == 0 || $endsetup > $pageptr[0];

# Output the pages
pstops($pagerange, $signature, $modulo, $pagesperspec, $odd, $even, $reverse, $nobinding, $specs, $draw, @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]);
    die("I/O error") 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")
      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 };
    } else {
      die("page range syntax error") unless $range_text =~ m/^(-?\d+)?(?:(:)(-?\d+))?$/;
      $range = { from => $1 || 1, to => $2 ? ($3 || -1) : $1 };
    }
    $range->{text} = $range_text;
    push @ranges, $range;
  }
  return \@ranges;
}

sub abs_page {
  my ($n) = @_;
  if ($n < 0) {
    $n += $pages + 1;
    $n = max($n, 1);
  }
  return $n;
}

sub page_index_to_real_page {
  my ($ps, $maxpage, $modulo, $signature, $pagebase) = @_;
  my $page_number = ($ps->{reversed} ? $maxpage - $pagebase - $modulo : $pagebase) + $ps->{pageno};
  my $real_page = $page_number - $page_number % $signature;
  my $page_on_sheet = $page_number % 4;
  my $recto_verso = int(($page_number % $signature) / 2);
  if ($page_on_sheet == 0 || $page_on_sheet == 3) {
    $real_page += $signature - 1 - $recto_verso;
  } else {
    $real_page += $recto_verso;
  }
  return $real_page;
}

sub gcd {
  my ($a, $b) = @_;
  return $b ? gcd($b, $a % $b) : $a;
}

sub ps_transform {
  my ($ps) = @_;
  return $ps->{rotate} != 0 || $ps->{flip} ne "" || defined($ps->{scale}) || defined($ps->{xoff});
}

sub pstops {
  my ($pagerange, $signature, $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 {
   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") if $currentpg > $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;

  # Reverse page list if reversing pages
  @page_to_real_page = reverse @page_to_real_page if $reverse;

  # Adjust for signature size
  my $maxpage = (int($pages_to_output + $modulo - 1) / $modulo) * $modulo;
  if ($signature == 0) {
    $signature = $maxpage = $pages_to_output + (4 - $pages_to_output % 4) % 4;
  } else {
    my $lcm = ($signature / gcd($signature, $modulo)) * $modulo;
    $maxpage = $pages_to_output + ($lcm - $pages_to_output % $lcm) % $lcm;
  }

  # 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 ($pagescmt) {
    fcopy($pagescmt, @ignorelist);
    my $line;
    die("I/O error in header") 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($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
  fcopy($beginprocset) if $beginprocset;
  # Skip any existing procset if we're using ours
  seek $infile, $endprocset, SEEK_SET if $endprocset && $use_procset;
  fcopy($endsetup);

  # Save transformation from original to current matrix
  say $outfile "userdict/PStoPSxform PStoPSmatrix matrix currentmatrix\
 matrix invertmatrix matrix concatmatrix\
 matrix invertmatrix put" if !$beginprocset && $use_procset;

  # Write from end of setup to start of pages
  fcopy($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 $real_page = page_index_to_real_page($ps, $maxpage, $modulo, $signature, $pagebase);
        if ($real_page < $pages_to_output && &$page_to_real_page($real_page) < $pages) {
          # Seek the page
          my $p = &$page_to_real_page($real_page);
          seek $infile, $pageptr[$p], SEEK_SET;
          my $line = <$infile>;
          die("I/O error seeking page $p") unless $line && iscomment($line, "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_real_page($spec, $maxpage, $modulo, $signature, $pagebase)) + 1;
          }
          $pagelabel = "(" . (join ",", @pagelabels) . ")";
          # Write page comment
          my $page_label_number = $real_page < $pages_to_output && &$page_to_real_page($real_page) < $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->{flip} eq "h";
          say $outfile "[ 1 0 0 -1 0 " . $iheight * $ps->{scale} * $scale . " ] concat"
            if $ps->{flip} eq "v";
          say $outfile (sprintf "%f", $ps->{scale} * $scale) . " dup scale"
            if defined($ps->{scale});
          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 ($beginprocset && $real_page < $pages_to_output && &$page_to_real_page($real_page) < $pages) {
          # Search for page setup
          for (;;) {
            my $line = <$infile>;
            die("I/O error reading page setup $outputpage") if !defined($line);
            last if $line !~ /^PStoPSxform/;
            print $outfile $line or die("I/O error writing page setup $outputpage");
          }
        }
        say $outfile "PStoPSxform concat" if !$beginprocset && $use_procset;
        if ($real_page < $pages_to_output && &$page_to_real_page($real_page) < $pages) {
          # Write the body of a page
          fcopy($pageptr[&$page_to_real_page($real_page) + 1]);
        } else {
          say $outfile "showpage";
        }
        say $outfile "PStoPSsaved restore" if $use_procset;
        $spec_page_number++;
      }
    }
  }

  # Write trailer
  seek $infile, $pageptr[$pages], SEEK_SET;
  while (<$infile>) { print $outfile $_; }
  say STDERR "Wrote $outputpage pages" if $verbose;
}
