[catagits/Gitalist.git] / local-lib5 / lib / perl5 / LWP / Protocol / gopher.pm

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 <ftp://cui.unige.ch/PUBLIC/oscar/scripts/http.pl>
# including contributions from Marc van Heyningen and Martijn Koster.

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

my %gopher2encoding = (
    '6' => '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->new(&HTTP::Status::RC_BAD_REQUEST,
				   'You can not proxy through the gopher');
    }

    my $url = $request->uri;
    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') {
	# XXX: don't even try it so we set this header
	$response->header('Client-Warning' => 'Client answer only');
	return $response;
    }
    
    if ($gophertype eq '7' && ! $url->search) {
      # the url is the prompt for a gopher search; supply boiler-plate
      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";

    # potential request headers are just ignored

    # Ok, lets make the request
    my $socket = IO::Socket::INET->new(PeerAddr => $host,
				       PeerPort => $port,
				       LocalAddr => $self->{ua}{local_address},
				       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;

    # 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->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;
      } );

    # Convert menu to HTML and return data to user.
    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') {
	# telnet session
	$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;
Commit	Line	Data
3fea05b9	1	package 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
	10	use strict;
	11	use vars qw(@ISA);
	12
	13	require HTTP::Response;
	14	require HTTP::Status;
	15	require IO::Socket;
	16	require IO::Select;
	17
	18	require LWP::Protocol;
	19	@ISA = qw(LWP::Protocol);
	20
	21
	22	my %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
	38	my %gopher2encoding = (
	39	'6' => 'x_uuencode', # 6 UNIX uuencoded file.
	40	);
	41
	42	sub 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>
93	This is a searchable Gopher index.
94	Use the search function of your browser to enter search terms.
95	</BODY>
96	EOT
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	LocalAddr => $self->{ua}{local_address},
124	Proto => 'tcp',
125	Timeout => $timeout);
126	die "Can't connect to $host:$port" unless $socket;
127	my $sel = IO::Select->new($socket);
128
129	{
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);
134	}
135
136	my $user_arg = $arg;
137
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';
142
143	# collect response
144	my $buf = '';
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);
149	return \$buf;
150	} );
151
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);
157	}
158	else {
159	$response->content($content);
160	}
161	}
162
163	$response;
164	}
165
166
167	sub gopher2url
168	{
169	my($gophertype, $path, $host, $port) = @_;
170
171	my $url;
172
173	if ($gophertype eq '8' \|\| $gophertype eq 'T') {
174	# telnet session
175	$url = $HTTP::URI_CLASS->new($gophertype eq '8' ? 'telnet:':'tn3270:');
176	$url->user($path) if defined $path;
177	}
178	else {
179	$path = URI::Escape::uri_escape($path);
180	$url = $HTTP::URI_CLASS->new("gopher:/$gophertype$path");
181	}
182	$url->host($host);
183	$url->port($port);
184	$url;
185	}
186
187	sub menu2html {
188	my($menu) = @_;
189
190	$menu =~ s/\015//g; # remove carriage return
191	my $tmp = <<"EOT";
192	<HTML>
193	<HEAD>
194	<TITLE>Gopher menu</TITLE>
195	</HEAD>
196	<BODY>
197	<H1>Gopher menu</H1>
198	EOT
199	for (split("\n", $menu)) {
200	last if /^\./;
201	my($pretty, $path, $host, $port) = split("\t");
202
203	$pretty =~ s/^(.)//;
204	my $type = $1;
205
206	my $url = gopher2url($type, $path, $host, $port)->as_string;
207	$tmp .= qq{<A HREF="$url">$pretty</A><BR>\n};
208	}
209	$tmp .= "</BODY>\n</HTML>\n";
210	$tmp;
211	}
212
213	1;