Source

xemacsweb / cgi-bin / wilma

Full commit
#!/usr/bin/perl -w

# Web Interface to List Mail Archives
#
# Copyright 1997, 1998 by Jason L. Tibbitts III <tibbs@hpc.uh.edu> and
# David Wolfe <dave_wolfe@computer.org>. May be freely used, modified,
# and redistributed under the same terms as Perl. Absolutely no warranty
# of any kind. Authors are not responsible for any damage or loss caused
# by use of this program.
#
# Generates an index page and search form for mail lists archived and
# HTMLized with MHonArc, with a bias toward Majordomo archives.
#
# This is the entry CGI program to view/search a mail list archive. It
# extracts the list name from the PATH_INFO, e.g.
#  http://server/path/wilma/listname
#
# List configuration files are in the ".wilma" subdirectory of the
# directory where this CGI program is installed (but see CFG_ROOT
# below). They reside in files named in the form listname.cf (but see
# CFG_SUFFIX below), e.g. ".wilma/testlist.cf". The other supporting
# programs are assumed to be in the same directory as this one.
#
# $Revision$

use CGI qw/ :standard :html3 /;
use AppCfg 1.2;
use strict;
use subs qw/
    error_exit
    print_ml_index
    print_search_form
/;
use vars qw/
    $CFG_ROOT
    $CFG_SUFFIX
    @MONTH
    $SEARCH
/;

*CFG_ROOT   = \'.wilma';	# Configuration file root directory
*CFG_SUFFIX = \'.cf';		# Configuration file name suffix
*SEARCH     = \'wilma_glimpse';	# Search CGI program name
*MONTH      = [qw/ dummy January February March April May June July
		  August September October November December /];
$| = 1; # Autoflush output

# Determine the name of the list. It's assumed that we're running as the
# index, so we don't get any parameters, but we can expect it in the
# path info. If not, display an index of all the lists we can find.

my ($list) = (path_info() =~ m{^/+([^/]+)}) if path_info();
print_ml_index() unless defined $list && $list ne "";

# Get the list configuration parameters
eval {
    my $cfg = new AppCfg "$CFG_ROOT/$list$CFG_SUFFIX";
    $cfg->import_variables();
};
error_exit("Configuration File Error", $@) if $@;

$CFG::arc_url   ||= $CFG::arc_dir;
$CFG::mail_name ||= $CFG::mail_addr;

my $Address       = ($CFG::mail_addr eq "")
		    ? ""
		    : address(a({'-href' => "mailto:$CFG::mail_addr"},
			$CFG::mail_name));

opendir(ARCHIVES, $CFG::arc_dir) ||
    error_exit("Archive Directory Error",
	"Opening directory '$CFG::arc_dir' for list '$list' received the error '$!'");

my @Archives = reverse sort grep {/$CFG::arc_regex/ && -d "$CFG::arc_dir/$_"}
				    readdir(ARCHIVES);
closedir(ARCHIVES);

my %ArcLabels;
foreach (@Archives) {
    my ($year, $month) = m/$CFG::arc_regex/;
    $year += (($year < 70) ? 2000 : 1900) if $year < 100;
    $ArcLabels{$_} = "$MONTH[$month], $year";
}

my %hdr_args = ('-title' => "$CFG::title Mailing List Interface");
if (defined $CFG::index_background && $CFG::index_background ne "" &&
    -f $CFG::index_background) {
    $hdr_args{'-background'} = $CFG::index_background;
}
elsif (defined $CFG::index_bg_color && $CFG::index_bg_color ne "") {
    $hdr_args{'-bgcolor'} = $CFG::index_bg_color;
}

print header(),
    start_html(%hdr_args),
    h1("$CFG::title Mailing List Interface"),
    hr({'-size' => 4}), "\n";

print p(),
    "The archives are currently being generated.",
    "This happens nightly and occasionally at other times.",
    "Please reload this page for the current status.\n"
	if -f $CFG::flag_file;

print p(),
    "You can ",
    a({'-href' => "#search"}, "search"),
    " or ",
    a({'-href' => "#browse"}, "browse"),
    " the archives.",
    hr({'-size' => 4}), "\n";

(my $base = script_name()) =~ s([^/]+$)();
print_search_form("$base$SEARCH/$list");

print a({'-name' => "browse"},
    h2("Browse the $CFG::title Archives")),
    table({'-cellpadding' => 0, '-cellspacing' => 0},
	build_archive_links($list)),
    hr(), "\n";

if (-r "$CFG::arc_dir/info.html") {
    print a({'-href' => "$CFG::arc_url/info.html"}, "[List Info]");
}
elsif (-r "$CFG::arc_dir/info.txt") {
    print a({'-href' => "$CFG::arc_url/info.txt"}, "[List Info]");
}

print p(), $Address, end_html;

exit 0;

# Appease -w
$CFG::flag_file ||= $CFG::flag_file;

###################################################

sub print_ml_index {
    my $url = script_name();
    local (*DIR);
    my @index;

    opendir(DIR, $CFG_ROOT) || die "Can't open $CFG_ROOT directory: $!\n";
    foreach (sort grep /$CFG_SUFFIX$/, readdir(DIR)) {
	my ($cfg, $list, $title);
	eval {
	    $cfg = new AppCfg "$CFG_ROOT/$_";
	};
	next unless defined $cfg && ($title = $cfg->get_scalar("title"));
	($list = $_) =~ s/$CFG_SUFFIX$//;
	push @index, li(a({'-href' => "$url/$list"}, "$list"),
			" -- $title\n");
    }
    closedir(DIR);

    print header(),
	start_html('-title' => "Mailing List Interface"),
	h1("Archived Mailing Lists"),
	hr(), "\n",
	ul(@index),
	hr(),
	end_html();
    exit 0;
}


###################################################
#
# Outputs the search form

sub print_search_form {
    my ($script) = @_;
    print a({'-name' => "search"}, h2("Search the $CFG::title Archives")),
	startform('-method' => "GET", '-action' => $script),

	b("This server supports complex queries:"),
	br(),

	"Words separated by a space are searched for together (",
	b("mailing list"),
	"). To find either one word or the other, separate them with a comma (",
	b("mailing,list"),
	"). To find two words together in the same file, ",
	"separate them with a semicolon (",
	b("mailing;list"),
	"). Note that ",
	strong("all"),
	" spaces are significant; searching for two words separated ",
	"by a space will not find those two words separated by ",
	"anything other than a single space.",
	br(), "\n";

    print b("Click for more ",
	  a({'-href' => $CFG::glimpse_help}, "help on patterns."),
	) if defined $CFG::glimpse_help;

    print p(),
	b("What would you like to search for? "),
	textfield('-name' => "query", '-size' => 50),
	br(),

	submit('-name' => "Search"),
	reset('-name' => "Reset"),
	br(),

	table(
	  Tr(
	    td(checkbox('-name' => "case", '-label' => "")),
	    td(b("Case sensitive")),
	    td({'-colspan' => 2}, "Check this box if you want to find ",
	      "only matches having the exact case as your input. ",
	      "With this, a search for ",
	      b("Mailing"),
	      " would not find ",
	      b("mailing"),
	      ".",
	    ),
	  ),
	  Tr(
	    td(checkbox('-name' => "partial", '-label' => "")),
	    td(b("Partial match")),
	    td({'-colspan' => 2}, "Check this box if you want to find ",
	      "partial matches to a word. With this, a search for ",
	      b("mail"),
	      " would find ",
	      b("mailing"),
	      ".",
	    ),
	  ),
	  Tr(
	    td(checkbox('-name' => "lineonly", '-label' => "")),
	    td(b("Single line match")),
	    td({'-colspan' => 2}, "Check this if you want all terms of your ",
	      "search to be found on the same line.  With this, a search for ",
	      b("mailing;list"),
	      " will only find documents with both ",
	      b("mailing"),
	      " and ",
	      b("list"),
	      " on the same line.",
	    ),
	  ),
	  Tr(
	    td(checkbox('-name' => "restricttofiles", '-label' => "")),
	    td(b("Restrict matched files")),
	    td("Check this if you want to restrict the search to a ",
	      "specific archive or set of archives. If not checked, ",
	      "the search will span all of the individual archives.",
	      br(),
	      "Choose the archives to search from the following list:",
	    ),
	    br(),
	    td(scrolling_list('-name'     => 'filelist',
			      '-values'   => \@Archives,
			      '-labels'   => \%ArcLabels,
			      '-size'     => 5,
			      '-multiple' => 'true'),
	    ),
	  ),
	),

	table(
	  Tr(
	    td({'-colspan' => 2, '-align' => 'center'},
	      b("Misspellings allowed."),
	    ),
	    td({'-colspan' => 2, '-rowspan' => 2}, br(),
	      "Words can be found even if they are misspelled.  Set this to ",
	      "the number of errors allowed in each match.  With this set to ",
	      b("1"),
	      ", a search for ",
	      b("mailling"),
	      " will find ",
	      b("mailing"),
	      " but not ",
	      b("maling"),
	      ". Note that misspelled matches are not ",
	      "highlighted in the search results.",
	    ),
	  ),
	  Tr(
	    td({'-colspan' => 2, '-align' => 'center'},
	      popup_menu('-name' => 'errors',
		'-values' => [0, 1, 2, 3, 4, 5, 6, 7, 8, 'Best match']),
	    ), 
	  ),
	  Tr(
	    td({'-colspan' => 2, '-align' => 'center'},
	      b("Max. files returned."),
	    ),
	    td({'-colspan' => 2, '-rowspan' => 2}, br(),
	      "This limits the number of matching files that will be ",
	      "reported in the search results.",
	    ),
	  ),
	  Tr(
	    td({'-colspan' => 2, '-align' => 'center'},
	      popup_menu('-name' => 'maxfiles',
		'-values' => [10, 20, 50, 100, 500, 1000], '-default' => 50),
	    ),
	  ),
	  Tr(
	    td({'-colspan' => 2, '-align' => 'center'},
	      b("Max. matches per file."),
	    ),
	    td({'-colspan' => 2, '-rowspan' => 2}, br(),
	      "This limits the number of matching lines that will be ",
	      "found in a single file.  Set this to ",
	      b("0"),
	      " if you only want to find matching files.",
	    ),
	  ),
	  Tr(
	    td({'-colspan' => 2, '-align' => 'center'},
	      popup_menu('-name' => 'maxlines',
		'-values' => [0, 5, 10, 25, 50, 100], '-default' => 10),
	    ),
	  ),
	),

	endform(),
	hr(), "\n";
}


###################################################
#
# Returns an array of HTML text for the available archive index links

sub build_archive_links {
    my ($list) = @_;
    my @rows;

    foreach (@Archives) {
	my ($arsize, @cols);
	push(@cols, td({'-align' => "right"}, b("$ArcLabels{$_}:\n")));
	push(@cols, ((-r "$CFG::arc_dir/$_/index.html")
		      ? td(a({'-href' => "$CFG::arc_url/$_/"}, "[Index]\n"))
		      : td()
		    ));
	push(@cols, ((-r "$CFG::arc_dir/$_/threads.html")
		      ? td(a({'-href' => "$CFG::arc_url/$_/threads.html"},
			    "[Thread]\n"))
		      : td()
		    ));
	push(@cols, ((-r "$CFG::arc_dir/$list.$_" && ($arsize = -s _))
		      ? td(a({'-href' => "$CFG::arc_url/$list.$_"},
			  "[Raw Archive ($arsize bytes)]\n"))
		      : td()
		    ));
	push(@rows, Tr(@cols));
    }

    @rows;
}


###################################################
#
# Generic error display of HTML error message and exit.

sub error_exit {
    my $text = shift || "Unspecified Error Exit";
    my $desc = join(" ", @_) || "";
    unless (defined $desc && $desc =~ /\S/) {
	my ($pkg, $file, $line) = caller();
	$desc = "In package '$pkg' at line $line of '$file'.";
    }

    my $address = "";
    if (defined $CFG::mail_addr && $CFG::mail_addr ne "") {
	$CFG::mail_name ||= $CFG::mail_addr;
	$address          = address(a({'-href' => "mailto:$CFG::mail_addr"},
			    $CFG::mail_name));
    }

    print header(),
	start_html('-title' => "ERROR"),
	h1($text),
	$desc,
	p(),
	$Address,
	end_html();

    exit 1;
}