/extras/perl/site_perl/LWP/Protocol/gopher.pm
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;