home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / bin / www.pl < prev   
Encoding:
Perl Script  |  1999-12-28  |  11.6 KB  |  467 lines

  1. package www;
  2. $version = "951219.9";
  3.  
  4.  
  5. %http_return_code =
  6.     (200,"OK",
  7.      201,"Created",
  8.      202,"Accepted",
  9.      203,"Partial Information",
  10.      204,"No Response",
  11.      301,"Moved",
  12.      302,"Found",
  13.      303,"Method",
  14.      304,"Not modified",
  15.      400,"Bad request",
  16.      401,"Unauthorized",
  17.      402,"Payment required",
  18.      403,"Forbidden",
  19.      404,"Not found",
  20.      500,"Internal error",
  21.      501,"Not implemented",
  22.      502,"Service temporarily overloaded",
  23.      503,"Gateway timeout");
  24.  
  25. if (length($0) >= 6 && substr($0, -6) eq 'www.pl')
  26. {
  27.    seek(DATA, 0, 0) || die "$0: can't reset internal pointer.\n";
  28.    print "www.pl version $version\n", '=' x 60, "\n";
  29.    while (<DATA>) {
  30.     next unless /^##>/../^##</;   ## select lines to print
  31.     s/^##[<> ]?//;                ## clean up
  32.     print;
  33.    }
  34.    exit(0);
  35. }
  36.  
  37.  
  38.  
  39. %default_port = ('http', 80,
  40.          'ftp',  21,
  41.          'gopher', 70,
  42.          'telnet', 23,
  43.          'wais', 210,
  44.          );
  45.  
  46. %name2protocol = (
  47.     'www',     'http',
  48.     'wwwcgi','http',
  49. );
  50.  
  51. $last_message_length = 0;
  52. $useragent = "www.pl/$version";
  53.  
  54. sub open_http_url
  55. {
  56.     local(*HTTP, $URL, @options) = @_;
  57.     return &open_http_connection(*HTTP, $URL, undef, undef, undef, @options);
  58. }
  59.  
  60.  
  61. sub read_http_header
  62. {
  63.     local(*HTTP) = @_;
  64.     local(%info, $_);
  65.  
  66.     unless (defined($info{'STATUS'} = <HTTP>)) {
  67.     $info{'TYPE'} = "empty";
  68.         return (0, %info);
  69.     }
  70.     chop $info{'STATUS'};
  71.  
  72.     unless ($info{'STATUS'} =~ m/^HTTP\S+\s+(\d\d\d)\s+(.*\S)/i) {
  73.     $info{'TYPE'} = 'unknown';
  74.         return (0, %info);
  75.     }
  76.  
  77.     $info{'CODE'} = $1;
  78.     $info{'TYPE'} = $2;
  79.     $info{'HEADER'} = '';
  80.  
  81.     while (<HTTP>) {
  82.     last if m/^\s*$/;
  83.     $info{'HEADER'} .= $_; ## save whole text of header.
  84.  
  85.     if (m/^([^\n:]+):[ \t]*(.*\S)/) {
  86.         local($field, $value) = ("\L$1", $2);
  87.         if (defined $info{$field}) {
  88.         $info{$field} .= "\n" . $value;
  89.         } else {
  90.         $info{$field} = $value;
  91.         }
  92.     } elsif (defined $info{'UNKNOWN'}) {
  93.         $info{'UNKNOWN'} .= $_;
  94.     } else {
  95.         $info{'UNKNOWN'} = $_;
  96.     }
  97.     }
  98.  
  99.     return ($info{'CODE'}, %info);
  100. }
  101.  
  102. sub grok_URL
  103. {
  104.     local($_, $noproxy, $defaultprotocol) = @_;
  105.     $noproxy = defined($noproxy) && $noproxy;
  106.  
  107.     local($protocol, $address, $port, $path, $target, $user, $password);
  108.  
  109.     return undef unless m%^(([a-zA-Z]+)://|/*)([^/]+)(/.*)?$%;
  110.  
  111.     ($protocol, $address, $path) = ((index($1,":") >= 0 ? $2 : undef), $3, $4);
  112.  
  113.     if (!defined $protocol)
  114.     {
  115.     if (defined $defaultprotocol)    {
  116.         $protocol = $defaultprotocol;
  117.     }
  118.     else
  119.     {
  120.         $address =~ m/^[a-zA-Z]+/;
  121.         if (defined($name2protocol{"\L$&"})) {
  122.         $protocol = $name2protocol{"\L$&"};
  123.         } else {
  124.         $protocol = defined($default_port{"\L$&"}) ? $& : 'http';
  125.         }
  126.         }
  127.     }
  128.     $protocol =~ tr/A-Z/a-z/; ## ensure lower-case.
  129.  
  130.     if ($protocol eq 'ftp' || $protocol eq 'telnet' || $protocol eq 'http')
  131.     {
  132.     if ($address =~ s/^(([^\@:]+)(:([^@]+))?\@)//) {
  133.         ($user, $password) = ($2, $4);
  134.     }
  135.     }
  136.  
  137.     if ($address =~ s/:(\d+)$//) {
  138.        $port = $1;
  139.     } else {
  140.        $port = $default_port{$protocol};
  141.     }
  142.  
  143.     $path = '/' if !defined $path;
  144.  
  145.     local($proxy) = $ENV{$protocol."_proxy"};
  146.     if (!$noproxy && defined($proxy) && !&no_proxy($protocol,$address))
  147.     {
  148.     local($dummy);
  149.     local($old_pass, $old_user);
  150.  
  151.         if ($protocol eq 'http' && (defined($password) || defined($user)))
  152.     {
  153.         $path = "http://$address$path";
  154.         $old_pass = $password;
  155.         $old_user = $user;
  156.     } else {
  157.         ($path = $_) =~ s,^($protocol:)?/*,$protocol://,i;
  158.         }
  159.  
  160.     $target = ($port==$default_port{$protocol})?$address:"$address:$port";
  161.  
  162.         ($protocol, $address, $port, $dummy, $dummy, $user, $password)
  163.         = &grok_URL($proxy, 1);
  164.         $password = $old_pass if defined $old_pass;
  165.         $user     = $old_user if defined $old_user;
  166.     }
  167.     ($protocol, $address, $port, $path, $target, $user, $password);
  168. }
  169.  
  170.  
  171.  
  172. sub no_proxy
  173. {
  174.     local($protocol, $targethost) = @_;
  175.     local(@dests, $dest, $host, @hosts, $aliases);
  176.     local($proxy) = $ENV{$protocol."_proxy"};
  177.     return 0 if !defined $proxy;
  178.     $targethost =~ tr/A-Z/a-z/; ## ensure all lowercase;
  179.  
  180.     @dests = ($proxy);
  181.     push(@dests,split(/\s*,\s*/,$ENV{'no_proxy'})) if defined $ENV{'no_proxy'};
  182.  
  183.     foreach $dest (@dests)
  184.     {
  185.     $host = (&grok_URL($dest, 1), 'http')[1];
  186.  
  187.     if (!defined $host) {
  188.         warn "can't grok [$dest] from no_proxy env.var.\n";
  189.         next;
  190.     }
  191.     @hosts = ($host); ## throw in original name just to make sure
  192.     ($host, $aliases) = (gethostbyname($host))[0, 1];
  193.  
  194.     if (defined $aliases) {
  195.         push(@hosts, ($host, split(/\s+/, $aliases)));
  196.     } else {
  197.         push(@hosts, $host);
  198.     }
  199.     foreach $host (@hosts) {
  200.         next if !defined $host;
  201.         return 1 if "\L$host" eq $targethost;
  202.     }
  203.     }
  204.     return 0;
  205. }
  206.  
  207. sub ensure_proper_network_library
  208. {
  209.    require 'network.pl' if !defined $network'version;
  210.    warn "WARNING:\n". __FILE__ .
  211.         qq/ needs a newer version of "network.pl"\n/ if
  212.      !defined($network'version) || $network'version < "950311.5";
  213. }
  214.  
  215.  
  216.  
  217. sub open_http_connection
  218. {
  219.     local(*HTTP, $host, $port, $path, $target, @options) = @_;
  220.     local($post_text, @error, %seen);
  221.     local(%info);
  222.  
  223.     &ensure_proper_network_library;
  224.  
  225.     local($post, $retry, $authorization,  $nofollow, $noproxy,
  226.       $head, $debug, $ifmodifiedsince, $quiet,              ) = (0) x 10;
  227.     foreach $opt (@options)
  228.     {
  229.     next unless defined($opt) && $opt ne '';
  230.     local($var, $val);
  231.     if ($opt =~ m/^(\w+)=(.*)/) {
  232.         ($var, $val) = ($1, $2);
  233.     } else {
  234.         $var = $opt;
  235.         $val = 1;
  236.     }
  237.     $var =~ tr/A-Z/a-z/; ## ensure variable is lowercase.
  238.     local(@error);
  239.  
  240.     eval "if (defined \$$var) { \$$var = \$val; } else { \@error = 
  241.               ('error', 'bad open_http_connection option [$opt]'); }";
  242.         return ('error', "open_http_connection eval: $@") if $@;
  243.     return @error if defined @error;
  244.     }
  245.     $quiet = 0 if $debug;  ## debug overrides quiet
  246.    
  247.     local($protocol, $error, $code, $URL, %info, $tmp, $aite);
  248.  
  249.     unless (defined($port) && defined($path))
  250.     {
  251.         ($protocol,$host,$port,$path,$target)=&grok_URL($host,$noproxy,'http');
  252.     if ($protocol ne "http") {
  253.         return ('error',"open_http_connection doesn't grok [$protocol]");
  254.     }
  255.     unless (defined($host)) {
  256.         return ('error', "can't grok [$URL]");
  257.     }
  258.     }
  259.  
  260.     return ('error', "no port in URL [$URL]") unless defined $port;
  261.     return ('error', "no path in URL [$URL]") unless defined $path;
  262.  
  263.     RETRY: while(1)
  264.     {
  265.     if ($port == $default_port{'http'}) {
  266.         $URL = "http://$host";
  267.     } else {
  268.         $URL = "http://$host:$default_port{'http'}";
  269.     }
  270.         $URL .= ord($path) eq ord('/') ? $path : "/$path";
  271.  
  272.     $aite = defined($target) ? "$target via $host" : $host;
  273.  
  274.     &message($debug, "connecting to $aite ...") unless $quiet;
  275.  
  276.         local(%preinfo) = (
  277.         'PROTOCOL', 'http',
  278.         'HOST', $host,
  279.         'PORT', $port,
  280.         'PATH', $path,
  281.         );
  282.     if (defined $target) {
  283.         $preinfo{'TARGET'} = $target;
  284.     } elsif ($default_port{'http'} == $port) {
  285.         $preinfo{'TARGET'} = $host;
  286.     } else {
  287.         $preinfo{'TARGET'} = "$host:$port";
  288.     }
  289.  
  290.     $error = &network'connect_to(*HTTP, $host, $port);
  291.     if (defined $error) {
  292.         return('error', "can't connect to $aite: $error", %preinfo);
  293.     }
  294.  
  295.     if ($post && $path =~ m/\?/) {
  296.         $post_text = $'; ## everything after the '?'
  297.         $path = $`;      ## everything before the '?'
  298.         }
  299.  
  300.     $tmp = $head ? 'HEAD' : (defined $post_text ? 'POST' : 'GET');
  301.  
  302.     &message($debug, "sending request to $aite ...") if !$quiet;
  303.     print HTTP $tmp, " $path HTTP/1.0\n";
  304.  
  305.     if ($ifmodifiedsince) {
  306.         print HTTP "If-Modified-Since: $ifmodifiedsince\n";
  307.     }
  308.  
  309.     print HTTP "Accept: */*\n";
  310.     print HTTP "User-Agent: $useragent\n" if defined $useragent;
  311.  
  312.         if ($authorization) {
  313.         print HTTP "Authorization: Basic ",
  314.             &htuu_encode($authorization), "\n";
  315.     }
  316.  
  317.     if (defined $post_text)
  318.     {
  319.         print HTTP "Content-type: application/x-www-form-urlencoded\n";
  320.         print HTTP "Content-length: ", length $post_text, "\n\n";
  321.         print HTTP $post_text, "\n";
  322.     }
  323.     print HTTP "\n";
  324.     &message($debug, "waiting for data from $aite ...") unless $quiet;
  325.  
  326.     binmode(HTTP); ## just in case.
  327.  
  328.     ($code, %info) = &read_http_header(*HTTP);
  329.     &message(1, "header returns code $code ($info{'TYPE'})") if $debug;
  330.  
  331.     local($val, $key);
  332.     while (($val, $key) = each %preinfo) {
  333.         $info{$val} = $key;
  334.     }
  335.  
  336.     if ($code == 0)
  337.     {
  338.         return('error',"empty response for $URL")
  339.         if $info{'TYPE'} eq 'empty';
  340.         return('error', "non-HTTP response for $URL", %info)
  341.         if $info{'TYPE'} eq 'unknown';
  342.         return('error', "unknown zero-code for $URL", %info);
  343.     }
  344.  
  345.     if ($code == 302) ## 302 is magic for "Found"
  346.     {
  347.         if (!defined $info{'location'}) {
  348.         return('error', "No location info for Found URL $URL", %info);
  349.         }
  350.         local($newURL) = $info{'location'};
  351.  
  352.         $newURL =~ s,^(http:/+[^/:]+):80/,$1/,i;
  353.         $info{"NewURL"} = $newURL;
  354.  
  355.         return('follow', $newURL, %info) if
  356.         $nofollow || $newURL!~m/^http:/i;
  357.  
  358.         $seen{$host, $port, $path} = 1;
  359.  
  360.         &message(1, qq/[note: now moved to "$newURL"]/) unless $quiet;
  361.  
  362.  
  363.         ($protocol, $host, $port, $path, $target) =
  364.         &www'grok_URL($newURL, $noproxy);
  365.         &message(1, "[$protocol][$host][$port][$path]") if $debug;
  366.  
  367.         if (defined $seen{$host, $port, $path})
  368.         {
  369.         return('error', "circular reference among:\n    ".
  370.                join("\n    ", sort grep(/^http/i, keys %seen)), %seen);
  371.         }
  372.         next RETRY;
  373.     }
  374.     elsif ($code == 500) ## 500 is magic for "internal error"
  375.     {
  376.         if ($retry)
  377.         {
  378.         local($_) = $info{'BODY'} = join('', <HTTP>);
  379.         if (/Can't locate remote host:\s*(\S+)/i) {
  380.             local($times) = ($retry == 1) ?
  381.             "once more" : "up to $retry more times";
  382.             &message(0, "can't locate $1, will try $times ...")
  383.             unless $quiet;
  384.             sleep(5);
  385.             $retry--;
  386.             next RETRY;
  387.         }
  388.         }
  389.     }
  390.  
  391.     if ($code != 200)  ## 200 is magic for "OK";
  392.     {  
  393.         &clear_message;
  394.         if ($info{'TYPE'} eq '')
  395.         {
  396.         if (defined $http_return_code{$code}) {
  397.             $info{'TYPE'} = $http_return_code{$code};
  398.         } else {
  399.             $info{'TYPE'} = "(unknown status code $code)";
  400.         }
  401.         }
  402.         return ('status', $info{'TYPE'}, %info);
  403.     }
  404.  
  405.         &clear_message;
  406.     return ('ok', 'ok', %info);
  407.     }
  408. }
  409.  
  410.  
  411. sub htuu_encode
  412. {
  413.     local(@in) = unpack("C*", $_[0]);
  414.     local(@out);
  415.  
  416.     push(@in, 0, 0); ## in case we need to round off an odd byte or two
  417.     while (@in >= 3) {
  418.     push(@out, $in[0] >> 2);
  419.     push(@out, (($in[0] << 4) & 060) | (($in[1] >> 4) & 017));
  420.         push(@out, (($in[1] << 2) & 074) | (($in[2] >> 6) & 003));
  421.         push(@out,   $in[2]       & 077);
  422.     splice(@in, 0, 3); ## remove these three
  423.     }
  424.  
  425.     foreach $new (@out) {
  426.     $new = substr(
  427.           "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/",
  428.           $new, 1);
  429.     }
  430.  
  431.     if (@in == 2) {
  432.     } elsif (@in == 1) {
  433.     $out[$#out] = '=';
  434.     } else {
  435.     $out[$#out   ] = '=';
  436.     $out[$#out -1] = '=';
  437.     }
  438.  
  439.     join('', @out);
  440. }
  441.  
  442. sub message
  443. {
  444.     local($nl) = shift;
  445.     die "oops $nl." unless $nl =~ m/^\d+$/;
  446.     local($text) = join('', @_);
  447.     local($NL) = $nl ? "\n" : "\r";
  448.     $thislength = length($text);
  449.     if ($thislength >= $last_message_length) {
  450.     print STDERR $text, $NL;
  451.     } else {
  452.     print STDERR $text, ' 'x ($last_message_length-$thislength), $NL;
  453.     }    
  454.     $last_message_length = $nl ? 0 : $thislength;
  455. }
  456.  
  457. sub clear_message
  458. {
  459.     if ($last_message_length) {
  460.     print STDERR ' ' x $last_message_length, "\r";
  461.     $last_message_length = 0;
  462.     }
  463. }
  464.  
  465. 1;
  466. __END__
  467.