PageRenderTime 31ms CodeModel.GetById 15ms app.highlight 14ms RepoModel.GetById 1ms app.codeStats 0ms

/extras/perl/site_perl/LWP/Protocol/gopher.pm

http://github.com/perigrin/android-scripting-environment-perl
Perl | 212 lines | 176 code | 22 blank | 14 comment | 12 complexity | b116ed47b8a79bf039ad0cd395008a9f MD5 | raw file
  1package 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
 10use strict;
 11use vars qw(@ISA);
 12
 13require HTTP::Response;
 14require HTTP::Status;
 15require IO::Socket;
 16require IO::Select;
 17
 18require LWP::Protocol;
 19@ISA = qw(LWP::Protocol);
 20
 21
 22my %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
 38my %gopher2encoding = (
 39    '6' => 'x_uuencode',                # 6 UNIX uuencoded file.
 40);
 41
 42sub request
 43{
 44    my($self, $request, $proxy, $arg, $size, $timeout) = @_;
 45
 46    $size = 4096 unless $size;
 47
 48    # check proxy
 49    if (defined $proxy) {
 50	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
 51				   'You can not proxy through the gopher');
 52    }
 53
 54    my $url = $request->uri;
 55    die "bad scheme" if $url->scheme ne 'gopher';
 56
 57
 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");
 63    }
 64
 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 ' .
 69				   $gophertype);
 70    }
 71
 72    my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
 73    $response->header('Content-type' => $gopher2mimetype{$gophertype}
 74					|| 'text/plain');
 75    $response->header('Content-Encoding' => $gopher2encoding{$gophertype})
 76	if exists $gopher2encoding{$gophertype};
 77
 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');
 81	return $response;
 82    }
 83    
 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");
 87<HEAD>
 88<TITLE>Gopher Index</TITLE>
 89<ISINDEX>
 90</HEAD>
 91<BODY>
 92<H1>$url<BR>Gopher Search</H1>
 93This is a searchable Gopher index.
 94Use the search function of your browser to enter search terms.
 95</BODY>
 96EOT
 97    }
 98
 99    my $host = $url->host;
100    my $port = $url->port;
101
102    my $requestLine = "";
103
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";
113	    }
114	}
115    }
116    $requestLine .= "\015\012";
117
118    # potential request headers are just ignored
119
120    # Ok, lets make the request
121    my $socket = IO::Socket::INET->new(PeerAddr => $host,
122				       PeerPort => $port,
123				       Proto    => 'tcp',
124				       Timeout  => $timeout);
125    die "Can't connect to $host:$port" unless $socket;
126    my $sel = IO::Select->new($socket);
127
128    {
129	die "write timeout" if $timeout && !$sel->can_write($timeout);
130	my $n = syswrite($socket, $requestLine, length($requestLine));
131	die $! unless defined($n);
132	die "short write" if $n != length($requestLine);
133    }
134
135    my $user_arg = $arg;
136
137    # must handle menus in a special way since they are to be
138    # converted to HTML.  Undefing $arg ensures that the user does
139    # not see the data before we get a change to convert it.
140    $arg = undef if $gophertype eq '1' || $gophertype eq '7';
141
142    # collect response
143    my $buf = '';
144    $response = $self->collect($arg, $response, sub {
145	die "read timeout" if $timeout && !$sel->can_read($timeout);
146        my $n = sysread($socket, $buf, $size);
147	die $! unless defined($n);
148	return \$buf;
149      } );
150
151    # Convert menu to HTML and return data to user.
152    if ($gophertype eq '1' || $gophertype eq '7') {
153	my $content = menu2html($response->content);
154	if (defined $user_arg) {
155	    $response = $self->collect_once($user_arg, $response, $content);
156	}
157	else {
158	    $response->content($content);
159	}
160    }
161
162    $response;
163}
164
165
166sub gopher2url
167{
168    my($gophertype, $path, $host, $port) = @_;
169
170    my $url;
171
172    if ($gophertype eq '8' || $gophertype eq 'T') {
173	# telnet session
174	$url = $HTTP::URI_CLASS->new($gophertype eq '8' ? 'telnet:':'tn3270:');
175	$url->user($path) if defined $path;
176    }
177    else {
178	$path = URI::Escape::uri_escape($path);
179	$url = $HTTP::URI_CLASS->new("gopher:/$gophertype$path");
180    }
181    $url->host($host);
182    $url->port($port);
183    $url;
184}
185
186sub menu2html {
187    my($menu) = @_;
188
189    $menu =~ s/\015//g;  # remove carriage return
190    my $tmp = <<"EOT";
191<HTML>
192<HEAD>
193   <TITLE>Gopher menu</TITLE>
194</HEAD>
195<BODY>
196<H1>Gopher menu</H1>
197EOT
198    for (split("\n", $menu)) {
199	last if /^\./;
200	my($pretty, $path, $host, $port) = split("\t");
201
202	$pretty =~ s/^(.)//;
203	my $type = $1;
204
205	my $url = gopher2url($type, $path, $host, $port)->as_string;
206	$tmp .= qq{<A HREF="$url">$pretty</A><BR>\n};
207    }
208    $tmp .= "</BODY>\n</HTML>\n";
209    $tmp;
210}
211
2121;