#!/usr/bin/perl -w
#   $0 [ dir=<directory> ] [ ignore=<suffix,suffix,suffix> ]
# Produce a checkbox list of files for <directory>.
# If no directory, do current directory.
# Must have r and x perms on the directory.
# Directory must contain a generally-writable .tmp directory;
# will not produce a list unles .tmp/. exists in <directory>.
#
# Apache suexec notes:
#  - suexec is automatically used for public_html CGI scripts
#  - suexec will not be used for a 1.3 virtual domain unless the
#    User and Group are given in the VirtualHosts section in
#    /etc/httpd/conf/vhosts/Vhosts.conf
#  - suexec will not be used for a 2.x virtual domain unless the
#    SuexecUserGroup is given in the VirtualHosts section in
#    /etc/httpd/conf/vhosts/Vhosts.conf
#  - if suexec is used in a virtual domain, the compiled-in docroot
#    inside suexec must be a prefix of the virtual domain docroot
#    (it usually isn't - this is a real pain - some versions of suexec
#    are built with "/" as the compiled-in docroot to get around this)
#  - cgi scripts cannot be symlinks if suexec is used; links are OK
# idallen@idallen.ca

use CGI qw/:standard/;
use CGI::Carp qw/fatalsToBrowser/;
open(STDERR,">&STDOUT");
use Cwd;

# Print and flush the header so that subsequent error messages are visible.
#
$| = 1;
print header;
$| = 0;

# This happens when defaults() clears the form!
# Put back $dir from the arg list.
#
#if( @ARGV <= 0 ){
#	$dir = $ENV{QUERY_STRING} || '';
#	print "DEBUG resetting dir '$dir'\n";
#	$dir =~ s/dir=//;
#	param('dir',$dir);
#}

# Optional: comma-separated list of what suffixes to ignore.
# ignore=html,cgi,sh,etc
#
if ( param('ignore') ) {
	$ignore = param('ignore');
	$ignore =~ s/,/|/;
	$ignore =~ s/.*/\\.($&)\$/;
	# print "DEBUG ignore='$ignore'\n";
} else {
	$ignore = '\.(cgi)$';
}

# Find out in which directory we are operating
$dir = param('dir');

# If $dir is missing, assume current directory.
#
unless( $dir ){
    	$dir = '';
	$realdir = '';
} else {
    # Remove zero or more trailing slashes and replace with one slash
    $dir =~ s|/*$|/|;

    # Fix up ~user directory references to be correct for NETSRV or my home
    $realdir = param('realdir');
    unless ( $realdir ) {
	    $realdir = $dir;
	    ($idallen) = $realdir =~ /~(idallen\w*)/;
	    if ( $idallen ) {
		if ( -d "/home/$idallen/public_html" ) {
		    $realdir =~ s|/~idallen\w*|/home/$idallen/public_html|;
		}
	    } elsif ( -d '/homepages/27/d89455221/htdocs' ) {
		$realdir =~ s|/~u35482050|/homepages/27/d89455221/htdocs|;
	    } elsif ( -d '/thome/alleni/public_html' ) {
		$realdir =~ s|/~alleni|/thome/alleni/public_html|;
	    } elsif ( -d '/export/home2/algu/alleni/public_html' ) {
		$realdir =~ s|/~alleni|/export/home2/algu/alleni/public_html|;
	    }
    }
    chdir $realdir or die "Cannot chdir to '$realdir': $!\n";
}

# Get the name of the current directory.
# Isolate the pathname after the document root prefix and slash.
# Don't use &fastcwd - it may not get back to this directory.
#
my $cwd = &cwd || `pwd` || die "Uid $< $> cannot find working dir: $!\n ";
chomp($cwd);
my $root = $ENV{'DOCUMENT_ROOT'};
$root = "/thome/alleni/public_html/teaching"
	if $root eq "/usr/HTTPServer/htdocs/en_US";
my ($shortcwd) = $cwd =~ /$root\/(.*)/;
$shortcwd = $cwd unless $shortcwd;
$shortcwd =~ s/.*\/teaching\///;
# $shortcwd =~ s:/thome/alleni/public_html/teaching/:: ;

print start_html('-title'=>$shortcwd);
print h1("Index of &nbsp;" . font({'-color'=>'red'},tt($shortcwd)));

# print "DEBUG [$root] [$shortcwd]\n<PRE>";
# system('printenv');

unless (
	$cwd =~ m+/(alleni|idallen\w*)/public_html/.+
	||
	$cwd =~ m+/homepages/27/d89455221/htdocs/.+
	||
	$cwd =~ m+/d2/pictures/.+
	||
	$cwd =~ m+/idallen\w*/algonquin/(cst|dat)..../.+
	) {
	print h1($savedir);
	print h2($realdir);
	print h3($cwd) unless $realdir eq $cwd;
	print p("This directory is not a public Ian Allen Web directory.\n");
	print p("The pathname is not under a built-in list.\n");
	print end_html();
	exit 1;
}

$savedir = $dir;

# Browsable dirs must have a .tmp in them; otherwise, this script might
# browse any directories owned by the user.
#
unless ( -r '.' && -x _ && -e '.tmp/.' ) {
	print h1($savedir);
	print h2($realdir);
	print h3($cwd) unless $realdir eq $cwd;
	print p("Directory $cwd does not permit browsing.\n<PRE>");
	system("id;pwd;ls -ld . .tmp");
	print end_html();
	exit 1;
}

$download = param('download');
@selectfiles = param('selectfiles');

unless ( $download && @selectfiles ) {
	# FIRST Menu
	#  Present a list of files and let users check off which ones
	#  they want to download.
	#  Runs unless user has pushed "download" and has non-empty
	#  list of selected files.
	#  Set "download" and "selectfiles" parameters.
	#
	opendir(DIR,".") or die "Cannot open '.': $!";
	# @files = sort grep { /^[^.]/ && -f && ! /^index.(cgi|html?)$/i} readdir(DIR);
	@files = sort grep { /^[^.]/ && -f && -r } readdir(DIR);
	@files = grep { ! /$ignore/oi } @files if $ignore;
	closedir DIR;
	#print "DEBUG @files<br>\n";

	@checkboxes = checkbox_group(
		'-name'=>'selectfiles',
		'-values'=>\@files,
		'-nolabels'=>'1',
		'-linebreak'=>'1',
		);
	$sort = param('sort') || 'Dmtime';
	$mostrecent = 0;
	$mostfile = 'UNKNOWN';
	$countcheckboxes = 0;   # count of files that can be checked
	foreach ( @files ) {
		my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
                      $atime,$mtime,$ctime,$blksize,$blocks)
			    = stat;
		$commasize = commify($size);
		$mostrecent = $mtime, $mostfile = $_
			if $mostrecent < $mtime;
		$sortby = '';
		$sortproc = '{$a cmp $b}';
		if ( $sort eq 'Dname' ){
			$sortproc = '{$b cmp $a}';
		} elsif ( $sort eq 'Amtime' ) {
			$sortby = sprintf("%010d",$mtime);
			$sortproc = '{$a cmp $b}';
		} elsif ( $sort eq 'Dmtime' ) {
			$sortby = sprintf("%010d",$mtime);
			$sortproc = '{$b cmp $a}';
		} elsif ( $sort eq 'Asize' ) {
			$sortby = sprintf("%010d",$size);
			$sortproc = '{$a cmp $b}';
		} elsif ( $sort eq 'Dsize' ) {
			$sortby = sprintf("%010d",$size);
			$sortproc = '{$b cmp $a}';
		}
		# Only make a checkbox for plain text files.
		$cb = shift @checkboxes;
		if ( /\.(txt|asm|c|pl|log|cgi|java)$/i ) {
			++$countcheckboxes;
		} else {
			$cb = '&nbsp;';
		}
		push(@rows,"<!--$sortby-->"
			. td({'-align'=>'right'},tt($cb))
			. th({'-align'=>'left'},
				a({href=>$dir.CGI->escape($_)},tt($_)))
			. td({'-align'=>'right'},tt("$commasize "))
			. td(tt(scalar localtime $mtime))
			);
	}

	# Only show download words and buttons if there is something
	# that can be downloaded.
	#
	$h1download = '';
	$selecttitle = '';
	if ( $countcheckboxes ) {
		$h1download = ', or select files for concatenation and download';
		$selecttitle = "Select";
	}

	print h2("Browse$h1download");
	# print "DEBUG [", param('download'), "]\n";

	if ( $download && $countcheckboxes && @selectfiles <= 0 ) {
	    	print h3("You must select some files before you can download");
	    	print h4("Use the Select buttons beside the file names");
	}
	if ( @rows ) {
		$date = localtime($mostrecent);
		print p("Most recently updated file:",
			tt("&nbsp;",b($mostfile),"&nbsp;",b($date)));
		@rows = eval "sort $sortproc \@rows";
	}
	print start_form;
	print hidden('-name'=>'hidden','-value'=>$$);
	print hidden('-name'=>'dir','-value'=>$dir);
	print hidden('-name'=>'ignore','-value'=>$ignore);
	print hidden('-name'=>'realdir','-value'=>$realdir);
	&DoSubmit if $countcheckboxes;
	@buttons = qw(Aname Dname Asize Dsize Amtime Dmtime);
	@buttonlabels{@buttons} = qw(Sort Reverse Sort Reverse Sort Reverse);
	@printlabels{@buttons} = (
		'Ascending Name',
		'Reverse Name',
		'Ascending Size',
		'Reverse Size',
		'Ascending Date Modified',
		'Reverse Date Modified',
		);
	@radio = radio_group(
		'-name'=>'sort',
		'-default'=>$sort,
		'-values'=>\@buttons,
		'-labels'=>\%buttonlabels,
		'-onClick'=>"submit()",
		);
	print table({-border=>''},
	        caption(strong('Sorted by:',$printlabels{$sort}),
			br("Select a Sort/Reverse Button to change the sort order")),
		Tr(""
			.th($selecttitle)
			.th( "File Name<br>", $radio[0], $radio[1] )
			.th( "Size in Bytes<br>", $radio[2], $radio[3] )
			.th( "Last Modified Date/Time<br>", $radio[4], $radio[5] )
		    ),
		    Tr(\@rows)
		);
	&DoSubmit if $countcheckboxes;
	print end_form;
} else {
	# SECOND Menu
	#  Called to handle the selected items.
	#
	print h1("Link to selected files for download");
	@selectfiles = param('selectfiles');
	die "Cannot find any files\n  " unless @selectfiles;
	$hidden = param('hidden') || die;
	print p(tt("@selectfiles"));
	die "Cannot download; cannot find writable '.tmp': $!\n  "
		unless -w '.tmp/.';
	$out = ".tmp/cgi_$hidden";
	# remove previous files with this root
	unlink <$out*>;
	# generate a new file name every time, so that browser
	# caching doesn't display an old page
	$out .= "_$$.txt";
	open(OUT,">$out")
		or die "Cannot open '$dir$out': $!";
	foreach $f (@selectfiles) {
		open(IN,"<$f")
			or die "Cannot open '$dir$f': $!";
		my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
                      $atime,$mtime,$ctime,$blksize,$blocks)
			    = stat(IN);
		$date = localtime($mtime);
		print OUT ")---------- $f -- $date ----------\n";
		print OUT <IN>;
		close IN;
	}
	close OUT or die "Cannot close '$dir$out': $!";
	print h2("Right-click on the link and select 'Save'");
	print p("The concatenated text file is in Unix format,",
		"using ASCII newline line-end terminators.");
	print p("Open it with VI, WRITE, or WORDPAD.",
		"Windows NOTEPAD will not display it correctly.");
	print a({href=>"$dir$out"},"Download Concatenated Selected Files");
}

print end_html();

exit 0;

sub commify {
	local $_ = shift;
	1 while s/(\d)(\d\d\d)\b/$1,$2/;
	return $_;
}

# Print the list of submit buttons.
#
sub DoSubmit {
	# Need a dummy first submit button so that when the JavaScript
	# submit() is called, 'download' doesn't have a value.
	# Is this a bug?
	# defaults() clears even the passed query string!
	# This makes it useless for a CGI that takes arguments.
	print p(
		submit('-name'=>'dummy','-value'=>''),
		submit('-name'=>'download','-value'=>'Download selected files'),
		reset('Undo current changes')
		);
}