package LWP::Protocol::gopher;
use strict;
use vars qw(@ISA);
require HTTP::Response;
require HTTP::Status;
require IO::Socket;
require IO::Select;
require LWP::Protocol;
@ISA = qw(LWP::Protocol);
my %gopher2mimetype = (
'0' => 'text/plain', '1' => 'text/html', '4' => 'application/mac-binhex40', '5' => 'application/zip', '6' => 'application/octet-stream', '7' => 'text/html', '9' => 'application/octet-stream', 'h' => 'text/html', 'g' => 'image/gif', 'I' => 'image/*', );
my %gopher2encoding = (
'6' => 'x_uuencode', );
sub request
{
my($self, $request, $proxy, $arg, $size, $timeout) = @_;
LWP::Debug::trace('()');
$size = 4096 unless $size;
if (defined $proxy) {
return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
'You can not proxy through the gopher');
}
my $url = $request->url;
die "bad scheme" if $url->scheme ne 'gopher';
my $method = $request->method;
unless ($method eq 'GET' || $method eq 'HEAD') {
return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
'Library does not allow method ' .
"$method for 'gopher:' URLs");
}
my $gophertype = $url->gopher_type;
unless (exists $gopher2mimetype{$gophertype}) {
return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
'Library does not support gophertype ' .
$gophertype);
}
my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
$response->header('Content-type' => $gopher2mimetype{$gophertype}
|| 'text/plain');
$response->header('Content-Encoding' => $gopher2encoding{$gophertype})
if exists $gopher2encoding{$gophertype};
if ($method eq 'HEAD') {
$response->header('Client-Warning' => 'Client answer only');
return $response;
}
if ($gophertype eq '7' && ! $url->search) {
return $self->collect_once($arg, $response, <<"EOT");
<HEAD>
<TITLE>Gopher Index</TITLE>
<ISINDEX>
</HEAD>
<BODY>
<H1>$url<BR>Gopher Search</H1>
This is a searchable Gopher index.
Use the search function of your browser to enter search terms.
</BODY>
EOT
}
my $host = $url->host;
my $port = $url->port;
my $requestLine = "";
my $selector = $url->selector;
if (defined $selector) {
$requestLine .= $selector;
my $search = $url->search;
if (defined $search) {
$requestLine .= "\t$search";
my $string = $url->string;
if (defined $string) {
$requestLine .= "\t$string";
}
}
}
$requestLine .= "\015\012";
my $socket = IO::Socket::INET->new(PeerAddr => $host,
PeerPort => $port,
Proto => 'tcp',
Timeout => $timeout);
die "Can't connect to $host:$port" unless $socket;
my $sel = IO::Select->new($socket);
{
die "write timeout" if $timeout && !$sel->can_write($timeout);
my $n = syswrite($socket, $requestLine, length($requestLine));
die $! unless defined($n);
die "short write" if $n != length($requestLine);
}
my $user_arg = $arg;
$arg = undef if $gophertype eq '1' || $gophertype eq '7';
my $buf = '';
$response = $self->collect($arg, $response, sub {
die "read timeout" if $timeout && !$sel->can_read($timeout);
my $n = sysread($socket, $buf, $size);
die $! unless defined($n);
return \$buf;
} );
if ($gophertype eq '1' || $gophertype eq '7') {
my $content = menu2html($response->content);
if (defined $user_arg) {
$response = $self->collect_once($user_arg, $response, $content);
}
else {
$response->content($content);
}
}
$response;
}
sub gopher2url
{
my($gophertype, $path, $host, $port) = @_;
my $url;
if ($gophertype eq '8' || $gophertype eq 'T') {
$url = $HTTP::URI_CLASS->new($gophertype eq '8' ? 'telnet:':'tn3270:');
$url->user($path) if defined $path;
}
else {
$path = URI::Escape::uri_escape($path);
$url = $HTTP::URI_CLASS->new("gopher:/$gophertype$path");
}
$url->host($host);
$url->port($port);
$url;
}
sub menu2html {
my($menu) = @_;
$menu =~ s/\015//g; # remove carriage return
my $tmp = <<"EOT";
<HTML>
<HEAD>
<TITLE>Gopher menu</TITLE>
</HEAD>
<BODY>
<H1>Gopher menu</H1>
EOT
for (split("\n", $menu)) {
last if /^\./;
my($pretty, $path, $host, $port) = split("\t");
$pretty =~ s/^(.)//;
my $type = $1;
my $url = gopher2url($type, $path, $host, $port)->as_string;
$tmp .= qq{<A HREF="$url">$pretty</A><BR>\n};
}
$tmp .= "</BODY>\n</HTML>\n";
$tmp;
}
1;