<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package LWP::Protocol::gopher;

# Implementation of the gopher protocol (RFC 1436)
#
# This code is based on 'wwwgopher.pl,v 0.10 1994/10/17 18:12:34 shelden'
# which in turn is a vastly modified version of Oscar's http'get()
# dated 28/3/94 in &lt;ftp://cui.unige.ch/PUBLIC/oscar/scripts/http.pl&gt;
# including contributions from Marc van Heyningen and Martijn Koster.

use strict;

our $VERSION = '6.76';

require HTTP::Response;
require HTTP::Status;
require IO::Socket;
require IO::Select;

use parent qw(LWP::Protocol);


my %gopher2mimetype = (
    '0' =&gt; 'text/plain',                # 0 file
    '1' =&gt; 'text/html',                 # 1 menu
					# 2 CSO phone-book server
					# 3 Error
    '4' =&gt; 'application/mac-binhex40',  # 4 BinHexed Macintosh file
    '5' =&gt; 'application/zip',           # 5 DOS binary archive of some sort
    '6' =&gt; 'application/octet-stream',  # 6 UNIX uuencoded file.
    '7' =&gt; 'text/html',                 # 7 Index-Search server
					# 8 telnet session
    '9' =&gt; 'application/octet-stream',  # 9 binary file
    'h' =&gt; 'text/html',                 # html
    'g' =&gt; 'image/gif',                 # gif
    'I' =&gt; 'image/*',                   # some kind of image
);

my %gopher2encoding = (
    '6' =&gt; 'x_uuencode',                # 6 UNIX uuencoded file.
);

sub request
{
    my($self, $request, $proxy, $arg, $size, $timeout) = @_;

    $size = 4096 unless $size;

    # check proxy
    if (defined $proxy) {
	return HTTP::Response-&gt;new(HTTP::Status::RC_BAD_REQUEST,
				   'You can not proxy through the gopher');
    }

    my $url = $request-&gt;uri;
    die "bad scheme" if $url-&gt;scheme ne 'gopher';


    my $method = $request-&gt;method;
    unless ($method eq 'GET' || $method eq 'HEAD') {
	return HTTP::Response-&gt;new(HTTP::Status::RC_BAD_REQUEST,
				   'Library does not allow method ' .
				   "$method for 'gopher:' URLs");
    }

    my $gophertype = $url-&gt;gopher_type;
    unless (exists $gopher2mimetype{$gophertype}) {
	return HTTP::Response-&gt;new(HTTP::Status::RC_NOT_IMPLEMENTED,
				   'Library does not support gophertype ' .
				   $gophertype);
    }

    my $response = HTTP::Response-&gt;new(HTTP::Status::RC_OK, "OK");
    $response-&gt;header('Content-type' =&gt; $gopher2mimetype{$gophertype}
					|| 'text/plain');
    $response-&gt;header('Content-Encoding' =&gt; $gopher2encoding{$gophertype})
	if exists $gopher2encoding{$gophertype};

    if ($method eq 'HEAD') {
	# XXX: don't even try it so we set this header
	$response-&gt;header('Client-Warning' =&gt; 'Client answer only');
	return $response;
    }

    if ($gophertype eq '7' &amp;&amp; ! $url-&gt;search) {
      # the url is the prompt for a gopher search; supply boiler-plate
      return $self-&gt;collect_once($arg, $response, &lt;&lt;"EOT");
&lt;HEAD&gt;
&lt;TITLE&gt;Gopher Index&lt;/TITLE&gt;
&lt;ISINDEX&gt;
&lt;/HEAD&gt;
&lt;BODY&gt;
&lt;H1&gt;$url&lt;BR&gt;Gopher Search&lt;/H1&gt;
This is a searchable Gopher index.
Use the search function of your browser to enter search terms.
&lt;/BODY&gt;
EOT
    }

    my $host = $url-&gt;host;
    my $port = $url-&gt;port;

    my $requestLine = "";

    my $selector = $url-&gt;selector;
    if (defined $selector) {
	$requestLine .= $selector;
	my $search = $url-&gt;search;
	if (defined $search) {
	    $requestLine .= "\t$search";
	    my $string = $url-&gt;string;
	    if (defined $string) {
		$requestLine .= "\t$string";
	    }
	}
    }
    $requestLine .= "\015\012";

    # potential request headers are just ignored

    # Ok, lets make the request
    my $socket = IO::Socket::INET-&gt;new(PeerAddr =&gt; $host,
				       PeerPort =&gt; $port,
				       LocalAddr =&gt; $self-&gt;{ua}{local_address},
				       Proto    =&gt; 'tcp',
				       Timeout  =&gt; $timeout);
    die "Can't connect to $host:$port" unless $socket;
    my $sel = IO::Select-&gt;new($socket);

    {
	die "write timeout" if $timeout &amp;&amp; !$sel-&gt;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;

    # must handle menus in a special way since they are to be
    # converted to HTML.  Undefing $arg ensures that the user does
    # not see the data before we get a change to convert it.
    $arg = undef if $gophertype eq '1' || $gophertype eq '7';

    # collect response
    my $buf = '';
    $response = $self-&gt;collect($arg, $response, sub {
	die "read timeout" if $timeout &amp;&amp; !$sel-&gt;can_read($timeout);
        my $n = sysread($socket, $buf, $size);
	die $! unless defined($n);
	return \$buf;
      } );

    # Convert menu to HTML and return data to user.
    if ($gophertype eq '1' || $gophertype eq '7') {
	my $content = menu2html($response-&gt;content);
	if (defined $user_arg) {
	    $response = $self-&gt;collect_once($user_arg, $response, $content);
	}
	else {
	    $response-&gt;content($content);
	}
    }

    $response;
}


sub gopher2url
{
    my($gophertype, $path, $host, $port) = @_;

    my $url;

    if ($gophertype eq '8' || $gophertype eq 'T') {
	# telnet session
	$url = $HTTP::URI_CLASS-&gt;new($gophertype eq '8' ? 'telnet:':'tn3270:');
	$url-&gt;user($path) if defined $path;
    }
    else {
	$path = URI::Escape::uri_escape($path);
	$url = $HTTP::URI_CLASS-&gt;new("gopher:/$gophertype$path");
    }
    $url-&gt;host($host);
    $url-&gt;port($port);
    $url;
}

sub menu2html {
    my($menu) = @_;

    $menu =~ tr/\015//d;  # remove carriage return
    my $tmp = &lt;&lt;"EOT";
&lt;HTML&gt;
&lt;HEAD&gt;
   &lt;TITLE&gt;Gopher menu&lt;/TITLE&gt;
&lt;/HEAD&gt;
&lt;BODY&gt;
&lt;H1&gt;Gopher menu&lt;/H1&gt;
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)-&gt;as_string;
	$tmp .= qq{&lt;A HREF="$url"&gt;$pretty&lt;/A&gt;&lt;BR&gt;\n};
    }
    $tmp .= "&lt;/BODY&gt;\n&lt;/HTML&gt;\n";
    $tmp;
}

1;
</pre></body></html>