#!/usr/bin/perl

=pod

=head1 NAME

psbind - Transform PostScript files to save trees and reduce guilt

=head1 DESCRIPTION

C<psbind> examines the margins in a PostScript document and rearranges the pages
to fit them onto paper efficiently. It outputs a transformed PostScript
document.

Because C<psbind> detects the margins in its input automatically, it is
particularly useful on documents with large or unbalanced margins. For example,
many PostScript documents are laid out for paper sizes smaller than A4 or
Letter. C<psbind> can place two such pages onto one output page, often without
shrinking the text. It is also useful for printing documents formatted for A4
paper on Letter stock, or vice versa.

Please see http://www.digitas.harvard.edu/~ken/psbind for
further documentation.

=head1 PREREQUISITES

C<psbind> requires Ghostscript with C<bbox> device support (see L<gs>).  It also
requires psutils (see L<psnup>, L<pstops>, L<psselect>, and L<fixps>).

=head1 COREQUISITES

For sending its output to a printer, C<psbind> relies on C<lpr> (see L<lpr>).

=head1 VERSION

This version of C<psbind> is dated 2001-04-23.

=head1 COPYING

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

=head1 README

psbind examines the margins in a PostScript document and rearranges the pages
to fit them onto paper efficiently.

=head1 SCRIPT CATEGORIES

CPAN/Administrative

=cut

use strict;
use Getopt::Long;

my $VERSION = 2001_04_23;

## 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;
}