home *** CD-ROM | disk | FTP | other *** search
/ Super Net 1 / SUPERNET_1.iso / PC / OTROS / UNIX / ARCHIE / CLIENTS / PERL_ARC.TAR / perl_archie / archie < prev    next >
Encoding:
Text File  |  1991-08-29  |  18.3 KB  |  670 lines
  1. #!/u3/thesis/clipper/bin/perl
  2. # Copyright (C) Khun Yee Fung clipper@csd.uwo.ca 1991
  3. #
  4. # Modified by Peter Orbaek (poe@daimi.aau.dk) to look more perl'ish.
  5. #
  6. # You can do anything to this program except selling it for profit or
  7. # pretending you wrote it. The copyright notice must be preserved in all 
  8. # copies. Absolutely no warranty.
  9. #
  10. # $Id: archie,v 3.8 1991/08/12 17:05:18 clipper Exp clipper $
  11. #
  12. # This version of the program is based on Beta 4.2 of prospero protocol.
  13. # The Version number of this release is $Revision: 3.8 $.
  14.  
  15. eval "exec perl -S $0 $*"
  16.     if $running_under_some_shell;
  17.  
  18. require 'resolver.pl';
  19. require 'sys/socket.ph';
  20. require 'newgetopt.pl';
  21. require 'archie.depend';
  22. $servername =~ tr/A-Z/a-z/;
  23.  
  24. select(STDOUT); $| = 1;
  25.  
  26. # To get the options on the command line. Explanations are in the code
  27. # handling them.
  28. &NGetOpt('match=i', 'reg', 'exact', 'nocase', 'case', 'server=s',
  29.      'ffile=s', 'format=s', 'along', 'norc', 'syntax', 'version',
  30.      'sort=s', 'reverse', 'rc=s', 'domain=s', 'aftp');
  31.  
  32. # Get the name of this program. The last element is the one.
  33. @prog = split('/', $0);
  34. $prog = $prog[$#prog];
  35.  
  36. # Usage string.
  37. # The options -syntax and -aftp are invisible because -syntax is used only
  38. # to check the syntax of the program and -aftp is useful only for the archie
  39. # interface of the nftp program.
  40. $usage = 
  41. "Usage: $prog [options] word1 word2 ...
  42.   Where options are one or more of the following:
  43.   -along            Print the entries when they are available.
  44.   -case             Case sensitive
  45.   -nocase           Case insensitive
  46.   -exact            Exact match
  47.   -reg              Regular expression match
  48.   -match \#          Max hits
  49.   -server hostname  An alternative archie server
  50.   -ffile filename   Use a format file
  51.   -format string    Specify a format string
  52.   -norc             Do not read .archierc file in home directory.
  53.   -version          Print the version number of the program.
  54.   -rc filename      Read another file as the startup file.
  55.   -sort [date|host] Sort by date ot host.
  56.   -reverse          Reverse sorting order.
  57.   -domain string    Use the order in the string to sort the hosts.
  58. ";
  59.  
  60. ($Revision) = ('$Revision: 3.8 $' =~ /Revision: ([\d\.]+)/);
  61. $version = "Prospero Beta.4.2 (Perl Archie Client Version $Revision)\n";
  62.  
  63. # Should have at least one query.
  64. if ($#ARGV < 0) {
  65.     if (defined($opt_version)) {
  66.         print $version;
  67.         exit(0);
  68.     }
  69.     print "Please specify at least one query.\n";
  70.     print $usage;
  71.     exit(255);
  72. }
  73. @string = @ARGV;
  74.  
  75. %domainorder = ('ca', 1, 'edu', 2, 'com', 3, 'gov', 4, 'net', 5,
  76.         'de', 6, 'dk', 7, 'nl', 8, 'fi', 9, 'se', 10,
  77.         'au', 1000, 'nz', 1001);
  78.  
  79. # For the conversion of date in the subroutine date.
  80. %month = ('Jan', 1, 'Feb', 2, 'Mar', 3, 'Apr', 4, 'May', 5, 'Jun', 6, 
  81.       'Jul', 7, 'Aug', 8, 'Sep', 9, 'Oct', 10, 'Nov', 11, 'Dec', 12);
  82. @month = ('', 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 
  83.       'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
  84.  
  85. # The archie port number is 1525.
  86. $port = 1525;
  87.  
  88. # The socketaddr structure. See /usr/include/sys/socket.h for the C 
  89. # version.
  90. $sockaddr = 'S n a4 x8';
  91.  
  92. # Defaults: maximum hit is 40. It does not mean there will be exactly
  93. # 40 entries returned, though. Expect a few entries more or less.
  94. # The default search option is case insensitive.
  95. $match = 40; $case = 'S'; $pnum = 1;
  96.  
  97. # The default format string. Can be overiden by the -format or -ffile 
  98. # options. Can also specify a default format string in ~/.archierc
  99. $format = "%02seq Host %host
  100.  
  101.     Location: %dir
  102.       %10type %mode %08size %date %name
  103.  
  104. ";
  105.  
  106. # To get the user name and user home path.
  107. @pw = getpwuid($<);
  108. $user = $pw[0];
  109. $userpath = $pw[7];
  110.  
  111. # Read the system startup file if there is one. Set the filename in
  112. # archie.depend.
  113.  
  114. &parserc($startup);
  115.  
  116. $startfile = defined($opt_rc) ? $opt_rc : "$userpath/.archierc";
  117. $along = defined($opt_along);
  118. &parserc($startfile) unless (defined($opt_norc));  # Read ~/.archierc?
  119. $match = $opt_match if (defined($opt_match)); # how many hits wanted?
  120. print $version      if (defined($opt_version)); # Print version number?
  121. &pdomain($opt_domain) if (defined($opt_domain)); # Get a domain order?
  122.  
  123. # The sort option. Default is by the domains of the hosts.
  124. $sortpack = 'host';
  125. if ($opt_sort) {
  126.     if ($opt_sort eq 'date') {
  127.     $sortpack = 'date';
  128.     }
  129.     elsif ($opt_sort eq 'host') {
  130.     $sortpack = 'host';
  131.     }
  132.     else {
  133.     print "Not valid sort field: $opt_sort. Assume host.\n";
  134.     $sortpack = 'host';
  135.     }
  136. }
  137. $reversesort = defined($opt_reverse);
  138.  
  139. # Read a format string from a file.
  140. if (defined($opt_ffile)) {
  141.     open(FFILE, "$opt_ffile") || die "Can't open format file $opt_ffile\n";
  142.     # slurp in the whole file
  143.     undef $/; $format = <FFILE>; $/ = "\n";
  144.     close FFILE;
  145. }
  146.  
  147. # Read a format string on the command line.
  148. $format = $opt_format if (defined($opt_format));
  149.  
  150. # Set the search option.
  151. $case = $ecase = '=' if (defined($opt_exact));  # Exact match
  152. $case = 'C' if (defined($opt_case));   # Set search option to case sensitive.
  153. $case = 'S' if (defined($opt_nocase)); # Set search option to case insensitive.
  154. $case = 'R' if (defined($opt_reg));    # search using a regular expression.
  155. $case =~ tr/A-Z/a-z/ if ($ecase eq '=');
  156.  
  157. # set a new archie server.
  158. if (defined($opt_server)) {
  159.     $serverip = $servername = $opt_server;
  160.     $servername =~ tr/A-Z/a-z/;
  161. }
  162.  
  163. # Support for a aftp pipe. [Useful only for the program nftp.]
  164. $format = "%type:%host:%dir\n" if ($opt_aftp);
  165.  
  166. # parse the format string,
  167. $format = &parseformat($format);
  168.  
  169. # This is for checking the format etc. Not for external use :-)
  170. if ($opt_syntax) {
  171.     print "Execution until here.\n";
  172.     exit(0);
  173. }
  174.  
  175. # Get the IP address of the archie server.
  176. if ($serverip =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) {
  177.   $thataddr = pack("CCCC", $1, $2, $3, $4);
  178.   $serverip = $servername;
  179. }
  180. elsif (!(($name, $aliases, $type, $len, $thataddr) = 
  181.      gethostbyname($servername))) {
  182.     $thataddr = &resolver($servername, $nsserver) || 
  183.     die "Can't find the IP address of the archie server $servername\n";
  184.     $serverip = join('.', unpack("CCCC", $thataddr));
  185. }
  186. else {
  187.     $serverip = join('.', unpack("CCCC", $thataddr));
  188. }
  189.  
  190. $them = pack($sockaddr, &AF_INET, $port, $thataddr);
  191.  
  192. # now construct our own address
  193. # dnb@meshugge.media.mit.edu gave the patch to satisfy taintperl. 
  194. $PATH = $ENV{'PATH'};
  195. $ENV{'PATH'} = '/bin:/usr/bin';
  196. chop($thishost = `hostname`);
  197. $ENV{'PATH'} = $PATH;
  198. ($name, $aliases, $type, $len, $thisaddr) = gethostbyname($thishost);
  199. $us = pack($sockaddr, &AF_INET, 0, $thisaddr);
  200.  
  201. # get and bind a socket.
  202. socket(DATA, &AF_INET, &SOCK_DGRAM, 0) || die "socket:$!\n";
  203. bind(DATA, $us) || die "bind: $!\n";
  204.  
  205. # Get the list of matches.
  206. @lists = &list($them, $user, $match, @string);
  207.  
  208. # Print them.
  209. &result(@lists) unless ($along);
  210.  
  211. close(DATA);
  212.  
  213. sub getpacket {
  214.     local($restime) = @_;
  215.     local($seq, $rin, $timeleft, $rout, $ans, $id, $hbyte, $rdp, $hdr_len);
  216.     local($header, $backoff, $kk, $dum, $flags, $wantack, $pktsnum, $nfound);
  217.     $seq = 0;
  218.  
  219.     # wait for a packet to come back.
  220.     $rin = '';
  221.     vec($rin, fileno(DATA), 1) = 1;
  222.     ($nfound, $timeleft) = select($rout = $rin, '', '', $restime);
  223.     if ($timeleft == 0 || ord($rout) == 0){
  224.     return(0);
  225.     }
  226.  
  227.     # Read a packet from the server.
  228.     $ans = '';
  229.     recv(DATA, $ans, 10000, 0) || die "recv: Can't recv. Die.\n";
  230.  
  231.     $hbyte = ord(substr($ans, 0, 1));
  232.     $header = '';
  233.     if ($hbyte < 20) {
  234.     $rdp = ($hbyte & 0xc0) >> 6;
  235.     $hdr_len = $hbyte & 0x3F;
  236.     $header = substr($ans, 0, $hdr_len);
  237.     substr($ans, 0, $hdr_len) = '';
  238.     $backoff = $seq = $kk = $flags = 0;
  239.     ($dum, $id, $seq, $kk, $dum, $backoff, $flags) =
  240.         unpack("Cnnnnnn", $header);
  241.     # Should I acknowledge?
  242.     $wantack = (($flags & 0x8000) != 0);
  243.     $pktsnum = ($kk) ? $kk : 0;
  244.     $timeout = $backoff if ($backoff);
  245.     }
  246.     else {
  247.     $seq = 1;
  248.     $pktsnum = 1;
  249.     $wantack = 0;
  250.     $timeout = 0;
  251.     }
  252.     return (1, $seq, $wantack, $pktsnum, $timeout, $ans);
  253. }
  254.  
  255. # The subroutine list is the `meat' of the query.
  256. # It sends the query to the archie server host and parses the entries
  257. # returned by the server.
  258. sub list {
  259.     local($them, $user, $match, @words) = @_;
  260.     local($ans, $timeout, $retries, $lines, @lines);
  261.     local($pktsnum, $pktseq, $seq, $timeleft, $acktime);
  262.     local($dum, $backoff, $word, $index, @received, $recthrough);
  263.     local($sq, $waxk, $pkts, $tout);
  264.     
  265.     $timeout = 4;
  266.     $retries = 3;
  267.     $acktime = 0.3;
  268.     @received = ('YES');
  269.  
  270.     # Construct the query packet.
  271.     @lines = ("VERSION 1\n", "AUTHENTICATOR UNAUTHENTICATED $user\n");
  272.     foreach $word (@words) {
  273.     push(@lines, "DIRECTORY ASCII ARCHIE/MATCH($match,0,$case)/$word\n");
  274.     push(@lines, "LIST ATTRIBUTES COMPONENTS \n");
  275.     }
  276.     $lines = join('', @lines);
  277.  
  278.     $recthrough = 0;
  279.  
  280.   RETRY: 
  281.     {
  282.     $head = pack("Cnnnn", 9, $$, 1, 1, $recthrough);
  283.     send(DATA, $head . $lines, 0, $them)
  284.         || die "send: Failed to send packet: $!";
  285.  
  286.     $pktsnum = 0;
  287.     while ($pktsnum == 0 || $pktseq < $pktsnum) {
  288.         $restime = $timeout;
  289.         ($res, $sq, $wack, $pkts, $tout, $ans) = &getpacket($restime);
  290.         if (!$res){
  291.         if ($retries-- > 0) {
  292.             $timeout *= 2;
  293.             redo RETRY;
  294.         }
  295.         else {
  296.             die "No responses from the archie server.\n";
  297.         }
  298.         }
  299.         do {
  300.         $seq = $sq;
  301.         $timeout = $tout if ($tout);
  302.         $pktsnum = $pkts if ($pkts);
  303.         $wantack++ if ($wack);
  304.         if ($seq) {
  305.             if ($received[$seq] ne 'YES') {
  306.             # not duplicate packet.
  307.             $retries = 3;
  308.             foreach $i (($#received + 1) .. ($seq - 1)) {
  309.                 $received[$i] = "NO $i";
  310.             }
  311.             $received[$seq] = 'YES';
  312.             $ans =~ s/\000//g;
  313.             $answer[$seq] = $ans unless ($recthrough >= $seq);
  314.             @notyet = grep(/^NO/, @received);
  315.             if ($#notyet < 0) {
  316.                 $recthrough = $#received;
  317.                 $pktseq = $#received;
  318.             }
  319.             else {
  320.                 $notyet[0] =~ /NO (\d+)$/;
  321.                 $recthrough = $1 - 1;
  322.                 $pktseq = $1 - 1;
  323.             }
  324.             if ($along) {
  325.                 &alongtheway($recthrough, 0);
  326.             }
  327.             }
  328.             if ($pktsnum == 0 || $pktseq < $pktsnum) {
  329.             ($res, $sq, $wack, $pkts, $tout, $ans) = 
  330.                 &getpacket($acktime);
  331.             }
  332.             else {
  333.                     $head = pack("Cnnnn", 9, $$, 1, 1, $recthrough);
  334.             last;
  335.             }
  336.         }
  337.         } until (!$res || $seq == 0);
  338.         $head = pack("Cnnnn", 9, $$, 1, 1, $recthrough);
  339.         if ($wantack) {
  340.         send(DATA, $head . $lines, 0, $them)
  341.             || die "send: Failed to send an acknowledgement: $!";
  342.         $wantack = 0;
  343.         }
  344.     }
  345.     }
  346.     if ($wantack) {
  347.     send(DATA, $head . $lines, 0, $them)
  348.         || die "send: Failed to send an acknowledgement: $!";
  349.     }
  350.     if ($along) {
  351.     &alongtheway($recthrough, 1);
  352.     }
  353.     @answer;
  354. }
  355.  
  356. # Print the entries in a packet.
  357. sub parselist {
  358.     local(@lists) = @_;
  359.     local(@lines, $dum, $lastmod, $modes, $size, $dir, $entry);
  360.     local($name, @attr, @ainfo, $type);
  361.  
  362.     $entry = 0;
  363.     # split the lines in the packet first.
  364.     @lines = split(/\n/, join('', @lists));
  365.     foreach $line (@lines) {
  366.     # If a LINK L line, then get the initial fields for the
  367.     # entry. Output the last entry if there is one.
  368.     if ($line =~ /^LINK L/) {
  369.         &store($host, $type, $dir, $size, $modes, $lastmod, $name) 
  370.         if ($entry);
  371.         $type = $name = $host = $dir = '';
  372.         $size = $modes = $lastmod = '';
  373.         $#attr = $#ainfo = -1;
  374.         ($dum, $dum, $type, $name, $dum, $host, $dum, $dir, $dum, $dum) =
  375.         split(/ /, $line);
  376.         $host =~ tr/A-Z/a-z/;
  377.         $entry = 1;
  378.     }
  379.     elsif ($line =~ /^LINK /) {
  380.         # What should I do if the response is LINK but not L?
  381.     }
  382.     elsif ($line =~ /^LINK-INFO/) {
  383.         # A LINK-INFO line. Get one attribute per line.
  384.         ($dum, $dum, $attr, $dum, @info) = split(/ /, $line);
  385.         if ($attr eq 'SIZE') {
  386.         $size = join(' ', @info);
  387.         }
  388.         elsif ($attr eq 'UNIX-MODES') {
  389.         $modes = join(' ', @info);
  390.         }
  391.         elsif ($attr eq 'LAST-MODIFIED') {
  392.         $lastmod = join(' ', @info);
  393.         }
  394.         else {
  395.         push(@attr, $attr);
  396.         push(@ainfo, join(' ', @info));
  397.         }
  398.     }
  399.     elsif ($line =~ /^VERSION-NOT-SUPPORTED TRY (\d+)-(\d+),(\d+)/) {
  400.         die "Version of archie server ($1-$2, $3) not supported.\n";
  401.     }
  402.     elsif ($line =~ /^NOT-A-DIRECTORY/) {
  403.         print "Archie error: Not a directory.\n";
  404.     }
  405.     elsif ($line =~ /^UNRESOLVED/) {
  406.         print "Archie error: Unresolved entries.\n";
  407.     }
  408.     elsif ($line =~ /^FILTER/) {
  409.     }
  410.     elsif ($line =~ /^OBJECT-INFO/) {
  411.     }
  412.     elsif ($line =~ /^NONE-FOUND/) {
  413.     }
  414.     elsif ($line =~ /^SUCCESS/) {
  415.     }
  416.     elsif ($line =~ /^FORWARDED/) {
  417.         print "Archie error: No forwarding allowed.\n";
  418.     }
  419.     elsif ($line =~ /^FAILURE/) {
  420.         print "Archie server returns error. \n";
  421.         if ($line =~ /^FAILURE NOT-AUTHORIZED/) {
  422.         print "Probably Max. hit too high. Use smaller -match value\n";
  423.         }
  424.         else {
  425.         print "The error message is:\n";
  426.         print $line;
  427.         }
  428.     }
  429.     elsif ($line =~ /^NOT-AUTHORIZED/) {
  430.         print "Archie error: Not authorized.\n";
  431.     }
  432.     else {
  433.     }
  434.     }
  435.     &store($host, $type, $dir, $size, $modes, $lastmod, $name) if ($entry);
  436. }
  437.  
  438. # Write the fields out on terminal using the format string.
  439. sub write {
  440.     local($host, $type, $dir, $size, $mode, $lastmod, $name) = @_;
  441.     local($seq, @path, $date, $path);
  442.  
  443.     # Convert the date string from 19910713123250Z to
  444.     # 1991 Jul 13 12:32:50 GMT
  445.     $date = ($lastmod eq '') ? 'No Date' : &date($lastmod);
  446.     $seq = $pnum++;
  447.  
  448.     # print the entry. Die if something is wrong. Should I
  449.     # Log the output in a file so the effect is not wasted?
  450.     eval "printf $format"
  451.     || die "A syntax error occured when printing the format string: $@\n";
  452. }
  453.  
  454. # Convert a string.
  455. sub date {
  456.     local($date) = @_;
  457.     local($year, $month, $day, $hour, $min, $sec) =
  458.     (0, 1, 0, 0, 0, 0);
  459.     local($zone) = 'Z';
  460.  
  461.     ($year, $month, $day, $hour, $min, $sec, $zone) = 
  462.     ($date =~ /^(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(.*)/);
  463.  
  464.     # A time zone Z is the same as GMT.
  465.     if ($zone eq 'Z') {
  466.     $zone = 'GMT';
  467.     }
  468.     "$year $month[$month] $day $hour:$min:$sec $zone";
  469. }
  470.  
  471. # Parse the format string to convert it to a valid perl format
  472. # string.
  473. sub parseformat {
  474.     local($string) = @_;
  475.     local($nstring, $index, @plist);
  476.  
  477.     $string =~ s/([\$\{\}\@\*])/\\$1/g;
  478.     $nstring = '';
  479.     $#plist = -1;
  480.     while (($index = index($string, '%')) >= 0) {
  481.     $nstring .= substr($string, 0, $index);
  482.     substr($string, 0, $index) = '';
  483.     if (substr($string, 1, 1) eq '%') {
  484.         substr($string, 0, 2) = '';
  485.         $nstring .= '%%';
  486.     }
  487.     elsif ($string =~ /^\%(\d*)(host|dir|mode|date|seq|size|name|type)/) {
  488.         push(@plist, "\$$2");
  489.         if ($2 eq 'size' || $2 eq 'seq') {
  490.         $nstring .= "\%$1d";
  491.         }
  492.         else {
  493.         $nstring .= "\%$1s";
  494.         }
  495.         substr($string, 0, length($1 . $2) + 1) = '';
  496.     }
  497.     else {
  498.         die sprintf("$prog: Format error. Unknown field: %s\n", $string);
  499.     }
  500.     }
  501.     $nstring .= $string;
  502.     $nstring = '"' . $nstring . '"';
  503.     join(', ', $nstring, @plist);
  504. }
  505.  
  506. # Parse the startup file ~/.archierc
  507. # The format of the file is very simple:
  508. # command option
  509. # The format command must be the last one.
  510. sub parserc {
  511.     local($startfile) = @_;
  512.     local($domain, @domain);
  513.     if (-e $startfile && -r $startfile) {
  514.     open (RC, $startfile) || return;
  515.     while (<RC>) {
  516.         chop;
  517.         if (/^\s*match\s+(\d+)\s*$/) {
  518.         $match = $1;
  519.         }
  520.         elsif (/^\s*sort\s+/) {
  521.         if (/^\s*sort\s+date\s*$/) {
  522.             $sortpack = 'date';
  523.         }
  524.         elsif (/^\s*sort\s+host\s*$/) {
  525.             $sortpack = 'host';
  526.         }
  527.         else {
  528.             print "Unknown sort field in startup file: $startfile\n";
  529.         }
  530.         }
  531.         elsif (/^\s*domain\s+(.*)$/) {
  532.         &pdomain($1);
  533.         }
  534.         elsif (/^\s*search\s+([a-z]+)\s*$/) {
  535.         if ($1 eq 'case') {
  536.             $case = 'C';
  537.         }
  538.         elsif ($1 eq 'nocase') {
  539.             $case = 'S';
  540.         }
  541.         elsif ($1 eq 'reg') {
  542.             $case = 'R';
  543.         }
  544.         elsif ($1 eq 'exact') {
  545.             $case = '=';
  546.         }
  547.         else {
  548.             print "$prog: $user/.archierc: unknown search option $1\n";
  549.         }
  550.         }
  551.         elsif (/^\s*host\s+(.+)\s*$/) {
  552.         $archieserver = $1;
  553.         }
  554.         elsif (/^\s*format\s*$/) {
  555.         undef $/; $format = <RC>; $/ = "\n";
  556.         last;
  557.         }
  558.         elsif ($_ =~ /^\s*$/ || $_ =~ /^\s*\#/) {
  559.         # Empty or comment line in the startup file.
  560.         }
  561.         else {
  562.         print "$prog: Unknown option in $user/.archierc: $_\n";
  563.         }
  564.     }
  565.     close(RC);
  566.     }
  567. }
  568.  
  569. sub store {
  570.     local($host, $type, $dir, $size, $mode, $lastmod, $name) = @_;
  571.  
  572.     $type = ($type eq 'DIRECTORY') ? 'Directory' : 'File';
  573.     if ($type eq 'Directory' && $dir =~ m.ARCHIE/HOST.) {
  574.     ($archie, $dum, $host, $dir) = 
  575.         ($dir =~ m|([^/]+)/([^/]+)/([^/]+)/(.*)$|);
  576.     $dir = '/' . $dir;
  577.     }
  578.     push(@s_lastmod, $lastmod);
  579.     push(@s_name, $name);
  580.     push(@s_host, $host);
  581.     push(@s_type, $type);
  582.     push(@s_dir, $dir);
  583.     push(@s_size, $size);
  584.     push(@s_mode, $mode);
  585. }
  586.  
  587. sub result {
  588.     local(@lists) = @_;
  589.     local(%entries, $host, $index, @order, @host, $order, $field);
  590.     $#s_lastmod = -1;
  591.     $#s_name = -1;
  592.     $#s_host = -1;
  593.     $#s_type = -1;
  594.     $#s_dir = -1;
  595.     $#s_mode = -1;
  596.     $#s_size = -1;
  597.     &parselist(@lists);
  598.     $index = 0;
  599.     %entries = ();
  600.     @field =  ($sortpack eq 'date') ? @s_lastmod : @s_host;
  601.     foreach $field (@field) {
  602.     $entries{$field} .= "$index ";
  603.     $index++;
  604.     }
  605.     @order = ($sortpack eq 'date') ? sort sortdate @s_lastmod : 
  606.     sort sorthost @s_host;
  607.     foreach $order (@order) {
  608.     if ($entries{$order} ne '') {
  609.         @indexes = split(' ', $entries{$order});
  610.         foreach $i (@indexes) {
  611.         &write($s_host[$i], $s_type[$i], $s_dir[$i],
  612.                $s_size[$i], $s_mode[$i], $s_lastmod[$i], $s_name[$i]);
  613.         }
  614.         $entries{$order} = '';
  615.     }
  616.     }
  617. }
  618.  
  619. sub sorthost {
  620.     local($t);
  621.     local($c, $d);
  622.     @c = split(/\./, $a);
  623.     @d = split(/\./, $b);
  624.     $domainorder{$c[$#c]} = 1100 if ($domainorder{$c[$#c]} eq '');
  625.     $domainorder{$d[$#d]} = 1100 if ($domainorder{$d[$#d]} eq '');
  626.     $t = ($domainorder{$c[$#c]} > $domainorder{$d[$#d]}) ? 1 :
  627.     ($domainorder{$c[$#c]} < $domainorder{$d[$#d]}) ? -1 : 0;
  628.     ($reversesort) ? -$t : $t;
  629. }
  630.  
  631. sub sortdate {
  632.     local($t);
  633.     local(@c, @d, $c, $d, $e, $f);
  634.     $c = $a; $d = $b;
  635.     @c = split(/ /, $c);
  636.     @d = split(/ /, $d);
  637.     $e = join(' ', $c[0], "$month{$c[1]}", @c[2 .. 6]);
  638.     $f = join(' ', $d[0], "$month{$d[1]}", @d[2 .. 6]);
  639.     $t = $e gt $f ? 1 : $e lt $f ? -1 : 0;
  640.     ($reversesort) ? -$t : $t;
  641. }
  642.  
  643. sub pdomain {
  644.     local($list) = @_;
  645.     local($domain, @domain, $index);
  646.     @domain = split(/ /, $list);
  647.     $index = 0;
  648.     foreach $domain (@domain) {
  649.     $domainorder{$domain} = $index;
  650.     $index++;
  651.     }
  652. }    
  653.  
  654. sub alongtheway {
  655.     local($through, $all) = @_;
  656.     return if ($queuehead > $through);
  657.     local(@link, @part, @part1);
  658.     @part = split(/\n/, join('', @answer[$queuehead .. $through]));
  659.     if (!$all) {
  660.     while(($line = pop(@part)) !~ /^LINK L/) {
  661.         unshift(@part1, $line);
  662.     }
  663.     unshift(@part1, $line) unless ($line eq '');
  664.     $answer[$through] = join("\n", @part1);
  665.     $answer[$through] .= "\n";
  666.     $queuehead = $through;
  667.     }
  668.     &result(join("\n", @part));
  669. }
  670.