#!/usr/bin/env perl
# @(#) CIPserver.pl	Acquires Castelle-Internet-Print jobs from a POP3 server
#			and passes them to a designated printer.
#			Rev'd: 2011-11-04.
#
# Copyright (c) 2007 Graham Jenkins <grahjenk@cpan.org>. All rights reserved.
# This program is free software; you can redistribute it and/or modify it under
# the same terms as Perl itself.

use strict;
use warnings;
use File::Basename;
use File::Temp qw/tempfile/;
use Mail::POP3Client;        # Note: IO::Socket::SSL must be installed
use Net::Netrc;              # if SSL connections are to be made!
use Net::SMTP;
use Net::CUPS::Destination;
use MIME::Base64;
use Compress::Zlib;
use Compress::Raw::Lzma;
use Sys::Hostname;
use Socket;
use vars qw($VERSION);
$VERSION = "1.14";

# Un_compress subroutine; accepts string as parameter, uncompresses if possible
sub un_compress {
  my ($z,$o);
  if ( defined(uncompress($_[0])) ) { $_[0]=uncompress$_[0]; return } 
  $z=new Compress::Raw::Lzma::AutoDecoder;
  if( $z->code($_[0],$o)==LZMA_STREAM_END ) { $_[0]=$o }
}

# Usage check
if ($#ARGV != 2) {die "Usage: ",basename($0)." Pop3Server Printer MaxMb\n"}
if ( ($ARGV[2] !~ m/^\d+$/) && ($ARGV[2] !~ m/^-\d+$/) ) {
  die "MaxMb must be integer, with optional preceding '-' for SSL connection\n"}

# If an old PID file exists, kill the stale process; then write new PID
my $pidfile=File::Spec->catdir(File::Spec->rootdir,"var","tmp",
                               basename($0)."=".$ARGV[0]); 
if (open(FILE,$pidfile)) {my $p=<FILE>; close FILE; unlink($pidfile); kill 9,$p}

open(FILE,'>',$pidfile) or die "Can't open PID file";
print FILE $$           or die "Can't write to PID file";
close FILE;

# Login to POP3 server, get and delete one job, then repeat 
while (1) {
  my ($ssl, $mach, $login, $pass, $acc, $pop);
  if ($ARGV[2]>0) {$ssl=0} elsif ($ARGV[2]<0) {$ssl=1} else {die "MaxMB=0 ??\n"}
  $mach=Net::Netrc->lookup($ARGV[0])   or die ".netrc entry not found\n";
  ($login, $pass, $acc) = $mach->lpa   or die "Login or password not found\n";
  $pop=new Mail::POP3Client(USER=>$login, PASSWORD=>$pass, HOST=>$ARGV[0],
                            USESSL=>$ssl);
  if ($pop->Count()<0)                          {die "Connection failed\n"}
  if ($pop->Count()<1)                          {exit 0}
  my ($msgn,$size) = split(/\s+/,$pop->List(1));
  if ($size < abs($ARGV[2])*1024*1024) {# Append line to string if "Notify",
    my ($retu, $noti, $junk, $str,$b64);# "base64" and empty line have been seen
    foreach my $a (my @array=$pop->Retrieve(1)) { 
      if (defined($str))                                       {$str.=$a; next}
      if (defined($b64) && (length($a)<2))                     {$str="" ; next}
      my (@word)=split(/\s+/,$a);
      if (defined($word[1]) && ($word[0]=~m/^From:$/        )) {$retu=$word[1]}
      if (defined($word[1]) && ($word[0]=~m/^Notify:$/      )) {$noti=$word[1]}
      if (defined($word[0]) && ($word[0]=~m/^BRO-NOTIFY=/   )) {$noti="Y"     }
      if (defined($word[0]) && ($word[0]=~m/^BRO-NOTIFY=N/  )) {$noti="N"     }
      if (defined($word[0]) && ($word[0]=~m/^BRO-REPLY=/    )) {
                                             ($junk,$retu)=split(/=/,$word[0])}
      if (defined($noti)&&defined($word[1])&&($word[1]=~m/^base64$/)) {$b64=""}
    }
    if( ! (defined($retu)) )                              {$retu=""; $noti="N"}
    if(defined($str)) {
      if ( $str=decode_base64($str) ) {
        my $got=length($str);
        un_compress($str);
        my ($fh,$tmp)=tempfile(UNLINK=>1);
        print $fh $str;                 # Decode the string, check for (non-
        close $fh;                      # standard) compression, print to
        my $cups=Net::CUPS->new();      # temporary file, then print the file
        my $printer=$cups->getDestination($ARGV[1]);
        my ($index,$uid)=split(/\s+/,$pop->Uidl(1));
        if (my $jobid=$printer->printFile("$tmp","$uid")) {print $uid,": ",
                 $retu, " ", $got, " bytes => ", $ARGV[1]."-".$jobid, "\n"}
        if ( $noti=~m/^Y/ ) {		# If notification requested, email it
          if (my $smtp=Net::SMTP->new() ) {
            my @host=gethostbyaddr(inet_aton(hostname),AF_INET);
            my $logname=$ENV{LOGNAME} || $ENV{USER} || "root";
            $smtp->mail($logname."\@".$host[0]); $smtp->to($retu);
            $smtp->data("To: ",$retu,"\nSubject: Job ",$uid," for Printer ",
                               $ARGV[1], "\n\n", $got,     " bytes received;",
                                         "\n", length($str)," bytes printed.");
            $smtp->quit();           print $uid,": notification => ",$retu,"\n"
          }
        }
      }
    }
  }
  $pop->Delete(1); $pop->Close()	# Close as soon as we've processed each
}					# job, so a break can only effect 1 job

__END__

=head1 NAME

CIPserver - Castelle/Kingston print-server emulator

=head1 README

CIPserver acquires Castelle-Internet-Print jobs from
a POP3 server and passes them to a designated printer.

=head1 DESCRIPTION

C<CIPserver> is a simple Castelle print-server emulator using
the Castelle-Internet-Print protocol. It should be called
periodically (e.g. through 'cron' at 15-minute intervals).

At each invocation, it retrieves jobs sent to a
designated address on a POP3 server, and passes
them to a corresponding printer.

=head1 USAGE

=over 6

CIPserver Pop3Server Printer [-]Max-Mb

=back

e.g.: CIPserver lavabit.com HP4350 -64

Accesses the designated POP3 server and sends jobs
found there to the nominated printer. Incoming messages
whose length exceeds Max-Mb are dropped. Messages whose
contents have been compressed by a software client are
automatically uncompressed.

Login names and passwords are extracted using Net::Netrc.
You can force CIPserver to use SSL by specifying a
negative value for Max-Mb.

An appropriate Windows client program can be downloaded
from <www.castelle.com>. CIPserver is also able to
process single-part Brother-Internet-Print jobs and jobs
intended for Kingston print-servers.

=head1 SCRIPT CATEGORIES

Networking
UNIX/System_administration

=head1 AUTHOR

Graham Jenkins <grahjenk@cpan.org>

=head1 COPYRIGHT

Copyright (c) 2007 Graham Jenkins. All rights reserved.
This program is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.

=cut