1 package LWP::Protocol::gopher;
3 # Implementation of the gopher protocol (RFC 1436)
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.
13 require HTTP::Response;
18 require LWP::Protocol;
19 @ISA = qw(LWP::Protocol);
22 my %gopher2mimetype = (
23 '0' => 'text/plain', # 0 file
24 '1' => 'text/html', # 1 menu
25 # 2 CSO phone-book server
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
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
38 my %gopher2encoding = (
39 '6' => 'x_uuencode', # 6 UNIX uuencoded file.
44 my($self, $request, $proxy, $arg, $size, $timeout) = @_;
46 $size = 4096 unless $size;
50 return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
51 'You can not proxy through the gopher');
54 my $url = $request->uri;
55 die "bad scheme" if $url->scheme ne 'gopher';
58 my $method = $request->method;
59 unless ($method eq 'GET' || $method eq 'HEAD') {
60 return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
61 'Library does not allow method ' .
62 "$method for 'gopher:' URLs");
65 my $gophertype = $url->gopher_type;
66 unless (exists $gopher2mimetype{$gophertype}) {
67 return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
68 'Library does not support gophertype ' .
72 my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
73 $response->header('Content-type' => $gopher2mimetype{$gophertype}
75 $response->header('Content-Encoding' => $gopher2encoding{$gophertype})
76 if exists $gopher2encoding{$gophertype};
78 if ($method eq 'HEAD') {
79 # XXX: don't even try it so we set this header
80 $response->header('Client-Warning' => 'Client answer only');
84 if ($gophertype eq '7' && ! $url->search) {
85 # the url is the prompt for a gopher search; supply boiler-plate
86 return $self->collect_once($arg, $response, <<"EOT");
88 <TITLE>Gopher Index</TITLE>
92 <H1>$url<BR>Gopher Search</H1>
93 This is a searchable Gopher index.
94 Use the search function of your browser to enter search terms.
99 my $host = $url->host;
100 my $port = $url->port;
102 my $requestLine = "";
104 my $selector = $url->selector;
105 if (defined $selector) {
106 $requestLine .= $selector;
107 my $search = $url->search;
108 if (defined $search) {
109 $requestLine .= "\t$search";
110 my $string = $url->string;
111 if (defined $string) {
112 $requestLine .= "\t$string";
116 $requestLine .= "\015\012";
118 # potential request headers are just ignored
120 # Ok, lets make the request
121 my $socket = IO::Socket::INET->new(PeerAddr => $host,
123 LocalAddr => $self->{ua}{local_address},
125 Timeout => $timeout);
126 die "Can't connect to $host:$port" unless $socket;
127 my $sel = IO::Select->new($socket);
130 die "write timeout" if $timeout && !$sel->can_write($timeout);
131 my $n = syswrite($socket, $requestLine, length($requestLine));
132 die $! unless defined($n);
133 die "short write" if $n != length($requestLine);
138 # must handle menus in a special way since they are to be
139 # converted to HTML. Undefing $arg ensures that the user does
140 # not see the data before we get a change to convert it.
141 $arg = undef if $gophertype eq '1' || $gophertype eq '7';
145 $response = $self->collect($arg, $response, sub {
146 die "read timeout" if $timeout && !$sel->can_read($timeout);
147 my $n = sysread($socket, $buf, $size);
148 die $! unless defined($n);
152 # Convert menu to HTML and return data to user.
153 if ($gophertype eq '1' || $gophertype eq '7') {
154 my $content = menu2html($response->content);
155 if (defined $user_arg) {
156 $response = $self->collect_once($user_arg, $response, $content);
159 $response->content($content);
169 my($gophertype, $path, $host, $port) = @_;
173 if ($gophertype eq '8' || $gophertype eq 'T') {
175 $url = $HTTP::URI_CLASS->new($gophertype eq '8' ? 'telnet:':'tn3270:');
176 $url->user($path) if defined $path;
179 $path = URI::Escape::uri_escape($path);
180 $url = $HTTP::URI_CLASS->new("gopher:/$gophertype$path");
190 $menu =~ s/\015//g; # remove carriage return
194 <TITLE>Gopher menu</TITLE>
199 for (split("\n", $menu)) {
201 my($pretty, $path, $host, $port) = split("\t");
206 my $url = gopher2url($type, $path, $host, $port)->as_string;
207 $tmp .= qq{<A HREF="$url">$pretty</A><BR>\n};
209 $tmp .= "</BODY>\n</HTML>\n";