vcs.maemo.org Git - pkg-perl/blob - deb-src/libwww-perl/libwww-perl-5.813/lib/LWP/Protocol/gopher.pm

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