summaryrefslogtreecommitdiff
path: root/win32/bin
diff options
context:
space:
mode:
authorPerl 5 Porters <perl5-porters@africa.nicoh.com>1997-01-29 18:11:00 +1200
committerChip Salzenberg <chip@atlantic.net>1997-01-29 18:11:00 +1200
commit0a753a764065f2260004b6e6975085378b850346 (patch)
treee5163ab53209cc4bf655cabaf4067f18036a9106 /win32/bin
parent4b094ceb80288fc9f7c15ae78fc662051510284d (diff)
downloadperl-0a753a764065f2260004b6e6975085378b850346.tar.gz
[inseparable changes from patch from perl5.003_23 to perl5.003_24]perl-5.003_24
CORE LANGUAGE CHANGES Subject: glob defaults to $_ Date: Mon, 27 Jan 1997 03:09:13 -0500 From: Gurusamy Sarathy <gsar@engin.umich.edu> Files: op.c opcode.pl pod/perlfunc.pod t/op/glob.t private-msgid: <199701270809.DAA00934@aatma.engin.umich.edu> Subject: Re: an overloading bug Date: Sun, 26 Jan 1997 19:07:45 -0500 From: Gurusamy Sarathy <gsar@engin.umich.edu> Files: pod/perldiag.pod pod/perlfunc.pod pp_ctl.c private-msgid: <199701270007.TAA26525@aatma.engin.umich.edu> CORE PORTABILITY Subject: Win32 port From: Gary Ng <71564.1743@compuserve.com> Files: MANIFEST win32/* Subject: Amiga files Date: Sun, 26 Jan 1997 17:42:15 +0100 From: Norbert Pueschel <pueschel@imsdd.meb.uni-bonn.de> Files: MANIFEST README.amiga hints/amigaos.sh private-msgid: <77724712@Armageddon.meb.uni-bonn.de> DOCUMENTATION Subject: perldelta Fcntl enhancement Date: Sat, 25 Jan 1997 17:05:34 +0200 (EET) From: Jarkko Hietaniemi <jhi@cc.hut.fi> Files: pod/perldelta.pod private-msgid: <199701251505.RAA22159@alpha.hut.fi> Subject: Updates to perldelta re: Fcntl, DB_File, Net::Ping From: Paul Marquess <pmarquess@bfsec.bt.co.uk> Files: pod/perldelta.pod Subject: Document restrictions on gv_fetchmethod() and perl_call_sv() From: Chip Salzenberg <chip@atlantic.net> Files: pod/perldelta.pod pod/perlguts.pod Subject: perldiag.pod: No comma allowed after %s Date: Sat, 25 Jan 1997 17:41:53 +0200 (EET) From: Jarkko Hietaniemi <Jarkko.Hietaniemi@cc.hut.fi> Files: pod/perldiag.pod private-msgid: <199701251541.RAA04120@alpha.hut.fi> Subject: perlfunc.pod: localtime Date: Sat, 25 Jan 1997 18:29:37 +0200 (EET) From: Jarkko Hietaniemi <jhi@cc.hut.fi> Files: pod/perlfunc.pod private-msgid: <199701251629.SAA08114@alpha.hut.fi> Subject: perlfunc diff: gmtime Date: Tue, 28 Jan 1997 14:52:08 +0000 From: Peter Haworth <pmh@edison.ioppublishing.com> Files: pod/perlfunc.pod private-msgid: <32EE1298.7B90@edison.ioppublishing.com> Subject: Updates to guts Date: Sun, 26 Jan 1997 19:34:18 -0500 (EST) From: Ilya Zakharevich <ilya@math.ohio-state.edu> Files: pod/perlguts.pod private-msgid: <199701270034.TAA13177@monk.mps.ohio-state.edu> TESTS Subject: New test op/closure.t From: Tom Phoenix <rootbeer@teleport.com> Files: MANIFEST t/op/closure.t
Diffstat (limited to 'win32/bin')
-rw-r--r--win32/bin/PL2BAT.BAT40
-rw-r--r--win32/bin/network.pl211
-rw-r--r--win32/bin/search.bat1873
-rw-r--r--win32/bin/test.bat143
-rw-r--r--win32/bin/webget.bat1099
-rw-r--r--win32/bin/www.pl901
6 files changed, 4267 insertions, 0 deletions
diff --git a/win32/bin/PL2BAT.BAT b/win32/bin/PL2BAT.BAT
new file mode 100644
index 0000000000..462affa7d0
--- /dev/null
+++ b/win32/bin/PL2BAT.BAT
@@ -0,0 +1,40 @@
+@rem = '
+@echo off
+perl -S %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+@rem ';
+
+$head = <<'--end--';
+@rem = '--*-Perl-*--';
+@rem = '
+@echo off
+perl -S %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+@rem ';
+--end--
+
+$tail = "__END__\n:endofperl\n";
+
+if ( @ARGV ) {
+ LOOP:
+ foreach ( @ARGV ) {
+ open( FILE, $_ );
+ @file = <FILE>;
+ if ( grep( /:endofperl/, @file ) ) {
+ warn "$_ has already been converted to a batch file!!\n";
+ next LOOP;
+ }
+ close( FILE, $_ );
+ s/\.pl//;
+ s/\.bat//;
+ open( FILE, ">$_.bat" );
+ print FILE $head, @file, $tail;
+ close( FILE );
+ }
+} else {
+ @file = <STDIN>;
+ print $head, @file, $tail;
+}
+
+__END__
+:endofperl
diff --git a/win32/bin/network.pl b/win32/bin/network.pl
new file mode 100644
index 0000000000..f49045333d
--- /dev/null
+++ b/win32/bin/network.pl
@@ -0,0 +1,211 @@
+##
+## Jeffrey Friedl (jfriedl@omron.co.jp)
+## Copyri.... ah hell, just take it.
+##
+## July 1994
+##
+package network;
+$version = "950311.5";
+
+## version 950311.5 -- turned off warnings when requiring 'socket.ph';
+## version 941028.4 -- some changes to quiet perl5 warnings.
+## version 940826.3 -- added check for "socket.ph", and alternate use of
+## socket STREAM value for SunOS5.x
+##
+
+## BLURB:
+## A few simple and easy-to-use routines to make internet connections.
+## Similar to "chat2.pl" (but actually commented, and a bit more portable).
+## Should work even on SunOS5.x.
+##
+
+##>
+##
+## connect_to() -- make an internet connection to a server.
+##
+## Two uses:
+## $error = &network'connect_to(*FILEHANDLE, $fromsockaddr, $tosockaddr)
+## $error = &network'connect_to(*FILEHANDLE, $hostname, $portnum)
+##
+## Makes the given connection and returns an error string, or undef if
+## no error.
+##
+## In the first form, FROMSOCKADDR and TOSOCKADDR are of the form returned
+## by SOCKET'GET_ADDR and SOCKET'MY_ADDR.
+##
+##<
+sub connect_to
+{
+ local(*FD, $arg1, $arg2) = @_;
+ local($from, $to) = ($arg1, $arg2); ## for one interpretation.
+ local($host, $port) = ($arg1, $arg2); ## for the other
+
+ if (defined($to) && length($from)==16 && length($to)==16) {
+ ## ok just as is
+ } elsif (defined($host)) {
+ $to = &get_addr($host, $port);
+ return qq/unknown address "$host"/ unless defined $to;
+ $from = &my_addr;
+ } else {
+ return "unknown arguments to network'connect_to";
+ }
+
+ return "connect_to failed (socket: $!)" unless &my_inet_socket(*FD);
+ return "connect_to failed (bind: $!)" unless bind(FD, $from);
+ return "connect_to failed (connect: $!)" unless connect(FD, $to);
+ local($old) = select(FD); $| = 1; select($old);
+ undef;
+}
+
+
+
+##>
+##
+## listen_at() - used by a server to indicate that it will accept requests
+## at the port number given.
+##
+## Used as
+## $error = &network'listen_at(*LISTEN, $portnumber);
+## (returns undef upon success)
+##
+## You can then do something like
+## $addr = accept(REMOTE, LISTEN);
+## print "contact from ", &network'addr_to_ascii($addr), ".\n";
+## while (<REMOTE>) {
+## .... process request....
+## }
+## close(REMOTE);
+##
+##<
+sub listen_at
+{
+ local(*FD, $port) = @_;
+ local($empty) = pack('S n a4 x8', 2 ,$port, "\0\0\0\0");
+ return "listen_for failed (socket: $!)" unless &my_inet_socket(*FD);
+ return "listen_for failed (bind: $!)" unless bind(FD, $empty);
+ return "listen_for failed (listen: $!)" unless listen(FD, 5);
+ local($old) = select(FD); $| = 1; select($old);
+ undef;
+}
+
+
+##>
+##
+## Given an internal packed internet address (as returned by &connect_to
+## or &get_addr), return a printable ``1.2.3.4'' version.
+##
+##<
+sub addr_to_ascii
+{
+ local($addr) = @_;
+ return "bad arg" if length $addr != 16;
+ return join('.', unpack("CCCC", (unpack('S n a4 x8', $addr))[2]));
+}
+
+##
+##
+## Given a host and a port name, returns the packed socket addresss.
+## Mostly for internal use.
+##
+##
+sub get_addr
+{
+ local($host, $port) = @_;
+ return $addr{$host,$port} if defined $addr{$host,$port};
+ local($addr);
+
+ if ($host =~ m/^\d+\.\d+\.\d+\.\d+$/)
+ {
+ $addr = pack("C4", split(/\./, $host));
+ }
+ elsif ($addr = (gethostbyname($host))[4], !defined $addr)
+ {
+ local(@lookup) = `nslookup $host 2>&1`;
+ if (@lookup)
+ {
+ local($lookup) = join('', @lookup[2 .. $#lookup]);
+ if ($lookup =~ m/^Address:\s*(\d+\.\d+\.\d+\.\d+)/) {
+ $addr = pack("C4", split(/\./, $1));
+ }
+ }
+ if (!defined $addr) {
+ ## warn "$host: SOL, dude\n";
+ return undef;
+ }
+ }
+ $addr{$host,$port} = pack('S n a4 x8', 2 ,$port, $addr);
+}
+
+
+##
+## my_addr()
+## Returns the packed socket address of the local host (port 0)
+## Mostly for internal use.
+##
+##
+sub my_addr
+{
+ local(@x) = gethostbyname('localhost');
+ local(@y) = gethostbyname($x[0]);
+# local($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($x[0]);
+# local(@bytes) = unpack("C4",$addrs[0]);
+# return pack('S n a4 x8', 2 ,0, $addr);
+ return pack('S n a4 x8', 2 ,0, $y[4]);
+}
+
+
+##
+## my_inet_socket(*FD);
+##
+## Local routine to do socket(PF_INET, SOCK_STREAM, AF_NS).
+## Takes care of figuring out the proper values for the args. Hopefully.
+##
+## Returns the same value as 'socket'.
+##
+sub my_inet_socket
+{
+ local(*FD) = @_;
+ local($socket);
+
+ if (!defined $socket_values_queried)
+ {
+ ## try to load some "socket.ph"
+ if (!defined &main'_SYS_SOCKET_H_) {
+ eval 'package main;
+ local($^W) = 0;
+ require("sys/socket.ph")||require("socket.ph");';
+ }
+
+ ## we'll use "the regular defaults" if for PF_INET and AF_NS if unknown
+ $PF_INET = defined &main'PF_INET ? &main'PF_INET : 2;
+ $AF_NS = defined &main'AF_NS ? &main'AF_NS : 6;
+ $SOCK_STREAM = &main'SOCK_STREAM if defined &main'SOCK_STREAM;
+
+ $socket_values_queried = 1;
+ }
+
+ if (defined $SOCK_STREAM) {
+ $socket = socket(FD, $PF_INET, $SOCK_STREAM, $AF_NS);
+ } else {
+ ##
+ ## We'll try the "regular default" of 1. If that returns a
+ ## "not supported" error, we'll try 2, which SunOS5.x uses.
+ ##
+ $socket = socket(FD, $PF_INET, 1, $AF_NS);
+ if ($socket) {
+ $SOCK_STREAM = 1; ## got it.
+ } elsif ($! =~ m/not supported/i) {
+ ## we'll just assume from now on that it's 2.
+ $socket = socket(FD, $PF_INET, $SOCK_STREAM = 2, $AF_NS);
+ }
+ }
+ $socket;
+}
+
+## This here just to quiet -w warnings.
+sub dummy {
+ 1 || $version || &dummy;
+}
+
+1;
+__END__
diff --git a/win32/bin/search.bat b/win32/bin/search.bat
new file mode 100644
index 0000000000..0bb123759f
--- /dev/null
+++ b/win32/bin/search.bat
@@ -0,0 +1,1873 @@
+@rem = '--*-Perl-*--';
+@rem = '
+@echo off
+perl -S %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+@rem ';
+#!/usr/local/bin/perl -w
+'di';
+'ig00';
+##############################################################################
+##
+## search
+##
+## Jeffrey Friedl (jfriedl@omron.co.jp), Dec 1994.
+## Copyright 19.... ah hell, just take it.
+##
+## BLURB:
+## A combo of find and grep -- more or less do a 'grep' on a whole
+## directory tree. Fast, with lots of options. Much more powerful than
+## the simple "find ... | xargs grep ....". Has a full man page.
+## Powerfully customizable.
+##
+## This file is big, but mostly comments and man page.
+##
+## See man page for usage info.
+## Return value: 2=error, 1=nothing found, 0=something found.
+##
+
+$version = "950918.5";
+##
+## "950918.5";
+## Changed all 'sysread' to 'read' because Linux perl's don't seem
+## to like sysread()
+##
+## "941227.4";
+## Added -n, -u
+##
+## "941222.3"
+## Added -nice (due to Lionel Cons <Lionel.Cons@cern.ch>)
+## Removed any leading "./" from name.
+## Added default flags for ~/.search, including TTY, -nice, -list, etc.
+## Program name now has path removed when printed in diagnostics.
+## Added simple tilde-expansion to -dir arg.
+## Added -dskip, etc. Fixed -iregex bug.
+## Changed -dir to be additive, adding -ddir.
+## Now screen out devices, pipes, and sockets.
+## More tidying and lots of expanding of the man page
+##
+##
+## "941217.2";
+## initial release.
+
+$stripped=0;
+
+&init;
+$rc_file = join('/', $ENV{'HOME'}, ".search");
+
+&check_args;
+
+## Make sure we've got a regex.
+## Don't need one if -find or -showrc was specified.
+$!=2, die "expecting regex arguments.\n"
+ if $FIND_ONLY == 0 && $showrc == 0 && @ARGV == 0;
+
+&prepare_to_search($rc_file);
+
+&import_program if !defined &dodir; ## BIG key to speed.
+
+## do search while there are directories to be done.
+&dodir(shift(@todo)) while @todo;
+
+&clear_message if $VERBOSE && $STDERR_IS_TTY;
+exit($retval);
+###############################################################################
+
+sub init
+{
+ ## initialize variables that might be reset by command-line args
+ $DOREP=0; ## set true by -dorep (redo multi-hardlink files)
+ $DO_SORT=0; ## set by -sort (sort files in a dir before checking)
+ $FIND_ONLY=0; ## set by -find (don't search files)
+ $LIST_ONLY=0; ## set true by -l (list filenames only)
+ $NEWER=0; ## set by -newer, "-mtime -###"
+ $NICE=0; ## set by -nice (print human-readable output)
+ $NOLINKS=0; ## set true by -nolinks (don't follow symlinks)
+ $OLDER=0; ## set by -older, "-mtime ###"
+ $PREPEND_FILENAME=1; ## set false by -h (don't prefix lines with filename)
+ $REPORT_LINENUM=0; ## set true by -n (show line numbers)
+ $VERBOSE=0; ## set to a value by -v, -vv, etc. (verbose messages)
+ $WHY=0; ## set true by -why, -vvv+ (report why skipped)
+ $XDEV=0; ## set true by -xdev (stay on one filesystem)
+ $all=0; ## set true by -all (don't skip many kinds of files)
+ $iflag = ''; ## set to 'i' by -i (ignore case);
+ $norc=0; ## set by -norc (don't load rc file)
+ $showrc=0; ## set by -showrc (show what happens with rc file)
+ $underlineOK=0; ## set true by -u (watch for underline stuff)
+ $words=0; ## set true by -w (match whole-words only)
+ $DELAY=0; ## inter-file delay (seconds)
+ $retval=1; ## will set to 0 if we find anything.
+
+ ## various elements of stat() that we might access
+ $STAT_DEV = 1;
+ $STAT_INODE = 2;
+ $STAT_MTIME = 9;
+
+ $VV_PRINT_COUNT = 50; ## with -vv, print every VV_PRINT_COUNT files, or...
+ $VV_SIZE = 1024*1024; ## ...every VV_SIZE bytes searched
+ $vv_print = $vv_size = 0; ## running totals.
+
+ ## set default options, in case the rc file wants them
+ $opt{'TTY'}= 1 if -t STDOUT;
+
+ ## want to know this for debugging message stuff
+ $STDERR_IS_TTY = -t STDERR ? 1 : 0;
+ $STDERR_SCREWS_STDOUT = ($STDERR_IS_TTY && -t STDOUT) ? 1 : 0;
+
+ $0 =~ s,.*/,,; ## clean up $0 for any diagnostics we'll be printing.
+}
+
+##
+## Check arguments.
+##
+sub check_args
+{
+ while (@ARGV && $ARGV[0] =~ m/^-/)
+ {
+ $arg = shift(@ARGV);
+
+ if ($arg eq '-version' || ($VERBOSE && $arg eq '-help')) {
+ print qq/Jeffrey's file search, version "$version".\n/;
+ exit(0) unless $arg eq '-help';
+ }
+ if ($arg eq '-help') {
+ print <<INLINE_LITERAL_TEXT;
+usage: $0 [options] [-e] [PerlRegex ....]
+OPTIONS TELLING *WHERE* TO SEARCH:
+ -dir DIR start search at the named directory (default is current dir).
+ -xdev stay on starting file system.
+ -sort sort the files in each directory before processing.
+ -nolinks don't follow symbolic links.
+OPTIONS TELLING WHICH FILES TO EVEN CONSIDER:
+ -mtime # consider files modified > # days ago (-# for < # days old)
+ -newer FILE consider files modified more recently than FILE (also -older)
+ -name GLOB consider files whose name matches pattern (also -regex).
+ -skip GLOB opposite of -name: identifies files to not consider.
+ -path GLOB like -name, but for files whose whole path is described.
+ -dpath/-dregex/-dskip versions for selecting or pruning directories.
+ -all don't skip any files marked to be skipped by the startup file.
+ -x<SPECIAL> (see manual, and/or try -showrc).
+ -why report why a file isn't checked (also implied by -vvvv).
+OPTIONS TELLING WHAT TO DO WITH FILES THAT WILL BE CONSIDERED:
+ -f | -find just list files (PerlRegex ignored). Default is to grep them.
+ -ff | -ffind Does a faster -find (implies -find -all -dorep)
+OPTIONS CONTROLLING HOW THE SEARCH IS DONE (AND WHAT IS PRINTED):
+ -l | -list only list files with matches, not the lines themselves.
+ -nice | -nnice print more "human readable" output.
+ -n prefix each output line with its line number in the file.
+ -h don't prefix output lines with file name.
+ -u also look "inside" manpage-style underlined text
+ -i do case-insensitive searching.
+ -w match words only (as defined by perl's \\b).
+OTHER OPTIONS:
+ -v, -vv, -vvv various levels of message verbosity.
+ -e end of options (in case a regex looks like an option).
+ -showrc show what the rc file sets, then exit.
+ -norc don't load the rc file.
+ -dorep check files with multiple hard links multiple times.
+INLINE_LITERAL_TEXT
+ print "Use -v -help for more verbose help.\n" unless $VERBOSE;
+ print "This script file is also a man page.\n" unless $stripped;
+ print <<INLINE_LITERAL_TEXT if $VERBOSE;
+
+If -f (or -find) given, PerlRegex is optional and ignored.
+Otherwise, will search for files with lines matching any of the given regexes.
+
+Combining things like -name and -mtime implies boolean AND.
+However, duplicating things (such as -name '*.c' -name '*.txt') implies OR.
+
+-mtime may be given floating point (i.e. 1.5 is a day and a half).
+-iskip/-idskip/-ipath/... etc are case-insensitive versions.
+
+If any letter in -newer/-older is upper case, "or equal" is
+inserted into the test.
+
+You can always find the latest version on the World Wide Web in
+ http://www.wg.omron.co.jp/~jfriedl/perl/
+INLINE_LITERAL_TEXT
+ exit(0);
+ }
+ $DOREP=1, next if $arg eq '-dorep'; ## do repeats
+ $DO_SORT=1, next if $arg eq '-sort'; ## sort files
+ $NOLINKS=1, next if $arg eq '-nolinks'; ## no sym. links
+ $PREPEND_FILENAME=0, next if $arg eq '-h'; ## no filename prefix
+ $REPORT_LINENUM=1, next if $arg eq '-n'; ## show line numbers
+ $WHY=1, next if $arg eq '-why'; ## tell why skipped
+ $XDEV=1, next if $arg eq '-xdev'; ## don't leave F.S.
+ $all=1,$opt{'-all'}=1,next if $arg eq '-all'; ## don't skip *.Z, etc
+ $iflag='i', next if $arg eq '-i'; ## ignore case
+ $norc=1, next if $arg eq '-norc'; ## don't load rc file
+ $showrc=1, next if $arg eq '-showrc'; ## show rc file
+ $underlineOK=1, next if $arg eq '-u'; ## look throuh underln.
+ $words=1, next if $arg eq '-w'; ## match "words" only
+ &strip if $arg eq '-strip'; ## dump this program
+ last if $arg eq '-e';
+ $DELAY=$1, next if $arg =~ m/-delay(\d+)/;
+
+ $FIND_ONLY=1, next if $arg =~/^-f(ind)?$/;## do "find" only
+
+ $FIND_ONLY=1, $DOREP=1, $all=1,
+ next if $arg =~/^-ff(ind)?$/;## fast -find
+ $LIST_ONLY=1,$opt{'-list'}=1,
+ next if $arg =~/^-l(ist)?$/;## only list files
+
+ if ($arg =~ m/^-(v+)$/) { ## verbosity
+ $VERBOSE =length($1);
+ foreach $len (1..$VERBOSE) { $opt{'-'.('v' x $len)}=1 }
+ next;
+ }
+ if ($arg =~ m/^-(n+)ice$/) { ## "nice" output
+ $NICE =length($1);
+ foreach $len (1..$NICE) { $opt{'-'.('n' x $len).'ice'}=1 }
+ next;
+ }
+
+ if ($arg =~ m/^-(i?)(d?)skip$/) {
+ local($i) = $1 eq 'i';
+ local($d) = $2 eq 'd';
+ $! = 2, die qq/$0: expecting glob arg to -$arg\n/ unless @ARGV;
+ foreach (split(/\s+/, shift @ARGV)) {
+ if ($d) {
+ $idskip{$_}=1 if $i;
+ $dskip{$_}=1;
+ } else {
+ $iskip{$_}=1 if $i;
+ $skip{$_}=1;
+ }
+ }
+ next;
+ }
+
+
+ if ($arg =~ m/^-(i?)(d?)(regex|path|name)$/) {
+ local($i) = $1 eq 'i';
+ $! = 2, die qq/$0: expecting arg to -$arg\n/ unless @ARGV;
+ foreach (split(/\s+/, shift @ARGV)) {
+ $iname{join(',', $arg, $_)}=1 if $i;
+ $name{join(',', $arg, $_)}=1;
+ }
+ next;
+ }
+
+ if ($arg =~ m/^-d?dir$/) {
+ $opt{'-dir'}=1;
+ $! = 2, die qq/$0: expecting filename arg to -$arg\n/ unless @ARGV;
+ $start = shift(@ARGV);
+ $start =~ s#^~(/+|$)#$ENV{'HOME'}$1# if defined $ENV{'HOME'};
+ $! = 2, die qq/$0: can't find ${arg}'s "$start"\n/ unless -e $start;
+ $! = 2, die qq/$0: ${arg}'s "$start" not a directory.\n/ unless -d _;
+ undef(@todo), $opt{'-ddir'}=1 if $arg eq '-ddir';
+ push(@todo, $start);
+ next;
+ }
+
+ if ($arg =~ m/^-(new|old)er$/i) {
+ $! = 2, die "$0: expecting filename arg to -$arg\n" unless @ARGV;
+ local($file, $time) = shift(@ARGV);
+ $! = 2, die qq/$0: can't stat -${arg}'s "$file"./
+ unless $time = (stat($file))[$STAT_MTIME];
+ local($upper) = $arg =~ tr/A-Z//;
+ if ($arg =~ m/new/i) {
+ $time++ unless $upper;
+ $NEWER = $time if $NEWER < $time;
+ } else {
+ $time-- unless $upper;
+ $OLDER = $time if $OLDER == 0 || $OLDER > $time;
+ }
+ next;
+ }
+
+ if ($arg =~ m/-mtime/) {
+ $! = 2, die "$0: expecting numerical arg to -$arg\n" unless @ARGV;
+ local($days) = shift(@ARGV);
+ $! = 2, die qq/$0: inappropriate arg ($days) to $arg\n/ if $days==0;
+ $days *= 3600 * 24;
+ if ($days < 0) {
+ local($time) = $^T + $days;
+ $NEWER = $time if $NEWER < $time;
+ } else {
+ local($time) = $^T - $days;
+ $OLDER = $time if $OLDER == 0 || $OLDER > $time;
+ }
+ next;
+ }
+
+ ## special user options
+ if ($arg =~ m/^-x(.+)/) {
+ foreach (split(/[\s,]+/, $1)) { $user_opt{$_} = $opt{$_}= 1; }
+ next;
+ }
+
+ $! = 2, die "$0: unknown arg [$arg]\n";
+ }
+}
+
+##
+## Given a filename glob, return a regex.
+## If the glob has no globbing chars (no * ? or [..]), then
+## prepend an effective '*' to it.
+##
+sub glob_to_regex
+{
+ local($glob) = @_;
+ local(@parts) = $glob =~ m/\\.|[*?]|\[]?[^]]*]|[^[\\*?]+/g;
+ local($trueglob)=0;
+ foreach (@parts) {
+ if ($_ eq '*' || $_ eq '?') {
+ $_ = ".$_";
+ $trueglob=1; ## * and ? are a real glob
+ } elsif (substr($_, 0, 1) eq '[') {
+ $trueglob=1; ## [..] is a real glob
+ } else {
+ s/^\\//; ## remove any leading backslash;
+ s/\W/\\$&/g; ## now quote anything dangerous;
+ }
+ }
+ unshift(@parts, '.*') unless $trueglob;
+ join('', '^', @parts, '$');
+}
+
+sub prepare_to_search
+{
+ local($rc_file) = @_;
+
+ $HEADER_BYTES=0; ## Might be set nonzero in &read_rc;
+ $last_message_length = 0; ## For &message and &clear_message.
+
+ &read_rc($rc_file, $showrc) unless $norc;
+ exit(0) if $showrc;
+
+ $NEXT_DIR_ENTRY = $DO_SORT ? 'shift @files' : 'readdir(DIR)';
+ $WHY = 1 if $VERBOSE > 3; ## Arg -vvvv or above implies -why.
+ @todo = ('.') if @todo == 0; ## Where we'll start looking
+
+ ## see if any user options were specified that weren't accounted for
+ foreach $opt (keys %user_opt) {
+ next if defined $seen_opt{$opt};
+ warn "warning: -x$opt never considered.\n";
+ }
+
+ die "$0: multiple time constraints exclude all possible files.\n"
+ if ($NEWER && $OLDER) && ($NEWER > $OLDER);
+
+ ##
+ ## Process any -skip/-iskip args that had been given
+ ##
+ local(@skip_test);
+ foreach $glob (keys %skip) {
+ $i = defined($iskip{$glob}) ? 'i': '';
+ push(@skip_test, '$name =~ m/'. &glob_to_regex($glob). "/$i");
+ }
+ if (@skip_test) {
+ $SKIP_TEST = join('||',@skip_test);
+ $DO_SKIP_TEST = 1;
+ } else {
+ $DO_SKIP_TEST = $SKIP_TEST = 0;
+ }
+
+ ##
+ ## Process any -dskip/-idskip args that had been given
+ ##
+ local(@dskip_test);
+ foreach $glob (keys %dskip) {
+ $i = defined($idskip{$glob}) ? 'i': '';
+ push(@dskip_test, '$name =~ m/'. &glob_to_regex($glob). "/$i");
+ }
+ if (@dskip_test) {
+ $DSKIP_TEST = join('||',@dskip_test);
+ $DO_DSKIP_TEST = 1;
+ } else {
+ $DO_DSKIP_TEST = $DSKIP_TEST = 0;
+ }
+
+
+ ##
+ ## Process any -name, -path, -regex, etc. args that had been given.
+ ##
+ undef @name_test;
+ undef @dname_test;
+ foreach $key (keys %name) {
+ local($type, $pat) = split(/,/, $key, 2);
+ local($i) = defined($iname{$key}) ? 'i' : '';
+ if ($type =~ /regex/) {
+ $pat =~ s/!/\\!/g;
+ $test = "\$name =~ m!^$pat\$!$i";
+ } else {
+ local($var) = $type eq 'name' ? '$name' : '$file';
+ $test = "$var =~ m/". &glob_to_regex($pat). "/$i";
+ }
+ if ($type =~ m/^-i?d/) {
+ push(@dname_test, $test);
+ } else {
+ push(@name_test, $test);
+ }
+ }
+ if (@name_test) {
+ $GLOB_TESTS = join('||', @name_test);
+
+ $DO_GLOB_TESTS = 1;
+ } else {
+ $GLOB_TESTS = $DO_GLOB_TESTS = 0;
+ }
+ if (@dname_test) {
+ $DGLOB_TESTS = join('||', @dname_test);
+ $DO_DGLOB_TESTS = 1;
+ } else {
+ $DGLOB_TESTS = $DO_DGLOB_TESTS = 0;
+ }
+
+
+ ##
+ ## Process any 'magic' things from the startup file.
+ ##
+ if (@magic_tests && $HEADER_BYTES) {
+ ## the $magic' one is for when &dodir is not inlined
+ $tests = join('||',@magic_tests);
+ $MAGIC_TESTS = " { package magic; \$val = ($tests) }";
+ $DO_MAGIC_TESTS = 1;
+ } else {
+ $MAGIC_TESTS = 1;
+ $DO_MAGIC_TESTS = 0;
+ }
+
+ ##
+ ## Prepare regular expressions.
+ ##
+ {
+ local(@regex_tests);
+
+ if ($LIST_ONLY) {
+ $mflag = '';
+ ## need to have $* set, but perl5 just won''t shut up about it.
+ if ($] >= 5) {
+ $mflag = 'm';
+ } else {
+ eval ' $* = 1 ';
+ }
+ }
+
+ ##
+ ## Until I figure out a better way to deal with it,
+ ## We have to worry about a regex like [^xyz] when doing $LIST_ONLY.
+ ## Such a regex *will* match \n, and if I'm pulling in multiple
+ ## lines, it can allow lines to match that would otherwise not match.
+ ##
+ ## Therefore, if there is a '[^' in a regex, we can NOT take a chance
+ ## an use the fast listonly.
+ ##
+ $CAN_USE_FAST_LISTONLY = $LIST_ONLY;
+
+ local(@extra);
+ local($underline_glue) = ($] >= 5) ? '(:?_\cH)?' : '(_\cH)?';
+ while (@ARGV) {
+ $regex = shift(@ARGV);
+ ##
+ ## If watching for underlined things too, add another regex.
+ ##
+ if ($underlineOK) {
+ if ($regex =~ m/[?*+{}()\\.|^\$[]/) {
+ warn "$0: warning, can't underline-safe ``$regex''.\n";
+ } else {
+ $regex = join($underline_glue, split(//, $regex));
+ }
+ }
+
+ ## If nothing special in the regex, just use index...
+ ## is quite a bit faster.
+ if (($iflag eq '') && ($words == 0) &&
+ $regex !~ m/[?*+{}()\\.|^\$[]/)
+ {
+ push(@regex_tests, "(index(\$_, q+$regex+)>=0)");
+
+ } else {
+ $regex =~ s#[\$\@\/]\w#\\$&#;
+ if ($words) {
+ if ($regex =~ m/\|/) {
+ ## could be dangerous -- see if we can wrap in parens.
+ if ($regex =~ m/\\\d/) {
+ warn "warning: -w and a | in a regex is dangerous.\n"
+ } else {
+ $regex = join($regex, '(', ')');
+ }
+ }
+ $regex = join($regex, '\b', '\b');
+ }
+ $CAN_USE_FAST_LISTONLY = 0 if substr($regex, "[^") >= 0;
+ push(@regex_tests, "m/$regex/$iflag$mflag");
+ }
+
+ ## If we're done, but still have @extra to do, get set for that.
+ if (@ARGV == 0 && @extra) {
+ @ARGV = @extra; ## now deal with the extra stuff.
+ $underlineOK = 0; ## but no more of this.
+ undef @extra; ## or this.
+ }
+ }
+ if (@regex_tests) {
+ $REGEX_TEST = join('||', @regex_tests);
+ ## print STDERR $REGEX_TEST, "\n"; exit;
+ } else {
+ ## must be doing -find -- just give something syntactically correct.
+ $REGEX_TEST = 1;
+ }
+ }
+
+ ##
+ ## Make sure we can read the first item(s).
+ ##
+ foreach $start (@todo) {
+ $! = 2, die qq/$0: can't stat "$start"\n/
+ unless ($dev,$inode) = (stat($start))[$STAT_DEV,$STAT_INODE];
+
+ if (defined $dir_done{"$dev,$inode"}) {
+ ## ignore the repeat.
+ warn(qq/ignoring "$start" (same as "$dir_done{"$dev,$inode"}").\n/)
+ if $VERBOSE;
+ next;
+ }
+
+ ## if -xdev was given, remember the device.
+ $xdev{$dev} = 1 if $XDEV;
+
+ ## Note that we won't want to do it again
+ $dir_done{"$dev,$inode"} = $start;
+ }
+}
+
+
+##
+## See the comment above the __END__ above the 'sub dodir' below.
+##
+sub import_program
+{
+ sub bad {
+ print STDERR "$0: internal error (@_)\n";
+ exit 2;
+ }
+
+ ## Read from data, up to next __END__. This will be &dodir.
+ local($/) = "\n__END__";
+ $prog = <DATA>;
+ close(DATA);
+
+ $prog =~ s/\beval\b//g; ## remove any 'eval'
+
+ ## Inline uppercase $-variables by their current values.
+ if ($] >= 5) {
+ $prog =~ s/\$([A-Z][A-Z0-9_]{2,}\b)/
+ &bad($1) if !defined ${$main::{$1}}; ${$main::{$1}};/eg;
+ } else {
+ $prog =~ s/\$([A-Z][A-Z0-9_]{2,}\b)/local(*VAR) = $_main{$1};
+ &bad($1) if !defined $VAR; $VAR;/eg;
+ }
+
+ eval $prog; ## now do it. This will define &dodir;
+ $!=2, die "$0 internal error: $@\n" if $@;
+}
+
+###########################################################################
+
+##
+## Read the .search file:
+## Blank lines and lines that are only #-comments ignored.
+## Newlines may be escaped to create long lines
+## Other lines are directives.
+##
+## A directive may begin with an optional tag in the form <...>
+## Things inside the <...> are evaluated as with:
+## <(this || that) && must>
+## will be true if
+## -xmust -xthis or -xmust -xthat
+## were specified on the command line (order doesn't matter, though)
+## A directive is not done if there is a tag and it's false.
+## Any characters but whitespace and &|()>,! may appear after an -x
+## (although "-xdev" is special). -xmust,this is the same as -xmust -xthis.
+## Something like -x~ would make <~> true, and <!~> false.
+##
+## Directives are in the form:
+## option: STRING
+## magic : NUMBYTES : EXPR
+##
+## With option:
+## The STRING is parsed like a Bourne shell command line, and the
+## options are used as if given on the command line.
+## No comments are allowed on 'option' lines.
+## Examples:
+## # skip objects and libraries
+## option: -skip '.o .a'
+## # skip emacs *~ and *# files, unless -x~ given:
+## <!~> option: -skip '~ #'
+##
+## With magic:
+## EXPR can be pretty much any perl (comments allowed!).
+## If it evaluates to true for any particular file, it is skipped.
+## The only info you'll have about a file is the variable $H, which
+## will have at least the first NUMBYTES of the file (less if the file
+## is shorter than that, of course, and maybe more). You'll also have
+## any variables you set in previous 'magic' lines.
+## Examples:
+## magic: 6 : ($x6 = substr($H, 0, 6)) eq 'GIF87a'
+## magic: 6 : $x6 eq 'GIF89a'
+##
+## magic: 6 : (($x6 = substr($H, 0, 6)) eq 'GIF87a' ## old gif \
+## || $x6 eq 'GIF89a' ## new gif
+## (the above two sets are the same)
+## ## Check the first 32 bytes for "binarish" looking bytes.
+## ## Don't blindly dump on any high-bit set, as non-ASCII text
+## ## often has them set. \x80 and \xff seem to be special, though.
+## ## Require two in a row to not get things like perl's $^T.
+## ## This is known to get *.Z, *.gz, pkzip, *.elc and about any
+## ## executable you'll find.
+## magic: 32 : $H =~ m/[\x00-\x06\x10-\x1a\x1c-\x1f\x80\xff]{2}/
+##
+sub read_rc
+{
+ local($file, $show) = @_;
+ local($line_num, $ln, $tag) = 0;
+ local($use_default, @default) = 0;
+
+ { package magic; $ = 0; } ## turn off warnings for when we run EXPR's
+
+ unless (open(RC, "$file")) {
+ $use_default=1;
+ $file = "<internal default startup file>";
+ ## no RC file -- use this default.
+ @default = split(/\n/,<<'--------INLINE_LITERAL_TEXT');
+ magic: 32 : $H =~ m/[\x00-\x06\x10-\x1a\x1c-\x1f\x80\xff]{2}/
+ option: -skip '.a .COM .elc .EXE .gz .o .pbm .xbm .dvi'
+ option: -iskip '.tarz .zip .z .lzh .jpg .jpeg .gif .uu'
+ <!~> option: -skip '~ #'
+--------INLINE_LITERAL_TEXT
+ }
+
+ ##
+ ## Make an eval error pretty.
+ ##
+ sub clean_eval_error {
+ local($_) = @_;
+ s/ in file \(eval\) at line \d+,//g; ## perl4-style error
+ s/ at \(eval \d+\) line \d+,//g; ## perl5-style error
+ $_ = $` if m/\n/; ## remove all but first line
+ "$_\n";
+ }
+
+ print "reading RC file: $file\n" if $show;
+
+ while ($_ = ($use_default ? shift(@default) : <RC>)) {
+ $ln = ++$line_num; ## note starting line num.
+ $_ .= <RC>, $line_num++ while s/\\\n?$/\n/; ## allow continuations
+ next if /^\s*(#.*)?$/; ## skip blank or comment-only lines.
+ $do = '';
+
+ ## look for an initial <...> tag.
+ if (s/^\s*<([^>]*)>//) {
+ ## This simple s// will make the tag ready to eval.
+ ($tag = $msg = $1) =~
+ s/[^\s&|(!)]+/
+ $seen_opt{$&}=1; ## note seen option
+ "defined(\$opt{q>$&>})" ## (q>> is safe quoting here)
+ /eg;
+
+ ## see if the tag is true or not, abort this line if not.
+ $dothis = (eval $tag);
+ $!=2, die "$file $ln <$msg>: $_".&clean_eval_error($@) if $@;
+
+ if ($show) {
+ $msg =~ s/[^\s&|(!)]+/-x$&/;
+ $msg =~ s/\s*!\s*/ no /g;
+ $msg =~ s/\s*&&\s*/ and /g;
+ $msg =~ s/\s*\|\|\s*/ or /g;
+ $msg =~ s/^\s+//; $msg =~ s/\s+$//;
+ $do = $dothis ? "(doing because $msg)" :
+ "(do if $msg)";
+ } elsif (!$dothis) {
+ next;
+ }
+ }
+
+ if (m/^\s*option\s*:\s*/) {
+ next if $all && !$show; ## -all turns off these checks;
+ local($_) = $';
+ s/\n$//;
+ local($orig) = $_;
+ print " $do option: $_\n" if $show;
+ local($0) = "$0 ($file)"; ## for any error message.
+ local(@ARGV);
+ local($this);
+ ##
+ ## Parse $_ as a Bourne shell line -- fill @ARGV
+ ##
+ while (length) {
+ if (s/^\s+//) {
+ push(@ARGV, $this) if defined $this;
+ undef $this;
+ next;
+ }
+ $this = '' if !defined $this;
+ $this .= $1 while s/^'([^']*)'// ||
+ s/^"([^"]*)"// ||
+ s/^([^'"\s\\]+)//||
+ s/^(\\[\D\d])//;
+ die "$file $ln: error parsing $orig at $_\n" if m/^\S/;
+ }
+ push(@ARGV, $this) if defined $this;
+ &check_args;
+ die qq/$file $ln: unused arg "@ARGV".\n/ if @ARGV;
+ next;
+ }
+
+ if (m/^\s*magic\s*:\s*(\d+)\s*:\s*/) {
+ next if $all && !$show; ## -all turns off these checks;
+ local($bytes, $check) = ($1, $');
+
+ if ($show) {
+ $check =~ s/\n?$/\n/;
+ print " $do contents: $check";
+ }
+ ## Check to make sure the thing at least compiles.
+ eval "package magic; (\$H = '1'x \$main'bytes) && (\n$check\n)\n";
+ $! = 2, die "$file $ln: ".&clean_eval_error($@) if $@;
+
+ $HEADER_BYTES = $bytes if $bytes > $HEADER_BYTES;
+ push(@magic_tests, "(\n$check\n)");
+ next;
+ }
+ $! = 2, die "$file $ln: unknown command\n";
+ }
+ close(RC);
+}
+
+sub message
+{
+ if (!$STDERR_IS_TTY) {
+ print STDERR $_[0], "\n";
+ } else {
+ local($text) = @_;
+ $thislength = length($text);
+ if ($thislength >= $last_message_length) {
+ print STDERR $text, "\r";
+ } else {
+ print STDERR $text, ' 'x ($last_message_length-$thislength),"\r";
+ }
+ $last_message_length = $thislength;
+ }
+}
+
+sub clear_message
+{
+ print STDERR ' ' x $last_message_length, "\r" if $last_message_length;
+ $vv_print = $vv_size = $last_message_length = 0;
+}
+
+##
+## Output a copy of this program with comments, extra whitespace, and
+## the trailing man page removed. On an ultra slow machine, such a copy
+## might load faster (but I can't tell any difference on my machine).
+##
+sub strip {
+ seek(DATA, 0, 0) || die "$0: can't reset internal pointer.\n";
+ while(<DATA>) {
+ print, next if /INLINE_LITERAL_TEXT/.../INLINE_LITERAL_TEXT/;
+ ## must mention INLINE_LITERAL_TEXT on this line!
+ s/\#\#.*|^\s+|\s+$//; ## remove cruft
+ last if $_ eq '.00;';
+ next if ($_ eq '') || ($_ eq "'di'") || ($_ eq "'ig00'");
+ s/\$stripped=0;/\$stripped=1;/;
+ s/\s\s+/ /; ## squish multiple whitespaces down to one.
+ print $_, "\n";
+ }
+ exit(0);
+}
+
+##
+## Just to shut up -w. Never executed.
+##
+sub dummy {
+
+ 1 || &dummy || &dir_done || &bad || &message || $NEXT_DIR_ENTRY ||
+ $DELAY || $VV_SIZE || $VV_PRINT_COUNT || $STDERR_SCREWS_STDOUT ||
+ @files || @files || $magic'H || $magic'H || $xdev{''} || &clear_message;
+
+}
+
+##
+## If the following __END__ is in place, what follows will be
+## inlined when the program first starts up. Any $ variable name
+## all in upper case, specifically, any string matching
+## \$([A-Z][A-Z0-9_]{2,}\b
+## will have the true value for that variable inlined. Also, any 'eval' is
+## removed
+##
+## The idea is that when the whole thing is then eval'ed to define &dodir,
+## the perl optimizer will make all the decisions that are based upon
+## command-line options (such as $VERBOSE), since they'll be inlined as
+## constants
+##
+## Also, and here's the big win, the tests for matching the regex, and a
+## few others, are all inlined. Should be blinding speed here.
+##
+## See the read from <DATA> above for where all this takes place.
+## But all-in-all, you *want* the __END__ here. Comment it out only for
+## debugging....
+##
+
+__END__
+
+##
+## Given a directory, check all "appropriate" files in it.
+## Shove any subdirectories into the global @todo, so they'll be done
+## later.
+##
+## Be careful about adding any upper-case variables, as they are subject
+## to being inlined. See comments above the __END__ above.
+##
+sub dodir
+{
+ local($dir) = @_;
+ $dir =~ s,/+$,,; ## remove any trailing slash.
+ unless (opendir(DIR, "$dir/.")) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ warn qq($0: can't opendir "$dir/".\n);
+ return;
+ }
+
+ if ($VERBOSE) {
+ &message($dir);
+ $vv_print = $vv_size = 0;
+ }
+
+ @files = sort readdir(DIR) if $DO_SORT;
+
+ while (defined($name = eval $NEXT_DIR_ENTRY))
+ {
+ next if $name eq '.' || $name eq '..'; ## never follow these.
+
+ ## create full relative pathname.
+ $file = $dir eq '.' ? $name : "$dir/$name";
+
+ ## if link and skipping them, do so.
+ if ($NOLINKS && -l $file) {
+ warn qq/skip (symlink): $file\n/ if $WHY;
+ next;
+ }
+
+ ## skip things unless files or directories
+ unless (-f $file || -d _) {
+ if ($WHY) {
+ $why = (-S _ && "socket") ||
+ (-p _ && "pipe") ||
+ (-b _ && "block special")||
+ (-c _ && "char special") || "somekinda special";
+ warn qq/skip ($why): $file\n/;
+ }
+ next;
+ }
+
+ ## skip things we can't read
+ unless (-r _) {
+ if ($WHY) {
+ $why = (-l $file) ? "follow" : "read";
+ warn qq/skip (can't $why): $file\n/;
+ }
+ next;
+ }
+
+ ## skip things that are empty
+ unless (-s _) {
+ warn qq/skip (empty): $file\n/ if $WHY;
+ next;
+ }
+
+ ## Note file device & inode. If -xdev, skip if appropriate.
+ ($dev, $inode) = (stat(_))[$STAT_DEV, $STAT_INODE];
+ if ($XDEV && defined $xdev{$dev}) {
+ warn qq/skip (other device): $file\n/ if $WHY;
+ next;
+ }
+ $id = "$dev,$inode";
+
+ ## special work for a directory
+ if (-d _) {
+ ## Do checks for directory file endings.
+ if ($DO_DSKIP_TEST && (eval $DSKIP_TEST)) {
+ warn qq/skip (-dskip): $file\n/ if $WHY;
+ next;
+ }
+ ## do checks for -name/-regex/-path tests
+ if ($DO_DGLOB_TESTS && !(eval $DGLOB_TESTS)) {
+ warn qq/skip (dirname): $file\n/ if $WHY;
+ next;
+ }
+
+ ## _never_ redo a directory
+ if (defined $dir_done{$id}) {
+ warn qq/skip (did as "$dir_done{$id}"): $file\n/ if $WHY;
+ next;
+ }
+ $dir_done{$id} = $file; ## mark it done.
+ unshift(@todo, $file); ## add to the list to do.
+ next;
+ }
+ if ($WHY == 0 && $VERBOSE > 1) {
+ if ($VERBOSE>2||$vv_print++>$VV_PRINT_COUNT||($vv_size+=-s _)>$VV_SIZE){
+ &message($file);
+ $vv_print = $vv_size = 0;
+ }
+ }
+
+ ## do time-related tests
+ if ($NEWER || $OLDER) {
+ $_ = (stat(_))[$STAT_MTIME];
+ if ($NEWER && $_ < $NEWER) {
+ warn qq/skip (too old): $file\n/ if $WHY;
+ next;
+ }
+ if ($OLDER && $_ > $OLDER) {
+ warn qq/skip (too new): $file\n/ if $WHY;
+ next;
+ }
+ }
+
+ ## do checks for file endings
+ if ($DO_SKIP_TEST && (eval $SKIP_TEST)) {
+ warn qq/skip (-skip): $file\n/ if $WHY;
+ next;
+ }
+
+ ## do checks for -name/-regex/-path tests
+ if ($DO_GLOB_TESTS && !(eval $GLOB_TESTS)) {
+ warn qq/skip (filename): $file\n/ if $WHY;
+ next;
+ }
+
+
+ ## If we're not repeating files,
+ ## skip this one if we've done it, or note we're doing it.
+ unless ($DOREP) {
+ if (defined $file_done{$id}) {
+ warn qq/skip (did as "$file_done{$id}"): $file\n/ if $WHY;
+ next;
+ }
+ $file_done{$id} = $file;
+ }
+
+ if ($DO_MAGIC_TESTS) {
+ if (!open(FILE_IN, $file)) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ warn qq/$0: can't open: $file\n/;
+ next;
+ }
+ unless (read(FILE_IN, $magic'H, $HEADER_BYTES)) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ warn qq/$0: can't read from "$file"\n"/;
+ close(FILE_IN);
+ next;
+ }
+
+ eval $MAGIC_TESTS;
+ if ($magic'val) {
+ close(FILE_IN);
+ warn qq/skip (magic): $file\n/ if $WHY;
+ next;
+ }
+ seek(FILE_IN, 0, 0); ## reset for later <FILE_IN>
+ }
+
+ if ($WHY != 0 && $VERBOSE > 1) {
+ if ($VERBOSE>2||$vv_print++>$VV_PRINT_COUNT||($vv_size+=-s _)>$VV_SIZE){
+ &message($file);
+ $vv_print = $vv_size = 0;
+ }
+ }
+
+ if ($DELAY) {
+ sleep($DELAY);
+ }
+
+ if ($FIND_ONLY) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ print $file, "\n";
+ $retval=0; ## we've found something
+ close(FILE_IN) if $DO_MAGIC_TESTS;
+ next;
+ } else {
+ ## if we weren't doing magic tests, file won't be open yet...
+ if (!$DO_MAGIC_TESTS && !open(FILE_IN, $file)) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ warn qq/$0: can't open: $file\n/;
+ next;
+ }
+ if ($LIST_ONLY && $CAN_USE_FAST_LISTONLY) {
+ ##
+ ## This is rather complex, but buys us a LOT when we're just
+ ## listing files and not the individual internal lines.
+ ##
+ local($size) = 4096; ## block-size in which to do reads
+ local($nl); ## will point to $_'s ending newline.
+ local($read); ## will be how many bytes read.
+ local($_) = ''; ## Starts out empty
+ local($hold); ## (see below)
+
+ while (($read = read(FILE_IN,$_,$size,length($_)))||length($_))
+ {
+ undef @parts;
+ ## if read a full block, but no newline, need to read more.
+ while ($read == $size && ($nl = rindex($_, "\n")) < 0) {
+ push(@parts, $_); ## save that part
+ $read = read(FILE_IN, $_, $size); ## keep trying
+ }
+
+ ##
+ ## If we had to save parts, must now combine them together.
+ ## adjusting $nl to reflect the now-larger $_. This should
+ ## be a lot more efficient than using any kind of .= in the
+ ## loop above.
+ ##
+ if (@parts) {
+ local($lastlen) = length($_); #only need if $nl >= 0
+ $_ = join('', @parts, $_);
+ $nl = length($_) - ($lastlen - $nl) if $nl >= 0;
+ }
+
+ ##
+ ## If we're at the end of the file, then we can use $_ as
+ ## is. Otherwise, we need to remove the final partial-line
+ ## and save it so that it'll be at the beginning of the
+ ## next read (where the rest of the line will be layed in
+ ## right after it). $hold will be what we should save
+ ## until next time.
+ ##
+ if ($read != $size || $nl < 0) {
+ $hold = '';
+ } else {
+ $hold = substr($_, $nl + 1);
+ substr($_, $nl + 1) = '';
+ }
+
+ ##
+ ## Now have a bunch of full lines in $_. Use it.
+ ##
+ if (eval $REGEX_TEST) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ print $file, "\n";
+ $retval=0; ## we've found something
+
+ last;
+ }
+
+ ## Prepare for next read....
+ $_ = $hold;
+ }
+
+ } else { ## else not using faster block scanning.....
+
+ $lines_printed = 0 if $NICE;
+ while (<FILE_IN>) {
+ study;
+ next unless (eval $REGEX_TEST);
+
+ ##
+ ## We found a matching line.
+ ##
+ $retval=0;
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ if ($LIST_ONLY) {
+ print $file, "\n";
+ last;
+ } else {
+ ## prepare to print line.
+ if ($NICE && $lines_printed++ == 0) {
+ print '-' x 70, "\n" if $NICE > 1;
+ print $file, ":\n";
+ }
+
+ ##
+ ## Print all the prelim stuff. This looks less efficient
+ ## than it needs to be, but that's so that when the eval
+ ## is compiled (and the tests are optimized away), the
+ ## result will be less actual PRINTs than the more natural
+ ## way of doing these tests....
+ ##
+ if ($NICE) {
+ if ($REPORT_LINENUM) {
+ print " line $.: ";
+ } else {
+ print " ";
+ }
+ } elsif ($REPORT_LINENUM && $PREPEND_FILENAME) {
+ print "$file,:$.: ";
+ } elsif ($PREPEND_FILENAME) {
+ print "$file: ";
+ } elsif ($REPORT_LINENUM) {
+ print "$.: ";
+ }
+ print $_;
+ print "\n" unless m/\n$/;
+ }
+ }
+ print "\n" if ($NICE > 1) && $lines_printed;
+ }
+ close(FILE_IN);
+ }
+ }
+ closedir(DIR);
+}
+
+__END__
+.00; ## finish .ig
+
+'di \" finish diversion--previous line must be blank
+.nr nl 0-1 \" fake up transition to first page again
+.nr % 0 \" start at page 1
+.\"__________________NORMAL_MAN_PAGE_BELOW_________________
+.ll+10n
+.TH search 1 "Dec 17, 1994"
+.SH SEARCH
+search \- search files (a'la grep) in a whole directory tree.
+.SH SYNOPSIS
+search [ grep-like and find-like options] [regex ....]
+.SH DESCRIPTION
+.I Search
+is more or less a combo of 'find' and 'grep' (although the regular
+expression flavor is that of the perl being used, which is closer to
+egrep's than grep's).
+
+.I Search
+does generally the same kind of thing that
+.nf
+ find <blah blah> | xargs egrep <blah blah>
+.fi
+does, but is
+.I much
+more powerful and efficient (and intuitive, I think).
+
+This manual describes
+.I search
+as of version "941227.4". You can always find the latest version at
+.nf
+ http://www.wg.omron.co.jp/~jfriedl/perl/index.html
+.fi
+
+.SH "QUICK EXAMPLE"
+Basic use is simple:
+.nf
+ % search jeff
+.fi
+will search files in the current directory, and all sub directories, for
+files that have "jeff" in them. The lines will be listed with the
+containing file's name prepended.
+.PP
+If you list more than one regex, such as with
+.nf
+ % search jeff Larry Randal+ 'Stoc?k' 'C.*son'
+.fi
+then a line containing any of the regexes will be listed.
+This makes it effectively the same as
+.nf
+ % search 'jeff|Larry|Randal+|Stoc?k|C.*son'
+.fi
+However, listing them separately is much more efficient (and is easier
+to type).
+.PP
+Note that in the case of these examples, the
+.B \-w
+(list whole-words only) option would be useful.
+.PP
+Normally, various kinds of files are automatically removed from consideration.
+If it has has a certain ending (such as ".tar", ".Z", ".o", .etc), or if
+the beginning of the file looks like a binary, it'll be excluded.
+You can control exactly how this works -- see below. One quick way to
+override this is to use the
+.B \-all
+option, which means to consider all the files that would normally be
+automatically excluded.
+Or, if you're curious, you can use
+.B \-why
+to have notes about what files are skipped (and why) printed to stderr.
+
+.SH "BASIC OVERVIEW"
+Normally, the search starts in the current directory, considering files in
+all subdirectories.
+
+You can use the
+.I ~/.search
+file to control ways to automatically exclude files.
+If you don't have this file, a default one will kick in, which automatically
+add
+.nf
+ -skip .o .Z .gif
+.fi
+(among others) to exclude those kinds of files (which you probably want to
+skip when searching for text, as is normal).
+Files that look to be be binary will also be excluded.
+
+Files ending with "#" and "~" will also be excluded unless the
+.B -x~
+option is given.
+
+You can use
+.B -showrc
+to show what kinds of files will normally be skipped.
+See the section on the startup file
+for more info.
+
+You can use the
+.B -all
+option to indicate you want to consider all files that would otherwise be
+skipped by the startup file.
+
+Based upon various other flags (see "WHICH FILES TO CONSIDER" below),
+more files might be removed from consideration. For example
+.nf
+ -mtime 3
+.fi
+will exclude files that aren't at least three days old (change the 3 to -3
+to exclude files that are more than three days old), while
+.nf
+ -skip .*
+.fi
+would exclude any file beginning with a dot (of course, '.' and '..' are
+special and always excluded).
+
+If you'd like to see what files are being excluded, and why, you can get the
+list via the
+.B \-why
+option.
+
+If a file makes it past all the checks, it is then "considered".
+This usually means it is greped for the regular expressions you gave
+on the command line.
+
+If any of the regexes match a line, the line is printed.
+However, if
+.B -list
+is given, just the filename is printed. Or, if
+.B -nice
+is given, a somewhat more (human-)readable output is generated.
+
+If you're searching a huge tree and want to keep informed about how
+the search is progressing,
+.B -v
+will print (to stderr) the current directory being searched.
+Using
+.B -vv
+will also print the current file "every so often", which could be useful
+if a directory is huge. Using
+.B -vvv
+will print the update with every file.
+
+Below is the full listing of options.
+
+.SH "OPTIONS TELLING *WHERE* TO SEARCH"
+.TP
+.BI -dir " DIR"
+Start searching at the named directory instead of the current directory.
+If multiple
+.B -dir
+arguments are given, multiple trees will be searched.
+.TP
+.BI -ddir " DIR"
+Like
+.B -dir
+except it flushes any previous
+.B -dir
+directories (i.e. "-dir A -dir B -dir C" will search A, B, and C, while
+"-dir A -ddir B -dir C" will search only B and C. This might be of use
+in the startup file (see that section below).
+.TP
+.B -xdev
+Stay on the same filesystem as the starting directory/directories.
+.TP
+.B -sort
+Sort the items in a directory before processing them.
+Normally they are processed in whatever order they happen to be read from
+the directory.
+.TP
+.B -nolinks
+Don't follow symbolic links. Normally they're followed.
+
+.SH "OPTIONS CONTROLLING WHICH FILES TO CONSIDER AND EXCLUDE"
+.TP
+.BI -mtime " NUM"
+Only consider files that were last changed more than
+.I NUM
+days ago
+(less than
+.I NUM
+days if
+.I NUM
+has '-' prepended, i.e. "-mtime -2.5" means to consider files that
+have been changed in the last two and a half days).
+.TP
+.B -older FILE
+Only consider files that have not changed since
+.I FILE
+was last changed.
+If there is any upper case in the "-older", "or equal" is added to the sense
+of the test. Therefore, "search -older ./file regex" will never consider
+"./file", while "search -Older ./file regex" will.
+
+If a file is a symbolic link, the time used is that of the file and not the
+link.
+.TP
+.BI -newer " FILE"
+Opposite of
+.BR -older .
+.TP
+.BI -name " GLOB"
+Only consider files that match the shell filename pattern
+.IR GLOB .
+The check is only done on a file's name (use
+.B -path
+to check the whole path, and use
+.B -dname
+to check directory names).
+
+Multiple specifications can be given by separating them with spaces, a'la
+.nf
+ -name '*.c *.h'
+.fi
+to consider C source and header files.
+If
+.I GLOB
+doesn't contain any special pattern characters, a '*' is prepended.
+This last example could have been given as
+.nf
+ -name '.c .h'
+.fi
+It could also be given as
+.nf
+ -name .c -name .h
+.fi
+or
+.nf
+ -name '*.c' -name '*.h'
+.fi
+or
+.nf
+ -name '*.[ch]'
+.fi
+(among others)
+but in this last case, you have to be sure to supply the leading '*'.
+.TP
+.BI -path " GLOB"
+Like
+.B -name
+except the entire path is checked against the pattern.
+.TP
+.B -regex " REGEX"
+Considers files whose names (not paths) match the given perl regex
+exactly.
+.TP
+.BI -iname " GLOB"
+Case-insensitive version of
+.BR -name .
+.TP
+.BI -ipath " GLOB"
+Case-insensitive version of
+.BR -path .
+.TP
+.BI -iregex " REGEX"
+Case-insensitive version of
+.BR -regex .
+
+.TP
+.BI -dpath " GLOB"
+Only search down directories whose path matches the given pattern (this
+doesn't apply to the initial directory given by
+.BI -dir ,
+of course).
+Something like
+.nf
+ -dir /usr/man -dpath /usr/man/man*
+.fi
+would completely skip
+"/usr/man/cat1", "/usr/man/cat2", etc.
+.TP
+.BI -dskip " GLOB"
+Skips directories whose name (not path) matches the given pattern.
+Something like
+.nf
+ -dir /usr/man -dskip cat*
+.fi
+would completely skip any directory in the tree whose name begins with "cat"
+(including "/usr/man/cat1", "/usr/man/cat2", etc.).
+.TP
+.BI -dregex " REGEX"
+Like
+.BI -dpath ,
+but the pattern is a full perl regex. Note that this quite different
+from
+.B -regex
+which considers only file names (not paths). This option considers
+full directory paths (not just names). It's much more useful this way.
+Sorry if it's confusing.
+.TP
+.BI -dpath " GLOB"
+This option exists, but is probably not very useful. It probably wants to
+be like the '-below' or something I mention in the "TODO" section.
+.TP
+.BI -idpath " GLOB"
+Case-insensitive version of
+.BR -dpath .
+.TP
+.BI -idskip " GLOB"
+Case-insensitive version of
+.BR -dskip .
+.TP
+.BI -idregex " REGEX"
+Case-insensitive version of
+.BR -dregex .
+.TP
+.B -all
+Ignore any 'magic' or 'option' lines in the startup file.
+The effect is that all files that would otherwise be automatically
+excluded are considered.
+.TP
+.BI -x SPECIAL
+Arguments starting with
+.B -x
+(except
+.BR -xdev ,
+explained elsewhere) do special interaction with the
+.I ~/.search
+startup file. Something like
+.nf
+ -xflag1 -xflag2
+.fi
+will turn on "flag1" and "flag2" in the startup file (and is
+the same as "-xflag1,flag2"). You can use this to write your own
+rules for what kinds of files are to be considered.
+
+For example, the internal-default startup file contains the line
+.nf
+ <!~> option: -skip '~ #'
+.fi
+This means that if the
+.B -x~
+flag is
+.I not
+seen, the option
+.nf
+ -skip '~ #'
+.fi
+should be done.
+The effect is that emacs temp and backup files are not normally
+considered, but you can included them with the -x~ flag.
+
+You can write your own rules to customize
+.I search
+in powerful ways. See the STARTUP FILE section below.
+.TP
+.B -why
+Print a message (to stderr) when and why a file is not considered.
+
+.SH "OPTIONS TELLING WHAT TO DO WITH FILES THAT WILL BE CONSIDERED"
+.TP
+.B -find
+(you can use
+.B -f
+as well).
+This option changes the basic action of
+.IR search .
+
+Normally, if a file is considered, it is searched
+for the regular expressions as described earlier. However, if this option
+is given, the filename is printed and no searching takes place. This turns
+.I search
+into a 'find' of some sorts.
+
+In this case, no regular expressions are needed on the command line
+(any that are there are silently ignored).
+
+This is not intended to be a replacement for the 'find' program,
+but to aid
+you in understanding just what files are getting past the exclusion checks.
+If you really want to use it as a sort of replacement for the 'find' program,
+you might want to use
+.B -all
+so that it doesn't waste time checking to see if the file is binary, etc
+(unless you really want that, of course).
+
+If you use
+.BR -find ,
+none of the "GREP-LIKE OPTIONS" (below) matter.
+
+As a replacement for 'find',
+.I search
+is probably a bit slower (or in the case of GNU find, a lot slower --
+GNU find is
+.I unbelievably
+fast).
+However, "search -ffind"
+might be more useful than 'find' when options such as
+.B -skip
+are used (at least until 'find' gets such functionality).
+.TP
+.B -ffind
+(or
+.BR -ff )
+A faster more 'find'-like find. Does
+.nf
+ -find -all -dorep
+.fi
+.SH "GREP-LIKE OPTIONS"
+These options control how a searched file is accessed,
+and how things are printed.
+.TP
+.B -i
+Ignore letter case when matching.
+.TP
+.B -w
+Consider only whole-word matches ("whole word" as defined by perl's "\\b"
+regex).
+.TP
+.B -u
+If the regex(es) is/are simple, try to modify them so that they'll work
+in manpage-like underlined text (i.e. like _^Ht_^Hh_^Hi_^Hs).
+This is very rudimentary at the moment.
+.TP
+.B -list
+(you can use
+.B -l
+too).
+Don't print matching lines, but the names of files that contain matching
+lines. This will likely be *much* faster, as special optimizations are
+made -- particularly with large files.
+.TP
+.B -n
+Pepfix each line by its line number.
+.TP
+.B -nice
+Not a grep-like option, but similar to
+.BR -list ,
+so included here.
+.B -nice
+will have the output be a bit more human-readable, with matching lines printed
+slightly indented after the filename, a'la
+.nf
+
+ % search foo
+ somedir/somefile: line with foo in it
+ somedir/somefile: some food for thought
+ anotherdir/x: don't be a buffoon!
+ %
+
+.fi
+will become
+.nf
+
+ % search -nice foo
+ somedir/somefile:
+ line with foo in it
+ some food for thought
+ anotherdir/x:
+ don't be a buffoon!
+ %
+
+.fi
+This option due to Lionel Cons.
+.TP
+.B -nnice
+Be a bit nicer than
+.BR -nice .
+Prefix each file's output by a rule line, and follow with an extra blank line.
+.TP
+.B -h
+Don't prepend each output line with the name of the file
+(meaningless when
+.B -find
+or
+.B -l
+are given).
+
+.SH "OTHER OPTIONS"
+.TP
+.B -help
+Print the usage information.
+.TP
+.B -version
+Print the version information and quit.
+.TP
+.B -v
+Set the level of message verbosity.
+.B -v
+will print a note whenever a new directory is entered.
+.B -vv
+will also print a note "every so often". This can be useful to see
+what's happening when searching huge directories.
+.B -vvv
+will print a new with every file.
+.B -vvvv
+is
+-vvv
+plus
+.BR -why .
+.TP
+.B -e
+This ends the options, and can be useful if the regex begins with '-'.
+.TP
+.B -showrc
+Shows what is being considered in the startup file, then exits.
+.TP
+.B -dorep
+Normally, an identical file won't be checked twice (even with multiple
+hard or symbolic links). If you're just trying to do a fast
+.BR -find ,
+the bookkeeping to remember which files have been seen is not desirable,
+so you can eliminate the bookkeeping with this flag.
+
+.SH "STARTUP FILE"
+When
+.I search
+starts up, it processes the directives in
+.IR ~/.search .
+If no such file exists, a default
+internal version is used.
+
+The internal version looks like:
+.nf
+
+ magic: 32 : $H =~ m/[\ex00-\ex06\ex10-\ex1a\ex1c-\ex1f\ex80\exff]{2}/
+ option: -skip '.a .COM .elc .EXE .gz .o .pbm .xbm .dvi'
+ option: -iskip '.tarz .zip .z .lzh .jpg .jpeg .gif .uu'
+ <!~> option: -skip '~ #'
+
+.fi
+If you wish to create your own "~/.search",
+you might consider copying the above, and then working from there.
+
+There are two kinds of directives in a startup file: "magic" and "option".
+.RS 0n
+.TP
+OPTION
+Option lines will automatically do the command-line options given.
+For example, the line
+.nf
+ option: -v
+.fi
+in you startup file will turn on -v every time, without needing to type it
+on the command line.
+
+The text on the line after the "option:" directive is processed
+like the Bourne shell, so make sure to pay attention to quoting.
+.nf
+ option: -skip .exe .com
+.fi
+will give an error (".com" by itself isn't a valid option), while
+.nf
+ option: -skip ".exe .com"
+.fi
+will properly include it as part of -skip's argument.
+
+.TP
+MAGIC
+Magic lines are used to determine if a file should be considered a binary
+or not (the term "magic" refers to checking a file's magic number). These
+are described in more detail below.
+.RE
+
+Blank lines and comments (lines beginning with '#') are allowed.
+
+If a line begins with <...>, then it's a check to see if the
+directive on the line should be done or not. The stuff inside the <...>
+can contain perl's && (and), || (or), ! (not), and parens for grouping,
+along with "flags" that might be indicated by the user with
+.BI -x flag
+options.
+
+For example, using "-xfoo" will cause "foo" to be true inside the <...>
+blocks. Therefore, a line beginning with "<foo>" would be done only when
+"-xfoo" had been specified, while a line beginning with "<!foo>" would be
+done only when "-xfoo" is not specified (of course, a line without any <...>
+is done in either case).
+
+A realistic example might be
+.nf
+ <!v> -vv
+.fi
+This will cause -vv messages to be the default, but allow "-xv" to override.
+
+There are a few flags that are set automatically:
+.RS
+.TP
+.B TTY
+true if the output is to the screen (as opposed to being redirected to a file).
+You can force this (as with all the other automatic flags) with -xTTY.
+.TP
+.B -v
+True if -v was specified. If -vv was specified, both
+.B -v
+and
+.B -vv
+flags are true (and so on).
+.TP
+.B -nice
+True if -nice was specified. Same thing about -nnice as for -vv.
+.PP
+.TP
+.B -list
+true if -list (or -l) was given.
+.TP
+.B -dir
+true if -dir was given.
+.RE
+
+Using this info, you might change the last example to
+.nf
+
+ <!v && !-v> option: -vv
+
+.fi
+The added "&& !-v" means "and if the '-v' option not given".
+This will allow you to use "-v" alone on the command line, and not
+have this directive add the more verbose "-vv" automatically.
+
+.RS 0
+Some other examples:
+.TP
+<!-dir && !here> option: -dir ~/
+Effectively make the default directory your home directory (instead of the
+current directory). Using -dir or -xhere will undo this.
+.TP
+<tex> option: -name .tex -dir ~/pub
+Create '-xtex' to search only "*.tex" files in your ~/pub directory tree.
+Actually, this could be made a bit better. If you combine '-xtex' and '-dir'
+on the command line, this directive will add ~/pub to the list, when you
+probably want to use the -dir directory only. You could do
+.nf
+
+ <tex> option: -name .tex
+ <tex && !-dir> option: -dir ~/pub
+.fi
+
+to will allow '-xtex' to work as before, but allow a command-line "-dir"
+to take precedence with respect to ~/pub.
+.TP
+<fluff> option: -nnice -sort -i -vvv
+Combine a few user-friendly options into one '-xfluff' option.
+.TP
+<man> option: -ddir /usr/man -v -w
+When the '-xman' option is given, search "/usr/man" for whole-words
+(of whatever regex or regexes are given on the command line), with -v.
+.RE
+
+The lines in the startup file are executed from top to bottom, so something
+like
+.nf
+
+ <both> option: -xflag1 -xflag2
+ <flag1> option: ...whatever...
+ <flag2> option: ...whatever...
+
+.fi
+will allow '-xboth' to be the same as '-xflag1 -xflag2' (or '-xflag1,flag2'
+for that matter). However, if you put the "<both>" line below the others,
+they will not be true when encountered, so the result would be different
+(and probably undesired).
+
+The "magic" directives are used to determine if a file looks to be binary
+or not. The form of a magic line is
+.nf
+ magic: \fISIZE\fP : \fIPERLCODE\fP
+.fi
+where
+.I SIZE
+is the number of bytes of the file you need to check, and
+.I PERLCODE
+is the code to do the check. Within
+.IR PERLCODE ,
+the variable $H will hold at least the first
+.I SIZE
+bytes of the file (unless the file is shorter than that, of course).
+It might hold more bytes. The perl should evaluate to true if the file
+should be considered a binary.
+
+An example might be
+.nf
+ magic: 6 : substr($H, 0, 6) eq 'GIF87a'
+.fi
+to test for a GIF ("-iskip .gif" is better, but this might be useful
+if you have images in files without the ".gif" extension).
+
+Since the startup file is checked from top to bottom, you can be a bit
+efficient:
+.nf
+ magic: 6 : ($x6 = substr($H, 0, 6)) eq 'GIF87a'
+ magic: 6 : $x6 eq 'GIF89a'
+.fi
+You could also write the same thing as
+.nf
+ magic: 6 : (($x6 = substr($H, 0, 6)) eq 'GIF87a') || ## an old gif, or.. \e
+ $x6 eq 'GIF89a' ## .. a new one.
+.fi
+since newlines may be escaped.
+
+The default internal startup file includes
+.nf
+ magic: 32 : $H =~ m/[\ex00-\ex06\ex10-\ex1a\ex1c-\ex1f\ex80\exff]{2}/
+.fi
+which checks for certain non-printable characters, and catches a large
+number of binary files, including most system's executables, linkable
+objects, compressed, tarred, and otherwise folded, spindled, and mutilated
+files.
+
+Another example might be
+.nf
+ ## an archive library
+ magic: 17 : substr($H, 0, 17) eq "!<arch>\en__.SYMDEF"
+.fi
+
+.SH "RETURN VALUE"
+.I Search
+returns zero if lines (or files, if appropriate) were found,
+or if no work was requested (such as with
+.BR -help ).
+Returns 1 if no lines (or files) were found.
+Returns 2 on error.
+
+.SH TODO
+Things I'd like to add some day:
+.nf
+ + show surrounding lines (context).
+ + highlight matched portions of lines.
+ + add '-and', which can go between regexes to override
+ the default logical or of the regexes.
+ + add something like
+ -below GLOB
+ which will examine a tree and only consider files that
+ lie in a directory deeper than one named by the pattern.
+ + add 'warning' and 'error' directives.
+ + add 'help' directive.
+.fi
+.SH BUGS
+If -xdev and multiple -dir arguments are given, any file in any of the
+target filesystems are allowed. It would be better to allow each filesystem
+for each separate tree.
+
+Multiple -dir args might also cause some confusing effects. Doing
+.nf
+ -dir some/dir -dir other
+.fi
+will search "some/dir" completely, then search "other" completely. This
+is good. However, something like
+.nf
+ -dir some/dir -dir some/dir/more/specific
+.fi
+will search "some/dir" completely *except for* "some/dir/more/specific",
+after which it will return and be searched. Not really a bug, but just sort
+of odd.
+
+File times (for -newer, etc.) of symbolic links are for the file, not the
+link. This could cause some misunderstandings.
+
+Probably more. Please let me know.
+.SH AUTHOR
+Jeffrey Friedl, Omron Corp (jfriedl@omron.co.jp)
+.br
+http://www.wg.omron.co.jp/cgi-bin/j-e/jfriedl.html
+
+.SH "LATEST SOURCE"
+See http://www.wg.omron.co.jp/~jfriedl/perl/index.html
+__END__
+:endofperl
diff --git a/win32/bin/test.bat b/win32/bin/test.bat
new file mode 100644
index 0000000000..e6b7b38160
--- /dev/null
+++ b/win32/bin/test.bat
@@ -0,0 +1,143 @@
+@rem = '
+@echo off
+if exist perl.exe goto perlhere
+echo Cannot run without perl.exe in current directory!! Did you build it?
+pause
+goto endofperl
+:perlhere
+if exist perlglob.exe goto perlglobhere
+echo Cannot run without perlglob.exe in current directory!! Did you build it?
+pause
+goto endofperl
+:perlglobhere
+perl %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+@rem ';
+
+#Portions (C) 1995 Microsoft Corporation. All rights reserved.
+# Developed by hip communications inc., http://info.hip.com/info/
+
+
+# This is written in a peculiar style, since we're trying to avoid
+# most of the constructs we'll be testing for.
+
+$| = 1;
+
+if ($ARGV[0] eq '-v') {
+ $verbose = 1;
+ shift;
+}
+
+
+# WYT 1995-05-02
+chdir 't' if -f 't/TESTNT';
+
+
+if ($ARGV[0] eq '') {
+# @ARGV = split(/[ \n]/,
+# `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t lib/*.t`);
+# `ls base/*.t comp/*.t cmd/*.t io/*.t op/*.t lib/*.t`);
+
+# WYT 1995-05-02 wildcard expansion,
+# `perl -e "print( join( ' ', \@ARGV ) )" base/*.t comp/*.t cmd/*.t io/*.t op/*.t lib/*.t nt/*.t`);
+
+# WYT 1995-06-01 removed all dependency on perlglob
+# WYT 1995-11-28 hacked up to cope with braindead Win95 console.
+ push( @ARGV, `dir/s/b base` );
+ push( @ARGV, `dir/s/b comp` );
+ push( @ARGV, `dir/s/b cmd` );
+ push( @ARGV, `dir/s/b io` );
+ push( @ARGV, `dir/s/b op` );
+ push( @ARGV, `dir/s/b lib` );
+ push( @ARGV, `dir/s/b nt` );
+
+ grep( chomp, @ARGV );
+ @ARGV = grep( /\.t$/, @ARGV );
+ grep( s/.*t\\//, @ARGV );
+}
+
+$sharpbang = 0;
+
+$bad = 0;
+$good = 0;
+$total = @ARGV;
+while ($test = shift) {
+ if ($test =~ /^$/) {
+ next;
+ }
+ $te = $test;
+# chop off 't' extension
+ chop($te);
+ print "$te" . '.' x (15 - length($te));
+ if ($sharpbang) {
+ open(results,"./$test |") || (print "can't run.\n");
+ } else {
+ $switch = '';
+# open(results,"./perl$switch $test |") || (print "can't run.\n");
+ open(results,"perl$switch $test |") || (print "can't run.\n");
+ }
+ $ok = 0;
+ $next = 0;
+ while (<results>) {
+ if ($verbose) {
+ print $_;
+ }
+ unless (/^#/||/^$/) {
+ if (/^1\.\.([0-9]+)/) {
+ $max = $1;
+ $totmax += $max;
+ $files += 1;
+ $next = 1;
+ $ok = 1;
+ } else {
+ $next = $1, $ok = 0, last if /^not ok ([0-9]*)/;
+ if (/^ok (.*)/ && $1 == $next) {
+ $next = $next + 1;
+ } else {
+ $ok = 0;
+ }
+ }
+ }
+ }
+ $next = $next - 1;
+ if ($ok && $next == $max) {
+ print "ok\n";
+ $good = $good + 1;
+ } else {
+ $next += 1;
+ print "FAILED on test $next\n";
+ $bad = $bad + 1;
+ $_ = $test;
+ if (/^base/) {
+ die "Failed a basic test--cannot continue.\n";
+ }
+ }
+}
+
+if ($bad == 0) {
+ if ($ok) {
+ print "All tests successful.\n";
+ } else {
+ die "FAILED--no tests were run for some reason.\n";
+ }
+} else {
+ $pct = sprintf("%.2f", $good / $total * 100);
+ if ($bad == 1) {
+ warn "Failed 1 test, $pct% okay.\n";
+ } else {
+ die "Failed $bad/$total tests, $pct% okay.\n";
+ }
+}
+
+
+# WYT 1995-05-03 times not implemented.
+#($user,$sys,$cuser,$csys) = times;
+#print sprintf("u=%g s=%g cu=%g cs=%g files=%d tests=%d\n",
+# $user,$sys,$cuser,$csys,$files,$totmax);
+
+#`del /f Cmd_while.tmp Comp.try null 2>NULL`;
+
+unlink 'Cmd_while.tmp', 'Comp.try', 'null';
+
+__END__
+:endofperl
diff --git a/win32/bin/webget.bat b/win32/bin/webget.bat
new file mode 100644
index 0000000000..e77bb88ced
--- /dev/null
+++ b/win32/bin/webget.bat
@@ -0,0 +1,1099 @@
+@rem = '--*-Perl-*--';
+@rem = '
+@echo off
+perl -S %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9
+goto endofperl
+@rem ';
+#!/usr/local/bin/perl -w
+
+#-
+#!/usr/local/bin/perl -w
+$version = "951121.18";
+$comments = 'jfriedl@omron.co.jp';
+
+##
+## This is "webget"
+##
+## Jeffrey Friedl (jfriedl@omron.co.jp), July 1994.
+## Copyright 19.... ah hell, just take it.
+## Should work with either perl4 or perl5
+##
+## BLURB:
+## Given a URL on the command line (HTTP and FTP supported at the moment),
+## webget fetches the named object (HTML text, images, audio, whatever the
+## object happens to be). Will automatically use a proxy if one is defined
+## in the environment, follow "this URL has moved" responses, and retry
+## "can't find host" responses from a proxy in case host lookup was slow).
+## Supports users & passwords (FTP), Basic Authorization (HTTP), update-if-
+## modified (HTTP), and much more. Works with perl4 or perl5.
+
+##
+## More-detailed instructions in the comment block below the history list.
+##
+
+##
+## To-do:
+## Add gopher support.
+## Fix up how error messages are passed among this and the libraries.
+##
+
+## 951219.19
+## Lost ftp connections now die with a bit more grace.
+##
+## 951121.18
+## Add -nnab.
+## Brought the "usage" string in line with reality.
+##
+## 951114.17
+## Added -head.
+## Added -update/-refresh/-IfNewerThan. If any URL was not pulled
+## because it was not out of date, an exit value of 2 is returned.
+##
+## 951031.16
+## Added -timeout. Cleaned up (a bit) the exit value. Now exits
+## with 1 if all URLs had some error (timeout exits immediately with
+## code 3, though. This is subject to change). Exits with 0 if any
+## URL was brought over safely.
+##
+## 951017.15
+## Neat -pf, -postfile idea from Lorrie Cranor
+## (http://www.ccrc.wustl.edu/~lorracks/)
+##
+## 950912.14
+## Sigh, fixed a typo.
+##
+## 950911.13
+## Added Basic Authorization support for http. See "PASSWORDS AND STUFF"
+## in the documentation.
+##
+## 950911.12
+## Implemented a most-excellent suggestion by Anthony D'Atri
+## (aad@nwnet.net), to be able to automatically grab to a local file of
+## the same name as the URL. See the '-nab' flag.
+##
+## 950706.11
+## Quelled small -w warning (thanks: Lars Rasmussen <gnort@daimi.aau.dk>)
+##
+## 950630.10
+## Steve Campbell to the rescue again. FTP now works when supplied
+## with a userid & password (eg ftp://user:pass@foo.bar.com/index.txt).
+##
+## 950623.9
+## Incorporated changes from Steve Campbell (steven_campbell@uk.ibm.com)
+## so that the ftp will work when no password is required of a user.
+##
+## 950530.8
+## Minor changes:
+## Eliminate read-size warning message when size unknown.
+## Pseudo-debug/warning messages at the end of debug_read now go to
+## stderr. Some better error handling when trying to contact systems
+## that aren't really set up for ftp. Fixed a bug concerning FTP access
+## to a root directory. Added proxy documentation at head of file.
+##
+## 950426.6,7
+## Complete Overhaul:
+## Renamed from httpget. Added ftp support (very sketchy at the moment).
+## Redid to work with new 'www.pl' library; chucked 'Www.pl' library.
+## More or less new and/or improved in many ways, but probably introduced
+## a few bugs along the way.
+##
+## 941227.5
+## Added follow stuff (with -nofollow, etc.)
+## Added -updateme. Cool!
+## Some general tidying up.
+##
+## 941107.4
+## Allowed for ^M ending a header line... PCs give those kind of headers.
+##
+## 940820.3
+## First sorta'clean net release.
+##
+##
+
+##
+##>
+##
+## Fetch http and/or ftp URL(s) given on the command line and spit to
+## STDOUT.
+##
+## Options include:
+## -V, -version
+## Print version information; exit.
+##
+## -p, -post
+## If the URL looks like a reply to a form (i.e. has a '?' in it),
+## the request is POST'ed instead of GET'ed.
+##
+## -head
+## Gets the header only (for HTTP). This might include such useful
+## things as 'Last-modified' and 'Content-length' fields
+## (a lack of a 'Last-modified' might be a good indication that it's
+## a CGI).
+##
+## The "-head" option implies "-nostrip", but does *not* imply,
+## for example "-nofollow".
+##
+##
+## -pf, -postfile
+## The item after the '?' is taken as a local filename, and the contents
+## are POST'ed as with -post
+##
+## -nab, -f, -file
+## Rather than spit the URL(s) to standard output, unconditionally
+## dump to a file (or files) whose name is that as used in the URL,
+## sans path. I like '-nab', but supply '-file' as well since that's
+## what was originally suggested. Also see '-update' below for the
+## only-if-changed version.
+##
+## -nnab
+## Like -nab, but in addtion to dumping to a file, dump to stdout as well.
+## Sort of like the 'tee' command.
+##
+## -update, -refresh
+## Do the same thing as -nab, etc., but does not bother pulling the
+## URL if it older than the localfile. Only applies to HTTP.
+## Uses the HTTP "If-Modified-Since" field. If the URL was not modified
+## (and hence not changed), the return value is '2'.
+##
+## -IfNewerThan FILE
+## -int FILE
+## Only pulls URLs if they are newer than the date the local FILE was
+## last written.
+##
+## -q, -quiet
+## Suppresses all non-essential informational messages.
+##
+## -nf, -nofollow
+## Normally, a "this URL has moved" HTTP response is automatically
+## followed. Not done with -nofollow.
+##
+## -nr, -noretry
+## Normally, an HTTP proxy response of "can't find host" is retried
+## up to three times, to give the remote hostname lookup time to
+## come back with an answer. This suppresses the retries. This is the
+## same as '-retry 0'.
+##
+## -r#, -retry#, -r #, -retry #
+## Sets the number of times to retry. Default 3.
+##
+## -ns, -nostrip
+## For HTTP items (including other items going through an HTTP proxy),
+## the HTTP response header is printed rather than stripped as default.
+##
+## -np, -noproxy
+## A proxy is not used, even if defined for the protocol.
+##
+## -h, -help
+## Show a usage message and exit.
+##
+## -d, -debug
+## Show some debugging messages.
+##
+## -updateme
+## The special and rather cool flag "-updateme" will see if webget has
+## been updated since you got your version, and prepare a local
+## version of the new version for you to use. Keep updated! (although
+## you can always ask to be put on the ping list to be notified when
+## there's a new version -- see the author's perl web page).
+##
+## -timeout TIMESPAN
+## -to TIMESPAN
+## Time out if a connection can not be made within the specified time
+## period. TIMESPAN is normally in seconds, although a 'm' or 'h' may
+## be appended to indicate minutes and hours. "-to 1.5m" would timeout
+## after 90 seconds.
+##
+## (At least for now), a timeout causes immediate program death (with
+## exit value 3). For some reason, the alarm doesn't always cause a
+## waiting read or connect to abort, so I just die immediately.. /-:
+##
+## I might consider adding an "entire fetch" timeout, if someone
+## wants it.
+##
+## PASSWORDS AND SUCH
+##
+## You can use webget to do FTP fetches from non-Anonymous systems and
+## accounts. Just put the required username and password into the URL,
+## as with
+## webget 'ftp:/user:password@ftp.somesite.com/pub/pix/babe.gif
+## ^^^^^^^^^^^^^
+## Note the user:password is separated from the hostname by a '@'.
+##
+## You can use the same kind of thing with HTTP, and if so it will provide
+## what's know as Basic Authorization. This is >weak< authorization. It
+## also provides >zero< security -- I wouldn't be sending any credit-card
+## numbers this way (unless you send them 'round my way :-). It seems to
+## be used most by providers of free stuff where they want to make some
+## attempt to limit access to "known users".
+##
+## PROXY STUFF
+##
+## If you need to go through a gateway to get out to the whole internet,
+## you can use a proxy if one's been set up on the gateway. This is done
+## by setting the "http_proxy" environmental variable to point to the
+## proxy server. Other variables are used for other target protocols....
+## "gopher_proxy", "ftp_proxy", "wais_proxy", etc.
+##
+## For example, I have the following in my ".login" file (for use with csh):
+##
+## setenv http_proxy http://local.gateway.machine:8080/
+##
+## This is to indicate that any http URL should go to local.gateway.machine
+## (port 8080) via HTTP. Additionally, I have
+##
+## setenv gopher_proxy "$http_proxy"
+## setenv wais_proxy "$http_proxy"
+## setenv ftp_proxy "$http_proxy"
+##
+## This means that any gopher, wais, or ftp URL should also go to the
+## same place, also via HTTP. This allows webget to get, for example,
+## GOPHER URLs even though it doesn't support GOPHER itself. It uses HTTP
+## to talk to the proxy, which then uses GOPHER to talk to the destination.
+##
+## Finally, if there are sites inside your gateway that you would like to
+## connect to, you can list them in the "no_proxy" variable. This will allow
+## you to connect to them directly and skip going through the proxy:
+##
+## setenv no_proxy "www.this,www.that,www.other"
+##
+## I (jfriedl@omron.co.jp) have little personal experience with proxies
+## except what I deal with here at Omron, so if this is not representative
+## of your situation, please let me know.
+##
+## RETURN VALUE
+## The value returned to the system by webget is rather screwed up because
+## I didn't think about dealing with it until things were already
+## complicated. Since there can be more than one URL on the command line,
+## it's hard to decide what to return when one times out, another is fetched,
+## another doesn't need to be fetched, and a fourth isn't found.
+##
+## So, here's the current status:
+##
+## Upon any timeout (via the -timeout arg), webget immediately
+## returns 3. End of story. Otherwise....
+##
+## If any URL was fetched with a date limit (i.e. via
+## '-update/-refresh/-IfNewerThan' and was found to not have changed,
+## 2 is returned. Otherwise....
+##
+## If any URL was successfully fetched, 0 is returned. Otherwise...
+##
+## If there were any errors, 1 is returned. Otherwise...
+##
+## Must have been an info-only or do-nothing instance. 0 is returned.
+##
+## Phew. Hopefully useful to someone.
+##<
+##
+
+## Where latest version should be.
+$WEB_normal = 'http://www.wg.omron.co.jp/~jfriedl/perl/webget';
+$WEB_inlined = 'http://www.wg.omron.co.jp/~jfriedl/perl/inlined/webget';
+
+
+require 'network.pl'; ## inline if possible (directive to a tool of mine)
+require 'www.pl'; ## inline if possible (directive to a tool of mine)
+$inlined=0; ## this might be changed by a the inline thing.
+
+##
+## Exit values. All screwed up.
+##
+$EXIT_ok = 0;
+$EXIT_error = 1;
+$EXIT_notmodified = 2;
+$EXIT_timeout = 3;
+
+##
+##
+
+warn qq/WARNING:\n$0: need a newer version of "network.pl"\n/ if
+ !defined($network'version) || $network'version < "950311.5";
+warn qq/WARNING:\n$0: need a newer version of "www.pl"\n/ if
+ !defined($www'version) || $www'version < "951114.8";
+
+$WEB = $inlined ? $WEB_inlined : $WEB_normal;
+
+$debug = 0;
+$strip = 1; ## default is to strip
+$quiet = 0; ## also normally off.
+$follow = 1; ## normally, we follow "Found (302)" links
+$retry = 3; ## normally, retry proxy hostname lookups up to 3 times.
+$nab = 0; ## If true, grab to a local file of the same name.
+$refresh = 0; ## If true, use 'If-Modified-Since' with -nab get.
+$postfile = 0; ## If true, filename is given after the '?'
+$defaultdelta2print = 2048;
+$TimeoutSpan = 0; ## seconds after which we should time out.
+
+while (@ARGV && $ARGV[0] =~ m/^-/)
+{
+ $arg = shift(@ARGV);
+
+ $nab = 1, next if $arg =~ m/^-f(ile)?$/;
+ $nab = 1, next if $arg =~ m/^-nab$/;
+ $nab = 2, next if $arg =~ m/^-nnab$/;
+ $post = 1, next if $arg =~ m/^-p(ost)?$/i;
+ $post = $postfile = 1, next if $arg =~ m/^-p(ost)?f(ile)?$/i;
+ $quiet=1, next if $arg =~ m/^-q(uiet)?$/;
+ $follow = 0, next if $arg =~ m/^-no?f(ollow)?$/;
+ $strip = 0, next if $arg =~ m/^-no?s(trip)?$/;
+ $debug=1, next if $arg =~ m/^-d(ebug)?$/;
+ $noproxy=1, next if $arg =~ m/^-no?p(roxy)?$/;
+ $retry=0, next if $arg =~ m/^-no?r(etry)?$/;
+ $retry=$2, next if $arg =~ m/^-r(etry)?(\d+)$/;
+ &updateme if $arg eq '-updateme';
+ $strip = 0, $head = 1, next if $arg =~ m/^-head(er)?/;
+ $nab = $refresh = 1, next if $arg =~ m/^-(refresh|update)/;
+
+ &usage($EXIT_ok) if $arg =~ m/^-h(elp)?$/;
+ &show_version, exit($EXIT_ok) if $arg eq '-version' || $arg eq '-V';
+
+ if ($arg =~ m/^-t(ime)?o(ut)?$/i) {
+ local($num) = shift(@ARGV);
+ &usage($EXIT_error, "expecting timespan argument to $arg\n") unless
+ $num =~ m/^\d+(\d*)?[hms]?$/;
+ &timeout_arg($num);
+ next;
+ }
+
+ if ($arg =~ m/^-if?n(ewer)?t(han)?$/i) {
+ $reference_file = shift(@ARGV);
+ &usage($EXIT_error, "expecting filename arg to $arg")
+ if !defined $reference_file;
+ if (!-f $reference_file) {
+ warn qq/$0: ${arg}'s "$reference_file" not found.\n/;
+ exit($EXIT_error);
+ }
+ next;
+ }
+
+ if ($arg eq '-r' || $arg eq '-retry') {
+ local($num) = shift(@ARGV);
+ &usage($EXIT_error, "expecting numerical arg to $arg\n") unless
+ defined($num) && $num =~ m/^\d+$/;
+ $retry = $num;
+ next;
+ }
+ &usage($EXIT_error, qq/$0: unknown option "$arg"\n/);
+}
+
+if ($head && $post) {
+ warn "$0: combining -head and -post makes no sense, ignoring -post.\n";
+ $post = 0;
+ undef $postfile;
+}
+
+if ($refresh && defined($reference_file)) {
+ warn "$0: combining -update and -IfNewerThan make no sense, ignoring -IfNewerThan.\n";
+ undef $reference_file;
+}
+
+if (@ARGV == 0) {
+ warn "$0: nothing to do. Use -help for info.\n";
+ exit($EXIT_ok);
+}
+
+
+##
+## Now run through the remaining arguments (mostly URLs) and do a quick
+## check to see if they look well-formed. We won't *do* anything -- just
+## want to catch quick errors before really starting the work.
+##
+@tmp = @ARGV;
+$errors = 0;
+while (@tmp) {
+ $arg = shift(@tmp);
+ if ($arg =~ m/^-t(ime)?o(ut)?$/) {
+ local($num) = shift(@tmp);
+ if ($num !~ m/^\d+(\d*)?[hms]?$/) {
+ &warn("expecting timespan argument to $arg\n");
+ $errors++;
+ }
+ } else {
+ local($protocol) = &www'grok_URL($arg, $noproxy);
+
+ if (!defined $protocol) {
+ warn qq/can't grok "$arg"/;
+ $errors++;
+ } elsif (!$quiet && ($protocol eq 'ftp')) {
+ warn qq/warning: -head ignored for ftp URLs\n/ if $head;
+ warn qq/warning: -refresh ignored for ftp URLs\n/if $refresh;
+ warn qq/warning: -IfNewerThan ignored for ftp URLs\n/if defined($reference_file);
+
+ }
+ }
+}
+
+exit($EXIT_error) if $errors;
+
+
+$SuccessfulCount = 0;
+$NotModifiedCount = 0;
+
+##
+## Now do the real thing.
+##
+while (@ARGV) {
+ $arg = shift(@ARGV);
+ if ($arg =~ m/^-t(ime)?o(ut)?$/) {
+ &timeout_arg(shift(@ARGV));
+ } else {
+ &fetch_url($arg);
+ }
+}
+
+if ($NotModifiedCount) {
+ exit($EXIT_notmodified);
+} elsif ($SuccessfulCount) {
+ exit($EXIT_ok);
+} else {
+ exit($EXIT_error);
+}
+
+###########################################################################
+###########################################################################
+
+sub timeout_arg
+{
+ ($TimeoutSpan) = @_;
+ $TimeoutSpan =~ s/s//;
+ $TimeoutSpan *= 60 if $TimeoutSpan =~ m/m/;
+ $TimeoutSpan *= 3600 if $TimeoutSpan =~ m/h/;
+
+}
+
+##
+## As a byproduct, returns the basename of $0.
+##
+sub show_version
+{
+ local($base) = $0;
+ $base =~ s,.*/,,;
+ print STDERR "This is $base version $version\n";
+ $base;
+}
+
+##
+## &usage(exitval, message);
+##
+## Prints a usage message to STDERR.
+## If MESSAGE is defined, prints that first.
+## If exitval is defined, exits with that value. Otherwise, returns.
+##
+sub usage
+{
+ local($exit, $message) = @_;
+
+ print STDERR $message if defined $message;
+ local($base) = &show_version;
+ print STDERR <<INLINE_LITERAL_TEXT;
+usage: $0 [options] URL ...
+ Fetches and displays the named URL(s). Supports http and ftp.
+ (if no protocol is given, a leading "http://" is normally used).
+
+Options are from among:
+ -V, -version Print version information; exit.
+ -p, -post If URL looks like a form reply, does POST instead of GET.
+ -pf, -postfile Like -post, but takes everything after ? to be a filename.
+ -q, -quiet All non-essential informational messages are suppressed.
+ -nf, -nofollow Don't follow "this document has moved" replies.
+ -nr, -noretry Doesn't retry a failed hostname lookup (same as -retry 0)
+ -r #, -retry # Sets failed-hostname-lookup-retry to # (default $retry)
+ -np, -noproxy Uses no proxy, even if one defined for the protocol.
+ -ns, -nostrip The HTTP header, normally elided, is printed.
+ -head gets item header only (implies -ns)
+ -nab, -file Dumps output to file whose name taken from URL, minus path
+ -nnab Like -nab, but *also* dumps to stdout.
+ -update HTTP only. Like -nab, but only if the page has been modified.
+ -h, -help Prints this message.
+ -IfNewerThan F HTTP only. Only brings page if it is newer than named file.
+ -timeout T Fail if a connection can't be made in the specified time.
+
+ -updateme Pull the latest version of $base from
+ $WEB
+ and reports if it is newer than your current version.
+
+Comments to $comments.
+INLINE_LITERAL_TEXT
+
+ exit($exit) if defined $exit;
+}
+
+##
+## Pull the latest version of this program to a local file.
+## Clip the first couple lines from this executing file so that we
+## preserve the local invocation style.
+##
+sub updateme
+{
+ ##
+ ## Open a temp file to hold the new version,
+ ## redirecting STDOUT to it.
+ ##
+ open(STDOUT, '>'.($tempFile="/tmp/webget.new")) ||
+ open(STDOUT, '>'.($tempFile="/usr/tmp/webget.new")) ||
+ open(STDOUT, '>'.($tempFile="/webget.new")) ||
+ open(STDOUT, '>'.($tempFile="webget.new")) ||
+ die "$0: can't open a temp file.\n";
+
+ ##
+ ## See if we can figure out how we were called.
+ ## The seek will rewind not to the start of the data, but to the
+ ## start of the whole program script.
+ ##
+ ## Keep the first line if it begins with #!, and the next two if they
+ ## look like the trick mentioned in the perl man page for getting
+ ## around the lack of #!-support.
+ ##
+ if (seek(DATA, 0, 0)) { ##
+ $_ = <DATA>; if (m/^#!/) { print STDOUT;
+ $_ = <DATA>; if (m/^\s*eval/) { print STDOUT;
+ $_ = <DATA>; if (m/^\s*if/) { print STDOUT; }
+ }
+ }
+ print STDOUT "\n#-\n";
+ }
+
+ ## Go get the latest one...
+ local(@options);
+ push(@options, 'head') if $head;
+ push(@options, 'nofollow') unless $follow;
+ push(@options, ('retry') x $retry) if $retry;
+ push(@options, 'quiet') if $quiet;
+ push(@options, 'debug') if $debug;
+ local($status, $memo, %info) = &www'open_http_url(*IN, $WEB, @options);
+ die "fetching $WEB:\n $memo\n" unless $status eq 'ok';
+
+ $size = $info{'content-length'};
+ while (<IN>)
+ {
+ $size -= length;
+ print STDOUT;
+ if (!defined $fetched_version && m/version\s*=\s*"([^"]+)"/) {
+ $fetched_version = $1;
+ &general_read(*IN, $size);
+ last;
+ }
+ }
+
+ $fetched_version = "<unknown>" unless defined $fetched_version;
+
+ ##
+ ## Try to update the mode of the temp file with the mode of this file.
+ ## Don't worry if it fails.
+ ##
+ chmod($mode, $tempFile) if $mode = (stat($0))[2];
+
+ $as_well = '';
+ if ($fetched_version eq $version)
+ {
+ print STDERR "You already have the most-recent version ($version).\n",
+ qq/FWIW, the newly fetched one has been left in "$tempFile".\n/;
+ }
+ elsif ($fetched_version <= $version)
+ {
+ print STDERR
+ "Mmm, your current version seems newer (?!):\n",
+ qq/ your version: "$version"\n/,
+ qq/ new version: "$fetched_version"\n/,
+ qq/FWIW, fetched one left in "$tempFile".\n/;
+ }
+ else
+ {
+ print STDERR
+ "Indeed, your current version was old:\n",
+ qq/ your version: "$version"\n/,
+ qq/ new version: "$fetched_version"\n/,
+ qq/The file "$tempFile" is ready to replace the old one.\n/;
+ print STDERR qq/Just do:\n % mv $tempFile $0\n/ if -f $0;
+ $as_well = ' as well';
+ }
+ print STDERR "Note that the libraries it uses may (or may not) need updating$as_well.\n"
+ unless $inlined;
+ exit($EXIT_ok);
+}
+
+##
+## Given a list of URLs, fetch'em.
+## Parses the URL and calls the routine for the appropriate protocol
+##
+sub fetch_url
+{
+ local(@todo) = @_;
+ local(%circref, %hold_circref);
+
+ URL_LOOP: while (@todo)
+ {
+ $URL = shift(@todo);
+ %hold_circref = %circref; undef %circref;
+
+ local($protocol, @args) = &www'grok_URL($URL, $noproxy);
+
+ if (!defined $protocol) {
+ &www'message(1, qq/can't grok "$URL"/);
+ next URL_LOOP;
+ }
+
+ ## call protocol-specific handler
+ $func = "fetch_via_" . $protocol;
+ $error = &$func(@args, $TimeoutSpan);
+ if (defined $error) {
+ &www'message(1, "$URL: $error");
+ } else {
+ $SuccessfulCount++;
+ }
+ }
+}
+
+sub filedate
+{
+ local($filename) = @_;
+ local($filetime) = (stat($filename))[9];
+ return 0 if !defined $filetime;
+ local($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($filetime);
+ return 0 if !defined $wday;
+ sprintf(qq/"%s, %02d-%s-%02d %02d:%02d:%02d GMT"/,
+ ("Sunday", "Monday", "Tuesdsy", "Wednesday",
+ "Thursday", "Friday", "Saturday")[$wday],
+ $mday,
+ ("Jan", "Feb", "Mar", "Apr", "May", "Jun",
+ "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")[$mon],
+ $year,
+ $hour,
+ $min,
+ $sec);
+}
+
+sub local_filename
+{
+ local($filename) = @_;
+ $filename =~ s,/+$,,; ## remove any trailing slashes
+ $filename =~ s,.*/,,; ## remove any leading path
+ if ($filename eq '') {
+ ## empty -- pick a random name
+ $filename = "file0000";
+ ## look for a free random name.
+ $filename++ while -f $filename;
+ }
+ $filename;
+}
+
+sub set_output_file
+{
+ local($filename) = @_;
+ if (!open(OUT, ">$filename")) {
+ &www'message(1, "$0: can't open [$filename] for output");
+ } else {
+ open(SAVEOUT, ">>&STDOUT") || die "$!";;
+ open(STDOUT, ">>&OUT");
+ }
+}
+
+sub close_output_file
+{
+ local($filename) = @_;
+ unless ($quiet)
+ {
+ local($note) = qq/"$filename" written/;
+ if (defined $error) {
+ $note .= " (possibly corrupt due to error above)";
+ }
+ &www'message(1, "$note.");
+ }
+ close(STDOUT);
+ open(STDOUT, ">&SAVEOUT");
+}
+
+sub http_alarm
+{
+ &www'message(1, "ERROR: $AlarmNote.");
+ exit($EXIT_timeout); ## the alarm doesn't seem to cause a waiting syscall to break?
+# $HaveAlarm = 1;
+}
+
+##
+## Given the host, port, and path, and (for info only) real target,
+## fetch via HTTP.
+##
+## If there is a user and/or password, use that for Basic Authorization.
+##
+## If $timeout is nonzero, time out after that many seconds.
+##
+sub fetch_via_http
+{
+ local($host, $port, $path, $target, $user, $password, $timeout) = @_;
+ local(@options);
+ local($local_filename);
+
+ ##
+ ## If we're posting, but -postfile was given, we need to interpret
+ ## the item in $path after '?' as a filename, and replace it with
+ ## the contents of the file.
+ ##
+ if ($postfile && $path =~ s/\?([\d\D]*)//) {
+ local($filename) = $1;
+ return("can't open [$filename] to POST") if !open(IN, "<$filename");
+ local($/) = ''; ## want to suck up the whole file.
+ $path .= '?' . <IN>;
+ close(IN);
+ }
+
+ $local_filename = &local_filename($path)
+ if $refresh || $nab || defined($reference_file);
+ $refresh = &filedate($local_filename) if $refresh;
+ $refresh = &filedate($reference_file) if defined($reference_file);
+
+ push(@options, 'head') if $head;
+ push(@options, 'post') if $post;
+ push(@options, 'nofollow') unless $follow;
+ push(@options, ('retry') x 3);
+ push(@options, 'quiet') if $quiet;
+ push(@options, 'debug') if $debug;
+ push(@options, "ifmodifiedsince=$refresh") if $refresh;
+
+ if (defined $password || defined $user) {
+ local($auth) = join(':', ($user || ''), ($password || ''));
+ push(@options, "authorization=$auth");
+ }
+
+ local($old_alarm);
+ if ($timeout) {
+ $old_alarm = $SIG{'ALRM'} || 'DEFAULT';
+ $SIG{'ALRM'} = "main'http_alarm";
+# $HaveAlarm = 0;
+ $AlarmNote = "host $host";
+ $AlarmNote .= ":$port" if $port != $www'default_port{'http'};
+ $AlarmNote .= " timed out after $timeout second";
+ $AlarmNote .= 's' if $timeout > 1;
+ alarm($timeout);
+ }
+ local($result, $memo, %info) =
+ &www'open_http_connection(*HTTP, $host,$port,$path,$target,@options);
+
+ if ($timeout) {
+ alarm(0);
+ $SIG{'ALRM'} = $old_alarm;
+ }
+
+# if ($HaveAlarm) {
+# close(HTTP);
+# $error = "timeout after $timeout second";
+# $error .= "s" if $timeout > 1;
+# return $error;
+# }
+
+ if ($follow && ($result eq 'follow')) {
+ %circref = %hold_circref;
+ $circref{$memo} = 1;
+ unshift(@todo, $memo);
+ return undef;
+ }
+
+
+ return $memo if $result eq 'error';
+ if (!$quiet && $result eq 'status' && ! -t STDOUT) {
+ #&www'message(1, "Warning: $memo");
+ $error = "Warning: $memo";
+ }
+
+ if ($info{'CODE'} == 304) { ## 304 is magic for "Not Modified"
+ close(HTTP);
+ &www'message(1, "$URL: Not Modified") unless $quiet;
+ $NotModifiedCount++;
+ return undef; ## no error
+ }
+
+
+ &set_output_file($local_filename) if $nab;
+
+ unless($strip) {
+ print $info{'STATUS'}, "\n", $info{'HEADER'}, "\n";
+
+ print SAVEOUT $info{'STATUS'}, "\n", $info{'HEADER'}, "\n" if $nab==2;
+ }
+
+ if (defined $info{'BODY'}) {
+ print $info{'BODY'};
+ print SAVEOUT $info{'BODY'} if $nab==2;
+ }
+
+ if (!$head) {
+ &general_read(*HTTP, $info{'content-length'});
+ }
+ close(HTTP);
+ &close_output_file($local_filename) if $nab;
+
+ $error; ## will be 'undef' if no error;
+}
+
+sub fetch_via_ftp
+{
+ local($host, $port, $path, $target, $user, $password, $timeout) = @_;
+ local($local_filename) = &local_filename($path);
+ local($ftp_debug) = $debug;
+ local(@password) = ($password);
+ $path =~ s,^/,,; ## remove a leading / from the path.
+ $path = '.' if $path eq ''; ## make sure we have something
+
+ if (!defined $user) {
+ $user = 'anonymous';
+ $password = $ENV{'USER'} || 'WWWuser';
+ @password = ($password.'@'. &network'addr_to_ascii(&network'my_addr),
+ $password.'@');
+ } elsif (!defined $password) {
+ @password = ("");
+ }
+
+ local($_last_ftp_reply, $_passive_host, $_passive_port);
+ local($size);
+
+ sub _ftp_get_reply
+ {
+ local($text) = scalar(<FTP_CONTROL>);
+ die "lost connection to $host\n" if !defined $text;
+ local($_, $tmp);
+ print STDERR "READ: $text" if $ftp_debug;
+ die "internal error: expected reply code in response from ".
+ "ftp server [$text]" unless $text =~ s/^(\d+)([- ])//;
+ local($code) = $1;
+ if ($2 eq '-') {
+ while (<FTP_CONTROL>) {
+ ($tmp = $_) =~ s/^\d+[- ]//;
+ $text .= $tmp;
+ last if m/^$code /;
+ }
+ }
+ $text =~ s/^\d+ ?/<foo>/g;
+ ($code, $text);
+ }
+
+ sub _ftp_expect
+ {
+ local($code, $text) = &_ftp_get_reply;
+ $_last_ftp_reply = $text;
+ foreach $expect (@_) {
+ return ($code, $text) if $code == $expect;
+ }
+ die "internal error: expected return code ".
+ join('|',@_).", got [$text]";
+ }
+
+ sub _ftp_send
+ {
+ print STDERR "SEND: ", @_ if $ftp_debug;
+ print FTP_CONTROL @_;
+ }
+
+ sub _ftp_do_passive
+ {
+ local(@commands) = @_;
+
+ &_ftp_send("PASV\r\n");
+ local($code) = &_ftp_expect(227, 125);
+
+ if ($code == 227)
+ {
+ die "internal error: can't grok passive reply [$_last_ftp_reply]"
+ unless $_last_ftp_reply =~ m/\(([\d,]+)\)/;
+ local($a,$b,$c,$d, $p1, $p2) = split(/,/, $1);
+ ($_passive_host, $_passive_port) =
+ ("$a.$b.$c.$d", $p1*256 + $p2);
+ }
+
+ foreach(@commands) {
+ &_ftp_send($_);
+ }
+
+ local($error)=
+ &network'connect_to(*PASSIVE, $_passive_host, $_passive_port);
+ die "internal error: passive ftp connect [$error]" if $error;
+ }
+
+ ## make the connection to the host
+ &www'message($debug, "connecting to $host...") unless $quiet;
+
+ local($old_alarm);
+ if ($timeout) {
+ $old_alarm = $SIG{'ALRM'} || 'DEFAULT';
+ $SIG{'ALRM'} = "main'http_alarm"; ## can use this for now
+# $HaveAlarm = 0;
+ $AlarmNote = "host $host";
+ $AlarmNote .= ":$port" if $port != $www'default_port{'ftp'};
+ $AlarmNote .= " timed out after $timeout second";
+ $AlarmNote .= 's' if $timeout > 1;
+ alarm($timeout);
+ }
+
+ local($error) = &network'connect_to(*FTP_CONTROL, $host, $port);
+
+ if ($timeout) {
+ alarm(0);
+ $SIG{'ALRM'} = $old_alarm;
+ }
+
+ return $error if $error;
+
+ local ($code, $text) = &_ftp_get_reply(*FTP_CONTROL);
+ close(FTP_CONTROL), return "internal ftp error: [$text]" unless $code==220;
+
+ ## log in
+ &www'message($debug, "logging in as $user...") unless $quiet;
+ foreach $password (@password)
+ {
+ &_ftp_send("USER $user\r\n");
+ ($code, $text) = &_ftp_expect(230,331,530);
+ close(FTP_CONTROL), return $text if ($code == 530);
+ last if $code == 230; ## hey, already logged in, cool.
+
+ &_ftp_send("PASS $password\r\n");
+ ($code, $text) = &_ftp_expect(220,230,530,550,332);
+ last if $code != 550;
+ last if $text =~ m/can't change directory/;
+ }
+
+ if ($code == 550)
+ {
+ $text =~ s/\n+$//;
+ &www'message(1, "Can't log in $host: $text") unless $quiet;
+ exit($EXIT_error);
+ }
+
+ if ($code == 332)
+ {
+ &_ftp_send("ACCT noaccount\r\n");
+ ($code, $text) = &_ftp_expect(230, 202, 530, 500,501,503, 421)
+ }
+ close(FTP_CONTROL), return $text if $code >= 300;
+
+ &_ftp_send("TYPE I\r\n");
+ &_ftp_expect(200);
+
+ unless ($quiet) {
+ local($name) = $path;
+ $name =~ s,.*/([^/]),$1,;
+ &www'message($debug, "requesting $name...");
+ }
+ ## get file
+ &_ftp_do_passive("RETR $path\r\n");
+ ($code,$text) = &_ftp_expect(125, 150, 550, 530);
+ close(FTP_CONTROL), return $text if $code == 530;
+
+ if ($code == 550)
+ {
+ close(PASSIVE);
+ if ($text =~ /directory/i) {
+ ## probably from "no such file or directory", so just return now.
+ close(FTP_CONTROL);
+ return $text;
+ }
+
+ ## do like Mosaic and try getting a directory listing.
+ &_ftp_send("CWD $path\r\n");
+ ($code) = &_ftp_expect(250,550);
+ if ($code == 550) {
+ close(FTP_CONTROL);
+ return $text;
+ }
+ &_ftp_do_passive("LIST\r\n");
+ &_ftp_expect(125, 150);
+ }
+
+ $size = $1 if $text =~ m/(\d+)\s+bytes/;
+ binmode(PASSIVE); ## just in case.
+ &www'message($debug, "waiting for data...") unless $quiet;
+ &set_output_file($local_filename) if $nab;
+ &general_read(*PASSIVE, $size);
+ &close_output_file($local_filename) if $nab;
+
+ close(PASSIVE);
+ close(FTP_CONTROL);
+ undef;
+}
+
+sub general_read
+{
+ local(*INPUT, $size) = @_;
+ local($lastcount, $bytes) = (0,0);
+ local($need_to_clear) = 0;
+ local($start_time) = time;
+ local($last_time, $time) = $start_time;
+ ## Figure out how often to print the "bytes read" message
+ local($delta2print) =
+ (defined $size) ? int($size/50) : $defaultdelta2print;
+
+ &www'message(0, "read 0 bytes") unless $quiet;
+
+ ## so $! below is set only if a real error happens from now
+ eval 'local($^W) = 0; undef $!';
+
+
+ while (defined($_ = <INPUT>))
+ {
+ ## shove it out.
+ &www'clear_message if $need_to_clear;
+ print;
+ print SAVEOUT if $nab==2;
+
+ ## if we know the content-size, keep track of what we're reading.
+ $bytes += length;
+
+ last if eof || (defined $size && $bytes >= $size);
+
+ if (!$quiet && $bytes > ($lastcount + $delta2print))
+ {
+ if ($time = time, $last_time == $time) {
+ $delta2print *= 1.5;
+ } else {
+ $last_time = $time;
+ $lastcount = $bytes;
+ local($time_delta) = $time - $start_time;
+ local($text);
+
+ $delta2print /= $time_delta;
+ if (defined $size) {
+ $text = sprintf("read $bytes bytes (%.0f%%)",
+ $bytes*100/$size);
+ } else {
+ $text = "read $bytes bytes";
+ }
+
+ if ($time_delta > 5 || ($time_delta && $bytes > 10240))
+ {
+ local($rate) = int($bytes / $time_delta);
+ if ($rate < 5000) {
+ $text .= " ($rate bytes/sec)";
+ } elsif ($rate < 1024 * 10) {
+ $text .= sprintf(" (%.1f k/sec)", $rate/1024);
+ } else {
+ $text .= sprintf(" (%.0f k/sec)", $rate/1024);
+ }
+ }
+ &www'message(0, "$text...");
+ $need_to_clear = -t STDOUT;
+ }
+ }
+ }
+
+ if (!$quiet)
+ {
+ if ($size && ($size != $bytes)) {
+ &www'message("WARNING: Expected $size bytes, read $bytes bytes.\n");
+ }
+# if ($!) {
+# print STDERR "\$! is [$!]\n";
+# }
+# if ($@) {
+# print STDERR "\$\@ is [$@]\n";
+# }
+ }
+ &www'clear_message($text) unless $quiet;
+}
+
+sub dummy {
+ 1 || &dummy || &fetch_via_ftp || &fetch_via_http || &http_alarm;
+ 1 || close(OUT);
+ 1 || close(SAVEOUT);
+}
+
+__END__
+__END__
+:endofperl
diff --git a/win32/bin/www.pl b/win32/bin/www.pl
new file mode 100644
index 0000000000..8022597454
--- /dev/null
+++ b/win32/bin/www.pl
@@ -0,0 +1,901 @@
+##
+## Jeffrey Friedl (jfriedl@omron.co.jp)
+## Copyri.... ah hell, just take it.
+##
+## This is "www.pl".
+## Include (require) to use, execute ("perl www.pl") to print a man page.
+## Requires my 'network.pl' library.
+package www;
+$version = "951219.9";
+
+##
+## 951219.9
+## -- oops, stopped sending garbage Authorization line when no
+## authorization was requested.
+##
+## 951114.8
+## -- added support for HEAD, If-Modified-Since
+##
+## 951017.7
+## -- Change to allow a POST'ed HTTP text to have newlines in it.
+## Added 'NewURL to the open_http_connection %info. Idea courtesy
+## of Bryan Schmersal (http://www.transarc.com/~bryans/Home.html).
+##
+##
+## 950921.6
+## -- added more robust HTTP error reporting
+## (due to steven_campbell@uk.ibm.com)
+##
+## 950911.5
+## -- added Authorization support
+##
+
+##
+## HTTP return status codes.
+##
+%http_return_code =
+ (200,"OK",
+ 201,"Created",
+ 202,"Accepted",
+ 203,"Partial Information",
+ 204,"No Response",
+ 301,"Moved",
+ 302,"Found",
+ 303,"Method",
+ 304,"Not modified",
+ 400,"Bad request",
+ 401,"Unauthorized",
+ 402,"Payment required",
+ 403,"Forbidden",
+ 404,"Not found",
+ 500,"Internal error",
+ 501,"Not implemented",
+ 502,"Service temporarily overloaded",
+ 503,"Gateway timeout");
+
+##
+## If executed directly as a program, print as a man page.
+##
+if (length($0) >= 6 && substr($0, -6) eq 'www.pl')
+{
+ seek(DATA, 0, 0) || die "$0: can't reset internal pointer.\n";
+ print "www.pl version $version\n", '=' x 60, "\n";
+ while (<DATA>) {
+ next unless /^##>/../^##</; ## select lines to print
+ s/^##[<> ]?//; ## clean up
+ print;
+ }
+ exit(0);
+}
+
+##
+## History:
+## version 950425.4
+## added require for "network.pl"
+##
+## version 950425.3
+## re-did from "Www.pl" which was a POS.
+##
+##
+## BLURB:
+## A group of routines for dealing with URLs, HTTP sessions, proxies, etc.
+## Requires my 'network.pl' package. The library file can be executed
+## directly to produce a man page.
+
+##>
+## A motley group of routines for dealing with URLs, HTTP sessions, proxies,
+## etc. Requires my 'network.pl' package.
+##
+## Latest version, as well as other stuff (including network.pl) available
+## at http://www.wg.omron.co.jp/~jfriedl/perl/
+##
+## Simpleton complete program to dump a URL given on the command-line:
+##
+## require 'network.pl'; ## required for www.pl
+## require 'www.pl'; ## main routines
+## $URL = shift; ## get URL
+## ($status, $memo) = &www'open_http_url(*IN, $URL); ## connect
+## die "$memo\n" if $status ne 'ok'; ## report any error
+## print while <IN>; ## dump contents
+##
+## There are various options available for open_http_url.
+## For example, adding 'quiet' to the call, i.e. vvvvvvv-----added
+## ($status, $memo) = &www'open_http_url(*IN, $URL, 'quiet');
+## suppresses the normal informational messages such as "waiting for data...".
+##
+## The options, as well as the various other public routines in the package,
+## are discussed below.
+##
+##<
+
+##
+## Default port for the protocols whose URL we'll at least try to recognize.
+##
+%default_port = ('http', 80,
+ 'ftp', 21,
+ 'gopher', 70,
+ 'telnet', 23,
+ 'wais', 210,
+ );
+
+##
+## A "URL" to "ftp.blah.com" without a protocol specified is probably
+## best reached via ftp. If the hostname begins with a protocol name, it's
+## easy. But something like "www." maps to "http", so that mapping is below:
+##
+%name2protocol = (
+ 'www', 'http',
+ 'wwwcgi','http',
+);
+
+$last_message_length = 0;
+$useragent = "www.pl/$version";
+
+##
+##>
+##############################################################################
+## routine: open_http_url
+##
+## Used as
+## ($status, $memo, %info) = &www'open_http_url(*FILEHANDLE, $URL, options..)
+##
+## Given an unused filehandle, a URL, and a list of options, opens a socket
+## to the URL and returns with the filehandle ready to read the data of the
+## URL. The HTTP header, as well as other information, is returned in %info.
+##
+## OPTIONS are from among:
+##
+## "post"
+## If PATH appears to be a query (i.e. has a ? in it), contact
+## via a POST rather than a GET.
+##
+## "nofollow"
+## Normally, if the initial contact indicates that the URL has moved
+## to a different location, the new location is automatically contacted.
+## "nofollow" inhibits this.
+##
+## "noproxy"
+## Normally, a proxy will be used if 'http_proxy' is defined in the
+## environment. This option inhibits the use of a proxy.
+##
+## "retry"
+## If a host's address can't be found, it may well be because the
+## nslookup just didn't return in time and that retrying the lookup
+## after a few seconds will succeed. If this option is given, will
+## wait five seconds and try again. May be given multiple times to
+## retry multiple times.
+##
+## "quiet"
+## Informational messages will be suppressed.
+##
+## "debug"
+## Additional messages will be printed.
+##
+## "head"
+## Requests only the file header to be sent
+##
+##
+##
+##
+## The return array is ($STATUS, $MEMO, %INFO).
+##
+## STATUS is 'ok', 'error', 'status', or 'follow'
+##
+## If 'error', the MEMO will indicate why (URL was not http, can't
+## connect, etc.). INFO is probably empty, but may have some data.
+## See below.
+##
+## If 'status', the connnection was made but the reply was not a normal
+## "OK" successful reply (i.e. "Not found", etc.). MEMO is a note.
+## INFO is filled as noted below. Filehandle is ready to read (unless
+## $info{'BODY'} is filled -- see below), but probably most useful
+## to treat this as an 'error' response.
+##
+## If 'follow', MEMO is the new URL (for when 'nofollow' was used to
+## turn off automatic following) and INFO is filled as described
+## below. Unless you wish to give special treatment to these types of
+## responses, you can just treat 'follow' responses like 'ok'
+## responses.
+##
+## If 'ok', the connection went well and the filehandle is ready to
+## read.
+##
+## INFO contains data as described at the read_http_header() function (in
+## short, the HTTP response header) and additional informational fields.
+## In addition, the following fields are filled in which describe the raw
+## connection made or attempted:
+##
+## PROTOCOL, HOST, PORT, PATH
+##
+## Note that if a proxy is being used, these will describe the proxy.
+## The field TARGET will describe the host or host:port ultimately being
+## contacted. When no proxy is being used, this will be the same info as
+## in the raw connection fields above. However, if a proxy is being used,
+## it will refer to the final target.
+##
+## In some cases, the additional entry $info{'BODY'} exists as well. If
+## the result-code indicates an error, the body of the message may be
+## parsed for internal reasons (i.e. to support 'repeat'), and if so, it
+## will be saved in $info{'BODY}.
+##
+## If the URL has moved, $info{'NewURL'} will exist and contain the new
+## URL. This will be true even if the 'nofollow' option is specified.
+##
+##<
+##
+sub open_http_url
+{
+ local(*HTTP, $URL, @options) = @_;
+ return &open_http_connection(*HTTP, $URL, undef, undef, undef, @options);
+}
+
+
+##
+##>
+##############################################################################
+## routine: read_http_header
+##
+## Given a filehandle to a just-opened HTTP socket connection (such as one
+## created via &network'connect_to which has had the HTTP request sent),
+## reads the HTTP header and and returns the parsed info.
+##
+## ($replycode, %info) = &read_http_header(*FILEHANDLE);
+##
+## $replycode will be the HTTP reply code as described below, or
+## zero on header-read error.
+##
+## %info contains two types of fields:
+##
+## Upper-case fields are informational from the function.
+## Lower-case fields are the header field/value pairs.
+##
+## Upper-case fields:
+##
+## $info{'STATUS'} will be the first line read (HTTP status line)
+##
+## $info{'CODE'} will be the numeric HTTP reply code from that line.
+## This is also returned as $replycode.
+##
+## $info{'TYPE'} is the text from the status line that follows CODE.
+##
+## $info{'HEADER'} will be the raw text of the header (sans status line),
+## newlines and all.
+##
+## $info{'UNKNOWN'}, if defined, will be any header lines not in the
+## field/value format used to fill the lower-case fields of %info.
+##
+## Lower-case fields are reply-dependent, but in general are described
+## in http://info.cern.ch/hypertext/WWW/Protocols/HTTP/Object_Headers.html
+##
+## A header line such as
+## Content-type: Text/Plain
+## will appear as $info{'content-type'} = 'Text/Plain';
+##
+## (*) Note that while the field names are are lower-cased, the field
+## values are left as-is.
+##
+##
+## When $replycode is zero, there are two possibilities:
+## $info{'TYPE'} is 'empty'
+## No response was received from the filehandle before it was closed.
+## No other %info fields present.
+## $info{'TYPE'} is 'unknown'
+## First line of the response doesn't seem to be proper HTTP.
+## $info{'STATUS'} holds that line. No other %info fields present.
+##
+## The $replycode, when not zero, is as described at
+## http://info.cern.ch/hypertext/WWW/Protocols/HTTP/HTRESP.html
+##
+## Some of the codes:
+##
+## success 2xx
+## ok 200
+## created 201
+## accepted 202
+## partial information 203
+## no response 204
+## redirection 3xx
+## moved 301
+## found 302
+## method 303
+## not modified 304
+## error 4xx, 5xx
+## bad request 400
+## unauthorized 401
+## paymentrequired 402
+## forbidden 403
+## not found 404
+## internal error 500
+## not implemented 501
+## service temporarily overloaded 502
+## gateway timeout 503
+##
+##<
+##
+sub read_http_header
+{
+ local(*HTTP) = @_;
+ local(%info, $_);
+
+ ##
+ ## The first line of the response will be the status (OK, error, etc.)
+ ##
+ unless (defined($info{'STATUS'} = <HTTP>)) {
+ $info{'TYPE'} = "empty";
+ return (0, %info);
+ }
+ chop $info{'STATUS'};
+
+ ##
+ ## Check the status line. If it doesn't match and we don't know the
+ ## format, we'll just let it pass and hope for the best.
+ ##
+ unless ($info{'STATUS'} =~ m/^HTTP\S+\s+(\d\d\d)\s+(.*\S)/i) {
+ $info{'TYPE'} = 'unknown';
+ return (0, %info);
+ }
+
+ $info{'CODE'} = $1;
+ $info{'TYPE'} = $2;
+ $info{'HEADER'} = '';
+
+ ## read the rest of the header.
+ while (<HTTP>) {
+ last if m/^\s*$/;
+ $info{'HEADER'} .= $_; ## save whole text of header.
+
+ if (m/^([^\n:]+):[ \t]*(.*\S)/) {
+ local($field, $value) = ("\L$1", $2);
+ if (defined $info{$field}) {
+ $info{$field} .= "\n" . $value;
+ } else {
+ $info{$field} = $value;
+ }
+ } elsif (defined $info{'UNKNOWN'}) {
+ $info{'UNKNOWN'} .= $_;
+ } else {
+ $info{'UNKNOWN'} = $_;
+ }
+ }
+
+ return ($info{'CODE'}, %info);
+}
+
+##
+##>
+##
+##############################################################################
+## routine: grok_URL(URL, noproxy, defaultprotocol)
+##
+## Given a URL, returns access information. Deals with
+## http, wais, gopher, ftp, and telnet
+## URLs.
+##
+## Information returned is
+## (PROTOCOL, HOST, PORT, PATH, TARGET, USER, PASSWORD)
+##
+## If noproxy is not given (or false) and there is a proxy defined
+## for the given protocol (via the "*_proxy" environmental variable),
+## the returned access information will be for the proxy and will
+## reference the given URL. In this case, 'TARGET' will be the
+## HOST:PORT of the original URL (PORT elided if it's the default port).
+##
+## Access information returned:
+## PROTOCOL: "http", "ftp", etc. (guaranteed to be lowercase).
+## HOST: hostname or address as given.
+## PORT: port to access
+## PATH: path of resource on HOST:PORT.
+## TARGET: (see above)
+## USER and PASSWORD: for 'ftp' and 'telnet' URLs, if supplied by the
+## URL these will be defined, undefined otherwise.
+##
+## If no protocol is defined via the URL, the defaultprotocol will be used
+## if given. Otherwise, the URL's address will be checked for a leading
+## protocol name (as with a leading "www.") and if found will be used.
+## Otherwise, the protocol defaults to http.
+##
+## Fills in the appropriate default port for the protocol if need be.
+##
+## A proxy is defined by a per-protocol environmental variable such
+## as http_proxy. For example, you might have
+## setenv http_proxy http://firewall:8080/
+## setenv ftp_proxy $http_proxy
+## to set it up.
+##
+## A URL seems to be officially described at
+## http://www.w3.org/hypertext/WWW/Addressing/URL/5_BNF.html
+## although that document is a joke of errors.
+##
+##<
+##
+sub grok_URL
+{
+ local($_, $noproxy, $defaultprotocol) = @_;
+ $noproxy = defined($noproxy) && $noproxy;
+
+ ## Items to be filled in and returned.
+ local($protocol, $address, $port, $path, $target, $user, $password);
+
+ return undef unless m%^(([a-zA-Z]+)://|/*)([^/]+)(/.*)?$%;
+
+ ##
+ ## Due to a bug in some versions of perl5, $2 might not be empty
+ ## even if $1 is. Therefore, we must check $1 for a : to see if the
+ ## protocol stuff matched or not. If not, the protocol is undefined.
+ ##
+ ($protocol, $address, $path) = ((index($1,":") >= 0 ? $2 : undef), $3, $4);
+
+ if (!defined $protocol)
+ {
+ ##
+ ## Choose a default protocol if none given. If address begins with
+ ## a protocol name (one that we know via %name2protocol or
+ ## %default_port), choose it. Otherwise, choose http.
+ ##
+ if (defined $defaultprotocol) {
+ $protocol = $defaultprotocol;
+ }
+ else
+ {
+ $address =~ m/^[a-zA-Z]+/;
+ if (defined($name2protocol{"\L$&"})) {
+ $protocol = $name2protocol{"\L$&"};
+ } else {
+ $protocol = defined($default_port{"\L$&"}) ? $& : 'http';
+ }
+ }
+ }
+ $protocol =~ tr/A-Z/a-z/; ## ensure lower-case.
+
+ ##
+ ## Http support here probably not kosher, but fits in nice for basic
+ ## authorization.
+ ##
+ if ($protocol eq 'ftp' || $protocol eq 'telnet' || $protocol eq 'http')
+ {
+ ## Glean a username and password from address, if there.
+ ## There if address starts with USER[:PASSWORD]@
+ if ($address =~ s/^(([^\@:]+)(:([^@]+))?\@)//) {
+ ($user, $password) = ($2, $4);
+ }
+ }
+
+ ##
+ ## address left is (HOSTNAME|HOSTNUM)[:PORTNUM]
+ ##
+ if ($address =~ s/:(\d+)$//) {
+ $port = $1;
+ } else {
+ $port = $default_port{$protocol};
+ }
+
+ ## default path is '/';
+ $path = '/' if !defined $path;
+
+ ##
+ ## If there's a proxy and we're to proxy this request, do so.
+ ##
+ local($proxy) = $ENV{$protocol."_proxy"};
+ if (!$noproxy && defined($proxy) && !&no_proxy($protocol,$address))
+ {
+ local($dummy);
+ local($old_pass, $old_user);
+
+ ##
+ ## Since we're going through a proxy, we want to send the
+ ## proxy the entire URL that we want. However, when we're
+ ## doing Authenticated HTTP, we need to take out the user:password
+ ## that webget has encoded in the URL (this is a bit sleazy on
+ ## the part of webget, but the alternative is to have flags, and
+ ## having them part of the URL like with FTP, etc., seems a bit
+ ## cleaner to me in the context of how webget is used).
+ ##
+ ## So, if we're doing this slezy thing, we need to construct
+ ## the new URL from the compnents we have now (leaving out password
+ ## and user), decode the proxy URL, then return the info for
+ ## that host, a "filename" of the entire URL we really want, and
+ ## the user/password from the original URL.
+ ##
+ ## For all other things, we can just take the original URL,
+ ## ensure it has a protocol on it, and pass it as the "filename"
+ ## we want to the proxy host. The difference between reconstructing
+ ## the URL (as for HTTP Authentication) and just ensuring the
+ ## protocol is there is, except for the user/password stuff,
+ ## nothing. In theory, at least.
+ ##
+ if ($protocol eq 'http' && (defined($password) || defined($user)))
+ {
+ $path = "http://$address$path";
+ $old_pass = $password;
+ $old_user = $user;
+ } else {
+ ## Re-get original URL and ensure protocol// actually there.
+ ## This will become our new path.
+ ($path = $_) =~ s,^($protocol:)?/*,$protocol://,i;
+ }
+
+ ## note what the target will be
+ $target = ($port==$default_port{$protocol})?$address:"$address:$port";
+
+ ## get proxy info, discarding
+ ($protocol, $address, $port, $dummy, $dummy, $user, $password)
+ = &grok_URL($proxy, 1);
+ $password = $old_pass if defined $old_pass;
+ $user = $old_user if defined $old_user;
+ }
+ ($protocol, $address, $port, $path, $target, $user, $password);
+}
+
+
+
+##
+## &no_proxy($protocol, $host)
+##
+## Returns true if the specified host is identified in the no_proxy
+## environmental variable, or identify the proxy server itself.
+##
+sub no_proxy
+{
+ local($protocol, $targethost) = @_;
+ local(@dests, $dest, $host, @hosts, $aliases);
+ local($proxy) = $ENV{$protocol."_proxy"};
+ return 0 if !defined $proxy;
+ $targethost =~ tr/A-Z/a-z/; ## ensure all lowercase;
+
+ @dests = ($proxy);
+ push(@dests,split(/\s*,\s*/,$ENV{'no_proxy'})) if defined $ENV{'no_proxy'};
+
+ foreach $dest (@dests)
+ {
+ ## just get the hostname
+ $host = (&grok_URL($dest, 1), 'http')[1];
+
+ if (!defined $host) {
+ warn "can't grok [$dest] from no_proxy env.var.\n";
+ next;
+ }
+ @hosts = ($host); ## throw in original name just to make sure
+ ($host, $aliases) = (gethostbyname($host))[0, 1];
+
+ if (defined $aliases) {
+ push(@hosts, ($host, split(/\s+/, $aliases)));
+ } else {
+ push(@hosts, $host);
+ }
+ foreach $host (@hosts) {
+ next if !defined $host;
+ return 1 if "\L$host" eq $targethost;
+ }
+ }
+ return 0;
+}
+
+sub ensure_proper_network_library
+{
+ require 'network.pl' if !defined $network'version;
+ warn "WARNING:\n". __FILE__ .
+ qq/ needs a newer version of "network.pl"\n/ if
+ !defined($network'version) || $network'version < "950311.5";
+}
+
+
+
+##
+##>
+##############################################################################
+## open_http_connection(*FILEHANDLE, HOST, PORT, PATH, TARGET, OPTIONS...)
+##
+## Opens an HTTP connection to HOST:PORT and requests PATH.
+## TARGET is used only for informational messages to the user.
+##
+## If PORT and PATH are undefined, HOST is taken as an http URL and TARGET
+## is filled in as needed.
+##
+## Otherwise, it's the same as open_http_url (including return value, etc.).
+##<
+##
+sub open_http_connection
+{
+ local(*HTTP, $host, $port, $path, $target, @options) = @_;
+ local($post_text, @error, %seen);
+ local(%info);
+
+ &ensure_proper_network_library;
+
+ ## options allowed:
+ local($post, $retry, $authorization, $nofollow, $noproxy,
+ $head, $debug, $ifmodifiedsince, $quiet, ) = (0) x 10;
+ ## parse options:
+ foreach $opt (@options)
+ {
+ next unless defined($opt) && $opt ne '';
+ local($var, $val);
+ if ($opt =~ m/^(\w+)=(.*)/) {
+ ($var, $val) = ($1, $2);
+ } else {
+ $var = $opt;
+ $val = 1;
+ }
+ $var =~ tr/A-Z/a-z/; ## ensure variable is lowercase.
+ local(@error);
+
+ eval "if (defined \$$var) { \$$var = \$val; } else { \@error =
+ ('error', 'bad open_http_connection option [$opt]'); }";
+ return ('error', "open_http_connection eval: $@") if $@;
+ return @error if defined @error;
+ }
+ $quiet = 0 if $debug; ## debug overrides quiet
+
+ local($protocol, $error, $code, $URL, %info, $tmp, $aite);
+
+ ##
+ ## if both PORT and PATH are undefined, treat HOST as a URL.
+ ##
+ unless (defined($port) && defined($path))
+ {
+ ($protocol,$host,$port,$path,$target)=&grok_URL($host,$noproxy,'http');
+ if ($protocol ne "http") {
+ return ('error',"open_http_connection doesn't grok [$protocol]");
+ }
+ unless (defined($host)) {
+ return ('error', "can't grok [$URL]");
+ }
+ }
+
+ return ('error', "no port in URL [$URL]") unless defined $port;
+ return ('error', "no path in URL [$URL]") unless defined $path;
+
+ RETRY: while(1)
+ {
+ ## we'll want $URL around for error messages and such.
+ if ($port == $default_port{'http'}) {
+ $URL = "http://$host";
+ } else {
+ $URL = "http://$host:$default_port{'http'}";
+ }
+ $URL .= ord($path) eq ord('/') ? $path : "/$path";
+
+ $aite = defined($target) ? "$target via $host" : $host;
+
+ &message($debug, "connecting to $aite ...") unless $quiet;
+
+ ##
+ ## note some info that might be of use to the caller.
+ ##
+ local(%preinfo) = (
+ 'PROTOCOL', 'http',
+ 'HOST', $host,
+ 'PORT', $port,
+ 'PATH', $path,
+ );
+ if (defined $target) {
+ $preinfo{'TARGET'} = $target;
+ } elsif ($default_port{'http'} == $port) {
+ $preinfo{'TARGET'} = $host;
+ } else {
+ $preinfo{'TARGET'} = "$host:$port";
+ }
+
+ ## connect to the site
+ $error = &network'connect_to(*HTTP, $host, $port);
+ if (defined $error) {
+ return('error', "can't connect to $aite: $error", %preinfo);
+ }
+
+ ## If we're asked to POST and it looks like a POST, note post text.
+ if ($post && $path =~ m/\?/) {
+ $post_text = $'; ## everything after the '?'
+ $path = $`; ## everything before the '?'
+ }
+
+ ## send the POST or GET request
+ $tmp = $head ? 'HEAD' : (defined $post_text ? 'POST' : 'GET');
+
+ &message($debug, "sending request to $aite ...") if !$quiet;
+ print HTTP $tmp, " $path HTTP/1.0\n";
+
+ ## send the If-Modified-Since field if needed.
+ if ($ifmodifiedsince) {
+ print HTTP "If-Modified-Since: $ifmodifiedsince\n";
+ }
+
+ ## oh, let's sputter a few platitudes.....
+ print HTTP "Accept: */*\n";
+ print HTTP "User-Agent: $useragent\n" if defined $useragent;
+
+ ## If doing Authorization, do so now.
+ if ($authorization) {
+ print HTTP "Authorization: Basic ",
+ &htuu_encode($authorization), "\n";
+ }
+
+ ## If it's a post, send it.
+ if (defined $post_text)
+ {
+ print HTTP "Content-type: application/x-www-form-urlencoded\n";
+ print HTTP "Content-length: ", length $post_text, "\n\n";
+ print HTTP $post_text, "\n";
+ }
+ print HTTP "\n";
+ &message($debug, "waiting for data from $aite ...") unless $quiet;
+
+ ## we can now read the response (header, then body) via HTTP.
+ binmode(HTTP); ## just in case.
+
+ ($code, %info) = &read_http_header(*HTTP);
+ &message(1, "header returns code $code ($info{'TYPE'})") if $debug;
+
+ ## fill in info from %preinfo
+ local($val, $key);
+ while (($val, $key) = each %preinfo) {
+ $info{$val} = $key;
+ }
+
+ if ($code == 0)
+ {
+ return('error',"empty response for $URL")
+ if $info{'TYPE'} eq 'empty';
+ return('error', "non-HTTP response for $URL", %info)
+ if $info{'TYPE'} eq 'unknown';
+ return('error', "unknown zero-code for $URL", %info);
+ }
+
+ if ($code == 302) ## 302 is magic for "Found"
+ {
+ if (!defined $info{'location'}) {
+ return('error', "No location info for Found URL $URL", %info);
+ }
+ local($newURL) = $info{'location'};
+
+ ## Remove :80 from hostname, if there. Looks ugly.
+ $newURL =~ s,^(http:/+[^/:]+):80/,$1/,i;
+ $info{"NewURL"} = $newURL;
+
+ ## if we're not following links or if it's not to HTTP, return.
+ return('follow', $newURL, %info) if
+ $nofollow || $newURL!~m/^http:/i;
+
+ ## note that we've seen this current URL.
+ $seen{$host, $port, $path} = 1;
+
+ &message(1, qq/[note: now moved to "$newURL"]/) unless $quiet;
+
+
+ ## get the new one and return an error if it's been seen.
+ ($protocol, $host, $port, $path, $target) =
+ &www'grok_URL($newURL, $noproxy);
+ &message(1, "[$protocol][$host][$port][$path]") if $debug;
+
+ if (defined $seen{$host, $port, $path})
+ {
+ return('error', "circular reference among:\n ".
+ join("\n ", sort grep(/^http/i, keys %seen)), %seen);
+ }
+ next RETRY;
+ }
+ elsif ($code == 500) ## 500 is magic for "internal error"
+ {
+ ##
+ ## A proxy will often return this with text saying "can't find
+ ## host" when in reality it's just because the nslookup returned
+ ## null at the time. Such a thing should be retied again after a
+ ## few seconds.
+ ##
+ if ($retry)
+ {
+ local($_) = $info{'BODY'} = join('', <HTTP>);
+ if (/Can't locate remote host:\s*(\S+)/i) {
+ local($times) = ($retry == 1) ?
+ "once more" : "up to $retry more times";
+ &message(0, "can't locate $1, will try $times ...")
+ unless $quiet;
+ sleep(5);
+ $retry--;
+ next RETRY;
+ }
+ }
+ }
+
+ if ($code != 200) ## 200 is magic for "OK";
+ {
+ ## I'll deal with these as I see them.....
+ &clear_message;
+ if ($info{'TYPE'} eq '')
+ {
+ if (defined $http_return_code{$code}) {
+ $info{'TYPE'} = $http_return_code{$code};
+ } else {
+ $info{'TYPE'} = "(unknown status code $code)";
+ }
+ }
+ return ('status', $info{'TYPE'}, %info);
+ }
+
+ &clear_message;
+ return ('ok', 'ok', %info);
+ }
+}
+
+
+##
+## Hyper Text UUencode. Somewhat different from regular uuencode.
+##
+## Logic taken from Mosaic for X code by Mark Riordan and Ari Luotonen.
+##
+sub htuu_encode
+{
+ local(@in) = unpack("C*", $_[0]);
+ local(@out);
+
+ push(@in, 0, 0); ## in case we need to round off an odd byte or two
+ while (@in >= 3) {
+ ##
+ ## From the next three input bytes,
+ ## construct four encoded output bytes.
+ ##
+ push(@out, $in[0] >> 2);
+ push(@out, (($in[0] << 4) & 060) | (($in[1] >> 4) & 017));
+ push(@out, (($in[1] << 2) & 074) | (($in[2] >> 6) & 003));
+ push(@out, $in[2] & 077);
+ splice(@in, 0, 3); ## remove these three
+ }
+
+ ##
+ ## @out elements are now indices to the string below. Convert to
+ ## the appropriate actual text.
+ ##
+ foreach $new (@out) {
+ $new = substr(
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/",
+ $new, 1);
+ }
+
+ if (@in == 2) {
+ ## the two left over are the two extra nulls, so we encoded the proper
+ ## amount as-is.
+ } elsif (@in == 1) {
+ ## We encoded one extra null too many. Undo it.
+ $out[$#out] = '=';
+ } else {
+ ## We must have encoded two nulls... Undo both.
+ $out[$#out ] = '=';
+ $out[$#out -1] = '=';
+ }
+
+ join('', @out);
+}
+
+##
+## This message stuff really shouldn't be here, but in some seperate library.
+## Sorry.
+##
+## Called as &message(SAVE, TEXT ....), it shoves the text to the screen.
+## If SAVE is true, bumps the text out as a printed line. Otherwise,
+## will shove out without a newline so that the next message overwrites it,
+## or it is clearded via &clear_message().
+##
+sub message
+{
+ local($nl) = shift;
+ die "oops $nl." unless $nl =~ m/^\d+$/;
+ local($text) = join('', @_);
+ local($NL) = $nl ? "\n" : "\r";
+ $thislength = length($text);
+ if ($thislength >= $last_message_length) {
+ print STDERR $text, $NL;
+ } else {
+ print STDERR $text, ' 'x ($last_message_length-$thislength), $NL;
+ }
+ $last_message_length = $nl ? 0 : $thislength;
+}
+
+sub clear_message
+{
+ if ($last_message_length) {
+ print STDERR ' ' x $last_message_length, "\r";
+ $last_message_length = 0;
+ }
+}
+
+1;
+__END__