/extras/perl/site_perl/LWP/Protocol/gopher.pm

http://github.com/perigrin/android-scripting-environment-perl · Perl · 212 lines · 155 code · 37 blank · 20 comment · 29 complexity · b116ed47b8a79bf039ad0cd395008a9f MD5 · raw file

  1. package LWP::Protocol::gopher;
  2. # Implementation of the gopher protocol (RFC 1436)
  3. #
  4. # This code is based on 'wwwgopher.pl,v 0.10 1994/10/17 18:12:34 shelden'
  5. # which in turn is a vastly modified version of Oscar's http'get()
  6. # dated 28/3/94 in <ftp://cui.unige.ch/PUBLIC/oscar/scripts/http.pl>
  7. # including contributions from Marc van Heyningen and Martijn Koster.
  8. use strict;
  9. use vars qw(@ISA);
  10. require HTTP::Response;
  11. require HTTP::Status;
  12. require IO::Socket;
  13. require IO::Select;
  14. require LWP::Protocol;
  15. @ISA = qw(LWP::Protocol);
  16. my %gopher2mimetype = (
  17. '0' => 'text/plain', # 0 file
  18. '1' => 'text/html', # 1 menu
  19. # 2 CSO phone-book server
  20. # 3 Error
  21. '4' => 'application/mac-binhex40', # 4 BinHexed Macintosh file
  22. '5' => 'application/zip', # 5 DOS binary archive of some sort
  23. '6' => 'application/octet-stream', # 6 UNIX uuencoded file.
  24. '7' => 'text/html', # 7 Index-Search server
  25. # 8 telnet session
  26. '9' => 'application/octet-stream', # 9 binary file
  27. 'h' => 'text/html', # html
  28. 'g' => 'image/gif', # gif
  29. 'I' => 'image/*', # some kind of image
  30. );
  31. my %gopher2encoding = (
  32. '6' => 'x_uuencode', # 6 UNIX uuencoded file.
  33. );
  34. sub request
  35. {
  36. my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  37. $size = 4096 unless $size;
  38. # check proxy
  39. if (defined $proxy) {
  40. return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  41. 'You can not proxy through the gopher');
  42. }
  43. my $url = $request->uri;
  44. die "bad scheme" if $url->scheme ne 'gopher';
  45. my $method = $request->method;
  46. unless ($method eq 'GET' || $method eq 'HEAD') {
  47. return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  48. 'Library does not allow method ' .
  49. "$method for 'gopher:' URLs");
  50. }
  51. my $gophertype = $url->gopher_type;
  52. unless (exists $gopher2mimetype{$gophertype}) {
  53. return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
  54. 'Library does not support gophertype ' .
  55. $gophertype);
  56. }
  57. my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
  58. $response->header('Content-type' => $gopher2mimetype{$gophertype}
  59. || 'text/plain');
  60. $response->header('Content-Encoding' => $gopher2encoding{$gophertype})
  61. if exists $gopher2encoding{$gophertype};
  62. if ($method eq 'HEAD') {
  63. # XXX: don't even try it so we set this header
  64. $response->header('Client-Warning' => 'Client answer only');
  65. return $response;
  66. }
  67. if ($gophertype eq '7' && ! $url->search) {
  68. # the url is the prompt for a gopher search; supply boiler-plate
  69. return $self->collect_once($arg, $response, <<"EOT");
  70. <HEAD>
  71. <TITLE>Gopher Index</TITLE>
  72. <ISINDEX>
  73. </HEAD>
  74. <BODY>
  75. <H1>$url<BR>Gopher Search</H1>
  76. This is a searchable Gopher index.
  77. Use the search function of your browser to enter search terms.
  78. </BODY>
  79. EOT
  80. }
  81. my $host = $url->host;
  82. my $port = $url->port;
  83. my $requestLine = "";
  84. my $selector = $url->selector;
  85. if (defined $selector) {
  86. $requestLine .= $selector;
  87. my $search = $url->search;
  88. if (defined $search) {
  89. $requestLine .= "\t$search";
  90. my $string = $url->string;
  91. if (defined $string) {
  92. $requestLine .= "\t$string";
  93. }
  94. }
  95. }
  96. $requestLine .= "\015\012";
  97. # potential request headers are just ignored
  98. # Ok, lets make the request
  99. my $socket = IO::Socket::INET->new(PeerAddr => $host,
  100. PeerPort => $port,
  101. Proto => 'tcp',
  102. Timeout => $timeout);
  103. die "Can't connect to $host:$port" unless $socket;
  104. my $sel = IO::Select->new($socket);
  105. {
  106. die "write timeout" if $timeout && !$sel->can_write($timeout);
  107. my $n = syswrite($socket, $requestLine, length($requestLine));
  108. die $! unless defined($n);
  109. die "short write" if $n != length($requestLine);
  110. }
  111. my $user_arg = $arg;
  112. # must handle menus in a special way since they are to be
  113. # converted to HTML. Undefing $arg ensures that the user does
  114. # not see the data before we get a change to convert it.
  115. $arg = undef if $gophertype eq '1' || $gophertype eq '7';
  116. # collect response
  117. my $buf = '';
  118. $response = $self->collect($arg, $response, sub {
  119. die "read timeout" if $timeout && !$sel->can_read($timeout);
  120. my $n = sysread($socket, $buf, $size);
  121. die $! unless defined($n);
  122. return \$buf;
  123. } );
  124. # Convert menu to HTML and return data to user.
  125. if ($gophertype eq '1' || $gophertype eq '7') {
  126. my $content = menu2html($response->content);
  127. if (defined $user_arg) {
  128. $response = $self->collect_once($user_arg, $response, $content);
  129. }
  130. else {
  131. $response->content($content);
  132. }
  133. }
  134. $response;
  135. }
  136. sub gopher2url
  137. {
  138. my($gophertype, $path, $host, $port) = @_;
  139. my $url;
  140. if ($gophertype eq '8' || $gophertype eq 'T') {
  141. # telnet session
  142. $url = $HTTP::URI_CLASS->new($gophertype eq '8' ? 'telnet:':'tn3270:');
  143. $url->user($path) if defined $path;
  144. }
  145. else {
  146. $path = URI::Escape::uri_escape($path);
  147. $url = $HTTP::URI_CLASS->new("gopher:/$gophertype$path");
  148. }
  149. $url->host($host);
  150. $url->port($port);
  151. $url;
  152. }
  153. sub menu2html {
  154. my($menu) = @_;
  155. $menu =~ s/\015//g; # remove carriage return
  156. my $tmp = <<"EOT";
  157. <HTML>
  158. <HEAD>
  159. <TITLE>Gopher menu</TITLE>
  160. </HEAD>
  161. <BODY>
  162. <H1>Gopher menu</H1>
  163. EOT
  164. for (split("\n", $menu)) {
  165. last if /^\./;
  166. my($pretty, $path, $host, $port) = split("\t");
  167. $pretty =~ s/^(.)//;
  168. my $type = $1;
  169. my $url = gopher2url($type, $path, $host, $port)->as_string;
  170. $tmp .= qq{<A HREF="$url">$pretty</A><BR>\n};
  171. }
  172. $tmp .= "</BODY>\n</HTML>\n";
  173. $tmp;
  174. }
  175. 1;