1
2=head1 NAME
3
4Net::Printer - Perl extension for direct-to-lpd printing.
5
6=head1 SYNOPSIS
7
8  use Net::Printer;
9
10  # Create new Printer Object
11  $lineprinter = new Net::Printer(
12                                  filename    => "/home/jdoe/myfile.txt",
13                                  printer     => "lp",
14                                  server      => "printserver",
15                                  port        => 515,
16                                  lineconvert => "YES"
17                                  );
18
19  # Print the file
20  $result = $lineprinter->printfile();
21
22  # Optionally print a file
23  $result = $lineprinter->printfile("/home/jdoe/myfile.txt");
24
25  # Print a string
26  $result =
27    $lineprinter->printstring("Smoke me a kipper, I'll be back for breakfast.");
28
29  # Did I get an error?
30  $errstr = $lineprinter->printerror();
31
32  # Get Queue Status
33  @result = $lineprinter->queuestatus();
34
35=head1 DESCRIPTION
36
37Perl module for directly printing to a print server/printer without
38having to create a pipe to either lpr or lp.  This essentially mimics
39what the BSD LPR program does by connecting directly to the line
40printer printer port (almost always 515), and transmitting the data
41and control information to the print server.
42
43Please note that this module only talks to print servers that speak
44BSD.  It will not talk to printers using SMB, SysV, or IPP unless they
45are set up as BSD printers.  CUPS users will need to set up
46B<cups-lpd> to provide legacy access. ( See L</"Using Net::Printer
47with CUPS"> )
48
49=cut
50
51use strict;
52use warnings;
53
54package Net::Printer;
55
56our @ISA = qw( Exporter );
57
58use 5.006;
59
60use Carp;
61use File::Temp;
62use FileHandle;
63use IO::Socket;
64use Sys::Hostname;
65
66our $VERSION = '1.12';
67
68# Exported functions
69our @EXPORT = qw( printerror printfile printstring queuestatus );
70
71# ----------------------------------------------------------------------
72
73=head1 METHODS
74
75=head2 new
76
77Constructor returning Net::Printer object
78
79=head3 Parameters
80
81A hash with the following keys:
82
83=over
84
85=item  * filename
86
87[optional] absolute path to the file you wish to print.
88
89=item  * printer
90
91[default: "lp"] Name of the printer you wish to print to.
92
93=item  * server
94
95[default: "localhost"] Name of the printer server
96
97=item  * port
98
99[default: 515] The port you wish to connect to
100
101=item  * lineconvert
102
103[default: "NO"] Perform LF -> LF/CR translation
104
105=item  * rfc1179
106
107[default: "NO"] Use RFC 1179 compliant source address.  Default
108"NO". see L<"RFC-1179 Compliance Mode and Security Implications">.
109
110=back
111
112=head3 Returns
113
114The blessed object
115
116=cut
117
118sub new
119{
120
121        my (%vars) = ("filename"    => "",
122                      "lineconvert" => "No",
123                      "printer"     => "lp",
124                      "server"      => "localhost",
125                      "port"        => 515,
126                      "rfc1179"     => "No",
127                      "debug"       => "No",
128                      "timeout"     => 15,
129        );
130
131        # Parameter(s);
132        my $type   = shift;
133        my %params = @_;
134        my $self   = {};
135
136        # iterate through each variable
137        foreach my $var (keys %vars) {
138                if   (exists $params{$var}) { $self->{$var} = $params{$var}; }
139                else                        { $self->{$var} = $vars{$var}; }
140        }
141
142        $self->{errstr} = undef;
143
144        return bless $self, $type;
145
146}          # new
147
148=head2 printerror
149
150Getter for error string, if any.
151
152=head3 Returns
153
154String containing error text, if any.  Undef otherwise.
155
156=cut
157
158sub printerror
159{
160
161        # Parameter(s)
162        my $self = shift;
163        return $self->{errstr};
164
165}          # printerror()
166
167=head2 printfile
168
169Transmits the contents of the specified file to the print server
170
171=head3 Parameters
172
173=over
174
175=item  * file
176
177Path to file to print
178
179=back
180
181=head3 Returns
182
1831 on success, undef on fail
184
185=cut
186
187sub printfile
188{
189        my $dfile;
190
191        my $self  = shift;
192        my $pfile = shift;
193
194        $self->_logDebug("invoked ... ");
195
196        # Are we being called with a file?
197        $self->{filename} = $pfile if ($pfile);
198        $self->_logDebug(sprintf("Filename is %s", $self->{filename}));
199
200        # File valid?
201        if (!($self->{filename}) || (!-e $self->{filename})) {
202
203                # Bad file name
204                $self->_lpdFatal(
205                                 sprintf("Given filename (%s) not valid",
206                                         $self->{filename}));
207                return undef;
208
209        } elsif (uc($self->{lineconvert}) eq "YES") {
210
211                # do newline coversion
212                $dfile = $self->_nlConvert();
213
214        } else {
215
216                # just set $dfile to the filename
217                $dfile = $self->{filename};
218        }
219
220        $self->_logDebug(sprintf("Real Data File    %s", $dfile));
221
222        # Create Control File
223        my @files = $self->_fileCreate();
224
225        $self->_logDebug(sprintf("Real Control File %s", $files[0]));
226        $self->_logDebug(sprintf("Fake Data    File %s", $files[1]));
227        $self->_logDebug(sprintf("Fake Control File %s", $files[2]));
228
229        # were we able to create control file?
230        unless (-e $files[0]) {
231                $self->_lpdFatal("Could not create control file\n");
232                return undef;
233        }
234
235        # Open Connection to remote printer
236        my $sock = $self->_socketOpen();
237
238        # did we connect?
239        if ($sock) { $self->{socket} = $sock; }
240        else {
241                $self->_lpdFatal("Could not connect to printer: $!\n");
242                return undef;
243        }
244
245        # initialize LPD connection
246        my $resp = $self->_lpdInit();
247
248        # did we get a response?
249        unless ($resp) {
250                $self->_lpdFatal(
251                                 sprintf("Printer %s on %s not ready!\n",
252                                         $self->{printer}, $self->{server}));
253                return undef;
254        }
255
256        $resp = $self->_lpdSend($files[0], $dfile, $files[2], $files[1]);
257
258        unless ($resp) {
259                $self->_lpdFatal("Error Occured sending data to printer\n");
260                return undef;
261        }
262
263        # Clean up
264        $self->{socket}->shutdown(2);
265
266        unlink $files[0];
267        unlink $dfile if (uc($self->{lineconvert}) eq "YES");
268
269        return 1;
270
271}          # printfile()
272
273=head2 printstring
274
275Prints the given string to the printer.  Note that each string given
276to this method will be treated as a separate print job.
277
278=head3 Parameters
279
280=over
281
282=item  * string
283
284String to send to print queue
285
286=back
287
288=head3 Returns
289
2901 on succes, undef on fail
291
292=cut
293
294sub printstring
295{
296
297        my $self = shift;
298        my $str  = shift;
299
300        # Create temporary file
301        my $tmpfile = $self->_tmpfile();
302        my $fh      = FileHandle->new("> $tmpfile");
303
304        # did we connect?
305        unless ($fh) {
306                $self->_lpdFatal("Could not open $tmpfile: $!\n");
307                return undef;
308        }
309
310        # ... and print it out to our file handle
311        print $fh $str;
312        $fh->close();
313        return undef unless $self->printfile($tmpfile);
314
315        # otherwise return
316        unlink $tmpfile;
317
318        return 1;
319
320}          # printstring()
321
322=head2 queuestatus
323
324Retrives status information from print server
325
326=head3 Returns
327
328Array containing queue status
329
330=cut
331
332sub queuestatus
333{
334
335        my @qstatus;
336        my $self = shift;
337
338        # Open Connection to remote printer
339        my $sock = $self->_socketOpen();
340
341        # did we connect?
342        unless ($sock) {
343                push( @qstatus,
344                      sprintf("%s\@%s: Could not connect to printer: $!\n",
345                              $self->{printer}, $self->{server},
346                      ));
347                return @qstatus;
348        }
349
350        # store the socket
351        $self->{socket} = $sock;
352
353        # Note that we want to handle remote lpd response ourselves
354        $self->_lpdCommand(sprintf("%c%s\n", 4, $self->{printer}), 0);
355
356        # Read response from server and format
357        eval {
358                local $SIG{ALRM} = sub { die "timeout\n" };
359                alarm 15;
360                $sock = $self->{socket};
361                while (<$sock>) {
362                        s/($_)/$self->{printer}\@$self->{server}: $1/;
363                        push(@qstatus, $_);
364                }
365                alarm 0;
366                1;
367        };
368
369        # did we get an error retrieving status?
370        if ($@) {
371                push( @qstatus,
372                      sprintf(
373"%s\@%s: Timed out getting status from remote printer\n",
374                              $self->{printer}, $self->{server})
375                ) if ($@ =~ /timeout/);
376        }
377
378        # Clean up
379        $self->{socket}->shutdown(2);
380        return @qstatus;
381}          # queuestatus()
382
383# Private Methods
384# ----------------------------------------------------------------------
385
386# Method: _logDebug
387#
388# Displays informative messages ... meant for debugging.
389#
390# Parameters:
391#
392#   msg    - message to display
393#
394# Returns:
395#
396#   none
397sub _logDebug
398{
399
400        # Parameter(s)
401        my $self = shift;
402        my $msg  = shift;
403
404        # strip newlines
405        $msg =~ s/\n//;
406
407        # get caller information
408        my @a = caller(1);
409
410        printf("DEBUG-> %-32s: %s\n", $a[3], $msg)
411            if (uc($self->{debug}) eq "YES");
412
413}          # _logDebug()
414
415# Method: _lpdFatal
416#
417# Gets called when there is an unrecoverable error.  Sets error
418# object for debugging purposes.
419#
420# Parameters:
421#
422#   msg - Error message to log
423#
424# Returns:
425#
426#   1
427sub _lpdFatal
428{
429
430        my $self = shift;
431        my $msg  = shift;
432
433        # strip newlines
434        $msg =~ s/\n//;
435
436        # get caller information and b uild error string
437        my @a = caller();
438        my $errstr = sprintf("ERROR:%s[%d]: %s", $a[0], $a[2], $msg,);
439        $self->{errstr} = $errstr;
440
441        # carp it
442        carp "$errstr\n";
443
444        return 1;
445
446}          # _lpdFatal()
447
448# Method: _tmpfile
449#
450# Creates temporary file returning its name.
451#
452# Parameters:
453#
454#   none
455#
456# Returns:
457#
458#   name of temporary file
459sub _tmpfile
460{
461
462        my $self = shift;
463
464        my $fh    = File::Temp->new();
465        my $fname = $fh->filename;
466
467        # Clean up
468        $fh->close();
469
470        return $fname
471
472}          # _tmpfile()
473
474# Method: _nlConvert
475#
476# Given a filename, will convert newline's (\n) to
477# newline-carriage-return (\n\r), output to new file, returning name
478# of file.
479#
480# Parameters:
481#
482#   none
483#
484# Returns:
485#
486#   name of file containing strip'd text, undef on fail
487sub _nlConvert
488{
489        my $self = shift;
490
491        $self->_logDebug("invoked ... ");
492
493        # Open files
494        my $ofile = $self->{filename};
495        my $nfile = $self->_tmpfile();
496        my $ofh   = FileHandle->new("$ofile");
497        my $nfh   = FileHandle->new("> $nfile");
498
499        # Make sure each file opened okay
500        unless ($ofh) {
501                $self->_logDebug("Cannot open $ofile: $!\n");
502                return undef;
503        }
504        unless ($nfh) {
505                $self->_logDebug("Cannot open $nfile: $!\n");
506                return undef;
507        }
508        while (<$ofh>) {
509                s/\n/\n\r/;
510                print $nfh $_;
511        }          # while ($ofh)
512
513        # Clean up
514        $ofh->close();
515        $nfh->close();
516
517        return $nfile;
518
519}          # _nlConvert()
520
521# Method: _socketOpen
522#
523# Opens a socket returning it
524#
525# Parameters:
526#
527#   none
528#
529# Returns:
530#
531#   socket
532sub _socketOpen
533{
534
535        my $sock;
536        my $self = shift;
537
538        # See if user wants rfc1179 compliance
539        if (uc($self->{rfc1179}) eq "NO") {
540                $sock =
541                    IO::Socket::INET->new(Proto    => 'tcp',
542                                          PeerAddr => $self->{server},
543                                          PeerPort => $self->{port},
544                    );
545        } else {
546
547                # RFC 1179 says "source port be in the range 721-731"
548                # so iterate through each port until we can open
549                # one.  Note this requires superuser privileges
550                foreach my $p (721 .. 731) {
551                        $sock =
552                            IO::Socket::INET->new(PeerAddr  => $self->{server},
553                                                  PeerPort  => $self->{port},
554                                                  Proto     => 'tcp',
555                                                  LocalPort => $p
556                            ) and last;
557                }
558        }
559
560        # return the socket
561        return $sock;
562
563}          # _socketOpen()
564
565# Method: _fileCreate
566#
567# Purpose:
568#
569#   Creates control file
570#
571# Parameters:
572#
573#   none
574#
575# Returns:
576#
577#   *Array containing following elements:*
578#
579#    - control file
580#    - name of data file
581#    - name of control file
582sub _fileCreate
583{
584        my %chash;
585        my $self   = shift;
586        my $myname = hostname();
587        my $snum   = int(rand 1000);
588
589        # Fill up hash
590        $chash{'1H'} = $myname;
591        $chash{'2P'} = getlogin || getpwuid($<) || "nobody";
592        $chash{'3J'} = $self->{filename};
593        $chash{'4C'} = $myname;
594        $chash{'5f'} = sprintf("dfA%03d%s", $snum, $myname);
595        $chash{'6U'} = sprintf("cfA%03d%s", $snum, $myname,);
596        $chash{'7N'} = $self->{filename};
597
598        my $cfile = $self->_tmpfile();
599        my $cfh   = new FileHandle "> $cfile";
600
601        # validation
602        unless ($cfh) {
603                $self->_logDebug(
604                                "_fileCreate:Could not create file $cfile: $!");
605                return undef;
606        }          # if we didn't get a proper filehandle
607
608        # iterate through each key cleaning things up
609        foreach my $key (sort keys %chash) {
610                $_ = $key;
611                s/(.)(.)/$2/g;
612                my $ccode = $_;
613                printf $cfh ("%s%s\n", $ccode, $chash{$key});
614
615        }
616
617        # Return what we need to
618        return ($cfile, $chash{'5f'}, $chash{'6U'});
619
620}          # _fileCreate()
621
622# Method: _lpdCommand
623#
624# Sends command to remote lpd process, returning response if
625# asked.
626#
627# Parameters:
628#
629#   self - self
630#
631#   cmd  - command to send (should be pre-packed)
632#
633#   gans - do we get an answer?  (0 - no, 1 - yes)
634#
635# Returns:
636#
637#   response of lpd command
638
639sub _lpdCommand
640{
641
642        my $response;
643
644        my $self = shift;
645        my $cmd  = shift;
646        my $gans = shift;
647
648        $self->_logDebug(sprintf("Sending %s", $cmd));
649
650        # Send info
651        $self->{socket}->send($cmd);
652
653        if ($gans) {
654
655                # We wait for a response
656                eval {
657                        local $SIG{ALRM} = sub { die "timeout\n" };
658                        alarm 5;
659                        $self->{socket}->recv($response, 1024)
660                            or die "recv: $!\n";
661                        1;
662                };
663
664                alarm 0;
665
666                # did we get an error?
667                if ($@) {
668                        if ($@ =~ /timeout/) {
669                                $self->_logDebug("Timed out sending command");
670                                return undef;
671                        }
672                }
673
674                $self->_logDebug(sprintf("Got back :%s:", $response));
675
676                return $response;
677
678        }
679
680}          # _lpdCommand()
681
682# Method: _lpdInit
683#
684# Notify remote lpd server that we're going to print returning 1 on
685# okay, undef on fail.
686#
687# Parameters:
688#
689#   none
690#
691# Returns:
692#
693#   1 on success, undef on fail
694sub _lpdInit
695{
696        my $self = shift;
697
698        my $buf     = "";
699        my $retcode = 1;
700
701        $self->_logDebug("invoked ... ");
702
703        # Create and send ready
704        $buf = sprintf("%c%s\n", 2, $self->{printer}) || "";
705        $buf = $self->_lpdCommand($buf, 1);
706        $retcode = unpack("c", $buf || 1);
707
708        $self->_logDebug("Return code is $retcode");
709
710        # check return code
711        if (($retcode =~ /\d/) && ($retcode == 0)) {
712                $self->_logDebug(
713                                 sprintf("Printer %s on Server %s is okay",
714                                         $self->{printer}, $self->{server}));
715                return 1;
716        } else {
717                $self->_lpdFatal(
718                                 sprintf("Printer %s on Server %s not okay",
719                                         $self->{printer}, $self->{server}));
720                $self->_logDebug(sprintf("Printer said %s", $buf || "nothing"));
721
722                return undef;
723        }
724}          # _lpdInit()
725
726# Method: _lpdSend
727#
728# Sends the control file and data file
729#
730# Parameter(s):
731#
732#   cfile   - Real Control File
733#   dfile   - Real Data File
734#   p_cfile - Fake Control File
735#   p_dfile - Fake Data File
736#
737# Returns:
738#
739#   1 on success, undef on fail
740sub _lpdSend
741{
742        my $self    = shift;
743        my $cfile   = shift;
744        my $dfile   = shift;
745        my $p_cfile = shift;
746        my $p_dfile = shift;
747
748        $self->_logDebug("invoked ... ");
749
750        # build hash
751        my $lpdhash = {
752                        "3" => {
753                                 "name" => $p_dfile,
754                                 "real" => $dfile
755                        },
756                        "2" => {
757                                 "name" => $p_cfile,
758                                 "real" => $cfile
759                        },
760        };
761
762        # iterate through each keytype and process
763        foreach my $type (keys %{$lpdhash}) {
764
765                $self->_logDebug(
766                                 sprintf("TYPE:%d:FILE:%s:",
767                                         $type, $lpdhash->{$type}->{"name"},
768                                 ));
769
770                # Send msg to lpd
771                my $size = (stat $lpdhash->{$type}->{"real"})[7];
772                my $buf = sprintf(
773                        "%c%ld %s\n", $type,          # Xmit type
774                        $size,                        # size
775                        $lpdhash->{$type}->{"name"},  # name
776                );
777
778                $buf = $self->_lpdCommand($buf, 1);
779
780                # check bugger
781                unless ($buf) {
782                        carp "Couldn't send data: $!\n";
783                        return undef;
784                }
785
786                $self->_logDebug(
787                                 sprintf("FILE:%s:RESULT:%s",
788                                         $lpdhash->{$type}->{"name"}, $buf
789                                 ));
790
791                # open new file handle
792                my $fh = FileHandle->new($lpdhash->{$type}->{"real"});
793
794                unless ($fh) {
795                        $self->_lpdFatal(
796                                        sprintf("Could not open %s: %s\n",
797                                                $lpdhash->{$type}->{"real"}, $!,
798                                        ));
799                        return undef;
800                }
801
802                # set blocksize
803                my $blksize = (stat $fh)[11] || 16384;
804
805                # read from socket
806                while (my $len = sysread $fh, $buf, $blksize) {
807
808                        # did we get anything back?
809                        unless ($len) {
810                                next if ($! =~ /^Interrupted/);
811                                carp "Error while reading\n";
812                                return undef;
813                        }
814
815                        my $offset = 0;
816
817                        # write out buffer
818                        while ($len) {
819                                my $resp = syswrite($self->{socket},
820                                                    $buf, $len, $offset);
821                                next unless $resp;
822                                $len -= $resp;
823                                $offset += $resp;
824
825                        }
826                }
827
828                # Clean up
829                $fh->close();
830
831                # Confirm server response
832                $buf = $self->_lpdCommand(sprintf("%c", 0), 1);
833                $self->_logDebug(sprintf("Confirmation status: %s", $buf));
834        }
835
836        return 1;
837
838}          # _lpdSend()
839
840# ----------------------------------------------------------------------
841# Standard publically accessible method
842# ----------------------------------------------------------------------
843
844# Method: DESTROY
845#
846# called when module destroyed
847#
848sub DESTROY
849{
850
851        # Parameter(s)
852        my $self = shift;
853
854        # Just in case :)
855        $self->{socket}->shutdown(2) if ($self->{socket});
856
857}          # DESTROY
858
8591;
860
861=head1 TROUBLESHOOTING
862
863=head2 Stair Stepping Problem
864
865When printing text, if you have the infamous "stair-stepping" problem,
866try setting lineconvert to "YES".  This should, in most cases, rectify
867the problem.
868
869=head2 RFC-1179 Compliance Mode and Security Implications
870
871RFC 1179 specifies that any program connecting to a print service must
872use a source port between 721 and 731, which are I<reserved ports>,
873meaning you must have root (administrative) privileges to use them.
874I<This is a security risk which should be avoided if at all
875possible!>
876
877=head2 Using Net::Printer with CUPS
878
879Net::Printer does not natively speak to printers running CUPS (which
880uses the IPP protocol).  In order to provide support for legacy
881clients, CUPS provides the B<cups-lpd> mini-server which can be set up
882to run out of either B<inetd> or B<xinetd> depending on preference.
883You will need to set up this functionality in order to use
884Net::Printer with CUPS server.  Consult your system documentation as
885to how to do this.
886
887=head1 SEE ALSO
888
889L<cups-lpd|cups-lpd/8>, L<lp|lp/1>, L<lpr|lpr/1>, L<perl|perl/1>
890
891RFC 1179 L<http://www.ietf.org/rfc/rfc1179.txt?number=1179>
892
893=head1 AUTHOR
894
895Christopher M. Fuhrman C<< <cfuhrman at panix.com> >>
896
897=head1 REVISION INFORMATION
898
899  $Id: 9044ee617cffd95213cff21af410d8ea1dc3f1fd $
900
901=head1 COPYRIGHT & LICENSE
902
903Copyright (c) 2000-2005,2008,2011,2013 Christopher M. Fuhrman,
904All rights reserved.
905
906This program is free software licensed under the...
907
908	The BSD License
909
910The full text of the license can be found in the
911LICENSE file included with this module.
912
913=cut
914
915__END__
916