#!/bin/sh -- # A comment mentioning perl, to prevent perl from looping. Indented to work with bash. eval 'exec perl -S $0 ${1+"$@"}' if 0; ############################################################################ # This script "defang" will listen on a port and transfer HTTP connections to # a real HTTP proxy or make the connection directly. # Any animated gif's it sees going by it will replace with a red "A" # on a transparent background. See also "oneloop" mode below. # Many other features have been added, ad filtering, etc. # # Run "perl defang -help" for more info. # # A good place to check this script out on is "http://www.cnn.com". ############################################################################ $Program = 'defang'; $Program0 = $0; $Version = '0.4'; $Copyright = 'Copyright (c) 1997-2001 by Karl J. Runge '; # Config: (note: most all of these can be set via cmd line args) ##### Config File: ##### $Config_File = ''; $Config_File = "$0.conf"; ##### Access: ##### $Hosts_Allow = ''; $Hosts_Deny = ''; $Url_Deny = ''; $Allow_Cache_File = "\$Flag_File_Prefix.access"; $Allow_Cache_Dict_File = "\$Flag_File_Prefix.access.dict"; $Denied_Log_File = "$Allow_Cache_File.denied"; $User = $ENV{USER}; ##### Signal Files: ##### $Flag_File_Prefix = "/tmp/defang"; # Path prefix to make "mode" flag $Flag_File_Prefix .= ".$User" if $User; # files. Simple hack to change # the "edit mode" of the filter. $Log = 'defang.log'; # Default log file. ##### Gif Editing modes: ##### $Default_Edit_Mode = "replace"; # or "oneloop" $Flags{'replace'} = 1; # "replace" means replace gif with red "A" $Flags{'oneloop'} = 1; # "oneloop" means edit the NETSCAPE2.0 # extension in the GIF, and # make it only do 1 loop of the # animation. (working ok?) # Any others (e.g. just show 1st frame)? @Flags = ('replace', 'oneloop'); # place a list here for some efficiency # put most common one first. # todo: automatically put default first. $Check_Any_Gif89_Ext = 0; # Look for gif extension: !ù^D.(time1)(time2) # time's are delays. $Check_Multi_Gif89_Ext = 1; # Look for multiple gif extensions: !ù^D.*!ù^D $No_Fake_Gifs = 0; # Never return back a fake gif or jpg, just send # HTTP 202. ##### Network settings: ##### $Proxy_host = 'haystack'; # The proxy I refer requests to. $Proxy_host = 'NONE'; # set to '', or 'NONE', or 'none' to try the # direct connection. (probably not so robust..) $Proxy_port = '8080'; # The proxy port, ignored for 'NONE' $My_Listen_Port = '8082'; # The port I listen on. Point browser's # HTTP proxy to this port on the machine # you run this script on. Leave FTP, GOPHER, # alone (IMHO) $Use_Dns_Cache = 1; # Save DNS gethostbyname lookups. $Dns_Purge_Time = 3600 * 3; $Last_Dns_Purge = time; $Do_Shutdown = 0; # close "half" of the connection when done. #### Transfer blocksizes: ##### # May want to "tune" these for optimum transfers depending on # the speed of your connection .... $First_Block_Size = 16384; # First block of gif is read with this # size. Animated gif string(s) is checked for # ONLY in this block. #$Buf_Size = 16384; $Buf_Size = 8192; #$Buf_Size = 4096; #$Buf_Size = 2048; # Remainder of gif (or entire non-gif URL) # is read and sent in blocks of this size. # 256 is used for modem, maybe higher on # fast connection. (maybe 1024 on modem?) # remember netscape makes 4 connections at once #### Misc: ##### $Unix = 1; # Be lazy and use system() to std Unix utils. $Windows = 0; # No pain, no gain if $Windows == 1; $IS_SYSV = 0; # Set to 1 on System V Unix (e.g. Solaris) # Set to 0 on Linux, *BSD*, SunOS 4.x # Um, Windows??? (0 seems to work) $Extra_Fork = 0; # For HTTP no real need to do an extra # fork for the two-way data flow. # Set to 1 to do that extra fork anyway. # (Unix only) $Single_Fork = 0; # Set to 1 for no double fork to avoid zombies. $Pre_Fork = 20; # fork this many simultaneous children # (set to zero to skip) $Jobs_Per_Fork = 20; # and each child does this many connections. # (there will be rediscover of allow/deny info) #$Pre_Fork = 1; # for debugging a single process. #$Jobs_Per_Fork = 100; $Debug = 0; # Set to '1' for lots of reporting to STDERR # and additional stuff to log file. $Argv_Url = 1; # Set argv 0 to url name. ###$Header_Insert = ''; # Something to insert in the return header. # not implemented $Http_Version = ''; # Will rewrite the protocol version number # to this value. $Http_Version0 = "HTTP/1.0"; # used for errors going back to client. $Do_Keepalive = 0; # try to handle Proxy-Connection: Keep-Alive #### No Config below here ... ##### ############################################################################# # Todo: # Check this script wrt SSL secure "CONNECT" method. # Need more heuristics to detect animated gifs. Some get thru still. ############################################################################# $Usage = <<"END"; defang: Interpose upon HTTP connections and filter animated gifs that come in. Can either replace the Animated Gif with a simple static gif, or can make the animated GIF do just one loop. It can also screen connections based on remote hostname (allow and deny) and URL pathname (deny only). defang evidently stands for: DElete Friggin ANimated Gifs :-) Configuration: Edit the top portion of the script. (or see cmd line options below) Setup your browser (e.g. Netscape) to use the machine and port you run this script on to be your browsers HTTP PROXY. Best to leave the FTP and GOPHER PROXYs alone. (although they might work too...). Options: -h, -help This help. -on Turn on (default mode: $Default_Edit_Mode) -r Turn on GIF replacement mode. (red A) -once, -1 Turn on GIF One Loop mode. -off Turn off GIF filtering. -all Turn off ACCESS filtering. -noall Turn on ACCESS filtering. Using any of the above options will not cause the server to be started, unless run via, say: defang -once start Yow! Here are cmd line options for everything else: -c Use as config file instead of $Config_File. -F Use as the flag file prefix instead of $Flag_File_Prefix. -f Set initial Gif read block size to "N" (only this portion is checked for animation signature) Default: $First_Block_Size -b Set the overall transfer read block size to "N". Default: $Buf_Size -v Set to, say "HTTP/1.0" to force overwrite of the Http version in the GET line. Could be dangerous, really should be per-site. -nfg Never return a fake gif or jpg to client. Only return HTTP 202. -d Turn on debugging mode. -l Use as debugging logfile instead of "$Log" Implies -d. -u The machine is Unix (ahhh) Default. -w The machine is Windows (gulp!) -sysv The machine is SVR4 wrt sockets. (e.g. Solaris) -p Listen on port , Default: $My_Listen_Port -proxy_host Use as proxy to refer requests to. Specify "NONE" for no proxy. Default: $Proxy_host -proxy_port The port of the proxy to connect to. Ignored if host is "NONE". Default: $Proxy_port Or use -proxy_host host:port -ef Do an extra fork() call on Unix for the two-way data flow. Not needed for most HTTP. (But may be for secure/CONNECT method). -sf Do a single fork to not protect against zombie creation. -ka Use Connection: Keep-Alive protocol. -pf Prefork children. Use 0 to skip prefork mechanism. -jpf Under prefork mode, each child handles this many connections. -allow Allow hosts matching names or ips in patterns E.g. -allow *.nick.com,*.disney.com -deny Deny hosts matching patterns E.g. -deny *.xxx.com,*.lycos.com -url_deny Deny urls with pathnames matching the patterns in . Spaces may be used instead of commas in pattern lists. Use // to use a perl regex w/o commas or spaces. Params to set in Config_File: Hosts_Allow (space/comma sep and additive) Hosts_Deny (space/comma sep and additive) Url_Deny (space/comma sep and additive) Url_Redir (additive) Url_Rewrite (additive) Flag_File_Prefix (filename) Proxy_host (host or host:port) Proxy_port (port #) My_Listen_Port (port #) First_Block_Size (number) Buf_Size (number) Pre_Fork (number) Jobs_Per_Fork (number) Http_Version (e.g. HTTP/1.1) Check_Multi_Gif89_Ext (0 or 1) Check_Any_Gif89_Ext (0 or 1) No_Fake_Gifs (0 or 1) Do_Shutdown (0 or 1) Do_Keepalive (0 or 1) Unix (0 or 1) Windows (0 or 1) IS_SYSV (0 or 1) Extra_Fork (0 or 1) Single_Fork (0 or 1) Debug (0 or 1) Argv_Url (0 or 1) ENV hacks: \$ENV{DENIED_FILE} for internal Denied_Log_File Notes: The Config_File is reread if it is modified. Send signals to program named ${Program}_master USR1 Restart_Children USR2, HUP Restart_All TERM, INT Kill everything and exit. Bugs: Loop once does not seem to work any more. Allow/Deny host lists take 2 connections to get back to server. Cannot turn off and on Host and Url access easily. Does not fork on Windows. 1 connection at a time. $Copyright END @Initial_Args = @ARGV; setpgrp(0, 0); # check for and read config file for ($i=0; $i < @ARGV; $i++) { if ( $ARGV[$i] eq '-c' ) { $Config_File = $ARGV[$i+1]; } elsif ( $ARGV[$i] =~ /^-h/ ) { &help(); exit 0; } } @Special_Sigs = qw(USR1 USR2 HUP TERM INT); &Read_Config_File('force'); # cmd line arg processor: $action = ''; $start = 0; # Process args LOOP: while (@ARGV) { $_ = shift @ARGV; CASE: { /^-h/ && ( (&help()), exit 0, last CASE); /^-d$/ && ( $Debug++, last CASE); /^-l$/ && ( $Debug++, $Log = shift, last CASE); /^-on$/ && ( $action = "on", last CASE); /^-off$/ && ( $action = "off", last CASE); /^-all$/ && ( $action = "allow", last CASE); /^-noall$/ && ( $action = "noallow", last CASE); /^s/ && ( $start = 1, last CASE); /^-r$/ && ( $action = "replace", $Default_Edit_Mode = "replace", last CASE); /^-once$|^-1$/ && ( $action = "oneloop", $Default_Edit_Mode = "oneloop", last CASE); /^-f$/ && ( $First_Block_Size = shift, last CASE); /^-nfg$/ && ( $No_Fake_Gifs = 1, last CASE); /^-c$/ && ( $Config_File = shift, last CASE); /^-F$/ && ( $Flag_File_Prefix = shift, last CASE); /^-b$/ && ( $Buf_Size = shift, last CASE); /^-v$/ && ( $Http_Version = shift, last CASE); /^-ka$/ && ( $Do_Keepalive = 1, last CASE); /^-ef$/ && ( $Extra_Fork = 1, last CASE); /^-sf$/ && ( $Single_Fork = 1, last CASE); /^-pf$/ && ( $Pre_Fork = shift, last CASE); /^-jpf$/ && ( $Jobs_Per_Fork = shift, last CASE); /^-u$/ && ( $Unix = 1, $Windows = 0, last CASE); /^-w$/ && ( $Unix = 0, $Windows = 1, last CASE); /^-p$/ && ( $My_Listen_Port = shift, last CASE); /^-proxy_host$/ && ( $Proxy_host = shift, last CASE); /^-proxy_port$/ && ( $Proxy_port = shift, last CASE); /^-allow$/ && ( $Hosts_Allow .= ' ' . shift, last CASE); /^-deny$/ && ( $Hosts_Deny .= ' ' . shift, last CASE); /^-url_deny$/ && ( $Url_Deny .= ' ' . shift, last CASE); /^-url_redir$/ && ( $Url_Redir .= "\n" . shift, last CASE); /^-url_rewrite$/ && ( $Url_Rewrite .= "\n" . shift, last CASE); /^-sysv$/ && ( $IS_SYSV = 1, last CASE); /^--$/ && (last LOOP); # -- means end of switches /^-(-.*)$/ && (unshift(@ARGV, $1), last CASE); if ( /^-(..+)$/ ) { # split bundled switches: local($y, $x) = ($1, ''); foreach $x (reverse(split(//, $y))) { unshift(@ARGV,"-$x") }; last CASE; } /^-/ && ( (print "$_ is not an option, Bye!\n"), exit 0, last CASE); unshift(@ARGV,$_); # put back if done with flags last LOOP; } } &Clear_Caches(); &Setup_Access(); if ( $Windows ) { $Flag_File_Prefix = "C:\\defangx"; } else { ### $Flag_File_Prefix .= "$$"; } if ( $Proxy_host =~ /^(.*):(\d+)$/ ) { $Proxy_host = $1; $Proxy_port = $2; } if ( $Proxy_host eq '' || $Proxy_host =~ /^none$/i ) { $Proxy_port = $Proxy_host; } # Empty cmd line, means start the server. if ( $action eq '' ) { $start = 1; } # Filenames for switching flag file on and off, etc. Remove them all. # Needs perlglob on windows? unlink <$Flag_File_Prefix.*> if $start; # Handle the flag file cases: print STDERR "\n"; $action = 'on' if $action eq ''; foreach $action (split(/,/, $action)) { if ( $action eq 'replace' ) { # REPLACE MODE &create("$Flag_File_Prefix.replace"); print STDERR "Mode is: replace\n"; system("ls -l $Flag_File_Prefix.*") if $Unix; exit 0 unless $start; } elsif ( $action eq 'oneloop' ) { # ONELOOP MODE &create("$Flag_File_Prefix.oneloop"); print STDERR "Mode is: oneloop\n"; system("ls -l $Flag_File_Prefix.*") if $Unix; exit 0 unless $start; } elsif ( $action eq 'off' ) { # NO GIF FILTERING unlink <$Flag_File_Prefix.replace>; unlink <$Flag_File_Prefix.oneloop>; print STDERR "Mode is: turned off gif filtering\n"; system("ls -l $Flag_File_Prefix.*") if $Unix; exit 0 unless $start; } elsif ( $action eq 'allow' ) { # NO ACCESS FILTERING &create("$Flag_File_Prefix.allow_all"); print STDERR "Set allow_all\n"; system("ls -l $Flag_File_Prefix.*") if $Unix; exit 0 unless $start; } elsif ( $action eq 'noallow' ) { # ACCESS FILTERING unlink <$Flag_File_Prefix.allow_all>; print STDERR "Turned off allow_all\n"; system("ls -l $Flag_File_Prefix.*") if $Unix; exit 0 unless $start; } if ( $action eq '' || $action eq 'on' ) { # DEFAULT STARTUP MODE unlink <$Flag_File_Prefix.replace>; unlink <$Flag_File_Prefix.oneloop>; &create("$Flag_File_Prefix.$Default_Edit_Mode"); print STDERR "Mode is: $Default_Edit_Mode\n"; if ( $action eq 'on' && ! $start ) { exit 0; } } } system("ls -l $Flag_File_Prefix.*") if $Unix; $My_Pid = $$; @Params = ( Flag_File_Prefix, Default_Edit_Mode, Proxy_host, Proxy_port, My_Listen_Port, My_Pid, First_Block_Size, Check_Multi_Gif89_Ext, Check_Any_Gif89_Ext, No_Fake_Gifs, Buf_Size, Unix, Windows, IS_SYSV, Http_Version, Http_Version0, Hosts_Allow, Hosts_Deny, Url_Deny, Url_Redir, Url_Rewrite, Config_File, Allow_Cache_File, Denied_Log_File, Do_Shutdown, Do_Keepalive, Extra_Fork, Single_Fork, Pre_Fork, Jobs_Per_Fork, Use_Dns_Cache, Argv_Url, Log, Debug ); eval "\$Allow_Cache_File = \"$Allow_Cache_File\""; eval "\$Allow_Cache_Dict_File = \"$Allow_Cache_Dict_File\""; eval "\$Denied_Log_File = \"$Denied_Log_File\""; if ( $ENV{'DENIED_FILE'} ne '' ) { $Denied_Log_File = $ENV{'DENIED_FILE'}; } # Show user the parameter settings. sub print_parameters { print STDERR "\nParameters:\n"; my ($var, $x); foreach $var (@Params) { eval "\$x = \$$var"; print STDERR " $var: $x\n"; } print STDERR "\n"; } &print_parameters; # Use ksockets socket macros. &Use_Ksockets(); if ( $Debug ) { open(LOG, ">>$Log") || die "$!"; # Open log file if debugging. system("ls -l $Log"); select(LOG); $| = 1; select(STDOUT); } select(STDERR); $| = 1; select(STDOUT); $| = 1; # Set a string to the gif to be substituted. &Subst_Gif(); # Listen with a max of 64 outstanding connections. $Server = &Server($My_Listen_Port, 64); # Check if all is OK wrt server. die "$Server" if &SocketError($Server); print STDERR "Listening on port $My_Listen_Port\n"; system("sh -c 'sleep 1; netstat -an | grep $My_Listen_Port | grep LISTEN' &") if $Unix; sleep 2; sub Make_Child { my $pid; if ( $pid = fork ) { $0 = "${Program}_master"; $Kid_Count++; print STDERR "NEW_CHILD\[$Kid_Count\]: $pid\n"; $Kids{$pid} = 1; } else { foreach my $sig (@Special_Sigs) { $SIG{$sig} = 'DEFAULT'; } my ($n); if ( ! $Jobs_Per_Fork ) { $Jobs_Per_Fork = 10; } foreach $n (1..$Jobs_Per_Fork) { if ( $Argv_Url ) { $0 = "$Program\->waiting\[$Kid_Count=" . "$n/$Jobs_Per_Fork]..."; } ($Client) = &AcceptConnection($Server); $Conn = sprintf(" %-15s", "$n\[$Kid_Count/$$\]"); &Handle_Conn(); close $Client; } close $Server; exit 0; } } sub Make_Wakeup { my ($sleep) = @_; my $pid; if ( $pid = fork ) { $Kids{$pid} = 1; return $pid } else { foreach my $sig (@Special_Sigs) { $SIG{$sig} = 'DEFAULT'; } $0 = "${Program}_wakeup"; close $Server; $sleep = 60 unless $sleep; sleep $sleep; exit 0; } } sub Watch_Config_File { my $startup = 10; $0 = "$Program\->watch_config_file..."; if ( ! -f $Config_File ) { die "Watch_Config_File: $!"; } sleep $startup; my $mtime = -M $Config_File; while (1) { sleep 5; $newtime = -M $Config_File; if ( $newtime < $mtime ) { $mtime = $newtime; print STDERR "Watch_Config_File: sending " . "SIGUSR1 to $Parent, $newtime < $mtime\n"; kill USR1, $Parent; sleep $startup; } } exit 0; } sub Restart_Children { $SIG{'USR1'} = 'IGNORE'; my ($kid, $cnt); foreach $kid (sort(keys %Kids)) { $cnt = kill TERM, $kid; print STDERR "Restart_Children: kill $kid, TERM: $cnt\n"; $cnt = kill KILL, $kid unless $cnt; if ( $cnt ) { wait; delete $Kids{$kid}; } } # reread the config &Read_Config_File('force'); &print_parameters; # initialize the children: $Kid_Count = 0; foreach $cnt (1..$Pre_Fork) { &Make_Child(); } sleep 5; $SIG{'USR1'} = 'Restart_Children'; } sub Restart_All { $SIG{'HUP'} = 'IGNORE'; $SIG{'TERM'} = 'IGNORE'; $SIG{'INT'} = 'IGNORE'; my ($sig) = @_; my ($kid, $cnt); foreach $kid (sort(keys %Kids), $Watcher_Child) { $cnt = kill TERM, $kid; print STDERR "Restart_All: kill $kid, TERM: $cnt\n"; print STDERR "Restart_All: Watcher_Child: $Watcher_Child\n" if $kid == $Watcher_Child; $cnt = kill KILL, $kid unless $cnt; if ( $cnt ) { wait; delete $Kids{$kid}; } } close $Server; close $Client; if ( $sig eq 'TERM' || $sig eq 'INT' ) { print STDERR "Restart_All: Exiting($$/$My_Pid) with $sig\n"; sleep 1; exit 0; } foreach my $sig (@Special_Sigs) { $SIG{$sig} = 'DEFAULT'; } # restart all: print STDERR "sleep...\n"; sleep 5; $i = 0; while ($i < 10) { $i++; $test = `netstat -an | sed -e 's/:$My_Listen_Port *[^0-9]/:EGG /' | grep ':$My_Listen_Port '` if $Unix; if ( $test ne '' ) { my @a; $n = scalar(@a = split(/\n/, $test)); print STDERR "Still bound: $n\n"; my $s = 6 + $i; print STDERR "sleep($s) ...\n"; sleep $s; } else { last; } } print STDERR "\n"; system("netstat -an | grep ':$My_Listen_Port'") if $Unix; print STDERR "\n"; sleep 1; $exec = 0; setpgrp(0, 0); if ( $exec ) { exec $Program0, @Initial_Args; exit 1; } else { $cmd = "$Program0 " . join(' ', @Initial_Args); #system("xterm -geometry -10-10 -e $cmd &"); system("$cmd &"); } exit 0; } ######################################################################### # Main loop(s): $Conn = ''; # LOOP OVER ALL INCOMING CONNECTIONS. if ( ! $Windows && $Pre_Fork > 0 ) { # we normally use this preforking mode: # Preforking mode (each child handles several connections) print STDERR "Preforking mode... $Pre_Fork\n"; # make a child to watch the config file: $Parent = $$; if ( $Watcher_Child = fork() ) { $SIG{'USR1'} = 'Restart_Children'; $SIG{'USR2'} = 'Restart_All'; $SIG{'HUP'} = 'Restart_All'; $SIG{'TERM'} = 'Restart_All'; $SIG{'INT'} = 'Restart_All'; } else { &Watch_Config_File(); exit 0; } # intialize the children: &gettime(); # initialises gettimeofday for children. $Kid_Count = 0; $Conn = sprintf(" %-15s", "master\[$$]"); foreach $i (1..$Pre_Fork) { &Make_Child(); } my $waitpid; my $wakeup = 30; my $wakeup_pid = &Make_Wakeup($wakeup); while (1) { # wait for 1 to exit, then make a new one. $waitpid = wait; if ( $waitpid > 0 ) { delete $Kids{$waitpid}; } if ( $waitpid == $wakeup_pid ) { # this is the wakeup child print STDERR "CAC#$Conn: wakeup: $wakeup_pid " . &Date . "\n" if $Debug; &Merge_Allow_Cache_File(); $wakeup_pid = &Make_Wakeup($wakeup); next; } if ( $waitpid <= 0 ) { next; } # take this opportunity to update configs, caches, etc. &Read_Config_File(); &Merge_Allow_Cache_File(); # created the new child &Make_Child(); } } else { # Older, fork at connection always mode. # Or on Windows single process no forks. while (1) { # Forking mode (each child handles only 1 connection) $t = &Date; $Conn++; &Merge_Allow_Cache_File() if ! $Windows; &Read_Config_File() if $Conn % 20 == 0; print STDERR "SRV:$Conn: Waiting for Connection $Conn at " . "$t ...\n"; ($Client) = &AcceptConnection($Server); if ( $Windows ) { # Win32 must finish transaction before getting next # request in queue. &Handle_Conn(); close $Client; } else { # Fork off child for connection if (!fork) { # Don't need this handle anymore. close $Server; if ( ! $Single_Fork ) { # Now a double fork to avoid zombies... unless (fork) { # POSIX sez no setpgrp(0, $$) setpgrp(0, 0); # Go take care of the transaction. &Handle_Conn(); close $Client; exit 0; } # This exit happens quickly... exit 0; } else { &Handle_Conn(); close $Client; exit 0; } } if ( ! $Single_Fork ) { # ...so the 1st child is harvested quickly. wait; } } # The server continues here, and no longer needs the # filehandle to connection: close $Client; # On to the next connection ... } } ######################################################################### exit 0; #### subroutines: #### sub Date { my ($mode) = @_; my ($t); if ( $mode eq 'HTTP' ) { local($ENV{TZ}) = 'UTC'; $t = scalar(localtime); my ($day, $mon, $nday, $hms, $y) = split(' ', $t); $t = "$day, $nday $mon $y $hms GMT"; return $t; } else { $t = localtime; # use chop($t = `date`) on perl4 + Unix? return $t; } } sub Read_Config_File { my ($mode) = @_; my ($old_time); if ( $mode eq 'force' ) { $old_time = 0; } elsif ( $Config_File_Time ne '' ) { $old_time = $Config_File_Time; } else { $old_time = 0; } if ( ! -f $Config_File ) { $Config_File_Time = 0; } else { $Config_File_Time = -M $Config_File; } if ( $Config_File_Time >= $old_time ) { if ( $old_time != 0 ) { print STDERR "CONFIG: SKIP: Read_Config_File: " . "old=$old_time new=$Config_File_Time\n" if $Debug; return; } } print STDERR "CONFIG# Read_Config_File: old=$old_time" . "new=$Config_File_Time\n"; if ( open(CONF, "<$Config_File") ) { my ($key, $val, %init); while ($line = ) { chop($line); $line =~ s/#.*$//; next if $line =~ /^\s*$/; $line =~ s/^\s*//; $line =~ s/\s*$//; $key = ''; $val = ''; ($key, $val) = split(/[\s:]+/, $line, 2); print STDERR "CONFIG: key: $key => val $val\n" if $Debug; if ( $key =~ /^(Hosts_|Url_)/ ) { if ( ! $init{$key} ) { eval "undef \$$key"; $init{$key} = 1; } eval "\$$key .= \$val"; if ( $key =~ /Url_Redir|Url_Rewrite/ ) { eval "\$$key .= \"\\n\""; } else { eval "\$$key .= ' '"; } } else { eval "\$$key = \$val"; } } close(CONF); } else { print STDERR "CONFIG# could not open $Config_File: $!\n" if $Debug; } &Setup_Access(); # Hosts_Allow # Hosts_Deny # Url_Deny # Url_Redir # Url_Rewrite # Flag_File_Prefix # Proxy_host # Proxy_port # My_Listen_Port # First_Block_Size # Buf_Size # Unix # Windows # IS_SYSV # Extra_Fork # Single_Fork # Debug # Argv_Url } sub Merge_Allow_Cache_File { my ($mode) = @_; my $wait_time; if ( $mode eq 'child' ) { $file = $Allow_Cache_Dict_File; $wait_time = 10; } else { $file = $Allow_Cache_File; $wait_time = 5; } if ( ! -e $file || -z $file ) { print STDERR "CAC#$Conn: Merge_Allow_Cache_File: " . "no file: $file\n" if $Debug && ! -e $file; return; } my ($list, $host, $ip, @cache); my ($time) = time; if ( defined($Merge_Allow_Cache_File_Time) && $time < $Merge_Allow_Cache_File_Time + $wait_time ) { # merge at most $wait_time seconds after the last merge. my $dt = $time - $Merge_Allow_Cache_File_Time; print STDERR "CAC#$Conn: MergeOut wait dt=$dt\n" if $Debug; return; } if ( $mode eq 'child' ) { my($size, $mtime) = (stat($file))[7,9]; my $diff = 0; my $how = ''; if ( defined($Merge_Allow_Cache_File_Size) ) { if ( $Merge_Allow_Cache_File_Size == $size ) { # it has not changed. print STDERR "CAC#$Conn: MergeOut size $size\n" if $Debug; return; } else { $how = 'size'; $diff = 1; } } if ( ! $diff && defined($Merge_Allow_Cache_File_Time) ) { if ( $mtime < $Merge_Allow_Cache_File_Time ) { my $dt = $Merge_Allow_Cache_File_Time - $mtime; print STDERR "CAC#$Conn: MergeOut mtime dt=$dt " . "$Merge_Allow_Cache_File_Time - $mtime\n" if $Debug; return; } else { $how = 'mtime'; } } $Merge_Allow_Cache_File_Size = $size; #$Merge_Allow_Cache_File_Mtim = $mtime; print STDERR "CAC#$Conn: Merge_Allow_Cache_File child read " . "- how=$how\n" if $Debug; } $Merge_Allow_Cache_File_Time = $time; my $learned = 0; my $cleared = ''; my %saw; if ( open(CACHE, "<$file") ) { print STDERR "CAC#$Conn: Merge_Allow_Cache_File: $file\n" if $Debug; @cache = ; close(CACHE); if ( $mode ne 'child' ) { if ( open(CACHE, ">$Allow_Cache_File") ) { close(CACHE); } else { unlink($Allow_Cache_File); } } foreach $line (@cache) { next if $saw{$line}; $saw{$line} = 1; chomp($line); print STDERR "CAC#$Conn: Merge_Allow_Cache_File: " . "$line\n" if $Debug && $mode ne 'child'; $line =~ s/#.*$//; next if $line =~ /^\s*$/; $line =~ s/^\s*//; $line =~ s/\s*$//; $list = ''; if ( $line =~ /^allow[\s:]+/i ) { $list = $'; foreach $host (split(/[\s:]+/, $list)) { my ($host2, $val) = split(/=/, $host); next if $host2 =~ /^\s*$/; $val = 1 if $val eq ''; $learned++ if ! exists($Allow_Cache{$host2}) || $Allow_Cache{$host2} ne $val; $Allow_Cache{$host2} = $val; } } if ( $line =~ /^deny[\s:]+/i ) { $list = $'; foreach $host (split(/[\s:]+/, $list)) { my ($host2, $val) = split(/=/, $host); next if $host2 =~ /^\s*$/; $val = 1 if $val eq ''; $learned++ if ! exists($Deny_Cache{$host2}) || $Deny_Cache{$host2} ne $val; $Deny_Cache{$host2} = $val; } } if ( $Use_Dns_Cache && $line =~ /^dns[\s:]+/i ) { $list = $'; foreach $host (split(/[\s:]+/, $list)) { next if $host =~ /^\s*$/; ($host, $ip) = split(/=/, $host, 2); next if $host =~ /^\s*$/; next if $ip =~ /^\s*$/; $learned++ if ! exists($Dns_Cache{$host}) || $Dns_Cache{$host} ne $ip; $Dns_Cache{$host} = $ip; } } if ( $line =~ /^clear[\s:]+/i ) { $list = $'; $list = 'allow,deny,dns' if $list =~ /all/i; undef %Allow_Cache if $list =~ /allow/i; undef %Deny_Cache if $list =~ /deny/i; undef %Dns_Cache if $list =~ /dns/i; $learned++ if $list =~ /allow|deny|dns/i; $cleared .= "$line\n"; } } } foreach $host (keys(%Deny_Cache)) { # delete accidental -1 access (e.g. from dns alias flukes) # we let '1' determinations remain... if ( $Access_Cache{$host} eq '-1' ) { delete $Access_Cache{$host}; $learned++; } } my ($key, $val); print STDERR "CAC#$Conn: Allow_Cache=", scalar(keys(%Allow_Cache)), " Deny_Cache=", scalar(keys(%Deny_Cache)), " Dns_Cache=", scalar(keys(%Dns_Cache)), "\n"; if ( $mode eq 'child' ) { return; } # Write out the dictionary file for children to read: print STDERR "CAC#$Conn: learned=$learned\n" if $Debug; if ( $learned && open(DICT, ">$Allow_Cache_Dict_File") ) { print DICT "# $Conn: last-modified: ", &Date, "\n"; print DICT $cleared if $cleared; foreach $key (keys(%Allow_Cache)) { print DICT "ALLOW:$key=$Allow_Cache{$key}\n"; } foreach $key (keys(%Deny_Cache)) { print DICT "DENY:$key=$Deny_Cache{$key}\n"; } if ($time > $Last_Dns_Purge + $Dns_Purge_Time) { undef %Dns_Cache; $Last_Dns_Purge = $time; print STDERR "CAC#$Conn: Purge Dns_Cache (delay: $Dns_Purge_Time)\n"; print DICT "CLEAR:dns\n"; } foreach $key (keys(%Dns_Cache)) { print DICT "DNS:$key=$Dns_Cache{$key}\n"; } close(DICT); } if ( $Debug > 1 ) { foreach $key (keys(%Allow_Cache)) { print STDERR "CAC#hash: ALLOW: $key\t$Allow_Cache{$key}\n"; } foreach $key (keys(%Deny_Cache)) { print STDERR "CAC#hash: DENY: $key\t$Deny_Cache{$key}\n"; } foreach $key (keys(%Dns_Cache)) { print STDERR "CAC#hash: DNS: $key\t$Dns_Cache{$key}\n"; } } } sub Clear_Caches { undef %Allow_Cache; undef %Deny_Cache; } sub Setup_Access { my (@code, @sub); my ($i, $j, $start_debug, $allow, $allow0, $deny, $deny0); my ($start) = 'sub %SUB% { my __MACH__ = 0; $_ = $_[0]; '; $start_debug = ''; $start_debug = 'print STDOUT "MTC:$Conn: into-sub: %SUB%' . '(", join(", ", @_), ")\n"; ' if $Debug; $start .= $start_debug; $sub[1] = 'allow_match_addr'; # are all these really needed? $sub[2] = 'allow_match_name'; $sub[3] = 'deny_match_addr'; $sub[4] = 'deny_match_name'; $sub[5] = 'url_deny'; $sub[6] = 'url_redir'; $sub[7] = 'url_rewrite'; undef %Hosts_Allow; undef %Hosts_Deny; print STDERR "The Dns_Cache has ", scalar(keys(%Dns_Cache)), " entries.\n"; foreach $i (1..7) { eval "undef \&$sub[$i]"; $code[$i] = $start; $code[$i] =~ s/%SUB%/$sub[$i]/g; } if ( $Debug ) { print STDERR "SETUP_ACCESS: Hosts_Allow: $Hosts_Allow,\n\t"; print STDERR "Hosts_Deny: $Hosts_Deny,\n\t"; print STDERR "Url_Deny: $Url_Deny\n\t"; print STDERR "Url_Redir: $Url_Redir\n"; print STDERR "Url_Rewrite: $Url_Rewrite\n"; } if ( $Url_Rewrite ne '' ) { my $rewrite; foreach $rewrite (split(/\n+/, $Url_Rewrite)) { next if $rewrite =~ /^\s*$/; $rewrite =~ s/^\s*//; $rewrite =~ s/\s*$//; $code[7] .= "__MACH__ = (\$_ =~ $rewrite) if ! __MACH__; \n"; } $code[7] .= " return \$_; }"; $code[7] =~ s/__MACH__/\$ret/g; print STDERR "CODE: sub7 = $code[7]\n" if $Debug; eval $code[7]; } if ( $Url_Redir ne '' ) { my ($redir, $type, $action); $code[6] .= '$fh = $_[1]; '; foreach $redir (split(/\n+/, $Url_Redir)) { next if $redir =~ /^\s*$/; $redir =~ s/^\s*//; ($match, $type) = split(/\s+/, $redir, 2); ($type, $action) = split(/:/, $type, 2); if ( $match =~ m,^/(.*)/$, ) { $match = $1; } else { $match =~ s/\./\\./g; $match =~ s/\*/.*/g; $match = "^$match\$"; } if ( $type eq 'TYPE' ) { $code[6] .= "__MACH__ = &redir_content_type(\$_, \$fh, '$action') if ! __MACH__ && m,$match,i; \n"; } elsif ( $type eq 'HDR' ) { $code[6] .= "__MACH__ = &redir_header_modify(\$_, \$fh, '$action') if ! __MACH__ && m,$match,i; \n"; } elsif ( $type eq 'CMD' ) { $code[6] .= "__MACH__ = &redir_to_command(\$_, \$fh, '$action') if ! __MACH__ && m,$match,i; \n"; } elsif ( $type eq 'PROXY' ) { $code[6] .= "__MACH__ = &redir_to_proxy(\$_, \$fh, '$action') if ! __MACH__ && m,$match,i; \n"; } } $code[6] .= " return __MACH__; }"; $code[6] =~ s/__MACH__/\$ret/g; print STDERR "CODE: sub6 = $code[6]\n" if $Debug; eval $code[6]; } if ( $Url_Deny ne '' ) { foreach $deny (split(/[\s]+/, $Url_Deny)) { next if $deny =~ /^\s*$/; if ( $deny =~ m,^/(.*)/$, ) { $deny = $1; } else { $deny =~ s/\./\\./g; $deny =~ s/\*/.*/g; $deny = "^$deny\$"; } $code[5] .= "__MACH__ = 1 if m,$deny,i; "; } $code[5] .= " return __MACH__; }"; $code[5] =~ s/__MACH__/\$ret/g; print STDERR "CODE: sub5 = $code[5]\n" if $Debug; eval $code[5]; } $Always_Allow = 0; if ( $Hosts_Allow eq '' && $Hosts_Deny eq '' ) { $Always_Allow = 1; foreach $i (1..2) { $code[$i] = "sub %SUB% { $start_debug return 1; }"; $j = $i + 2; $code[$j] = "sub %SUB% { $start_debug return 0; }"; } foreach $i (1..4) { $code[$i] =~ s/%SUB%/$sub[$i]/g; eval $code[$i]; } return; } if ( $Hosts_Allow ne '' ) { foreach $allow (split(/[\s,]+/, $Hosts_Allow)) { next if $allow =~ /^\s*$/; $Hosts_Allow{$allow} = 1; } } if ( $Hosts_Deny ne '' ) { foreach $deny (split(/[\s,]+/, $Hosts_Deny)) { next if $deny =~ /^\s*$/; $Hosts_Deny{$deny} = 1; } } foreach $allow (keys(%Hosts_Allow)) { next if $allow =~ /^\s*$/; if ( $allow eq '*' ) { foreach $i (1..2) { $code[$i] = "sub %SUB% { $start_debug return 1; }"; $j = $i + 2; $code[$j] = "sub %SUB% { $start_debug return 0; }"; } foreach $i (1..4) { $code[$i] =~ s/%SUB%/$sub[$i]/g; eval $code[$i]; } return; } $allow0 = $allow; if ( $allow =~ m,^/(.*)/$, ) { $allow = $1; } else { $allow =~ s/\./\\./g; $allow =~ s/\*/.*/g; $allow = "^$allow\$"; } if ( $allow0 =~ /^[\d\.\*]+$/ ) { $code[1] .= "__MACH__ = 1 if m,$allow,i; "; } else { $code[2] .= "__MACH__ = 1 if m,$allow,i; "; } } foreach $deny (keys(%Hosts_Deny)) { next if $deny =~ /^\s*$/; $deny0 = $deny; if ( $deny =~ m,^/(.*)/$, ) { $deny = $1; } else { $deny =~ s/\./\\./g; $deny =~ s/\*/.*/g; $deny = "^$deny\$"; } if ( $deny0 eq '*' ) { $code[3] .= "__MACH__ = 1 if /.*/; "; $code[4] .= "__MACH__ = 1 if /.*/; "; } elsif ( $deny0 =~ /^[\d\.\*]+$/ ) { $code[3] .= "__MACH__ = 1 if m,$deny,i; "; } else { $code[4] .= "__MACH__ = 1 if m,$deny,i; "; } } foreach $i (1..4) { $code[$i] .= " return __MACH__; }"; $code[$i] =~ s/__MACH__/\$ret/g; print STDERR "CODE: sub$i = $code[$i]\n" if $Debug; eval $code[$i]; } } sub redir_to_command { my ($url, $fh, $cmd) = @_; print STDERR "RED:$Conn: redir_to_command: $url $fh $cmd\n"; my ($request, $x); my $get_the_request = 0; if ( $get_the_request ) { while (<$fh>) { $x = <$fh>; $request .= $x; last if $x =~ /^[\r\n]*$/; } $request =~ s/\r//g; } my $sockaddr = 'S n a4 x8'; my $remote = getpeername($fh); my ($fam, $port, $addr) = unpack($sockaddr, $remote); $addr = join('.', unpack('C4',$addr)); $request = "GET $url $Http_Version0\n" . "REMOTE_ADDR: $addr\n" . $request; # grotty, hope mommy isn't looking... my $tmp = "/tmp/$Program.$$"; if ( open(TMP, ">$tmp") ) { print TMP $request; close(TMP); } else { return 0; # i.e. failure } if (fork) { sleep 3; print $fh "$Http_Version0 200 OK\r\n"; print $fh $x; print $fh "\r\n"; print $fh " \n"; close($fh); } else { close($Server); close($Client); close($fh); $x = `$cmd < $tmp 2>/dev/null`; sleep 1; unlink($tmp); exit 0; } return 1; } sub redir_content_type { my ($url, $fh, $type) = @_; my $debug = 1; my $get_the_request = 0; print STDERR "REDIR:$Conn: redir_content_type: $url $fh $type\n"; my ($request, $x); if ( $get_the_request ) { while (<$fh>) { $x = <$fh>; print STDERR "redir_content_type: x=$x\n" if $debug; $request .= $x; last if $x =~ /^[\r\n]*$/; } print STDERR "redir_content_type: out of loop\n" if $debug; } print $fh "$Http_Version0 200 OK\r\n"; print $fh "Connection: close\r\n"; if ( $type =~ m,\bnull-html$, ) { # special case application/null-html print $fh "Content-Type: text/html\r\n"; print $fh "\r\n"; print $fh " \n"; } else { print $fh "Content-Type: $type\r\n"; print $fh "\r\n"; # this string goes to the *viewer*, which it should decode $x = "$url Content-Type: $type\n"; print $fh $x; } close($fh); return 1; } sub redir_header_modify { my ($url, $fh, $type) = @_; my $debug = 1; print STDERR "REDIR:$Conn: redir_header_modify: $url $fh $type\n"; if ( $type =~ m,^User-Agent, ) { return "KEEP_FH\n$type"; } return 0; } sub redir_to_proxy { my ($url, $fh, $type) = @_; my $debug = 1; print STDERR "REDIR:$Conn: redir_proxy: $url $fh $type\n"; if ( $type =~ m,^(.*):(.*), ) { return "KEEP_FH\nProxy_host:$1\nProxy_port:$2\n"; } else { return "KEEP_FH\nProxy_host:$type\nProxy_port:8080\n"; } return 0; } sub Access { my ($host) = @_; if ( $Deny_Cache{$host} ) { return 0; } if ( exists($Allow_Cache{$host}) ) { return $Allow_Cache{$host}; } my ($acc) = 0; my (@addrs) = (); ($acc, @addrs) = &host_access_match($host); if ($acc == 1 || $acc == 0) { &Write_Allow_Cache_File() if @Modified_Allow_Cache; return $acc; } if ( $acc == -1 ) { # means a default accept. my ($htry); foreach $htry (@addrs) { next if $htry =~ /^\s*$/; $Allow_Cache{$htry} = -1; push(@Modified_Allow_Cache, "ALLOW:$htry=-1"); } &Write_Allow_Cache_File(); return -1; } } sub host_access_match { my ($host) = @_; @Modified_Allow_Cache = (); if ( $Deny_Cache{$host} ) { return (0, $host); } if ( exists($Allow_Cache{$host}) ) { return ($Allow_Cache{$host}, $host); } my ($name, $aliases, $addrtype, $length, $a, @addrs, @hosts, @all); my ($af_inet) = 2; my ($htry); my ($dodns) = 0; if ( $host =~ /^[\d\.]+$/ ) { $a = pack('C4',split(/\./, $host)); ($name, $aliases, $addrtype, $length, @addrs) = gethostbyaddr($a,$af_inet); foreach $a (@addrs) { $a = join('.', unpack('C4',$a)); } unshift(@addrs, $host); @hosts = split(/\s+/, $aliases); unshift(@hosts, $name); } else { $dodns = 1; ($name, $aliases, $addrtype, $length, @addrs) = gethostbyname($host); @hosts = split(/\s+/, $aliases); unshift(@hosts, $host); unshift(@hosts, $name); foreach $a (@addrs) { $a = join('.', unpack('C4',$a)); } } foreach $a (@hosts) { $a =~ y/A-Z/a-z/; # modifies @hosts values } # clean up the lists for dups: my (@h2, %h2, @a2, %a2); foreach $a (@hosts) { next if $h2{$a}; $h2{$a} = 1; push(@h2, $a); } @hosts = @h2; foreach $a (@addrs) { next if $a2{$a}; $a2{$a} = 1; push(@a2, $a); } @addrs = @a2; if ( $Debug ) { print STDERR "TRY:$Conn: name '$name'\n"; print STDERR "TRY:$Conn: aliases '$aliases'\n"; print STDERR "TRY:$Conn: hosts '" . join(' ', @hosts) . "'\n"; print STDERR "TRY:$Conn: addrs '" . join(' ', @addrs) . "'\n"; } @all = (@hosts, @addrs); if ( $Use_Dns_Cache && $dodns && ! $Dns_Cache{$host} ne '' && $addrs[0] ne '') { if ( @addrs == 1 ) { # We skip caching if we notice Round-Robin in place. $Dns_Cache{$host} = $addrs[0]; push(@Modified_Allow_Cache, "DNS:$host=$Dns_Cache{$host}"); } } my ($decision) = ''; foreach $htry (@hosts) { next if $htry =~ /^\s*$/; print STDERR "TRY:$Conn: allow?: $htry\n" if $Debug; if ( &allow_match_name($htry) ) { $decision = 'ALLOW'; } } foreach $htry (@addrs) { next if $htry =~ /^\s*$/; print STDERR "TRY:$Conn: allow?: $htry\n" if $Debug; if ( &allow_match_addr($htry) ) { $decision = 'ALLOW'; } } if ( $decision eq 'ALLOW' ) { foreach $htry (@hosts, @addrs) { next if $htry =~ /^\s*$/; $Allow_Cache{$htry} = 1; push(@Modified_Allow_Cache, "ALLOW:$htry=1"); } return (1, @all); } foreach $htry (@hosts) { next if $htry =~ /^\s*$/; print STDERR "TRY:$Conn: deny?: $htry\n" if $Debug; if ( &deny_match_name($htry) ) { $decision = 'DENY'; } } foreach $htry (@addrs) { next if $htry =~ /^\s*$/; print STDERR "TRY:$Conn: deny?: $htry\n" if $Debug; if ( &deny_match_addr($htry) ) { $decision = 'DENY'; } } if ( $decision eq 'DENY' ) { foreach $htry (@hosts, @addrs) { next if $htry =~ /^\s*$/; $Deny_Cache{$htry} = 1; push(@Modified_Allow_Cache, "DENY:$htry=1"); } return (0, @all); } # -1 is true when used later. Indicates default accept was the case. return (-1, @all); } sub Write_Allow_Cache_File { # TODO: add a locking mechanism. For now just append my ($output, $line); $output = ''; foreach $line (@Modified_Allow_Cache) { next if $line =~ /^\s*$/; $output .= "$line\n"; } return if $output eq ''; if ( open(CACHE, ">>$Allow_Cache_File") ) { select(CACHE); $| = 1; print CACHE $output; close(CACHE); select(STDOUT); my ($tmp) = $output; $tmp =~ s/\n/ /g; print STDERR "CAC#$Conn: Write_Allow_Cache_File: $tmp\n"; } } sub Extract_Host { # Try to parse URL into host and file path # (this has not been tested extensively..) my ($url) = @_; my ($host, $port, $path, $userpass); # Remove extra spaces on ends. $url =~ s/^\s*//; $url =~ s/\s*$//; # Remove http:// if any. $url =~ s,^\w+://,,; my ($method) = $&; ($host, $path) = split(/\//, $url, 2); # Put back leading "/" if needed. if ( $path !~ /^\// ) { $path = "/$path"; } # Look for host:8001, etc if ( $host =~ /^(.*):(\d+)$/ ) { $host = $1; $port = $2; } else { # No port -> 80 $port = 80; } # Look for user:passwd@host if ( $host =~ /@([^@]*)$/ ) { $host = $1; $userpass = $`; if ( $userpass ne '' ) { $userpass = &tobase64($userpass); chomp($userpass); } } else { $userpass = ''; } # Try to handle not so well used protocols... if ( $method =~ /^gopher/i ) { $port = 70; } elsif ( $method =~ /^ftp/i ) { $port = 21; # UGH! } elsif ( $method =~ /^telnet/i ) { $port = 23; # UGH! } return ($host, $port, $path, $userpass); } sub debase64 { my ($x) = @_; $x =~ y,A-Za-z0-9+/,,cd; $x =~ y,A-Za-z0-9+/, -_,; my $len = pack("c", 32 + 0.75*length($x)); $x = unpack("u", $len . $x); return $x; } sub tobase64 { my $res = ""; my $eol = "\n"; pos($_[0]) = 0; while ($_[0] =~ /(.{1,45})/gs) { $res .= substr(pack('u', $1), 1); chop($res); } $res =~ tr|` -_|AA-Za-z0-9+/|; #` ### Fix padding at the end: my $padding = (3 - length($_[0]) % 3) % 3; $res =~ s/.{$padding}$/'=' x $padding/e if $padding; ### Break encoded string into lines of no more than 76 characters each: $res =~ s/(.{1,76})/$1$eol/g if (length $eol); return $res; } sub gettime { if ( ! $GetTime_Syscall_Init ) { my ($dir, $found_it); $found_it = 0; foreach $dir (@INC) { if ( -f "$dir/sys/syscall.ph" ) { $found_it = 1; # whew! last; } } if ( ! $found_it ) { # bummer... try to guess the syscall # $OS_Name = `uname -s` unless $OS_Name; if ( $OS_Name =~ /sunos/i ) { eval "sub SYS_gettimeofday { return 156; }"; } elsif ( $OS_Name =~ /linux/i ) { eval "sub SYS_gettimeofday { return 78; }"; } } else { require 'sys/syscall.ph'; } &SYS_gettimeofday() || die "$!"; $GetTime_Syscall_Init = &SYS_gettimeofday(); print STDERR "Initialized: GetTime_Syscall\n" if $Debug; } # let's keep these global... # my ($tv, $tv_sec, $tv_usec); # Allocate the "timeval" space: $tv = ("\0" x 4) x 2; # assumes long is 4 bytes. $tz = ("\0" x 4) x 2; # assumes long is 4 bytes. syscall($GetTime_Syscall_Init, $tv, $tz); ($tv_sec, $tv_usec) = unpack("L2", $tv); # $tv_sec = substr($tv, 0, 4); # $tv_usec = substr($tv, 4, 4); # $tv_sec = unpack("l", $tv_sec); # $tv_usec = unpack("l", $tv_usec); $tv_usec2 = sprintf("%8.6f", $tv_usec/1000000.0); if ( $tv_usec2 =~ /^0\./ ) { $tv_usec2 =~ s/^0\././; $tv_sec = "$tv_sec$tv_usec2"; } else { $tv_sec = $tv_sec + ($tv_usec/1000000.0); } if ( $StartTime ne '' ) { $tv_sec -= $StartTime; } return $tv_sec; } sub print_time { my($m1, $m2) = @_; my $now = &gettime(); my $dt = sprintf("%.3f", $now - $SETTIME); my $secs = 'secs'; $secs = '#' x int($dt) . $secs if $dt > 1.0; print STDERR "TME:$Conn: $m1 $dt $secs $m2\n"; } sub Handle_Conn { $HTTP = ''; $HTTP_host = ''; $KEEPALIVE_COUNT = 0; if ( $Extra_Fork || ! $Do_Keepalive ) { # for now, do not handle extra fork and keep alive # for the forking case: &Process_Conn(); &print_time('DT:', $URL); &Merge_Allow_Cache_File('child') if $Pre_Fork; } else { $KEEPALIVE = 1; $SIG{ALRM} = \&client_alarm_handler; while ($KEEPALIVE) { print STDERR "KEP:$Conn: KEEPALIVE_COUNT: " . "$KEEPALIVE_COUNT last_host='$HTTP_host' " . "timeout='$Keep_Alive_Timeout'\n"; &Process_Conn(); &print_time('DT:', $URL); &Merge_Allow_Cache_File('child') if $Pre_Fork; $KEEPALIVE_COUNT++; } } } sub Process_Conn { # Handles the entire transaction. # On Unix we are usually a child process. # On Windows we must be parent. no fork(). my ($host, $h_tmp, $port, $path, $userpass); my ($request, $client_request, $Get_Line); my ($get, $url, $version); my ($Is_Gif, $Is_Jpg, $pid, $gif89, $Mode); my ($mode, $anim, $Buf1, $buf, $i, $amatch); my ($replace_string, $c, $t); my ($dofork) = 0; my $user_agent = ''; my $my_debug = $Debug; if ( -f "$Flag_File_Prefix.debug" ) { $my_debug = 1; } # for Handle_Conn(), we reset to 1 when we know keep-alive will # take place. $KEEPALIVE = 0; $dofork = 1 if $Extra_Fork; # Unbuffer socket. select($Client); $| = 1; $request = ''; $client_request = ''; $Get_Line = ''; my $method = ''; if ( $KEEPALIVE_COUNT > 0 ) { my $timeout = 60; $Keep_Alive_Timeout = $timeout . '+'; if ( $Keep_Alive_Header =~ /timeout=(\d+)/i ) { $timeout = $1; $Keep_Alive_Timeout = $timeout; } chomp($SIG_Keep_Alive_Header = $Keep_Alive_Header); $SIG_Keep_Alive_Header =~ s/\s*$//; print STDERR "KEP:$Conn: setting ALRM timeout: $timeout\n" if $my_debug; $timeout = $timeout - 1; $timeout = 2 if $timeout < 2; alarm($timeout); } # Try to find the GET or POST line... (TODO: other methods??) # Note: this is just the first blank line and is assumed to be Request. while (<$Client>) { # Skip leading blank lines. print LOG "Client:$Conn:A:$_" if $my_debug; $client_request .= $_; next if /^\n|^\r\n$/; next if /^\s*\n?$/; $request = $_; print STDERR "IN0:$Conn: $_" if $my_debug; if (/^(HEAD|GET|POST|OPTIONS|PUT|DELETE|TRACE)/) { # TODO: try CONNECT someday. $method = $1; $Get_Line = $_; } last; } $SETTIME = &gettime(); alarm(0) if $KEEPALIVE_COUNT > 0; my $Get_Line0 = $Get_Line; if ( $Get_Line eq '' ) { if ( $client_request =~ /^\s*$/ ) { $t = "client_request was blank\n"; } else { $t = &Proxy_Error("METHOD OR PROTOCOL NOT SUPPORTED:" . "\n\n $request", $Client, 0, 4); } print STDERR "ERR:$Conn: ProxyError EMPTY GET/METHOD LINE: $t"; print STDERR "ERR:$Conn: ProxyError CLIENT_REQUEST='${client_request}' " . "REQUEST='${request}'\n"; return; } $Is_Gif = 0; # Global Flag to indicate a gif or not. $Is_Jpg = 0; # Split up the GET/METHOD line. ($get, $url, $version) = split(/\s+/, $Get_Line); $URL = $url; if ( $Argv_Url ) { if ( $KEEPALIVE_COUNT > 0 ) { $0 = "$Program\->$url-KEEPALIVE=$KEEPALIVE_COUNT"; } else { $0 = "$Program\->$url"; } } # Set HTTP version if empty. $version = $Http_Version0 unless $version; if ( $Http_Version ne '' && $version ne $Http_Version ) { $version = $Http_Version; } if ( $url =~ /\.gif\b/i ) { # Check if it is any kind of GIF. # used to have $ at match end $Is_Gif = 1; } if ( $url =~ /\.jpe?g\b/i ) { # Check if it is any kind of JPG. # used to have $ at match end $Is_Jpg = 1; } my $proxy_host = $Proxy_host; my $proxy_port = $Proxy_port; my $allow_all = 0; if ( -f "$Flag_File_Prefix.allow_all" ) { $allow_all = 1; } if ( $Url_Rewrite ne '' && ! $allow_all ) { my $url0 = $url; $url = &url_rewrite($url); if ( $url ne $url0 ) { print STDERR "REWRITE:$Conn: $url0 -> $url\n"; print $Client "$version 302 Found\r\n"; print $Client "Location: $url\r\n"; print $Client "Connection: close\r\n"; print $Client "\r\n"; return; } } if ( $Url_Redir ne '' && ! $allow_all ) { my $result = &url_redir($url, $Client); my $stay = 0; if ($result =~ /KEEP_FH/) { $stay = 1; } foreach my $item (split(/\n/, $result)) { if ($item =~ /User-Agent:/) { $user_agent = $item; print STDERR "UAG:$Conn: $url $item\n"; } elsif ($item =~ /Proxy_host:\s*/) { $proxy_host = $'; } elsif ($item =~ /Proxy_port:\s*/) { $proxy_port = $'; } } if ( ! $stay && $result ) { return; } } ($host, $port, $path) = &Extract_Host($url); if ( $KEEPALIVE_COUNT > 0 ) { my $host_lc = $host; $host_lc =~ s/A-Z/a-z/; print STDERR "KEP:$Conn: check host $host_lc =? $HTTP_host\n" if $my_debug; if ( $HTTP_host ne $host_lc ) { print STDERR "KEP:$Conn: new HTTP_host '$host_lc' != " . "'$HTTP_host' cannot Keep-Alive, closing HTTP\n"; $KEEPALIVE_COUNT = 0; close($HTTP); } elsif ($method =~ /HEAD/i) { print STDERR "KEP:$Conn: skip Keep-Alive on HEAD " . "'$HTTP_host'\n"; $KEEPALIVE_COUNT = 0; close($HTTP); } } $HTTP_host = $host; $HTTP_host =~ y/A-Z/a-z/; my $access_result = ''; if ( ! $Always_Allow && ! $allow_all ) { $host =~ y/A-Z/a-z/; $access_result = &Access($host); print STDERR "ACR:$Conn: host=$host " . "access_result='$access_result'\n" if $my_debug; } else { $access_result = 1; } my $deny_it = 0; if ( $Url_Deny ne '' && ! $allow_all && $access_result ne '1' ) { if ( &url_deny($url) ) { $deny_it = 1; } } my $show_cookies = 0; my $show_cookies_match = ''; $show_cookies_match = '(Cookie|Referer)'; $show_cookies_match = '(.)'; if ( -f "$Flag_File_Prefix.show_cookies" ) { $show_cookies = 1; } &print_time('access-done ', $URL) if $my_debug; if ( ! $access_result || $deny_it ) { # we are going to deny it w/o contacting remote host. my $how; my $connection = 'close'; if ( 1 && $Do_Keepalive ) { my $content_len = ''; my $connect_hdr = ''; my $hdr = ''; while (<$Client>) { if ( /^content-length\s*:\s*(\d+)\s*$/i ) { $content_len = $1; } elsif ( /^[^:]*connection:\s*\S+/i ) { $connection_hdr = $&; } $hdr .= $_; last if /^\r\n$/; last if /^\n/; } $hdr = &tabbed_header($Get_Line0 . $hdr); print STDERR "KEP:$Conn: denied Client Header:\n\t$hdr" if $my_debug || $show_cookies; if ( $connection_hdr =~ /keep-alive/i ) { $connection = 'keep-alive'; if ( $content_len ne '' ) { # get the client data uptodate: my $buf; read($Client, $buf, $content_len); } $KEEPALIVE = 1; print STDERR "KEP:$Conn: set KEEPALIVE, " . "content_len='$content_len'\n" if $my_debug; } } if ( $Is_Gif && ! $No_Fake_Gifs ) { &Return_Document($Question_Gif, 'image/gif', $Client, $connection); $how = 'Fake-Gif'; } elsif ( $Is_Jpg && ! $No_Fake_Gifs ) { &Return_Document($Question_Jpg, 'image/jpeg', $Client, $connection); $how = 'Fake-Jpg'; } else { $KEEPALIVE = 0; $connection = 'close'; print STDERR "KEP:$Conn: Proxy_Error turn off " . "Keep-Alive\n" if $my_debug; $t = &Proxy_Error("Permission denied (contact" . " your $Program admin):\n\n $request", $Client, 0, 2, $connection); $how = 'Fake-202'; } print STDERR "ACC#$Conn: **DENIED: $host - $how - $request"; if ( open(DENIED, ">>$Denied_Log_File") ) { print DENIED "ACC:$Conn: DENIED: $host - $how " . "- $request"; close(DENIED); } return; } print STDERR "ACC:$Conn: ALLOWED: $host - $request"; # Decide the connection host+port and the GET/METHOD line we will # send to it: ($host, $port, $path, $userpass) = &Extract_Host($url); my $extra_proxy = 0; if ( $proxy_host eq '' || $proxy_host =~ /^none$/i ) { # DIRECT CONNECTION CASE ($host, $port, $path, $userpass) = &Extract_Host($url); $Get_Line = "$get $path $version\r\n"; if ( $userpass ) { $Get_Line .= "Authorization: Basic $userpass\r\n"; } print STDERR "DIR:$Conn: host=$host port=$port " . "userpass=$userpass, $Get_Line0" if $userpass ne ''; } else { # ADDITIONAL PROXY CONNECTION CASE $host = $proxy_host; $port = $proxy_port; $path = $url; # not used, orig $Get_Line is used. $extra_proxy = 1; } $request = $Get_Line; if ( $Windows ) { $pid = "Windoze"; # (only used for info to STDERR) } else { $pid = $$; } print STDERR "GET:$Conn: $Get_Line0"; $h_tmp = $host; if ( $Use_Dns_Cache && $Dns_Cache{$host} ne '' ) { print STDERR "DNS:$Conn: Using cached lookup: $h_tmp => " . "$Dns_Cache{$host}\n" if $my_debug; $h_tmp = $Dns_Cache{$host}; } my $retries = 2; if ( $KEEPALIVE_COUNT > 0 ) { $retries = 0; } else { ($HTTP) = &Connect($h_tmp, $port); } for (my $i = 0; $i < $retries; $i++) { if (&SocketError($HTTP) && $HTTP =~ /gethost/ ) { # try again: my $tmsg = $HTTP; $tmsg =~ s/Error:Ksockets:Connect://; warn "WARNING: TRYING_LOOKUP_AGAIN\[$i\]: $tmsg\n"; fsleep(0.33); ($HTTP) = &Connect($h_tmp, $port); } else { last; } } # See if connection was OK: if ($KEEPALIVE_COUNT == 0 && &SocketError($HTTP)) { my $tmsg = $HTTP; $tmsg =~ s/Error:Ksockets:Connect://; &Proxy_Error("Could not connect:\n\n $tmsg", $Client, 1, 4); if ( $Windows ) { # Child returns. close $HTTP; warn "$HTTP"; return; # COMPLETELY DONE } else { # Child dies, not server. if ( $Pre_Fork ) { warn "WARNING: $HTTP"; return; } else { die "$HTTP"; } } } &print_time('connect-done', $URL) if $my_debug; print STDERR "HFH:$Conn: HTTP=$HTTP\n" if $my_debug; select($HTTP); $| = 1; select(STDOUT); # The following is not implemented... (CONNECT is rejected above). if ( $get =~ /^CONNECT/i && ! $Windows ) { print STDERR "CHG: Change mode to dofork for CONNECT\n"; $dofork = 1; } if ( ! $dofork && $get =~ /^CONNECT/i ) { # SEND REQUEST TO REMOTE MACHINE Usually Windows only. &Proxy_Error("Need to fork() to do CONNECT method\n " . "$request", $Client, 1, 5); close $HTTP; return; } # Fork if we have to. my $ChildPID = ''; if ( $dofork ) { $ChildPID = fork(); if ( !defined($ChildPID) ) { &Proxy_Error("Problem forking for method\n " . "$request", $Client, 1, 5); close $HTTP; return; } } my $Client_Content_Length = 0; my $Connection = ''; my $Client_Header = $Get_Line0 . $request; # SEND REQUEST TO REMOTE MACHINE Both Unix and Windows. my $doing_keepalive = 0; if ( ! $dofork || $ChildPID ) { # Parent case when forking. print $HTTP $request; print LOG "Client:$Conn:request:$request" if $my_debug; while (<$Client>) { print LOG "Client:$Conn:B:$_" if $my_debug; if ( /^content-length\s*:\s*(\d+)\s*$/i ) { $Client_Content_Length = $1; print STDERR "HDC:$Conn: ContentLength is: " . "$Client_Content_Length\n" if $my_debug; } elsif ( $user_agent ne '' && /^user-agent:/i ) { print STDERR "UAG:$Conn: $user_agent was: $_"; if ( $user_agent =~ /NONE$/ ) { $_ = ''; } else { $_ = $user_agent . "\r\n"; } } if ( $show_cookies && /^\S*$show_cookies_match/io ) { print STDERR "HDC:$Conn: Client:$Conn: $_" } $Client_Header .= $_; # this is for Proxy-Connection: Keep-Alive # or Connection: Keep-Alive if ( /^[^:]*connection:\s*\S+/i ) { $Connection = $&; print STDERR "CNM:$Conn: Connection-match: " . "$Connection\n" if $my_debug; if ( $Connection =~ /keep-alive/i ) { if ( ! $Do_Keepalive || $dofork ) { print STDERR "CONNECTION: FOUND KEEP-ALIVE " . "changing to close\n" if $my_debug; $_ = "Connection: close\r\n"; } else { $doing_keepalive = 1; $_ =~ s/Proxy-//ig unless $extra_proxy; print STDERR "CNM:$Conn: TRYING KEEP-ALIVE " . "sending: $_" if $my_debug; } } } print $HTTP $_; last if /^\r\n$/; last if /^\n/; } $t = ''; if ( $my_debug || $show_cookies ) { $t = &tabbed_header($Client_Header); print STDERR "CLH:$Conn: Client Header:\n\t$t"; } if ( $Client_Content_Length != 0 ) { read($Client, $buf, $Client_Content_Length); if ( $method eq "POST" ) { my $line; foreach $line (split(/\n/, $buf)) { print STDERR "PST:$Conn: $line\n"; } } else { print STDERR "read: $buf\n" if $my_debug; } print LOG "Client:$Conn:read:$buf\n" if $my_debug; print $HTTP $buf; } if ( $Do_Shutdown && ! $doing_keepalive ) { shutdown($Client, 0); # SHUTDOWN EXPT } } &print_time('cli-hdr-done', $URL) if $my_debug; if ( $dofork && $ChildPID ) { # Parent case when forking. ###print STDERR "SND:$Conn: close Client\n" if $my_debug; ###close $Client; print STDERR "SND:$Conn: close HTTP\n" if $my_debug; close $HTTP; # TODO: if ( $get =~ /^CONNECT/i && $Extra_Fork ) { # continue with the transfer; # } return; # COMPLETELY DONE } else { if ( $Do_Shutdown && ! $doing_keepalive ) { shutdown($HTTP, 1); # Half close, sends EOF } } # RECEIVE REQUEST FROM REMOTE MACHINE Both Unix and Windows. if ( $dofork && $ChildPID ) { # Parent case when forking return; } $gif89 = 0; # Use Flag File to determine our Edit mode: $Mode = ''; foreach $mode (@Flags) { if ( -f "$Flag_File_Prefix.$mode" ) { $Mode = $mode; last; } } my $Server_Content_Length = 0; my $ContentType = ''; my $Return_Connection = ''; my $ServerType = ''; my $HttpStatus = ''; my $Return_Header = ''; my $Last_Blank = ''; $Keep_Alive_Header = ''; while (<$HTTP>) { print LOG "Remote:$Conn:A:$_" if $my_debug; if ( $show_cookies && /^\S*$show_cookies_match/io ) { print STDERR "Remote:$Conn: $_"; } if ( /^[^:]*keep-alive:/i ) { $Keep_Alive_Header = $_; print STDERR "KEP:$Conn: Keep-Alive-match: " . "$Keep_Alive_Header\n" if $my_debug; } elsif ( /^content-length\s*:\s*(\d+)\s*$/i ) { $Server_Content_Length = $1; print STDERR "HDS:$Conn: ContentLength: " . "$Server_Content_Length\n" if $my_debug; } elsif ( /^content-type\s*:\s*(.*)\s*$/i ) { $ContentType = $1; print STDERR "HDS:$Conn: ContentType: " . "$ContentType\n" if $my_debug; } elsif ( /^[^:]*connection:\s*\S+/i ) { $Return_Connection = $&; print STDERR "RTC:$Conn: Return_Connection: " . "$Return_Connection\n" if $my_debug; if ( $Return_Connection =~ /keep-alive/i ) { if ( ! $doing_keepalive ) { print STDERR "RTC: RETURN_HDR: " . "changing KEEP-ALIVE => CLOSE ($host)\n"; $_ =~ s/keep-alive/close/i; print STDERR "RTC:$Conn: Return_Connection: " . "EDITED: $_" if $my_debug; } else { print STDERR "RTC:$Conn: RETURN_HDR KA_OK " . "\(CNT=$KEEPALIVE_COUNT): " . "$Return_Connection ($host)\n"; $doing_keepalive = 2; } } elsif ( 0 && $extra_proxy != 0 && $Return_Connection =~ /close/i ) { # let's try it! $doing_keepalive = 2; $_ =~ s/close/keep-alive/i; } } elsif ( /^server\s*:\s*(.*)\s*$/i ) { $ServerType = $1; } elsif ( /^http/i ) { chomp($HttpStatus = $_); $HttpStatus =~ s/\s*$//; } if ( /^\r\n$/ || /^\n/ ) { $Last_Blank = $_; last; } $Return_Header .= $_; } print STDERR "STA:$Conn: $HttpStatus ($URL)\n"; &print_time('rem-hdr-done', $URL) if $my_debug; my ($prot, $status, $status_str) = split(/\s+/, $HttpStatus); $t = ''; if ( $my_debug || $show_cookies ) { $t = &tabbed_header("+$Get_Line0" . $Return_Header); } if ( 0 && $extra_proxy && ! $Return_Connection ) { $doing_keepalive = 2; $Return_Header .= "Connection: keep-alive\r\n"; $Return_Header .= "Keep-Alive: timeout=60 max=100\r\n"; } if ( $doing_keepalive == 2 ) { print STDERR "KEP:$Conn: setting KEEPALIVE=1\n\t$t" if $my_debug; $KEEPALIVE = 1; } elsif ( $doing_keepalive == 1 ) { print STDERR "KEP:$Conn: NO KEEPALIVE\n\t$t" if $my_debug; $doing_keepalive = 0; } elsif ( $show_cookies ) { print STDERR "KEP:$Conn: Server header:\n\t$t"; } if ( $ContentType ne '' && $ContentType =~ /image.*gif/i ) { $Is_Gif = 1; } if ( ! $Mode ) { $Is_Gif = 0; } $anim = 0; # $anim > 0 => Animated Gif. $amatch = ''; my $read = 0; my ($t1, $t2, $t1b, $t2b, $time, $rest); if ( $Is_Gif && $status =~ /^2\d\d$/ ) { # TODO: there is no error checking here!!! my $size = $First_Block_Size; if ( $Server_Content_Length > 0 && $Server_Content_Length < $size ) { $size = $Server_Content_Length; } $read += read($HTTP, $Buf1, $size); $Buf0 = substr($Buf1, 0, 16); if ( $Buf0 =~ /GIF89a/i ) { # Look for GIF89a string. $gif89 = 'GIF89a'; } if ( $Buf1 =~ /NETSCAPE2\.0/ ) { # Look for netscape extension $amatch .= $&; $anim = 1; } elsif ( $Check_Multi_Gif89_Ext && $Buf1 =~ /\041\371\004.(.)(.)[\s\S]*\041\371\004/ ) { $t2 = hex(unpack("H*", $1)); $t1 = hex(unpack("H*", $2)); $time = ($t1 * 255) + $t2; $amatch .= "GCEXT-MULTI-$t1-$t2-$time/100"; $anim = 4; } elsif ( $Check_Any_Gif89_Ext && $Buf1 =~ /\041\371\004.(.)(.)/ ) { $t2 = hex(unpack("H*", $1)); $t1 = hex(unpack("H*", $2)); $rest = $'; # not really needed any more. $time = ($t1 * 255) + $t2; if ( $time != 0 ) { $amatch .= "GCEXT-ANY-$t1-$t2-$time/100"; $anim = 3; } elsif ( $rest =~ /\041\371\004.(.)(.)/ ) { $t2b = hex(unpack("H*", $1)); $t1b = hex(unpack("H*", $2)); $rest = $'; $time = ($t1b * 255) + $t2b; $amatch .= "GCEXT-ANY-$t1-$t2-$time/100-II"; $anim = 3; } } elsif ( $Buf1 =~ /GifBuilder/ ) { # sometimes not really an animation # and may be caught above anyway... $amatch .= $&; $anim = 2; } } if ($anim) { # Handle the gif editing if animated. print STDERR "ANM:$Conn: *** Found animated gif " . "($amatch,anim=$anim) in: $url\n"; if ( $No_Fake_Gifs ) { my $conn = 'close'; if ( ! $doing_keepalive ) { close $HTTP; } else { if ( $Server_Content_Length && $status =~ /^2\d\d$/ ) { my $n = $Server_Content_Length - $read; read($HTTP, $Buf1, $n) if $n; $conn = 'keep-alive'; } else { ##$KEEPALIVE = 0; ##$doing_keepalive = 0; ##close $HTTP; } } &Proxy_Error("ANIMATED-GIFS-NOT-ALLOWED", $Client, 0, 2, $conn); return; } elsif ( $Mode eq 'replace' ) { my $len = $Subst_Gif_Size[$anim]; if ( ! $len ) { print STDERR "ANM:$Conn: MISSING length: $len\n"; } elsif ( $Return_Header =~ /Content-Length:/i ) { $Return_Header =~ s/(Content-Length:\s+)(\d+)/$1$len/i; print STDERR "ANM:$Conn: SUBBED: $1$len WAS $2\n"; } else { $Return_Header .= "Content-Length: $len\r\n"; print STDERR "ANM:$Conn: APPENDED: " . "Content-Length: $len\n"; } $Return_Header .= $Last_Blank; print $Client $Return_Header; print $Client $Subst_Gif[$anim]; if ( ! $doing_keepalive ) { ###print STDERR "ANM:$Conn: close Client " ### . "($gif89,$amatch)\n" if $my_debug; ###close $Client; print STDERR "ANM:$Conn: close HTTP " . "($gif89,$amatch)\n" if $my_debug; close $HTTP; } else { if ( $Server_Content_Length ) { my $n = $Server_Content_Length - $read; read($HTTP, $Buf1, $n) if $n; } else { # this violates Connection: keep-alive # presumably in $Return_Header ##$KEEPALIVE = 0; ##$doing_keepalive = 0; ##close $HTTP; } } return; # COMPLETELY DONE } elsif ( $Mode eq 'oneloop' ) { if ( $Buf1 =~ /NETSCAPE2\.0(....)/ ) { # $repl_match = $&; $replace_string = ''; # should be: 0x03, 0x01, 0x01, 0x00 (one loop?) # Default is: 0x03, 0x01, 0x00, 0x00 (loop forever?) $Buf1 =~ s/NETSCAPE2\.0(....)/NETSCAPE2.0${replace_string}/o; } } # Otherwise, deliver $Buf1 unaltered. } print $Client $Return_Header . $Last_Blank; print $Client $Buf1; # Send the gif data to browser. $buf = ''; if ( $doing_keepalive ) { # XXX bad idea to read all into RAM?? # make a loop? if ( $status =~ /^2\d\d$/ ) { my $total_len = $Server_Content_Length; my $read_all_at_once = 0; if ( $read_all_at_once ) { my $n = $total_len - $read; read($HTTP, $buf, $n) if $n; print $Client $buf; } else { while ($read + $Buf_Size < $total_len) { $read += read($HTTP, $buf, $Buf_Size); print $Client $buf; } my $n = $total_len - $read; read($HTTP, $buf, $n) if $n; print $Client $buf; } } } else { $KEEPALIVE = 0; $doing_keepalive = 0; if ( $status =~ /^[2345]\d\d$/ ) { while (read($HTTP, $buf, $Buf_Size)) { print $Client $buf; last if eof($HTTP); } } } if ( ! $doing_keepalive ) { print STDERR "RCV:$Conn: close HTTP\n" if $my_debug; close $HTTP; } $t = &Date; print STDERR "RCV:$Conn: Done at $t ($host)\n"; return; # return (and the perhaps exit if Unix) } sub client_alarm_handler { print STDERR "TIM:$Conn: KeepAlive client timed out (remote=$HTTP_host," . " $SIG_Keep_Alive_Header). closing and exiting.\n" if $Debug; $SIG{ALRM} = 'DEFAULT'; close($HTTP); close($Client); &fsleep(1.5*rand()); exit 0; } sub tabbed_header { my ($hdr) = @_; $hdr =~ s/\n/\n\t/g; chop($hdr); $hdr = "\n" if $hdr eq ''; return $hdr; } sub do_ps { my ($str) = @_; my $ps = "$str -- PS \[$Conn/$$]:\n". `ps lfw $$`; $ps =~ s/\n(.)/\n$str$1/g; print STDERR $ps; return; } sub fsleep { my ($time) = @_; select(undef, undef, undef, $time) if $time; } sub help { my ($data) = @_; $data = $Usage if $data eq ''; if ( $ENV{'PAGER'} ne '' && open(PAGER, "|$ENV{'PAGER'}") ) { # open pipeline to user's pager print PAGER "$data"; close(PAGER); } elsif ( open(MORE, "|more") ) { # open pipeline to "more" print MORE "$data"; close(MORE); } else { print STDERR "$data"; } } # Replaces Unix "touch" once used. sub create { my ($file) = @_; open(FH, ">$file") || die "cannot create flag file \"$file\", \"$!\""; close(FH); } sub Return_Document { my ($data, $type, $fh, $connection) = @_; my $len = length($data); my $date = &Date('HTTP'); $connection = 'close' unless $connection ne ''; my $hdr = <<"END"; $Http_Version0 200 Document follows MIME-Version: 1.0 Server: $Program/$Version Date: $date Connection: $connection Content-Type: $type Content-Length: $len END my ($CR); $CR = "\r\n"; #$CR = "\n"; $hdr =~ s/\n/$CR/g; print $fh $hdr; print $fh $data; if ( $Debug ) { my $t = &tabbed_header($hdr); print STDERR "RDC:$Conn: Return_Document:\n\t$t"; } } sub Proxy_Error { my ($error_msg, $handle, $dotext, $mode, $connection) = @_; $connection = 'close' unless $connection; my ($msg); my $date = &Date('HTTP'); if ( $dotext ) { $msg = $error_msg; } my $text = <<"END_OF_TEXT"; [[defang]]: $msg END_OF_TEXT $text = '' unless $dotext; my ($CR, $hdr); $CR = "\r\n"; #$CR = "\n"; $hdr = <<"END"; MIME-Version: 1.0 Server: $Program/$Version Date: $date Connection: $connection END $hdr =~ s/\n/$CR/g; if ( $text ne '' ) { $hdr .= "Content-Type: text/html$CR"; $hdr .= "Content-Length: " . length($text) . $CR; } if ( $mode == 2 ) { $text = "$Http_Version0 202 Accepted$CR${hdr}$CR" . $text; } elsif ( $mode == 3 ) { $text = "$Http_Version0 304 Not Modified$CR${hdr}$CR" . $text; } elsif ( $mode == 4 ) { $text = "$Http_Version0 404 Not Found$CR${hdr}$CR" . $text; } elsif ( $mode == 5 ) { $text = "$Http_Version0 500 Internal Server " . "Error$CR${hdr}$CR" . $text; } if ( defined($handle) && $handle ne '' ) { print $handle $text; } if ( $Debug ) { my $t = &tabbed_header($text); print STDERR "PXY:$Conn: Proxy_Error:\n\t$t"; } return $text; } sub Subst_Gif { my ($uudata); $X_Gif = ''; $X_Jpg = ''; # red "A" on transparent background $uudata = <<'END'; M1TE&.#EA,@`4`(```/C\^/@``"'Y!`$`````+``````R`!0```(PA(^IR^T/ MHYRTVHNSOF%[TWU:%XH<4)I4F:I1`,/N>K1ST]IW$M?R#@P*A\2BL5@``#L* END $Subst_Gif[1] = unpack("u", $uudata); # purple "A" on transparent background $uudata = <<'END'; M1TE&.#EA,@`4`(```/____\`_R'Y!`$`````+``````R`!0```(PA(^IR^T/ LHYRTVHNSOF%[TWU:%XH<4)I4F:I1`,/N>K1ST]IW$M?R#@P*A\2BL5@``#L` ` END $Subst_Gif[2] = unpack("u", $uudata); # blue "X" on transparent background $uudata = <<'END'; M1TE&.#EA,@`4`(```/___P``_R'Y!`$`````+``````R`!0```(QA(^IR^T/ MHYRTVHNSIJ&;'FQ8>)#B19JG!:Z:YZ(`''-?;9=XU,[T#@P*A\2B\9@H```[ ` END #' $Subst_Gif[3] = unpack("u", $uudata); # green "A" on transparent background $uudata = <<'END'; M1TE&.#EA,@`4`(```/___P#_`"'Y!`$`````+``````R`!0```(PA(^IR^T/ LHYRTVHNSOF%[TWU:%XH<4)I4F:I1`,/N>K1ST]IW$M?R#@P*A\2BL5@``#L` ` END $Subst_Gif[4] = unpack("u", $uudata); # blue "?" on transparent background $uudata = <<'END'; M1TE&.#EA,@`4`(```/___P``_R'Y!`$`````+``````R`!0```(IA(^IR^T/ EHYRTVHNSOB'L[P'AMXTD9IY6JE9L.[WP3!MRC>?ZSO>^7@``.P`` ` END $Subst_Gif[5] = unpack("u", $uudata); # red "?" on transparent background $uudata = <<'END'; M1TE&.#EA,@`4`(```/____\``"'Y!`$`````+``````R`!0```(JA(^IR^T/ FHYRTVHM?"+DC#H#>*(Y9:5YH:JTLY;[RG,3TC>?ZSO?^/RD``#L` END #' $Question_Gif = unpack("u", $uudata); # red "?" JPG $uudata = <<'END'; M_]C_X``02D9)1@`!`0```0`!``#_VP!#``@&!@<&!0@'!P<)"0@*#!0-#`L+ M#!D2$P\4'1H?'AT:'!P@)"XG("(L(QP<*#7J#A(6&AXB)BI*3E)66EYB9FJ*CI*6FIZBIJK*SM+6VM[BYNL+#Q,7& MQ\C)RM+3U-76U]C9VN'BX^3EYN?HZ>KQ\O/T]?;W^/GZ_\0`'P$``P$!`0$! M`0$!`0````````$"`P0%!@<("0H+_\0`M1$``@$"!`0#!`<%!`0``0)W``$" M`Q$$!2$Q!A)!40=A<1,B,H$(%$*1H;'!"2,S4O`58G+1"A8D-.$E\1<8&1HF M)R@I*C4V-S@Y.D-$149'2$E*4U155E=865IC9&5F9VAI:G-T=79W>'EZ@H.$ MA8:'B(F*DI.4E9:7F)F:HJ.DI::GJ*FJLK.TM;:WN+FZPL/$Q<;'R,G*TM/4 MU=;7V-G:XN/DY>;GZ.GJ\O/T]?;W^/GZ_]H`#`,!``(1`Q$`/P#W^BBB@#.U M?49M,MQ/':>?&O,A\P*<9`"H,$O(Q("KP">"P.,Z-5+RT^TW6GRXS]EG,OW\ M8S$Z=,'/W^F1ZYXP;=2KW9I-QY(I+76_]?UO\PHHHJC,****`"BBB@`HHHH` *****`"BBB@#_V0`` END $Question_Jpg = unpack("u", $uudata); # red "X" on transparent background $uudata = <<'END'; M1TE&.#EA,@`4`(```/____\``"'Y!`$`````+``````R`!0```(PA(^IR^T/ LHYRTVHM?V&:'#'Z'"&8B66)>FG*L";BO=7J#A(6&AXB)BI*3E)66EYB9FJ*CI*6FIZBIJK*SM+6VM[BYNL+#Q,7& MQ\C)RM+3U-76U]C9VN'BX^3EYN?HZ>KQ\O/T]?;W^/GZ_\0`'P$``P$!`0$! M`0$!`0````````$"`P0%!@<("0H+_\0`M1$``@$"!`0#!`<%!`0``0)W``$" M`Q$$!2$Q!A)!40=A<1,B,H$(%$*1H;'!"2,S4O`58G+1"A8D-.$E\1<8&1HF M)R@I*C4V-S@Y.D-$149'2$E*4U155E=865IC9&5F9VAI:G-T=79W>'EZ@H.$ MA8:'B(F*DI.4E9:7F)F:HJ.DI::GJ*FJLK.TM;:WN+FZPL/$Q<;'R,G*TM/4 MU=;7V-G:XN/DY>;GZ.GJ\O/T]?;W^/GZ_]H`#`,!``(1`Q$`/P#W^BBB@#.U MO4+C2]+DO;>VBG$/SS"28QA(Q]Y\A6)P.<`9(!QDX!9I^JR:E?3_`&>*"33$ M4>5>Q3[A*_=0-N"!SE@Q&<#J&"OUN+4;C2Y+?3/*$\OR,\DS1%$/WBK*K$/C MH<<'GGT?2Y]'OKRWMX8(]'D;S8$69BTFGGOV[J_9&S1116AQA1110`4444`%%%%`!1110`4444`?_9 END #' $X_Jpg = unpack("u", $uudata); # record lengths of the Gifs to send back my $i; for ($i=0; $i <= $#Subst_Gif; $i++) { $Subst_Gif_Size[$i] = length($Subst_Gif[$i]); } } #---------------------------------------------------------------------- package Ksockets; #=========================================================================== # Ksockets v0.3: Karl's sockets. Copyright (c) 1996-2006 by Karl J. Runge # Socket macros to perl's low level socket interface. #=========================================================================== sub main'Use_Ksockets { ################################################################### # # Initialize Ksockets Package # # USAGE: # # &Use_Ksockets(); # ################################################################### if ( defined($ksockets_initialized) ) { return; } if (0) { # List of functions in this package: &main'Use_Ksockets; &main'Server; &main'Connect; &main'AcceptConnection; &main'Recv; &main'Send; &main'Ready; &main'SocketError; &main'IP_From_Name; &main'SocketInfo; &main'Local_IP; &main'spit_ksockets; &get_sock_type; # List of variables referenced: $main'Debug; } $pkg = 'Ksockets'; $Server_Handles = 'KSOCKETSSERVER00000'; $Connect_Handles = 'KSOCKETSCONNECT0000'; $Ksockets_Handle_String = 'KSOCKETS'; $AF_INET = 2; # choose INET family my $is_svr4 = ''; if ( defined($main'IS_SYSV) ) { if ( $main'IS_SYSV ) { $is_svr4 = 1; } else { $is_svr4 = 0; } } elsif ( defined($main'Is_Sysv) ) { if ( $main'Is_Sysv ) { $is_svr4 = 1; } else { $is_svr4 = 0; } } else { if ( -x "/bin/uname" || -x "/usr/bin/uname" ) { # OK, this is quite a hack... my $osname = `uname -s`; my $release = `uname -r`; if ( $osname =~ /sunos/i && $release !~ /^4\./ ) { $is_svr4 = 1; } # add others ... } } if ( ! $is_svr4 ) { $SOCK_STREAM = 1; # BSD flavor $SOCK_DGRAM = 2; # known to work on Linux # SunOS 4. } else { $SOCK_STREAM = 2; # SVR4 flavor $SOCK_DGRAM = 1; # known to work on solaris } # todo: SOCK_RAW SOCK_SEQPACKET SOCK_RDM $Default_Proto = 'tcp'; $Default_Backlog = '8'; # template for packing socket address into binary. $SockAddr = 'S n a4 x8'; if ( $main'Local ne '' ) { $Hostname = $main'Local; } else { chop($Hostname = `hostname`); } my($name,$aliases,$type,$len,$localaddr) = gethostbyname($Hostname); $Local_IP = join('.', unpack('C4',$localaddr)); $ksockets_initialized = 1; } # end Use_Ksockets sub main'Server { ################################################################### # # Open a listening socket on a port. # # USAGE: # # $file_handle = &Server($port, $backlog[OPT], $proto_in[OPT]) # # Then use $file_handle in &AcceptConnection($file_handle) calls # Test for errors via a call to: &SocketError($file_handle) # # e.g: # $Server = &Server('8888'); # die "$Server" if &SocketError($Server); # ($Client) = &AcceptConnection($Server); # die "$Client" if &SocketError($Client); # ... ################################################################### my($port, $backlog, $proto_in) = @_; my($name, $aliases, $proto); if ( !defined($proto_in) || $proto_in eq '' ) { $proto_in = $Default_Proto; } if ($port !~ /^\d+$/) { # port could be "smtp" though not likely ($name, $aliases, $port, $proto) = getservbyname($port, $proto_in); } ($name, $aliases, $proto) = getprotobyname($proto_in); $backlog = $Default_Backlog unless $backlog; print STDERR "Server:port:$port\n" if $main'Debug; # pack our address my $us = pack($SockAddr, $AF_INET, $port, "\0\0\0\0"); my $listen = ++$Server_Handles; # force filehandles into callers' package my $package = caller; $listen =~ s/^[^']+$/$package'$&/; my $old = select($listen); $| = 1; select($old); my $SOCK_TYPE = &get_sock_type($proto_in); if ( ! socket($listen, $AF_INET, $SOCK_TYPE, $proto) ) { return "Error:$pkg:Server:socket($listen, $AF_INET, $SOCK_TYPE, $proto): \"$!\""; } if ( ! bind($listen, $us) ) { return "Error:$pkg:Server:bind($listen, SOCKADDR): \"$!\""; } if ( $proto_in eq 'tcp' ) { if ( ! listen($listen, $backlog) ) { return "Error:$pkg:Server:listen($listen, $backlog): \"$!\""; } } return $listen; } # end Server sub main'Connect { ################################################################### # # Make a connection to a remote host port. # # USAGE: # # ($file_handle, $host_ip, $Local_IP, $host_sockaddr, $local_sockaddr) = # &Connect($host, $port, $proto_in[OPT]) # # Then use $file_handle in to read and write from remote connection # # Test for errors via a call to: &SocketError($file_handle) # # Use $host_ip and $local_ip as IP address information. # The $host_sockaddr and $local_sockaddr are packed socket addresses # for us in connectionless sockets (e.g. 'udp') # # e.g: # ($Remote) = &Connect('www.netscape.com', '80'); # die "$Remote" if &SocketError($Remote); # ... ################################################################### my($host, $port, $proto_in) = @_; my($name, $aliases, $proto); my($type,$len); my($local_addr, $local_sockaddr); # , $local_ip); my($host_addr, $host_sockaddr, $host_ip); if ( !defined($proto_in) || $proto_in eq '' ) { $proto_in = $Default_Proto; } if ($port !~ /^\d+$/) { # port could be "smtp" ($name, $aliases, $port, $proto) = getservbyname($port, $proto_in); if ( $port eq '' ) { return ("Error:$pkg:Connect:getservbyname($port, $proto_in): Empty port returned", '', '', '', ''); } } ($name, $aliases, $proto) = getprotobyname($proto_in); if ( !defined($proto) || $proto eq '' ) { return ("Error:$pkg:Connect:getprotobyname($proto_in): Empty proto returned", '', '', '', ''); } if ( $host =~ /^\d+/ ) { $host_ip = $host; $host_addr = pack('C4', split(/\./, $host, 4)); } else { ($name,$aliases,$type,$len,$host_addr) = gethostbyname($host); if ( !defined($host_addr) || $host_addr eq '' ) { return ("Error:$pkg:Connect:gethostbyname($host): Empty host_addr returned", '', '', '', ''); } $host_ip = join('.', unpack('C4', $host_addr)); } # $local_addr = pack('C4', split(/\./, $Local_IP, 4)); $local_addr = pack('C4', split(/\./, "0.0.0.0", 4)); $local_sockaddr = pack($SockAddr, $AF_INET, 0, $local_addr); $host_sockaddr = pack($SockAddr, $AF_INET, $port, $host_addr); my $connection = ++$Connect_Handles; # force filehandles into callers' package my $package = caller; $connection =~ s/^[^']+$/$package'$&/; my $old = select($connection); $| = 1; select($old); my $SOCK_TYPE = &get_sock_type($proto_in); if ( ! socket($connection, $AF_INET, $SOCK_TYPE, $proto) ) { return ("Error:$pkg:Connect:socket($connection, $AF_INET, $SOCK_TYPE, $proto): \"$!\"", '', '', '', ''); } if ( ! bind($connection, $local_sockaddr) ) { return ("Error:$pkg:Connect:bind($connection, $Local_IP): \"$!\"", '', '', '', ''); } if ( $proto_in eq 'tcp' ) { if ( ! connect($connection, $host_sockaddr) ) { return ("Error:$pkg:Connect:connect($connection, $host_ip): \"$!\"", '', '', '', ''); } } return ($connection, $host_ip, $Local_IP, $host_sockaddr, $local_sockaddr); } # end Connect sub main'AcceptConnection { ################################################################### # # Wait for and accept a connection on a listening port. # # Listening port created with &Server(); # # USAGE: # # ($file_handle, $address, $client_port) = # &AcceptConnection($listen_file_handle)) # # Then use $file_handle in to read and write from remote connection # Test for errors via a call to: &SocketError($file_handle) # # e.g: # ($OurService) = &Server('8888'); # die "$OurService" if &SocketError($OurService); # ($Guest) = &AcceptConnection($OurService); # die "$Guest" if &SocketError($Guest); # ... ################################################################### my($listen_socket) = @_; my $real_socket = ++$Server_Handles; # force filehandles into callers' package my $package = caller; $real_socket =~ s/^[^']+$/$package'$&/; my $old = select($real_socket); $| = 1; select($old); my $address = ''; my $fail = ''; ($address = accept($real_socket, $listen_socket)) || ($fail = "Error:$pkg:AcceptConnection:accept($real_socket, $listen_socket): \"$!\""); if ( $fail ne '' ) { close($real_socket); return ($fail, '', ''); } my($af,$c_port,$inetaddr) = unpack($SockAddr,$address); $address = join('.', unpack('C4',$inetaddr)); return ($real_socket, $address, $c_port); } # end AcceptConnection sub main'Ready { ################################################################### # # See if a socket handle is ready to be read or written to. # # USAGE: # # ($handle_ready, $time_left ) = # &Ready($socket_handle, $time_out, $mode[OPT]) # # Given handle will be checked for readiness up to $time_out seconds # Default for $mode is 'read', but it could be 'write' or 'error' # # $handle_ready will be the integer result of the select() call, # i.e. the number of 'ready' handles. Should be 0 (problem) or # 1 (handle ready). # # If time_out is undef, it should block waiting for readiness. # # E.g.: # ($ready) = &Ready($socket, '30'); # if ($ready) { # # } else { # # } # ################################################################### my($socket, $time_out, $mode) = @_; my($handle_ready, $time_left, $in, $out) = ('', '', '',''); vec($in, fileno($socket), 1) = 1; # note, the $out = $in stuff is not useful since they are # reset every time. if ( ! defined($mode) || $mode eq 'read' ) { ($handle_ready, $time_left) = select($out = $in, undef, undef, $time_out); } elsif ( $mode eq 'write' ) { ($handle_ready, $time_left) = select(undef, $out = $in, undef, $time_out); } elsif ( $mode eq 'error' ) { ($handle_ready, $time_left) = select(undef, undef, $out = $in, $time_out); } elsif ( $mode eq 'sleep' ) { # undoc'd floating pt sleep ($handle_ready, $time_left) = select(undef, undef, undef, $time_out); } else { # should handle error case better $handle_ready = undef; $time_left = 'Error:Ready:unknown mode'; } return ($handle_ready, $time_left); } # end Ready sub main'Recv { ################################################################### # # Receive data from a socket. # # USAGE: # # ($data, $recv_address_info ) = &Recv($socket_handle, $size) # # ################################################################### my($socket, $size) = @_; my($recv_info, $buf) = ('', ''); $recv_info = recv($socket, $buf, $size, 0); return ($buf, $recv_info); } # end Recv sub main'Send { ################################################################### # # Send data to a socket. # # USAGE: # # $nchars = &Send($socket_handle, $message, $TO[OPT]) # # $nchars is number of characters sent. # optional $TO is for 'udp' sockets. The Remote sockaddr # returned on Connect() say. # # ################################################################### my($socket, $message, $to) = @_; my $send_info = ''; if ( !defined($to) || $to eq '' ) { $send_info = send($socket, $message, 0); } else { $send_info = send($socket, $message, 0, $to); } if ( !defined($send_info) ) { $send_info = "Error:$pkg:Send:send($socket, $message, 0, $to): \"$!\""; } return $send_info; } # end Send sub main'SocketError { ################################################################### # # Test for error on a Ksocket command. # # USAGE: # # ($socket_file_handle, .... ) = &Ksocket_Command(...) # # Ksocket_Command can be: # Server() # Connect() # AcceptConnection() # IP_From_Name() # # $error = &SocketError($socket_file_handle) # # if ( $error ) { # # } else { # # } # ################################################################### my($msg) = @_; if ( $msg =~ /^\s*$/ ) { return 1; } if ( $msg =~ /^\s*ERROR/i ) { return 1; } if ( $msg !~ /$Ksockets_Handle_String/ && $msg !~ /^\d+\.\d+\.\d+\.\d+$/ ) { return 1; } return 0; } # end SocketError sub main'IP_From_Name { ################################################################### # # Translate a machine host name into IP number nnn.nnn.nnn.nnn # # USAGE: # # $ip_number = &IP_From_Name($name) # # e.g. # $ip_number = &IP_From_Name('www.netscape.com'); # die "$ip_number" if &SocketError($ip_number); # ... # ################################################################### my($input_name) = @_; my($remote_address); my($name, $aliases, $type, $len, $ip); if ( $input_name =~ /^\d+\./ ) { return $input_name; } # Turn name -> ddd.ddd.ddd.ddd ($name,$aliases,$type,$len,$remote_address) = gethostbyname($input_name); if ( !defined($remote_address) || $remote_address eq '' ) { return "Error:$pkg:IP_From_Name:gethostbyname($input_name): \"$!\""; } $ip = join(".", unpack('C4',$remote_address)); return $ip; } # end IP_From_Name sub main'SocketInfo { ################################################################### # # Translate a internal address format into human readable information # # USAGE: # # ($r_port, $r_ip, $af) = &SocketInfo($address) # # $address comes from some socket operation, like recv # NOTE: not finished # ################################################################### my($input_address) = @_; my($af, $remote_port, $remote_address) = unpack($SockAddr, $input_address); $remote_address = join('.', unpack('C4', $remote_address)); return ($remote_port, $remote_address, $af) } # end SocketInfo sub get_sock_type { ################################################################### # # INTERNAL ROUTINE not available in main'. # # Translate string protocol name (e.g. tcp or udp) # into Socket type. # # USAGE: # # $SOCK_TYPE = &get_sock_type($name) # # e.g. # $SOCK_TYPE = &get_sock_type('udp'); # ... # ################################################################### my($name) = @_; if ( $name eq 'tcp' || $name eq '' ) { return $SOCK_STREAM; } elsif ( $name eq 'udp' ) { return $SOCK_DGRAM; } } # end get_sock_type sub main'Local_IP { my($ip) = @_; if ( $ip ne '' ) { $Local_IP = $ip; } return $Local_IP; } # end Local_IP sub main'spit_ksockets { open(THIS_FILE, "$0"); my $ok_to_print = ''; my $first = 1; while () { if (0 && $first ) { $first = ''; print STDOUT <<'EOQ'; #!/bin/sh -- # A comment mentioning perl, to prevent perl from looping. Indented to work with bash. eval 'exec perl -S $0 ${1+"$@"}' if 0; EOQ print STDOUT "\n"; print STDOUT "&Use_Ksockets();\n"; print STDOUT "\n"; print STDOUT "#----------------------------------------------------------------------\n"; } if ( /^package Ksockets/ ) { $ok_to_print = 1; } print STDOUT if $ok_to_print; if ( /^[\s\#]*END OF PACKAGE Ksockets/ ) { $ok_to_print = ''; } } } # END OF PACKAGE Ksockets