#! /usr/bin/perl -w
#
# uriarchie - a neat wrapper for archie command
#
#  Uriarchie can display results of archie as a URI format and can sort 
#  results in late order of dates. So you can easily get a latest
#  software which you want by doing copy and paste to pass a URI to 
#  your favorite ftp client such as ncftp, wget, lynx, etc. 
#
#  Also uriarchie can exclude specific sites from results with a 
#  regular expression pattern. If you want to exclude FreeBSD 
#  and NetBSD mirror sites from results, you can do that by just 
#  specifying -vBSD as a first argument.
#
#  In addition, uriarchie can pass results to a pager automatically if
#  outputs go beyond 24 or $ENV{LINES} lines. Hppy archieing!
#
#  REQUIREMENTS: 
#    * archie v1.4.1, 1.4.1-FIXED or 1.4.1-FIXED+URL.patch
#    * perl 5.004 or later.
#
# Copyright (C) 1999 Satoru Takabayashi <satoru-t@is.aist-nara.ac.jp>
#     All rights reserved.
#     This is free software with ABSOLUTELY NO WARRANTY.
#
# You can redistribute it and/or modify it under the terms of 
# the GNU General Public License version 2.
#
require 5.004;
use strict;
use IO::File;
use Time::Local;

my %month_names = ("Jan" => 0, "Feb" => 1, "Mar" => 2, "Apr" => 3, 
		   "May" => 4, "Jun" => 5, "Jul" => 6, "Aug" => 7, 
		   "Sep" => 8, "Oct" => 9, "Nov" => 10, "Dec" => 11);
my $re_month =  join '|', keys %month_names;
my $re_day   =  '(?:0?[1-9]|[12][0-9]|3[01])';
my $re_year  =  '(?:\d\d\d\d+|[7890]\d\d)'; # allow 2 digit fomrat such as '98'
my $re_hour  =  '(?:[01][0-9]|2[0-3])';
my $re_min   =  '(?:[012345][0-9])';
my $re_sec   =  '(?:[012345][0-9])';
my $DebugOpt = 0;

# archie command
my $ARCHIE = "archie";

# pager command
my $PAGER  = defined $ENV{PAGER} ? $ENV{PAGER} : "less";

# the pager is invoked when outputs go beyond the lines.
my $LINES  = defined $ENV{LINES} ? $ENV{LINES} : 24;

STDOUT->autoflush(1);
main();

sub main () {
    my $ex_regex = getopt();
    my $fh = new IO::File;
    $fh->open("$ARCHIE @ARGV|") || die;

    my $host     = "";
    my $location = "";
    my %uris     = ();
    while (<$fh>) {
	$host = $1 if /^Host (.*)/;
	$location = $1 if /^\s+Location: (.*)/;
	if (/\s+(DIRECTORY|FILE)\s+..........\s+(\d+)\s+(.*?)\s+(\S+)$/) {
	    my $type = $1;
	    my $size = $2;
	    my $date = $3;
	    my $lastpart = $4;
	    my $uri = $host;
	    $uri = "ftp://" . $uri unless $uri =~ m!^ftp://!;
	    $uri =~ s!/$!!g;
	    $uri .= "$location/$lastpart";
	    if ($type eq "DIRECTORY") {
		$uri .= "/";
		$size = undef;
	    }
	    unless ($ex_regex ne "" && $uri =~ /$ex_regex/) {
		$uris{$uri}->{date} = gettimestr($date);
		$uris{$uri}->{size} = $size;
	    }
	}
    }

    # using the Schwartzian Transform. In this case, it's not meaningful.
    # my @sorted = map { $_->[0] } sort { $b->[1] <=> $a->[1] } 
    # map { [$_, $uris{$_}->{date}] } keys %uris;

    my @sorted = sort { $uris{$b}->{date} <=> $uris{$a}->{date} } keys %uris;

    my @buf = ();
    for my $uri (@sorted) {
	my $date = localtime($uris{$uri}->{date});
	$date =~ s/00:00:00 //;
	
 	push @buf, "Date: $date";
        $buf[$#buf] .=  ", Size: $uris{$uri}->{size}" 
	    if defined $uris{$uri}->{size};
	push @buf, "  $uri";
	push @buf, "";
    }

    print_result(@buf);
}

sub getopt () {
    my $regex = "";

    if (defined $ARGV[0] && $ARGV[0] =~ /^-v(.+)?/) {
	if (defined $1) {
	    $regex = $1;
	} elsif (defined $ARGV[1]) {
	    $regex = $ARGV[1];
	    shift @ARGV;
	} 
	shift @ARGV;
    }
    if (@ARGV == 0) {
	print "usage: uriarchie [-v<pattern>] <argments for archie command>\n";
	print "   -v<pattern>: exclude URIs with the pattern.\n";
	exit 0;
    }
    return $regex;
}

sub gettimestr () {
    my ($orig_str) = @_;
    my $str = $orig_str;
    my ($sec, $min, $hour, $mday, $mon, $year);
    my ($mtime);

    # get the hour, min and sec.
    if ($str =~ s/\b($re_hour):($re_min):($re_sec)\b//) {
	$hour = $1;
	$min  = $2;
	$sec  = $3;
    } else {
	print STDERR "[$orig_str]:: lacks 'hour:min:sec'\n" if $DebugOpt;
	$hour = 0;
	$min  = 0;
	$sec  = 0;
    }

    # get the month
    if ($str =~ s/\b($re_month)\b//i) {
	$mon = $month_names{$1};
    } else {
	print STDERR "[$orig_str]:: lacks 'month'\n" if $DebugOpt;
	$mon = 0;
    }

    # get the year
    # CAUTION: YEAR 10,000 problem is creeping :-)
    if ($str =~ s/\b($re_year)\b//i) {
	$year = $1;
    } else {
	print STDERR "[$orig_str]:: lacks 'year'\n" if $DebugOpt;
	$year = (localtime)[5];  # current year
	$year-- if $mon > (localtime)[4];  # current month
    }

    # get the day using little bit tricky regex :-)
    # this SHOULD be tried at the last.
    if ($str =~ s/\b($re_day)\b//i) {
	$mday = $1;
    } else {
	print STDERR "[$orig_str]:: lacks 'day'\n" if $DebugOpt;
	$mday = 0;
    }

    # calculate
    $mtime = timelocal($sec, $min, $hour, $mday, $mon, $year);

    if ($DebugOpt) {
	print STDERR 
	    "DATE:: [$orig_str] -> $year, $mon, $mday, $hour, $min, $sec" .
		"->$mtime\n" if $DebugOpt;
    }
    return $mtime;
}

sub print_result (@) {
    my @result = @_;

    if ($LINES <= @result) {
	my $pager_fh   = new IO::File;
        if ($pager_fh->open("| $PAGER")) {
	    my $current_fh = select $pager_fh;
	    for my $line (@result) {
		print $line, "\n";
	    }
	    $pager_fh->close;
	    select $current_fh;
	    return;
	}
    } 
    for my $line (@result) {
	print $line, "\n";
    }
}