home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _5ab9ab4a17c8477c3e86a7cee828499c < prev    next >
Text File  |  2004-06-01  |  6KB  |  219 lines
  1. #
  2. # $Id: gopher.pm,v 1.20 2003/10/23 19:11:33 uid39246 Exp $
  3.  
  4. # Implementation of the gopher protocol (RFC 1436)
  5. #
  6. # This code is based on 'wwwgopher.pl,v 0.10 1994/10/17 18:12:34 shelden'
  7. # which in turn is a vastly modified version of Oscar's http'get()
  8. # dated 28/3/94 in <ftp://cui.unige.ch/PUBLIC/oscar/scripts/http.pl>
  9. # including contributions from Marc van Heyningen and Martijn Koster.
  10. #
  11.  
  12. package LWP::Protocol::gopher;
  13.  
  14. use strict;
  15. use vars qw(@ISA);
  16.  
  17. require HTTP::Response;
  18. require HTTP::Status;
  19. require IO::Socket;
  20. require IO::Select;
  21.  
  22. require LWP::Protocol;
  23. @ISA = qw(LWP::Protocol);
  24.  
  25.  
  26. my %gopher2mimetype = (
  27.     '0' => 'text/plain',                # 0 file
  28.     '1' => 'text/html',                 # 1 menu
  29.                     # 2 CSO phone-book server
  30.                     # 3 Error
  31.     '4' => 'application/mac-binhex40',  # 4 BinHexed Macintosh file
  32.     '5' => 'application/zip',           # 5 DOS binary archive of some sort
  33.     '6' => 'application/octet-stream',  # 6 UNIX uuencoded file.
  34.     '7' => 'text/html',                 # 7 Index-Search server
  35.                     # 8 telnet session
  36.     '9' => 'application/octet-stream',  # 9 binary file
  37.     'h' => 'text/html',                 # html
  38.     'g' => 'image/gif',                 # gif
  39.     'I' => 'image/*',                   # some kind of image
  40. );
  41.  
  42. my %gopher2encoding = (
  43.     '6' => 'x_uuencode',                # 6 UNIX uuencoded file.
  44. );
  45.  
  46. sub request
  47. {
  48.     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  49.  
  50.     LWP::Debug::trace('()');
  51.  
  52.     $size = 4096 unless $size;
  53.  
  54.     # check proxy
  55.     if (defined $proxy) {
  56.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  57.                    'You can not proxy through the gopher');
  58.     }
  59.  
  60.     my $url = $request->url;
  61.     die "bad scheme" if $url->scheme ne 'gopher';
  62.  
  63.  
  64.     my $method = $request->method;
  65.     unless ($method eq 'GET' || $method eq 'HEAD') {
  66.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  67.                    'Library does not allow method ' .
  68.                    "$method for 'gopher:' URLs");
  69.     }
  70.  
  71.     my $gophertype = $url->gopher_type;
  72.     unless (exists $gopher2mimetype{$gophertype}) {
  73.     return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
  74.                    'Library does not support gophertype ' .
  75.                    $gophertype);
  76.     }
  77.  
  78.     my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
  79.     $response->header('Content-type' => $gopher2mimetype{$gophertype}
  80.                     || 'text/plain');
  81.     $response->header('Content-Encoding' => $gopher2encoding{$gophertype})
  82.     if exists $gopher2encoding{$gophertype};
  83.  
  84.     if ($method eq 'HEAD') {
  85.     # XXX: don't even try it so we set this header
  86.     $response->header('Client-Warning' => 'Client answer only');
  87.     return $response;
  88.     }
  89.     
  90.     if ($gophertype eq '7' && ! $url->search) {
  91.       # the url is the prompt for a gopher search; supply boiler-plate
  92.       return $self->collect_once($arg, $response, <<"EOT");
  93. <HEAD>
  94. <TITLE>Gopher Index</TITLE>
  95. <ISINDEX>
  96. </HEAD>
  97. <BODY>
  98. <H1>$url<BR>Gopher Search</H1>
  99. This is a searchable Gopher index.
  100. Use the search function of your browser to enter search terms.
  101. </BODY>
  102. EOT
  103.     }
  104.  
  105.     my $host = $url->host;
  106.     my $port = $url->port;
  107.  
  108.     my $requestLine = "";
  109.  
  110.     my $selector = $url->selector;
  111.     if (defined $selector) {
  112.     $requestLine .= $selector;
  113.     my $search = $url->search;
  114.     if (defined $search) {
  115.         $requestLine .= "\t$search";
  116.         my $string = $url->string;
  117.         if (defined $string) {
  118.         $requestLine .= "\t$string";
  119.         }
  120.     }
  121.     }
  122.     $requestLine .= "\015\012";
  123.  
  124.     # potential request headers are just ignored
  125.  
  126.     # Ok, lets make the request
  127.     my $socket = IO::Socket::INET->new(PeerAddr => $host,
  128.                        PeerPort => $port,
  129.                        Proto    => 'tcp',
  130.                        Timeout  => $timeout);
  131.     die "Can't connect to $host:$port" unless $socket;
  132.     my $sel = IO::Select->new($socket);
  133.  
  134.     {
  135.     die "write timeout" if $timeout && !$sel->can_write($timeout);
  136.     my $n = syswrite($socket, $requestLine, length($requestLine));
  137.     die $! unless defined($n);
  138.     die "short write" if $n != length($requestLine);
  139.     }
  140.  
  141.     my $user_arg = $arg;
  142.  
  143.     # must handle menus in a special way since they are to be
  144.     # converted to HTML.  Undefing $arg ensures that the user does
  145.     # not see the data before we get a change to convert it.
  146.     $arg = undef if $gophertype eq '1' || $gophertype eq '7';
  147.  
  148.     # collect response
  149.     my $buf = '';
  150.     $response = $self->collect($arg, $response, sub {
  151.     die "read timeout" if $timeout && !$sel->can_read($timeout);
  152.         my $n = sysread($socket, $buf, $size);
  153.     die $! unless defined($n);
  154.     return \$buf;
  155.       } );
  156.  
  157.     # Convert menu to HTML and return data to user.
  158.     if ($gophertype eq '1' || $gophertype eq '7') {
  159.     my $content = menu2html($response->content);
  160.     if (defined $user_arg) {
  161.         $response = $self->collect_once($user_arg, $response, $content);
  162.     }
  163.     else {
  164.         $response->content($content);
  165.     }
  166.     }
  167.  
  168.     $response;
  169. }
  170.  
  171.  
  172. sub gopher2url
  173. {
  174.     my($gophertype, $path, $host, $port) = @_;
  175.  
  176.     my $url;
  177.  
  178.     if ($gophertype eq '8' || $gophertype eq 'T') {
  179.     # telnet session
  180.     $url = $HTTP::URI_CLASS->new($gophertype eq '8' ? 'telnet:':'tn3270:');
  181.     $url->user($path) if defined $path;
  182.     }
  183.     else {
  184.     $path = URI::Escape::uri_escape($path);
  185.     $url = $HTTP::URI_CLASS->new("gopher:/$gophertype$path");
  186.     }
  187.     $url->host($host);
  188.     $url->port($port);
  189.     $url;
  190. }
  191.  
  192. sub menu2html {
  193.     my($menu) = @_;
  194.  
  195.     $menu =~ s/\015//g;  # remove carriage return
  196.     my $tmp = <<"EOT";
  197. <HTML>
  198. <HEAD>
  199.    <TITLE>Gopher menu</TITLE>
  200. </HEAD>
  201. <BODY>
  202. <H1>Gopher menu</H1>
  203. EOT
  204.     for (split("\n", $menu)) {
  205.     last if /^\./;
  206.     my($pretty, $path, $host, $port) = split("\t");
  207.  
  208.     $pretty =~ s/^(.)//;
  209.     my $type = $1;
  210.  
  211.     my $url = gopher2url($type, $path, $host, $port)->as_string;
  212.     $tmp .= qq{<A HREF="$url">$pretty</A><BR>\n};
  213.     }
  214.     $tmp .= "</BODY>\n</HTML>\n";
  215.     $tmp;
  216. }
  217.  
  218. 1;
  219.