diff options
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm')
-rw-r--r-- | systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm | 213 |
1 files changed, 0 insertions, 213 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm deleted file mode 100644 index 1b46df4a07..0000000000 --- a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/LWP/Protocol/gopher.pm +++ /dev/null @@ -1,213 +0,0 @@ -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; - -our $VERSION = '6.61'; - -require HTTP::Response; -require HTTP::Status; -require IO::Socket; -require IO::Select; - -use parent 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 =~ tr/\015//d; # 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; |