1#!@PERL@ 2 3# read the lpd.conf file, and set up values from it 4 5package LPRng; 6require 5.003; 7use Exporter (); 8 9 10@ISA = qw(Exporter); 11@EXPORT = qw( 12Set_Debug 13Setup_LPRng 14Get_printer_name 15FixStrVals 16Setup_pc_entry 17Real_printer 18MatchHost 19MakeMask 20Read_printcap_file 21CheckRecurse 22Read_pc_entry 23Dump_index 24Dump_pc 25Read_conf 26Dump_conf 27Fix_value 28trimall 29Get_remote_pr_host 30getconnection 31sendit 32sendbuffer 33sendfile 34); 35 36use strict; 37use FileHandle; 38use Sys::Hostname; 39use Socket; 40use English; 41 42 sub FixStrVals( $ \% ); 43 sub Setup_pc_entry( $ ); 44 sub Real_printer( $ ); 45 sub MatchHost( \@ $ ); 46 sub MakeMask( $ ); 47 sub Read_printcap_file( $ \% \% $ $ \@ ); 48 sub CheckRecurse( $ \% \% $ $ \@ ); 49 sub Read_pc_entry( $ ); 50 sub Dump_index( $ \% ); 51 sub Dump_pc( $ \% ); 52 sub Read_conf( $ \% ); 53 sub Dump_conf( $ \% ); 54 sub Fix_value( $ ); 55 sub trimall( $ ); 56 57my( 58$Debug, %Init_hash, %Pc_hash, %Pc_index, @Hostname, %Keyvals, 59); 60 61# permanent values 62# Debug level 63# 64# %Init_hash: lpd.conf file values 65# %Pc_hash: printcap entries 66# %Pc_index: printcap entry names 67# @Hostname: hostname information, used for 'oh' printcap information 68# 69 70# maximum depth of recursion for printcap file lookup 71my($Max_depth) = 10; 72 73sub trimall( $ ) 74{ 75 my($line) = @_; 76 $line ||= ""; 77 $line =~ s/^\s+//; 78 $line =~ s/\s+$//; 79 return( $line ); 80} 81 82# convert a printcap or config file value into 83# a corresponding string or integer value 84 85sub Fix_value( $ ) 86{ 87 my($value) = @_; 88 if( $value =~ /^=/ or $value =~ /^#/ ){ 89 $value = trimall( substr( $value, 1 ) ); 90 } elsif ( $value =~ /^\@/ ){ 91 $value = 0; 92 } else { 93 $value = 1; 94 } 95 return $value; 96} 97 98# sub Read_conf( $conf_file, \%conf_values ) 99# Read a configuration file 100# $conf_file = configuration file 101# $conf_values = hash to store values in 102# 103 104 105sub Dump_conf( $ \% ) 106{ 107 my($title, $hash) = @_; 108 my($key); 109 print "$title config\n"; 110 foreach $key (sort keys %$hash ){ 111 print " '$key'='". $hash->{$key} . "'\n"; 112 } 113} 114 115sub Read_conf( $ \% ) 116{ 117 my($conf_file,$conf_values) = @_; 118 my($file,$key,$value,$line); 119 120 # open the conf file 121 $file = new FileHandle; 122 if( not defined( $file->open("<$conf_file")) ){ 123 return "cannot open $conf_file - $!"; 124 } 125 while( defined( $line = <$file>) ){ 126 chomp $line; 127 next if not $line or $line =~ /^\s*#/; 128 ($key,$value) = ($line =~ /^\s*([\w-]*)(.*)/); 129 $value = trimall($value); 130 ($key = trimall($key)) =~ s/-/_/g; 131 print "key '$key'='$value'\n" if $Debug > 2; 132 $conf_values->{$key} = Fix_value( $value ); 133 print "set key '$key'='" . $conf_values->{$key} . "'\n" if $Debug > 2; 134 } 135 $file->close; 136 Dump_conf( "Read_conf", %$conf_values ) if $Debug > 1; 137 return ""; 138} 139 140# Dump_pc( $title, %Pc_hash ) 141# dump the printcap hash 142# 143 144sub Dump_pc( $ \% ) 145{ 146 my($title, $hash) = @_; 147 my($key, $name); 148 $name = (); 149 $name = \@{$hash->{'NAME'}}; 150 print "Dump_pc: $title pc '". join( "','",@$name) . "'\n"; 151 foreach $key (sort keys %$hash ){ 152 print " '$key'='". $hash->{$key} . "'\n"; 153 } 154} 155 156sub Dump_index( $ \% ) 157{ 158 my($title, $hash) = @_; 159 my($key); 160 print "Dump_index: $title index\n"; 161 foreach $key (sort keys %$hash ){ 162 print " '$key'='". $hash->{$key} . "'\n"; 163 } 164} 165 166# sub Read_pc_entry( $file ) 167# $file = filehandle 168# find and read a printcap entry 169# 170 171my($lastline); 172 173sub Read_pc_entry( $ ) 174{ 175 my($file) = @_; 176 my($hash,$state,$escape,$line,@lines,$len,$i,@names); 177 my($key,$value,$add_next); 178 $state = ""; 179 $hash = (); 180 $add_next = 0; 181 print "Read_pc_entry: starting\n" if $Debug > 1; 182 while( $lastline or defined( $lastline = <$file> ) ){ 183 $line = trimall( $lastline ); 184 print "line '$line'\n" if $Debug > 3; 185 if( not $line or $line =~ /^\s*#/ ){ 186 $lastline = ""; 187 next; 188 } 189 # beginning of next entry? 190 last if not $add_next and $line =~ /^\s*\w/ and $state ne ""; 191 # we get rid of escapes at the end of the line 192 $lastline = ""; 193 $add_next = 0; 194 ($line, $escape) = ($line =~ /^(.*?)(\\*)$/); 195 if( defined( $escape ) ){ 196 print "escape '$escape'\n" if $Debug > 3; 197 $len = length($escape); 198 if( $len % 2 ){ 199 $escape = substr($escape,0,$len-1); 200 $add_next = 1; 201 } 202 $line .= $escape; 203 } 204 last if( not $state and $line =~ /^\s*include\s/ ); 205 $state .= $line; 206 print "state '$state'\n" if $Debug > 3; 207 } 208 print "Read_pc_entry: final state '$state'\n" if $Debug > 2; 209 if( $state eq "" ){ 210 return undef; 211 } 212 @lines = split( /\s*:+/,$state); 213 if( $Debug > 3 ){ 214 print "Read_pc_entry: split values=\n"; 215 for( $i = 0 ; $i < @lines; ++$i ){ 216 print "[$i] '$lines[$i]'\n"; 217 } 218 } 219 @names = split( /\s*\|+/, shift(@lines)); 220 @names = map { trimall($_) } @names; 221 @{$hash->{'NAME'}} = @names; 222 foreach $line (@lines){ 223 ($key,$value) = ($line =~ /^\s*([\w-]*)(.*)/); 224 $value = trimall($value); 225 ($key = trimall($key)) =~ s/-/_/g; 226 print " key '$key'='$value'\n" if $Debug > 3; 227 $hash->{$key} = Fix_value( $value ); 228 print " set key '$key'='" . $hash->{$key} . "'\n" if $Debug > 3; 229 } 230 Dump_pc( "Read_pc_entry: final value", %$hash ) if $Debug > 1; 231 return $hash; 232} 233 234sub CheckRecurse( $ \% \% $ $ \@ ) 235{ 236 if( defined $lastline ){ 237 my($v,$file) = split( ' ', $lastline ); 238 if( $v eq 'include' ){ 239 $lastline = ""; 240 print "CheckRecurse: file '$file'\n" if $Debug>0; 241 my( $pc_file, $Pc_hash, $Pc_index, $server, $depth, $hostname ) = @_; 242 Read_printcap_file($file, %$Pc_hash, %$Pc_index, $server, $depth, @$hostname ); 243 } 244 } 245} 246 247# sub Read_printcap_file( 248# $pc_file - file name 249# %Pc_hash - hash to store printcap values in 250# %Pc_index - index of all printcap names 251# $server - if $server != 0 then a server, and use server printcap entries 252# $depth - recursion depth 253# @Hostname - hostname information 254# 255# read the printcap file and produce a 256# hash with pointers to hashes of printcap vars 257# 258# Algorithm: 259# open file 260# while (read a printcap entry){ 261# decode the printcap entry 262# if printcap values exist then 263# merge values 264# else 265# create printcap entry 266# endif 267# endwhile 268 269sub Read_printcap_file( $ \% \% $ $ \@ ) 270{ 271 my( $pc_file, $Pc_hash, $Pc_index, $server, $depth, $hostname ) = @_; 272 my($file,$file_name,$hash,$key,$value,$names,$first,$name); 273 my($i,@n,@Hostentry); 274 275 # open the conf file 276 $file = new FileHandle; 277 ++$depth; 278 print "Read_printcap_file: file '$pc_file', depth $depth\n" if $Debug>0; 279 if( $depth > $Max_depth ){ 280 return "nesting too deep for '$pc_file'"; 281 } 282 # get either file or filter 283 $file_name = trimall($pc_file); 284 if( ($file_name =~ s/^\|//) ){ 285 $file_name = $file_name . '|'; 286 } else { 287 $file_name = '<' . $file_name; 288 } 289 $file_name = FixStrVals( $file_name, %Keyvals ); 290 print "Read_printcap_file: opening '$file_name'\n" if $Debug>0; 291 if( not defined( $file->open($file_name)) ){ 292 return "cannot open '" . $file_name . "' - $!"; 293 } 294 for(; defined( $hash = Read_pc_entry($file) ); 295 CheckRecurse($pc_file, %$Pc_hash, %$Pc_index, $server, $depth, @$hostname ) ){ 296 Dump_pc( "Read_printcap_file: checking", %$hash ) if $Debug > 1; 297 if( $hash->{'server'} and not $server ){ 298 print "Read_printcap_file: " . 299 "server=(pc '$hash->{server}', need '$server')\n" 300 if $Debug>1; 301 next; 302 } 303 if( $hash->{'oh'} and not MatchHost( @$hostname, $hash->{'oh'} ) ){ 304 print "Read_printcap_file: " . 305 "oh '$hash->{oh}' not matched\n" if $Debug>1; 306 next; 307 } 308 $names = $hash->{'NAME'}; 309 $first = $names->[0]; 310 # find out if we need to add or merge printcap 311 # entries 312 my(%k) = (); 313 for( $i = 1; $i < @$names; ++$i ){ 314 $name = $names->[$i]; 315 $k{$name} = $name; 316 } 317 $value = $Pc_hash->{$first}->{'NAME'}; 318 if( defined @$value ){ 319 for( $i = 1; $i < @$value; ++$i ){ 320 $name = $value->[$i]; 321 $k{$name} = $name; 322 } 323 } 324 @n = ( $first, sort keys %k ); 325 @{$Pc_hash->{$first}->{'NAME'}} = @n; 326 foreach $key (keys %$hash){ 327 $value = $hash->{$key}; 328 if( $key ne 'NAME' ){ 329 $Pc_hash->{$first}->{$key} = $value; 330 } 331 } 332 foreach $name (@$names){ 333 $Pc_index->{$name} = $first; 334 } 335 if( not $Pc_index->{'FIRST'} ){ 336 $Pc_index->{'FIRST'} = $first; 337 } 338 if( $Debug > 1 ){ 339 Dump_index( "Read_printcap_file: after adding '$first'", %$Pc_index ); 340 foreach $name (sort keys %$Pc_hash){ 341 Dump_pc( "Read_printcap_file: after adding '$first'", %{$Pc_hash->{$name}} ); 342 } 343 } 344 } 345 if( $Debug > 0 ){ 346 Dump_index( "Read_printcap_file: after '$pc_file'", %$Pc_index ); 347 foreach $name (sort keys %$Pc_hash){ 348 Dump_pc( "Read_printcap_file: after '$pc_file'", %{$Pc_hash->{$name}} ); 349 } 350 } 351} 352 353sub MakeMask( $ ) 354{ 355 my($mask) = @_; 356 my($mnum,$v,@v,$x,$i,$j,@d); 357 if( defined $mask ){ 358 if( $mask =~ /\./ ){ 359 $mnum = inet_aton( $mask ); 360 } else { 361 if( $mask < 32 and $mask >= 0 ){ 362 $v = pack( "N", (1 << $mask ) - 1); 363 @v = reverse split( '', unpack( "B32", $v )); 364 for( $i = 0; $i < 4; ++$i ){ 365 $x = 0; 366 for( $j = 0; $j < 8; ++$j ){ 367 $x *= 2; 368 $x += $v[$i*8+$j]; 369 } 370 $d[$i] = $x; 371 } 372 $i = join(".", @d ); 373 #print "MakeMask: generated $mask = '$i'\n" if $Debug > 5; 374 $mnum = inet_aton( $i ); 375 } else { 376 $mnum = inet_aton( "255.255.255.255" ); 377 } 378 } 379 } else { 380 $mnum = inet_aton( "255.255.255.255" ); 381 } 382 print "MakeMask: $mask = '" . inet_ntoa( $mnum ) . "'\n" if $Debug > 5; 383 return $mnum; 384} 385 386# sub MatchHost( @Hostinfo, $matches ) 387# @Hostinfo is value returned by gethostbyname() 388# ($name, $alises, $addrtype, $length, @addrs ) 389# 0 1 2 3 4 390# matches has format: ((glob|ip/mask),)* 391 392sub MatchHost( \@ $ ) 393{ 394 my($hostinfo,$matches) = @_; 395 my(@list,$value,$addr,$mask,$anum,$mnum,$null,@v,$i,$ipaddr); 396 @list = split( '[,\s]', $matches ); 397 foreach $value ( @list ){ 398 print "Matchhost: '$value' to $hostinfo->[0]\n" if $Debug>2; 399 if( $value =~ /^\d/ ){ 400 # we have addr/mask 401 $null = inet_aton("0.0.0.0"); 402 ($addr,$mask) = split( '/',$value ); 403 $anum = inet_aton( $addr ); 404 $mnum = MakeMask( $mask ); 405 print "Matchhost: addr '" . inet_ntoa($anum) . "', mask '" 406 . inet_ntoa($mnum) . "'\n" if $Debug>3; 407 for($i = 4; $i < @$hostinfo; ++$i ){ 408 $ipaddr = $hostinfo->[$i]; 409 print "Matchhost: ipaddr '" . inet_ntoa($ipaddr) . "'\n" if $Debug>3; 410 $ipaddr = ($ipaddr ^ $anum) & $mnum; 411 print "Matchhost: result '" . inet_ntoa($ipaddr) . "'\n" if $Debug>3; 412 if( $ipaddr eq $null ){ 413 print "Matchhost: found '".inet_ntoa( $hostinfo->[$i])."'\n" if $Debug>3; 414 return 1; 415 } 416 } 417 } else { 418 # we have glob str 419 $value =~ s/\./\\./g; 420 $value =~ s/\*/.*/g; 421 print "Matchhost: new value '$value'\n" if $Debug>3; 422 if( $hostinfo->[0] =~ /$value/ ){ 423 print "Matchhost: found\n" if $Debug>3; 424 return 1; 425 } 426 } 427 } 428 return 0; 429} 430 431# sub Setup_pc_entry( $name ) 432# 1. look up the pc entry 433# 2. set the initial values to configuration defaults 434# 3. combine the pc values 435# returns: hash of combined values 436 437sub Real_printer( $ ) 438{ 439 my($name) = @_; 440 $name = $Pc_index{$name}; 441 return $name; 442} 443 444 445sub Setup_pc_entry( $ ) 446{ 447 my($name ) = @_; 448 my($real, %hash, $value, $key, $tc_val, @tc_list, %tc_hash ); 449 $real = Real_printer( $name ); 450 if( not $real ){ 451 return undef; 452 } 453 print "Setup_pc_entry: pr '$name', using real '$real'\n" if $Debug > 2; 454 %hash = %Init_hash; 455 Dump_pc( "Setup_pc_entry: after init", %hash ) if $Debug > 3; 456 457 $value = $Pc_hash{$real}; 458 Dump_pc( "Setup_pc_entry: pc value for '$real'", %$value ) if $Debug > 3; 459 foreach $key (keys %$value){ 460 print "Setup_pc_entry: setting '$key'='$value->{$key}'\n" if $Debug > 5; 461 $hash{$key} = $value->{$key}; 462 } 463 Dump_pc( "Setup_pc_entry: pr '$name', real '$real'; result", %hash ) if $Debug > 1; 464 # now we have to resolve the TC values 465 # 466 $tc_val = $hash{'tc'}; 467 $hash{'tc'} = ""; 468 if( $tc_val ){ 469 push @tc_list, split( /[\s,;:]/, $tc_val ); 470 } 471 while( @tc_list ){ 472 $tc_val = shift @tc_list; 473 print "Setup_pc_entry: tc '$tc_val'" if $Debug > 5; 474 $real = Real_printer( $tc_val ); 475 if( $tc_hash{$tc_val} ){ 476 print STDERR "Setup_pc_entry: Printer '$name' has tc with multiple uses of '$tc_val', really '$real'"; 477 return undef; 478 } 479 $tc_hash{$tc_val} = 1; 480 if( not defined $real ){ 481 print STDERR "Setup_pc_entry: Printer '$name' missing tc entry for '$tc_val', really '$real'"; 482 return undef; 483 } 484 $value = $Pc_hash{$real}; 485 foreach $key (keys %$value){ 486 print "Setup_pc_entry: setting '$key'='$value->{$key}'\n" if $Debug > 5; 487 if( $key ne 'NAME' ){ 488 $hash{$key} = $value->{$key}; 489 } 490 } 491 Dump_pc( "Setup_pc_entry: pr '$name', after tc '$real'", %hash ) if $Debug > 1; 492 $tc_val = $hash{'tc'}; 493 $hash{'tc'} = ""; 494 if( $tc_val ){ 495 push @tc_list, split( '\s,;:', $tc_val ); 496 } 497 } 498 return \%hash; 499} 500 501sub FixStrVals( $ \% ) 502{ 503 my($str, $hash ) = @_; 504 my( $key, $val ); 505 while( $str =~ /%(.)/ ){ 506 $key = $1; 507 print "FixStrVals: fixing '$key' in '$str'\n" if $Debug > 5; 508 $val = $hash->{$key}; 509 $val = "" if( not defined $val ); 510 $str =~ s/%$key/$val/g; 511 } 512 print "FixStrVals: final '$str'\n" if $Debug > 5; 513 return $str; 514} 515 516sub Get_printer_name( \% ) 517{ 518 my($Args) = shift; 519 my($printer); 520 $printer ||= $Args->{'P'}; 521 $printer ||= $Pc_index{'FIRST'}; 522 $printer ||= $Init_hash{'default_printer'}; 523 print "Get_printer_name: '$printer'\n" if $Debug>0; 524 return( $printer ); 525} 526 527 528sub Setup_LPRng( \% ) 529{ 530 my($Args) = @_; 531 my($pc_path,$file,$key); 532 # get the command line options 533 # get the hostname information 534 $key = hostname(); 535 @Hostname = gethostbyname( $key ); 536 # set up the key values 537 $Keyvals{'H'} = $Hostname[0]; 538 #Read_conf("/var/tmp/LPD/lpd.conf", %Init_hash); 539 Read_conf("/etc/lpd.conf", %Init_hash); 540 $pc_path = "/etc/printcap"; 541 if( $Init_hash{'printcap_path'} ){ 542 $pc_path = $Init_hash{'printcap_path'}; 543 } 544 foreach $file ( split( '[:,]', $pc_path ) ){ 545 $file = FixStrVals( $file, %Keyvals ); 546 Read_printcap_file($file, %Pc_hash, %Pc_index, 1, 0, @Hostname); 547 } 548} 549 550sub Set_Debug( $ ) 551{ 552 my($v) = $Debug; 553 $Debug = $_[0]; 554} 555 556# sub Get_remote_pr_host( $Printer, $Pc_value ); 557# returns: ($pr, $remote, $port) 558# $pr = remote printer, $remote = remote host, $port = port to use 559# 560# if Pc_value 561# we use the lp value 562# if no lp value, we use rp, rm value 563# else 564# we use the lp value 565# if the lp value then we split it up 566# 567 568sub Get_remote_pr_host( $ $) 569{ 570 my( $prname, $pc ) = @_; 571 my( $lp, $pr, $remote, $port ); 572 573 if( defined $pc ){ 574 $lp = $pc->{'lp'}; 575 } else { 576 $lp = $prname; 577 } 578 # we now check to see if we have pr@host 579 if( defined $lp ){ 580 if( $lp =~ /\@/ ){ 581 ($pr, $remote ) = split( '@', $lp ); 582 } else { 583 $pr = $prname 584 } 585 } elsif( defined $pc ){ 586 $pr = $pc->{'rp'}; 587 $remote = $pc->{'rm'}; 588 } 589 if( not $pr ){ 590 $pr = $prname; 591 } 592 $pr = $prname if( $pr =~ /%P/ ); 593 594 if( not $remote ){ 595 if( defined $pc ){ 596 $remote = "localhost" if $pc->{'force_localhost'}; 597 } else { 598 $remote = "localhost" if $Init_hash{'force_localhost'}; 599 } 600 } 601 if( not $remote ){ 602 if( defined $pc ){ 603 $remote = $pc->{'default_remote_host'}; 604 } else { 605 $remote = $Init_hash{'default_remote_host'}; 606 } 607 } 608 if( not $remote ){ 609 $remote = "localhost"; 610 } 611 612 ($remote, $port ) = split( '%', $remote ); 613 614 if( not $port ){ 615 if( defined $pc ){ 616 $port = $pc->{'lpd_port'}; 617 } else { 618 $port = $Init_hash{'lpd_port'}; 619 } 620 } 621 if( not $port ){ 622 $port = "printer"; 623 } 624 if( $port + 0 == 0 ){ 625 $port = getservbyname( $port, "tcp" ); 626 } 627 return( $pr, $remote, $port ); 628} 629 630sub getconnection ($ $) 631{ 632 my ($remote,$port) = @_; 633 my ($iaddr,$paddr,$proto); 634 my ($low_port, $high_port, $ports, $t, $euid ) if $Debug>0; 635 $ports = $Init_hash{'originate_port'}; 636 if( $ports ){ 637 ($low_port, $high_port) = split( /[\s,;]+/, $ports ); 638 print "low_port '$low_port', high_port '$high_port'\n" if $Debug>0; 639 } 640 $low_port += 0; 641 $high_port += 0; 642 print "num low_port '$low_port', high_port '$high_port'\n" if $Debug>0; 643 644 $iaddr = inet_aton($remote) or die "no host: $remote"; 645 $paddr = sockaddr_in($port,$iaddr); 646 $proto = getprotobyname('tcp'); 647 print "remote='$remote', port ='$port', iaddr='" . inet_ntoa($iaddr). "'\n" if $Debug; 648 $t = 0; 649 if( $low_port < $high_port and ($EUID == 0 or $UID == 0 ) ){ 650 $euid = $EUID; 651 $EUID = 0; 652 while( $t == 0 and $low_port < $high_port ){ 653 close(SOCK); 654 socket(SOCK,PF_INET,SOCK_STREAM,$proto) or die "socket: $!"; 655 setsockopt( SOCK, SOL_SOCKET, SO_REUSEADDR, 1 ) 656 or warn "setsockopt failed - $!\n"; 657 if( bind( SOCK, sockaddr_in( $low_port, INADDR_ANY ) ) ){ 658 $t = 1; 659 } else { 660 print "bind to $low_port failed - $!\n"; 661 ++$low_port; 662 } 663 } 664 $EUID = $euid; 665 } 666 if( $t == 0 ){ 667 close(SOCK); 668 socket(SOCK,PF_INET,SOCK_STREAM,$proto) or die "socket: $!"; 669 setsockopt( SOCK, SOL_SOCKET, SO_REUSEADDR, 1 ) or warn "setsockopt failed - $!\n"; 670 } 671 connect(SOCK,$paddr) or die "connect: $!"; 672 print "connection made\n" if $Debug; 673 # unbufferred IO 674 select(SOCK); $| = 1; select(STDOUT); 675 return \*SOCK; 676} 677 678sub sendit( $ $ ) 679{ 680 my( $SOCK, $line ) = @_; 681 my( $count ); 682 print "sendit sending '$line'\n" if $Debug; 683 print $SOCK $line or die "print to socket failed - $!\n"; 684 $line = ""; 685 $count = read $SOCK, $line, 1; 686 print "sendit read $count\n" if $Debug; 687 if( !defined($count) ){ 688 die "read error on socket - $!\n"; 689 } 690 if( !$count ){ 691 die "EOF on socket\n"; 692 } 693 $count = unpack( "C", $line ); 694 if( $count ){ 695 print "error: "; 696 while( defined ( $line = <$SOCK> ) ){ 697 print $line; 698 } 699 print "\n"; 700 exit 1; 701 } 702 print "sendit no error\n" if $Debug; 703} 704 705sub sendbuffer( $ $ $ ) 706{ 707 my($SOCK, $line, $buffer ) = @_; 708 my( $count ); 709 print "sendbuffer line '$line'\n" if $Debug; 710 sendit( $SOCK, $line ); 711 print "sendbuffer buffer '$buffer'\n" if $Debug; 712 print $SOCK $buffer; 713 print $SOCK "\000"; 714 $line = ""; 715 $count = read $SOCK, $line, 1; 716 print "sendbuffer read $count\n" if $Debug; 717 if( !defined($count) ){ 718 die "read error on socket - $!\n"; 719 } 720 if( !$count ){ 721 die "EOF on socket\n"; 722 } 723 $count = unpack( "C", $line ); 724 if( $count ){ 725 print "error code: $count\n"; 726 while( defined($line = <$SOCK>) ){ 727 print $line; 728 } 729 print "\n"; 730 exit 1; 731 } 732 print "sendbuffer no error\n" if $Debug; 733} 734 735sub sendfile ( $ $ $ ) 736{ 737 my( $SOCK, $name, $filename ) = @_; 738 my( $size, $line, $count ); 739 open( FILE, "<$filename") or die "cannot open file '$filename'\n"; 740 $size = -s FILE; 741 print "sendfile: '$name' size $size\n" if $Debug; 742 sendit( $SOCK, "\003$size $name\n" ); 743 print "sendfile: sending file\n" if $Debug; 744 while( $size = read FILE, $line, 1024 ){ 745 print "read $size bytes\n" if $Debug; 746 print $SOCK $line; 747 } 748 print "sendfile: finished\n" if $Debug; 749 if( !defined( $size ) ){ 750 die "bad read from '$name' - $!\n"; 751 } 752 print $SOCK "\000"; 753 $line = ""; 754 $count = read $SOCK, $line, 1; 755 print "sendfile: read $count\n" if $Debug; 756 if( !defined($count) ){ 757 die "read error on socket - $!\n"; 758 } 759 if( !$count ){ 760 die "EOF on socket\n"; 761 } 762 $count = unpack( "C", $line ); 763 if( $count ){ 764 print "error code: $count\n"; 765 while( defined($line = <$SOCK>) ){ 766 print $line; 767 } 768 print "\n"; 769 exit 1; 770 } 771 print "sendfile: no error\n" if $Debug; 772} 773 774$Debug = 0; 7751; 776