home *** CD-ROM | disk | FTP | other *** search
/ World Wide Catalog 1995 Summer / World_Wide_Catalog_InfoMagic_Summer_1995.iso / pages / rbuutexx.edu / http.pl < prev    next >
Perl Script  |  1995-06-11  |  8KB  |  216 lines
  1. #! /usr/bin/perl
  2. #
  3. # http.pl    --- retrieve http URLs
  4. #
  5. # NB: If this package interests you, you should probably
  6. # have a look at Roy Fielding's libwww-perl packages:
  7. # http://www.ics.uci.edu/WebSoft/libwww-perl/
  8. #
  9. # oscar :
  10. # http'get:    perform an http request and return the result
  11. #
  12. # gorm :
  13. # http'mod_get   perform an http request with the modified-since req.
  14. # http'get_last_modified  return the last modified stamp on a file in
  15. #                         the right format for use with http
  16. # http'bit2rfc850  convert from 32 bit timestamp to rfc850
  17. #
  18. # This package and friends can be found at:
  19. # http://iamwww.unibe.ch/~scg/Src/
  20. #
  21. # Oscar Nierstrasz 26/8/93 oscar@cui.unige.ch
  22. # Gorm Haug Eriksen gorm@usit.uio.no
  23. #
  24. # oscar 25/3/94 -- moved to separate package
  25. # oscar 28/3/94 -- added stripping of MIME headers (code by Martijn Koster)
  26. #
  27. # FIX to strip off MIME headers!
  28. # oscar 9/1/95  -- added Accept-Header field; accepts every mime type; 
  29. #
  30. # gorm 20/5/95 -- added some procedures for Modified-Since get, and
  31. #                 for handeling. this procedure will be used in w3mir.pl 
  32. # gorm 21/5/95 -- added redirection in http'mod_get
  33. # TEMPORARY HACK!
  34. # unshift(@INC, "/home/haegar/oscar/Sys/Perl");
  35.  
  36. package http;
  37.  
  38. # This should be installed in /local/lib/perl
  39. # If it's not there, complain to your system admin!
  40. require "sys/socket.ph";
  41.  
  42. $timeout = 60;
  43.  
  44. $sockaddr = 'S n a4 x8';
  45. chop($thishost = `hostname`);
  46. chop($user = `whoami`);
  47. ($name, $aliases, $proto) = getprotobyname("tcp");
  48. ($name, $aliases, $type, $len, $thisaddr) = gethostbyname($thishost);
  49. $thissock = pack($sockaddr, &AF_INET, 0, $thisaddr);
  50.  
  51. $useragent  = "User-Agent: w3mirror\r\n";
  52. $from       = "From: $user@$thishost\r\n";
  53. $mimeaccept = "Accept: */*\r\n";     #-- accept any mime type
  54.  
  55. # perform an http request and return the result
  56. # Code adapted from Marc van Heyningen
  57. sub get {
  58.     local($host,$port,$request,$version) = @_;
  59.     ($fqdn, $aliases, $type, $len, $thataddr) = gethostbyname($host);
  60.     $that = pack($sockaddr, &AF_INET, $port, $thataddr);
  61.     socket(FS, &AF_INET, &SOCK_STREAM, $proto) || return undef;
  62.     bind(FS, $thissock) || return undef;
  63.     local($/);
  64.     unless (eval q!
  65.         $SIG{'ALRM'} = "http'timeout";
  66.         alarm($timeout);
  67.         connect(FS, $that) || return undef;
  68.         select(FS); $| = 1; select(STDOUT);
  69.     # MIME header treatment from Martijn Koster
  70.         if ($version) {
  71.             print FS "GET $request HTTP/1.0\r\n$useragent$from$mimeaccept\r\n"; 
  72.             undef($page);
  73.             $/ = "\n";
  74.             $_ = <FS>;
  75.             if (m:HTTP/1.0\s+\d+\s+:) { #HTTP/1.0
  76.                 while(<FS>) {
  77.                     last if /^[\r\n]+$/; # end of header
  78.                 }
  79.                 undef($/);
  80.                 $page = <FS>;
  81.             }
  82.             else {    # old style server reply
  83.                 undef($/);
  84.                 $page = $_;
  85.                 $_ = <FS>;            
  86.                 $page .= $_;
  87.             }
  88.         }
  89.         else {        # old style request
  90.             print FS "GET $request\r\n";
  91.             $page = <FS>; # gives old-style reqply
  92.         }
  93.         $SIG{'ALRM'} = "IGNORE";
  94.         !) {
  95.             return undef;
  96.         }
  97.     close(FS);
  98.     $page;
  99. }
  100.  
  101. sub get_last_modified {
  102. # will return the last modified time for a local file
  103. # this procedure are for mirroring. The return will be in the
  104. # rfc 850 format, and the timezone will be GMT
  105.     local($file) = @_;
  106.     local(@tmp) = stat($file); # file doesn't exist ok to fetch
  107.     # now we got the last modified in a 32 bit integer.
  108.     # time to convert it and return
  109.     return &bit2rfc850($tmp[9]);
  110. }
  111.     
  112. sub bit2rfc850 {
  113. # this procedure will convert a 32bit timefield to regular
  114. # rfc850 GMT format. this is implemented in this package because
  115. # this format is the format used by http
  116. # IN  : 32bit timesign
  117. # OUT : http formated timestamp
  118.     local($timebit) = @_;
  119.     local(@DoW) = ('Sunday','Monday','Tuesday','Wedensday','Thursday','Friday','Saturday');
  120.     local(@MoY) = ('Jan','Feb','Mar','Apr','May','Jun',
  121.         'Jul','Aug','Sep','Oct','Nov','Dec'); 
  122.  
  123.     local($time) = @_;
  124.     local($[) = 0;
  125.     local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst);
  126.     ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = 
  127.     gmtime($timebit);    # uses GMT time
  128. # hack to fix the real time #########################################
  129.     @tmplist = ($mday,$hour,$min,$sec);                             #
  130.     for ($c=0;$c <= $#tmplist;$c++) {                               #
  131.     $tmplist[$c] = "0$tmplist[$c]" if $tmplist[$c] < 10;        #
  132.     }                                                    #
  133.     ($mday,$hour,$min,$sec) = @tmplist;                             #
  134. #####################################################################
  135. # returning the right http format    
  136.     sprintf("%s, %s-%s-%s %s:%s:%s GMT", 
  137.         $DoW[$wday], $mday, $MoY[$mon], $year, $hour, $min, $sec)
  138. }
  139.  
  140. sub mod_get {
  141. # this is a patched version of the above get, that will use 
  142. # a timestamp to check if it will get he page or not.
  143. # if it doesn't get the page, it will thought still recive
  144. # the header of the file. this was added by gorm haug eriksen
  145. # gorm@usit.uio.no for use in a mirror (W3) script
  146.     local($host,$port,$request,@modtime) = @_;
  147.     !@modtime && die "get_mod: didnt' get a lastmodified argument";
  148.     # modtime is a list on the rfc850 format, that is :
  149.     # Weekday, DD-Mon-YY HH:MM:SS TIMEZONE, but the httpd 
  150.     # protocoll state that the TIMEZONE to be used always 
  151.     # should be GMT. 
  152.     ($fqdn, $aliases, $type, $len, $thataddr) = gethostbyname($host);
  153.     $that = pack($sockaddr, &AF_INET, $port, $thataddr);
  154.     socket(FS, &AF_INET, &SOCK_STREAM, $proto) || return undef;
  155.     bind(FS, $thissock) || return undef;
  156.     local($/);
  157.     unless (eval q!
  158.         $SIG{'ALRM'} = "http'timeout";
  159.         alarm($timeout);
  160.         connect(FS, $that) || return undef;
  161.         select(FS); $| = 1; select(STDOUT);
  162.         # MIME header treatment from Martijn Koster
  163.         print FS "GET $request HTTP/1.0\r\n${useragent}${from}${mimeaccept}If-Modified-Since: @modtime\r\n\r\n"; 
  164. # debug
  165. #        print "GET $request HTTP/1.0\r\n${useragent}${from}${mimeaccept}If-Modified-Since: @modtime\r\n\r\n"; 
  166.  
  167.         undef($page);
  168.         $/ = "\n";
  169.         $_ = <FS>;
  170.         if (m:HTTP/1.0\s+(\d+)\s+:) { #HTTP/1.0
  171. # DEBUG :          print "Return $1\n";
  172.         if ($1 eq "302") {
  173.             # this is a routine that will enable redirection
  174.             # in the program. It will fetch the new url, and 
  175.             # the user will see nothing to the redirection
  176.             close(FS);
  177.             print "$that\n";
  178.             alarm(0);    # stopping alarm
  179.             $SIG{'ALRM'} = "http'timeout";
  180.             alarm($timeout);
  181.             ($fqdn, $aliases, $type, $len, $thataddr) = gethostbyname($host);
  182.             $that = pack($sockaddr, &AF_INET, $port, $thataddr);
  183.             socket(FS, &AF_INET, &SOCK_STREAM, $proto) || return undef;
  184.             bind(FS, $thissock) || return undef;
  185.             connect(FS, $that) || return undef;
  186.             select(FS); $| = 1; select(STDOUT);
  187.             # MIME header treatment from Martijn Koster
  188.             $request = "$request/index.html";
  189.             print "REQ : $request\n";
  190.             print FS "GET $request HTTP/1.0\r\n${useragent}${from}${mimeaccept}If-Modified-Since: @modtime\r\n\r\n"; 
  191.             undef $page;
  192.         }
  193.             return undef if $1 == 403; # not modified
  194.         while(<FS>) {
  195.             last if /^[\r\n]+$/; # end of header
  196.         }
  197.         undef($/);
  198.         $page = <FS>;
  199.         }
  200.         else {            # old style server reply
  201.         warn "Old Style Server Reply from $host. Ask admin to upgrade server or forget to mirror it" && return undef;
  202.         }
  203.         
  204.         $SIG{'ALRM'} = "IGNORE";
  205.         !) {
  206.             return undef; # a error has occoured
  207.         }
  208.     close(FS);
  209.     $page;
  210. }
  211.  
  212. sub timeout { die "Timeout\n"; }
  213.  
  214. 1;
  215.  
  216.