home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_ste.zip / LWP / Protocol / gopher.pm < prev    next >
Text File  |  1996-05-08  |  6KB  |  218 lines
  1. #
  2. # $Id: gopher.pm,v 1.16 1996/05/08 16:25:59 aas 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. require LWP::Protocol;
  15. require LWP::Socket;
  16. require HTTP::Request;
  17. require HTTP::Response;
  18. require HTTP::Status;
  19.  
  20. use Carp;
  21.  
  22. @ISA = qw(LWP::Protocol);
  23.  
  24.  
  25. %gopher2mimetype = (
  26.     '0' => 'text/plain',                # 0 file
  27.     '1' => 'text/html',                 # 1 menu
  28.                     # 2 CSO phone-book server
  29.                     # 3 Error
  30.     '4' => 'application/mac-binhex40',  # 4 BinHexed Macintosh file
  31.     '5' => 'application/zip',           # 5 DOS binary archive of some sort
  32.     '6' => 'application/octet-stream',  # 6 UNIX uuencoded file.
  33.     '7' => 'text/html',                 # 7 Index-Search server
  34.                     # 8 telnet session
  35.     '9' => 'application/octet-stream',  # 9 binary file
  36.     'h' => 'text/html',                 # html
  37.     'g' => 'image/gif',                 # gif
  38.     'I' => 'image/*',                   # some kind of image
  39. );
  40.  
  41. %gopher2encoding = (
  42.     '6' => 'x_uuencode',                # 6 UNIX uuencoded file.
  43. );
  44.  
  45. sub request
  46. {
  47.     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  48.  
  49.     LWP::Debug::trace('()');
  50.  
  51.     $size = 4096 unless $size;
  52.  
  53.     # check proxy
  54.     if (defined $proxy)
  55.     {
  56.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  57.                   'You can not proxy through the gopher';
  58.     }
  59.  
  60.     my $url = $request->url;
  61.     if ($url->scheme ne 'gopher') {
  62.     my $scheme = $url->scheme;
  63.     return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  64.                "LWP::Protocol::gopher::request called for '$scheme'";
  65.     }
  66.  
  67.     # check method
  68.     $method = $request->method;
  69.  
  70.     unless ($method eq 'GET' || $method eq 'HEAD') {
  71.     return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
  72.                   'Library does not allow method ' .
  73.                   "$method for 'gopher:' URLs";
  74.     }
  75.  
  76.     my $gophertype = $url->gtype;
  77.     unless (exists $gopher2mimetype{$gophertype}) {
  78.     return new HTTP::Response &HTTP::Status::RC_NOT_IMPLEMENTED,
  79.                   'Library does not support gophertype ' .
  80.                   $gophertype;
  81.     }
  82.  
  83.     my $response = new HTTP::Response &HTTP::Status::RC_OK,
  84.                       'Document follows';
  85.     $response->header('MIME-Version' => '1.0');
  86.     $response->header('Content-type' => $gopher2mimetype{$gophertype}
  87.                     || 'text/plain');
  88.     $response->header('Content-Encoding' => $gopher2encoding{$gophertype})
  89.     if exists $gopher2encoding{$gophertype};
  90.  
  91.     if ($method eq 'HEAD') {
  92.     # XXX: don't even try it so we set this header
  93.     $response->header('X-Warning' => 'Client answer only');
  94.     return $response;
  95.     }
  96.     
  97.     if ($gophertype eq '7' && ! $url->search) {
  98.       # the url is the prompt for a gopher search; supply boiler-plate
  99.       return $self->collect_once($arg, $response, <<"EOT");
  100. <HEAD>
  101. <TITLE>Gopher Index</TITLE>
  102. <ISINDEX>
  103. </HEAD>
  104. <BODY>
  105. <H1>$url<BR>Gopher Search</H1>
  106. This is a searchable Gopher index.
  107. Use the search function of your browser to enter search terms.
  108. </BODY>
  109. EOT
  110.     }
  111.  
  112.     my $host = $url->host;
  113.     my $port = $url->port;
  114.  
  115.     my $requestLine = "";
  116.  
  117.     my $selector = $url->selector;
  118.     if (defined $selector) {
  119.     $requestLine .= $selector;
  120.     my $search = $url->search;
  121.     if (defined $search) {
  122.         $requestLine .= "\t$search";
  123.         my $string = $url->string;
  124.         if (defined $string) {
  125.         $requestLine .= "\t$string";
  126.         }
  127.     }
  128.     }
  129.     $requestLine .= "\015\012";
  130.  
  131.     # potential request headers are just ignored
  132.  
  133.     # Ok, lets make the request
  134.     my $socket = new LWP::Socket;
  135.     alarm($timeout) if $self->use_alarm and defined $timeout;
  136.  
  137.     $socket->connect($host, $port);
  138.     LWP::Debug::debug('connected');
  139.  
  140.     $socket->write($requestLine, $timeout);
  141.  
  142.     my $user_arg = $arg;
  143.  
  144.     # must handle menus in a special way since they are to be
  145.     # converted to HTML.  Undefing $arg ensures that the user does
  146.     # not see the data before we get a change to convert it.
  147.     $arg = undef if $gophertype eq '1' || $gophertype eq '7';
  148.  
  149.     # collect response
  150.     $response = $self->collect($arg, $response, sub {
  151.     LWP::Debug::debug('collecting');
  152.     my $content = '';
  153.     my $result = $socket->read(\$content, $size, $timeout);
  154.     LWP::Debug::debug("collected: $content");
  155.     return \$content;
  156.       } );
  157.  
  158.     # Convert menu to HTML and return data to user.
  159.     if ($gophertype eq '1' || $gophertype eq '7') {
  160.     my $content = menu2html($response->content);
  161.     if (defined $user_arg) {
  162.         $response = $self->collect_once($user_arg, $response, $content);
  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 = new URI::URL ($gophertype eq '8' ? 'telnet:' : 'tn3270:');
  181.     $url->user($path) if defined $path;
  182.     } else {
  183.     $path = URI::Escape::uri_escape($path);
  184.     $url = new URI::URL "gopher:/$gophertype$path";
  185.     }
  186.     $url->host($host);
  187.     $url->port($port);
  188.     $url;
  189. }
  190.  
  191. sub menu2html {
  192.     my($menu) = @_;
  193.  
  194.     $menu =~ s/\015//g;  # remove carriage return
  195.     my $tmp = <<"EOT";
  196. <HTML>
  197. <HEAD>
  198.    <TITLE>Gopher menu</TITLE>
  199. </HEAD>
  200. <BODY>
  201. <H1>Gopher menu</H1>
  202. EOT
  203.     for (split("\n", $menu)) {
  204.     last if /^\./;
  205.     my($pretty, $path, $host, $port) = split("\t");
  206.  
  207.     $pretty =~ s/^(.)//;
  208.     my $type = $1;
  209.  
  210.     my $url = gopher2url($type, $path, $host, $port)->as_string;
  211.     $tmp .= qq{<A HREF="$url">$pretty</A><BR>\n};
  212.     }
  213.     $tmp .= "</BODY>\n</HTML>\n";
  214.     $tmp;
  215. }
  216.  
  217. 1;
  218.