#!/usr/bin/perl
#
# psbind -- Transform PostScript files to save trees and reduce guilt
# http://www.digitas.harvard.edu/~ken/psbind

# Copyright (c) 2001, Chung-chieh Shan.

# 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 2 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, write to the Free Software
# Foundation, Inc., 59 Temple Place Suite 330, Boston, MA 02111-1307,
# USA.

# You may contact Chung-chieh Shan at:

#     240 Franklin St Apt 4
#     Cambridge, MA 02139-3986, USA
#     ccshan@post.harvard.edu

# Latest contact information may be found at
# http://www.digitas.harvard.edu/~ken

use strict;
use Getopt::Long;

## Parse command line options

local $SIG{__WARN__} = sub
{
    print STDERR $_[0]
        unless $_[0] =~ /^Ignoring '!' modifier for short option/s;
};

Getopt::Long::Configure(qw(no_auto_abbrev
    no_getopt_compat no_require_order permute bundling));

my %options =
(
    quiet       => 0,           # Whether to hide status messages
    nup         => undef,       # Action choice 1: invoke psnup (default)
    trim        => undef,       # Action choice 2: trim to bounding box
    center      => undef,       # Action choice 3: center on page
    xmodulus    => 2,           # Modulus with which to detect input width
    ymodulus    => 1,           # Modulus with which to detect input height
    sample      => '-10',       # Input pages to sample
    paper       => 'letter',    # Output paper size (letter or a4)
    printer     => undef,       # Output printer name
    n           => 2,           # Number of pages per sheet, for --nup
    margin      => 9,           # Margin around each sheet, for --nup
    border      => 9,           # Border around each page, for --nup
    fix         => 'auto',      # Fixps invocation control (auto/no/yes/force)
    scoot       => undef,       # Whether to prepend a blank virtual page
    tumble      => undef,       # Whether to rotate every other (n-up'd) page
    ghostscript => 'gs',        # Command for invoking Ghostscript
    psnup       => 'psnup',     # Command for invoking psnup
    pstops      => 'pstops',    # Command for invoking pstops
    psselect    => 'psselect',  # Command for invoking psselect
    fixps       => 'fixps',     # Command for invoking fixps
    lpr         => 'lpr',       # Command for invoking lpr
);
GetOptions
(
    \%options,
    'quiet|q!',
    'nup|N!',
    'trim|T!',
    'center|C!',
    'xmodulus|x-modulus|xmod|x-mod|xm|x=i',
    'ymodulus|y-modulus|ymod|y-mod|ym|y=i',
    'sample|s=s',
    'paper|p=s',
    'printer|P=s',
    'n|nup-n=i',
    'margin|nup-margin|m=s',
    'border|nup-border|b=s',
    'fix=s',
    'scoot!',
    'tumble!',
    'ghostscript=s',
    'psnup=s',
    'pstops=s',
    'psselect=s',
    'fixps=s',
    'lpr=s',
    map(("$_", sub { $options{n} = $_[0] }), 1..9)
)
or exit 3;

$options{nup} = 1
    if not defined $options{nup}
    and not $options{trim}
    and not $options{center};

die "Usage error: Only one of --nup, --trim and --center may be specified.\n"
    if $options{nup} + $options{trim} + $options{center} != 1;

my %fix = qw(auto       auto
             a          auto
             automatic  auto
             default    auto
             no         no
             n          no
             false      no
             off        no
             yes        yes
             y          yes
             true       yes
             on         yes
             force      force
             f          force
             full       force
             rewrite    force);
die "Usage error: The value of --fix must be one of: auto, no, yes, force.\n"
    if not defined ($options{fix} = $fix{lc($options{fix})});

my $sample = parse_sample($options{sample})
    or die qq|Usage error: "$options{sample}" is not a valid list of pages.\n|;

my ($paper_cx, $paper_cy) = parse_paper($options{paper})
    or die qq|Usage error: Unknown paper size "$options{paper}".\n|;

unshift @ARGV, "-"   if @ARGV == 0;
push    @ARGV, undef if defined $options{printer};
push    @ARGV, "-"   if @ARGV < 2;

@ARGV == 2 or die "Usage error: Too many file names specified.\n";

sub parse_sample
{
    my $sample = $_[0];

    $sample =~ s/^,+//s;
    my @sample = split /,+/, $sample;
    @sample or return undef;

    my @ret;
    foreach my $sample (@sample)
    {
        my ($beg, $end) = ($sample =~ /^\s*([-+]?\d*)\s*-\s*([-+]?\d*)\s*$/s)
            or return undef;
        $beg or $beg = 1;
        $end or $end = -1;
        push @ret, [$beg, $end];
    }
    return \@ret;
}

sub parse_paper
{
    my $paper = $_[0];
    study $paper;

    return (612, 792) if $paper =~ /^(?:us|letter)$/si;
    return (596, 842) if $paper =~ /^a4$/si;
    return ();
}

## Put standard input in a temporary file, if necessary

if ($ARGV[0] eq "-")
{
    require File::Copy;
    my $tmpnam = tmpnam();
    File::Copy::copy(\*STDIN, $tmpnam)
        or die qq|Could not create temporary file "$tmpnam": $!.\n|;
    $ARGV[0] = $tmpnam;
}

# Choose and keep track of temporary file names
my @tmpnam;
BEGIN { $SIG{INT} = $SIG{QUIT} = sub { exit 1 } }
END { unlink @tmpnam }
sub tmpnam
{
    require POSIX;
    my $tmpnam = POSIX::tmpnam();
    push @tmpnam, $tmpnam;
    print STDERR qq|Creating temporary file "$tmpnam".\n|
        unless $options{quiet};
    return $tmpnam;
}

## Use Ghostscript to find bounding boxes of pages

my ($xmin, $xmax, $cx, $ymin, $ymax, $cy);

my @bbox_trial = ();
$options{fix} =~ /^auto|no$/s
    and push @bbox_trial, [$ARGV[0], 'file'];
$options{fix} =~ /^yes$/s
    and push @bbox_trial, ["$options{fixps} \Q$ARGV[0]\E", 'pipe'];
$options{fix} =~ /^auto|force$/s
    and push @bbox_trial, ["$options{fixps} --force \Q$ARGV[0]\E", 'pipe'];
while (@bbox_trial)
{
    my ($input, $input_type) = @{shift @bbox_trial};
    if ($input_type eq 'pipe')
    {
        my $tmpnam = tmpnam();
        $input = "$input | tee \Q$tmpnam\E";
        $ARGV[0] = $tmpnam;
    }

    if (($xmin, $xmax, $cx, $ymin, $ymax, $cy) = find_bbox($input, $input_type))
    {
        last if $options{fix} ne 'auto';
        last if $cx > 100 and $cx < 1200 and $cy > 100 and $cy < 1200;
    }
}
die "Could not determine page layout from sampled pages.\n"
    if grep { not defined } $xmin, $xmax, $cx, $ymin, $ymax, $cy;
print STDERR "x: (@$xmin)--(@$xmax) = $cx\n" unless $options{quiet};
print STDERR "y: (@$ymin)--(@$ymax) = $cy\n" unless $options{quiet};

sub find_bbox
{
    my ($x1, $y1, $x2, $y2) = gs_bbox(@_);
    my $n = scalar(@$x1) or return;
    my $relevant = relevant($n);
    my ($xmin, $xmax, $cx) = detect($x1, $x2,
        $relevant, $options{xmodulus}, $options{ymodulus}) or return;
    my ($ymin, $ymax, $cy) = detect($y1, $y2,
        $relevant, $options{ymodulus}, $options{xmodulus}) or return;
    return ($xmin, $xmax, $cx, $ymin, $ymax, $cy);
}

# Invoke Ghostscript and read its output
sub gs_bbox
{
    my ($input, $input_type) = @_;      # Read input from file or pipe
    my @x1; my @y1; my @x2; my @y2;     # Bounding boxes by page, in points

    # Compose command to invoke ghostscript with the bbox device driver
    my $cmd = "$options{ghostscript} -dNOPLATFONTS -dNOPAUSE " .
        "-dQUIET -dSAFER -sDEVICE=bbox -dBATCH -sOutputFile=/dev/null";
    if    ($input_type eq 'file') { $cmd = "$cmd \Q$input\E 2>&1" }
    elsif ($input_type eq 'pipe') { $cmd = "$input | $cmd - 2>&1" }
    else                          { die                           }
    print STDERR "$cmd\n" unless $options{quiet};

    # Be ready to cut off Ghostscript if we don't need further information
    my $max_sample = 0;
    {
        my @sample = map @$_, @$sample;
        if (not grep $_ < 0, @sample)
        {
            $max_sample >= $_ or $max_sample = $_ foreach @sample;
        }
    }

    # Invoke Ghostscript and read bounding box information from it
    open GS, "$cmd|" or die "Could not invoke Ghostscript: $!.\n";
    while (defined($_ = <GS>) and not ($max_sample > 0 and @x1 >= $max_sample))
    {
        if (my ($x1, $y1, $x2, $y2) =
            /^%%\s*BoundingBox\s*:\s*(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s*$/is)
        {
            push @x1, $x1;
            push @y1, $y1;
            push @x2, $x2;
            push @y2, $y2;
            printf STDERR "%4d: %s", scalar(@x1), $_
                unless $options{quiet};
        }
    }
    close GS;

    # Done
    return (\@x1, \@y1, \@x2, \@y2);
}

# Decide which pages' bounding boxes we actually want to consider
sub relevant
{
    my ($n) = @_;
    my @relevant;

    foreach my $s (@$sample)
    {
        my ($beg, $end) = @$s;
        $relevant[$_] = 1
            foreach ($beg > 0 ? $beg - 1 : $beg + $n)
                 .. ($end > 0 ? $end - 1 : $end + $n);
    }
    return \@relevant;
}

# Detect input page size
sub detect
{
    my ($list1, $list2, $relevant, $modulus, $other_modulus) = @_;

    my @min = (undef) x $modulus;
    my @max = (undef) x $modulus;
    for (my $i = 0; $i < @$relevant; ++$i)
    {
        if ($relevant->[$i] and $list1->[$i] < $list2->[$i])
        {
            my $offset = $i % $modulus;
            defined $min[$offset] and $min[$offset] <= $list1->[$i]
                                   or $min[$offset]  = $list1->[$i];
            defined $max[$offset] and $max[$offset] >= $list2->[$i]
                                   or $max[$offset]  = $list2->[$i];
        }
    }
    return () if grep !defined, @min or grep !defined, @max;

    my $sizes = zip(sub { $_[1] - $_[0] }, \@min, \@max);
    my $size = undef;
    defined $size and $size >= $_ or $size = $_ foreach @$sizes;

    @min = (@min) x $other_modulus;
    @max = (@max) x $other_modulus;

    return (\@min, \@max, $size);
}

## Construct command line for performing desired action

my ($ps2ps_cx, $ps2ps_cy)       # Output bounding box from pstops
    = $options{center} ? ($paper_cx, $paper_cy) : ($cx, $cy);

my ($final_cx, $final_cy)       # Final %%BoundingBox and %%PageBoundingBox
    = $options{trim} ? ($cx, $cy) : ($paper_cx, $paper_cy);

my $quiet = $options{"quiet"} ? " -q" : "";

my $cmd = "$options{pstops}$quiet";
$cmd .= " '" . scalar(@$xmin) . ":" . join(",",
    map sprintf("%d(%g,%g)", $_,
            ($ps2ps_cx - $cx) / 2 - $xmin->[$_],
            ($ps2ps_cy - $cy) / 2 - $ymin->[$_]), 0..$#$xmin);
$cmd .= "' \Q$ARGV[0]\E";

if ($options{scoot})
{
    $cmd .= " | $options{psselect}$quiet -p_,-";
}

if ($options{nup})
{
    $cmd .= " | $options{psnup}$quiet -w$paper_cx -h$paper_cy -W$cx -H$cy";
    $cmd .= " -m\Q$options{margin}\E -b\Q$options{border}\E -\Q$options{n}\E";
}

if ($options{tumble})
{
    $cmd .= " | $options{pstops}$quiet '2:0,1U($paper_cx,$paper_cy)'";
}

## Do it; filter output to fix DSC comments

my $out;
if ($ARGV[1] eq "-")
{
    $out = \*STDOUT;
}
elsif (defined $options{printer})
{
    require IO::Pipe;
    $out = IO::Pipe->new;
    $out->writer("$options{lpr} -P\Q$options{printer}\E");
}
else
{
    require IO::File;
    $out = IO::File->new($ARGV[1], ">")
        or die qq|Could not open "$ARGV[1]" for writing: $!.\n|;
}
print STDERR "$cmd\n"
    unless $options{quiet};
open PS, "$cmd|" or die "Could not invoke psutils: $!.\n";
while (<PS>)
{
    if (/^\s*%%\s*(BoundingBox|PageBoundingBox)\s*:/is)
    {
        print $out "%%$1: 0 0 $final_cx $final_cy\n";
    }
    elsif (/^\s*%%\s*(DocumentPaperSizes|PaperSize)\s*:/is)
    {
        # Do nothing
    }
    else
    {
        print $out $_;
    }
}
close PS;
close $out;

# The bane of functional programming

sub zip
{
    my $code = shift;

    my @ret;
    for (my $i = 0; grep $i < @$_, @_; ++$i)
    {
        push @ret, $code->(map $_->[$i], @_);
    }
    return \@ret;
}

