Apache::OpenIndex - Perl Open Index manager for a Apache Web server

  PerlModule Apache::Icon
  PerlModule Apache::OpenIndex
  (PerlModule Apache::Language) optional
  (PerlModule Image::Magick)    optional

	"http://www.site.com/bob/.XOI/"

  PerlModule Apache::Icon
  PerlModule Apache::OpenIndex

   use Apache::Icon();
   use Apache::OpenIndex();

    <Directory>
    <Files>
    <Location>

    <LocationMatch /.*/\.XOI>
	SetHandler perl-script
	PerlHandler Apache::OpenIndex
    </LocationMatch> 

    http:://www.site.com/friends/bob/.XOI/

 PerlAuthenHandler Apache::AuthenDBI
 PerlAuthzHandler  Apache::AuthzDBI
 AuthName DBI
 AuthType Basic
 PerlSetVar Auth_DBI_data_source  dbi:Pg:dbname=webdb
 PerlSetVar Auth_DBI_username     webuser
 PerlSetVar Auth_DBI_password     webpass
 PerlSetVar Auth_DBI_pwd_table    users
 PerlSetVar Auth_DBI_uid_field    username
 PerlSetVar Auth_DBI_grp_field    GID
 PerlSetVar Auth_DBI_pwd_field    password
 PerlSetVar Auth_DBI_encrypted    on
 require group webgroup friends propellers

 SetHandler perl-script
 PerlHandler Apache::OpenIndex

    OpenIndexOptions GIDEnv=REMOTE_GROUP

	REMOTE_GROUP=1000

  OpenIndexOptions GIDEnv=REMOTE_GROUP
  OpenIndexOptions Admin=1000

    http://www.apache.org/docs/mod/mod_autoindex.html

#$Id: OpenIndex.pm,v 1.04b 2001/10/17 13:33:42 perler@xorgate.com Exp $
package Apache::OpenIndex;
use strict;

$Apache::OpenIndex::VERSION = '1.04b';

use Apache::Constants qw(:common OPT_INDEXES DECLINE_CMD REDIRECT DIR_MAGIC_TYPE);
use DynaLoader ();
use Fcntl qw/:flock/;
use Apache::Util qw(ht_time size_string escape_html);
use Apache::ModuleConfig;
use Apache::Icon;
use Apache::Language;
use Apache::Request;
use Apache::Log;

#Configuration constants
use constant FANCY_INDEXING 	=> 1;
use constant ICONS_ARE_LINKS 	=> 2;
use constant SCAN_HTML_TITLES 	=> 4;
use constant SUPPRESS_LAST_MOD	=> 8;
use constant SUPPRESS_SIZE  	=> 16;
use constant SUPPRESS_DESC	=> 32;
use constant SUPPRESS_PREAMBLE 	=> 64;
use constant SUPPRESS_COLSORT 	=> 128;
use constant THUMBNAILS 	=> 256;
use constant SHOW_PERMS         => 512;
use constant HIDE_EXT		=> 1024;
use constant FOLDERS_FIRST	=> 2048;
use constant NO_OPTIONS		=> 4096;
use constant SKIP_INDEX		=> -1;
use constant ERROR		=> -2;
use constant URI_FILE		=> 1;
use constant URI_DIR		=> 2;
use constant URI_ROOT		=> 4;
use constant URI_MARK		=> 8;

use vars qw(%GenericDirectives);
%GenericDirectives = 
(      
    fancyindexing		=> FANCY_INDEXING,
    iconsarelinks		=> ICONS_ARE_LINKS,
    scanhtmltitles		=> SCAN_HTML_TITLES,
    suppresslastmodified	=> SUPPRESS_LAST_MOD,
    suppresssize		=> SUPPRESS_SIZE,
    suppressdescription		=> SUPPRESS_DESC,
    suppresshtmlpreamble	=> SUPPRESS_PREAMBLE,
    suppresscolumnsorting	=> SUPPRESS_COLSORT,
    thumbnails			=> THUMBNAILS,
    showpermissions		=> SHOW_PERMS,
    hideext			=> HIDE_EXT,
    foldersfirst		=> FOLDERS_FIRST,
);

#Default values
use constant DEFAULT_ICON_WIDTH => 20;
use constant DEFAULT_ICON_HEIGHT=> 22;
use constant DEFAULT_NAME_WIDTH => 23;
use constant DEFAULT_ORDER	=> 'ND';
use constant DEFAULT_FAKE_DIR 	=> '.XOI';
use constant DEFAULT_MARK_DIR 	=> '.MARK';
use constant DEFAULT_TEXT_LEN 	=> 49;
use constant DEFAULT_MENU	=> ['Upload','Unzip','Delete','MkDir','MkFile','Copy','Move','Edit','Rename','Help',];
use constant DEFAULT_ADMN_MENU	=> ['SetGID','Revoke','Debug',];
use constant DEFAULT_POST_MAX 	=> 4194304;
use constant DEFAULT_EDIT_MAX 	=>  131072;
use constant DEFAULT_HELP_URL 	=> 'http://www.xorgate.com/help/OpenIndex';
use constant DEFAULT_DIR_MOD 	=> 0770;
use constant DEFAULT_FILE_MOD 	=> 0460;
use constant REVOKE_DIR		=> '/revoke';
use constant REVOKE_FILE	=> '/revoked';

use vars qw(%sortname);
%sortname =
( 	
'N'=>'Name',
'M'=>'LastModified',
'S'=>'Size',
'D'=>'Description',
);

#Statistics variables
use vars qw($nDir $nRedir $nIndex $nThumb);
$nDir=0;
$nRedir=0;
$nIndex=0;
$nThumb=0;

# global arguments
use vars qw($debug $dodump $errmsg $chgid $users $iconfig %commands);
%commands = (
    Menu => {
	back=>\&procform,
    },
    Upload => {			# name of the menu button selected
	cmd=>\&Upload,		# routine to call when selected
	req=>'browse',		# have to have browse form field
	src=>'browse',
    },
    Unzip => {
	cmd=>\&Unzip,
	min=>1,			# at least 1 item has to be selected
    },
    Delete => {
	cmd=>\&Delete,
	min=>1,			# at least 1 item has to be selected
    },
    MkDir => {
	cmd=>\&MkDir,
	req=>'dst',		# has to have a destination
    },
    MkFile => {
	cmd=>\&Edit,
	req=>'dst',
	src=>'dst',
	back=>\&EditSave,	# routine called back after MkFile submit
    },
    Copy => {
	cmd=>\&Copy,
	req=>'dst',		# has to have a destination
	min=>1,
    },
    Move => {
	cmd=>\&Move,
	req=>'dst',
	min=>1,
    },
    Edit => {
	cmd=>\&Edit,
	min=>1,
	max=>1,			# can only operate on one item
	back=>\&EditSave,	# routine called back after Edit submit
    },
    Rename => {
	cmd=>\&Rename,
	req=>'dst',
	min=>1,
	max=>1,			# can only operate on one item
    },
    Help => {
	cmd=>\&Help,
    },
    SetGID => {
	cmd=>\&SetGID,
	min=>1,
	req=>'group',
	dst=>'group',
	admin=>1,
    },
    Revoke => {
	cmd=>\&Revoke,
	back=>\&Revokem,
	admin=>1,
    },
    Debug => {
	cmd=>\&Debug,
	admin=>1,
    },
    SelectAll => {
	cmd=>\&SelectAll,
    },
);

if ($ENV{MOD_PERL}){
    no strict;
    @ISA=qw(DynaLoader);
    __PACKAGE__->bootstrap($Apache::OpenIndex::VERSION);
    if (Apache->module('Apache::Status')) {
	Apache::Status->menu_item('OpenIndex'=>'Apache::OpenIndex status',\&status);
    }
}

sub oindex {
 my ($r,$args,$filename,$mode,$cfg) = @_;
 my $uri = $r->uri;
 my $fakedir=$cfg->{fakedir};
 my $markdir=$cfg->{markdir};
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $isroot;
 my $retval=1;
    $r->filename($filename);
    return 0 unless opendir HDH, $filename;
 my $msg=$lang->{IndexOf} || 'Index of';
    chomp($msg);
 my $ref=$args->{dir};
    if($mode) {
	if($mode & URI_MARK) {
	    if($cfg->{markroot}) {
		$isroot=$filename=~m:^$cfg->{markroot}$:;
	    } else {
		$isroot=$filename=~m:$fakedir/$markdir/$:;
	    }
	} elsif($mode & URI_ROOT) {
	    $isroot=$uri=~m:^$args->{root}$fakedir/$:;
	    $ref=~s:/$fakedir/:/:;
	}
    } else {
	$isroot=$uri=~m:^$args->{root}$:;
    }
    print STDERR "oindex() open $filename\n" if $debug;
    thumb_conf($r) if $cfg->{options} & THUMBNAILS;
    tagout('h2',$cfg,'', qq~<a name="main">$msg $ref</a></h2>~);
    if($mode) {
	tagout('form',$cfg,qq~method="post" action="$uri" enctype="multipart/form-data"~);
	cmd_form($r,$args,$cfg);
    }
    $nDir++;
    if($cfg->{options} & FANCY_INDEXING) {
	$retval=fancy_page($r,$args,\*HDH,$mode,$isroot); 
    } else {
	$retval=plain_page($r,$args,\*HDH,$mode,$isroot);
    }
    print "</form>\n" if($mode);
    closedir HDH;
    $retval;
}

sub procform {
 my ($r,$args,$cfg,$docroot) = @_;
 my $fakedir = $cfg->{fakedir};
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $mode=$args->{mode};
 my $msg;
 my $dir;
 my $formsrc;
 my $formdst;
 my $userdir;
 my $count;
 my $retval=0;
 my $items=$args->{items};	# Items array selected
 my $icnt=@$items;		# The number selected
 my $cmd = getcmd($cfg->{menu},$args);
    $cmd||=getcmd($cfg->{admnmenu},$args);
 my $cmdname=$lang->{$cmd} || $cmd;
    chomp $cmdname;
 my $req=$commands{$cmd}{req};
    if($mode & URI_MARK) {
	if($args->{dst}=~m:^/:o) {
	    $formdst=$args->{dst};
	} else {
	    $formdst="$args->{dir}$args->{dst}";
	}
	$dir=$args->{dir};
    } elsif($mode & URI_ROOT) {
	if($args->{dst}=~m:^/:o) {
	    $formdst=$args->{dst};
	} else {
	    ($formdst="$args->{dir}$args->{dst}")=~s:/$fakedir/:/:;
	}
	($dir=$args->{dir})=~s:/$fakedir/:/:;
    } else {
	$msg=$lang->{mode} || 'UNKNOWN: mode';
	errmsg($msg);
	return 0;
    }
 my $dst=$commands{$cmd}{dst};
    if($dst) {
	if($dst eq 'src') {
	    $formdst=$formsrc;
	} else {
	    $formdst=$args->{$dst};
	}
    }
    print STDERR "procform($cmd)\n" if $debug;
# check if cmd
    unless($cmd) {
	$msg=$lang->{command} || 'UNKNOWN: command';
	errmsg($msg);
	$r->log->error(__PACKAGE__." internal error: NULL command");
	return ERROR;
    }
# check min select
    $count=$commands{$cmd}{min};
    if($count && $icnt<$count) {
	$msg=$lang->{min} || 'Select more items!';
	errmsg("$cmdname: $msg");
	$r->log->warn(__PACKAGE__." $cmd ERROR: $args->{user}: $msg");
	return ERROR;
    }
# check max select
    $count=$commands{$cmd}{max};
    if($count && $icnt>$count) {
	$msg=$lang->{max} || 'Too many items selected!';
	errmsg("$cmdname: $msg");
	$r->log->warn(__PACKAGE__." $cmd ERROR: $args->{user}: $msg");
	return ERROR;
    }
# check req
    if($req) {
	unless($args->{$req}) {
	    $msg=$lang->{$req} || "$req";
	    chomp($msg);
	    $msg.=' ';
	    $msg.=$lang->{required} || "required!";
	    errmsg("$cmdname: $msg");
	    $r->log->warn(__PACKAGE__." $cmd ERROR: $args->{user}: $msg");
	    return ERROR;
	}
	unless($args->{isadmin}) {
# do not allow hidden files names to be used.
	 my $ignore_regex;
	    if($cfg->{ignore}) {
		if($args->{$req}=~m:[/\\]:o) {
		    $ignore_regex = '.*[/\\\\]'.join('$|.*[/\\\\]',@{$cfg->{ignore}}).'$';
		} else {
		    $ignore_regex = '^'.join('$|^',@{$cfg->{ignore}}).'$';
		}
	    }
	    if($args->{$req}=~m:$ignore_regex:) {
		$msg=$lang->{forbid} || 'Forbidden: ';
		$msg.=$lang->{$req} || $args->{$req};
		errmsg($msg);
		$r->log->error(__PACKAGE__." FORBIDDEN: $req=$args->{$req}");
		return ERROR;
	    }
	}
    }
    $docroot='' if $mode & URI_MARK && $cfg->{markroot};
    $userdir=$cfg->{userdir};
    $docroot='' if $formdst=~m:/~:o && $userdir=~m:^/:o;
    $formdst=xuserdir($formdst,$userdir) if $userdir;
    $dir    =~tr{ :.a-zA-Z0-9~!@#$^&+i_\\\-/}{}cd; #strip unusual characters
    $formdst=~tr{ :.a-zA-Z0-9~!@#$^&+i_\\\-/}{}cd;
    unless(dirbound($formdst,$args->{root})) { # Don't allow $formdst below root
	$msg=$lang->{ProcDstRoot} || 'Destination goes below the root directory';
	errmsg($msg);
	return ERROR;
    } 
 my $oldmask=umask $cfg->{umask} if $args->{gid} && $cfg->{umask};
# process any before command
    if($commands{$cmd}{before}) {
	unless($commands{$cmd}{before}->($r,$args,$cfg,$docroot,$items,$formdst)) {
	    $r->log->error(__PACKAGE__." $cmd before");
	    return ERROR;
	}
    }
    do {
     my $src=$commands{$cmd}{src};
	if($src) {
	    if($src eq 'dst') {
		$formsrc=$formdst;
	    } else {
		$formsrc=$args->{$src};
	    }
	} else {
	    $formsrc="$dir$items->[--$icnt]";
	}
	$formsrc=xuserdir($formsrc,$userdir) if $userdir;
	$formsrc=~tr{ :.a-zA-Z0-9~!@#$^&+i_\\\-/}{}cd;
	unless(dirbound($formsrc,$args->{root})) { # Don't allow $formsrc below root
	    $msg=$lang->{SourcePath} || 'Bad source path';
	    errmsg($msg);
	    umask($oldmask) if $args->{gid} && $cfg->{umask};
	    $retval=ERROR;
	} else {
	    $retval=$commands{$cmd}{cmd}->($r,$args,$cfg,$docroot,$formsrc,$formdst);
	    unless($retval) {
		$r->log->warn(__PACKAGE__." $cmd ERROR: $args->{user}: $docroot: src=$formsrc dst=$formdst");
		$retval=ERROR;
	    } else {
		$retval=0 unless $retval<0 || $retval>99;
	    }
	}
    } until $icnt<1 || $retval;
# process any after command
    if($commands{$cmd}{after}) {
	$retval=$commands{$cmd}{after}->($r,$args,$cfg,$docroot,$formdst);
	unless($retval) {
	    $r->log->error(__PACKAGE__." $cmd after");
	    $retval=ERROR;
	}
    }
    umask($oldmask) if $args->{gid} && $cfg->{umask};
    $retval;
}

# Returns the translated UserDir $path according to the $pattern
sub xuserdir {
 my($path,$pattern)=@_;
    print STDERR "xuserdir() path=$path pattern=$pattern" if $debug;
    return $path unless $pattern;
 my($head,$user,$tail)=$path=~m:^(.*)/~(.+)/(.*):o;
 my $userdir=$pattern;
    if($pattern=~m:/\*/:o) {
	$userdir=~s:/\*:/$user: if $user;
	$path=~s:/~$user:$userdir:;
    } elsif($pattern=~m:^/:o) {
	$path=$pattern;
	$path.='/' unless $path=~m:/$:o;
	$path.="$user/$tail";
    } else {
	$path="$head/$user/$pattern";
	$path.="/$tail" if $tail;
    }
print STDERR "->$path\n" if $debug;
    $path;
}

sub frames {
 my($r,$args,$cfg) = @_;
 my $uri = $r->uri;
 my $footer=gotfooter($r,$cfg);
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $ac = $uri=~m:\?:o ? '&amp;':'?';
 my $msg=qq~src="$uri${ac}frame=main"~;
    print STDERR "frames() uri=$uri src=$msg footer=$footer\n" if $debug;
    if($cfg->{frameset}) {
	tagout('frameset',$cfg);
    } else {
	print qq~<frameset rows="15%,*~,$footer?',15%':'',qq~">\n~;
    }
    if($cfg->{htmltext}{frame}) {
	my $frametext=$lang->{$cfg->{htmltext}{frame}} || $cfg->{htmltext}{frame};
	if($cfg->{frame}) {
	    $frametext=~s:<mainframe>:<frame $msg $cfg->{frame} />:i;
	} else {
	    $frametext=~s:<mainframe>:<frame $msg id="main" />:i;
	}
	print "$frametext\n";
    } else {
	print qq~<frame src="$uri${ac}frame=head" id="head" />\n~;
    	etagout('frame',$cfg,qq~src="$uri${ac}frame=main"~.$cfg->{frame}?'':'id="main"');
	print qq~<frame src="$uri${ac}frame=foot" id="foot" />\n~ if $footer;
    }
    if($cfg->{htmltext}{noframes}) {
	$msg=$lang->{$cfg->{htmltext}{noframe}} || $cfg->{htmltext}{noframe};
    } else {
	$msg=$lang->{NoFrames} || 'Sorry, your browser can not display frames.  Select the following:';
	chomp $msg;
    }
    tagout('noframes',$cfg);
    print qq~$msg <a href="$uri${ac}frame=none">\n</noframes>\n</frameset>\n~;
    1;
}

sub header {
 my ($r,$args,$cfg,$notitle)=@_;
    print STDERR "header() $cfg->{headuri}\n" if $debug;
    if($cfg->{headuri}) {
     my $subr = $r->lookup_uri($cfg->{headuri});
	$subr->run;
    }
    place_doc($r,$cfg,'header') if $cfg->{header};
    unless($notitle || $cfg->{notitle}) {
	tagout('h1',$cfg,'','OpenIndex');
	if($args->{gid}) {
	 my $lang = new Apache::Language($r) if $cfg->{language};
	 my $msg=$lang->{user} || 'User';
	    print " $msg=$args->{user}" if $args->{user};
	 my $cnt=@{$args->{gid}}-1;
	    $msg=$lang->{access} || 'Access';
	    print " $msg=$args->{gidname}[$cnt]";
	    for($cnt--;$cnt>=0;$cnt--) {
		print ",$args->{gidname}[$cnt]";
	    }
	}
	print "</h1>\n";
    }
    1;
}

sub httphead {
 my ($r,$title)=@_;
 my $cfg = Apache::ModuleConfig->get($r);
 my $lang = new Apache::Language($r) if $cfg->{language};
    $r->no_cache(1) if $cfg->{nocache};
    $r->send_http_header('text/html');
    return 0 if $r->header_only;
    print STDERR "httpdhead()\n" if $debug;
# print qq~<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN""http://www.w3.org/TR/REC-html40/loose.dtd">\n~;
    print qq~<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 ~,
	$cfg->{frames}?'FrameSet':'Transitional',qq~//EN\n"~,
	qq~"http://www.w3.org/TR/2000/REC-xhtml1-20000126/DTD/-~,
	$cfg->{frames}?'xhtml1-frameset.dtd':'xhtml1-transitional.dtd',qq~">\n~;
    print '<html>';
    tagout('head',$cfg);
    print $lang->{$cfg->{htmltext}{head}} || $cfg->{htmltext}{head} if $cfg->{htmltext}{head};
    tagout('title',$cfg);
    print "$title</title>\n";
    if($cfg->{htmltext}{style}) {
	tagout('style',$cfg);
	print "$cfg->{htmltext}{style}\n</style>\n";
    }
    print "</head>\n";
    tagout('body',$cfg) unless $cfg->{frames};
    1;
}


sub footer {
 my ($r,$cfg)=@_;
    print STDERR "footer() $cfg->{footuri}\n" if $debug;
    if($cfg->{readme}) {
	etagout('hr',$cfg) unless $cfg->{frames};
	place_doc($r,$cfg,'readme');
    }
    if($cfg->{footuri}) {
     my $subr = $r->lookup_uri($cfg->{footuri});
	$subr->run;
    }
    1;
}

sub gotfooter {
 my ($r,$cfg)=@_;
    return 1 if $cfg->{footuri} || $cfg->{readme};
    0;
}

sub cmd_form {
 my ($r,$args,$cfg)=@_;
 my $uri=$r->uri;
 my $dst;
 my $setgid;
 my $docroot=$r->document_root;
 my $fakedir=$cfg->{fakedir};
 my $textlen=$cfg->{textlen} || DEFAULT_TEXT_LEN;
 my $menu=$cfg->{menu}||DEFAULT_MENU;
    if($args->{error}) {
	tagout('h3',$cfg);
	if($cfg->{font}) {
	    tagout('font',$cfg,'',"ERROR: $errmsg</font></h3>");
	} else {
	    print qq~<font color=#FF0000> ERROR: $errmsg</font></h3>~;
	}
	$args->{error}=0;
    }
    if(!$args->{src}) {
	if(!$args->{file} && $args->{child}) {
	    $args->{src}=$args->{child};
	} else {
	    $args->{src}=$args->{file};
	}
    }
    $dst=$args->{dst};
    $setgid=$args->{gid};
 my $didit;
 my $msg='';
 my $lang = new Apache::Language($r) if $cfg->{language};
    tagout('div',$cfg);
    foreach (@$menu) {
	if($_ eq 'Upload') {
	    $msg=$lang->{$_} || $_;
	    chomp $msg;
	    chomp $msg;
	    textout($r,$cfg,'browse');
	    print "$cfg->{browse}" if $cfg->{browse};
	    etagout('input',$cfg,qq~type="file" name="browse" size=$textlen maxlength=255~);
	    textout($r,$cfg,'upload');
	    etagout('input',$cfg,qq~type="submit" name="$_" value="$msg"~);
	    etagout('br',$cfg);
	}
    }
    foreach (@$menu) {
	unless($_ eq 'Upload') {
	    $msg=$lang->{$_} || $_;
	    chomp $msg;
	    chomp $msg;
	    textout($r,$cfg,$_);
	    etagout('input',$cfg,qq~type="submit" name="$_" value="$msg"~);
	}
    }
    unless($cfg->{options} & FANCY_INDEXING) {  # enter the source item if not FANCY
	$msg=$lang->{src} || 'Select Item';
	chomp $msg;
	textout($r,$cfg,'src');
	etagout('br',$cfg);
	etagout('input',$cfg,
	    qq~TYPE="text" name="src" size=$textlen maxlength=255 value="$args->{src}"~,$msg);
    }
    $msg=$lang->{dst} || 'Destination';
    chomp $msg;
    textout($r,$cfg,'dst');
    etagout('br',$cfg);
    etagout('input',$cfg,qq~type="text" name="dst" size=$textlen maxlength=255 value="$dst"~,$msg);
    tagout('p',$cfg);
    if($args->{isadmin}) {
     my $halflen=($textlen+($textlen%2))/2;
	$menu=$cfg->{admnmenu}||DEFAULT_ADMN_MENU;
	foreach (@$menu) {
	    $msg=$lang->{$_} || $_;
	    chomp $msg;
	    chomp $msg;
	    next if $_ eq 'Revoke' && !$cfg->{revoke};
	    next if $_ eq 'Debug'  && !$cfg->{debug};
	    textout($r,$cfg,$_);
	    etagout('input',$cfg,qq~type="text" name="group" size=$halflen maxlength=255~) if $_ eq 'SetGID';
	    etagout('input',$cfg,qq~type="submit" name="$_" value="$msg"~);
	}
    }
    print qq~<input type="hidden" name="proc" value="Menu" />\n~;
    print qq~<input type="hidden" name="all" value="$args->{all}" />\n~ if $args->{all};
    print qq~<input type="hidden" name="frame" value="$args->{frame}" />\n~ if $args->{frame};
    print "</p></div>\n";
    1;
}

sub textout {
 my ($r,$cfg,$cmd)=@_;
    return unless $cfg->{htmltext}{$cmd};
 my $lang = new Apache::Language($r) if $cfg->{language};
    print $lang->{$cfg->{htmltext}{$cmd}} || $cfg->{htmltext}{$cmd};
}

sub plain_page {
 my ($r,$args,$dirhandle,$mode,$isroot)=@_;
 my $cfg = Apache::ModuleConfig->get($r);
 my $hide=!($args->{isadmin} && $dodump);
 my $ignore_regex;
    $ignore_regex = join('$|^',@{$cfg->{ignore}}) if $cfg->{ignore};
    print "<ul>\n";
    while (my $file = readdir $dirhandle) {
     my $stub;
	next if $file=~m/^\.$/o; # Never display '.' directory
	next if $hide && $file=~m/^$ignore_regex$/;
	next if $file eq ".." and $isroot;
     my $subr = $r->lookup_file($file);
	stat $subr->finfo;
	print '    <li><a href="',$args->{dir},$file;
	print '/' if -d _;
	if($mode) {
	    if($file eq '..') {
		$stub=$args->{dir};
		$stub=~s:/$::;
		$stub=~s:.*/::;
	    }
	    print "?child=$stub" if $stub;
	    print $stub?'&amp;':'?',"frame=$args->{frame}" if $args->{frame};
	    print '#main';
	}
	$file=~s:\..*::o if $cfg->{options} & HIDE_EXT;
    	if($file eq $args->{file}) { # selected file goes BOLD
	    print qq~"><b>$file</b></a></li>\n~;
    	} else {
	    print qq~">$file</a></li>\n~;
    	}
    }
    print "</ul>\n";
    1;
}

sub fancy_page {
 my ($r,$args,$dirhandle,$mode,$isroot)=@_;
 my $msg='';
 my $cfg  = Apache::ModuleConfig->get($r);
 my $subr;
 my $uri = $r->uri;
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $list = read_dir($r,$args,$dirhandle);
    tagout('table',$cfg,qq~summary="OpenIndex"~);
    tagout('tr',$cfg);
    if($cfg->{options} & SUPPRESS_COLSORT) {
	foreach('N','M','S','D') {
	    delete $args->{@_};
	}
    }
 my $listing=do_sort($list,$args,$cfg->{default_order},$cfg->{options} & FOLDERS_FIRST);
#Permission header
    tagout('th',$cfg,'align="left"','Permission</th>') if $cfg->{options} & SHOW_PERMS;
#Owner header
    tagout('th',$cfg,'align="left"','Owner</th>') if $args->{isadmin};
#Group header
    if($args->{gid}) {
	$msg=$args->{isadmin}?"Group":"Access";
	tagout('th',$cfg,'align="left"',"$msg</th>");
    }
#Select header
    tagout('th',$cfg,'align="center"','Select</th>') if $mode;
#Icon header
    tagout('th',$cfg,'align="left"','Icon</th>');
#Name, Last Modified, Size, and Description headers
    foreach ('N', 'M', 'S', 'D') {
	next if $cfg->{options} & SUPPRESS_LAST_MOD && $_ eq 'M';
	next if $cfg->{options} & SUPPRESS_SIZE     && $_ eq 'S';
	next if $cfg->{options} & SUPPRESS_DESC     && $_ eq 'D';
	tagout('th',$cfg,'align="left"');
	$msg=$lang->{$sortname{$_}} || $sortname{$_};
	chomp($msg);
	chomp($msg);
	if(not $cfg->{options} & SUPPRESS_COLSORT) {
	 my $query;
	    if($args->{$_}) {
		if($_ eq 'N') {		# Name, can sort on extention
		    $query=($args->{$_} eq 'D')?'A':($args->{$_} eq 'A')?'E':'D';
		} else {
		    $query = ($args->{$_} eq 'D')?'A':'D';
		}
	    } else {
		$query = 'A';
	    }
	    print qq~<a href="?$_=$query~,$args->{frame}?"&amp;frame=$args->{frame}":'',qq~">~;
	    tagout('i',$cfg,'',"$msg</i></a>");
	} else {
	    print $msg;
    	}
        print "</th>\n";
    }
    print '</tr>';
#End of header
    for my $entry (@$listing) {
     my $stub;
     my $label='';
     my $isdir;
	if($entry eq '..') {
	    next if $isroot;
	    $label=$lang->{Parent} || 'Parent&nbsp;Directory';
	    $isdir=1;
	} else {
	    $label = $entry;
	    $label=~s:\..*::o if $cfg->{options} & HIDE_EXT;
	}
     my $img = $list->{$entry}{icon};
	tagout('tr',$cfg,'align="left"');
#Permission data
	tagout('td',$cfg,'',"$list->{$entry}{mode}</td>") if $cfg->{options} & SHOW_PERMS;
#Owner data
	if($args->{isadmin}) {
	 my $pname=getpwuid($list->{$entry}{uid})||"$list->{$entry}{uid}";
	    tagout('td',$cfg,'',"${pname}</td>");
	}
#Group data
	if($args->{gid}) {
	 my $pname=getgrgid($list->{$entry}{gid})||"$list->{$entry}{gid}";
	    tagout('td',$cfg,'',"${pname}</td>");
	}
	if($mode && $entry eq '..') {
	    $stub=$args->{dir};
	    $stub=~s:/$::;
	    $stub=~s:.*/::;
	}
	$isdir=1 if $list->{$entry}{sizenice} eq '-';
#Select checkbox
	if($mode) {
	    if($entry eq '..') {
		print "<td></td>\n";
	    } else {
		tagout('td',$cfg,'align="center"');
		$msg=qq~TYPE="checkbox" name="${entry}"~;
		$msg.=' checked' if $args->{all};
		etagout('input',$cfg,$msg,'</td>');
	    }
	}
#Icon
	tagout('td',$cfg);
	if($cfg->{options} & ICONS_ARE_LINKS) {
	    $msg=$args->{dir};
	    $msg=~s:/$cfg->{fakedir}/:/: if $mode & URI_ROOT && !$isdir;
	    $msg.=$entry;
	    $msg.='/' if $isdir;
	    $msg.="?frame=$args->{frame}" if $args->{frame};
	    if($mode) {
	     my $ac=$args->{frame}?'&amp;':'?';
		$msg.="${ac}child=$stub" if $stub;
		$msg.='#main';
	    }
	    tagout('a',$cfg,qq~a href="$msg"~);
	}
	print 
qq~<img width="$list->{$entry}{width}" height="$list->{$entry}{height}" src="$img" alt="[$list->{$entry}{alt}]" border="0" />~;
	print "</a>" if ($cfg->{options} & ICONS_ARE_LINKS);
	print "</td>\n";
#Name data
	$msg=$args->{dir};
	$msg=~s:/$cfg->{fakedir}/:/: if $mode & URI_ROOT && !$isdir;
	tagout('td',$cfg);
	$msg.=$entry;
	$msg.='/' if $isdir;
	$msg.="?frame=$args->{frame}" if $args->{frame};
	if($mode) {
	 my $ac=$args->{frame}?'&amp;':'?';
	    $msg.="${ac}child=$stub" if $stub;
	    $msg.='#main';
	}
	tagout('a',$cfg,qq~a href="$msg"~);
	if($entry eq $args->{file}) {  # selected file goes BOLD
	    print qq~<b>$label</b>\n~;
	} else {
	    print qq~$label~;
	}
	print qq~</a></td>\n~;
#Last Modified data
	unless($cfg->{options} & SUPPRESS_LAST_MOD) {
	    tagout('td',$cfg);
	    print qq~$list->{$entry}{modnice}</td>~;
	}
#Size data
	unless($cfg->{options} & SUPPRESS_SIZE ) {
	    tagout('td',$cfg,qq~align="center"~);
	    print $list->{$entry}{sizenice},"</td>\n";
	}
#Description data
	unless($cfg->{options} & SUPPRESS_DESC) {
	    tagout('td',$cfg);
	    print $list->{$entry}{desc},'</td>';
	}
	print "</tr>\n";
    }
    if($mode && $args->{bytes} && !($cfg->{options} & SUPPRESS_SIZE)) {
	print '<tr>';
	print '<td></td>' if $cfg->{options} & SHOW_PERMS;
	print '<td></td>' if $args->{isadmin};
	print '<td></td>' if $args->{gid};
	print '<td></td>';
	print '<td></td>' if $cfg->{options} & ICONS_ARE_LINKS;
	print '<td></td>';
	print '<td></td>' unless ( $cfg->{options} & SUPPRESS_LAST_MOD );
	tagout('td',$cfg,qq~align="center"~);
	print '<b>',size_string($args->{bytes}),"</b></td></tr>\n";
    }
    print "</table>\n";
    if($debug && $dodump) {
	use Data::Dumper;
	print "<hr /><pre>\%list\n";
	print Dumper \%$list;
	print "</pre>";
    }
    1;
}

# Start of internal menu command routines
sub SelectAll {
 my ($r,$args,$cfg) = @_;
 my $uri = $r->uri;
 my $c='?';
    unless($args->{all}) {
	$uri.='?all=1';
	$c='&amp;';
    }
    if($args->{frame}) {
	$uri.="${c}frame=$args->{frame}";
	$c='&amp;';
    }
    $uri.="${c}dst=$args->{dst}" if $args->{dst};
    print STDERR "SelectAll() uri=$uri\n" if $debug;
    $r->header_out(Location=>$uri);
    REDIRECT;
}

sub Help {
 my ($r,$args,$cfg) = @_;
 my $uri=$cfg->{help}||DEFAULT_HELP_URL;
    $uri.="?version=$Apache::OpenIndex::VERSION&amp;postmax=$cfg->{postmax}";
    $uri.="&amp;mark=1"  if $cfg->{mark};
    $uri.="&amp;perms=1" if $args->{gid};
    $uri.="&amp;admin=1" if $args->{isadmin};
    $uri.="&amp;frame=$args->{frame}" if $args->{frame};
    $r->header_out(Location=>$uri);
    $r->log->notice(__PACKAGE__." $args->{user}: Help: $uri");
    REDIRECT;
}

sub Debug {
 my ($r,$args,$cfg) = @_;
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg='';
 my $cmdname=$lang->{Debug} || 'Debug';
    $dodump = !$dodump if $debug;
    print STDERR "Debug=$dodump\n" if $debug;
    $r->log->notice(__PACKAGE__." $args->{user}: Debug: $dodump");
    1;
}

sub SetGID {	# Set the item (file or dir) GID 
 my ($r,$args,$cfg,$root,$src,$igid) = @_;
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg='';
 my $cmdname=$lang->{SetGID} || 'SetGID';
 my $name;
    $src="$root$src";
    chomp $cmdname;
    if($igid=~m:[^0-9]:o) {		# if not a number look-up the group
	$name=$igid;
	unless(($igid=getgrnam $name)) {
	    $msg=$lang->{GIDbad} || 'GID name not found';
	    errmsg(qq~${cmdname}: "$name" $msg~);
	    return 0;
	}
    } else {
	unless(($name=getgrgid $igid)) {
	    $msg=$lang->{GIDbad} || 'GID name not found';
	    errmsg(qq~${cmdname}: "$igid" $msg~);
	    return 0;
	}
    }
    unless($igid && chown(-1,$igid,$src)) {
	$msg=$lang->{GIDset} || 'GID not set';
	errmsg(qq~${cmdname}: "$name" $msg~);
	return 0;
    }
    $r->log->notice(__PACKAGE__." $args->{user}: SetGID: $igid $src");
    1;
}

sub Revoke {
 my ($r,$args,$cfg) = @_;
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg='';
 my $cmdname=$lang->{Revoke} || 'Revoke';
 my $uri = $r->uri;
 my $textlen=$cfg->{textlen} || DEFAULT_TEXT_LEN;
 my $halflen=($textlen+($textlen%2))/2;
    chomp $cmdname;
    $r->no_cache(1);	# Always make sure that the data is not cached
    return SKIP_INDEX unless httphead($r,"OpenIndex $cmdname");
    header($r,$args,$cfg) unless $args->{frame}; 
    tagout('h3',$cfg,'',"OpenIndex $cmdname</h3>");
 my $gotdata;
 my $type;
 my $name;
    foreach (keys %$users) {
	if($users->{$_} eq '-') {
	 my($ruser,$rgid)=m:^(.*?)#(.*?)#:;
	    unless($gotdata) {
		$msg=$lang->{Revoked} || 'The following have been revoked:';
		tagout('p',$cfg,'',"$msg</p>");
		tagout('table',$cfg,qq~summary="$msg" cols="2"~);
		tagout('tr',$cfg);
		tagout('th',$cfg,'',' Type </th>');
		tagout('th',$cfg,'',' Name </th></tr>');
		$gotdata=1;
	    }
	    if($ruser) {
		$type='user';
		$name=$ruser;
	    }
	    if($rgid) {
		$type='gid';
		$name=getgrgid $rgid || $rgid;
	    }
	    tagout('tr',$cfg);
	    tagout('td',$cfg,''," $type </td>");
	    tagout('td',$cfg,''," $name </td></tr>");
	}
    }
    print "</table>\n" if $gotdata;
    unless($gotdata) {
	$msg=$lang->{NoUsers} || 'No user or group revoke information available';
	tagout('p',$cfg,'',"$msg</p>");
    }
    tagout('form',$cfg,qq~method="post" action="$uri" enctype="multipart/form-data"~);
    etagout('input',$cfg,qq~type="text" name="id" size=$halflen maxlength=255~);
	$msg=$lang->{EnableUID} || 'Enable User';
	chomp $msg;
    etagout('input',$cfg,qq~type="submit" name="enauid" value="$msg"~);
	$msg=$lang->{DisableUID} || 'Disable User';
	chomp $msg;
    etagout('input',$cfg,qq~type="submit" name="disuid" value="$msg"~);
	$msg=$lang->{EnableGID} || 'Enable GID';
	chomp $msg;
    etagout('input',$cfg,qq~type="submit" name="enagid" value="$msg"~);
	$msg=$lang->{DisableGID} || 'Disable GID';
	chomp $msg;
    etagout('input',$cfg,qq~type="submit" name="disgid" value="$msg"~);
    tagout('p',$cfg);
	$msg=$lang->{Return} || 'Return';
	chomp $msg;
    etagout('input',$cfg,qq~type="submit" name="return" value="$msg"~);
    etagout('input',$cfg,qq~type="hidden" name="proc" value="Revoke"~);
    hidenargs($args);
    print '</p></form>';
    etagout('hr',$cfg);
    $r->log->notice(__PACKAGE__." $args->{user}: Revoke:");
    SKIP_INDEX;
}

sub Edit {
 my ($r,$args,$cfg,$root,$src) = @_;
 my $relsrc=$src;
    $src="$root$src";
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg;
 my %info;
 my $inifile;
 my $opened;
 my $uri = $r->uri;
 my $fgid=(stat $src)[5];
 my $cmdname=$lang->{Edit} || 'Edit';
    chomp $cmdname;
    if(-e _) {
	unless(isagid($args->{gid},$fgid) || $args->{isadmin}) {
	    $msg=$lang->{SourceAccess} || 'Source access denied';
	    errmsg("${cmdname}: $msg");
	    return 0;
	}
	unless(-f _) {
	    $msg=$lang->{NotText} || 'Item is not a text file';
	    errmsg("${cmdname}: $msg");
	    return 0;
	}
	unless(-T _) {
	    $msg=$lang->{NotText} || 'Item is not a text file';
	    errmsg("${cmdname}: $msg");
	    return 0;
	}
     my $editmax=$cfg->{editmax} | DEFAULT_EDIT_MAX;
	unless(-s _ <= $editmax) {
	    $msg=$lang->{FileTooBig} || 'File size is larger than';
	    errmsg("${cmdname}: $msg $editmax");
	    return 0;
	}
	unless(open ITEM, "<$src") {
	    $msg=$lang->{FileOpen} || 'File open';
	    errmsg("${cmdname}: $msg");
	    return 0;
	}
	$opened=1;
    } else {
	return 0 unless parentok($src,$args,$cfg,$cmdname,$lang);
    }
    ($inifile=$src)=~s:^(.*/)(.+):$1\.$2\.ini:;
    if(open INIFILE,"<$inifile") {
	$info{open}=1;
	while(<INIFILE>) {
	    chomp;
	 my($key,$value)=m:(\w+)\s*=\s*(.+):;
	    $info{$key}=$value;
	}
	close INIFILE;
    }
    $r->no_cache(1);	# Always make sure that the data is not cached
    return SKIP_INDEX unless httphead($r,"OpenIndex $relsrc");
    header($r,$args,$cfg) unless $args->{frame}; 
    tagout('h3',$cfg,'',qq~$cmdname "$relsrc"</h3>~);
    if($info{status} eq 'out' && $args->{user} ne $info{user}) {
	$msg=$lang->{warning} || 'WARNING';
	$errmsg="${msg}:";
	if($args->{user}) {
	    $msg=$lang->{User} || 'User';
	    $errmsg.=qq~ $msg "$info{user}"~;
	}
	$msg=$lang->{CheckedOut} || 'Currently has checked out';
	$errmsg.=qq~ $msg "$relsrc"~;
	$r->log->warn(__PACKAGE__." Edit: $errmsg");
	tagout('h3',$cfg);
	if($cfg->{font}) {
	    tagout('font',$cfg,'',"ERROR: $errmsg</font></h3>");
	} else {
	    print qq~<font color=#FF0000> ERROR: $errmsg</font></h3>~;
	}
    }
    unless(open INIFILE, ">$inifile") {
	print STDERR "Edit() File open: $inifile\n" if $debug;
    } elsif(flock INIFILE, LOCK_EX|LOCK_NB) {
	print INIFILE "edited=$info{editedby}\ngid=$info{gid}\ntime=$info{time}\nuser=$args->{user}\nstatus=out\n";
	flock INIFILE, LOCK_UN;
	close INIFILE;
    } else {
	print STDERR "Edit() File lock: $inifile\n" if $debug;
    }
    if($info{open}) {
	$msg=$lang->{EditLast} || 'Last edit information:';
	chomp $msg;
     my $phrase=$msg;
	$msg=$lang->{User} || 'User';
	chomp $msg;
	$phrase.=" $msg";
	$phrase.="=$info{editedby}" if $info{editedby};
	$msg=$lang->{Access} || 'Access';
	chomp $msg;
	$phrase.=" $msg";
	$phrase.="=$info{gid}" if $info{gid};
	$msg=$lang->{Time} || 'Time';
	chomp $msg;
	$phrase.=" ${msg}=$info{time}";
	tagout('p',$cfg,'',"$phrase</p>");
    }
    tagout('form',$cfg,qq~method="post" action="$uri" enctype="multipart/form-data"~);
	$msg=$lang->{Undo} || 'Undo';
	chomp $msg;
    etagout('input',$cfg,qq~type="reset" name="undo" value="$msg"~);;
	$msg=$lang->{Quit} || 'Quit';
	chomp $msg;
    etagout('input',$cfg,qq~type="submiT" name="quit" value="$msg"~);
	$msg=$lang->{Save} || 'Save';
	chomp $msg;
    etagout('input',$cfg,qq~type="submIt" name="save" value="$msg"~);
    tagout('p',$cfg);
    tagout('textarea',$cfg,qq~name="text" rows="24" cols="80"~);
    if($opened) {
	while(<ITEM>) {
	    chomp;
	    print(escape_html($_));
	}
	close ITEM;
    }
    ($inifile=$relsrc)=~s:^(.*/)(.+):$1\.$2\.ini:;
    print '</textarea></p>';
    tagout('p',$cfg);
    print qq~<input type="hidden" name="proc" value="Edit" />\n~,
	qq~<input type="hidden" name="edit" value="$relsrc" />\n~,
	qq~<input type="hidden" name="saver" value="$info{user}" />\n~,
	qq~<input type="hidden" name="info" value="$inifile" />\n~;
    hidenargs($args);
    print qq~</p></form>\n~;
    if($debug && $dodump) {
	use Data::Dumper;
	print "<hr /><pre>\%info\n";
	print Dumper \%info;
	print '</pre>';
	etagout('hr',$cfg);
    }
    $r->log->notice(__PACKAGE__." $args->{user}: Edit: $src");
    SKIP_INDEX;
}

sub MkDir {
 my ($r,$args,$cfg,$root,$src,$dst) = @_;
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg;
 my $cmdname=$lang->{MkDir} || 'MkDir';
    chomp $cmdname;
    unless($dst) {
	$msg=$lang->{DestPath} || 'Bad destination path';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    $dst="$root$dst";
    if(-e $dst) {
	$msg=$lang->{DestExists} || 'Destination exists';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    if($args->{gid}) {
	my $fgid=parentok($dst,$args,$cfg,$cmdname,$lang);
	return 0 unless $fgid; 
	unless(mkdir $dst,0755) {
	    errmsg("${cmdname}: $!");
	    return 0;
	}
	chown(-1,$fgid,$dst);
    } else {
	unless(mkdir $dst,0755) {
	    errmsg("${cmdname}: $!");
	    return 0;
	}
    }
    $r->log->notice(__PACKAGE__." $args->{user}: MkDir: $dst");
    1;
}

sub Unzip {
 my ($r,$args,$cfg,$root,$src,$dst) = @_;
    $dst=~s:/$::;		# strip any trailing '/'
    use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
    use Archive::Zip::Tree;
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg;
 my $cmdname=$lang->{Unzip} || 'Unzip';
    chomp $cmdname;
    unless($dst) {
	$msg=$lang->{DestPath} || 'Bad destination path';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    $src="$root$src";
    $dst="$root$dst";
 my $fgid=(stat $src)[5];
    unless(isagid($args->{gid},$fgid) || $args->{isadmin}) {
	$msg=$lang->{SourceAccess} || 'Source access denied';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    $fgid=(stat $dst)[5];
    if(! -d _) {
	$msg=$lang->{DestDir} || 'Destination is not a directory';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    unless(isagid($args->{gid},$fgid) || $args->{isadmin}) {
	$msg=$lang->{DestAccess} || 'Destination access denied';
	errmsg("${cmdname}: $msg");
	return 0;
    }
 my $zip=Archive::Zip->new($src);
    unless ($zip) {
	$msg=$lang->{FileRead} || 'file read';
	errmsg("${cmdname}: $msg");
	return 0;
    }
 my $files=0;
 my $name;
    $dst.='/';
    for my $member ($zip->members()) {
	($name=$dst).=$member->fileName();
	if($member->isDirectory()) {
	    mkdir $name,0775;
	    chown(-1,$fgid,$name);
            next;
	}
	unless($member->extractToFileNamed($name)==AZ_OK) {
	    errmsg("$cmdname: $name");
	    return 0;
	}
	chown(-1,$fgid,$name);
	++$files;
    }
    $r->log->notice(__PACKAGE__." $args->{user}: Unzip: $src files=$files");
    1;
}

sub Move {
 my ($r,$args,$cfg,$root,$src,$dst) = @_;
 my $target=$src;
    $src="$root$src";
    $dst="$root$dst";
    use File::Copy qw(move);
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg;
 my $cmdname=$lang->{Move} || 'Move';
    chomp $cmdname;
    unless($target) {
	$msg=$lang->{DestPath} || 'Bad destination path';
	errmsg("${cmdname}: $msg");
	return 0;
    }
 my $srcgid=(stat $src)[5];
 my $src_is_dir=1 if -d _;
    unless(isagid($args->{gid},$srcgid) || $args->{isadmin}) {
	$msg=$lang->{SourceAccess} || 'Source access denied';
	errmsg("${cmdname}: $msg");
	return 0;
    }
 my $dstgid=(stat $dst)[5];
    unless(isagid($args->{gid},$dstgid) || $args->{isadmin}) {
	$msg=$lang->{DestAccess} || 'Destination access denied';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    $target=~s:^.*/(.*):$1:;
    $dst="$dst/$target" if $src_is_dir;
    unless(File::Copy::move($src, $dst)) {
	errmsg("${cmdname}: $!");
	return 0;
    }
    chown(-1,$dstgid,$dst) unless $args->{isadmin}; # admin can move others
    $r->log->notice(__PACKAGE__." $args->{user}: Move: $src->$dst");
    1;
}

sub Rename {
 my ($r,$args,$cfg,$root,$src,$dst) = @_;
 my $target=$dst;
    $src="$root$src";
    $dst="$root$dst";
    use File::Copy qw(move);
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg;
 my $fgid=(stat $src)[5];
 my $cmdname=$lang->{Rename} || 'Rename';
    chomp $cmdname;
    unless(isagid($args->{gid},$fgid) || $args->{isadmin}) {
	$msg=$lang->{SourceAccess} || 'source access denied';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    unless($target) {
	$msg=$lang->{DestPath} || 'Bad destination path';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    if(-e $dst) {
	$msg=$lang->{DestExists} || 'Destination';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    unless(File::Copy::move($src, $dst)) {
	errmsg("${cmdname}: $!");
	return 0;
    }
    $r->log->notice(__PACKAGE__." $args->{user}: Rename: $src->$dst");
    1;
}

###################################################################
# The following override is requried because File::NCopy uses glob
# which can not deal with spaces in the file names.
###################################################################
package File::NCopy;
use subs qw(glob);
sub glob {@_};
package Apache::OpenIndex;
###################################################################
sub Copy {
 my ($r,$args,$cfg,$root,$src,$dst) = @_;
 my $target=$src;
    $src="$root$src";
    $dst="$root$dst";
    use File::NCopy qw(copy);
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg;
 my $cmdname=$lang->{Copy} || 'Copy';
    chomp $cmdname;
    unless($target) {
	$msg=$lang->{DestPath} || 'Bad destination path';
	errmsg("${cmdname}: $msg");
	return 0;
    }
 my $file;
 my $isdir;
 my $fgid=(stat $dst)[5];
    $chgid=0;
    if(-e _) {
	$isdir=1 if -d _;
	unless(isagid($args->{gid},$fgid) || $args->{isadmin}) {
	    $msg=$lang->{DestAccess} || 'Destination access denied';
	    errmsg("${cmdname}: $msg");
	    return 0;
	}
	$chgid=$fgid if $args->{gid}; # global used by chgid() to set GID
    } else {
	$msg=$lang->{SourcePath} || 'Bad source path';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    unless(isagid($args->{gid},$fgid) || $args->{isadmin}) {
	$msg=$lang->{SourceAccess} || 'Source access denied';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    if(-d _) {
	unless($isdir) {
	    $msg=$lang->{DirConflict} || 'Source directory but a destination file';
	    errmsg("${cmdname}: $msg");
	    return 0;
	}
	if($dst=~m:^$src:) {
	    $msg=$lang->{CopyRecusive} || 'Recursive copy detected';
	    errmsg("${cmdname}: $msg");
	    return 0;
	}
	$file=File::NCopy->new(recursive=>1,force_write=>1,set_permission=>\&chgid);
    } else {
	$file=File::NCopy->new(force_write=>1,set_permission=>\&chgid);
    }
    unless($file->copy($src, $dst)) {
	$msg=$lang->{DestCheck} || 'Check destination path';
	errmsg("${cmdname}: $msg: $!");
	return 0;
    }
    $r->log->notice(__PACKAGE__." $args->{user}: Copy: $src->$dst");
    1;
}

sub Delete {
 my ($r,$args,$cfg,$root,$src) = @_;
    $src="$root$src";
    use File::Path qw(rmtree);
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg;
 my $fgid=(stat $src)[5];
 my $cmdname=$lang->{Delete} || 'Delete';
    chomp $cmdname;
    unless(-e _) {
	$msg=$lang->{SourcePath} || 'Bad source path';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    unless(isagid($args->{gid},$fgid) || $args->{isadmin}) {
	$msg=$lang->{SourceAccess} || 'Source access denied';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    if(-d _) {
	unless(File::Path::rmtree($src)) {
	    errmsg("${cmdname}: $!");
	    return 0;
	}
    } else {
	unless(unlink($src)) {
	    errmsg("${cmdname}: $!");
	    return 0;
	}
    }
    $r->log->notice(__PACKAGE__." $args->{user}: Delete: $src");
    1;
}

sub Upload {
 my ($r,$args,$cfg,$root,$src,$dst) = @_;
 my $upload=$r->upload;
 my $sfh=$upload->fh;
 my $bytes=0;
 my $size=0;
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg;
 my $cmdname=$lang->{Upload} || 'Upload';
    chomp $cmdname;
    $src=~s:.*[\\/]::o; # strip off the UNIX or DOS filename
    $dst="$root$dst$src";
    unless($sfh) {
	$msg=$lang->{internal} || 'internal';
	errmsg("${cmdname}: $msg");
	return 0;
    }
 my $fgid=parentok($dst,$args,$cfg,$cmdname,$lang);
    return 0 unless $fgid; 
    unless(open DFH, ">$dst") {
	$msg=$lang->{DestOpen} || 'Destination open';
	errmsg("${cmdname}: $msg");
	return 0;
    }
 my $buf;
    while(($size=read($sfh, $buf, 4096))) {
	unless(print DFH $buf) {
	    close DFH;
	    $msg=$lang->{write} || 'write';
	    errmsg("${cmdname}: $msg");
	    return 0;
	}
	$bytes+=$size;
    }
    $args->{bytes}+=$bytes;
    close DFH;
    chown(-1,$fgid,$dst);
    $r->log->notice(__PACKAGE__." $args->{user}: Upload: $bytes: $src->$dst");
    1;
}

sub View {
 my ($r,$args,$cfg,$root,$src,$dst) = @_;
    $src.="?frame=$args->{frame}" if($args->{frame});
    $r->log->notice(__PACKAGE__." View: $args->{user}: $src");
    $r->header_out(Location=>$src);
    return REDIRECT;
}
# End of internal menu command routines

# Start of internal proc call back routines
sub EditSave {
 my ($r,$args,$cfg,$docroot)=@_;
 my $file="$docroot$args->{edit}";
    if($args->{save}) {
     my $lang = new Apache::Language($r) if $cfg->{language};
     my $msg;
     my $exists=1 if -e $file;
     my $cmdname=$lang->{EditSave} || 'EditSave';
	chomp $cmdname;
	unless(open FILE, ">$file") {
	    $msg=$lang->{FileOpen} || 'File Open';
	    errmsg("${cmdname}: $msg");
	    return ERROR;
	} else {
	    print FILE $args->{text};
	    close FILE;
	    unless($exists) {
	     my ($parent)=$file=~m:(^.*)/.+:o;
	     my $fgid=(stat $parent)[5];
		chown(-1,$fgid,$file);
	    }
	    $r->log->notice(__PACKAGE__." $args->{user}: EditSave: $file");
	}
    }
    editini($r,$args,$file,"$docroot$args->{info}");
}

sub editini {
 my ($r,$args,$file,$inifile)=@_;
    if($args->{save} || $args->{user} eq $args->{saver}) {
	if($args->{save}) {
	    unless(open INIFILE, ">$inifile") {
		errmsg("Edit: Lock File write open");
		$args->{error}=1;
	    } else {
		unless(flock INIFILE, LOCK_EX|LOCK_NB) {
		    errmsg("Edit: Couldn't lock file.  Try again");
		    $args->{error}=1;
		} else {
		 my $fgid=(stat $file)[5];
		    $fgid=getgrgid $fgid || $fgid;
		    print INIFILE "editedby=$args->{user}\ngid=$fgid\ntime=",scalar localtime,"\nstatus=in\n";
		}
	    }
	} else {
	    unless(open INIFILE, ">>$inifile") {
		errmsg("Edit: Lock File append open");
		$args->{error}=1;
	    } else {
		unless(flock INIFILE, LOCK_EX|LOCK_NB) {
		    errmsg("Edit: Couldn't lock file.  Try again");
		    $args->{error}=1;
		} else {
		    print INIFILE "status=in\n";
		}
	    }
	}
	flock INIFILE,LOCK_UN;
	close INIFILE;
	delete $args->{text};
    }
    1;
}

sub Revokem {
 my ($r,$args,$cfg,$docroot) = @_;
    return 0 if $args->{return};
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg='';
 my $cmdname=$lang->{Revoke} || 'Revoke';
 my $revgid=$args->{id} if $args->{enagid} || $args->{disgid};
 my $revuser=$args->{id} if $args->{enauid} || $args->{disuid};
 my $file="$docroot$args->{root}$cfg->{fakedir}".REVOKE_DIR;
       $file.=REVOKE_FILE;
    if($revgid=~m:[A-Za-z]:o) {
	$revgid=getgrnam $revgid;
    }
    if($revuser eq $args->{user} || $revgid==$cfg->{admin}) {
	$r->warn(__PACKAGE__ . " revoke self not allowed");
	errmsg("admin IDs can not be revoked");
	return 0;
    } else {
     my $result=1;
	$result=revoker($r,$args,$cfg,'user','+',$args->{id}) if $args->{enauid};
	$result=revoker($r,$args,$cfg,'user','-',$args->{id}) if $args->{disuid};
	$result=revoker($r,$args,$cfg,'gid', '+',$args->{id}) if $args->{enagid};
	$result=revoker($r,$args,$cfg,'gid', '-',$args->{id}) if $args->{disgid};
	unless($result) {
	    $r->warn(__PACKAGE__ . " Revoke: $args->{user}: $args->{id}");
	    return 0;
	} else {
	    $r->log->notice(__PACKAGE__." Revoke: $args->{user}: $args->{id}");
	}
    }
    1;
}

sub revoker {
 my ($r,$args,$cfg,$type,$action,$name)=@_;
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg;
 my $cmdname=$lang->{Revoke} || 'Revoke';
    chomp $cmdname;
    print STDERR "revoker() type=$type action=$action name=$name\n" if $debug;
    unless($name) {
	$msg=$lang->{RevokeName} || 'No ID number or name provided';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    $name= lc $name;
 my $docroot=$r->document_root;
 my $path="$docroot$args->{root}$cfg->{fakedir}".REVOKE_DIR;
    unless(-e $path) {
	chmod 0750,$path;	# Attempt to create revoke dir
	unless(mkdir $path,0750) {		# If it does not exist
	    $msg=$lang->{create} || 'Can\'t create path';
	    $msg.=" $args->{root}$cfg->{fakedir}".REVOKE_DIR;
	    $msg.=" $!";
	    errmsg($msg);
	    chmod 0550,$path;
	    return 0;
	}
	chmod 0550,$path;
    }
 my $file=$path.REVOKE_FILE;
    if(-e "$file.new") {	# gross file locking, should never happen
	$r->warn(__PACKAGE__ . " revoke file locked: ${file}.new exists");
	$msg=$lang->{FileLocked} || 'File locked';
	errmsg("${cmdname}: $msg");
	return 0;
    }
 my $server=$r->get_server_name;
 my $key;
 my $val;
    if($name=~m:[^0-9]:o) { # if not a number get the GID for the name
	$key=getgrnam $name || $name;
    }
    $key="#${key}#${server}#$args->{root}" if $type eq 'gid';
    $key="${key}##${server}#$args->{root}" if $type eq 'user';
    if($action eq '-') {	# '-' implies disable user/group
	return 1 if $users->{$key} eq '-';	# return if already disabled
	$users->{$key}='-';
	if(open REVOKE, ">>$file") {	# append name to the revoke file
	    print REVOKE "$type=$name\n";
	    close REVOKE;
	} else {
	    $r->warn(__PACKAGE__ . " revoke file append open");
	    $msg=$lang->{FileOpen} || 'File open';
	    errmsg("${cmdname}: $msg");
	    return 0;
	}
    } elsif($action eq '+') {		# '+' implies enable user/group
	return 1 if $users->{$key} eq '+'; # return if already enabled
	$users->{$key}='+';
	if(open REVOKE, "<$file") {	# remove name from revoke file 
	    if(open NEWREVOKE, ">$file.new") {
		while(<REVOKE>) {	# copy all but current enabled record
		    ($key,$val)=m:(\w+)\s*=\s*(\w+):;
		    print NEWREVOKE "$key=$val\n" if $key && !($key eq $type && $val eq $name);
		}
		close NEWREVOKE;
		close REVOKE;
		unlink $file;
		rename "$file.new", $file;
	    } else {
		$r->warn(__PACKAGE__ . " revoke file write open");
		$msg=$lang->{FileOpen} || 'File open';
		errmsg("${cmdname}: $msg");
		close REVOKE;
		return 0;
	    }
	} else {
	    $r->warn(__PACKAGE__ . " revoke file read open");
	    $msg=$lang->{FileOpen} || 'File open';
	    errmsg("${cmdname}: $msg");
	    return 0;
	}
    }
    1;
}
# End of internal call back routines

sub tagout {
 my ($tag,$cfg,$prefix,$suffix,$empty)=@_;
 my $conf=$cfg->{htmltags}{$tag};
    print "<$tag";
    print " $prefix" if $prefix;
    print " $conf" if $conf;
    print $empty?' />':'>';
    print "$suffix" if $suffix;
    print "\n";
}

sub etagout {
 my ($tag,$cfg,$prefix,$suffix)=@_;
 tagout($tag,$cfg,$prefix,$suffix,1);
}

sub hidenargs {
 my ($args) =@_;
    print qq~<input type="hidden" name="dst" value="$args->{dst}" />\n~ if $args->{dst};
    print qq~<input type="hidden" name="src" value="$args->{src}" />\n~ if $args->{src};
    print qq~<input type="hidden" name="group" value="$args->{group}" />\n~ if $args->{group};
    print qq~<input type="hidden" name="frame" value="$args->{frame}" />\n~ if $args->{frame};
}

sub substrcnt {
 my ($str,$substr,$offset) =@_;
 my ($cnt,$ndx);
 my $sublen=length $substr;
    for($cnt=0; ($ndx=index($str,$substr,$offset))>=0; $cnt++) {
	$offset=$ndx+$sublen;
    }
    $cnt;
}

sub parentok {
 my ($str,$args,$cfg,$cmd,$lang)=@_;
 my ($parent)=$str=~m:(^.*)/.+:o;
 my $fgid=(stat $parent)[5];
    unless(isagid($args->{gid},$fgid) || $args->{isadmin}) {
	my $msg=$lang->{ParentAccess} || 'Parent access denied';
	errmsg("${cmd}: $msg");
	return 0;	# root(0) gid is always not allowed
    }
    $fgid;
}


sub dirbound {
 my ($dir, $root)=@_;
 my $level=substrcnt($root,'/');
 my $cnt=0;
    while($dir=~m:/:go) {
	$cnt++;
	if($dir=~m:\G\.\.(/|$):o) {
	    return 0 if --$cnt<$level;
	    $cnt-- if m:\G\.\./:o;
	}
    }
    1;
}

sub getcmd {
 my ($c, $a)=@_;
    foreach (@$c) {
	return $_ if $a->{$_};
    }
    '';
}

sub isagid {
 my ($gid,$check)=@_;
    return 0 unless $check;		# never allow a root(0) gid
    return 1 unless $gid && @$gid;	# always a member if no gid 
    for(my $cnt=@$gid-1;$cnt>=0;$cnt--) {
	return 1 if $gid->[$cnt]==$check;
    }
    0;
}

sub chgid {
    chown(-1,$chgid,$_[1]) if $chgid;
    1;
}

sub outfile {
 my ($file,$suppress) = @_;
 my $buf;
    return 0 unless(open OFILE, "<$file");
    while(<OFILE>) {
	if($suppress) {
	    s:</?html.*>\s*::oi if m:</?html[\s>]:oi;
	    s:</?body.*>\s*::oi if m:</?body[\s>]:oi;
	    if(m:<head[\s>]:oi) {
		do {
		    if(m:</head>:oi) {
			s:.*</head>\s*::oi;
			goto SHOW;
		    }
		} while(<OFILE>);
	    }
	}
    SHOW: print;
    }
    close OFILE;
    1;
}

sub errmsg {
    return $errmsg unless defined $_[0];
    ($errmsg)=shift;
    chomp $errmsg;
}

sub getrevoked {
 my ($r,$args,$file)=@_;
 my $server=$r->get_server_name;
 my $key;
    print STDERR "getrevoked() file=$file\n" if $debug;
    if(open REVOKED, $file) {
	while(<REVOKED>) {
	 my ($type,$val)=m:(\w+)=(\w+):;
	    if($type eq 'gid' && $val=~m:[^0-9]:o) {
		$val=getgrnam $val || $val;
	    }
	    $val = lc $val;
	    $key=$type eq 'user'?"$val#":'#';
	    $key.=$type eq 'gid' ?"$val#":'#';
	    $key.="${server}#$args->{root}";
	    print STDERR "getrevoked() found $type=$val key=$key\n" if $debug;
	    $users->{"$key"}='-';
	}
	close REVOKED;
    } else {
	print STDERR "getrevoked() open FAILED: $file\n" if $debug;
    }
}

sub place_doc {
 my ($r,$cfg,$docs) = @_;
 my $uri = $r->uri;
 my $ofile;
 my $subr;
 my $ishtml;
    $uri=~s:/$cfg->{fakedir}/:/: if $cfg->{dir};
    foreach my $doc (@{$cfg->{$docs}}) {
	print STDERR "place_doc() $docs: doc=$doc " if $debug;
	$ishtml=0;
	if($doc=~m:^/:o) {
	    $subr = $r->lookup_uri("$doc");
	    if(stat $subr->finfo) {
		$ofile=$subr->filename();
		$ishtml=1 if $subr->content_type() eq 'text/html';
		print '<pre>' unless $ishtml;
		print STDERR "$ofile\n" if $debug;
		outfile($ofile,$cfg->{options} & SUPPRESS_PREAMBLE);
		unless($ishtml) {
		    print '</pre>';
		    etagout('hr',$cfg);
		}
		next;
	    }
	} else {
	    $subr = $r->lookup_uri("${uri}${doc}");
	    if(stat $subr->finfo) {
		$ofile=$subr->filename();
		$ishtml=1 if $subr->content_type() eq 'text/html';
		print '<pre>' unless $ishtml;
		print STDERR "$ofile\n" if $debug;
		outfile($ofile,$cfg->{options} & SUPPRESS_PREAMBLE);
		unless($ishtml) {
		    print '</pre>';
		    etagout('hr',$cfg);
		}
		next;
	    }
	}
	print STDERR "<MISSING> $doc\n" if $debug;
    }
}

sub userinfo {
 my ($r,$args,$cfg) = @_;
    $cfg = Apache::ModuleConfig->get($r) unless $cfg;
 my $gidenv = $cfg->{gidenv};
    if($r->auth_type eq 'Basic') {
	$args->{user}=$r->user;
    } elsif($cfg->{userenv}) {
	$args->{user}=$r->subprocess_env($cfg->{userenv});
    }
    $args->{gid}=[split /[,:;]|$;/,$r->subprocess_env($gidenv)];
    if($debug) {
	print STDERR "userinfo() user=$args->{user} admin=$cfg->{admin} gidenv=$gidenv\n";
	if($args->{gid}) {
	    print STDERR " gid=";
	    for(my $cnt=@{$args->{gid}}-1;$cnt>=0;$cnt--) {
		print STDERR "$args->{gid}[$cnt],";
	    }
	    print STDERR "\n";
	}
    }
    if($args->{gid}) {
	for(my $cnt=@{$args->{gid}}-1;$cnt>=0; $cnt--) {
	    if($args->{gid}[$cnt]=~m:[^0-9]:o) {	# if not a number, look-up the group name
		$args->{gidname}[$cnt]=$args->{gid}[$cnt];
		$args->{gid}[$cnt]=getgrnam $args->{gidname}[$cnt];
	    } else {
		$args->{gidname}[$cnt]=getgrgid $args->{gid}[$cnt] || $args->{gid}[$cnt];
	    }
	}
    }
    $args->{isadmin}=$args->{gid} && isagid($args->{gid},$cfg->{admin});
}

sub usercheck {
 my ($r,$args,$cfg) = @_;
#
# A lite duty $users hash cache is used in order to reduce file IO
# The cache is not shared between children, so each has initialize it.
# A '-' indicated a revoke and a '+' indicated not revoked.
# This way admin users can revoke users from within the browser.
#
    if($cfg->{revoke} && $args->{gid}) {  # Only check if there is a revoke option and a gid
     my $server=$r->get_server_name;
     my $docroot=$r->document_root;
	unless($users->{"##${server}#$args->{root}"} eq '~') {	# Check if initialized
	    getrevoked($r,$args,"$docroot$args->{root}$cfg->{fakedir}".REVOKE_DIR.REVOKE_FILE);
	    $users->{"##${server}#$args->{root}"}='~';		# mark cache as initialized
	}
	if($users->{"$args->{user}##$server#$args->{root}"} eq '-') {
	    return 0;	# user has been revoked in the past
	} else {
	    for(my $cnt=@{$args->{gid}}-1;$cnt>=0;$cnt--) {  # check each user's gid
	     my $key="#$args->{gid}[$cnt]#$server#$args->{root}";
		if($users->{$key} eq '-') {
		    splice @{$args->{gid}},$cnt,1;	# remove each revoked gid
		    splice @{$args->{gidname}},$cnt,1;	# remove each revoked gid
		    return 0 unless @{$args->{gid}};	# if all gids are revoked
		}
	    }
	}
    }
    1;
}

sub handler {
 my($r)=shift;
 my %args;
 my @items;
 my $filename = $r->filename . $r->path_info;
 my $file;
 my $retval;
 my $oipath;
 my $uri = $r->uri;
 my $subr;
 my $tail;
 my $mode=0;
 my $cfg = Apache::ModuleConfig->get($r);
 my $docroot=$r->document_root;
 my $postmax=$cfg->{postmax}|DEFAULT_POST_MAX;
    $r = Apache::Request->new($r, POST_MAX=>$postmax);
    $cfg->{fakedir}=DEFAULT_FAKE_DIR unless $cfg->{fakedir};
 my $fakedir=$cfg->{fakedir};
    $cfg->{markdir}=DEFAULT_MARK_DIR unless $cfg->{markdir};
 my $markdir=$cfg->{markdir};
    ($args{root})=$uri=~m:(^.*/)$fakedir/:;
    $args{root}=$cfg->{root} unless $args{root};
    $debug=$cfg->{debug};
    print STDERR "===== ", __PACKAGE__, " DEBUG START =====\nuri=$uri " if $debug;
    $filename .= '/' unless $filename =~ m:/$:o;
    if($filename=~m:/$fakedir/:) {	# could be fakedir or markdir
	($oipath)=$filename=~m:(^.*)/$fakedir/:;	# path before fakedir
	unless(-d "$oipath/$fakedir") {			# make sure that the fakedir exists
	    $r->log_reason( __PACKAGE__ . " Path not found: $oipath/$fakedir");
	    print STDERR "FORBIDDEN\n===== ", __PACKAGE__, " DEBUG STOP  =====\n" if $debug;
	    return FORBIDDEN;
	}
	if($filename=~m:/$fakedir/$markdir/:) {		# ckeck for a URI_MARK
	    ($tail)=$filename=~m:$fakedir/$markdir/(.*/?)$:;
	    if($cfg->{markroot}) {
		$oipath=$cfg->{markroot};
		$filename=~s:^.*/$fakedir/$markdir/:$oipath:;
		($args{dir})=$filename=~m:(.*/).*$:o;	# strip any filename
	    } else {
		($args{dir})=$uri=~m:(.*/).*$:o;	# strip any filename
	    }
	    $mode|=URI_MARK;
	} else {
	    ($tail)=$filename=~m:$fakedir/(.*/?)$:;
	    $mode|=URI_ROOT;
	    $filename="$oipath/$tail";	# the actural filename
	    ($args{dir})=$uri=~m:(.*/).*$:o;	# strip any filename
	}
	print STDERR "filename=$filename oipath=$oipath fake=$fakedir mark=$markdir\n" if $debug;
    }
    $filename=~s:/$::;							# Remove any trailing '/'
    $subr = $r->lookup_file("$filename");
    stat $subr->finfo;
    unless(-e _) {
	$r->log_reason( __PACKAGE__ . " Path not found: ");
	print STDERR "FORBIDDEN $filename\n===== ", __PACKAGE__, " DEBUG STOP  =====\n" if $debug;
	return FORBIDDEN;
    } elsif(-d _) {
	unless ($r->path_info || $tail) { #Issue an external redirect if the dir isn't tailed with a '/'
	    $r->header_out(Location=>"$uri/");
	    $nRedir++;
	    print STDERR "REDIRECT\n===== ", __PACKAGE__, " DEBUG STOP  =====\n" if $debug;
	    return REDIRECT;
	}
	$filename .= '/' unless $filename =~ m:/$:o;
	$mode|=URI_DIR if $mode;
	$args{dir}=$uri unless $mode;
    } else {
	($file)=$filename =~ m:.*/(.+)$:o;	# filename clicked
	if($mode) {
	    $mode|=URI_FILE;			# not a directory, but a file
	    $filename =~ s:(.+/).*:$1:;		# the directory clicked
	} else {
	    ($args{dir})=$uri=~m:(.*/):o  unless $mode;
	}
    }
    print STDERR "type=$mode\n" if $debug;
    $r->filename("$filename");
    unless($oipath || ($r->content_type && $r->content_type eq DIR_MAGIC_TYPE)) {
	print STDERR "DECLINED\n===== ", __PACKAGE__, " DEBUG STOP  =====\n" if $debug;
	return DECLINED;
    }
    $args{mode}=$mode;
    if($r->allow_options & OPT_INDEXES || $mode) {
	$args{frame}='';
     my @params = $r->param;
	foreach my $arg (@params) {
	 my @values=$r->param($arg);	# The name params space will not clash.
	    foreach my $value (@values) {
		if($value eq 'on') {	# All select item checkboxes are set to on.
		    push @items, $arg;
		} else {
		    $args{$arg}=$value;
		}
	    }
	}
	$args{items}=\@items;
	if($mode) {	# Set if managing files.
	    if($args{src}) {
		$args{src}=~tr{ .a-zA-Z0-9~!@#$^&+i_\-/}{}cd; # scrub names
		push @items,$args{src};
	    }
	    $args{child}='' if $mode & URI_FILE;
	    $args{file}=$file;
	    $dodump=$debug unless $mode;	# Turn on debug dump for AutoIndex mode
	    userinfo($r,\%args,$cfg);
	    unless(usercheck($r,\%args,$cfg)) {
		$r->log_reason( __PACKAGE__ . " REVOKED: user=$args{user}");
		return FORBIDDEN;
	    }
	    if($cfg->{usersite} && "$cfg->{usersite}/$args{user}/" ne $args{root}) {
		$r->log_reason( __PACKAGE__ . " USERSITE: user=$args{user} site=$cfg->{usersite} root=$args{root}");
		return FORBIDDEN;
	    }
	    if($cfg->{always}) {
		$retval=$cfg->{always}->($r,\%args,$cfg,$uri);
		if($retval>99) {
		    $nRedir++;
		    print STDERR "ALWAYS $retval\n===== ", __PACKAGE__, " DEBUG STOP  =====\n" if $debug;
		    return $retval;
		} 
	    }
	    if($args{proc}) {
		$retval=0;
	     my $lang = new Apache::Language($r) if $cfg->{language};
		unless($args{dir}) {	# Fixup dir if missing
		    $args{dir}="$args{root}$cfg->{fakedir}/";
		    $args{dir}.="$cfg->{markdir}/" if $mode & URI_MARK;
		}
# check if call back routine exists
		unless($commands{$args{proc}}{back}) {
		 my $msg=$lang->{command} || 'UNKNOWN: command';
		    errmsg("$args{proc}: $msg");
		    $retval=ERROR;
		    $r->log->error(__PACKAGE__." internal error: NULL back routine");
		}
# check if admin is required
		if($commands{$args{proc}}{admin} && !$args{isadmin}) {
		 my $msg=$lang->{AdminAccess} || 'Admin access denied';
		    errmsg("$args{proc}: $msg");
		    $r->log->error(__PACKAGE__." Admin access denied");
		    $retval=ERROR;
		}
		$retval=$commands{$args{proc}}{back}->($r,\%args,$cfg,$docroot) unless $retval;
		if($retval>99) {
		    $nRedir++;
		    print STDERR "proc($args{proc}) $retval\n===== ", __PACKAGE__, " DEBUG STOP  =====\n" if $debug;
		    return  $retval;
		} 
		$args{error}=1 if $retval==ERROR;
	    }
	}
	unless($retval==SKIP_INDEX) {
	 my $frames=$cfg->{frames};
	 my $frame=$args{frame};
	 my $oidir;
	    if($mode) {
		$args{dir}=~m:(.*)$cfg->{fakedir}/(.*):;
		$oidir="$1$2";		# snip out the fakedir
	    } else {
		$oidir=$r->uri;
	    }
	    $retval=httphead($r,"OpenIndex $oidir");
	    if($frames && $frame ne 'none') {
		unless($frame) {
		    $retval=frames($r,\%args,$cfg);
		} else {
		    $retval=header($r,\%args,$cfg) if $retval && $frame eq 'head';
		    $retval=oindex($r,\%args,$filename,$mode,$cfg)
			if $retval && $frame eq 'main' && ($mode & URI_MARK);
		    $retval=oindex($r,\%args,$filename,$mode,$cfg)
			if $retval && $frame eq 'main' && !($mode & URI_MARK);
		    $retval=footer($r,$cfg) if $retval && $frame eq 'foot';
		}
		if($retval) {
		    $retval=OK;
		} else {
		    $retval=FORBIDDEN;
		}
	    } else {
		$retval=header($r,\%args,$cfg,!$mode) if $retval;
		$retval=oindex($r,\%args,$filename,$mode,$cfg) if $retval && ($mode & URI_MARK);
		$retval=oindex($r,\%args,$filename,$mode,$cfg) if $retval && !($mode & URI_MARK);
		$retval=footer($r,$cfg) if $retval;
		if($retval) {
		    $retval=OK;
		} else {
		    $retval=FORBIDDEN;
		}
	    }
	} else {
	    $retval=OK;
	}
	if($debug && $dodump) {
	    use Data::Dumper;
	    print "<hr /><pre>\n\$cfg\n";
	    print Dumper $cfg;
	    print "</pre><hr /><pre>\%args\n";
	    print Dumper \%args;
	    print "</pre><hr /><pre>Global variables\n";
	    if($cfg->{revoke}) {
		print "\$users\n";
		print Dumper $users;
	    }
	    print "\$commands\n";
	    print Dumper %commands;
	    print "\$iconfig\n";
	    print Dumper $iconfig;
	    print "</pre><hr /><pre>Environment variables\n";
	    print Dumper $r->subprocess_env();
	    print "</pre><hr />\n";
	}
	print "</body>" unless $args{frame};
	print "</html>\n";
	print STDERR "retval=$retval\n===== ", __PACKAGE__, " DEBUG STOP  =====\n" if $debug;
    } else {
	$retval=FORBIDDEN;
	$r->log_reason( __PACKAGE__ . " Directory index forbidden by rule", $r->uri . " (" . $r->filename . ")");
	print STDERR "FORBIDDEN\n===== ", __PACKAGE__, " DEBUG STOP  =====\n" if $debug;
    }
    $retval;
}

#Configuration Stuff
sub rmarray {
 my ($array, $element) = @_;
    for(my $ndx; $ndx<@$array; $ndx++) {
	return splice @$array,$ndx,1 if lc @$array[$ndx] eq lc $element;
    }
}

sub OpenIndexOptions($$$;*) {
 my ($cfg, $parms, $directive, $cfg_fh) = @_;
 my @args=split /[\s=>,]+/, $directive;
    warn "OpenIndexOptions $directive: No argument" unless $args[0];
 my $lcarg = lc shift @args;
 my ($action)=$args[0]=~m:^([+-]):o;
    $args[0]=~s:^[+-]::o if $action;
 my $arg=$args[0];
    if($lcarg eq 'menu') {
	splice @{$cfg->{menu}} unless $action; # removes all items
	foreach(@args) {
	    if($action eq '-') {
		rmarray \@{$cfg->{menu}},$_;
	    } else {
		if($commands{$_}) { # only add commands that exist
		    unshift @{$cfg->{menu}},$_;
		} else {
		    warn "OpenIndexOptions: MENU:  $_ does not exist! ";
		}
	    }
	}
    } elsif($lcarg eq 'admnmenu') {
	splice @{$cfg->{admnmenu}} unless $action; # to removes all items
	foreach(@args) {
	    if($action eq '-') {
		rmarray \@{$cfg->{admnmenu}},$_;
	    } else {
		if($commands{$_}) {
		    unshift @{$cfg->{admnmenu}},$_;
		} else {
		    warn "OpenIndexOptions: ADMNMENU:  $_ does not exist! ";
		}
	    }
	}
    } elsif($lcarg eq 'import') {
	required($arg); # 1st arg is the module name
     my $r=$args[1]; # 2nd arg is menu command
	if($r) {
	    for(my $ndx=2;$ndx<@args;$ndx=$ndx+2) {
		$commands{$r}{$args[$ndx]}=$args[$ndx+1]; 
	    }
	    no strict 'refs';
	    $commands{$r}{cmd}=\&$arg; # The menu command name and subroutine
	    $commands{$r}{before}=\&{$commands{$r}{before}} if $commands{$r}{before};
	    $commands{$r}{after}=\&{$commands{$r}{after}} if $commands{$r}{after};
	    $commands{$r}{back}=\&{$commands{$r}{back}} if $commands{$r}{back};
	    use strict 'refs';
# A lot can go wrong, but we do check that the routines are defined.
	 my $nodef='before' unless defined &{$commands{$r}{before}};
	       $nodef='after'  unless defined &{$commands{$r}{after}};
	       $nodef='back'   unless defined &{$commands{$r}{back}};
	       $nodef='cmd'    unless defined &{$commands{$r}{cmd}};
	    if($nodef) {
		delete $commands{$r}; # This is bad, so throw it away!
		warn "OpenIndexOptions: IMPORT: routine $nodef not defined! ";
	    }
	} else {
	    warn "OpenIndexOptions: IMPORT: no command! ";
	}
    } elsif($lcarg eq 'always') { # a command always called before all pages
	required($arg); # 1st arg is the module name
     my $r=$args[1]; # 2nd arg is the always command
	if($r) {
	    no strict 'refs';
	    $cfg->{always}=\&$r;
	    use strict 'refs';
	    for(my $ndx=2;$ndx<@args;$ndx=$ndx+2) {
		$commands{always}{$args[$ndx]}=$args[$ndx+1]; 
	    }
	    unless(defined &{$cfg->{always}}) {
		delete $commands{always}; # This is bad, so throw it all away!
		delete $cfg->{always};
		warn "OpenIndexOptions: ALWAYS: routine not defined! ";
	    }
	} else {
	    warn "OpenIndexOptions: ALWAYS: no command! ";
	}
    } elsif ($lcarg eq 'userdir') {
	($cfg->{userdir})=$directive=~m:\w+\s+(.*):o;
    } elsif ($lcarg eq 'textlen') {
	if($arg<8) {
	    warn "Bad OpenIndexOptions $directive directive<8";
	    $cfg->{textlen} = DEFAULT_TEXT_LEN;
	} else {
	    $cfg->{textlen} = $arg;
	}
    } elsif ($lcarg eq 'postmax') {
	if($arg<128000) {
	    warn "Bad OpenIndexOptions $directive directive<128000";
	    $cfg->{postmax} = DEFAULT_POST_MAX;
	} else {
	    $cfg->{postmax} = $arg;
	}
    } elsif ($lcarg eq 'editmax') {
	if($arg<1024) {
	    warn "Bad OpenIndexOptions $directive directive<1024";
	    $cfg->{postmax} = DEFAULT_EDIT_MAX;
	} else {
	    $cfg->{postmax} = $arg;
	}
    } elsif ($lcarg eq 'admin') {
	if($arg=~m:[^0-9]:o) {
	    $arg=getgrnam $arg;
	}
	$cfg->{admin}=$arg;
    } elsif ($lcarg eq 'umask') {
	if($arg>0777 || $arg<0001) {
	    warn "Bad OpenIndexOptions $directive directive";
	} else {
	    $cfg->{umask} = $arg;
	}
    } elsif ($lcarg eq 'help') {
	$cfg->{help} = $arg;
    } elsif ($lcarg eq 'debug') {
	$arg = lc $arg;
	if($arg eq '1' || $arg eq 'yes' || $arg eq 'on') {
	    $cfg->{debug} = 1;
	} else {
	    $cfg->{debug} = 0;
	}
    } elsif ($lcarg eq 'language') {
	$arg = lc $arg;
	if($arg eq '1' || $arg eq 'yes' || $arg eq 'on') {
	    $cfg->{language} = 1;
	} else {
	    $cfg->{language} = 0;
	}
    } elsif ($lcarg eq 'frames') {
	$arg = lc $arg;
	if($arg eq '1' || $arg eq 'yes' || $arg eq 'on') {
	    $cfg->{frames} = 1;
	} else {
	    $cfg->{frames} = 0;
	}
    } elsif ($lcarg eq 'mark') {		# Force mark directory
	$arg = lc $arg;
	if($arg eq '1' || $arg eq 'yes' || $arg eq 'on') {
	    $cfg->{mark} = 1;
	} else {
	    $cfg->{mark} = 0;
	}
    } elsif ($lcarg eq 'revoke') {
	$arg = lc $arg;
	if($arg eq '1' || $arg eq 'yes' || $arg eq 'on') {
	    $cfg->{revoke} = 1;
	} else {
	    $cfg->{revoke} = 0;
	}
    } elsif ($lcarg eq 'nocache') {
	$arg = lc $arg;
	if($arg eq '1' || $arg eq 'yes' || $arg eq 'on') {
	    $cfg->{nocache} = 1;
	} else {
	    $cfg->{nocache} = 0;
	}
    } elsif ($lcarg eq 'notitle') {
	$arg = lc $arg;
	if($arg eq '1' || $arg eq 'yes' || $arg eq 'on') {
	    $cfg->{notitle} = 1;
	} else {
	    $cfg->{notitle} = 0;
	}
    } elsif ($lcarg eq 'userenv') {
	$cfg->{userenv} = $arg;
    } elsif ($lcarg eq 'gidenv') {
	$cfg->{gidenv} = $arg;
    } elsif ($lcarg eq 'root') {
	$cfg->{root} = $arg;
    } else {
	$arg=~s:/$::o; # Remove any trailing '/'
	if($lcarg eq 'fakedir') {
	    $cfg->{fakedir}=$arg;
	} elsif ($lcarg eq 'markdir') {
	    $cfg->{markdir} = $arg;
	} elsif ($lcarg eq 'markroot') {
	    $arg.='/' unless $arg =~ m:/$:o;
	    unless($arg=~m:^/:o) {
		warn "Missing initial '/' in MarkRoot";
	    } else {
		$cfg->{markroot} = $arg;
	    }
	} elsif ($lcarg eq 'usersite') {
	    ($cfg->{usersite})=$directive=~m:\w+\s+(.*):o;
	} else {
	    warn "Unknown OpenIndexOptions $directive directive";
	}
    }
}

sub required {
 my ($module)=@_;
 my ($p,$m)=$module=~m/(.*)::(.*)/o;
    unless($p && $m) {
	$p=__PACKAGE__;
	$m=$module;
    }
    eval "require ${p}::${m}";
    return $m;
}

sub IndexOptions($$$;*) {
 my ($cfg, $parms, $directives, $cfg_fh) = @_;
    foreach (split /[\s,]+/, $directives) {
     my $option;
    (my $action, $_) = (lc $_) =~ /(\+|-)?(.*)/;
	if (/^none$/) {
	    die "Cannot combine '+' or '-' with 'None' keyword" if $action;
	    $cfg->{options} = NO_OPTIONS;
	    $cfg->{options_add} = 0;
	    $cfg->{options_del} = 0;
	} elsif (/^iconheight(=(\d*$|\*$)?)?(.*)$/) {
	    warn "Bad IndexOption $_ directive syntax" if ($3 || ($1 && !$2));
	    if ($2) {
		die "Cannot combine '+' or '-' with IconHeight" if $action;
		$cfg->{icon_height} = $2;
	    } else 	{
		if ($action eq '-') {
		    $cfg->{icon_height} = DEFAULT_ICON_HEIGHT;
		} else {
		    $cfg->{icon_height} = 0;
		}
	    }
	} elsif (/^iconwidth(=(\d*$|\*$)?)?(.*)$/) {
	    warn "Bad IndexOption $_ directive syntax" if ($3 || ($1 && !$2));
	    if ($2) {
		die "Cannot combine '+' or '-' with IconWidth" if $action;
		$cfg->{icon_width} = $2;
	    } else {
		if ($action eq '-') {
		    $cfg->{icon_width} = DEFAULT_ICON_WIDTH;
		} else {
		    $cfg->{icon_width} = 0;
		}
	    }
	} elsif (/^namewidth(=(\d*$|\*$)?)?(.*)$/) {
	    warn "Bad IndexOption $_ directive syntax" if ($3 || ($1 && !$2));
	    if ($2) {
		die "Cannot combine '+' or '-' with NameWidth" if $action;
		$cfg->{name_width} = $2;
	    } else {
		die "NameWidth with no value can't be used with '+'" if ($action ne '-');
		$cfg->{name_width} = 0;
	    }
	} else {
	    foreach my $directive (keys %GenericDirectives) {
		if(/^$directive$/) {
		    $option = $GenericDirectives{$directive};
		    last;                
		}
	    }
	    warn "IndexOptions unknown/unsupported directive $_" unless $option;
	}
	if(!$action) {
	    $cfg->{options} |= $option;
	    $cfg->{options_add} = 0;
	    $cfg->{options_del} = 0;
	} elsif($action eq '+') {
	    $cfg->{options_add} |= $option;
	    $cfg->{options_del} &= ~$option;
	} elsif($action eq '-') {
	    $cfg->{options_del} |= $option;
	    $cfg->{options_add} &= ~$option;
	}
	if(($cfg->{options} & NO_OPTIONS) && ($cfg->{options} & ~NO_OPTIONS)) {
	    die "Cannot combine other IndexOptions keywords with 'None'";
	}
    }
    return DECLINE_CMD if Apache->module('mod_autoindex.c');
}

sub DIR_CREATE {
 my $class=shift;
 my $self=$class->new;
 my $menu=DEFAULT_MENU;
    $self->{menu}=[@$menu];
    $menu=DEFAULT_ADMN_MENU;
    $self->{admnmenu}=[@$menu];
    $self->{userdir}='';
    $self->{usersite}='';
    $self->{icon_width}=DEFAULT_ICON_WIDTH;
    $self->{icon_height}=DEFAULT_ICON_HEIGHT;
    $self->{name_width}=DEFAULT_NAME_WIDTH;
    $self->{default_order}=DEFAULT_ORDER;
    $self->{fakedir}=DEFAULT_FAKE_DIR;
    $self->{markdir}=DEFAULT_MARK_DIR;
    $self->{markroot}='';
    $self->{root}="";
    $self->{admin}=0;
    $self->{umask}=0;
    $self->{frames}=0;
    $self->{mark}=0;
    $self->{revoke}=0;
    $self->{notitle}=0;
    $self->{nocache}=0;
    $self->{debug}=0;
    $self->{textlen}=DEFAULT_TEXT_LEN;
    $self->{postmax}=DEFAULT_POST_MAX;
    $self->{help}=DEFAULT_HELP_URL;
    $self->{language}=0;
    $self->{gidenv}= "";
    $self->{userenv}= "";
    $self->{headuri}="";
    $self->{footuri}="";
    $self->{ignore}=[];
    $self->{header}=[];
    $self->{readme}=[];
    $self->{indexfile}=[];
    $self->{desc}={};
    $self->{htmltags}={};
    $self->{htmltext}={};
    $self->{options}=0;
    $self->{options_add}=0;
    $self->{options_del}=0;
    return $self;
}

sub DIR_MERGE {
 my ($parent, $current) = @_;
 my %new;
    $new{default_order} = $current->{default_order} || $parent->{default_order};
    $new{options_add} = 0;
    $new{options_del} = 0;
    if($current->{options} & NO_OPTIONS) { # None=override all
	$new{options} = NO_OPTIONS;
    } else {
	if ($current->{options} == 0) { # all incremental, so combine them with parent
	    $new{options_add} = ($parent->{options_add} | $current->{options_add}) & ~$current->{options_del};
	    $new{options_del} = ($parent->{options_del} | $current->{options_del}) ;
	    $new{options} = $parent->{options} & ~NO_OPTIONS;
	} else {			# not all incremental, so no inheritance
	    $new{options} = $current->{options};
	}
# Collect cascaded options
	$new{options} |= $new{options_add};
	$new{options} &= ~ $new{options_del};
    }
    $new{userdir}     = $current->{userdir}     || $parent->{userdir};
    $new{usersite}    = $current->{usersite}    || $parent->{usersite};
    $new{icon_height} = $current->{icon_height} || $parent->{icon_height};
    $new{icon_width}  = $current->{icon_width}  || $parent->{icon_width};
    $new{name_width}  = $current->{name_width}  || $parent->{name_width};
    $new{fakedir}     = $current->{fakedir}     || $parent->{fakedir};
    $new{markdir}     = $current->{markdir}     || $parent->{markdir};
    $new{markroot}    = $current->{markroot}    || $parent->{markroot};
    $new{frames}      = $current->{frames}      || $parent->{frames};
    $new{root}        = $current->{root}        || $parent->{root};
    $new{admin}       = $current->{admin}       || $parent->{admin};
    $new{umask}       = $current->{umask}       || $parent->{umask};
    $new{textlen}     = $current->{textlen}     || $parent->{textlen};
    $new{postmax}     = $current->{postmax}     || $parent->{postmax};
    $new{help}        = $current->{help}        || $parent->{help};
    $new{language}    = $current->{language}    || $parent->{language};
    $new{userenv}     = $current->{userenv}     || $parent->{userenv};
    $new{gidenv}      = $current->{gidenv}      || $parent->{gidenv};
    $new{mark}        = $current->{mark}        || $parent->{mark};
    $new{revoke}      = $current->{revoke}      || $parent->{revoke};
    $new{nocache}     = $current->{nocache}     || $parent->{nocache};
    $new{notitle}     = $current->{notitle}     || $parent->{notitle};
    $new{debug}       = $current->{debug}       || $parent->{debug};
    $new{menu}        = $current->{menu}        || $parent->{menu};
    $new{admnmenu}    = $current->{admnmenu}    || $parent->{admnmenu};
    $new{always}      = $current->{always}      || $parent->{always};
    $new{headuri}     = $current->{headuri}     || $parent->{headuri};
    $new{footuri}     = $current->{footuri}     || $parent->{footuri};
    $new{readme}      = [ @{$current->{readme}},   @{$parent->{readme}} ];
    $new{header}      = [ @{$current->{header}},   @{$parent->{header}} ];
    $new{readme}      = [ @{$current->{readme}},   @{$parent->{readme}} ];
    $new{ignore}      = [ @{$current->{ignore}},   @{$parent->{ignore}} ];
    $new{indexfile}   = [ @{$current->{indexfile}},@{$parent->{indexfile}} ];
    $new{desc} = {% {$current->{desc}}};
    foreach ( keys %{$parent->{desc}}) { $new{desc}->{$_}=$parent->{desc}{$_}; }
    $new{htmltags} = {% {$current->{htmltags}}};
    foreach ( keys %{$parent->{htmltags}}) { $new{htmltags}->{$_}=$parent->{htmltags}{$_}; }
    $new{htmltext} = {% {$current->{htmltext}}};
    foreach ( keys %{$parent->{htmltext}}) { $new{htmltext}->{$_}=$parent->{htmltext}{$_}; }
    return bless \%new, ref($parent);
}

sub DirectoryIndex($$$;*) {
 my ($cfg, $parms, $files, $cfg_fh) = @_;
    for my $file (split /\s+/, $files) {
	push @{$cfg->{indexfile}}, $file;
    }
    return DECLINE_CMD if Apache->module('mod_dir.c');
}

sub AddDescription($$$;*) {
#this is not completely supported.  
#Since I didn't take the time to fully check mod_autoindex.c behavior,
#I just implemented this as simplt as I could.
 my ($cfg, $parms, $args, $cfg_fh) = @_;
 my ($desc, $files) = ( $args =~ /^\s*"([^"]*)"\s+(.*)$/);
 my $file = join "|", split /\s+/, $files;
    $file = patternize($file);
    $cfg->{desc}{$file} = $desc; 
    return DECLINE_CMD if Apache->module('mod_autoindex.c');
}

sub IndexOrderDefault($$$$) {
 my ($cfg, $parms, $order, $key) = @_;
    die "First keyword must be Ascending, Desending, or Extension" unless ( $order =~ /^(descending|ascending|extension)$/i);
    die "Second keyword must be Name, Date, Size or Description" unless ( $key =~ /^(date|name|size|description)$/i);
    die "Only the Name column can be sorted by Extension" if $order eq 'extension' && $key ne 'name';
    if ($key =~ /date/i) {
	$key = 'M';
    } else {
	$key =~ s/(.).*$/$1/;
    }
    $order =~ s/(.).*$/$1/;
    $cfg->{default_order} = $key . $order;
    return DECLINE_CMD if Apache->module('mod_autoindex.c');
}

sub FancyIndexing ($$$) {
 my ($cfg, $parms, $opt) = @_;
    die "FancyIndexing directive conflicts with existing IndexOptions None" if ($cfg->{options} & NO_OPTIONS);
    $cfg->{options} = ($opt ? ( $cfg->{options} | FANCY_INDEXING ) : ($cfg->{options} & ~FANCY_INDEXING));
    return DECLINE_CMD if Apache->module('mod_autoindex.c');
}
	
sub patternize {
 my $pattern = shift;
    $pattern =~ s/\./\\./g;
    $pattern =~ s/\*/.*/g;
    $pattern =~ s/\?/./g;
    return $pattern;
}

sub push_config {
 my ($cfg, $parms, $value) = @_;
 my $key = $parms->info;
    if ($key eq 'ignore'){
	$value = patternize($value);
    }
    push @ {$cfg->{$key}}, $value;
    return DECLINE_CMD if Apache->module('mod_autoindex.c');
}

sub set_config ($$$) {
 my ($cfg, $parms, $value) = @_;
    $cfg->{$parms->info}=$value;
}

sub IndexHtmlTag($$$;*) {
 my ($cfg,$parms,$directive,$cfg_fh) = @_;
 my ($key,$action,$value)=$directive=~m:(\w+)\s+([+-])?(.+):o;
    unless($key) {
	warn "IndexHtmlTag $directive: No argument";
	return;
    }
    $key=lc($key);
    if($action eq '+') { # '+' action provides multiple lines
	$cfg->{htmltags}{$key}.="\n$value";
    } else {
	$cfg->{htmltags}{$key}="$value";
    }
}

sub IndexHtmlText($$$;*) {
 my ($cfg,$parms,$directive,$cfg_fh) = @_;
 my ($key,$action,$value)=$directive=~m:(\w+)\s+([+-])?(.*):o;
    unless($key) {
	warn "IndexHtmlText $directive: No argument";
	return;
    }
    $key=lc($key);
    if($action eq '+') { # '+' action provides multiple lines
	$cfg->{htmltext}{$key}.="\n$value";
    } else {
	$cfg->{htmltext}{$key}="$value";
    }
}
# End of Configuration Stuff

sub status {
 my ($r, $q) = @_;
 my @s;
 my $cfg = Apache::ModuleConfig->get($r);
    push (@s,"<b>" , __PACKAGE__ , " (ver $Apache::OpenIndex::VERSION) statistics</b><br />");
    push (@s,"Done ".$nDir.   " listings so far<br />");
    push (@s,"Done ".$nRedir. " redirects so far<br />");
    push (@s,"Done ".$nIndex. " indexes so far<br />");
    push (@s,"Done ".$nThumb. " thumbnails so far<br />");
    use Data::Dumper;
    my $string = Dumper $cfg;
    push (@s, $string);
    return \@s;
}

sub thumb_conf {
 my($r) = @_;
    use Storable;
    $iconfig->{cache_dir} = $r->dir_config("IndexCacheDir") || ".thumbnails";
    $iconfig->{dir_create} = $r->dir_config("IndexCreateDir") || 1;
 my $cachedir = $r->filename .  $iconfig->{cache_dir} ;          
    stat $cachedir;
    $iconfig->{cache_ok} = (-e _ && ( -r _ && -w _)) || ((not -e _) && 
	$iconfig->{dir_create} && mkdir $cachedir,0755);
 my $oldopts;
    if ($iconfig->{cache_ok} && -e "$cachedir/.config" && -r _){
	$oldopts = retrieve ("$cachedir/.config");
    }
    $iconfig->{thumb_max_width} = $r->dir_config("ThumbMaxWidth") || DEFAULT_ICON_WIDTH*4;
    $iconfig->{thumb_max_height} = $r->dir_config("ThumbMaxHeight")|| DEFAULT_ICON_HEIGHT*4;
    $iconfig->{thumb_max_size} = $r->dir_config("ThumbMaxSize") || 500000;
    $iconfig->{thumb_min_size} = $r->dir_config("ThumbMinSize") || 5000;
    $iconfig->{thumb_width} = $r->dir_config("ThumbWidth");
    $iconfig->{thumb_height} = $r->dir_config("ThumbHeight");
    $iconfig->{thumb_height} = $r->dir_config("ThumbHeight");
    $iconfig->{thumb_scale_width} = $r->dir_config("ThumbScaleWidth");
    $iconfig->{thumb_scale_height} = $r->dir_config("ThumbScaleHeight");
    $iconfig->{changed} = 0;
    foreach (keys %$iconfig){
	next unless /^thumb/;
	if ($iconfig->{$_} != $oldopts->{$_}) {
	    $iconfig->{changed} = 1;
	    last;
	}
    }
    unless ($iconfig->{cache_ok} && ((not -e "$cachedir/.config") || -w _) && store $iconfig, "$cachedir/.config") {
	$iconfig->{changed} = 0;
    }
}

sub read_dir {
 my ($r,$args,$dirhandle) = @_;
 my $cfg = Apache::ModuleConfig->get($r);
 my @listing;
 my %list;
 my @accept;
 my $size;
 my $hide=!($args->{isadmin} && $dodump);
 my $ignore_regex;
    $ignore_regex = join('$|^',@{$cfg->{ignore}}) if $cfg->{ignore};
    if($cfg->{options} & THUMBNAILS) {
        #Decode the content-encoding accept field of the client
        foreach (split(',\s*',$r->header_in('Accept'))) {
           push @accept, $_ if m:^image/:o;
    	}
    }
    $args->{bytes}=0;
    while(my $file = readdir $dirhandle) {
	next if $file=~m/^\.$/o; # Never display '.' directory
	next if $hide && $file=~m/^$ignore_regex$/;
	push @listing, $file;
     my $subr = $r->lookup_file($file);
	$list{$file}{uid}=(stat $subr->finfo)[4];
	$list{$file}{gid}=(stat _)[5];
	$size = -s _;
	$list{$file}{size} = $size;
	$args->{bytes}+=$size;
	if (-d _) {
	    $list{$file}{size} = -1;
	    $list{$file}{sizenice} = '-';
	} else {
	    $list{$file}{sizenice} = size_string($list{$file}{size});
            $list{$file}{sizenice} =~ s/\s*//;    
        }
        $list{$file}{mod}  = (stat _)[9];
        $list{$file}{modnice} = ht_time($list{$file}{mod}, "%d-%b-%Y %H:%M", 0);
        $list{$file}{modnice} =~ s/\s/&nbsp;/g;
        $list{$file}{mode} = write_mod((stat _)[2]);
        $list{$file}{type}  = $subr->content_type;
        if(($list{$file}{type} =~ m:^image/:o) && 
	   ($cfg->{options} & THUMBNAILS ) && 
	   Apache->module("Image::Magick")) {
            if ($iconfig->{cache_ok}) {
                ($list{$file}{icon},$list{$file}{width},$list{$file}{height}) = get_thumbnail($r, $file, $list{$file}{mod}, $list{$file}{type}, @accept);
	    }
	}
        $list{$file}{height} ||= $cfg->{icon_height};
        $list{$file}{width} ||= $cfg->{icon_width};
# icons size might be calculated on the fly and cached...
     my $icon = Apache::Icon->new($subr);
	$list{$file}{icon} ||= $icon->find;           
	if (-d _) {	
	    $list{$file}{icon} ||= $icon->default('^^DIRECTORY^^');	
	    $list{$file}{alt} = "DIR";
	}	    
	$list{$file}{icon} ||= $icon->default;
        $list{$file}{alt} ||= $icon->alt; 
	$list{$file}{alt} ||= "???"; 
        foreach (keys %{$cfg->{desc}}) {
            $list{$file}{desc} = $cfg->{desc}{$_} if $subr->filename =~ /$_/;
	}
        if($list{$file}{type} eq "text/html" and 
	  ($cfg->{options} & SCAN_HTML_TITLES) and 
	  not $list{$file}{desc}) {
            use HTML::HeadParser;
         my $parser = HTML::HeadParser->new;
            open FILE, $subr->filename;
            while (<FILE>) {
                last unless $parser->parse($_);
	    }
            $list{$file}{desc} = $parser->header('Title');
            close FILE;
	}
        $list{$file}{desc} ||= "&nbsp;";
    }
    return \%list;
}

sub do_sort {
 my ($list,$query,$default,$foldersfirst) = @_;
 my @names = sort keys %$list;
    shift @names;                   #removes '..'
#handle default sorting
    unless ($query->{N} || $query->{S} || $query->{D} || $query->{M}) {
	$default =~ /(.)(.)/;
	$query->{$1} = $2;
    }
    if($query->{N}) {
	@names = sort file_ext @names if $query->{N} eq 'E';
	@names = sort @names if $query->{N} eq 'D';
	@names = reverse sort @names if $query->{N} eq "A";
    } elsif($query->{S}) {
	@names = sort { $list->{$b}{size} <=> $list->{$a}{size} } @names if $query->{S} eq "D";
	@names = sort { $list->{$a}{size} <=> $list->{$b}{size} } @names if $query->{S} eq "A";
    } elsif($query->{M}) {
	@names = sort { $list->{$b}{mod} <=> $list->{$a}{mod} } @names if $query->{M} eq "D";
	@names = sort { $list->{$a}{mod} <=> $list->{$b}{mod} } @names if $query->{M} eq "A";		
    } elsif($query->{D}) {
	@names = sort { $list->{$b}{desc} cmp $list->{$a}{desc} } @names if $query->{D} eq "D";
	@names = sort { $list->{$a}{desc} cmp $list->{$b}{desc} } @names if $query->{D} eq "A";		
    }
    unshift @names, '..';           #puts back '..' on top of the pile
    if($foldersfirst) {
     my @folders;
	for(my $n=0; $n<@names; ) {
	    if($list->{$names[$n]}{sizenice} eq '-') {
		push @folders,$names[$n];# Add dir to @folders
		splice(@names,$n,1);	 # Remove dir from @names
	    } else {
		$n++;
	    }
	}
   	splice(@names,0,0,@folders);
    }
    return \@names;
}

sub file_ext {
 my @aa=split /\./,$a;
 my @ba=split /\./,$b;
 my $an=$#aa;
 my $bn=$#ba;
 my $retval=0;
    while($an>=1 && $bn>=1) {
	return $retval if($retval=$aa[$an--] cmp $ba[$bn--]); 
    }
    return $aa[$an] cmp $ba[$bn] if $an==$bn;
    return 1  if $bn<1;
    return -1 if $an<1;
    0;
}

sub get_thumbnail {
 my ($r, $filename, $mod, $content, @accept) = @_; 
 my $accept = join('|', @accept);
 my $dir = $r->filename;
#these should sound better.
 my $cachedir = $iconfig->{cache_dir};
 my $xresize;
 my $yresize;
 my $img = Image::Magick->new;
 my($imgx, $imgy, $img_size, $img_type) = split(',', $img->Ping($dir . $filename));
#Is the image OK?
    return "/icons/broken.gif" unless ($imgx && $imgy);
    if (($content =~ /$content/) && ($img_type =~ /JPE?G|GIF|PNG/i)) {
	if ($dir =~ /$cachedir\/$/) {	#We know that what we'll generate will be seen.
	    return $filename, $imgx, $imgy #Avoiding recursive thumbnails from Hell
	}
	return undef if $img_size > $iconfig->{thumb_max_size}; #The image is way too big to try to process...
	if(defined $iconfig->{thumb_scale_width} || 
           defined $iconfig->{thumb_scale_height}) {
            #Factor scaling
            $xresize = $iconfig->{thumb_scale_width} * $imgx if defined $iconfig->{thumb_scale_width};
            $yresize = $iconfig->{thumb_scale_height} * $imgy if defined $iconfig->{thumb_scale_height};           
	} elsif(defined $iconfig->{thumb_width} || 
	    defined $iconfig->{thumb_height}) {
#Absolute scaling
	    $xresize = $iconfig->{thumb_width}  
		if defined $iconfig->{thumb_width};
	    $yresize = $iconfig->{thumb_height} 
		if defined $iconfig->{thumb_height};           
	}
#preserve ratio if we can
	$xresize ||= $yresize * ($imgx/$imgy);
	$yresize ||= $xresize * ($imgy/$imgx);   
#default if values are missing.
	$xresize ||= DEFAULT_ICON_WIDTH;
	$yresize ||= DEFAULT_ICON_HEIGHT;
#round off for picky browsers
	$xresize = int($xresize);
	$yresize = int($yresize);
#Image is too small to actually resize.  Simply resize with the WIDTH and HEIGHT attributes of the IMG tag
	return ($filename, $xresize , $yresize) if $img_size < $iconfig->{thumb_min_size};
	if ($iconfig->{changed} || $mod > (stat "$dir$cachedir/$filename")[9]) {
#We should actually resize the image
	if ($img->Read($dir . $filename)) { #Image is broken
	    return "/icons/broken.gif";
	}
	$nThumb++;
	$img->Sample(width=>$xresize, height=>$yresize);
	$img->Write("$dir$cachedir/$filename");       
    }
    return "$cachedir/$filename", $xresize , $yresize;
    }   
    return undef;
}

sub write_mod {
 my $mod = shift ;
    $mod = $mod & 4095;
 my $letters;
 my %modes = (
	1   =>  'x',
	2   =>  'w',
	4   =>  'r',
    );
    foreach my $f (64,8,1){
        foreach my $key (4,2,1) {
	    if ($mod & ($key * $f)){
                $letters .= $modes{$key};
	    } else {
		$letters .= '-';
	    }
	}
    }
    return $letters;
}

sub new{bless{},shift;}
1;

__END__