home *** CD-ROM | disk | FTP | other *** search
/ Chip: Windows 2000 Professional Resource Kit / W2KPRK.iso / apps / perl / ActivePerl.exe / data.z / www.bat < prev    next >
Encoding:
DOS Batch File  |  1999-10-16  |  27.6 KB  |  917 lines
  1. @rem = '--*-Perl-*--
  2. @echo off
  3. if "%OS%" == "Windows_NT" goto WinNT
  4. perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
  5. goto endofperl
  6. :WinNT
  7. perl -x -S "%0" %*
  8. if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
  9. if %errorlevel% == 9009 echo You do not have Perl in your PATH.
  10. goto endofperl
  11. @rem ';
  12. #!perl
  13. #line 14
  14. ##
  15. ## Jeffrey Friedl (jfriedl@omron.co.jp)
  16. ## Copyri.... ah hell, just take it.
  17. ##
  18. ## This is "www.pl".
  19. ## Include (require) to use, execute ("perl www.pl") to print a man page.
  20. ## Requires my 'network.pl' library.
  21. package www;
  22. $version = "951219.9";
  23.  
  24. ##
  25. ## 951219.9
  26. ## -- oops, stopped sending garbage Authorization line when no
  27. ##    authorization was requested.
  28. ##
  29. ## 951114.8
  30. ## -- added support for HEAD, If-Modified-Since
  31. ##
  32. ## 951017.7
  33. ## -- Change to allow a POST'ed HTTP text to have newlines in it.
  34. ##    Added 'NewURL to the open_http_connection %info. Idea courtesy
  35. ##    of Bryan Schmersal (http://www.transarc.com/~bryans/Home.html).
  36. ##
  37. ##
  38. ## 950921.6
  39. ## -- added more robust HTTP error reporting
  40. ##    (due to steven_campbell@uk.ibm.com)
  41. ##
  42. ## 950911.5
  43. ## -- added Authorization support
  44. ##
  45.  
  46. ##
  47. ## HTTP return status codes.
  48. ##
  49. %http_return_code =
  50.     (200,"OK",
  51.      201,"Created",
  52.      202,"Accepted",
  53.      203,"Partial Information",
  54.      204,"No Response",
  55.      301,"Moved",
  56.      302,"Found",
  57.      303,"Method",
  58.      304,"Not modified",
  59.      400,"Bad request",
  60.      401,"Unauthorized",
  61.      402,"Payment required",
  62.      403,"Forbidden",
  63.      404,"Not found",
  64.      500,"Internal error",
  65.      501,"Not implemented",
  66.      502,"Service temporarily overloaded",
  67.      503,"Gateway timeout");
  68.  
  69. ##
  70. ## If executed directly as a program, print as a man page.
  71. ##
  72. if (length($0) >= 6 && substr($0, -6) eq 'www.pl')
  73. {
  74.    seek(DATA, 0, 0) || die "$0: can't reset internal pointer.\n";
  75.    print "www.pl version $version\n", '=' x 60, "\n";
  76.    while (<DATA>) {
  77.     next unless /^##>/../^##</;   ## select lines to print
  78.     s/^##[<> ]?//;                ## clean up
  79.     print;
  80.    }
  81.    exit(0);
  82. }
  83.  
  84. ##
  85. ## History:
  86. ##   version 950425.4
  87. ##      added require for "network.pl"
  88. ##
  89. ##   version 950425.3
  90. ##      re-did from "Www.pl" which was a POS.
  91. ## 
  92. ##
  93. ## BLURB:
  94. ##   A group of routines for dealing with URLs, HTTP sessions, proxies, etc.
  95. ##   Requires my 'network.pl' package. The library file can be executed
  96. ##   directly to produce a man page.
  97.  
  98. ##>
  99. ## A motley group of routines for dealing with URLs, HTTP sessions, proxies,
  100. ## etc. Requires my 'network.pl' package.
  101. ##
  102. ## Latest version, as well as other stuff (including network.pl) available
  103. ## at http://www.wg.omron.co.jp/~jfriedl/perl/
  104. ##
  105. ## Simpleton complete program to dump a URL given on the command-line:
  106. ##
  107. ##    require 'network.pl';                             ## required for www.pl
  108. ##    require 'www.pl';                                 ## main routines
  109. ##    $URL = shift;                                     ## get URL
  110. ##    ($status, $memo) = &www'open_http_url(*IN, $URL); ## connect
  111. ##    die "$memo\n" if $status ne 'ok';                 ## report any error
  112. ##    print while <IN>;                                 ## dump contents
  113. ##
  114. ## There are various options available for open_http_url.
  115. ## For example, adding 'quiet' to the call, i.e.       vvvvvvv-----added
  116. ##    ($status, $memo) = &www'open_http_url(*IN, $URL, 'quiet');
  117. ## suppresses the normal informational messages such as "waiting for data...".
  118. ##
  119. ## The options, as well as the various other public routines in the package,
  120. ## are discussed below.
  121. ##
  122. ##<
  123.  
  124. ##
  125. ## Default port for the protocols whose URL we'll at least try to recognize.
  126. ##
  127. %default_port = ('http', 80,
  128.          'ftp',  21,
  129.          'gopher', 70,
  130.          'telnet', 23,
  131.          'wais', 210,
  132.          );
  133.  
  134. ##
  135. ## A "URL" to "ftp.blah.com" without a protocol specified is probably
  136. ## best reached via ftp. If the hostname begins with a protocol name, it's
  137. ## easy. But something like "www." maps to "http", so that mapping is below:
  138. ##
  139. %name2protocol = (
  140.     'www',     'http',
  141.     'wwwcgi','http',
  142. );
  143.  
  144. $last_message_length = 0;
  145. $useragent = "www.pl/$version";
  146.  
  147. ##
  148. ##>
  149. ##############################################################################
  150. ## routine: open_http_url
  151. ##
  152. ## Used as
  153. ##  ($status, $memo, %info) = &www'open_http_url(*FILEHANDLE, $URL, options..)
  154. ##
  155. ## Given an unused filehandle, a URL, and a list of options, opens a socket
  156. ## to the URL and returns with the filehandle ready to read the data of the
  157. ## URL. The HTTP header, as well as other information, is returned in %info.
  158. ##
  159. ## OPTIONS are from among:
  160. ##
  161. ##   "post"
  162. ##    If PATH appears to be a query (i.e. has a ? in it), contact
  163. ##    via a POST rather than a GET.
  164. ##
  165. ##   "nofollow" 
  166. ##    Normally, if the initial contact indicates that the URL has moved
  167. ##    to a different location, the new location is automatically contacted.
  168. ##    "nofollow" inhibits this.
  169. ##
  170. ##   "noproxy"
  171. ##    Normally, a proxy will be used if 'http_proxy' is defined in the
  172. ##    environment. This option inhibits the use of a proxy.
  173. ##
  174. ##   "retry"
  175. ##    If a host's address can't be found, it may well be because the
  176. ##    nslookup just didn't return in time and that retrying the lookup
  177. ##    after a few seconds will succeed. If this option is given, will
  178. ##    wait five seconds and try again. May be given multiple times to
  179. ##    retry multiple times.
  180. ##
  181. ##   "quiet"
  182. ##    Informational messages will be suppressed.
  183. ##
  184. ##   "debug"
  185. ##    Additional messages will be printed.
  186. ##
  187. ##   "head"
  188. ##      Requests only the file header to be sent
  189. ##
  190. ##
  191. ##
  192. ##
  193. ## The return array is ($STATUS, $MEMO, %INFO).
  194. ##
  195. ##    STATUS is 'ok', 'error', 'status', or 'follow'
  196. ##
  197. ##    If 'error', the MEMO will indicate why (URL was not http, can't
  198. ##    connect, etc.). INFO is probably empty, but may have some data.
  199. ##    See below.
  200. ##
  201. ##    If 'status', the connnection was made but the reply was not a normal
  202. ##    "OK" successful reply (i.e. "Not found", etc.). MEMO is a note.
  203. ##    INFO is filled as noted below. Filehandle is ready to read (unless
  204. ##    $info{'BODY'} is filled -- see below), but probably most useful
  205. ##    to treat this as an 'error' response.
  206. ##
  207. ##    If 'follow', MEMO is the new URL (for when 'nofollow' was used to
  208. ##    turn off automatic following) and INFO is filled as described
  209. ##    below.  Unless you wish to give special treatment to these types of
  210. ##    responses, you can just treat 'follow' responses like 'ok'
  211. ##    responses.
  212. ##
  213. ##    If 'ok', the connection went well and the filehandle is ready to
  214. ##      read.
  215. ##
  216. ##   INFO contains data as described at the read_http_header() function (in
  217. ##   short, the HTTP response header) and additional informational fields.
  218. ##   In addition, the following fields are filled in which describe the raw
  219. ##   connection made or attempted:
  220. ##
  221. ##     PROTOCOL, HOST, PORT, PATH
  222. ##
  223. ##   Note that if a proxy is being used, these will describe the proxy.
  224. ##   The field TARGET will describe the host or host:port ultimately being
  225. ##   contacted. When no proxy is being used, this will be the same info as
  226. ##   in the raw connection fields above. However, if a proxy is being used,
  227. ##   it will refer to the final target.
  228. ##
  229. ##   In some cases, the additional entry $info{'BODY'} exists as well. If
  230. ##   the result-code indicates an error, the body of the message may be
  231. ##   parsed for internal reasons (i.e. to support 'repeat'), and if so, it
  232. ##   will be saved in $info{'BODY}.
  233. ##
  234. ##   If the URL has moved, $info{'NewURL'} will exist and contain the new
  235. ##   URL.  This will be true even if the 'nofollow' option is specified.
  236. ##   
  237. ##<
  238. ##
  239. sub open_http_url
  240. {
  241.     local(*HTTP, $URL, @options) = @_;
  242.     return &open_http_connection(*HTTP, $URL, undef, undef, undef, @options);
  243. }
  244.  
  245.  
  246. ##
  247. ##>
  248. ##############################################################################
  249. ## routine: read_http_header
  250. ##
  251. ## Given a filehandle to a just-opened HTTP socket connection (such as one
  252. ## created via &network'connect_to which has had the HTTP request sent),
  253. ## reads the HTTP header and and returns the parsed info.
  254. ##
  255. ##   ($replycode, %info) = &read_http_header(*FILEHANDLE);
  256. ##
  257. ## $replycode will be the HTTP reply code as described below, or
  258. ## zero on header-read error.
  259. ## 
  260. ## %info contains two types of fields:
  261. ##
  262. ##    Upper-case fields are informational from the function.
  263. ##    Lower-case fields are the header field/value pairs.
  264. ##
  265. ##  Upper-case fields:
  266. ##
  267. ##     $info{'STATUS'} will be the first line read (HTTP status line)
  268. ##
  269. ##     $info{'CODE'} will be the numeric HTTP reply code from that line.
  270. ##       This is also returned as $replycode.
  271. ##
  272. ##     $info{'TYPE'} is the text from the status line that follows CODE.
  273. ##
  274. ##     $info{'HEADER'} will be the raw text of the header (sans status line),
  275. ##       newlines and all.
  276. ##
  277. ##     $info{'UNKNOWN'}, if defined, will be any header lines not in the
  278. ##       field/value format used to fill the lower-case fields of %info.
  279. ##
  280. ##  Lower-case fields are reply-dependent, but in general are described
  281. ##  in http://info.cern.ch/hypertext/WWW/Protocols/HTTP/Object_Headers.html
  282. ##
  283. ##  A header line such as
  284. ##      Content-type: Text/Plain
  285. ##  will appear as $info{'content-type'} = 'Text/Plain';
  286. ##
  287. ##  (*) Note that while the field names are are lower-cased, the field
  288. ##      values are left as-is.
  289. ##
  290. ##
  291. ## When $replycode is zero, there are two possibilities:
  292. ##    $info{'TYPE'} is 'empty'
  293. ##        No response was received from the filehandle before it was closed.
  294. ##        No other %info fields present.
  295. ##    $info{'TYPE'} is 'unknown'
  296. ##        First line of the response doesn't seem to be proper HTTP.
  297. ##        $info{'STATUS'} holds that line. No other %info fields present.
  298. ##
  299. ## The $replycode, when not zero, is as described at
  300. ##        http://info.cern.ch/hypertext/WWW/Protocols/HTTP/HTRESP.html
  301. ##
  302. ## Some of the codes:
  303. ##
  304. ##   success 2xx
  305. ##    ok 200
  306. ##    created 201
  307. ##    accepted 202
  308. ##    partial information 203
  309. ##    no response 204
  310. ##   redirection 3xx
  311. ##    moved 301
  312. ##    found 302
  313. ##    method 303
  314. ##    not modified 304
  315. ##   error 4xx, 5xx
  316. ##    bad request 400
  317. ##    unauthorized 401
  318. ##    paymentrequired 402
  319. ##    forbidden 403
  320. ##    not found 404
  321. ##    internal error 500
  322. ##    not implemented 501
  323. ##    service temporarily overloaded 502
  324. ##    gateway timeout 503
  325. ##
  326. ##<
  327. ##
  328. sub read_http_header
  329. {
  330.     local(*HTTP) = @_;
  331.     local(%info, $_);
  332.  
  333.     ##
  334.     ## The first line of the response will be the status (OK, error, etc.)
  335.     ##
  336.     unless (defined($info{'STATUS'} = <HTTP>)) {
  337.     $info{'TYPE'} = "empty";
  338.         return (0, %info);
  339.     }
  340.     chop $info{'STATUS'};
  341.  
  342.     ##
  343.     ## Check the status line. If it doesn't match and we don't know the
  344.     ## format, we'll just let it pass and hope for the best.
  345.     ##
  346.     unless ($info{'STATUS'} =~ m/^HTTP\S+\s+(\d\d\d)\s+(.*\S)/i) {
  347.     $info{'TYPE'} = 'unknown';
  348.         return (0, %info);
  349.     }
  350.  
  351.     $info{'CODE'} = $1;
  352.     $info{'TYPE'} = $2;
  353.     $info{'HEADER'} = '';
  354.  
  355.     ## read the rest of the header.
  356.     while (<HTTP>) {
  357.     last if m/^\s*$/;
  358.     $info{'HEADER'} .= $_; ## save whole text of header.
  359.  
  360.     if (m/^([^\n:]+):[ \t]*(.*\S)/) {
  361.         local($field, $value) = ("\L$1", $2);
  362.         if (defined $info{$field}) {
  363.         $info{$field} .= "\n" . $value;
  364.         } else {
  365.         $info{$field} = $value;
  366.         }
  367.     } elsif (defined $info{'UNKNOWN'}) {
  368.         $info{'UNKNOWN'} .= $_;
  369.     } else {
  370.         $info{'UNKNOWN'} = $_;
  371.     }
  372.     }
  373.  
  374.     return ($info{'CODE'}, %info);
  375. }
  376.  
  377. ##
  378. ##>
  379. ##
  380. ##############################################################################
  381. ## routine: grok_URL(URL, noproxy, defaultprotocol)
  382. ##
  383. ## Given a URL, returns access information. Deals with
  384. ##    http, wais, gopher, ftp, and telnet
  385. ## URLs.
  386. ##
  387. ## Information returned is
  388. ##     (PROTOCOL, HOST, PORT, PATH, TARGET, USER, PASSWORD)
  389. ##
  390. ## If noproxy is not given (or false) and there is a proxy defined
  391. ## for the given protocol (via the "*_proxy" environmental variable),
  392. ## the returned access information will be for the proxy and will
  393. ## reference the given URL. In this case, 'TARGET' will be the
  394. ## HOST:PORT of the original URL (PORT elided if it's the default port).
  395. ##
  396. ## Access information returned:
  397. ##   PROTOCOL: "http", "ftp", etc. (guaranteed to be lowercase).
  398. ##   HOST: hostname or address as given.
  399. ##   PORT: port to access
  400. ##   PATH: path of resource on HOST:PORT.
  401. ##   TARGET: (see above)
  402. ##   USER and PASSWORD: for 'ftp' and 'telnet' URLs, if supplied by the
  403. ##      URL these will be defined, undefined otherwise.
  404. ##
  405. ## If no protocol is defined via the URL, the defaultprotocol will be used
  406. ## if given. Otherwise, the URL's address will be checked for a leading
  407. ## protocol name (as with a leading "www.") and if found will be used.
  408. ## Otherwise, the protocol defaults to http.
  409. ##
  410. ## Fills in the appropriate default port for the protocol if need be.
  411. ##
  412. ## A proxy is defined by a per-protocol environmental variable such
  413. ## as http_proxy. For example, you might have
  414. ##    setenv http_proxy http://firewall:8080/
  415. ##    setenv ftp_proxy $http_proxy
  416. ## to set it up.
  417. ##
  418. ## A URL seems to be officially described at
  419. ##    http://www.w3.org/hypertext/WWW/Addressing/URL/5_BNF.html
  420. ## although that document is a joke of errors.
  421. ##
  422. ##<
  423. ##
  424. sub grok_URL
  425. {
  426.     local($_, $noproxy, $defaultprotocol) = @_;
  427.     $noproxy = defined($noproxy) && $noproxy;
  428.  
  429.     ## Items to be filled in and returned.
  430.     local($protocol, $address, $port, $path, $target, $user, $password);
  431.  
  432.     return undef unless m%^(([a-zA-Z]+)://|/*)([^/]+)(/.*)?$%;
  433.  
  434.     ##
  435.     ## Due to a bug in some versions of perl5, $2 might not be empty
  436.     ## even if $1 is. Therefore, we must check $1 for a : to see if the
  437.     ## protocol stuff matched or not. If not, the protocol is undefined.
  438.     ##
  439.     ($protocol, $address, $path) = ((index($1,":") >= 0 ? $2 : undef), $3, $4);
  440.  
  441.     if (!defined $protocol)
  442.     {
  443.     ##
  444.         ## Choose a default protocol if none given. If address begins with
  445.     ## a protocol name (one that we know via %name2protocol or
  446.     ## %default_port), choose it. Otherwise, choose http.
  447.     ##
  448.     if (defined $defaultprotocol)    {
  449.         $protocol = $defaultprotocol;
  450.     }
  451.     else
  452.     {
  453.         $address =~ m/^[a-zA-Z]+/;
  454.         if (defined($name2protocol{"\L$&"})) {
  455.         $protocol = $name2protocol{"\L$&"};
  456.         } else {
  457.         $protocol = defined($default_port{"\L$&"}) ? $& : 'http';
  458.         }
  459.         }
  460.     }
  461.     $protocol =~ tr/A-Z/a-z/; ## ensure lower-case.
  462.  
  463.     ##
  464.     ## Http support here probably not kosher, but fits in nice for basic
  465.     ## authorization.
  466.     ##
  467.     if ($protocol eq 'ftp' || $protocol eq 'telnet' || $protocol eq 'http')
  468.     {
  469.         ## Glean a username and password from address, if there.
  470.         ## There if address starts with USER[:PASSWORD]@
  471.     if ($address =~ s/^(([^\@:]+)(:([^@]+))?\@)//) {
  472.         ($user, $password) = ($2, $4);
  473.     }
  474.     }
  475.  
  476.     ##
  477.     ## address left is (HOSTNAME|HOSTNUM)[:PORTNUM]
  478.     ##
  479.     if ($address =~ s/:(\d+)$//) {
  480.        $port = $1;
  481.     } else {
  482.        $port = $default_port{$protocol};
  483.     }
  484.  
  485.     ## default path is '/';
  486.     $path = '/' if !defined $path;
  487.  
  488.     ##
  489.     ## If there's a proxy and we're to proxy this request, do so.
  490.     ##
  491.     local($proxy) = $ENV{$protocol."_proxy"};
  492.     if (!$noproxy && defined($proxy) && !&no_proxy($protocol,$address))
  493.     {
  494.     local($dummy);
  495.     local($old_pass, $old_user);
  496.  
  497.     ##
  498.     ## Since we're going through a proxy, we want to send the
  499.     ## proxy the entire URL that we want. However, when we're
  500.     ## doing Authenticated HTTP, we need to take out the user:password
  501.     ## that webget has encoded in the URL (this is a bit sleazy on
  502.     ## the part of webget, but the alternative is to have flags, and
  503.     ## having them part of the URL like with FTP, etc., seems a bit
  504.     ## cleaner to me in the context of how webget is used).
  505.     ##
  506.     ## So, if we're doing this slezy thing, we need to construct
  507.     ## the new URL from the compnents we have now (leaving out password
  508.     ## and user), decode the proxy URL, then return the info for
  509.     ## that host, a "filename" of the entire URL we really want, and
  510.     ## the user/password from the original URL.
  511.     ##
  512.     ## For all other things, we can just take the original URL,
  513.     ## ensure it has a protocol on it, and pass it as the "filename"
  514.     ## we want to the proxy host. The difference between reconstructing
  515.     ## the URL (as for HTTP Authentication) and just ensuring the
  516.     ## protocol is there is, except for the user/password stuff,
  517.     ## nothing. In theory, at least.
  518.     ##
  519.         if ($protocol eq 'http' && (defined($password) || defined($user)))
  520.     {
  521.         $path = "http://$address$path";
  522.         $old_pass = $password;
  523.         $old_user = $user;
  524.     } else {
  525.         ## Re-get original URL and ensure protocol// actually there.
  526.         ## This will become our new path.
  527.         ($path = $_) =~ s,^($protocol:)?/*,$protocol://,i;
  528.         }
  529.  
  530.     ## note what the target will be
  531.     $target = ($port==$default_port{$protocol})?$address:"$address:$port";
  532.  
  533.     ## get proxy info, discarding
  534.         ($protocol, $address, $port, $dummy, $dummy, $user, $password)
  535.         = &grok_URL($proxy, 1);
  536.         $password = $old_pass if defined $old_pass;
  537.         $user     = $old_user if defined $old_user;
  538.     }
  539.     ($protocol, $address, $port, $path, $target, $user, $password);
  540. }
  541.  
  542.  
  543.  
  544. ##
  545. ## &no_proxy($protocol, $host)
  546. ##
  547. ## Returns true if the specified host is identified in the no_proxy
  548. ## environmental variable, or identify the proxy server itself.
  549. ##
  550. sub no_proxy
  551. {
  552.     local($protocol, $targethost) = @_;
  553.     local(@dests, $dest, $host, @hosts, $aliases);
  554.     local($proxy) = $ENV{$protocol."_proxy"};
  555.     return 0 if !defined $proxy;
  556.     $targethost =~ tr/A-Z/a-z/; ## ensure all lowercase;
  557.  
  558.     @dests = ($proxy);
  559.     push(@dests,split(/\s*,\s*/,$ENV{'no_proxy'})) if defined $ENV{'no_proxy'};
  560.  
  561.     foreach $dest (@dests)
  562.     {
  563.     ## just get the hostname
  564.     $host = (&grok_URL($dest, 1), 'http')[1];
  565.  
  566.     if (!defined $host) {
  567.         warn "can't grok [$dest] from no_proxy env.var.\n";
  568.         next;
  569.     }
  570.     @hosts = ($host); ## throw in original name just to make sure
  571.     ($host, $aliases) = (gethostbyname($host))[0, 1];
  572.  
  573.     if (defined $aliases) {
  574.         push(@hosts, ($host, split(/\s+/, $aliases)));
  575.     } else {
  576.         push(@hosts, $host);
  577.     }
  578.     foreach $host (@hosts) {
  579.         next if !defined $host;
  580.         return 1 if "\L$host" eq $targethost;
  581.     }
  582.     }
  583.     return 0;
  584. }
  585.  
  586. sub ensure_proper_network_library
  587. {
  588.    require 'network.pl' if !defined $network'version;
  589.    warn "WARNING:\n". __FILE__ .
  590.         qq/ needs a newer version of "network.pl"\n/ if
  591.      !defined($network'version) || $network'version < "950311.5";
  592. }
  593.  
  594.  
  595.  
  596. ##
  597. ##>
  598. ##############################################################################
  599. ## open_http_connection(*FILEHANDLE, HOST, PORT, PATH, TARGET, OPTIONS...)
  600. ##
  601. ## Opens an HTTP connection to HOST:PORT and requests PATH.
  602. ## TARGET is used only for informational messages to the user.
  603. ##
  604. ## If PORT and PATH are undefined, HOST is taken as an http URL and TARGET
  605. ## is filled in as needed.
  606. ##
  607. ## Otherwise, it's the same as open_http_url (including return value, etc.).
  608. ##<
  609. ##
  610. sub open_http_connection
  611. {
  612.     local(*HTTP, $host, $port, $path, $target, @options) = @_;
  613.     local($post_text, @error, %seen);
  614.     local(%info);
  615.  
  616.     &ensure_proper_network_library;
  617.  
  618.     ## options allowed:
  619.     local($post, $retry, $authorization,  $nofollow, $noproxy,
  620.       $head, $debug, $ifmodifiedsince, $quiet,              ) = (0) x 10;
  621.     ## parse options:
  622.     foreach $opt (@options)
  623.     {
  624.     next unless defined($opt) && $opt ne '';
  625.     local($var, $val);
  626.     if ($opt =~ m/^(\w+)=(.*)/) {
  627.         ($var, $val) = ($1, $2);
  628.     } else {
  629.         $var = $opt;
  630.         $val = 1;
  631.     }
  632.     $var =~ tr/A-Z/a-z/; ## ensure variable is lowercase.
  633.     local(@error);
  634.  
  635.     eval "if (defined \$$var) { \$$var = \$val; } else { \@error = 
  636.               ('error', 'bad open_http_connection option [$opt]'); }";
  637.         return ('error', "open_http_connection eval: $@") if $@;
  638.     return @error if defined @error;
  639.     }
  640.     $quiet = 0 if $debug;  ## debug overrides quiet
  641.    
  642.     local($protocol, $error, $code, $URL, %info, $tmp, $aite);
  643.  
  644.     ##
  645.     ## if both PORT and PATH are undefined, treat HOST as a URL.
  646.     ##
  647.     unless (defined($port) && defined($path))
  648.     {
  649.         ($protocol,$host,$port,$path,$target)=&grok_URL($host,$noproxy,'http');
  650.     if ($protocol ne "http") {
  651.         return ('error',"open_http_connection doesn't grok [$protocol]");
  652.     }
  653.     unless (defined($host)) {
  654.         return ('error', "can't grok [$URL]");
  655.     }
  656.     }
  657.  
  658.     return ('error', "no port in URL [$URL]") unless defined $port;
  659.     return ('error', "no path in URL [$URL]") unless defined $path;
  660.  
  661.     RETRY: while(1)
  662.     {
  663.     ## we'll want $URL around for error messages and such.
  664.     if ($port == $default_port{'http'}) {
  665.         $URL = "http://$host";
  666.     } else {
  667.         $URL = "http://$host:$default_port{'http'}";
  668.     }
  669.         $URL .= ord($path) eq ord('/') ? $path : "/$path";
  670.  
  671.     $aite = defined($target) ? "$target via $host" : $host;
  672.  
  673.     &message($debug, "connecting to $aite ...") unless $quiet;
  674.  
  675.     ##
  676.         ## note some info that might be of use to the caller.
  677.     ##
  678.         local(%preinfo) = (
  679.         'PROTOCOL', 'http',
  680.         'HOST', $host,
  681.         'PORT', $port,
  682.         'PATH', $path,
  683.         );
  684.     if (defined $target) {
  685.         $preinfo{'TARGET'} = $target;
  686.     } elsif ($default_port{'http'} == $port) {
  687.         $preinfo{'TARGET'} = $host;
  688.     } else {
  689.         $preinfo{'TARGET'} = "$host:$port";
  690.     }
  691.  
  692.     ## connect to the site
  693.     $error = &network'connect_to(*HTTP, $host, $port);
  694.     if (defined $error) {
  695.         return('error', "can't connect to $aite: $error", %preinfo);
  696.     }
  697.  
  698.     ## If we're asked to POST and it looks like a POST, note post text.
  699.     if ($post && $path =~ m/\?/) {
  700.         $post_text = $'; ## everything after the '?'
  701.         $path = $`;      ## everything before the '?'
  702.         }
  703.  
  704.     ## send the POST or GET request
  705.     $tmp = $head ? 'HEAD' : (defined $post_text ? 'POST' : 'GET');
  706.  
  707.     &message($debug, "sending request to $aite ...") if !$quiet;
  708.     print HTTP $tmp, " $path HTTP/1.0\n";
  709.  
  710.     ## send the If-Modified-Since field if needed.
  711.     if ($ifmodifiedsince) {
  712.         print HTTP "If-Modified-Since: $ifmodifiedsince\n";
  713.     }
  714.  
  715.     ## oh, let's sputter a few platitudes.....
  716.     print HTTP "Accept: */*\n";
  717.     print HTTP "User-Agent: $useragent\n" if defined $useragent;
  718.  
  719.         ## If doing Authorization, do so now.
  720.         if ($authorization) {
  721.         print HTTP "Authorization: Basic ",
  722.             &htuu_encode($authorization), "\n";
  723.     }
  724.  
  725.     ## If it's a post, send it.
  726.     if (defined $post_text)
  727.     {
  728.         print HTTP "Content-type: application/x-www-form-urlencoded\n";
  729.         print HTTP "Content-length: ", length $post_text, "\n\n";
  730.         print HTTP $post_text, "\n";
  731.     }
  732.     print HTTP "\n";
  733.     &message($debug, "waiting for data from $aite ...") unless $quiet;
  734.  
  735.     ## we can now read the response (header, then body) via HTTP.
  736.     binmode(HTTP); ## just in case.
  737.  
  738.     ($code, %info) = &read_http_header(*HTTP);
  739.     &message(1, "header returns code $code ($info{'TYPE'})") if $debug;
  740.  
  741.     ## fill in info from %preinfo
  742.     local($val, $key);
  743.     while (($val, $key) = each %preinfo) {
  744.         $info{$val} = $key;
  745.     }
  746.  
  747.     if ($code == 0)
  748.     {
  749.         return('error',"empty response for $URL")
  750.         if $info{'TYPE'} eq 'empty';
  751.         return('error', "non-HTTP response for $URL", %info)
  752.         if $info{'TYPE'} eq 'unknown';
  753.         return('error', "unknown zero-code for $URL", %info);
  754.     }
  755.  
  756.     if ($code == 302) ## 302 is magic for "Found"
  757.     {
  758.         if (!defined $info{'location'}) {
  759.         return('error', "No location info for Found URL $URL", %info);
  760.         }
  761.         local($newURL) = $info{'location'};
  762.  
  763.         ## Remove :80 from hostname, if there. Looks ugly.
  764.         $newURL =~ s,^(http:/+[^/:]+):80/,$1/,i;
  765.         $info{"NewURL"} = $newURL;
  766.  
  767.         ## if we're not following links or if it's not to HTTP, return.
  768.         return('follow', $newURL, %info) if
  769.         $nofollow || $newURL!~m/^http:/i;
  770.  
  771.         ## note that we've seen this current URL.
  772.         $seen{$host, $port, $path} = 1;
  773.  
  774.         &message(1, qq/[note: now moved to "$newURL"]/) unless $quiet;
  775.  
  776.  
  777.         ## get the new one and return an error if it's been seen.
  778.         ($protocol, $host, $port, $path, $target) =
  779.         &www'grok_URL($newURL, $noproxy);
  780.         &message(1, "[$protocol][$host][$port][$path]") if $debug;
  781.  
  782.         if (defined $seen{$host, $port, $path})
  783.         {
  784.         return('error', "circular reference among:\n    ".
  785.                join("\n    ", sort grep(/^http/i, keys %seen)), %seen);
  786.         }
  787.         next RETRY;
  788.     }
  789.     elsif ($code == 500) ## 500 is magic for "internal error"
  790.     {
  791.         ##
  792.         ## A proxy will often return this with text saying "can't find
  793.         ## host" when in reality it's just because the nslookup returned
  794.         ## null at the time. Such a thing should be retied again after a
  795.         ## few seconds.
  796.         ##
  797.         if ($retry)
  798.         {
  799.         local($_) = $info{'BODY'} = join('', <HTTP>);
  800.         if (/Can't locate remote host:\s*(\S+)/i) {
  801.             local($times) = ($retry == 1) ?
  802.             "once more" : "up to $retry more times";
  803.             &message(0, "can't locate $1, will try $times ...")
  804.             unless $quiet;
  805.             sleep(5);
  806.             $retry--;
  807.             next RETRY;
  808.         }
  809.         }
  810.     }
  811.  
  812.     if ($code != 200)  ## 200 is magic for "OK";
  813.     {  
  814.         ## I'll deal with these as I see them.....
  815.         &clear_message;
  816.         if ($info{'TYPE'} eq '')
  817.         {
  818.         if (defined $http_return_code{$code}) {
  819.             $info{'TYPE'} = $http_return_code{$code};
  820.         } else {
  821.             $info{'TYPE'} = "(unknown status code $code)";
  822.         }
  823.         }
  824.         return ('status', $info{'TYPE'}, %info);
  825.     }
  826.  
  827.         &clear_message;
  828.     return ('ok', 'ok', %info);
  829.     }
  830. }
  831.  
  832.  
  833. ##
  834. ## Hyper Text UUencode. Somewhat different from regular uuencode.
  835. ##
  836. ## Logic taken from Mosaic for X code by Mark Riordan and Ari Luotonen.
  837. ##
  838. sub htuu_encode
  839. {
  840.     local(@in) = unpack("C*", $_[0]);
  841.     local(@out);
  842.  
  843.     push(@in, 0, 0); ## in case we need to round off an odd byte or two
  844.     while (@in >= 3) {
  845.     ##
  846.         ## From the next three input bytes,
  847.     ## construct four encoded output bytes.
  848.     ##
  849.     push(@out, $in[0] >> 2);
  850.     push(@out, (($in[0] << 4) & 060) | (($in[1] >> 4) & 017));
  851.         push(@out, (($in[1] << 2) & 074) | (($in[2] >> 6) & 003));
  852.         push(@out,   $in[2]       & 077);
  853.     splice(@in, 0, 3); ## remove these three
  854.     }
  855.  
  856.     ##
  857.     ## @out elements are now indices to the string below. Convert to
  858.     ## the appropriate actual text.
  859.     ##
  860.     foreach $new (@out) {
  861.     $new = substr(
  862.           "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/",
  863.           $new, 1);
  864.     }
  865.  
  866.     if (@in == 2) {
  867.     ## the two left over are the two extra nulls, so we encoded the proper
  868.         ## amount as-is.
  869.     } elsif (@in == 1) {
  870.     ## We encoded one extra null too many. Undo it.
  871.     $out[$#out] = '=';
  872.     } else {
  873.         ## We must have encoded two nulls... Undo both.
  874.     $out[$#out   ] = '=';
  875.     $out[$#out -1] = '=';
  876.     }
  877.  
  878.     join('', @out);
  879. }
  880.  
  881. ##
  882. ## This message stuff really shouldn't be here, but in some seperate library.
  883. ## Sorry.
  884. ##
  885. ## Called as &message(SAVE, TEXT ....), it shoves the text to the screen.
  886. ## If SAVE is true, bumps the text out as a printed line. Otherwise,
  887. ## will shove out without a newline so that the next message overwrites it,
  888. ## or it is clearded via &clear_message().
  889. ##
  890. sub message
  891. {
  892.     local($nl) = shift;
  893.     die "oops $nl." unless $nl =~ m/^\d+$/;
  894.     local($text) = join('', @_);
  895.     local($NL) = $nl ? "\n" : "\r";
  896.     $thislength = length($text);
  897.     if ($thislength >= $last_message_length) {
  898.     print STDERR $text, $NL;
  899.     } else {
  900.     print STDERR $text, ' 'x ($last_message_length-$thislength), $NL;
  901.     }    
  902.     $last_message_length = $nl ? 0 : $thislength;
  903. }
  904.  
  905. sub clear_message
  906. {
  907.     if ($last_message_length) {
  908.     print STDERR ' ' x $last_message_length, "\r";
  909.     $last_message_length = 0;
  910.     }
  911. }
  912.  
  913. 1;
  914. __END__
  915. __END__
  916. :endofperl
  917.