#! /bin/perl
#
# http.pl	--- recognize, parse and retrieve URLs
#
# NB: If this package interests you, you should probably
# have a look at Roy Fielding's libwww-perl packages:
# http://www.ics.uci.edu/WebSoft/libwww-perl/
#
# http'get:	perform an http request and return the result
#
# This package and friends can be found at:
# http://cui_www.unige.ch/ftp/PUBLIC/oscar/scripts/README.html
# or ftp: cui.unige.ch:/PUBLIC/oscar/scripts/
#
# Oscar Nierstrasz 26/8/93 oscar@cui.unige.ch
#
# 25/3/94 -- moved to separate package
# 28/3/94 -- added stripping of MIME headers (code by Martijn Koster)
#
# FIX to strip off MIME headers!

package http;

# This should be installed in /local/lib/perl
# If it's not there, complain to your system admin!
require "sys/socket.ph";

$timeout = 60;

$sockaddr = 'S n a4 x8';
chop($thishost = `hostname`);
($name, $aliases, $proto) = getprotobyname("tcp");
($name, $aliases, $type, $len, $thisaddr) = gethostbyname($thishost);
$thissock = pack($sockaddr, &AF_INET, 0, $thisaddr);

$useragent = "User-Agent: http.pl\r\n";
$from = "From: $user@$thishost\r\n";

# perform an http request and return the result
# Code adapted from Marc van Heyningen
sub get {
    local($host,$port,$request,$version) = @_;
    ($fqdn, $aliases, $type, $len, $thataddr) = gethostbyname($host);
    $that = pack($sockaddr, &AF_INET, $port, $thataddr);
    socket(FS, &AF_INET, &SOCK_STREAM, $proto) || return undef;
    bind(FS, $thissock) || return undef;
    local($/);
    unless (eval q!
        $SIG{'ALRM'} = "http'timeout";
        alarm($timeout);
        connect(FS, $that) || return undef;
        select(FS); $| = 1; select(STDOUT);
	# MIME header treatment from Martijn Koster
        if ($version) {
            print FS "GET $request HTTP/1.0\r\n$useragent$from\r\n"; 
            undef($page);
            $/ = "\n";
            $_ = <FS>;
            if (m:HTTP/1.0\s+\d+\s+:) { #HTTP/1.0
                while(<FS>) {
                    last if /^[\r\n]+$/; # end of header
                }
                undef($/);
                $page = <FS>;
            }
            else {    # old style server reply
                undef($/);
                $page = $_;
                $_ = <FS>;            
                $page .= $_;
            }
        }
        else {        # old style request
            print FS "GET $request\r\n";
            $page = <FS>; # gives old-style reqply
        }
        $SIG{'ALRM'} = "IGNORE";
        !) {
            return undef;
        }
    close(FS);
    $page;
}

sub timeout { die "Timeout\n"; }

1;