#!/usr/bin/perl # This software is distributed under the MIT Licence. # # Copyright (c) 2002 Danijel Tasov # # Permission is hereby granted, free of charge, to any person obtaining # a copy of this software and associated documentation files (the # "Software"), to deal in the Software without restriction, including # without limitation the rights to use, copy, modify, merge, publish, # distribute, sublicense, and/or sell copies of the Software, and to # permit persons to whom the Software is furnished to do so, subject to # the following conditions: # # The above copyright notice and this permission notice shall be # included in all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF # MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. # IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY # CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, # TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE # SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. #use CGI::Fast; use CGI; use IO::Socket::INET; use HTML::Entities; use URI::Escape; use CGI::Carp qw(fatalsToBrowser); use strict; use constant VERSION => "0.91a"; my $bgcolor="black"; my $textcolor="white"; my $linkcolor="yellow"; my $vlinkcolor="cyan"; my $alinkcolor="red"; my %image = ( binary => "/icons/binary.gif", dir => "/icons/dir.gif", file => "/icons/generic.gif", image => "/icons/image1.gif", http => "/icons/link.gif", unknown => "/icons/unknown.gif" ); my $me="gopher.pl"; # STOP MAKING CHANGES HERE, UNTIL YOU DON'T KNOW WHAT YOU DO! my $info; my $cgi=new CGI; #while(my $cgi=CGI::Fast->new()) { my $nl="\r\n"; $/=$nl; #%ENV=%{$request->GetEnvironment()}; #my $cgi=CGI->new(); my $server=$cgi->param("server") || "data.homeunix.org"; my $port=$cgi->param("port") || 70; my $query=$cgi->param("query") || ""; my $type=$cgi->param("type") || ""; my $plain=$cgi->param("plain"); my $fp=IO::Socket::INET->new(PeerAddr => $server, PeerPort => $port, Timeout => 10, Proto => 'tcp'); if(!$fp) { printf "Content-Type: text/plain\n\nError: %s\n",join(",",$@,$!,$^E); exit; } $fp->print($query.$nl); for($type) { $_ eq "file" && do { $/="\n"; my $ln; if($plain) { print "Content-Type: text/plain\n\n"; } else { print "Content-Type: text/html\n\n"; print qq{ }; printf (qq{ Plain\n
},
	    $me, uri_escape($server), $port, uri_escape($query));
      $ln=1;
    }
    while(!$fp->eof) {
      my $line = $fp->getline;
      chomp($line);
      last if ($line eq ".
" && $fp->eof);
      if($plain) {
	print $line."\n";
      } else {
        printf qq{},$ln;
        printf qq{%5d },$ln++;
        printf qq{%s\n},encode_entities($line);
      }
    }
    unless($plain) {
      print "
"; printf (qq{ Plain\n}, $me, uri_escape($server), $port, uri_escape($query)); copyright(); print ""; } last; }; $_ eq "binary" && do { print "Content-Type: text/plain\n\n"; printf "Binaries currently not supported."; last; }; # default print << "EOT"; Content-Type: text/html

I'm showing @{[ encode_entities($server) ]} $port

EOT print "\n"; while(defined(my $line=$fp->getline)) { chomp($line); last if($line eq "."); my ($name,$path,$server,$port,$plus)=split(/\t/,$line); (my $type,$name) = $name=~/^(.)(.*)$/; for($type) { $_ eq "i" && do { # infos print "" if($info); #print "
" unless defined($info); printf qq{\n}, $me,uri_escape($server),$port,uri_escape($path), encode_entities($name); undef($info); last; }; $_ eq "0" && do { # a file print "" if($info); #print "
" unless defined($info); printf qq{" if($info); #print "
" unless defined($info); $path=~s/^GET //; printf qq{" if($info); #print "
" unless defined($info); printf qq{\n}, $me,uri_escape($server),$port,uri_escape($path), encode_entities($name); last; }; # Default print "" if($info); #print "
" unless defined($info); printf qq{\n", encode_entities($name); } } print "
 
" unless defined($info);
        printf "\t%s\n",encode_entities($name);
        $info=42;
        last;
      };
      $_ eq "1" && do { # directories
        print "
*}. qq{%s/
*}. qq{}. qq{%s\n}, $me,uri_escape($server),$port,uri_escape($path), encode_entities($name); undef($info); last; }; $_ eq "h" && do { print "
*}. qq{%s (HTTP)\n}, uri_escape($server),$port,uri_escape(substr($path,1)), encode_entities($name); undef($info); last; }; $_ eq "9" && do { print "
*}. qq{}. qq{%s
*}. "$_ %s(Currently unsupported)

"; copyright(); print ""; } sub copyright { print << "EOT";
CGI:Gopher @{[ VERSION ]}
Copyright (c) 2002 by Danijel Tasov gopher\@vosat.de
Get it here: http://www.vosat.de/gopher.perl
Bug reports, patches and pizza are welcome. EOT }