_ TWF  _ Code Chap 18

-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
HOME | BACK | NEXT | MENU | SEARCH | ORDER | COMMENT | HELPINFO -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

18code01.pl


#! /usr/tools/bin/perl 

#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 

#% PROGRAM : rtrurl.pl 

#% CREATOR : Mark Gaither 

#% CREATION DATE : Mon Nov 7 14:14:39 CST 1994 

#% DESCRIPTION : Retrieve URL from a WWW server #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%



$usage = 'Usage: rtrurl.pl -u url 

 -u = required URL

';



require "getopts.pl"; # include a Perl library call

&Getopts('hu:'); # get the command line options and values



if(defined($opt_h)) { print $usage; exit; } # usage message

if(!defined($opt_u)) { print $usage; exit; } 

else { $url = $opt_u; } # get URL value



$object = ''; # initialize the object to retrieve



# decipher the absolute URL

if($url =~ /^([a-z]+)\:\/\/([^:\/]+)(:\d+)?([^ ]*)$/) {

 $protocol = $1; # determine protocol (typically http)

 $server = $2; # get server DNS name

 $port = $3; # determine which port number

 $object = $4; # get the object to retrieve

 if(!defined($port)) { $port = 80; } # default port

 else { $port =~ s/://; } # remove ":" from server name

}



if($protocol ne 'http') { exit; } # restricted to HTTP only



###################################################################

# Build the GET HTTP command

###################################################################



# if the leading slash is omitted in the object, try adding one

if($object eq '') { $object = "/"; }



# HTTP GET command - notice two line break octal character pairs

$command = "GET $object HTTP/1.0\015\012\015\012";



# write the string to the open socket

&write_command($server,$port,$command);



exit;



##################################################################### Write the HTTP command to the open socket #################################################################### 

sub write_command {

 local($server,$port,$stream) = @_; # get parameters

 local($name,$aliases,$proto); # define local variables

 

 $name = $aliases = $proto = ''; # initialize local variables

 $AF_INET = 2; # required TCP/IP junk

 $SOCK_STREAM = 1; # ditto

 $sockaddr = 'S n a4 x8'; # more TCP/IP specific stuff

 

 chop($hostname = `hostname`); # remove the CR from the hostname

 

 # Next few lines are required for a TCP/IP connection

 ($name,$aliases,$proto) = getprotobyname('tcp');

 ($name,$aliases,$port) = getservbyname($port,'tcp') unless $port =~ /^\d+$/;;

 ($name,$aliases,$type,$len,$thisaddr) = gethostbyname($hostname);

 ($name,$aliases,$type,$len,$thataddr) = gethostbyname($server);

 

 if($name eq '') { die $!; } # handle gethostbyname failure

 # determine network addresses

 $this = pack($sockaddr,$AF_INET,0,$thisaddr);

 $that = pack($sockaddr,$AF_INET,$port,$thataddr);

 

 # make the socket filehandle

 if (!socket(S,$AF_INET,$SOCK_STREAM,$proto)) { die $!; };

 

 # give the socket an address

 if (!bind(S,$this)) { die $!; }

 

 #call up the server

 if (!connect(S,$that)) { die $!; }

 

 # set socket to be command buffered

 select(S);

 $| = 1; # flush stdout buffer 

 select(STDOUT);

 

 # write the GET command we built previously to the open socket

 print S $stream;

 $_ = <S>; # read first line of the response from the server

 

 # look for the status line in the response from the server

 if(/^HTTP/) {

 

 # continue reading the response from the open socket

 while(<S>) {

 

 # look for first blank line -- first CRLF!

   if(/^\w/) { next; }

   else { 

   

     # finally, the MIME entity is returned - typically of

     # type "text/html" or "text/plain". It is printed to the

    # 'stdout' file handle.

     while(<S>) { print STDOUT $_; }

   }

   }

 }

}




-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
HOME | BACK | NEXT | MENU | SEARCH | ORDER | COMMENT | HELPINFO -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

E-Mail: The Web Foundations at twf@lanw.com
URL: http://www.lanw.com/twf/codech18.htm
Text - Copyright © 1995, Ed Tittel, Mark Gaither, Sebastian Hassinger, & Mike Erwin.
Web Layout - Copyright © 1995, LANWrights & IMPACT Online.
Revised -- February 15th, 1996 [James Michael Stewart - WebMaster - IMPACT Online]

HTML 2.0 Checked!