#From news.utdallas.edu!tamsun.tamu.edu!cs.utexas.edu!uunet!spsgate!mogate!newsgate!melton.sps.mot.com!rhca80 Thu Mar 18 12:42:15 CST 1993
#Article: 1422 of comp.infosystems.gopher
#Xref: feenix.metronet.com comp.infosystems.gopher:1422 alt.sources:683
#Newsgroups: comp.infosystems.gopher,alt.sources
#Path: feenix.metronet.com!news.utdallas.edu!tamsun.tamu.edu!cs.utexas.edu!uunet!spsgate!mogate!newsgate!melton.sps.mot.com!rhca80
#From: rhca80@melton.sps.mot.com (Henry Melton)
#Subject: Gopher Server in Perl
#Message-ID: <1993Mar18.160739.1175@newsgate.sps.mot.com>
#Originator: rhca80@melton.sps.mot.com
#Sender: usenet@newsgate.sps.mot.com
#Nntp-Posting-Host: 222.1.248.94
#Organization: none
#Date: Thu, 18 Mar 1993 16:07:39 GMT
#Lines: 531

The following is a modified version of the perl gopherd server posted
about 3 days ago by Peter Lewis.  My intention is to provide a
replacement for the gopherd 1.12 distributed by the Uminn (did I get
that right) people.  I am in that class of people who put a lot of
effort customizing a gopher tree to work with gopherd 1.12 but who
live in a .com part of the net and who can not, for whatever reason,
run out and cut a purchase order for one of the Uminn licences.  I am
assuming that I am not the only member of that class.

There has been expressed reservations that a perl based server won't
handle the load.  This is probably true for servers with hundreds of
transactions per minute.  When I get there, with a user community with
demonstrated needs and a machine slowing to a halt, then I can go to
my boss with a smile on my face and show proof that the company should
spend the money for newer hardware and software licences.  If I have
to make that pitch with the limited user base I have today, the gopher
in my department will have to be aborted.

I needed a free gopher server today, so this is the result.  The
modifications from the original are mainly to support the file types I
was already using.  I have added comments throughout the code, so it
should be easy enough to add what I have missed.  I would prefer that
changes be sent back to me at rhca80@melton.sps.mot.com so that I can
fold them back into a reference version.  I am neither a perl nor a
gopher expert, so you will have to test to make sure that this works
as expected at your site.  

I live on a firewalled part of the net, so my server is not accessable, 
nor can I provide a ftp address to pick it up.  I hope someone will 
save this posting and publicise an ftp address for it.

Peter Lewis copyrighted his server and made it freely available.  My
changes have no additional copyright and are to be considered public
domain.

#!/usr/local/bin/perl
######################################################################
# Original Copyright Notice:
######################################################################
# gopherd.perl - Copyright Peter N Lewis, Mar 1993
# This script may be used and modified and distributed in any
# way you see fit as long as my name stays at the top somewhere
# and you add your changes and name somewhere in here.

# This is a trivial gopher server, it makes a directory tree available
# and allows links to other directories, and thats it.

# Its entirely free, you can do whatever you want with it, including
# sell it if y think you can get away with it.

# To use, put a line in your inetd like this:
# gopher stream tcp nowait ftp /usr/etc/gopherd.perl gopherd /home/ftp
######################################################################
# Enhancements:
######################################################################
# $Log:	gopherd.perl,v $
# Revision 1.2  93/03/18  09:16:53  rhca80
# Several enhancements by Henry Melton
# Now easier to run on A/UX systems with its /etc/server file
# instead of /etc/inetd.conf.
# Now supports .cache files for performance
# Supports .cap and .Links "side files" as well as retains 
# the .gophermap functions.
# Types now supported:
#   0 - plain text
#   0 - executable shell script to generate text
#   1 - executable shell script to generate menu
#   1 - reads directories generating a menu
#       Unix dot-files are invisible
#       AppleDouble % resource files are invisible
#       .cap/name files are processed
#       .Links entries are read and added
#       Files are typed using filename patterns, and then
#       using the Unix file command to look for magic tokens.
#       Currently coded in are just gif, jpeg, uuencoded, binhex
#       mailbox files, plain text and binaries.
#   2 - Not supported
#   3 - Not used
#   4 - Copies binhex files as text
#   5 - Copies DOS archives as binaries 
#   6 - Copies uuencode files as text
#   7 - Runs executable path, passing search string as parameter
#   8 - nothing done, client function
#   9 - copies binary to client
#   exec:"param":path  - run executable "path" with "param" as parameter
#   Rstart-end-path - randomly access text file from start to end


# Revision 1.1  93/03/18  08:50:56  rhca80
# Initial revision


######################################################################
# Configuration Section:  Modify the variables below:
#
$root="/data";              # Top level directory for the data
$defaultport=70;            # The standard port is 70
$agefactor=0.1;             # max age for .cache files in days
$cacheflag='1';             # 1 if use cacheing 
######################################################################
# Installation Section:   
#---------------------------------------------------------------------
# For Systems with /etc/inetd.conf add the following line:  
#
# gopher stream tcp nowait ftp /usr/etc/gopherd.perl gopherd /home/ftp
#
# You may need to change the 'ftp' to some other user id, depending on
# the access privs on your data directories.  The '/home/ftp' parameter
# listed will override the $root variable above if the following line
# is un-commented.
#$root=$ARGV[0] if $ARGV[0];
#
# You must also insert a line in /etc/services that looks like this:
# gopher          70/tcp
# Note that if NIS /YP is running, your services table may be the one
# running under yellow pages.
#---------------------------------------------------------------------
# For Systems with /etc/servers add the following line:
#
# gopher	tcp	/usr/local/etc/gopherd.perl
#
# Do NOT un-comment the $ARGV[0] line in the section above.
# The /etc/services line should be added as described above.
######################################################################

($name, $aliases, $ourport) = getservbyname('gopher','tcp');
$ourport=$defaultport unless $port;

chop($ourhost = `hostname`);
($ourhost, $aliases, $type, $len, $thisaddr) = gethostbyname($ourhost);

$line=<STDIN>;
chop $line;
chop $line;
$line="1" unless $line;

($selector,$search)= (split('\t',$line));
($type,$name)=unpack("a a*",$selector);
if ($name) {
  $path="$root/$name";
} else {
  $path=$root;
}

$die=0;
$die="Invalid Line \"$selector\" (contains ..)" if $path =~ m+\.\.+;
#$die="Invalid Line \"$selector\" (contains //)" if $path =~ m+//+;
$die="Invalid Line \"$selector\" ($root doesn't start with /)" unless $path =~ m+^/+;
$die="Invalid Line \"$selector\" (not a valid type)" unless $type =~ m+[0145679gIRe]+;

#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# Digest a directory (Type=1) and pass it to the client

if (! $die) {

  if ($type eq '1') {

# Check for alternate directory methods

    $magic=`file $path`;    
    $magic =~ s/^.*\t//;
    if ($magic =~ /Symbolic Link/ ) {
      chop $magic;
      ($a,$b,$c,$d)=split(/ /,$magic);
      $magic=`file $d`;
      $magic =~ s/^.*\t//;
    }

# If $path is an executable file, run it

    if ($magic =~ /executable/) {
      exec "$path";
      exit;
    }

# If $path is a mailbox file, then make a directory out of it

    if ($magic =~ /mail/) {
      $die="Couldn't open file" unless open (FILE, "<$path");
      if (! $die) {
        $shost=$ourhost;
        $sport=$ourport;
        while (<FILE>) {
          if (/^From / ) {
            $newpos=tell FILE - length;
            if ($pos ne "" ) {
              $putout="0$sname\tR$pos-$newpos-$name\t$shost\t$sport\r\n";
              print($putout);
              $sname="";
            }
            $pos=$newpos;
          }
          if (/^Subj/ ) {
            ($token,$sname)=split(/:/,$_,2);
          }
        }
        $newpos=tell FILE;
        $putout="0$sname\tR$pos-$newpos-$name\t$shost\t$sport\r\n";
        print($putout);
        close (FILE);
        print(".\r\n");
        exit;
      }
    }
       
# Maybe it is a real true directory

# If so, check for a fresh .cache file.  If new enough, print and
# exit.
    
    if ($cacheflag) {
      $age= -M "$path/.cache";
      if ( $age < $agefactor ) {
        if (open (FILE, "<$path/.cache")) {
          while (<FILE>) {
            print "$_";
          }
          close (FILE);
          print(".\r\n");
          exit;
        }
      }
    }
    
# If no .cache, then process the directory directly.    

    $die = "Couldn't open directory" unless opendir(DIR,$path);
    if (! $die) {

# The Lewis server supports a file called .gophermap that contains
# pairs of strings divided by a tab. The first is a filename, and the
# second is its substitution.  If there is a filename, with no
# following tab, it is removed from the listings.
# If the entry has a leading tab, then the substitution is sent to the
# client as an added entry. 

# Load the .gophermap into an array
      @mapping=();
      if (open(GOPHERMAP,"<$path/.gophermap")) {
        @mapping=<GOPHERMAP>;
        foreach (@mapping) {
          chop;
        }
        close(GOPHERMAP);
      }

# For each gophermap entry with a leading tab, add it to the output
# array.

      @output=();
      foreach (@mapping) {
        if (/^\t(.*)/) { @output=(@output, $1); }
      }

# Read the real Directory.  For each directory entry...

      while ($entry= readdir(DIR)) {

# If the first character of the filename is "." then skip it.
# (Unix invisible files)

        ($char)=unpack("c",$entry);
        next if ($char == 46); 

# If the first character of the filename is "%" then skip it.
# (AppleDouble Resource Fork.)

        next if ($char == 37);

# Guess the type of the file.  

        $secondary="";
        if (-d "$path/$entry") {
# Directories
          $stype="1";
        } elsif (-B _) {
# Binary Files
          $stype="9";
# First check the filename for more hints
          $lower=$entry;
          $lower =~ y/A-Z/a-z/;
          $stype="I" if $lower =~ /\.gif$/;
          $stype="I" if $lower =~ /\.jpg$/;
# If all else fails, use the file utility to hunt for magic tokens
          if ($stype=="9") {
            $magic=`file $path/$entry`;
            $magic =~ s/^.*\t//;
            $magic =~ y/A-Z/a-z/;
            $stype="I" if $magic =~ /gif/;
            $stype="I" if $magic =~ /jpeg/;
          }
        } else {
# Text Files
          $stype="0";
# First check the filename for more hints
          $lower=$entry;
          $lower =~ y/A-Z/a-z/;
          $stype="4" if $lower =~ /\.hqx$/;
# If all else fails, use the file utility to hunt for magic tokens
          if ($stype=="0") {
            $magic=`file $path/$entry`;
            $magic =~ s/^.*\t//;
            if ($magic =~ /Symbolic Link/ ) {
              chop $magic;
              ($a,$b,$c,$d)=split(/ /,$magic,4);
              $magic=`file $d`;
              $magic =~ s/^.*\t//;
            }

            $stype="4" if $magic =~ /uuencode/;

            if ($magic =~ /mail/) {
               $stype="1";
               $secondary="m";
            }
          }
        }

# Compose the output strings
        $sname=$entry;
        $spath="$path/$entry";
        $spath=$1 if $spath =~ m+$root/(.*)+;
        $shost=$ourhost;
        $sport=$ourport;

# Check for .cap file overrides
        if ( -r "$path/.cap/$entry" ) {
          if ( open (FILE, "<$path/.cap/$entry")) {
            while (<FILE>) {
              chop;
              ($ctoken,$cvalue)=unpack("a5a*",$_);
              $ctoken =~ y/A-Z/a-z/;
              $sname = $cvalue if $ctoken =~ /name=/;
              $spath = $cvalue if $ctoken =~ /path=/;
              $stype = $cvalue if $ctoken =~ /type=/;
              $shost = $cvalue if $ctoken =~ /host=/;
              $sport = $cvalue if $ctoken =~ /port=/;
            }
            close (FILE);
          }
        }


# Check the mapping array for overrides
        foreach (@mapping) {
          @map=split(/\t/);
          if ($entry eq $map[0]) {
            if ($map[1]) {
              ($mtype, $mname)=unpack("a a*",$map[1]);
              $stype=$mtype unless $mtype eq "X";
              $sname=$mname if $mname;
              $spath=$map[2] if $map[2];
              $shost=$map[3] if $map[3];
              $sport=$map[4] if $map[4];
            } else {
              $stype="X";
            }
          }
        }

        $secondary=$stype if secondary=="";
        $shost=$ourhost if $shost =~ /\+/;
        $sport=$ourport if $sport =~ /\+/;

        $putout=0;
        $putout="$stype$sname\t$secondary$spath\t$shost\t$sport";
        @output = (@output, $putout) unless $stype eq "X";
      }

# If a .Links file exists, Read it into the output array
# I am going to assume that a .Links entry begins with a Type=
# in the absense of any better information hjm

        if ( -r "$path/.Links" ) {
          if ( open (FILE, "<$path/.Links")) {
            $stype="";
            $sname="";
            $spath="";
            $shost="";
            $sport="";
            while (<FILE>) {
              chop;
              ($ctoken,$cvalue)=unpack("a5a*",$_);
              $ctoken =~ y/A-Z/a-z/;
              $sname = $cvalue if $ctoken =~ /name=/;
              $spath = $cvalue if $ctoken =~ /path=/;
              $shost = $cvalue if $ctoken =~ /host=/;
              $sport = $cvalue if $ctoken =~ /port=/;
              if ($ctoken =~ /type=/) {
                if ($stype) {
                  $shost=$ourhost if $shost =~ /\+/;
                  $sport=$ourport if $sport =~ /\+/;
                  $putout="$stype$sname\t$spath\t$shost\t$sport";
                  @output = (@output, $putout);
                  $sname="";
                  $spath="";
                  $shost="";
                  $sport="";
                }
                $stype = $cvalue;
              }
            }
            close (FILE);
            if ($stype) {
              $shost=$ourhost if $shost =~ /\+/;
              $sport=$ourport if $sport =~ /\+/;
              $putout="$stype$sname\t$spath\t$shost\t$sport";
              @output = (@output, $putout);
            }
          }
        }


# Define the case insensitive name sorting routine
sub byname {
  ($at, $an)=unpack("a a*",$a);
  ($bt, $bn)=unpack("a a*",$b);
  $an =~ tr/A-Z/a-z/;
  $bn =~ tr/A-Z/a-z/;
  $an cmp $bn;
}

# Sort the output array

      @output = sort byname @output;

# Print out the directory

      foreach (@output) { print "$_\r\n"; }
      closedir(DIR);

# Write out the new .cache file

      if ($cacheflag) {
        if (open(CFILE,">$path/.cache")) {
          foreach (@output) { print CFILE "$_\r\n"; }
          close (CFILE); 
        }
      }
    }
  }

#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# Executable file with parameters
# exec:"morris":/MemoryDatabases/NetworkAddresses/.ping'

  if ($type =~ /e/ ) {
    ($apart,$bpart,$cpart)=split(/:/,$path,3);
    ($junk,$parameter)=unpack("a a*",$bpart);
    chop $parameter;
    exec ("$root/$cpart","$parameter");
    exit;
  }

#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# Type 7 Search Directories

  if ($type =~ /7/ ) {
    $| = 1;
    exec ("$path","$search");
    print ".\r\n";
    exit;
  }

#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# Text Files -- Every line must be followed by cr-lf

  if ($type =~ /[046R]/ ) {

    $magic=`file $path`;
    $magic =~ s/^.*\t//;
    if ($magic =~ /Symbolic Link/ ) {
      chop $magic;
      ($a,$b,$c,$d)=split(/ /,$magic);
      $magic=`file $d`;
      $magic =~ s/^.*\t//;
    }

# If $path is an executable file, run it

    if ($magic =~ /executable/) {
      exec "$path";
      exit;
    }

# Check for a Mailbox Sub file encoded in the $name

    if ( $name =~ /^[0-9][0-9]*\-[0-9][0-9]*\-/ ) {
      ($start,$endpos,$realpath)=split(/\-/,$name,3);
      $path="$root/$realpath";
      $die="Couldn't open file" unless open (FILE, "<$path");
      if (! $die) {
        seek(FILE,$start,0);
        while(($_ = <FILE>) && ( tell(FILE) < $endpos )) {
          chop;
          print "$_\r\n";
        }
        close (FILE);
      }

# Else normal text file

    } else {
      $die="Couldn't open file" unless open (FILE, "<$path");
      if (! $die) {
        while (<FILE>) {
          chop;
          print "$_\r\n";
        }
        close (FILE);
      }
    }
  }
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# Binary Files -- cat the file out and then exit

  if ($type =~ /[59Ig]/ ) {
    exec "cat $path";
    exit;
  }
#+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
# End of Processed Types -- Cleanup
}

if ($die) {
  print "0Gopher: $die\r\n";
}

print(".\r\n");
-- 
Henry Melton rhca80@melton.sps.mot.com or henry@hutto.cactus.org