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