#!/usr/bin/perl -CSDAL

use strict;
use warnings;
use utf8;

use IO::Socket::INET;

my @quality= ( "auto", undef, undef, "draft", "normal", "high" );
# Not implemented as options:
#my @colourspace= qw( sGray sRGB CieLab AdobeRGB Gray32 RGB CMYK );
#my @duplex= qw( no shortside longside );
#my @mediatype= qw( auto stationery transparency envelope cardstock labels
#    stationery letterhead disc matte satin semigloss gloss highgloss other );
#my @mediaposition= qw( auto main alternate large capacity manual envelope
#    disc photo hagaki main roll alternate roll top middle bottom side left
#    right center rear bypass tray1 tray2 tray3 tray4 tray5 tray6 tray7 tray8
#    tray9 tray10 tray11 tray12 tray13 tray14 tray15 tray16 tray17 tray18 tray19
#    tray20 roll1 roll2 roll3 roll4 roll5 roll6 roll7 roll8 roll9 roll10 );

my $usage= <<EOF;
usage: printurf.pl [ -t | -p | -n ] [ -q <quality> ] <image> <width/resolution> <destination>
Convert image to URF format and optionally send to printer.
This program comes with NO WARRANTY of any kind, including but not limited to
any implied warranty of fitness for a purpose.
The GraphicsMagick command line tool is used to convert and pad or resize the
input image (except in test mode, see -t below).
<width/resolution> is a (possibly fractional) number followed by a unit mm, dpi
or dpmm.  In the first case it is the width of the image, otherwise the
resolution.  As printers seem to require the resolution to be a divisor of 1200
dpi, non-PPM input images will be resized while being converted and the
resolution changed; for PPM images a warning will be printed for potentially
unsuitable resolutions.  The URF format contains the resolution in integer dpi,
so values may be rounded.
<destination> is a file if it contains a slash, otherwise the host name or IP
address of the printer, possibly followed by a colon and the port number
(default 9100).
The options -p / -n enable / disable padding the image with a 0.4" white
margin.  By default, this is enabled for printer destinations and disabled for
file destinations.
The -q option sets the printing quality in the URF header.  <quality> is one of
auto (default), draft, normal or high.
The option -t activates test mode, which processes a PPM file without resizing
or padding and does not require GraphicsMagick.
EOF

my ($pad, $testmode);
my $padinches= 0.4;     # minimum > 0.2
my $quality= 0;

while( @ARGV && $ARGV[0] =~ /^-/ ) {
    if( $ARGV[0] =~ /^--?h(?:elp)?$/ ) {
        print $usage;
        exit;
    }
    elsif( $ARGV[0] eq "-t" ) {
        $testmode= 1;
    }
    elsif( $ARGV[0] =~ /^-[pn]$/ ) {
        $pad= $ARGV[0] eq "-p" ? 1 : 0;
    }
    elsif( $ARGV[0] eq "-q" ) {
        shift @ARGV;
        unless( @ARGV ) {
            print STDERR "-q has to be followed by print quality\n";
            print $usage;
            exit 1;
        }
        my $newq;
        for (0..$#quality) {
            $newq= $_, last if defined($quality[$_]) && $quality[$_] eq $ARGV[0];
        }
        unless( defined $newq ) {
            print STDERR "\`$ARGV' is not a recognised print quality\n";
            print $usage;
            exit 1;
        }
        $quality= $newq;
    }
    else {
        print STDERR "Unknown option $ARGV[0]\n";
        print $usage;
        exit 1;
    }
    shift @ARGV;
}

if( @ARGV != 3 ) {
    print STDERR (@ARGV > 3 ? "Trailing surplus" : "Too few"), " arguments\n";
    print $usage;
    exit 1;
}

autoflush STDOUT 1;

my ($ppmin, $dpi, $destfile, $printer, $printerport);
my $ppmtmp= "/tmp/printurf-$$.ppm";

die "Cannot parse (possibly fractional) number and unit mm, dpi or dpmm in width / resolution argument \`$ARGV[1]'\n"
    unless $ARGV[1] =~ /^\s*(\d+(?:\.\d*)?|\.\d+)\s*(mm|dpi|dpmm)\s*$/;
my ($wresnum, $wresunit)= ($1, $2);
if( $wresunit eq "dpi" ) {
    $dpi= int($wresnum + 0.5);
}
elsif( $wresunit eq "dpmm" ) {
    $dpi= int($wresnum*25.4 + 0.5);
    print "Given image resolution $wresnum dpmm is $dpi dpi\n";
}

if( $ARGV[2] =~ m|/| ) {
    $destfile= $ARGV[2];
    $pad //= 0;
}
else {
    $printer= $ARGV[2];
    $pad //= 1;
    $printerport= $printer =~ s/:(\d+)$// ? $1 : 9100;
    die "Port number $printerport exceeds 16 bits\n"
        if $printerport > 0xFFFF;
    unless( $printer =~ /^(?:\w+(?:\.\w+)*|\[[\da-f][\da-f:]+[\da-f]\])$/ ) {
        print STDERR "Warning: suspect printer host name or IP address \`$printer'\nInterrupt with Ctrl-C within 5 seconds unless OK\n";
        sleep 5;
    }
}

if( $testmode ) {
    die "Source image has to be in PPM format for test mode\n"
        unless $ARGV[0] =~ /\.ppm$/i;
    $ppmin= $ARGV[0];
    print "Warning: most printers do not support > 1200 dpi\n"
        if defined($dpi) && $dpi > 1200;
    print "Warning: image resolution does not divide 1200 dpi\n"
        if defined($dpi) && 1200 % $dpi != 0;
}
else {
    my ($w, $h)= split /\s+/, `gm identify -format "%w %h" $ARGV[0]`;
    die "Cannot determine resolution of input image with gm identify\n"
        unless $w && $h;
    if( $wresunit eq "mm" ) {
        $dpi= int($w/$wresnum*25.4 + 0.5);
        print "Given image width implies $dpi dpi\n";
    }
    my @resize;
    my $validdpi= $dpi >= 1200 ? 1200 : $dpi <= 150 ? 150 : 1200 / 2**int(log(1200/$dpi)/log(2));
    # IIRC 75 dpi is accepted too but has low geometrical accuracy
    if( $dpi != $validdpi ) {
        print "Changing image resolution $dpi dpi to $validdpi and scaling image accordingly.\n";
        @resize= ("-resize", int($w*$validdpi/$dpi+0.5)."x");
        $dpi= $validdpi;
    }
    my @cmd= ("gm", "convert", $ARGV[0], @resize, $ppmtmp);
    print "Running ", join(" ", @cmd), "\n";
    my $status= system @cmd;
    if( $status == -1 ) {
        die "Could not run gm convert on input image: $!\n";
    }
    elsif( $status != 0 ) {
        die "Error running gm convert on input image\n";
    }
    $ppmin= $ppmtmp;
}

open PPM, "<", $ppmin
    or die "Cannot open PPM image file $ppmin: $!\n";
binmode PPM;
my %ppm= ( data => "", size => -s $ppmin );
# Read and parse PPM header, assumed to be within first 1024 bytes
$_= read PPM, $ppm{data}, 1024;
die "Cannot read from PPM image file $ppmin: $!\n"
    unless defined $_;
die "$ppmin is not a binary PPM file\n"
    unless $ppm{data} =~ s/^P6\b//s;
my $gapre= qr/\s+(?:\#[^\n]*\n\s*)*|(?:\#[^\n]*\n\s*)*\s/;
die "Cannot parse PPM header in $ppmin\n"
    unless $ppm{data} =~ s/^$gapre(\d+)$gapre(\d+)$gapre(\d+)\s//;
@ppm{qw( width height max )}= ($1, $2, $3);
die "Cannot use 16-bit PPM file $ppmin\n"
    unless $ppm{max} < 256;
$_= $ppm{size} - tell(PPM) + length($ppm{data}) - 3*$ppm{width}*$ppm{height};
die "Mismatch between image size and file size in $ppmin - " . ($_ > 0 ? "surplus":"missing") . " data\n"
    unless $_ == 0;
die "Image width < 2 not supported\n" unless $ppm{width} >= 2;
if( $wresunit eq "mm" && $ppmin eq $ARGV[0] ) {
    $dpi= int($ppm{width}/$wresnum*25.4 + 0.5);
    print "Given image width implies $dpi dpi\n";
    die "Not printing: most printers do not support > 1200 dpi\n"
        if $dpi > 1200;
    print "Warning: image resolution is not 1200 dpi divided by power of 2\n"
        unless $dpi == 1200 / 2**int(log(1200/$dpi)/log(2));
}

my $dest;
if( defined $destfile ) {
    open $dest, ">", $destfile
        or die "Cannot create output file $destfile:\n$!\n";
    print "Writing to file $destfile\n";
}
else {
    $dest= IO::Socket::INET->new( Type => SOCK_STREAM(), Proto => "tcp",
                            PeerAddr => $printer, PeerPort => $printerport )
        or die "Cannot connect to printer: $!\n";
    print "Connected to printer $printer, port $printerport\n";
}
binmode $dest;

# Generate binary URF header
sub urfhead
{
    my ($bpp, $colspace, $duplex, $quality, $mediatype, $mediapos, $w, $h, $spi)= @_;
    return pack("a12C6a6N3a8", "UNIRAST", $bpp, $colspace, $duplex, $quality, $mediatype, $mediapos, "", $w, $h, $dpi, "");
}

# Encode a pixel row to URF format
sub encoderow
{
    my $row= shift;
    my $w= int(length($row)/3);
    my $out= "";
    my ($pix, $lastpix, $eqstart, $diffstart);
    my $x= 0;
    while( $x < $w-1 ) {
        if( substr($row, 3*$x, 3) eq substr($row, 3*$x+3, 3) ) {
            my $startx= $x;
            my $pix= substr($row, 3*$x, 3);
            my $topx= $w < $x + 128 ? $w : $x + 128;
            $x += 2;
            ++$x while $x < $topx && $pix eq substr($row, 3*$x, 3);
            $out .= pack("C", $x - $startx - 1) . $pix;
        }
        else {
            my $startx= $x;
            my $topx= $w < $x + 129 ? $w : $x + 129;
            # 129 is one more than the maximum sequence length, but we want to
            # shorten the sequence if its last pixel equals the following
            $x += 2;
            ++$x while $x < $topx && substr($row, 3*$x, 3) ne substr($row, 3*$x-3, 3);
            --$x unless $x == $w && $x < $startx + 129;
            # backtrack by 1 if we found an equal pair or exceeded the maximum
            # sequence length
            if( $x >= $startx + 2 || $x == $w ) {
                $out .= pack("C", 257 - ($x - $startx)) . substr($row, 3*$startx, 3*($x - $startx));
            }
            else {  # encode first pixel as run-length sequence and leave the
                    # rest for new run-length sequence
                $out .= "\x00" . substr($row, 3*$startx, 3);
            }
        }
    }
    $out .= "\x00" . substr($row, 3*$x, 3) if $x == $w-1;
    return $out;
}

my $padpixels= int($padinches*$dpi*$pad);
print "Padding by $padpixels pixels\n" if $pad;

# output URF header
print $dest urfhead(24, 1, 0, $quality, 0, 0, $ppm{width}+2*$padpixels, $ppm{height}+2*$padpixels, $dpi);

my ($whiterow, $padmargin)= ("", "");
if( $pad ) {
    $whiterow= "\xFF" x (3*($ppm{width}+2*$padpixels));
    $whiterow= encoderow($whiterow);
    my $padrows= $padpixels;
    while( $padrows > 256 ) {
        print $dest "\xFF", $whiterow;
        $padrows -= 256;
    }
    print $dest pack("C", $padrows-1), $whiterow;
    $padmargin= "\xFF" x (3*$padpixels);
}

# $eqrowsm1 is the number of sequential equal rows - 1
my ($y, $lastrow, $eqrowsm1)= ( 0, "", 0 );
while( $y < $ppm{height} ) {
    my $row;
    if( length $ppm{data} ) {
        $row= substr $ppm{data}, 0, 3*$ppm{width}, "";
        $_= length($row);
        if( $_ < 3*$ppm{width} ) {
            $_= read PPM, $row, 3*$ppm{width}-$_, $_;
            $_= length($row);
        }
    }
    else {
        $_= read PPM, $row, 3*$ppm{width};
    }
    if( !defined($_) || $_ < 3*$ppm{width} ) {
        die "Error reading pixel data from $ppmin" . (defined? "":": $!") . "\n";
    }
    ++$y;
    $row= $padmargin . $row . $padmargin;
    unless( length $lastrow ) {
        $lastrow= $row;
        next;
    }
    if( $eqrowsm1 < 255 && $row eq $lastrow ) {
        ++$eqrowsm1;
        next;
    }
    print $dest pack("C", $eqrowsm1), encoderow($lastrow);
    $eqrowsm1= 0;
    $lastrow= $row;
}
print $dest pack("C", $eqrowsm1), encoderow($lastrow);

if( $pad ) {
    # $whiterow, unlike $padmargin, is already encoded
    my $padrows= $padpixels;
    while( $padrows > 256 ) {
        print $dest "\xFF", $whiterow;
        $padrows -= 256;
    }
    print $dest pack("C", $padrows-1), $whiterow;
}

close $dest;
close PPM;

unlink $ppmtmp if -f $ppmtmp;

