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