#!/opt/bin/perl
require 5;
use strict;

=head1 copyright

Genesis Web Authoring System

Copyright 1997-2001 by Zoltan Milosevic.  Please adhere to the copyright
notice and conditions of use, described in the attached help file and hosted
at the URL below.  For the latest version and help files, visit:

	http://www.xav.com/scripts/genesis/

This search engine is managed from the web; the default username/password
is webmaster/658uwantit:

	http://www.teachabletech.com/genesis/index.cgi

=cut

use vars qw( $VERSION %params );

$VERSION = '2.1.0.0009';

my $all_code = <<'END_OF_CODE';

#changed 0008
$ENV{'PATH'} = &query_env('PATH');
foreach ('IFS','CDPATH','ENV','BASH_ENV') {
	delete $ENV{$_} if (defined($ENV{$_}));
	}

use vars qw( %security $auth %const @lang_strings %STATE @user_attribs_ro @user_attribs_rw @user_attribs_internal );

@user_attribs_internal = ('_BUILD', '_VERSION', 'Username', 'LastLogin', 'LastLoginFrom', 'AccountCreated');
@user_attribs_ro = ('Quota', 'Author:UseQuota', 'Author:UserFolder', 'Author:UserURL', 'allow_cgi');
@user_attribs_rw = ('shell', 'full_name', 'email_address', 'DiskUse', 'Warn', 'ShowTips', 'ShowDirSize', 'Sort', 'multi_upload_count', 'Rows', 'Cols', 'TextWrap', 'TextUpload', 'Concise', 'FontSize', 'Sound');

#changed 0008 - mac compat:
sub onetru_path(@);
sub onetru_path(@) {
	my $fullpath = join('/',@_);
	if (($^O) and ($^O =~ m!mac!i)) {
		$fullpath =~ s!:!/!sg;
		}
	elsif (($^O) and ($^O =~ m!(win|dos)!i)) {
		$fullpath =~ s!\\!/!sg;
		}
	$fullpath =~ s!/+!/!sg;
	return $fullpath;
	}
sub native_path($);
sub native_path($) {
	my $fullpath = defined($_[0]) ? $_[0] : '';
	if (($^O) and ($^O =~ m!mac!i)) {
		$fullpath =~ s!/!:!sg;
		}
	elsif (($^O) and ($^O =~ m!(win|dos)!i)) {
		$fullpath =~ s!/!\\!sg;
		}
	return $fullpath;
	}
#end changes

my $err_msg = '';
Err: {

	my $script_name = &query_env( 'SCRIPT_NAME', 'index.cgi' );

	my @paths = ();
	($err_msg, @paths) = &where_tf();
	next Err if ($err_msg);

	unless (chdir($paths[1])) {
		$err_msg = "unable to chdir to '$paths[1]' - $!";
		next Err;
		}

	%const = (
		'help file' => 'http://www.xav.com/scripts/genesis/help/',
		'full_script_url' => $paths[3],
		'super user' => 'webmaster',
		'script_url' => $script_name,
		'admin_url' => "$script_name?",
		'cwd_line' => '',
		'crypt_pass_line' => '',
		'http' => "$paths[4]/web_pages/",
		'image url' => "$paths[4]/web_pages/images/",
		);

	$const{'path'} = "$paths[1]/web_pages";
	$const{'preferences folder'} = "$paths[1]/script_data";
	$const{'event log'} = $const{'preferences folder'} . '/event.log';

	# Pull in the language settings:
	my $file = $const{'preferences folder'} . "/templates/english/strings.txt";

	@lang_strings = (''); # Initialize with a null element
	unless (open(FILE, "<$file")) {
		$err_msg = "unable to read from file '$file' - $!";
		next Err;
		}

	binmode(FILE);
	while (<FILE>) {
		chomp;
		push(@lang_strings, $_);
		}
	close(FILE);
	if ($lang_strings[1] =~ m!^VERSION (\d+\.\d+\.\d+\.\d+)$!) {
		my $strings_version = $1;
		if ($strings_version ne $VERSION) {
			$err_msg = "strings '$file' is version $strings_version, but this script is version $VERSION. Versions much match";
			next Err;
			}
		}

	%security = (
		'Base Folder'               => $const{'path'},
		'Base URL'                  => $const{'http'},
		'Images URL'                => $const{'image url'},
		'Mail Server'               => '',
		'Permission - Folder'       => '0777',
		'Permission - Normal Files' => '0766',
		'Permission - CGI Scripts'  => '0777',
		'Min Password Length'       => 4,
		'Allow Only Known Types'    => 0,
		'CGI Types'                 => " pl cgi sh exe php asp bat cmd idq stm shtml shtm ",
		'Known Types'               => " css js txt html htm jpg gif wav mid midi au ra zip tar hqx null tmp ",
		'Forbid Types'              => " htaccess ",
		'RegKey'                    => '',
		'mode'                      => 1,
		);


	$const{'code_validate'} = sub {
		my $p_decode = sub {
			local $_;
			my $code = defined($_[0]) ? $_[0] : '';
			my %map = ();
			my $i = 0;
			foreach (48..57,65..90,97..122) {
				$map{chr($_)} = $i % 16;
				$i++;
				}
			$code =~ s!\s|\r|\n|\015|\012!!sg;
			my $text = '';
			my $frag = '';
			$i = 0;
			while ($frag = substr($code, $i, 2)) {
				$i += 2;
				my $chn = 16 * $map{substr($frag,0,1)};
				$chn += $map{substr($frag,1,1)};
				my $ch = chr($chn);
				$text .= $ch;
				}
			$text = unpack('u',$text);
			return $text;
			};
		local $_;
		my $code = defined($_[0]) ? $_[0] : '';
		return 0 unless ($code);
		my $is_valid = 0;
		$code =~ s!BEGIN LICENSE!!sg;
		$code =~ s!END LICENSE!!sg;
		if ($code =~ m!^\s*(.*)\s*\-\s*(.*?)\s*$!s) {
			my ($pub, $pri) = ($1,$2);
			$pri = &$p_decode($pri);
			$pub =~ s!(\s|\r|\n)!!sg;
			$pri =~ s!(\s|\r|\n)!!sg;
			if ($pub eq $pri) {

				$is_valid = 1;
				}
			}
		return $is_valid;
		};


	my $text = '';
	($err_msg, $text) = &ReadFile( "$const{'preferences folder'}/security.txt" );
	next Err if ($err_msg);

	foreach (split(m!\r?\n!, $text)) {
		next unless (m!^(.+)\==(.*)$!);
		my ($name, $value) = ($1, $2);
		next unless (defined($security{$name}));
		$value =~ s!\\CRLF!\015\012!sg;
		$security{$name} = $value;
		}

	#changed 0006 - strip trailing slashes:
	$security{'Base Folder'} =~ s!/$!!o;
	$security{'Base URL'} =~ s!/$!!o;
	$security{'Images URL'} =~ s!/$!!o;
	$const{'preferences folder'} =~ s!/$!!o;


		# $const{'mode'}
		# 0 => is_demo; cannot save data
		# 1 => shareware / evaluation mode
		# 2 => shareware / registered
		# 3 => freeware

	# user can set it to whatever he wants.
	# BUT he can't be 2/registered unless he has a valid regkey (we'll kick him down to shareware)
	# AND nobody can be anything but demo if the "is_demo" file has been touched

	$const{'mode'} = $security{'mode'};
	if (($const{'mode'} == 2) and (not ($security{'RegKey'}))) {
		$const{'mode'} = 1;
		}

	if (-e "$const{'preferences folder'}/is_demo") {
		$const{'mode'} = 0;
		}


	#changed 0003 - Make the permissions value octal instead of text:
	undef($@);
	foreach ('Permission - Folder', 'Permission - Normal Files', 'Permission - CGI Scripts') {
		my $mode = $security{$_};
		next unless ($mode =~ m!^0\d\d\d$!);
		eval "\$security{\"\$_ - eval\"} = $mode;";
		if ($@) {
			$err_msg = "unable to evaluate command - $@";
			next Err;
			}
		}





	%params = ();
	my %upload_files = ();

	&standard_binmode();
	$err_msg = &WebForm( \%params, \%upload_files, "$const{'preferences folder'}/temp" );
	next Err if ($err_msg);


	# Initialize certain form fields:
	foreach ('CWD', 'Stop') {
		$params{$_} = '' unless ($params{$_});
		}

	$auth = &web_auth_new(
		'make_starter_accounts' => 1,
		'data_folder' => "$const{'preferences folder'}/accounts/",
		'lang_strings' => \@lang_strings,
		);


	my ($is_auth, $private_token, $auth_username, $is_cookies_aware) = $auth->Challenge( \%params );
	last Err unless ($is_auth);


	unless ($is_cookies_aware) {
		$const{'admin_url'} .= "web_auth_cp=$private_token&";
		$const{'crypt_pass_line'} = "<INPUT TYPE=\"hidden\" NAME=\"web_auth_cp\" VALUE=\"$private_token\">";
		}


	# Below is a mammoth procedure which handles all authentication methods, and reads
	# in this user's preferences to populate the $STATE array.  Authentication errors
	# below will redirect to the &Challenge procedure:

	# Okay, user is authenticated, input is parsed, it's time to do some editing...


	my $action = '';
	if ($params{'Action'}) {
		$action = $params{'Action'};
		}
	if ($action eq 'LogOut') {
		$auth->logout();
		last Err;
		}


	%STATE = ();
	$const{'home_dir_err_msg'} = &GetUserPrefs( $auth_username, \%STATE );


	my $title = '';
	if ($action eq 'Main') {
		$title = 'Administer Genesis';
		}
	elsif ($action eq 'SS') {
		$title = 'Switch Sort Method';
		}
	elsif ($action eq 'Delete') {
		$title = "Delete Files";
		}
	elsif ($action eq 'Rename') {
		$title = "Rename Files";
		}
	elsif ($action eq 'Copy') {
		$title = "Copy Files";
		}
	elsif ($action eq 'PR') {
		$title = 'Show Preferences';
		}
	elsif ($action eq 'save_prefs') {
		$title = 'Saving Preferences';
		}
	elsif ($action eq 'BT') {
		$title = 'Build Template';
		}
	elsif ($action eq 'VT') {
		$title = 'Save Template';
		}
	elsif ($action eq 'Edit') {
		$title = "<P>Editing file '$params{'FH'}'.</P>";
		}
	elsif ($action eq 'Write') {
		$title = "Save $params{FH}";
		}
	elsif ($action eq 'upload') {
		$title = "Upload File $params{'FH'}";
		}
	elsif ($action eq 'makedir') {
		$title = "Make Folder $params{'directory'}";
		}
	elsif ($action eq 'ListFiles') {
		$title = 'List Files and Folders';
		}
	elsif ($action eq 'ListTemplates') {
		$title = 'Template Editor';
		}
	elsif (($const{'mode'} != 3) and ($action eq 'multi-upload')) {
		$title = "Upload Files";
		}
	elsif (($const{'mode'} != 3) and ($action eq 'image-review')) {
		$title = "Review Images";
		}
	elsif ($STATE{'Username'} ne $const{'super user'}) {
		$title = '';
		}
	elsif ($action eq 'EventLog') {
		$title = 'Manage Event Log';
		}
	elsif ($action eq 'SY') {
		$title = 'Manage System Settings';
		}
	elsif ($action eq 'UC') {
		$title = 'Register Genesis Script';
		}
	elsif (($const{'mode'} != 3) and ($action eq 'UA')) {
		$title = 'User Administration';
		}





	my %replace_values = %const;
	$replace_values{'cpfooter'} = "<P ALIGN=center><FONT SIZE=-2>The <A HREF=\"http://www.xav.com/scripts/genesis/\">Genesis Web Authoring System</A> v$VERSION is copyright 2001 by Zoltan Milosevic.</FONT></P>";
	$replace_values{'title'} = $title;

	my ($header_text, $footer_text) = ('', '');
	my $template_text = &PrintTemplateEx( 1, 'template.html', "$const{'preferences folder'}/templates/english", \%replace_values );
	if ($template_text =~ m!^(.*)\%script_output\%(.*)$!is) {
		($header_text, $footer_text) = ($1, $2);
		}

	print "Content-Type: text/html\015\012\015\012";
	print $header_text;
	&StartHTML();

	if ($action eq '') {
		&user_shell();
		}
	elsif ($action eq 'Main') {
		&ui_Admin();
		}
	elsif ($action eq 'SS') {
		&SwitchSort();
		&ui_ListFiles();
		}
	elsif ($action eq 'Delete') {
		&ui_Delete( $STATE{'file_path'} );
		}
	elsif ($action eq 'Rename') {
		&ui_Rename();
		}
	elsif ($action eq 'Copy') {
		&ui_Copy();
		}
	elsif ($action eq 'PR') {
		&ShowSettings( $STATE{'Username'}, 1, 0 );
		}
	elsif ($action eq 'save_prefs') {
		&Save_Preferences( $STATE{'Username'}, 1 );
		}
	elsif ($action eq 'BT') {
		&BuildTemplate();
		}
	elsif ($action eq 'VT') {
		&SaveTemplate;
		}
	elsif ($action eq 'Edit') {
		&ui_Edit( $params{'FH'} );
		}
	elsif ($action eq 'Write') {
		&ui_Write( $params{'FH'}, $params{'file'} );
		&ui_ListFiles();
		}
	elsif ($action eq 'upload') {
		&ui_Upload( \%upload_files );
		}
	elsif ($action eq 'makedir') {
		&create_folder( $params{'directory'} );
		&ui_ListFiles();
		}
	elsif ($action eq 'ListFiles') {
		&ui_ListFiles();
		}
	elsif ($action eq 'ListTemplates') {
		&ui_ListTemplates();
		}

	# These features are not available in the freeware version:

		elsif (($const{'mode'} != 3) and ($action eq 'multi-upload')) {
			&form_BulkUpload();
			}
		elsif (($const{'mode'} != 3) and ($action eq 'image-review')) {
			&form_ImageReview();
			}
		elsif (($const{'mode'} != 3) and ($action eq 'html-review')) {
			&form_HTML_Review();
			}

	#end


	# If a user doesn't enter a $params{'Action'}, then he goes through the default
	# &ListFiles routine defined above.  Otherwise, he enters this IF/ELSE block
	# and proceeds until he finds a match for his $Action.  Every possible user
	# action (except LogOut) has been offered above.  Thus, if he makes it this
	# far, he is either trying to log out, he has an invalid $Action, or he is a
	# super-user.  To keep things safe and secure, at this point we are just going
	# to log the user out unless he is the super-user:

	elsif ($STATE{'Username'} ne $const{'super user'}) {
		&user_shell();
		}

	# Okay, he's made it through - time to start offering super-user actions:

	# Basic admin actions:

		elsif ($action eq 'EventLog') {
			&ui_ManageLog();
			}
		elsif ($action eq 'SY') {
			&ui_SystemSettings();
			}
		elsif ($action eq 'UC') {
			&ui_UpdateLicense();
			}

	# Admin actions regarding management of user accounts; not available in freeware mode==3

		elsif (($const{'mode'} != 3) and ($action eq 'UA')) {
			&ui_ManageUsers();
			}

	# Default action:

	else {
		&user_shell();
		}

	&ReportFreeSpace() if $STATE{'DiskUse'};
	print $footer_text;

	last Err;
	}
continue {
	print "Content-Type: text/html\015\012\015\12";
	print "<P><B>Error:</B> $err_msg.</P>";
	}


# Finished re-directing to the proper subprocedures.  The script is
# now finished executing.
#
# __________________________________________________________________


# see perldoc perlsec

sub query_env {
	my ($name,$default) = @_;
	if (($ENV{$name}) and ($ENV{$name} =~ m!^(.*)$!s)) {
		return $1;
		}
	elsif (defined($default)) {
		return $default;
		}
	else {
		return '';
		}
	}



sub user_shell {
	if ($STATE{'shell'} == 1) {
		&ui_ListTemplates();
		}
	elsif ($STATE{'shell'} == 2) {
		&ui_ListFiles();
		}
	else {
		&ui_Admin();
		}
	}



sub save_system_settings {
	local $_;
	my $text = '';
	$security{'Images URL'} = &Trim($security{'Images URL'});
	foreach (sort keys %security) {
		my $value = $security{$_};
		$value =~ s!(\r|\n)+!\\CRLF!sg;
		$text .= "$_==$value\n";
		}
	return &WriteFile( "$const{'preferences folder'}/security.txt", $text );
	}

sub ui_SystemSettings {
	my $err_msg = '';
	Err: {

print <<"EOM";
<P><B>
	<A HREF="$const{'admin_url'}Action=Main">Main</A> /
	<A HREF="$const{'admin_url'}Action=SY">System Settings</A> /
EOM


		my @order = (
			'Images URL',
			'Mail Server',

			'Permission - Folder',
			'Permission - Normal Files',
			'Permission - CGI Scripts',

			'Min Password Length',

			'Forbid Types',
			'CGI Types',
			'Allow Only Known Types',
			'Known Types',
			);

		my %desc_security = (
			'Images URL' => "The web folder holding all the images used in the UI. You may use http://www.xav.com/scripts/genesis/images if you like.",
			'Mail Server' => "The address of an SMTP server for sending mail. If one is not supplied, the script will try to auto-detect one whenever it needs to send mail.",

			'Permission - Folder'             => "File permissions for all folders.",
			'Permission - Normal Files'               => "File permissions for all normall files.",
			'Permission - CGI Scripts'           => "File permissions for CGI scripts.",
			'Min Password Length' => "Minimum password length",

			'Allow Only Known Types'         => "If set to 1, only file extensions in the 'Known Types' group will be allowed (CGI scripts will also be allowed for any users that you give the 'allow_cgi' privilege to). Alternately, when set to 0, any file extension will be permitted *unless* it has been specifically outlawed in the Forbid Types list.",

			'CGI Types'               => "All files with these extensions will be considered CGI scripts. List all extensions together, in lowercase, separated by spaces.",

			'Known Types'             => "These are familiar, friendly file extensions. Files with these extensions will be allowed. List all extensions together, in lowercase, separated by spaces.",
			'Forbid Types'            => "Any files with these extensions will be forbidden. List all extensions together, in lowercase, separated by spaces.",
			);


		if ($params{'subaction'} eq 'write') {
			print ' Save Data</B></P>';
			if ($const{'mode'} == 0) {
				$err_msg = $lang_strings[45];
				next Err;
				}
			my $text = '';
			foreach (@order) {
				$security{$_} = $params{$_};
				}
			$err_msg = &save_system_settings();
			next Err if ($err_msg);
			printf( $lang_strings[4], "saved security settings" );
			last Err;
			}
		else {
			print ' Overview</B></P>';
			}


print <<"EOM";

<P>Note: the settings "Base Folder" and "Base URL" have migrated to a per-user setting.</P>

<FORM METHOD="post" ACTION="$const{'script_url'}">
<INPUT TYPE="hidden" NAME="Action" VALUE="SY">
<INPUT TYPE="hidden" NAME="subaction" VALUE="write">
$const{'cwd_line'}
$const{'crypt_pass_line'}

EOM

		my $text = '';
		foreach (@order) {
			my $desc = $desc_security{$_};
			$text .= "<P><B>$_:</B><BR><TT><INPUT NAME=\"$_\" SIZE=65></TT><BR>$desc_security{$_}</P>\n";
			}

print &SetDefaults(<<"EOM", \%security );

$text

<P><INPUT TYPE=submit CLASS=submit VALUE="Save Data"></P>

</FORM>

EOM
		last Err;
		}
	continue {
		printf( $lang_strings[2], $err_msg );
		}
	}


sub ui_UpdateLicense {
	my $err_msg = '';
	Err: {

		print "<P><B><A HREF=\"$const{'admin_url'}Action=Main\">Main</A> / <A HREF=\"$const{'admin_url'}Action=UC\">Update License</A> / ";

		if ($params{'subaction'} eq 'write') {
			print "Save Data</B></P>";

			if ($const{'mode'} == 0) {
				$err_msg = $lang_strings[45];
				next Err;
				}

			if ($params{'RegKey'}) {
				my $virtual = $const{'code_validate'};
				unless (&$virtual($params{'RegKey'})) {
					#should not happen
					$err_msg = "the registration code you entered is not valid - please contact the vendor";
					next Err;
					}
				}


			if (($params{'RegKey'}) and ('' eq $security{'RegKey'})) {
				$security{'mode'} = 2;
				}
			else {
				$security{'mode'} = $params{'mode'};
				}
			$security{'RegKey'} = $params{'RegKey'};
			$err_msg = &save_system_settings();
			next Err if ($err_msg);
			printf( $lang_strings[4], "saved licensing information" );
			last Err;
			}
		else {
			print "Overview</B></P>";
			}


		my %defaults = (
			'mode' => $const{'mode'},
			'RegKey' => $security{'RegKey'},
			);

print &SetDefaults(<<"EOM", \%defaults);

<FORM METHOD="post" ACTION="$const{'script_url'}">
<INPUT TYPE="hidden" NAME="Action" VALUE="UC">
<INPUT TYPE="hidden" NAME="subaction" VALUE="write">
$const{'cwd_line'}
$const{'crypt_pass_line'}

<TABLE BORDER=0 CELLPADDING=4 CELLSPACING=1 BGCOLOR="#000000">
<TR BGCOLOR="#9eb3c7">
	<TH COLSPAN=2>License Mode</TH>
	<TH>Features</TH>
</TR>
<TR BGCOLOR="#d5d2bb" VALIGN=top>
	<TD><INPUT TYPE=radio NAME="mode" VALUE="3"></TD>
	<TD>Freeware<BR>Version</TD>
	<TD>Basic functionality - single user HTML and template editing.</TD>
</TR>
<TR BGCOLOR="#d5d2bb" VALIGN=top>
	<TD><INPUT TYPE=radio NAME="mode" VALUE="1"></TD>
	<TD>Trial<BR>Shareware</TD>
	<TD>Extended functionality for a reasonable trial period. Allows multiple user accounts, user settings updated over web, multiple file upload, etc.</TD>
</TR>
<TR BGCOLOR="#d5d2bb" VALIGN=top>
	<TD><INPUT TYPE=radio NAME="mode" VALUE="2"></TD>
	<TD>Registered<BR>Shareware</TD>
	<TD>All features, permanent. You receive the right to remove publicly-viewable copyright.</TD>
</TR>
</TABLE>

<P>Registration key: <TT><TEXTAREA NAME="RegKey" ROWS=10 COLS=65></TEXTAREA></TT></P>

<P><INPUT TYPE=submit CLASS=submit VALUE="Save Data"></P>

<P>To make inquiries or to acquire a new registration key, visit <A HREF="http://www.xav.com/scripts/genesis/purchase.pl">www.xav.com/scripts/genesis</A>.</P>
<P>Your support will help get new features added, and will help with bug fixes and performance improvements.</P>

EOM
		last Err;
		}
	continue {
		printf( $lang_strings[2], $err_msg );
		}
	}



sub ui_Admin {
	if ($STATE{'Username'} eq $const{'super user'}) {

print '<P><B>Admin Options</B></P><UL>';

print <<"EOM" if ($const{'mode'} != 3);

<LI> <P><B><A HREF="$const{'admin_url'}Action=UA">Manage Users</A></B><BR>
Create, review, and delete user accounts. Useful for delegating authoring privileges.</P>

<LI> <P><B><A HREF="$const{'admin_url'}Action=EventLog">Event Log</A></B><BR>
Review of log of server activity.</P>

EOM

print <<"EOM";

<LI> <P><B><A HREF="$const{'admin_url'}Action=SY">System Settings</A></B><BR>
Control the system-wide settings for Genesis. Includes security settings.</P>

<LI> <P><B><A HREF="$const{'admin_url'}Action=UC">Update License</A></B><BR>
Select licensing mode and/or enter registration key.</P>
</UL>

EOM

	}
print <<"EOM";

<P><B>Authoring Options</B></P>

<UL>

<LI> <P><B><A HREF="$const{'admin_url'}Action=ListTemplates">Template Editor</A></B><BR>
Allows you to create and maintain web pages without using HTML.</P>

<LI> <P><B><A HREF="$const{'admin_url'}Action=ListFiles">HTML Editor</A></B><BR>
Allows you to edit web pages with HTML, and also manage files and folders.</P>

<LI> <P><B><A HREF="$const{'admin_url'}Action=PR">My Account</A></B><BR>
Allows you to update name and email settings; reset password; and configure options for the HTML editor.</P>

<LI> <P><B><A HREF="$const{'admin_url'}Action=LogOut">Sign Out</A></B><BR>
Clears your authentication token - always complete this step when you're finished.</P>

<LI> <P><B><A HREF="$const{'help file'}">Help</A></B><BR>
Frequently asked questions document for this software. Includes links to Discussion Forum, install help, and source code.</P>

</UL>

EOM


	}




sub ui_Rename {
	my $err_msg = '';
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$err_msg = $const{'home_dir_err_msg'};
			next Err;
			}

		my @Files = ();

		my ($name, $value) = ();
		while (($name, $value) = each %params) {
			next unless ($name =~ m!^FH\:(.*)$!);
			push(@Files, $1);
			}

		if ($params{'Confirmed'}) {

			my ($err_msg, $is_cgi) = ();

			foreach (reverse sort @Files) {

				my $old_file = $_;
				my $new_file = $params{"FH:$_"};

				($err_msg, $is_cgi) = &CheckName( $new_file );
				if ($err_msg) {
					printf( $lang_strings[2], $err_msg );
					next;
					}

				my $old_abs_file = "$STATE{'file_path'}/$old_file";
				my $new_abs_file = "$STATE{'file_path'}/$new_file";

				unless (rename($old_abs_file, $new_abs_file)) {
					$err_msg = sprintf( $lang_strings[14], $old_file, $new_file, $! );
					printf( $lang_strings[2], $err_msg );
					next;
					}
				printf( $lang_strings[4], sprintf( $lang_strings[20], $old_file, $new_file ) );
				}
			}
		else {

print <<"EOM";

<P><B>Rename Files:</B></P>

<FORM METHOD="post" ACTION="$const{'script_url'}">
<INPUT TYPE="hidden" NAME="Action" VALUE="Rename">
<INPUT TYPE="hidden" NAME="Confirmed" VALUE="1">
$const{'cwd_line'}
$const{'crypt_pass_line'}

<TABLE BORDER=1>
<TR>
	<TH>Original File</TH>
	<TH>New File Name</TH>
</TR>

EOM

		my $relfile = ();
		foreach $relfile (@Files) {

print <<"EOM";

<TR>
	<TD>$relfile</TD>
	<TD><INPUT NAME="FH:$relfile"></TD>
</TR>

EOM
		}



print <<"EOM";

</TABLE>

	<P><INPUT TYPE=submit CLASS=submit VALUE="Rename"></P>
	</FORM>


EOM
			}
		last Err;
		}
	continue {
		printf($lang_strings[2], $err_msg);
		}
	}



sub ui_Copy {
	my $err_msg = '';
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$err_msg = $const{'home_dir_err_msg'};
			next Err;
			}


		my @Files = ();

		my ($name, $value) = ();
		while (($name, $value) = each %params) {
			next unless ($name =~ m!^FH\:(.*)$!);
			push(@Files, $1);
			}

		if ($params{'Confirmed'}) {

			foreach (reverse sort @Files) {

				my ($err_msg, $is_cgi) = ();
				Err: {

					my $old_file = $_;
					my $new_file = $params{"FH:$_"};

					($err_msg, $is_cgi) = &CheckName( $new_file );
					next Err if ($err_msg);

					my $old_abs_file = "$STATE{'file_path'}/$old_file";
					my $new_abs_file = "$STATE{'file_path'}/$new_file";

					my $contents = '';

					($err_msg, $contents) = &ReadFile( $old_abs_file );
					next Err if ($err_msg);

					($err_msg) = &WriteFile( $new_abs_file, $contents );
					next Err if ($err_msg);

					&Mask( $new_abs_file, $is_cgi );

					printf( $lang_strings[4], sprintf( $lang_strings[16], $new_file ) );

					last Err;
					}
				continue {
					printf( $lang_strings[2], $err_msg );
					}
				}

			}
		else {

print <<"EOM";

<P><B>Copy Files:</B></P>

<FORM METHOD="post" ACTION="$const{'script_url'}">
<INPUT TYPE="hidden" NAME="Action" VALUE="Copy">
<INPUT TYPE="hidden" NAME="Confirmed" VALUE="1">
$const{'cwd_line'}
$const{'crypt_pass_line'}

<TABLE BORDER=1>
<TR>
	<TH>Original File</TH>
	<TH>New File Name</TH>
</TR>

EOM

		my $rel_file = ();
		foreach $rel_file (@Files) {
			my $abs_file = "$STATE{'file_path'}/$rel_file";
			if (-d $abs_file) {

print <<"EOM";

<TR>
	<TD>$rel_file</TD>
	<TD>Cannot copy folders - only files</TD>
</TR>

EOM

			}
		else {

print <<"EOM";

<TR>
	<TD>$rel_file</TD>
	<TD><INPUT NAME="FH:$rel_file"></TD>
</TR>

EOM

			}
		}



print <<"EOM";

</TABLE>

	<P><INPUT TYPE=submit CLASS=submit VALUE="Copy"></P>
	</FORM>


EOM
			}
		last Err;
		}
	continue {
		printf($lang_strings[2], $err_msg);
		}
	}


sub ui_Delete {
	my $err_msg = '';
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$err_msg = $const{'home_dir_err_msg'};
			next Err;
			}


	my ($base_dir) = @_;
	my $qm_base_dir = quotemeta("$base_dir/");

	my @Files = ();

	my ($name, $value) = ();
	while (($name, $value) = each %params) {
		next unless ($name =~ m!^FH\:(.*)$!);
		next unless ($value);
		my $relfile = $1;
		next if ($relfile =~ m!\.\.!);
		push(@Files, $relfile);
		}

	if ($params{'Confirmed'}) {
		foreach (reverse sort @Files) {
			my $relfile = $_;
			my $abs_file = &clean_path("$base_dir/$_");
			unless ($abs_file =~ m!^$qm_base_dir!i) {
				printf( $lang_strings[2], "file name '$abs_file' doesn't pattern match to base dir '$base_dir'" );
				next;
				}
			unless ($abs_file =~ m!/([^/]+)$!) {
				printf( $lang_strings[2], "cannot extract base name from '$abs_file'" );
				next;
				}
			my $basename = $1;
			my $file_err = (&CheckName($basename))[0];
			if ($file_err) {
				printf( $lang_strings[2], $file_err );
				next;
				}

			if (-d $abs_file) {
				&Mask( $abs_file, 0 );
				if (rmdir($abs_file)) {
					printf( $lang_strings[4], sprintf( $lang_strings[27], $relfile ) );
					}
				else {
					printf( $lang_strings[2], sprintf( $lang_strings[23], $relfile, $! ) );
					}
				}
			else {
				&Mask( $abs_file, 0 );
				if (unlink($abs_file)) {
					printf( $lang_strings[4], sprintf( $lang_strings[19], $relfile ) );
					}
				else {
					printf( $lang_strings[2], sprintf( $lang_strings[13], $relfile, $! ) );
					}
				}
			}
		}
	else {

print <<"EOM";

<P><B>Confirm Delete:</B></P>

<FORM METHOD="post" ACTION="$const{'script_url'}">
<INPUT TYPE="hidden" NAME="Action" VALUE="Delete">
<INPUT TYPE="hidden" NAME="Confirmed" VALUE="1">
$const{'cwd_line'}
$const{'crypt_pass_line'}


EOM

	my $relfile = ();
	foreach $relfile (@Files) {
		my $file = "$base_dir/$relfile";

		my $file_err_msg = '';
		FileErr: {
			my $abs_file = &clean_path($file);
			unless ($abs_file =~ m!^$qm_base_dir!i) {
				$file_err_msg = "file name '$abs_file' doesn't pattern match to base dir '$base_dir'";
				next FileErr;
				}
			unless ($abs_file =~ m!/([^/]+)$!) {
				$file_err_msg = "cannot extract base name from '$abs_file'";
				next FileErr;
				}
			my $basename = $1;
			my $file_err = (&CheckName($basename))[0];
			if ($file_err) {
				$file_err_msg = $file_err;
				next FileErr;
				}
			if ($basename eq '.is_user_dir') {
				$file_err_msg = "is user home directory";
				next FileErr;
				}
			print "<P><INPUT TYPE=checkbox NAME=\"FH:$relfile\" CHECKED VALUE=1> $relfile</P>\n";
			last FileErr;
			}
		continue {
			print "<P><INPUT TYPE=checkbox NAME=\"foo\" VALUE=1 DISABLED> $relfile - cannot delete - $file_err_msg.</P>\n";
			}
		if (-d $file) {
			&ui_Delete_FolderContents( $file, $relfile );
			}
		}

print <<"EOM";

	<P><INPUT TYPE=submit CLASS=submit VALUE="Delete"></P>
	</FORM>

EOM
			}
		last Err;
		}
	continue {
		printf($lang_strings[2], $err_msg);
		}
	}



sub ui_Delete_FolderContents {
	my $err_msg = '';
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$err_msg = $const{'home_dir_err_msg'};
			next Err;
			}

		my ($abs_path, $rel_path) = @_;
		my $qm_base_dir = quotemeta("$abs_path/");
		my $base_dir = $abs_path;
		if (opendir(DIR, $abs_path)) {
			my @items = readdir(DIR);
			closedir(DIR);

			print "<UL>\n";

			foreach (@items) {
				next if (m!^\.\.?$!);
				my $relfile = "$rel_path/$_";
				my $sub_abs_path = "$abs_path/$_";


				my $file_err_msg = '';
				FileErr: {
					my $abs_file = &clean_path($sub_abs_path);
					unless ($abs_file =~ m!^$qm_base_dir!i) {
						$file_err_msg = "file name '$abs_file' doesn't pattern match to base dir '$base_dir'";
						next FileErr;
						}
					unless ($abs_file =~ m!/([^/]+)$!) {
						$file_err_msg = "cannot extract base name from '$abs_file'";
						next FileErr;
						}
					my $basename = $1;
					my $file_err = (&CheckName($basename))[0];
					if ($file_err) {
						$file_err_msg = $file_err;
						next FileErr;
						}
					if ($basename eq '.is_user_dir') {
						$file_err_msg = "is user home directory";
						next FileErr;
						}
					print "<P><INPUT TYPE=checkbox NAME=\"FH:$relfile\" CHECKED VALUE=1> $relfile</P>\n";
					last FileErr;
					}
				continue {
					print "<P><INPUT TYPE=checkbox NAME=\"foo\" VALUE=1 DISABLED> $relfile - cannot delete - $file_err_msg.</P>\n";
					}
				if (-d $sub_abs_path) {
					&ui_Delete_FolderContents( $sub_abs_path, $relfile );
					}

				}

			print "</UL>\n";
			}
		last Err;
		}
	continue {
		printf($lang_strings[2], $err_msg);
		}
	}



sub StartHTML {

print <<"EOM";

<TABLE BORDER=0 WIDTH=638>
<TR>
	<TD><B><A HREF="$const{'admin_url'}Action=Main">Main</A> -
<A HREF="$const{'admin_url'}Action=ListTemplates">Template Editor</A> -
<A HREF="$const{'admin_url'}Action=ListFiles">HTML Editor</A> -
<A HREF="$const{'admin_url'}Action=PR">My Account</A></B></TD>
	<TD ALIGN=right><B><A HREF="$const{'admin_url'}Action=LogOut">Sign Out</A> -
<A HREF="$const{'help file'}">Help</A></B></TD>
</TR>
</TABLE>

<HR SIZE=1>

EOM

	if ($STATE{'ShowTips'}) {
		my %replace_values = %const;
		my $tips = &PrintTemplateEx( 1, 'tips.txt', "$const{'preferences folder'}/templates/english", \%replace_values );
		my @tips = split(m!\r?\n!, $tips);
		my $N = scalar @tips;
		$N = int(rand($N));
		print "<B>Tip:</B> $tips[$N]<BR><HR SIZE=1>\n";
		}
	}



sub ui_ListTemplates {
	my $err_msg = '';
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$err_msg = $const{'home_dir_err_msg'};
			next Err;
			}



print <<"EOM";

		<P><B>Web Templates:</B></P>
		<P>Templates allow you to create a complete website, without using HTML.</P>


<FORM METHOD="post" ACTION="$const{'script_url'}">
<INPUT TYPE="hidden" NAME="Action" VALUE="BT">
$const{'cwd_line'}
$const{'crypt_pass_line'}

EOM


		my $sample_folder = "$const{'preferences folder'}/sample_sites";
		unless (opendir(DIR, $sample_folder)) {
			$err_msg = sprintf( $lang_strings[22], $sample_folder, $! );
			next Err;
			}

		my $checked = ' CHECKED';
		foreach (readdir(DIR)) {
			next unless (m!(.*)\.template$!);
			my $public_name = $1;
			$public_name =~ s!_! !g;
			print "<P><INPUT TYPE=\"radio\" NAME=\"Template\" VALUE=\"$_\"$checked> <B>$public_name</B></P>\n";
			$checked = '';
			}
		closedir(DIR);

print <<"EOM";

		<P><INPUT TYPE=submit CLASS=submit VALUE="Edit Template"></P>

		</FORM>

EOM
		last Err;
		}
	continue {
		printf( $lang_strings[2], $err_msg );
		}
	}



sub ui_ListFiles {
	my $err_msg = '';
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$err_msg = $const{'home_dir_err_msg'};
			next Err;
			}

		unless (opendir(DIR, '.')) {
			$err_msg = sprintf( $lang_strings[22], $STATE{'file_path'}, $! );
			next Err;
			}

		my ($s1, $s2) = (1, 1);
		while ($s1++) {
			last unless (-e "index$s1.html");
			}
		while ($s2++) {
			last unless (-e "folder$s2");
			}

		my %SIZE = ();
		my %DATE = ();

		my %sort_hash = ();

		my @subfolders = ();

		my ($file_size, $file_date) = (0, 0);

		foreach (readdir(DIR)) {
			next if (m!^\.\.?$!);
			next if (m!^\.!);

			($file_size, $file_date) = (0, 0);

			if (-d $_) {
				push(@subfolders, $_);
				if ($STATE{'ShowDirSize'}) {
					$file_size = &FolderSize($_);
					}
				}
			else {
				$file_size = -s $_;
				}

			$file_date = (stat($_))[9];

			if ($STATE{'Sort'} =~ m!s!i) { # sort by size
				$sort_hash{ (10E9 + $file_size) . $_} = $_;
				}
			elsif ($STATE{'Sort'} =~ m!n!i) { # sort by name
				$sort_hash{$_} = $_;
				}
			elsif ($STATE{'Sort'} =~ m!d!i) { # sort by date
				$sort_hash{ (10E9 + $file_date) . $_} = $_;
				}
			elsif (-d $_) { # sort by type (== file extension)
				$sort_hash{"-\.$_"} = $_; # folders have type "-"
				}
			elsif (m!(.*)\.(.*?)!) {
				my $extension = lc($2);
				$sort_hash{"$extension.$_"} = $_; # files with an extension use it:
				}
			else {
				$sort_hash{"_\.$_"} = $_; # files with no extension use "_"
				}

			$SIZE{$_} = $file_size;
			$DATE{$_} = $file_date;

			}
		closedir(DIR);

print <<"EOM";

		<FORM METHOD="get" ACTION="$const{'script_url'}">
		<INPUT TYPE=hidden NAME="Action" VALUE="ListFiles">
$const{'crypt_pass_line'}


		<B>Folder:</B>

		<SELECT NAME="CWD">

EOM

		my $LD = '';
		if ($params{'CWD'}) {
			print "<OPTION VALUE=\"\">$STATE{'Author:UserURL:parsed'}\n";
			foreach (split(m!\/!, $params{'CWD'})) {
				$LD .= $_;
				last if ($LD eq $params{'CWD'});
				print '<OPTION VALUE="', "$LD\">$STATE{'Author:UserURL:parsed'}/$LD\n";
				$LD .= '/';
				}
			}
		print "<OPTION VALUE=\"$params{'CWD'}\" SELECTED>$STATE{'web_path'}\n";
		foreach (@subfolders) {
			$LD = $params{'CWD'};
			$LD .= '/' if $LD;
			print '<OPTION VALUE="', "$LD$_\">$STATE{'web_path'}/$_\n";
			}

print <<"EOM";

		</SELECT><INPUT TYPE=submit CLASS=submit VALUE="Go"></FORM>

		<FORM METHOD="post" ACTION="$const{'script_url'}">
$const{'cwd_line'}
$const{'crypt_pass_line'}

		<TABLE BORDER=1 CELLPADDING=2 CELLSPACING=0>
		<TR>
			<TH COLSPAN=2><A HREF="$const{'admin_url'}Action=SS&SortType=N">Name</A> . <A HREF="$const{'admin_url'}Action=SS&SortType=T">Type</A></TH>
			<TH><A HREF="$const{'admin_url'}Action=SS&SortType=S">Size</A></TH>
			<TH><A HREF="$const{'admin_url'}Action=SS&SortType=D">Last Modified</A></TH>
			<TH COLSPAN=2>Actions</TH>
		</TR>

EOM

		if ($params{'CWD'}) {
			$params{'CWD'} =~ s!/+$!!g;

			my $newdir = '';
			$newdir = $1 if ($params{'CWD'} =~ m!^(.*)/!);
			my $admin_url = $const{'admin_url'};
			$admin_url =~ s!CWD=([^\&]*)!!g;

			printf("<TR><TD><BR></TD><TD><A HREF=\"$STATE{'web_path'}/..\">Parent Directory</A></TD><TD><BR></TD><TD><BR></TD><TD><A HREF=\"%sAction=ListFiles&CWD=$newdir\">updir</A></TD><TD><BR></TD></TR>\n", $admin_url);
			}

		my @Files = sort keys %sort_hash;
		unless ($STATE{'Sort'} =~ m![A-Z]!) {
			@Files = reverse @Files;
			}

		my $i = 0;

		my %icon_by_extension = (
			''      => 'generic',
			'mp3'   => 'music',
			'wav'   => 'sound',
			'html'  => 'html',
			'htm'   => 'html',
			'shtml' => 'html',
			'hqx'   => 'hqx',
			'txt'   => 'text',
			'text'  => 'text',
			'zip'   => 'zip',
			'gz'    => 'zip',
			'tar'   => 'tar',
			'pl'    => 'pl',
			'pdf'   => 'pdf',
			);


		foreach (@Files) {

			my $FH = $sort_hash{$_};

			my $size = &FormatNumber( $SIZE{$FH}, 0, 0, 0, 1 );
			my $last_modified = &FormatDateTime($DATE{$FH}, 0, 0);

			my $image = "icon_image.gif";

			my $extension = '';
			if ($FH =~ m!\.([^\.]+)$!) {
				$extension = lc($1);
				}
			if ($icon_by_extension{$extension}) {
				$image = "icon_$icon_by_extension{$extension}.gif";
				}

			my $action = '<BR>';
			if (-T $FH) {
				$action = "<A HREF=\"$const{'admin_url'}Action=Edit\&FH=$FH\">edit</A>";
				}
			elsif (-d $FH) {
				$image = "icon_dir.gif";

				if (-e "$FH/.is_user_dir") {
					$image = "icon_dir_secure.gif";
					}

				my $newdir = '';
				$newdir = "$params{'CWD'}/" if ($params{'CWD'});
				$newdir .= $FH;

				my $admin_url = $const{'admin_url'};
				$admin_url =~ s!CWD=([^\&]*)!!g;

				$action = "<A HREF=\"" . $admin_url . "Action=ListFiles&CWD=$newdir\">chdir</A>";

				}

			my $bgcolor = '';
			$i++;
			if ($i % 2) {
				$bgcolor = ' BGCOLOR=#eeeeee';
				}

			$image = "<IMG SRC=\"$security{'Images URL'}/$image\" HSPACE=5 BORDER=0>";


print <<"EOM";

<TR$bgcolor VALIGN="middle">
	<TD><INPUT TYPE=checkbox NAME="FH:$FH"></TD>
	<TD><A HREF="$STATE{'web_path'}/$FH">$image$FH</A></TD>
	<TD ALIGN="right"><TT>$size</TT></TD>
	<TD><TT>$last_modified</TT></TD>
	<TD>$action</TD>
	<TD><A HREF="$const{'admin_url'}Action=Delete&FH:$FH=1">delete</A></TD>
</TR>

EOM

			}

print <<"EOM";

		</TABLE>

		<BR>

		<TABLE BORDER=0 CELLPADDING=0 CELLSPACING=0>
		<TR VALIGN="top">
			<TD><TABLE BORDER=1 CELLPADDING=2 CELLSPACING=0><TR VALIGN="top"><TD><INPUT TYPE=checkbox CHECKED DISABLED></TD></TR></TABLE></TD>
			<TD>&nbsp; Checked Items =&gt; <INPUT TYPE=submit CLASS=submit NAME="Action" VALUE="Rename"> - <INPUT TYPE=submit CLASS=submit NAME="Action" VALUE="Copy"> - <INPUT TYPE=submit CLASS=submit NAME="Action" VALUE="Delete"></TD>
		</TR>
		</TABLE>
		</FORM>

<P><BR></P>

<TABLE BORDER=0>
<TR>

<FORM METHOD="post" ACTION="$const{'script_url'}">
<INPUT TYPE="hidden" NAME="Action" VALUE="Edit">
$const{'cwd_line'}
$const{'crypt_pass_line'}

	<TD><IMG SRC="$security{'Images URL'}/icon_html.gif" ALT="" HSPACE=8 HEIGHT=22 WIDTH=20></TD>
	<TD ALIGN="right"><B>Create HTML File:</B></TD>
	<TD><INPUT NAME="FH" VALUE="index$s1.html"> <INPUT TYPE=submit CLASS=submit VALUE="Create..."></TD>

	</FORM>

</TR>
<TR>

<FORM METHOD="post" ACTION="$const{'script_url'}">
<INPUT TYPE="hidden" NAME="Action" VALUE="makedir">
$const{'cwd_line'}
$const{'crypt_pass_line'}

	<TD><IMG SRC="$security{'Images URL'}/icon_dir.gif" ALT="" HSPACE=8 HEIGHT=22 WIDTH=20></TD>
	<TD ALIGN="right"><B>Create Folder:</B></TD>
	<TD><INPUT NAME="directory" VALUE="folder$s2"> <INPUT TYPE=submit CLASS=submit VALUE="Create..."></TD>

	</FORM>
</TR>
<TR>

<FORM METHOD="post" ACTION="$const{'script_url'}" ENCTYPE="multipart/form-data">
<INPUT TYPE="hidden" NAME="Action" VALUE="upload">
$const{'cwd_line'}
$const{'crypt_pass_line'}

	<TD><IMG SRC="$security{'Images URL'}/icon_image.gif" ALT="" HSPACE=8 HEIGHT=22 WIDTH=20></TD>
	<TD ALIGN="right"><B>Upload File:</B></TD>
	<TD><INPUT TYPE="file" NAME="FH"> <INPUT TYPE=submit CLASS=submit VALUE="Upload..."></TD>

	</FORM>
</TR>
</TABLE>

EOM

print <<"EOM" if ($const{'mode'} != 3);

<P><B>See Also:</B>
	<A HREF="$const{'admin_url'}Action=multi-upload">Multiple File Upload</A> -
	<A HREF="$const{'admin_url'}Action=image-review">Review Images</A> -
	<A HREF="$const{'admin_url'}Action=html-review">Review/Validate HTML</A></P>

EOM

		print '<P><BR></P>';

		last Err;
		}
	continue {
		printf( $lang_strings[2], $err_msg );
		}
	}


=item form_ImageReview()

Usage:
	&form_ImageReview();

=cut

sub form_ImageReview {
	my $err_msg = '';
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$err_msg = $const{'home_dir_err_msg'};
			next Err;
			}

print <<"EOM";

<P><B>Review All Images</B></P>
<FORM>

EOM

	my @ImageFiles = &GetFiles( $STATE{'file_path'}, "\.(jpg|jpeg|bmp|gif)\$" );
	foreach (sort @ImageFiles) {
		my ($err_msg, $x, $y, $filesize) = &image_size( $_ );

		my $rel_path = $_;
		$rel_path =~ s!^$STATE{'file_path'}/!!o;

		if ($err_msg) {
print <<"EOM";

EOM
			}
		else {
			my $html = &html_encode( "<IMG SRC=\"$STATE{'web_path'}/$rel_path\" BORDER=1 WIDTH=$x HEIGHT=$y>" );
			$filesize = &FormatNumber( $filesize, 0, 0, 0, 1 );

print <<"EOM";

<HR SIZE=1>
<TABLE BORDER=0>
<TR>
	<TD ALIGN=right><B>Path:</B></TD>
	<TD COLSPAN=2><A HREF="$STATE{'web_path'}/$rel_path">$rel_path</A></TD>
</TR>
<TR>
	<TD ALIGN=right><B>Size:</B></TD>
	<TD ALIGN=right>$filesize</TD>
	<TD>bytes</TD>
</TR>
<TR>
	<TD ALIGN=right><B>Width:</B></TD>
	<TD ALIGN=right>$x<BR></TD>
	<TD>pixels</TD>
</TR>
<TR>
	<TD ALIGN=right><B>Height:</B></TD>
	<TD ALIGN=right>$y<BR></TD>
	<TD>pixels</TD>
</TR>
<TR>
	<TD ALIGN=right><B>Commands:</B></TD>
	<TD COLSPAN=2>
		<A HREF="$const{'admin_url'}Action=Rename&FH:$rel_path=1">Rename</A> -
		<A HREF="$const{'admin_url'}Action=Copy&FH:$rel_path=1">Copy</A> -
		<A HREF="$const{'admin_url'}Action=Delete&FH:$rel_path=1">Delete</A>

	</TD>
</TR>
<TR>
	<TD ALIGN=right><B>HTML:</B></TD>
	<TD COLSPAN=2><BR></TD>
</TR>
</TABLE>
<P><TEXTAREA ROWS=3 COLS=80 NAME"$rel_path">$html</TEXTAREA></P>
<P><IMG SRC="$STATE{'web_path'}/$rel_path" BORDER=1 WIDTH=$x HEIGHT=$y ALT="$rel_path"></P>
EOM
				}
			}
		print "</FORM>";
		last Err;
		}
	continue {
		printf( $lang_strings[2], $err_msg );
		}
	}





=item form_HTML_Review()

Usage:
	&form_HTML_Review();

=cut

sub form_HTML_Review {
	my $err_msg = '';
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$err_msg = $const{'home_dir_err_msg'};
			next Err;
			}

print <<"EOM";

<P><B>Review All HTML Pages</B></P>

<TABLE BORDER=0 CELLPADDING=4 CELLSPACING=1 BGCOLOR="#000000">
<TR BGCOLOR="#9eb3c7">
	<TH>Path</TH>
	<TH>Size</TH>
	<TH>Actions</TH>
</TR>

EOM

	my @ImageFiles = &GetFiles( $STATE{'file_path'}, "\.(html|htm|shtml|stm)\$" );
	foreach (sort @ImageFiles) {

		my $rel_path = $_;

		my $size = &FormatNumber(-s $rel_path, 0, 0, 0, 1);
		$rel_path =~ s!^$STATE{'file_path'}/!!o;

		my $url = $STATE{'web_path'} . '/' . $rel_path;
		my $urlurl = &url_encode($url);

		if ($err_msg) {
print <<"EOM";

EOM
			}
		else {

print <<"EOM";

	<TR BGCOLOR="#d5d2bb">
		<TD>$rel_path</TD>
		<TD ALIGN=right>$size</TD>
		<TD><A HREF="http://validator.w3.org/check?uri=$urlurl">Validate HTML</A></TD>
	</TR>

EOM
				}
			}
		print "</TABLE>";
		last Err;
		}
	continue {
		printf( $lang_strings[2], $err_msg );
		}
	}





=item form_BulkUpload

Usage:
	&form_BulkUpload();

=cut

sub form_BulkUpload {
	my $err_msg = '';
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$err_msg = $const{'home_dir_err_msg'};
			next Err;
			}

		my $field_count = $STATE{'multi_upload_count'};

		if ($params{'multi_upload_count'}) {
			$field_count = $params{'multi_upload_count'};
			my %overrides = (
				'multi_upload_count' => $field_count,
				);
			my $err_msg = &SaveUserPrefs( $STATE{'Username'}, \%overrides, 1 );
			if ($err_msg) {
				&Report( sprintf( $lang_strings[2], $err_msg ) );
				}
			}

print <<"EOM";

<FORM METHOD="post" ACTION="$const{'script_url'}" ENCTYPE="multipart/form-data">
<INPUT TYPE="hidden" NAME="Action" VALUE="upload">
$const{'cwd_line'}
$const{'crypt_pass_line'}

<P><B>Upload Files</B></P>

EOM

for (1..$field_count) {
	print "<P>File: <INPUT TYPE=\"file\" NAME=\"file$_\" SIZE=60></P>\n";
	}

print &SetDefaults(<<"EOM", \%STATE);

<P><INPUT TYPE=submit CLASS=submit VALUE="Upload Now"></P>

</FORM>

<P><BR></P>
<HR SIZE=1>
<P><BR></P>

<FORM METHOD="post" ACTION="$const{'script_url'}">
<INPUT TYPE="hidden" NAME="Action" VALUE="multi-upload">
$const{'cwd_line'}
$const{'crypt_pass_line'}

	<P>Allow
		<SELECT NAME="multi_upload_count">
			<OPTION VALUE="10">10
			<OPTION VALUE="15">15
			<OPTION VALUE="25">25
			<OPTION VALUE="50">50
			<OPTION VALUE="100">100
		</SELECT>
	files to be uploaded. <INPUT TYPE=submit CLASS=submit VALUE="Set"></P>

</FORM>



EOM
		last Err;
		}
	continue {
		printf( $lang_strings[2], $err_msg );
		}
	}



sub BuildTemplate {
	my $err_msg = '';
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$err_msg = $const{'home_dir_err_msg'};
			next Err;
			}
		my $FILE = $const{'preferences folder'} . '/sample_sites/' . $params{'Template'};

		my $text = '';

		# Has this template been used before?
		my %replace_values = ();
		if (-e ".$params{'Template'}") {
			($err_msg, $text) = &ReadFile( ".$params{'Template'}" );
			foreach (split(m!\n!, $text)) {
				next unless (m!^(.*)\=(.*)$!);
				$replace_values{lc($1)} = $2;
				}
			}


		($err_msg, $text) = &ReadFile( $FILE );
		next Err if ($err_msg);

print <<"EOM";

<FORM METHOD="post" ACTION="$const{'script_url'}">
<INPUT TYPE="hidden" NAME="Action" VALUE="VT">
$const{'cwd_line'}
$const{'crypt_pass_line'}

		<INPUT TYPE="hidden" NAME="Template" VALUE="$params{'Template'}">

		<P>Fill out the form below, and then click "Build Web Site".</P>
		<HR SIZE=1>
EOM

		my $ready = 0;
		Line: foreach (split(m!\n!, $text)) {

			last if (m!</GENESIS:USERINPUT>!i);
			next if (m!^\#!);

			if (m!<GENESIS:USERINPUT>!i) {
				$ready = 1;
				next;
				}
			next unless ($ready);

			if (m!^(.*)<INPUT TYPE="(radio|checkbox)" NAME="(.+?)" VALUE="(.+?)"(.*)$!i) {
				my ($start, $type, $name, $value, $end) = ($1, $2, $3, $4, $5);
				if (($replace_values{$name}) and ($replace_values{$name} eq $value)) {
					$_ = "$start<INPUT TYPE=\"$type\" NAME=\"$name\" CHECKED VALUE=\"$value\"$end";
					}
				}
			elsif (m!^(.*)<INPUT TYPE="text" NAME="(.+?)"(.*)$!i) {
				my ($start, $name, $end) = ($1, $2, $3);
				if ($replace_values{$name}) {
					my $value = &html_encode( $replace_values{$name} );
					$_ = "$start<INPUT TYPE=\"text\" VALUE=\"$value\" NAME=\"$name\"$end";
					}
				}
			my $key = ();
			foreach $key (keys %replace_values) {
				s!\%$key\%!$replace_values{$key}!sig;
				}
			s!\%\w+\%!!sg;
			print "$_\n";
			}

print <<"EOM";

		<HR SIZE=1>
		<P><INPUT TYPE=submit CLASS=submit VALUE="Build Web Site"></P>
		</FORM>

		<P>This template creates the following files:</P>
		<UL>
EOM

		foreach (split(m!</GENESIS:FILE>!si, $text)) {
			next unless (m!<GENESIS:FILE NAME=\"(.*?)\">(.*)!si);
			my ($file) = ($1);
			if (-e $file) {
				print "<LI> <A HREF=\"$STATE{'web_path'}/$file\">$file</A> - will overwrite your existing file\n";
				}
			else {
				print "<LI> $file\n";
				}
			}

print <<"EOM";

		</UL>

EOM




		last Err;
		}
	continue {
		printf( $lang_strings[2], $err_msg );
		}

	}


sub SaveTemplate {
	my $err_msg = '';
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$err_msg = $const{'home_dir_err_msg'};
			next Err;
			}
		my %replace_values = ();

		my $text = '';
		my ($name, $value) = ();
		while (($name, $value) = each %params) {
			$value =~ s!(\r|\n|\015|\012)!!g;
			$name =~ s!\=!!g;
			$replace_values{$name} = $value;
			$text .= "$name=$value\n";
			}

		$err_msg = &WriteFile( ".$params{'Template'}", $text );
		next Err if ($err_msg);

		($err_msg, $text) = &ReadFile( "$const{'preferences folder'}/sample_sites/$params{'Template'}" );
		next Err if ($err_msg);

		my @temp_errors = ();
		my $temp_err_msg = '';

		my $prime_file = '';
		my $prime_complete = 0;

		foreach (split(m!\n!, $text)) {
			next unless (m!<GENESIS:IMPORT FROM=\"(.*?)\" TO=\"(.*?)\">!i);
			my ($rel_old_file, $new_file) = ($1, $2);
			my $abs_old_file = "$const{'preferences folder'}/sample_sites/$rel_old_file";

			my $is_cgi = 0;
			($temp_err_msg, $is_cgi) = &CheckName( $new_file );
			if ($temp_err_msg) {
				push(@temp_errors, $temp_err_msg);
				next;
				}
			my $contents = '';
			($temp_err_msg, $contents) = &ReadFile( $abs_old_file );
			if ($temp_err_msg) {
				push(@temp_errors, $temp_err_msg);
				next;
				}
			($temp_err_msg) = &WriteFile( $new_file, $contents );
			if ($temp_err_msg) {
				push(@temp_errors, $temp_err_msg);
				next;
				}
			}

		#changed 0009 - map \n => <BR>\n
		my $key = ();
		foreach $key (keys %params) {
			# don't map if the sample contains HTML tags itself
			next if ($params{$key} =~ m!\<.*\>!s);
			# don't map if the key is a noconvert_ key
			next if ($key =~ m!^noconvert_!);
			$params{$key} =~ s!\cM!!sg;
			$params{$key} =~ s!\n!<BR>\n!sg;
			}
		#end changes


		foreach (split(m!</GENESIS:FILE>!si, $text)) {
			next unless (m!<GENESIS:FILE NAME=\"(.*?)\">(.*)!si);
			my ($file, $text) = ($1, $2);

			my $is_cgi = 0;
			($temp_err_msg, $is_cgi) = &CheckName( $file );
			if ($temp_err_msg) {
				push(@temp_errors, $temp_err_msg);
				next;
				}

			$prime_file = $file unless ($prime_file);

			my $key = ();
			foreach $key (reverse sort keys %params) {
				$text =~ s!\%$key\%!$params{$key}!sig;
				}
			$text =~ s!\cM!!sg;

			my $file_size = length($text);
			$file_size -= (-s $file) if (-s $file);
			unless (($file_size < 0) || (&CheckFreeSpace($file_size))) {
				push(@temp_errors, sprintf( $lang_strings[9], $file, $lang_strings[29] ));
				last;
				}

			$temp_err_msg = &WriteFile( $file, $text );
			if ($temp_err_msg) {
				push(@temp_errors, $temp_err_msg);
				next;
				}
			if ($file eq $prime_file) {
				$prime_complete = 1;
				}
			}

		foreach (@temp_errors) {
			&Report( sprintf( $lang_strings[2], $_ ) );
			}
		print "<P>Your <A HREF=\"$STATE{'web_path'}/$prime_file\">template web site</A> is complete.</P>\n";

		last Err;
		}
	continue {
		&Report( sprintf( $lang_strings[2], $err_msg ) );
		}
	}


=item ui_Edit($)

Usage:
	&Edit( $file );

Creates an HTML form displaying the contents of $file for editing.

=cut

sub ui_Edit {
	my ($file) = @_;
	my $err_msg = '';
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$err_msg = $const{'home_dir_err_msg'};
			next Err;
			}
		my $is_cgi = 0;
		($err_msg, $is_cgi) = &CheckName( $file );
		next Err if ($err_msg);

		my $readthis = $file;
		if (-e ".ssi.$file") {
			$readthis = ".ssi.$file";
			}

		my $text = '';
		if (-e $readthis) {

			($err_msg, $text) = &ReadFile( $readthis );
			next Err if ($err_msg);

			$text = &html_encode($text);
			}
		else {
			($err_msg, $text) = &ReadFile( "$const{'preferences folder'}/sample_sites/default_html_page.txt" );
			next Err if ($err_msg);

			$text = &html_encode($text);
			}

		unless ($STATE{'Concise'}) {
			if ($text) {
				print "<P>Modify <A HREF=\"$STATE{'web_path'}/$file\">$file</A> as needed:<P>\n";
				}
			else {
				print "<P>This is a new file. Input your text below:<P>\n";
				}

			}

		my $wrap_tag = '';
		if ($STATE{'TextWrap'}) {
			$wrap_tag = ' WRAP="virtual"';
			}

print <<"EOM";

<FORM METHOD="post" ACTION="$const{'script_url'}">
<INPUT TYPE="hidden" NAME="Action" VALUE="Write">
$const{'cwd_line'}
$const{'crypt_pass_line'}

<P><TEXTAREA NAME="file" $wrap_tag ROWS=$STATE{'Rows'} COLS=$STATE{'Cols'} STYLE="font-size:$STATE{'FontSize'}pt">$text</TEXTAREA></P>
<P><INPUT NAME="FH" VALUE="$file"> - <INPUT TYPE=submit CLASS=submit VALUE="Save"></P>

EOM

if ($STATE{'allow_cgi'}) {
	my $c = ($file eq $readthis) ? '' : 'CHECKED';
	print <<"EOM";

<P><INPUT TYPE=checkbox $c NAME="parse_ssi" VALUE="1"> Parse server-side include statements.</P>

EOM
	}

print <<"EOM";

</FORM>

		<P>Entering an alternate filename will leave file '$file' untouched, and will place the above text into a file with the alternate name, overwriting the existing contents if the file already exists.</P>

EOM
		last Err;
		}
	continue {
		&Report( sprintf( $lang_strings[2], $err_msg ) );
		}
	}


=item ui_Write($$)

Usage:
	&ui_Write( $file, $text );

Dependencies:
	&CheckName
	&CheckFreeSpace
	&Mask
	&Report

=cut

sub ui_Write {
	my ($file, $text) = @_;

	my $err_msg = '';
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$err_msg = $const{'home_dir_err_msg'};
			next Err;
			}
		my $is_cgi = 0;
		($err_msg, $is_cgi) = &CheckName( $file );
		next Err if ($err_msg);

		&Mask( $file, $is_cgi ) if (-e $file);

		my $SIZE = length($text);
		$SIZE -= (-s $file) if (-e $file);
		unless (($SIZE < 0) or (&CheckFreeSpace(length($SIZE)))) {
			$err_msg = sprintf( $lang_strings[9], $file, $lang_strings[29] );
			next Err;
			}

		$text =~ s!\cM\n!\n!g;

		if (($STATE{'allow_cgi'}) and ($params{'parse_ssi'})) {
			my $shadow_file = '.ssi.' . $file;
			$err_msg = &WriteFile( $shadow_file, $text );
			next Err if ($err_msg);

			my $parsed_text = &PrintTemplateEx( 1, $shadow_file, '.' );
			$err_msg = &WriteFile( $file, $parsed_text );
			next Err if ($err_msg);

			}
		else {
			$err_msg = &WriteFile( $file, $text );
			next Err if ($err_msg);
			}

		&Mask( $file, $is_cgi );
		&Report( sprintf( $lang_strings[4], sprintf( $lang_strings[16], $file ) ) );
		last Err;
		}
	continue {
		&Report( sprintf( $lang_strings[2], $err_msg ) );
		}
	}


=item ui_Upload()

Usage:
	&ui_Upload( \%upload_files );

=cut

sub ui_Upload {
	my $err_msg = '';
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$err_msg = $const{'home_dir_err_msg'};
			next Err;
			}

		my ($p_upload_files) = @_;
		my $upload_success = 0;

		my ($name, $p_data) = ();
		while (($name, $p_data) = each %$p_upload_files) {
			my $file = $$p_data{'client file name'};
			next unless ($file);

			$file = $3 if ($file =~ m!^(.*)(\\|/)(.*?)$!);

			$file =~ s! !_!g;

			my $is_cgi = 0;
			($err_msg, $is_cgi) = &CheckName( $file );
			next Err if ($err_msg);

			&Mask( $file, $is_cgi ) if (-e $file);

			my $SIZE = $$p_data{'size'};
			if (($SIZE > 0) and (not &CheckFreeSpace($SIZE))) {
				$err_msg = sprintf( $lang_strings[9], $file, $lang_strings[29] );
				next Err;
				}

			my $FullText = '';

			my $TempFile = $$p_data{'temp file'};
			my $MODE = 'binary';
			if ((-T $TempFile) and ($STATE{'TextUpload'})) {
				$MODE = 'ascii/text';
				}

			unless (open(FILE, ">$file")) {
				$err_msg = sprintf( $lang_strings[9], $file, $! );
				next Err;
				}

			unless (binmode(FILE)) {
				$err_msg = sprintf( $lang_strings[12], $file, $! );
				next Err;
				}

			unless (open(TEMP, "<$TempFile")) {
				$err_msg = sprintf( $lang_strings[8], $TempFile, $! );
				next Err;
				}

			unless (binmode(TEMP)) {
				$err_msg = sprintf( $lang_strings[12], $TempFile, $! );
				next Err;
				}
			if ($MODE eq 'ascii/text') {
				while (<TEMP>) {
					s!\cM\n!\n!sg;
					s!\015\012!\012!sg;
					print FILE;
					}
				}
			else {
				while (<TEMP>) {
					print FILE;
					}
				}
			close(FILE);
			close(TEMP);

			&Mask( $file, $is_cgi );

			&Report( sprintf( $lang_strings[4], "file '$file' has been uploaded in $MODE mode" ) );
			$upload_success++;
			}
		if (($STATE{'Sound'}) and ($upload_success)) {
			printf( '<EMBED SRC="%s/done.wav" AUTOSTART="true" HIDDEN="true" LOOP="false">', $security{'Images URL'} );
			}
		last Err;
		}
	continue {
		&Report( sprintf( $lang_strings[2], $err_msg ) );
		}
	}



=item create_folder($)

Usage:
	&create_folder( $folder );

=cut

sub create_folder {
	my ($file) = @_;
	my $err_msg = '';
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$err_msg = $const{'home_dir_err_msg'};
			next Err;
			}

		my $is_cgi = 0;
		($err_msg, $is_cgi) = &CheckName( $file );
		next Err if ($err_msg);

		unless (mkdir($file, 0777)) {
			$err_msg = sprintf( $lang_strings[21], $file, $! );
			next Err;
			}
		&Mask( $file, 0 );

		&Report( sprintf( $lang_strings[4], sprintf( $lang_strings[25], $file ) ) );
		last Err;
		}
	continue {
		&Report( sprintf( $lang_strings[2], $err_msg ) );
		}
	}


=item FolderSize($)

Usage:
	$bytes = &FolderSize( $folder_name );

=cut

sub FolderSize {
	my $size = 0;
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$err_msg = $const{'home_dir_err_msg'};
			next Err;
			}

		my ($DIR) = @_;
		$DIR =~ s!\\!/!g;
		$DIR =~ s!/$!!o;

		next Err unless (opendir(DIR, $DIR));
		my @Files = readdir(DIR);
		closedir(DIR);

		foreach (@Files) {
			next if (m!^\.\.?$!);
			my $abs_path = "$DIR/$_";
			if (-d $abs_path) {
				$size += &FolderSize( $abs_path );
				}
			else {
				$size += (-s $abs_path);
				}
			}
		}
	return $size;
	}






sub ui_Confirmed {
	my ($object_name) = @_;
	if (($params{'Y'}) and ($params{'Y'} eq 'Y1')) {
		delete $params{'Y'};
		return 1;
		}

print <<"EOM";

	<P>Are you sure you want to delete '$object_name'?</P>

	<BLOCKQUOTE>

		<FORM METHOD="post" ACTION="$const{'script_url'}">
		<INPUT TYPE="hidden" NAME="Y" VALUE="Y1">

EOM

	my ($name, $value);
	while (($name, $value) = each %params) {
		next if ($name =~ m!^(cwd|web_auth_cp|y|sw)$!i);
		printf( '<INPUT TYPE=hidden NAME="%s" VALUE="%s">', &html_encode($name), &html_encode($value));
		}

print <<"EOM";

		$const{'cwd_line'}
		$const{'crypt_pass_line'}

		<P><INPUT TYPE=submit CLASS=submit VALUE="Yes, I'm Sure"></P>

		</FORM>

	</BLOCKQUOTE>

EOM
	return 0;
	}


sub ui_ManageUsers {

	my $err_msg = '';
	Err: {

print <<"EOM";

<P><B>
	<A HREF="$const{'admin_url'}Action=Main">Main</A> /
	<A HREF="$const{'admin_url'}Action=UA">Manage Users</A> /

EOM

		my $subaction = $params{'sa'} || '';

		if ($subaction eq 'DU') {
			print " Delete User</B></P>";

			my $username = $params{'UN'};

			last Err unless &ui_Confirmed($username);

			my $warnings = 0;

			my %TMP = ();
			&LoadUserPrefs( $username, \%TMP );

			my $UserDIR = $TMP{'Author:UserFolder:parsed'};

			my $file = "$UserDIR/.is_user_dir";
			if ((-e $file) and (not (unlink($file)))) {
				$err_msg = sprintf( $lang_strings[13], $file, $! );
				&Report( sprintf( $lang_strings[3], $err_msg ) );
				$warnings++;
				}

			my $UserFile = "$const{'preferences folder'}/accounts/$username.txt";
			if ((-e $UserFile) and (not (unlink($UserFile)))) {
				$err_msg = sprintf( $lang_strings[13], $UserFile, $! );
				&Report( sprintf( $lang_strings[3], $err_msg ) );
				$warnings++;
				}

			$err_msg = $auth->DeleteUser($username);
			if ($err_msg) {
				&Report( sprintf( $lang_strings[3], $err_msg ) );
				$warnings++;
				}

			if ($warnings) {
				&Report( sprintf( $lang_strings[4], "finished trying to remove user account '$username' - some steps did not complete successfully" ) );
				}
			else {
				&Report( sprintf( $lang_strings[4], "removed user account '$username'" ) );
				}

			print "<P>All files in the user's home folder '$UserDIR' are still present. Deleting files must be done separately.</P>\n";

			last Err;
			}
		elsif ($subaction eq 'EP') {
			print "<A HREF=\"$const{'admin_url'}Action=UA&sa=EP&UN=$params{'UN'}\">Account '$params{'UN'}'</A> / Overview</B></P>";
			&ShowSettings( $params{'UN'}, 0, 0);
			last Err;
			}
		elsif ($subaction eq 'NA') {
			print " New Account</B></P>";
			&ShowSettings( '', 0, 1);
			last Err;
			}
		elsif ($subaction eq 'SP') {
			print "<A HREF=\"$const{'admin_url'}Action=UA&sa=EP&UN=$params{'UN'}\">Account '$params{'UN'}'</A> / Save Data</B></P>";
			&Save_Preferences( $params{'UN'}, 0 );
			last Err;
			}
		elsif ($subaction eq 'CU') {
			print " Create User</B></P>";
			&CreateUser();
			last Err;
			}
		elsif ($subaction eq 'RP') {
			print " Reset Password</B></P>";
			&Give_Password();
			last Err;
			}
		elsif ($subaction eq 'SA') {
			print " Reset Password / Save Data</B></P>";
			if ($const{'super user'} eq $params{'UN'}) {
				&Save_Password( $params{'UN'}, $params{'OldPass'}, $params{'NewPass'}, $params{'NewPass2'}, 1 );
				}
			else {
				&Save_Password( $params{'UN'}, '', $params{'NewPass'}, $params{'NewPass2'}, 0 );
				}
			last Err;
			}
		else {
			print " Overview</B></P>";
			}

		my $accounts_dir = "$const{'preferences folder'}/accounts";
		unless (opendir(DIR, $accounts_dir)) {
			$err_msg = sprintf( $lang_strings[22], $accounts_dir, $! );
			next Err;
			}

print <<"EOM";

<TABLE BORDER=0 CELLPADDING=4 CELLSPACING=1 BGCOLOR="#000000">
<TR BGCOLOR="#9eb3c7">
	<TH>Username</TH>
	<TH>Account Created</TH>
	<TH>Last Accessed</TH>
	<TH COLSPAN=3>Actions</TH>
</TR>
<TR BGCOLOR="#d5d2bb">
	<TD><IMG SRC="$security{'Images URL'}/user_admin.gif" HEIGHT=15 WIDTH=15> $const{'super user'}</TD>
	<TD><BR></TD>
	<TD><BR></TD>
	<TD><A HREF="$const{'admin_url'}Action=UA&UN=$const{'super user'}&sa=EP">Edit Profile</A></TD>
	<TD><BR></TD>
	<TD><BR></TD>
</TR>
<TR BGCOLOR="#d5d2bb">
	<TD><IMG SRC="$security{'Images URL'}/user_admin.gif" HEIGHT=15 WIDTH=15> _default</TD>
	<TD><BR></TD>
	<TD><BR></TD>
	<TD><A HREF="$const{'admin_url'}Action=UA&UN=_default&sa=EP">Edit Profile</A></TD>
	<TD><BR></TD>
	<TD><BR></TD>
</TR>

EOM

		my %userdata = ();

		my $i = 1;
		foreach (sort readdir(DIR)) {
			next unless (m!(.*)\.txt$!i);
			my $User = $1;
			next if ($User eq $const{'super user'});
			next if ($User eq '_default');

			my $bgcolor = ' BGCOLOR=#eeeeee';
			$i++;
			$bgcolor = '' if ($i % 2);

			&LoadUserPrefs( $User, \%userdata );

			my $date_created_str = &FormatDateTime( $userdata{'AccountCreated'}, 14, 0 );

			my $time_str = 'never';
			if ($userdata{'LastLogin'}) {
				my $age = time() - $userdata{'LastLogin'};
				if ($age > (2 * 86400)) {
					$time_str = int($age / 86400) . ' days ago';
					}
				elsif ($age > (100 * 60)) {
					$time_str = int($age / 3600) . ' hours ago';
					}
				else {
					$time_str = int($age / 60) . ' min ago';
					}
				}

print <<"EOM";

<TR BGCOLOR="#d5d2bb">
	<TD><IMG SRC="$security{'Images URL'}/user_normal.gif" HEIGHT=15 WIDTH=15> $User</TD>
	<TD><TT>$date_created_str</TT></TD>
	<TD ALIGN=right><TT>$time_str</TT></TD>
	<TD><A HREF="$const{'admin_url'}Action=UA&UN=$User&sa=EP">Edit Profile</A></TD>
	<TD><A HREF="$const{'admin_url'}Action=UA&UN=$User&sa=RP">Reset Password</A></TD>
	<TD><A HREF="$const{'admin_url'}Action=UA&UN=$User&sa=DU">Delete</A></TD>
</TR>

EOM
			}
		closedir(DIR);

print <<"EOM";

</TABLE>

<P><B>[ <A HREF="$const{'admin_url'}Action=UA&sa=NA">New Account</A> ]</B></P>

EOM


		last Err;
		}
	continue {
		&Report( sprintf( $lang_strings[2], $err_msg ) );
		}
	}



sub Give_Password {

print <<"EOM";

	<FORM METHOD="post" ACTION="$const{'script_url'}">
$const{'cwd_line'}
$const{'crypt_pass_line'}

	<INPUT TYPE="hidden" NAME="Action" VALUE="UA">
	<INPUT TYPE="hidden" NAME="sa" VALUE="SA">
	<INPUT TYPE="hidden" NAME="UN" VALUE="$params{'UN'}">

	<P>Assigning new password for user '$params{'UN'}':</P>
	<TABLE BORDER=0>
	<TR>
		<TD ALIGN="right">Password:</TD>
		<TD><INPUT TYPE="password" NAME="NewPass"></TD>
	</TR>
	<TR>
		<TD ALIGN="right">Confirm:</TD>
		<TD><INPUT TYPE="password" NAME="NewPass2"></TD>
	</TR>
	</TABLE>
	<P><INPUT TYPE=submit CLASS=submit VALUE="Set Password"></P>

	</FORM>

EOM

	}


sub Report {
	my ($message, $do_not_print_to_screen) = @_;
	print $message unless ($do_not_print_to_screen);
	if (-e $const{'event log'}) {
		if (open(LOG, ">>$const{'event log'}")) {
			my $time = time();
			$message =~ s!<.*?>!!g;
			$message =~ s!\,!!g;
			my $remote_addr = &query_env('REMOTE_ADDR');
			print LOG "$remote_addr , $STATE{'Username'},$time,$message\n";
			close(LOG);
			}
		else {
			printf( $lang_strings[2], sprintf( $lang_strings[10], $const{'event log'}, $! ) );
			}
		}
	}



=item ui_ManageLog()

Manages admin options related to the log - viewing it, resetting it, and deleting.

=cut

sub ui_ManageLog {
	my $err_msg = '';
	Err: {

		print "<P><B><A HREF=\"$const{'admin_url'}Action=Main\">Main</A> / <A HREF=\"$const{'admin_url'}Action=EventLog\">Event Log</A> / ";

		if ($params{'Stop'}) {
			print " Stop</B></P>";
			unless (unlink($const{'event log'})) {
				$err_msg = sprintf( $lang_strings[13], $const{'event log'}, $! );
				next Err;
				}
			printf( $lang_strings[4], sprintf( $lang_strings[19], $const{'event log'} ) );
			last Err;
			}
		elsif ($params{'CMD'} eq 'Start') {
			print " Start</B></P>";
			unless (-e $const{'event log'}) {
				$err_msg = &WriteFile( $const{'event log'}, '' );
				next Err if ($err_msg);
				}
			&Report( sprintf( $lang_strings[4], "logging has been started" ) );
			last Err;
			}
		elsif ($params{'CMD'}) {
			print " Reset</B></P>";
			$err_msg = &WriteFile( $const{'event log'}, '' );
			next Err if ($err_msg);
			&Report( sprintf( $lang_strings[4], "the event log has been cleared" ) );
			last Err;
			}
		else {
			print " Overview</B></P>";
			}

		unless (-e $const{'event log'}) {

print <<"EOM";

			<FORM METHOD="post" ACTION="$const{'script_url'}">
$const{'cwd_line'}
$const{'crypt_pass_line'}

				<INPUT TYPE="hidden" NAME="Action" VALUE="EventLog">
				<INPUT TYPE="hidden" NAME="CMD" VALUE="Start">

				<P><INPUT TYPE=submit CLASS=submit VALUE="Begin Logging"></P>
				<P>Logging is currently disabled. To turn it on, click the button above.</P>

			</FORM>

EOM
			}
		else {

			unless (open(FILE, "<$const{'event log'}")) {
				$err_msg = sprintf( $lang_strings[8], $const{'event log'}, $! );
				next Err;
				}
			unless (binmode(FILE)) {
				$err_msg = sprintf( $lang_strings[12], $const{'event log'}, $! );
				next Err;
				}

print <<"EOM";

			<P>Listing all events, from oldest to newest.</P>
			<TABLE BORDER=1>
			<TR>
				<TH><NOBR>User IP</NOBR></TH>
				<TH>Username</TH>
				<TH>Time</TH>
				<TH>Event</TH>
			</TR>

EOM

			my $i = 0;
			while (<FILE>) {
				my ($ip, $user, $time, $event) = split(m!\,!);
				$i++;
				if ($i % 2) {
					print "<TR VALIGN=top BGCOLOR=#eeeeee>";
					}
				else {
					print "<TR VALIGN=top>";
					}
				print "<TD>$ip</TD><TD>$user</TD><TD><NOBR>" . &FormatDateTime($time, 14, 0) . "</NOBR></TD><TD>" . &html_encode($event) . "</TD></TR>\n";
				}
			close(FILE);

print <<"EOM";

			</TABLE>

			<FORM METHOD="post" ACTION="$const{'script_url'}">
$const{'cwd_line'}
$const{'crypt_pass_line'}

				<INPUT TYPE="hidden" NAME="Action" VALUE="EventLog">
				<INPUT TYPE="hidden" NAME="CMD" VALUE="Clear">

				<TABLE BORDER=0>
				<TR>
					<TD><INPUT TYPE=submit CLASS=submit VALUE="Clear Event Log"></TD>
				</TR>
				<TR>
					<TD>\&nbsp; <INPUT TYPE=checkbox NAME="Stop"> Stop Logging Process</TD>
				</TR>
				</TABLE>

				<P>The option to stop logging deletes the event log completely - to get it started again, you may need to manually log on to this server.</P>

			</FORM>

EOM
			}
		last Err;
		}
	continue {
		&Report( sprintf( $lang_strings[2], $err_msg ) );
		}
	}



sub CreateUser {

	my $err_msg = '';
	Err: {

		# Create User makes an entry (username.txt) in the preferences directory,
		# and creates a home directory for the new user.  The format is
		# &CreateUser with $params{$Name} = $Value defined. This procedure exits,
		# with an error code, if directory or userfile already exist.

		my $is_cgi = 0;
		($err_msg, $is_cgi) = &CheckName( $params{'Username'} );
		next Err if ($err_msg);

		foreach ($const{'super user'}, '_default') {
			if ($params{'Username'} eq $_) {
				$err_msg = "username '$_' is reserverd";
				next Err;
				}
			}

		my $UserFile = "$const{'preferences folder'}/accounts/$params{'Username'}.txt";
		if (-e $UserFile) {
			$err_msg = "user file '$UserFile' already exists";
			next Err;
			}

		my $UserDIR = $params{'Author:UserFolder'};
		$UserDIR =~ s!\%username\%!$params{'Username'}!ig;
		$UserDIR =~ s!/$!!o;
		if (-e $UserDIR) {
			$err_msg = "user home folder '$UserDIR' already exists";
			printf( $lang_strings[3], $err_msg );
			}
		else {
			unless (mkdir($UserDIR, 0777)) {
				$err_msg = sprintf( $lang_strings[21], $UserDIR, $! );
				next Err;
				}
			}
		&Mask( $UserDIR, 0 );


		$err_msg = &WriteFile( "$UserDIR/.is_user_dir", $params{'Username'} );
		if ($err_msg) {
			printf( $lang_strings[3], $err_msg );
			}
		&Mask( "$UserDIR/.is_user_dir", 0 );


		&Save_Preferences( $params{'Username'}, 0 );
		&Mask( $UserFile, 0 );

		my $password = '';
		if (($params{'NewPass'}) and ($params{'NewPass'} eq $params{'NewPass2'})) {
			$password = $params{'NewPass'};
			}
		else {
			$password = $auth->InventPassword();
			}
		$err_msg = $auth->SetPassword( $params{'Username'}, $password );
		next Err if ($err_msg);

		# Parse the welcome message up here - some fields will be deleted inside &SaveUserPrefs

		my %replace_values = %const;
		foreach (keys %params) {
			$replace_values{$_} = $params{$_};
			}
		my %webmaster_info = ();
		&LoadUserPrefs( $const{'super user'}, \%webmaster_info );
		foreach (keys %webmaster_info) {
			my $name = "webmaster_" . $_;
			$replace_values{$name} = $webmaster_info{$_};
			}
		$replace_values{'password'} = $password;
		my $welcome_message = &PrintTemplateEx( 1, 'welcome_email.txt', "$const{'preferences folder'}/templates/english", \%replace_values );

		&Report( sprintf( $lang_strings[4], "created new user '$params{'Username'}'" ) );

		my $start_site_dir = "$const{'preferences folder'}/sample_sites/start_site";
		if (opendir(DIR, $start_site_dir)) {
			foreach (readdir(DIR)) {
				my $abs_old_file = "$start_site_dir/$_";
				my $abs_new_file = "$UserDIR/$_";
				next if (-e $abs_new_file);
				my ($err_msg_x, $contents) = &ReadFile( $abs_old_file );
				($err_msg_x) = &WriteFile( $abs_new_file, $contents );
				}
			closedir(DIR);
			}

		if ($params{'email_address'}) {
			my $trace = '';
			my $from_addr = $webmaster_info{'email_address'} || $params{'email_address'};
			($err_msg, $trace) = &SendMailEx(
				'host'       => $security{'Mail Server'},
				'to'         => $params{'email_address'},
				'to name'    => $params{'full_name'},
				'from'       => $webmaster_info{'email_address'},
				'from name'  => $webmaster_info{'full_name'},
				'subject'    => "New web authoring account created",
				'message'    => $welcome_message,
				);
			next Err if ($err_msg);
			&Report( sprintf( $lang_strings[4], "sent account information with initial password to '$params{'email_address'}'" ) );
			}
		else {
			print "<P>Set initial account password to '$password'.</P>\n";
			}


		last Err;
		}
	continue {
		&Report( sprintf( $lang_strings[2], $err_msg ) );
		}
	}



# ------------------------------------------------------------------- #
#             Security and Error Reporting Procedures                 #
# ------------------------------------------------------------------- #

# Below are the all-important permission controls for every file
# controlled by Genesis. Forgive the poorly legible code - the first
# permission, 0600, is for your preference files - those should only
# be readable and writable by this script.  The next permission, 0755,
# applies to all directories - you could probably get away with 0700
# here.  The third permission, 0755, is for CGI scripts, *if* they're
# enabled in certain directories.  Again, 0700 will probably work. The
# final permissions number, 0644, is for standard files.  0600 will
# probably work.  Remember, the minimal file permissions are always
# best!!

=item Mask

Usage:
	&Mask( $abs_file, $is_cgi );

Attempts to set file permissions on Unix machine.

Dependencies:
	%security

=cut

sub Mask {
	my ($abs_file, $is_cgi) = @_;

	if (-d $abs_file) {
		chmod( $security{'Permission - Folder - eval'}, $abs_file);
		}
	elsif (($is_cgi) and ($const{'mode'} != 0)) {
		chmod( $security{'Permission - CGI Scripts - eval'}, $abs_file );
		}
	else {
		chmod( $security{'Permission - Normal Files - eval'}, $abs_file);
		}
	}



=item CheckFreeSpace($)

Accepts length in bytes of a file.  Compares it to the amount of free space.  Returns whether if that would kick it over the limit.

Dependencies:
	&FolderSize
	$security{'Base Folder'}
	$STATE{'Username'}
	$STATE{'Quota'}

=cut

sub CheckFreeSpace {
	my ($del_size) = @_;
	my $is_allowed = 1;
	Err: {
		if ($const{'home_dir_err_msg'}) {
			$is_allowed = 0;
			next Err;
			}
		last Err unless ($STATE{'Author:UseQuota'});
		my $Quota = $STATE{'Quota'};
		my $DiskBytes = &FolderSize($STATE{'Author:UserFolder:parsed'});
		my $DiskKB = int($DiskBytes/1000);
		my $FreeKB = $Quota - $DiskKB;

		$is_allowed = (($FreeKB * 1000) > $del_size) ? 1 : 0;
		}
	return $is_allowed;
	}


=item ReportFreeSpace

Prints the amount of space used, and the amount remaining.

=cut

sub ReportFreeSpace {
	return if ($const{'home_dir_err_msg'});
	my $DiskBytes = &FolderSize($STATE{'Author:UserFolder:parsed'});
	my $Quota = $STATE{'Quota'};
	my $DiskKB = int($DiskBytes/1000);
	my $FreeKB = $Quota - $DiskKB;
	my $percent = &FormatNumber( ( 100 * ($DiskBytes / 1000) / $Quota ), 1, 0, 0, 1 );
	my $width1 = int( 200 * ($DiskBytes / 1000) / $Quota );
	$width1 = 1 unless ($width1);
	$width1 = 199 if ($width1 > 199);
	my $width2 = 200 - $width1;
	$DiskKB = &FormatNumber( $DiskKB, 0, 0, 0, 1 );
	$FreeKB = &FormatNumber( $FreeKB, 0, 0, 0, 1 );
	$Quota = &FormatNumber( $Quota, 0, 0, 0, 1 );

print <<"EOM";

<HR SIZE=1>

<B>Disk Use:</B> <IMG SRC="$security{'Images URL'}/bar_red.gif" HEIGHT=7 WIDTH=$width1 BORDER=1><IMG SRC="$security{'Images URL'}/bar_black.gif" HEIGHT=7 WIDTH=$width2 BORDER=1> <TT>$percent%</TT><BR>
Using $DiskKB kb of $Quota kb quota - $FreeKB kb free<BR>

EOM

	}


=item CheckName($)

Usage:
	($err_msg, $is_cgi) = &CheckName( $file );

Dependencies:
	%security
	%STATE

=cut

sub CheckName {
	my ($file) = @_;
	my $is_cgi = 0;

	my $max_file_len = 120;

	my $err_msg = '';
	Err: {

		unless ($file) {
			$err_msg = "cannot be blank";
			next Err;
			}

		if (length($file) > $max_file_len) {
			$err_msg = "maximum allowed length is $max_file_len characters";
			next Err;
			}

		if ($file =~ m! !) {
			$err_msg = "blank spaces are not allowed";
			next Err;
			}

		if ($file =~ m!\.\.!) {
			$err_msg = "adjacent dots are not allowed";
			next Err;
			}

		if (($file =~ m!^\.!) and ($file !~ m!\.template$!)) {
			$err_msg = "cannot begin with a dot"; #but those .x.template files are ok
			next Err;
			}

		my $V = '';
		($V = $file) =~ s/\w//g;
		$V =~ s/\.//g;
		$V =~ s/\-//g;

		if ($V) {
			$err_msg = "contains illegal characters - $V";
			next Err;
			}

		my $extension = 'null';
		if ($file =~ m!(.*)\.(.*?)$!) {
			$extension = lc($2);
			}

		my $qm_ext = quotemeta( $extension );
		my $html_ext = &html_encode( $extension );

		$is_cgi = (" $security{'CGI Types'} " =~ m! $qm_ext !i) ? 1 : 0;

		if (" $security{'Forbid Types'} " =~ m! $qm_ext !i) {
			$err_msg = "extension '$html_ext' is forbidden";
			next Err;
			}

		if (($is_cgi) and (not $STATE{'allow_cgi'})) {
			$err_msg = "CGI extension '$html_ext' is not allowed";
			next Err;
			}
		elsif ($security{'Allow Only Known Types'}) {
			if (" $security{'Known Types'} " =~ m! $qm_ext !i) {
				# okay
				}
			else {
				$err_msg = "extension '$html_ext' is not among the declared 'Known Types'";
				next Err;
				}
			}
		}

	if ($err_msg) {
		$err_msg = "filename '$file' is invalid - $err_msg";
		}

	return ($err_msg, $is_cgi);
	}




# ------------------------------------------------------------------- #
#     Initialization, Authentication and Preferences Procedures       #
# ------------------------------------------------------------------- #


=item LoadUserPrefs($$)

Usage:
	&LoadUserPrefs( $username, \%prefs );

=cut

sub LoadUserPrefs {
	my ($username, $p_prefs) = @_;
	my $err_msg = '';
	Err: {
		my $UserFile = "$const{'preferences folder'}/accounts/$username.txt";

		# Default state:
		%$p_prefs = (
			'Username' => $username,
			);
		&LoadDefaults( $p_prefs );

		my $text = '';
		($err_msg, $text) = &ReadFile( $UserFile );

		# For now, it'll just be okay if the file doesn't exist:
		#next Err if ($err_msg);
		$err_msg = '';

		foreach (split(m!\r?\n!, $text)) {
			next unless (m!^(.*?)=(.*?)=!);
			$$p_prefs{$1} = $2;
			}

		#reverse compat - added for build 0006
		unless ($$p_prefs{'_BUILD'}) {
			$$p_prefs{'Author:UseQuota'} = 1;
			if ($username eq $const{'super user'}) {
				$$p_prefs{'Author:UserFolder'} = $security{'Base Folder'};
				$$p_prefs{'Author:UserURL'} = $security{'Base URL'};
				}
			else {
				$$p_prefs{'Author:UserFolder'} = "$security{'Base Folder'}/%username%";
				$$p_prefs{'Author:UserURL'} = "$security{'Base URL'}/%username%";
				}
			}
		#/reverse compat

		$$p_prefs{'Author:UserFolder:parsed'} = $$p_prefs{'Author:UserFolder'};
		$$p_prefs{'Author:UserFolder:parsed'} =~ s!\%username\%!$username!ig;
		$$p_prefs{'Author:UserFolder:parsed'} =~ s!/$!!o;

		$$p_prefs{'Author:UserURL:parsed'} = $$p_prefs{'Author:UserURL'};
		$$p_prefs{'Author:UserURL:parsed'} =~ s!\%username\%!$username!ig;
		$$p_prefs{'Author:UserURL:parsed'} =~ s!/$!!o;
		}
	}




=item SaveUserPrefs($$$)

Usage:
	my $err_msg = &SaveUserPrefs( $username, \%overrides, $is_login );

=cut

sub SaveUserPrefs {
	my ($username, $p_overrides, $is_login) = @_;

	my $err_msg = '';
	Err: {

		my $warn_msg = '';

		my $UserFile = "$const{'preferences folder'}/accounts/$username.txt";

		# Default state:
		my %prefs = ();
		&LoadDefaults( \%prefs );

		my $text = '';
		($err_msg, $text) = &ReadFile( $UserFile );

		# For now, it'll just be okay if the file doesn't exist:
		#next Err if ($err_msg);
		$err_msg = '';

		foreach (split(m!\r?\n!, $text)) {
			next unless (m!^(.*?)=(.*?)=!);
			$prefs{$1} = $2;
			}

		# Mix in the overrides:
		foreach (keys %$p_overrides) {
			# don't destroy the demo
			if (($const{'mode'} == 0) and (m!^(allow_cgi|quota|author:)!i)) {
				$warn_msg = "some fields cannot be updated while in demo mode";
				next;
				}
			$prefs{$_} = $$p_overrides{$_};
			}

		if ($const{'mode'} == 0) {
			$prefs{'Author:UseQuota'} = 1;
			$prefs{'Quota'} = 10000;
			$prefs{'allow_cgi'} = 0;
			if ($username eq $const{'super user'}) {
				$prefs{'Author:UserFolder'} = $security{'Base Folder'};
				$prefs{'Author:UserURL'} = $security{'Base URL'};
				}
			else {
				$prefs{'Author:UserFolder'} = "$security{'Base Folder'}/%username%";
				$prefs{'Author:UserURL'} = "$security{'Base URL'}/%username%";
				}
			}




		# Remove any fields which are not part of the schema:
		my %schema = ();
		foreach (@user_attribs_ro, @user_attribs_rw, @user_attribs_internal) {
			$schema{$_}++;
			}

		my @existing_fields = keys %prefs;
		foreach (@existing_fields) {
			next if ($schema{$_});
			delete $prefs{$_};
			}

		# Set internal properties:
		$prefs{'Username'} = $username;

		my $build = 1;
		if ($VERSION =~ m!(\d+)$!) {
			$build = 1 * $1;
			}
		$prefs{'_BUILD'} = $build;
		$prefs{'_VERSION'} = $VERSION;
		if ($is_login) {
			$prefs{'LastLogin'} = time();
			$prefs{'LastLoginFrom'} = &query_env('REMOTE_ADDR');
			}
		$prefs{'AccountCreated'} = time() unless ($prefs{'AccountCreated'});

		# Write to disk
		$text = '';
		foreach (sort keys %prefs) {
			$text .= "$_=$prefs{$_}=\n";
			}
		$err_msg = &WriteFile( $UserFile, $text );
		next Err if ($err_msg);

		$err_msg = $warn_msg if ($warn_msg);

		}
	return $err_msg;
	}


















=item GetUserPrefs($$)

Usage:
	my $err_msg = &GetUserPrefs( $username, \%STATE );

=cut

sub GetUserPrefs {
	my ($username, $p_STATE) = @_;
	my $err_msg = '';
	Err: {

		&LoadUserPrefs( $username, $p_STATE );

		# Initialize:
		$$p_STATE{'web_path'} = $$p_STATE{'Author:UserURL:parsed'};
		$$p_STATE{'file_path'} = $$p_STATE{'Author:UserFolder:parsed'};

		if ($params{'CWD'}) {
			if ($params{'CWD'} !~ m!\.\.!) {
				$$p_STATE{'file_path'} .= "/$params{'CWD'}";
				$$p_STATE{'web_path'} .= "/$params{'CWD'}";
				$const{'admin_url'} .= "CWD=$params{'CWD'}&";
				$const{'cwd_line'} = "<INPUT TYPE=hidden NAME=\"CWD\" VALUE=\"$params{'CWD'}\">";
				}
			}

		unless (chdir($$p_STATE{'file_path'})) {

			#changed 0007 - reset CWD if error during chdir
			$params{'CWD'} = '';
			$const{'admin_url'} =~ s!(\W)CWD=.*?(\&|$)!$1CWD=$2!os;
			$const{'cwd_line'} = "<INPUT TYPE=hidden NAME=\"CWD\" VALUE=\"\">";

			$err_msg = sprintf( $lang_strings[38], $$p_STATE{'file_path'}, $! );
			next Err;
			}


		# This code saves LastLogin every hour. It also saves if LastLogin is undef:

		if ((not $$p_STATE{'LastLogin'}) or (3600 > (time() - $$p_STATE{'LastLogin'}))) {
			&SaveUserPrefs( $username, $p_STATE, 1 );
			}


		last Err;
		}
	return $err_msg;
	}


=item SwitchSort

Switch sort method.

=cut

sub SwitchSort {
	my %SortTypes = (
		'N' => 'filename',
		'n' => 'reverse filename',
		'S' => 'size',
		's' => 'reverse size',
		'D' => 'last modified time',
		'd' => 'reverse last modified time',
		'T' => 'file type',
		't' => 'reverse file type',
		);

	if ($STATE{'Sort'} eq $params{'SortType'}) {
		$STATE{'Sort'} = lc($params{'SortType'});
		}
	else {
		$STATE{'Sort'} = $params{'SortType'};
		}

	my %overrides = (
		'Sort' => $STATE{'Sort'},
		);

	my $err_msg = &SaveUserPrefs( $STATE{'Username'}, \%overrides, 1 );
	if ($err_msg) {
		&Report( sprintf( $lang_strings[2], $err_msg ) );
		}
	else {
		&Report( sprintf( $lang_strings[4], "now sorting by $SortTypes{$STATE{'Sort'}}" ) );
		}
	}


=item LoadDefaults($)

Usage:
	&LoadDefaults( \%STATE );

=cut

sub LoadDefaults {
	my ($p_STATE) = @_;

	$$p_STATE{'Author:UseQuota'} = 0;

	$$p_STATE{'Author:UserFolder'} = '';
	$$p_STATE{'Author:UserURL'} = '';

	$$p_STATE{'Quota'} = 10000;
	$$p_STATE{'allow_cgi'} = 0;

	$$p_STATE{'Sort'} = 'Type';
	$$p_STATE{'Rows'} = 18;
	$$p_STATE{'Cols'} = 83;
	$$p_STATE{'FontSize'} = 10;

	$$p_STATE{'shell'} = 0;

	$$p_STATE{'Sound'} = 1;
	$$p_STATE{'Warn'} = 1;
	$$p_STATE{'ShowTips'} = 1;
	$$p_STATE{'ShowDirSize'} = 1;
	$$p_STATE{'DiskUse'} = 1;
	$$p_STATE{'TextWrap'} = 1;
	$$p_STATE{'TextUpload'} = 1;

	$$p_STATE{'AccountCreated'} = 0;
	$$p_STATE{'LastLogin'} = 0;
	$$p_STATE{'LastLoginFrom'} = '';
	}



=item ShowSettings($$$)

Usage:
	&ShowSettings($username, $is_self, $is_new_user);

This function is used to display and edit personal account settings.

Non-webmaster users can edit their own settings.

Webmaster users can edit their own settings or other's settings.  This screen is also used when creating a new user account.

=cut

sub ShowSettings {
	my ($username, $is_self, $is_new_user) = @_;

	my $err_msg = '';
	Err: {
		local $_;

		my %TMP = ();
		if ($is_new_user) {
			&LoadUserPrefs( '_default', \%TMP );
			}
		else {
			&LoadUserPrefs( $username, \%TMP );
			}



		my $misc_options = '';
		my %BooleanPrefs = (
			'Concise' => 'Use Minimal Header Information',
			'ShowDirSize' => 'Show Folder Sizes',
			'ShowTips' => 'Show Tips and Links',
			'DiskUse' => 'Always Show Disk Space',
			'Warn' => 'Always Warn Before Deleting',
			'Sound' => 'Allow Embedded Sound Clips',
			);
		foreach (keys %BooleanPrefs) {
			$misc_options .= sprintf('<TR><TD><INPUT TYPE=checkbox NAME="%s" VALUE="1"></TD><TD>%s</TD></TR>', $_, $BooleanPrefs{$_});
			}

		my $sort_options = '';
		my %SortTypes = (
			'N' => 'filename',
			'n' => 'reverse filename',
			'S' => 'size',
			's' => 'reverse size',
			'D' => 'last modified time',
			'd' => 'reverse last modified time',
			'T' => 'file type',
			't' => 'reverse file type',
			);
		foreach (keys %SortTypes) {
			$sort_options .= sprintf('<OPTION VALUE="%s">%s', $_, $SortTypes{$_});
			}




		my $UserDIR = $TMP{'Author:UserFolder:parsed'};

		my $d1 = &FormatDateTime( $TMP{'AccountCreated'}, 10, 0 );
		my $d2 = &FormatDateTime( $TMP{'LastLogin'}, 10, 0 );

print <<"EOM";

		<FORM METHOD="post" ACTION="$const{'script_url'}">
		$const{'cwd_line'}
		$const{'crypt_pass_line'}

		<DL>

EOM

		# Modify Other People's Settings:
		if (not $is_self) {

			if ($username) {

print &SetDefaults(<<"EOM", \%TMP );

<INPUT TYPE="hidden" NAME="Action" VALUE="UA">
<INPUT TYPE="hidden" NAME="sa" VALUE="SP">
<INPUT TYPE="hidden" NAME="UN" VALUE="$TMP{'Username'}">
<INPUT TYPE="hidden" NAME="Username" VALUE="$TMP{'Username'}">

EOM

				}
			elsif ($is_new_user) {

print &SetDefaults(<<"EOM", \%TMP);

<INPUT TYPE="hidden" NAME="Action" VALUE="UA">
<INPUT TYPE="hidden" NAME="sa" VALUE="CU">

<P>If you leave the password boxes blank, a default password will be created and emailed to the user.</P>

EOM

				}
			}

		else {
			# Modify your own settings:

print <<"EOM";

<INPUT TYPE="hidden" NAME="Action" VALUE="save_prefs">
<INPUT TYPE="hidden" NAME="Username" VALUE="$TMP{'Username'}">
<INPUT TYPE="hidden" NAME="UN" VALUE="$TMP{'Username'}">

EOM

			}


		my $DiskUsage = '';
		if (($username) and (-e $UserDIR) and ($TMP{'Author:UseQuota'})) {
			$DiskUsage = '(' . int( &FolderSize($UserDIR) / 1000 ) . ' used now)';
			}

		my $quota_text = sprintf( $lang_strings[42], '<INPUT NAME="Quota" SIZE=6 STYLE="text-align:right">' );

		my $username_text = $is_new_user ? '<TT><INPUT NAME=Username></TT>' : $TMP{'Username'};

print &SetDefaults(<<"EOM", \%TMP);

			<DT><P><B>Identity:</B><P></DT>
			<DD>

				<TABLE BORDER=0>
				<TR>
					<TD ALIGN=right WIDTH=120><B>Username:</B></TD>
					<TD>$username_text</TD>
				</TR>
				<TR>
					<TD ALIGN=right WIDTH=120><B>Full Name:</B></TD>
					<TD><INPUT NAME="full_name"></TD>
				</TR>
				<TR>
					<TD ALIGN=right WIDTH=120><B>Email address:</B></TD>
					<TD><INPUT NAME="email_address"></TD>
				</TR>
				</TABLE>

				<P><INPUT TYPE=submit CLASS=submit VALUE="Save Data"></P>

				<P><BR></P>
			</DD>

			<DT><P><B>Security Settings:</B><P></DT>
			<DD>

				<TABLE BORDER=0>

EOM

# Everyone needs to know their old password when resetting, even webmaster:

print <<"EOM" if (($STATE{'Username'} ne $const{'super user'}) or ($TMP{'Username'} eq $const{'super user'}));
				<TR>
					<TD ALIGN=right WIDTH=120>Old Password:</TD>
					<TD><INPUT TYPE="password" NAME="OldPass"></TD>
				</TR>
EOM
print <<"EOM";
				<TR>
					<TD ALIGN=right>New Password:</TD>
					<TD><INPUT TYPE="password" NAME="NewPass"></TD>
				</TR>
				<TR>
					<TD ALIGN=right>Confirm:</TD>
					<TD><INPUT TYPE="password" NAME="NewPass2"></TD>
				</TR>
				</TABLE>

				<P><INPUT TYPE=submit CLASS=submit VALUE="Save Data"></P>

				<P><BR></P>
			</DD>

EOM
if ($STATE{'Username'} eq $const{'super user'}) {
print &SetDefaults(<<"EOM", \%TMP);

			<DT><P><B>Authoring Privileges:</B></P></DT>
			<DD>

				<TABLE BORDER=0>
				<TR>
					<TD><BR></TD>
					<TD>&lt;<A HREF="$TMP{'Author:UserURL:parsed'}">$TMP{'Author:UserURL:parsed'}</A>&gt;</TD>
				</TR>
				<TR>
					<TD ALIGN=right><B>Base Folder:</B></TD>
					<TD><TT><INPUT NAME="Author:UserFolder" SIZE=45></TT></TD>
				</TR>
				<TR>
					<TD ALIGN=right><B>Base URL:</B></TD>
					<TD><TT><INPUT NAME="Author:UserURL" SIZE=45></TT></TD>
				</TR>
				<TR VALIGN=top>
					<TD ALIGN=right><B>Disk Quota:</B></TD>
					<TD>
						<INPUT TYPE=radio NAME="Author:UseQuota" VALUE="0"> $lang_strings[41]<BR>
						<INPUT TYPE=radio NAME="Author:UseQuota" VALUE="1"> $quota_text $DiskUsage
					</TD>
				</TR>
				<TR VALIGN=top>
					<TD ALIGN=right><B>CGI Access:</B></TD>
					<TD>
						<INPUT TYPE=radio NAME="allow_cgi" VALUE="0"> $lang_strings[44]<BR>
						<INPUT TYPE=radio NAME="allow_cgi" VALUE="1"> $lang_strings[43]</TD>
				</TR>
				</TABLE>

				<P><INPUT TYPE=submit CLASS=submit VALUE="Save Data"></P>

				<P><BR></P>
			</DD>

EOM
	}
else {
	my $text_quota = ($TMP{'Author:UseQuota'}) ? sprintf( $lang_strings[42], $TMP{'Quota'} ) : $lang_strings[41];
	my $text_cgi = $TMP{'allow_cgi'} ? $lang_strings[43] : $lang_strings[44];
print <<"EOM";

			<DT><P><B>Authoring Privileges:</B></P></DT>
			<DD>
				<TABLE BORDER=0>
				<TR>
					<TD><BR></TD>
					<TD>&lt;<A HREF="$TMP{'Author:UserURL:parsed'}">$TMP{'Author:UserURL:parsed'}</A>&gt;</TD>
				</TR>
				<TR>
					<TD ALIGN=right><B>Base Folder:</B></TD>
					<TD><TT>$TMP{'Author:UserFolder:parsed'}</TT></TD>
				</TR>
				<TR>
					<TD ALIGN=right><B>Base URL:</B></TD>
					<TD><TT>$TMP{'Author:UserURL:parsed'}</TT></TD>
				</TR>
				<TR VALIGN=top>
					<TD ALIGN=right><B>Disk Quota:</B></TD>
					<TD>$text_quota</TD>
				</TR>
				<TR VALIGN=top>
					<TD ALIGN=right><B>CGI Access:</B></TD>
					<TD>$text_cgi</TD>
				</TR>
				</TABLE>

				<P>Contact the administrator to change these values.</P>

				<P><BR></P>
			</DD>
EOM
	}

print &SetDefaults(<<"EOM", \%TMP);


		<DT><P><B>General Settings:</B></P></DT>

		<DD>

			<P>When first logging in, show this screen:</P>
			<BLOCKQUOTE>
				<P><INPUT TYPE=radio NAME="shell" VALUE="0"> Main Page<BR>
				<INPUT TYPE=radio NAME="shell" VALUE="1"> Template Editor<BR>
				<INPUT TYPE=radio NAME="shell" VALUE="2"> HTML Editor</P>
			</BLOCKQUOTE>



			<P>Allow <SELECT NAME="multi_upload_count">
					<OPTION VALUE="10">10
					<OPTION VALUE="15">15
					<OPTION VALUE="25">25
					<OPTION VALUE="50">50
					<OPTION VALUE="100">100
				</SELECT> files to be upload at once on multiple upload page.</P>

			<P>When listing all files, sort by <SELECT NAME="Sort">$sort_options</SELECT>.</P>

			<TABLE BORDER=0>
				$misc_options
			</TABLE>

				<P><INPUT TYPE=submit CLASS=submit VALUE="Save Data"></P>

				<P><BR></P>
			</DD>


		<DT><P><B>Text Editing Options:</B></P></DT>
		<DD>

			<P>The text editor can be customized to accomodate your screen resolution and preferences. Some features, like wrapped text and scaled fonts, require newer browsers.</P>

			<TABLE BORDER=0>
			<TR>
				<TD COLSPAN=2 ALIGN=right>Size of text:</TD>
				<TD><INPUT NAME="FontSize" SIZE=3 STYLE="text-align:right"> pt</TD>
			</TR>
			<TR>
				<TD COLSPAN=2 ALIGN=right>Height of Text Box:</TD>
				<TD><INPUT NAME="Rows" SIZE=3 STYLE="text-align:right"></TD>
			</TR>
			<TR>
				<TD COLSPAN=2 ALIGN=right>Width of Text Box:</TD>
				<TD><INPUT NAME="Cols" SIZE=3 STYLE="text-align:right"></TD>
			</TR>
			</TABLE>

			<P><BR></P>

			<TABLE BORDER=0>
			<TR>
				<TD><INPUT TYPE=checkbox NAME="TextUpload" VALUE="1"></TD>
				<TD COLSPAN=2>Upload All Text Files in ASCII Mode</TD>
			</TR>
			<TR>
				<TD><INPUT TYPE=checkbox NAME="TextWrap" VALUE="1"></TD>
				<TD COLSPAN=2>Wrap Long Lines</TD>
			</TR>
			</TABLE>

			<P><INPUT TYPE=submit CLASS=submit VALUE="Save Data"></P>

			<P><BR></P>
		</DD>
		</DL>

		</FORM>

		<HR SIZE=1>
		<TABLE BORDER=0>
		<TR>
			<TD ALIGN=right><B>Account Created:</B></TD>
			<TD>$d1</TD>
		</TR>
		<TR>
			<TD ALIGN=right><B>Last Login:</B></TD>
			<TD>$d2</TD>
		</TR>
		<TR>
			<TD ALIGN=right><B>Last Login From:</B></TD>
			<TD>$TMP{'LastLoginFrom'}</TD>
		</TR>
		</TABLE>


EOM

		last Err;
		}
	continue {
		&Report( sprintf( $lang_strings[2], $err_msg ) );
		}
	}



sub Save_Password {
	my ($username, $oldpass, $pass1, $pass2, $validate) = @_;
	my $err_msg = '';
	Err: {

		if (length($pass1) < $security{'Min Password Length'}) {
			$err_msg = "password must be at least $security{'Min Password Length'} characters long";
			next Err;
			}

		if ($validate) {
			my $is_valid = 0;
			($err_msg, $is_valid) = $auth->ValidatePassword( $username, $oldpass );
			next Err if ($err_msg);
			unless ($is_valid) {
				$err_msg = $lang_strings[33];
				next Err;
				}
			}

		if ($pass1 ne $pass2) {
			$err_msg = $lang_strings[40];
			next Err;
			}

		$err_msg = $auth->SetPassword( $username, $pass1 );
		next Err if ($err_msg);

		&Report( sprintf( $lang_strings[4], "set new password" ) );
		last Err;
		}
	continue {
		&Report( sprintf( $lang_strings[2], $err_msg ) );
		}
	}



sub Save_Preferences {
	my ($username, $is_login) = @_;
	my $err_msg = '';
	Err: {

		# Security check... if we're not webmaster, then we're editing our own account, right?
		unless ($STATE{'Username'} eq $const{'super user'}) {
			if ($username ne $STATE{'Username'}) {
				$err_msg = "you are logged in as '$STATE{'Username'}' - cannot edit account '$username'";
				next Err;
				}
			}


		if ($username ne '_default') {
			if ($params{'OldPass'}) {
				&Save_Password( $username, $params{'OldPass'}, $params{'NewPass'}, $params{'NewPass2'}, 1);
				}
			elsif ($STATE{'Username'} eq $const{'super user'}) {
				if (($params{'NewPass'}) and ($params{'NewPass2'}) and ($username ne $const{'super user'})) {
					&Save_Password( $username, '', $params{'NewPass'}, $params{'NewPass2'}, 0);
					}
				}
			}

		my %GNU = ();
		if ($STATE{'Username'} eq $const{'super user'}) {

			if ($username ne '_default') {
				my $test_folder = $params{'Author:UserFolder'};
				$test_folder =~ s!\%username\%!$username!ig;
				unless (-e $test_folder) {
					$err_msg = "folder '$test_folder' does not exist";
					next Err;
					}
				unless (-e $test_folder) {
					$err_msg = "object '$test_folder' is not a folder";
					next Err;
					}
				}

			foreach (@user_attribs_ro) {
				if (defined($params{$_})) {
					$GNU{$_} = $params{$_};
					}
				}
			}

		foreach (@user_attribs_rw) {
			$GNU{$_} = $params{$_};
			}

		$err_msg = &SaveUserPrefs( $username, \%GNU, $is_login );
		next Err if ($err_msg);

		&Report( sprintf( $lang_strings[4], 'updated user preferences' ) );
		last Err;
		}
	continue {
		&Report( sprintf( $lang_strings[2], $err_msg ) );
		}
	}


=item PrintTemplateEx($$$$$)

Usage:
	&PrintTemplateEx( $b_return_as_string, 'tips.html', 'templates/german', \%replace_values, \%parents );

See "admin_help.html" for extensive documentation on this function, its limitations, its failure scenarios, etc.

Dependencies:
	@lang_strings
	&ReadFile
	&PrintTemplateEx

=cut

sub PrintTemplateEx {
	my ($b_return_as_string, $file, $start_folder, $p_replace_values, $p_parents) = @_;
	my $return_text = '';

	my $err_msg = '';
	Err: {

		# Initialize:
		unless ($p_replace_values) {
			my %hash = ();
			$p_replace_values = \%hash;
			}

		unless ($p_parents) {
			my %hash = ();
			$p_parents = \%hash;
			}

		my $fullfile = '';

		my $max_parents = 12;

		$start_folder =~ s!/+^!!o;
		for (0..$max_parents) {
			$fullfile = $start_folder . '/' . ('../' x $_) . $file;
			$fullfile =~ s!/+!/!g;
			last if (-e $fullfile);
			}

		unless (-e $fullfile) {
			$err_msg = "unable to find file '$file'";
			next Err;
			}

		my $basename = '';
		if ($fullfile =~ m!([^\\|/]+)$!) {
			$basename = $1;
			}
		$$p_parents{$basename}++;

		my $text = '';

		($err_msg, $text) = &ReadFile( $fullfile );
		next Err if ($err_msg);

		foreach (reverse sort keys %$p_replace_values) {
			$text =~ s!\$$_!$$p_replace_values{$_}!isg;
			$text =~ s!\_\_$_\_\_!$$p_replace_values{$_}!isg;
			$text =~ s!\%$_\%!$$p_replace_values{$_}!isg;
			}

		my $pattern = '<!--#(include file|include virtual|echo var)=\"(.*?)\" -->';

		while ($text =~ m!^(.*?)$pattern(.*)$!is) {
			my ($start, $c1, $incfile, $end) = ($1, lc($2), $3, $4);

			if ($b_return_as_string) {
				$return_text .= $start;
				}
			else {
				print $start;
				}

			if ($c1 eq 'echo var') {
				my $var = uc($incfile);
				my $vardata = '';
				if ($var eq 'DATE_GMT') {
					$vardata = scalar gmtime();
					}
				elsif ($var eq 'DATE_LOCAL') {
					$vardata = scalar localtime();
					}
				elsif ($var eq 'DOCUMENT_NAME') {
					$vardata = $1 if ($0 =~ m!([^\\|/]+)$!);
					}
				elsif ($var eq 'DOCUMENT_URI') {
					$vardata = $ENV{'SCRIPT_NAME'};
					}
				elsif ($var eq 'LAST_MODIFIED') {
					$vardata = scalar localtime( (stat($0))[9] );
					}
				elsif (defined($ENV{$var})) {
					$vardata = $ENV{$var};
					}

				if ($b_return_as_string) {
					$return_text .= $vardata;
					}
				else {
					print $vardata;
					}

				}
			else {

				my $basefile = $incfile;
				if ($incfile =~ m!.*(\\|/)(.*?)$!) {
					$basefile = $2;
					}

				my $outstr = '';

				# Do we have a file extension?
				my $ok_list = 'txt|htm|html|shtml|stm|inc';
				if ($basefile !~ m!\.($ok_list)$!i) {
					$outstr = "<!-- PrintTemplateEx: not including file '$incfile' because extension not in set '$ok_list' -->";
					}
				elsif ($$p_parents{$basefile}) {
					$outstr = "<!-- PrintTemplateEx: loop avoidance: parsed file '$basefile' somewhere in my ancestor tree -->";
					}
				else {
					$outstr .= &PrintTemplateEx( $b_return_as_string, $incfile, $start_folder, $p_replace_values, $p_parents );
					}

				if ($b_return_as_string) {
					$return_text .= $outstr;
					}
				else {
					print $outstr;
					}
				}
			$text = $end;
			}
		if ($b_return_as_string) {
			$return_text .= $text;
			}
		else {
			print $text;
			}
		delete $$p_parents{$basename};
		last Err;
		}
	continue {
		if ($b_return_as_string) {
			$return_text .= "<P><B>Error:</B> $err_msg.</P>\n";
			}
		else {
			print "<P><B>Error:</B> $err_msg.</P>\n";
			}
		}
	return $return_text;
	}

=item ReadFile($)

Usage:
	my ($err_msg, $text) = &ReadFile( $file );
	if ($err_msg) {
		print "<P><B>Error:</B> $err_msg.</P>\n";
		}

=cut

sub ReadFile {
	my ($filename) = @_;
	my ($err_msg, $text) = ('', '');
	Err: {
		unless (open(FILE, "<$filename")) {
			$err_msg = sprintf( $lang_strings[8], $filename, $! );
			next Err;
			}
		unless (binmode(FILE)) {
			$err_msg = sprintf( $lang_strings[12], $filename, $! );
			next Err;
			}

		$text = join('', <FILE>);
		close(FILE);
		}
	return ($err_msg, $text);
	}



=item WriteFile($$)

Usage:
	my $err_msg = &WriteFile( $file, $text );
	if ($err_msg) {
		print "<P><B>Error:</B> $err_msg.</P>\n";
		}

=cut

sub WriteFile {
	my ($filename, $text) = @_;

	my $err_msg = '';
	Err: {
		unless (open(FILE, ">$filename")) {
			$err_msg = sprintf( $lang_strings[9], $filename, $! );
			next Err;
			}
		unless (binmode(FILE)) {
			$err_msg = sprintf( $lang_strings[12], $filename, $! );
			next Err;
			}
		print FILE $text;
		close(FILE);
		}
	return $err_msg;
	}



=item url_encode

Usage:
	my $str_url = url_encode($str);

Formats strings consistent with RFC 1945 by rewriting metacharacters in their
%HH format.

=cut

sub url_encode {
	local $_ = defined($_[0]) ? $_[0] : '';
	s!([^a-zA-Z0-9_.-])!uc(sprintf("%%%02x", ord($1)))!eg;
	return $_;
	}


sub url_decode {
	local $_ = defined($_[0]) ? $_[0] : '';
	tr!+! !;
	s!\%([a-fA-F0-9][a-fA-F0-9])!pack('C', hex($1))!eg;
	return $_;
	}


=item html_encode

Usage:
	my $html_str = html_encode($str);

Formats string consistent with embedding in an HTML document.  Escapes the
"><& characters.

=cut

sub html_encode {
	local $_ = defined($_[0]) ? $_[0] : '';
	s!\&!\&amp;!g;
	s!\>!\&gt;!g;
	s!\<!\&lt;!g;
	s!\"!\&quot;!g;
	return $_;
	}


=item WebForm()

Usage:
	my %params = ();
	my %upload_files = ();
	my $temp_dir = 'd:/temp';
	my $err_msg = '';
	Err: {
		$err_msg = &standard_binmode();
		next Err if ($err_msg);

		$err_msg = &WebForm( \%params, \%upload_files, $temp_dir );
		next Err if ($err_msg);

		foreach (sort keys %params) {
			print "<P>Param $_: $params{$_}.</P>\n";
			}

		foreach (keys %upload_files) {
			print "<P>Upload file: $_</P>\n";
			print "<UL>\n";

			my $p_data = $upload_files{$_};
			foreach (sort keys %$p_data) {
				print "<LI>File data: $_: $$p_data{$_}\n";
				}

			print "</UL>\n";
			}

		last Err;
		}
	continue {
		print "<P><B>Error:</B> $err_msg.</P>\n";
		}

Reads CGI name-value pairs from environment variables and/or standard input.  Returns a hash by reference.

Dependencies:
	&standard_binmode must have been called first.
	&url_decode

=cut


sub WebForm {
	my ($p_hash, $p_upload_files, $temp_dir) = @_;

	my $err_msg = '';
	Err: {
		unless ('HASH' eq ref($p_hash)) {
			$err_msg = "invalid argument - p_hash is not a HASH reference";
			next Err;
			}

		if ($p_upload_files) {
			unless ('HASH' eq ref($p_upload_files)) {
				$err_msg = "invalid argument - p_upload_files is not a HASH reference";
				next Err;
				}
			}

		my $global_unique_id = time() + int( 1000000 * rand() );

		my @Pairs = ();
		my $request_method = &query_env('REQUEST_METHOD');
		my $query_string = &query_env('QUERY_STRING');
		if ($request_method eq 'POST') {

			my $ctype = &query_env('CONTENT_TYPE');

			if ($ctype =~ m!multipart/form-data; boundary=(.*)!) {

				# okay, we have a multipart FILE UPLOAD in progress:

				my $boundary = $1;
				my $buffer = '';
				my $len = &query_env('CONTENT_LENGTH',0);
				my $bytes_read = read(main::STDIN, $buffer, $len, 0);
				unless ($bytes_read == $len) {
					$err_msg = "unable to read $len bytes from input - only read $bytes_read - $!";
					next Err;
					}
				&untaintme(\$buffer);

				#print "<P><XMP>$boundary\n$buffer</XMP></P>";

				foreach (split(m!$boundary!, $buffer)) {
					s!--$!!so;
					#print "<P><XMP>'$_'</XMP></P>";
					my ($name, $is_file, $filename, $value) = ('', 0, '', '');
					if (m!Content-Disposition: form-data; name="(.*?)"; filename="(.*?)"!is) {
						($name, $filename) = ($1, $2);
						$is_file = 1;
						}
					elsif (m!Content-Disposition: form-data; name="(.*?)"!is) {
						($name) = ($1);
						}
					else {
						next;
						}

					if (m!Content-Disposition: form-data; name="$name".*?\015\012\015\012(.*)$!is) {
						$value = $1;
						$value =~ s!\015\012$!!so;
						}
					else {
						next;
						}

					if (($is_file) and ($p_upload_files)) {
						my $contenttype = '';
						if (m!Content-Type:\s*(\S+)!is) {
							$contenttype = $1;
							}

						my %filedata = (
							'client file name' => $filename,
							'size' => length($value),
							'content' => "'$value'",
							'content-type' => $contenttype,
							);

						my $sf_err = '';
						SaveFile: {

							unless ($temp_dir) {
								$sf_err = "unable to save file - temp_dir parameter not defined";
								next SaveFile;
								}

							unless ((-e $temp_dir) and (-d $temp_dir)) {
								$sf_err = "unable to save file - temp_dir '$temp_dir' does not exist or is not a directory";
								next SaveFile;
								}

							$global_unique_id = 0 unless ($global_unique_id);
							$global_unique_id++;

							# create a temp file:
							my $file_num = $global_unique_id;
							for (;;) {
								last unless (-e "$temp_dir/fd_webformex_$file_num.tmp");
								$file_num++;
								}
							my $TempFile = "$temp_dir/fd_webformex_$file_num.tmp";

							unless (open(FILE, ">$TempFile")) {
								$sf_err = "unable to write to temp file '$TempFile' - $!";
								next SaveFile;
								}

							unless (binmode(FILE)) {
								$sf_err = "unable to set binmode on temp file '$TempFile' - $!";
								close(FILE);
								next SaveFile;
								}

							print FILE $value;
							close(FILE);

							$filedata{'temp file'} = $TempFile;
							delete $filedata{'content'};

							eval "END { unlink('$TempFile'); }\n";

							}
						$filedata{'err_msg'} = $sf_err if ($sf_err);

						$$p_upload_files{$name} = \%filedata;
						next;
						}
					$$p_hash{$name} = $value;
					}

				# Done with multipart form
				last Err;
				}

			my $buffer = '';
			my $len = &query_env('CONTENT_LENGTH');
			read(STDIN, $buffer, $len);
			&untaintme(\$buffer);
			@Pairs = split(m!\&!, $buffer);
			}
		elsif ($query_string) {
			@Pairs = split(m!\&!, $query_string);
			}
		else {
			@Pairs = @ARGV;
			}

		foreach (@Pairs) {
			next unless (m!^(.*?)=(.*)$!);
			my ($name, $value) = (&url_decode($1), &url_decode($2));
			if ($$p_hash{$name}) {
				$$p_hash{$name} .= ",$value";
				}
			else {
				$$p_hash{$name} = $value;
				}
			}
		}
	return $err_msg;
	}



=item standard_binmode()

Usage:
	my $err_msg = &standard_binmode();
	if ($err_msg) {
		print "<P><B>Error:</B> $err_msg.</P>\n";
		}

	my $needs_binmode = _needs_binmode();
	if ($needs_binmode) {
		binmode(main::STDIN);
		binmode(main::STDOUT);
		binmode(main::STDERR);
		}

Sets binmode on standard input, output, and error if required for this operating system (given by $^O).

Based on CGI.pm.

=cut

sub standard_binmode {
	my $err_msg = '';
	Err: {
		my $OS = $^O;
		if (($OS) and ($OS =~ m!(win|dos|os2)!i)) {

			unless (binmode(main::STDIN)) {
				$err_msg = "unable to set binmode on STDIN - $!";
				next Err;
				}
			unless (binmode(main::STDOUT)) {
				$err_msg = "unable to set binmode on STDOUT - $!";
				next Err;
				}
			unless (binmode(main::STDERR)) {
				$err_msg = "unable to set binmode on STDERR - $!";
				next Err;
				}
			}
		}
	return $err_msg;
	}






=item GetFiles($$)

Usage:
	my @Files = &GetFiles( $folder, $pattern );

Returns all files from $folder (recursively searched) that fit $pattern.

=cut

sub GetFiles {
	my ($FolderCount, @Folders, @Files, $Pattern) = (0);
	($Folders[0], $Pattern) = @_;
	# Format with all forward slashes; add a trailing slash to $Directory if
	# it's not present:
	$Folders[0] = &NixPath($Folders[0]);
	$Folders[0] .= '/' unless ($Folders[0] =~ m!/$!);

	while ($FolderCount < (scalar @Folders)) {
		my $Directory = $Folders[$FolderCount];
		$FolderCount++;

		unless (opendir(DIR, $Directory)) {
			print "Warning: could not read from directory $Directory - $!\n";
			next;
			}
		foreach (readdir(DIR)) {
			next if m!^\.\.?$!; # skip current and higher directories.

			my $Path = "$Directory$_";
			if (-d $Path) {
				push(@Folders, "$Path/");
				next;
				}
			push(@Files, $Path) if ((not $Pattern) or (m!$Pattern!i));
			}
		closedir(DIR);
		}
	return @Files;
	}



=item SendMailEx

Usage:

	my ($err, $trace) = &SendMailEx(
		'to' => 'user@host.com',
		'to name' => 'Bob User',      # *
		'from' => 'me@host.com',
		'from name' => 'Sally User',  # *
		'subject' => 'Hi Sally',      # *
		'message' => $message,
		'host' => 'mail.foo.com',     # *
		'port' => 25,                 # *
		);

	# * optional field

	if ($err) {
		print "<P>Error - $err</P>";
		}
	else {
		print "<P>Sent mail okay.</P>";
		}

	print "<P>Here is the trace:</P>\n\n";
	print "<XMP>\n$trace\n</XMP>\n";

Dependencies:
	use Socket;
	&get_mx()

=cut


sub SendMailEx {
	my %params = @_;

	my $socket_is_open = 0;

	my $trace = '';

	my $err_msg = '';
	Err: {

		undef($@);
		eval 'use Socket;';
		if ($@) {
			$err_msg = "unable to require Socket - $@";
			next Err;
			}


		# validate inputs:
		if ((not $params{'to name'}) and ($params{'to_name'})) {
			$params{'to name'} = $params{'to_name'};
			}
		if ((not $params{'from name'}) and ($params{'from_name'})) {
			$params{'from name'} = $params{'from_name'};
			}
		if ((not $params{'message'}) and ($params{'body'})) {
			$params{'message'} = $params{'body'};
			}

		foreach ('to', 'from') {
			unless ($params{$_}) {
				$err_msg = "invalid argument - requires '$_' parameter";
				next Err;
				}
			}

		# auto-detect SMTP server:
		unless ($params{'host'}) {
			$params{'host'} = &get_mx( $params{'to'} );
			}

		unless ($params{'host'}) {
			$err_msg = "SMTP server not defined, and unable to auto-detect one for destination address '$params{'to'}' - please define a SMTP server manually using the 'host' parameter";
			next Err;
			}

		$params{'port'} = 25 unless ($params{'port'});

		# Use strictly compliant line enders:
		my $CRLF = "\015\012";

		# build the full message:

		my $full_message = '';

		for ('to', 'from') {
			if ($params{"$_ name"}) {
				$full_message .= qq!$_: <$params{$_}> "$params{"$_ name"}"$CRLF!;
				}
			else {
				$full_message .= qq!$_: <$params{$_}>$CRLF!;
				}
			}

		my $date = &FormatDateTime( time(), 11, 1);

		$full_message .= "Date: $date$CRLF";
		if ($params{'subject'}) {
			$full_message .= "Subject: $params{'subject'}$CRLF";
			}
		$full_message .= $CRLF;
		$full_message .= $params{'message'};

		# Fix for bare LF

		$full_message =~ s!\012!\015\012!sg;
		$full_message =~ s!\015+!\015!sg;

		# Escape any literal CRLF . CRLF sequences (this is the end-of-message sequence in SMTP)
		$full_message =~ s!\015\012\.\015\012!\015\012\. \015\012!sg;


		# connect to the SMTP server

		my $proto = getprotobyname('tcp') || 6;
		unless (socket(MAIL, &PF_INET(), &SOCK_STREAM(), $proto)) {
			$err_msg = "unable to create socket - $! - $^E";
			next Err;
			}
		$socket_is_open = 1;
		my $HexIP = inet_aton( $params{'host'} );
		unless (defined($HexIP)) {
			$err_msg = "unable to resolve hostname '$params{'host'}' to IP address - $! - $^E";
			next Err;
			}
		unless (connect(MAIL, sockaddr_in($params{'port'}, $HexIP))) {
			$err_msg = "unable to connect to host '$params{'host'}' on port $params{'port'} - $! - $^E";
			next Err;
			}
		unless (binmode(MAIL)) {
			$err_msg = "unable to set binmode on mail socket - $!";
			next Err;
			}
		select(MAIL);
		$| = 1;
		select(STDOUT);

		my @commands = (
			[ 'Welcome',
				220, 0, '',
				],
			[ 'HELO',
				250, 1, "HELO $params{'host'}",
				],
			[ 'Mail From',
				250, 1, "MAIL FROM:<$params{'from'}>",
				],
			[ 'Recipient/To',
				250, 1, "RCPT TO:<$params{'to'}>",
				],
			[ 'Data Initialize',
				354, 1, "DATA",
				],
			[ 'Data Transfer',
				250, 1, "$full_message$CRLF.$CRLF",
				],
			);

		my $i = 0;
		for ($i = 0; $i <= $#commands; $i++) {
			my ($expect_code, $sendrecv, $send_data) = ($commands[$i][1], $commands[$i][2], $commands[$i][3]);
			if ($sendrecv) {
				$send_data .= $CRLF;
				my $data_len = length($send_data);
				my $send_len = send(MAIL, $send_data, 0);
				unless (defined($send_len)) {
					$err_msg = "error while sending data to SMTP server - $! - $^E";
					next Err;
					}
				if ($send_len != $data_len) {
					$err_msg = "error while sending data to SMTP server; sent only $send_len of $data_len total bytes of data - $! - $^E";
					next Err;
					}
				$trace .= $send_data;
				}
			my $response_code = '';
			my $response_text = '';
			while (<MAIL>) {
				$response_text .= $_;
				$trace .= $_;
				s!(\r|\n|\015|\012)!!g;#correct for MacPerl
				if ((m!^(\d\d\d)\-!) and ($1 ne '000')) {
					$response_code = $1 unless ($response_code);
					}
				elsif (m!^(\d\d\d)\r?(\s|$)!) {
					$response_code = $1 unless ($response_code);
					last;
					}
				else {
					$err_msg = "SMPT server '$params{'host'}' did not respond properly to the '$commands[$i][0]' command; receive server response not beginning with 3-digit number; full text: '$response_text'";
					next Err;
					}
				}
			unless ($response_code =~ m!$expect_code!) {
				$err_msg = "SMPT server '$params{'host'}' did not respond properly to the '$commands[$i][0]' command; expected '$expect_code' response, received '$response_code'; full text: '$response_text'";
				next Err;
				}
			}
		}
	close(MAIL) if ($socket_is_open);
	return ($err_msg, $trace);
	}



=item get_mx

Usage:
	my ($mailhost) = get_mx( $hostname );

Accepts a hostname or email address, and returns it's associated SMTP server.  Depends on a call to the 'nslookup' tool, which must exist and be in the path.

Sadly, this will not work on Win9x machines or Mac's.  It will work on WinNT, Win2000, Unix/Linux.

If there is an error, returns an empty string.

=cut

sub get_mx {
	my ($hostname) = @_;
	my $mailhost = '';
	$hostname = $1 if ($hostname =~ m!\@(.*)!);
	my $command = "nslookup -q=MX $hostname 2>&" . 1;
	my $text = `$command`;
	if ($text =~ m!mail exchanger\s*=\s*(\S+)(\r|\n|$)!is) {
		$mailhost = $1;
		}
	return $mailhost;
	}






=item FormatNumber

Usage:
	my $num_str = &FormatNumber( $expression, $decimal_places, $include_leading_digit, $use_parens_for_negative, $group_digits, $euro_style );

Arguments

$expression
	Required. Expression to be formatted.

$decimal_places
	Optional. Numeric value indicating how many places to the right of the decimal are displayed.
	Note: truncates $expression to $decimal_places, does not round.

$include_leading_digit
	Optional. Boolean that indicates whether or not a leading zero is displayed for fractional values.

$use_parens_for_negative
	Optional. Boolean that indicates whether or not to place negative values within parentheses.
	Style is used for outbound formatting only; inbound parsing always uses "-" for dec (Perl's internal format)

$group_digits
	Optional. Boolean that indicates whether or not numbers are grouped using the comma.

$euro_style
	Optional. If 1, then "." separates thousands and "," separates decimal.  i.e. "800.234,24" instead of "800,234.24".
	Style is used for outbound formatting only; inbound parsing always uses "." for dec (Perl's internal format)

Prototyped to match Microsoft's FormatNumber function for vbscript/jscript, with the limitation of not knowing about default settings.

Microsoft specification at http://msdn.microsoft.com/scripting/vbscript/doc/vsfctFormatNumber.htm or from http://msdn.microsoft.com/scripting/.

Error handling:
	if $expression is not numeric, is treated as 0

Dependencies:
	none

=cut

sub FormatNumber {
	my ( $expression, $decimal_places, $include_leading_digit, $use_parens_for_negative, $group_digits, $euro_style ) = @_;

	my $dec_ch = ($euro_style) ? ',' : '.';
	my $tho_ch = ($euro_style) ? '.' : ',';

	my $qm_dec_ch = quotemeta( $dec_ch );

	local $_ = $expression;
	unless (m!^\-?\d*\.?\d*$!) {
		#print "Warning: arg '$num' isn't numeric.\n";
		$_ = 0;
		}

	my $exp = 1;
	for (1..$decimal_places) {
		$exp *= 10;
		}
	$_ *= $exp;
	$_ = int($_);
	$_ = ($_ / $exp);

	# Add a trailing decimal divider if we don't have one yet
	$_ .= '.' unless (m!\.!);

	# Pad zero'es if appropriate:
	if ($decimal_places) {
		if (m!^(.*)\.(.*)$!) {
			$_ .= '0' x ($decimal_places - length($2));
			}
		}
	# Re-write with localized decimal divider:
	s!\.!$dec_ch!o;

	# Group digits:
	if ($group_digits) {
		while (m!(.*)(\d)(\d\d\d)(\,|\.)(.*)!) {
			$_ = "$1$2$tho_ch$3$4$5";
			}
		}
	if ($include_leading_digit) {
		s!^$qm_dec_ch!0$dec_ch!o;
		}
	# Have we somehow ended up with just a decimal point?  Make it zero then:
	if ("foo$_" eq "foo$dec_ch") {
		$_ = "0";
		}
	# Strip trailing decimal point
	s!$qm_dec_ch$!!o;
	if ($use_parens_for_negative) {
		s!^\-(.*)$!\($1\)!o;
		}
	return $_;
	}




=item FormatDateTime

Dependencies: none

Usage:
	my $date_str = &FormatDateTime( time(), $format_type, $b_format_as_gmt );

Written to model Microsoft's FormatDateTime function for vbscript and jscript.  See:
	http://msdn.microsoft.com/
	http://msdn.microsoft.com/scripting/
	http://msdn.microsoft.com/scripting/vbscript/doc/vsfctFormatDateTime.htm

dim x
for x = 0 to 4
	WScript.Echo x & ": " & FormatDateTime( Now(), x )
next

$format_type is one of:

0: 12/12/2000 10:46:55 PM
1: Tuesday, December 12, 2000
2: 12/12/2000
3: 10:46:55 PM
4: 22:46

Added the following to meet my specific needs:

10: Wed 11/1/2000 1:18 PM (short & clean)
11: Wed, 1 Nov 2000 13:18:00 -0000 (SMTP protocol date format)
12: 2000-11-01 13:18:00 (mysql format)
13: Perl native format / scalar localtime
14: 12/12/2000 22:46 (tight format)


=cut

sub FormatDateTime {
	my ($time, $format_type, $b_format_as_gmt) = @_;
	$format_type = 0 unless ($format_type);
	my $date_str = '';

	$time = 0 unless ($time);

	if ($format_type == 13) {

		if ($b_format_as_gmt) {
			$date_str = scalar gmtime( $time );
			}
		else {
			$date_str = scalar localtime( $time );
			}
		}
	else {

		my ($sec, $min, $milhour, $day, $month_index, $year, $weekday_index) = ($b_format_as_gmt) ? gmtime( $time ) : localtime( $time );

		$year += 1900;

		my $ampm = ( $milhour >= 12 ) ? 'PM' : 'AM';
		my $relhour = (($milhour - 1) % 12) + 1;
		my $month = $month_index + 1;

		foreach ($milhour, $relhour, $min, $sec, $month, $day) {
			$_ = "0$_" if (1 == length($_));
			}

		my @MonthNames = ('January', 'February', 'March', 'April', 'May', 'June', 'July', 'August', 'September', 'October', 'November', 'December');
		my @WeekNames = ('Sunday', 'Monday', 'Tuesday', 'Wednesday', 'Thursday', 'Friday', 'Saturday');

		my $full_weekday = $WeekNames[$weekday_index];
		my $short_weekday = substr($full_weekday, 0, 3);

		my $full_monthname = $MonthNames[$month_index];
		my $short_monthname = substr($full_monthname, 0, 3);

		if ($format_type == 0) {
			$date_str = "$month/$day/$year $relhour:$min:$sec $ampm";
			}
		elsif ($format_type == 1) {
			$date_str = "$full_weekday, $full_monthname $day, $year";
			}
		elsif ($format_type == 2) {
			$date_str = "$month/$day/$year";
			}
		elsif ($format_type == 3) {
			$date_str = "$relhour:$min:$sec $ampm";
			}
		elsif ($format_type == 4) {
			$date_str = "$milhour:$min";
			}
		elsif ($format_type == 10) {
			$date_str = "$short_weekday $month/$day/$year $relhour:$min:$sec $ampm";
			}
		elsif ($format_type == 11) {
			$date_str = "$short_weekday, $day $short_monthname $year $milhour:$min:$sec -0000";
			}
		elsif ($format_type == 12) {
			$date_str = "$year-$month-$day $milhour:$min:$sec";
			}
		elsif ($format_type == 14) {
			$date_str = "$month/$day/$year $milhour:$min";
			}
		}
	return $date_str;
	}




sub NixPath {
	local $_ = defined($_[0]) ? $_[0] : '';
	s!\\!/!mg;
	return $_;
	}



=item image_size($)

Usage:
	my ($err_msg, $x, $y, $filesize) = &image_size( $file );
	if ($err_msg) {
		print "<P><B>Error:</B> $err_msg.</P>\n";
		exit;
		}
	print "X: $x; Y: $y; Filesize: $filesize\n";

Returns the dimensions and byte size of a JPEG, GIF, or BMP image.

Based on Image::Size.

=cut

sub image_size {
	my ($file) = @_;
	if ($file =~ m!\.(jpeg|jpg)$!i) {
		return &jpegsize( $file );
		}
	elsif ($file =~ m!\.gif$!i) {
		return &gifsize( $file );
		}
	elsif ($file =~ m!\.bmp$!i) {
		return &bmpsize( $file );
		}
	else {
		return ('unable to parse image file format', -1, -1, -1);
		}
	}








=item bmpsize($)

Usage:
	my ($err_msg, $x, $y, $filesize) = &bmpsize( $file );
	if ($err_msg) {
		print "<P><B>Error:</B> $err_msg.</P>\n";
		exit;
		}
	print "X: $x; Y: $y; Filesize: $filesize\n";

Returns the dimensions and byte size of a BMP image.

Based on Image::Size.

=cut

sub bmpsize {
	my ($file) = @_;

	my ($x, $y, $filesize) = (-1, -1, -1);

	my $buffer = '';

	my $err_msg = '';
	Err: {

		unless (-e $file) {
			$err_msg = "file '$file' does not exist";
			next Err;
			}

		$filesize = -s $file;

		unless (open(FILE, "<$file")) {
			$err_msg = "unable to read from file '$file' - $!";
			next Err;
			}
		unless (binmode(FILE)) {
			$err_msg = "unable to set binmode on file '$file' - $!";
			next Err;
			}

		my $buffer = '';
		read(FILE, $buffer, 26);
		($x, $y) = unpack("x18VV", $buffer);

		last Err;
		}
	return ($err_msg, $x, $y, $filesize);
	}









=item gifsize($)

Usage:
	my ($err_msg, $x, $y, $filesize) = &gifsize( $file );
	if ($err_msg) {
		print "<P><B>Error:</B> $err_msg.</P>\n";
		exit;
		}
	print "X: $x; Y: $y; Filesize: $filesize\n";

Returns the dimensions and byte size of a GIF image.

Based on Image::Size.

=cut

sub gifsize {
	my ($file) = @_;

	my ($x, $y, $filesize) = (-1, -1, -1);

	my $buffer = '';

	my $err_msg = '';
	Err: {

		unless (-e $file) {
			$err_msg = "file '$file' does not exist";
			next Err;
			}

		$filesize = -s $file;

		unless (open(FILE, "<$file")) {
			$err_msg = "unable to read from file '$file' - $!";
			next Err;
			}
		unless (binmode(FILE)) {
			$err_msg = "unable to set binmode on file '$file' - $!";
			next Err;
			}

		my ($cmapsize, $buf, $h, $w, $type);

		my $gif_blockskip = sub {
			my ($skip, $type) = @_;
			my ($lbuf);

			my $buffer = '';
			read(FILE, $buffer, $skip);
			while (1) {
				if (eof(FILE)) {
					$err_msg = "Invalid/Corrupted GIF (at EOF in GIF $type)";
					next Err;
					}
				read(FILE, $lbuf, 1);
				last if ord($lbuf) == 0;     # Block terminator
				read(FILE, $buffer, ord($lbuf));
				}
			};

		read(FILE, $type, 6);



		if (read(FILE, $buf, 7) != 7 ) {
			$err_msg = "Invalid/Corrupted GIF (bad header)";
			next Err;
			}
		($x) = unpack("x4 C", $buf);
		if ($x & 0x80) {
			$cmapsize = 3 * (2**(($x & 0x07) + 1));
			unless ($cmapsize == read(FILE, $buffer, $cmapsize)) {
				$err_msg = "Invalid/Corrupted GIF (global color map too small?)";
				next Err;
				}
			}


		FINDIMAGE: while (1) {

			if (eof(FILE)) {
				$err_msg = "Invalid/Corrupted GIF (at EOF w/o Image Descriptors)";
				next Err;
				}

			read(FILE, $buf, 1);
			($x) = unpack("C", $buf);

			if ($x == 0x2c) {
				# Image Descriptor (GIF87a, GIF89a 20.c.i)
				if (read(FILE, $buf, 8) != 8) {
					$err_msg = "Invalid/Corrupted GIF (missing image header?)";
					next Err;
					}
				($x, $w, $y, $h) = unpack("x4 C4", $buf);
				$x += $w * 256;
				$y += $h * 256;
				last Err;
				}

			if ($x == 0x21) {
				# Extension Introducer (GIF89a 23.c.i, could also be in GIF87a)
				read(FILE, $buf, 1);
				($x) = unpack("C", $buf);
				if ($x == 0xF9) {
					# Graphic Control Extension (GIF89a 23.c.ii)
					read(FILE, $buffer, 6);
					next FINDIMAGE;
					}
				elsif ($x == 0xFE) {
					# Comment Extension (GIF89a 24.c.ii)
					&$gif_blockskip(0, "Comment");
					next FINDIMAGE;
					}
				elsif ($x == 0x01) {
					# Plain Text Label (GIF89a 25.c.ii)
					&$gif_blockskip(13, "text data");
					next FINDIMAGE;
					}
				elsif ($x == 0xFF) {
					# Application Extension Label (GIF89a 26.c.ii)
					&$gif_blockskip(12, "application data");
					next FINDIMAGE;
					}
				else {
					$err_msg = "Invalid/Corrupted GIF (Unknown extension $x)";
					next Err;
					}
				}
			else {
				$err_msg = sprintf("Invalid/Corrupted GIF (Unknown code %#x)", $x);
				}
			}
		last Err;
		}
	return ($err_msg, $x, $y, $filesize);
	}



=item bmpsize($)

Usage:
	my ($err_msg, $x, $y, $filesize) = &jpegsize( $file );
	if ($err_msg) {
		print "<P><B>Error:</B> $err_msg.</P>\n";
		exit;
		}
	print "X: $x; Y: $y; Filesize: $filesize\n";

Returns the dimensions and byte size of a JPEG image.

Based on Image::Size.

=cut

sub jpegsize {
	my ($file) = @_;

	my ($x, $y, $filesize) = (-1, -1, -1);

	my $err_msg = '';
	Err: {

		unless (-e $file) {
			$err_msg = "file '$file' does not exist";
			next Err;
			}

		$filesize = -s $file;

		unless (open(FILE, "<$file")) {
			$err_msg = "unable to read from file '$file' - $!";
			next Err;
			}
		unless (binmode(FILE)) {
			$err_msg = "unable to set binmode on file '$file' - $!";
			next Err;
			}


		my $MARKER = "\xFF";       # Section marker.

		my $SIZE_FIRST  = 0xC0;         # Range of segment identifier codes
		my $SIZE_LAST   = 0xC3;         #  that hold size info.

		my ($marker, $code, $length);
		my $segheader;

		# Dummy read to skip header ID

		my $buffer = '';
		read(FILE, $buffer, 2);

		while (1) {
			$length = 4;
			read(FILE, $buffer, $length);

			# Extract the segment header.
			($marker, $code, $length) = unpack("a a n", $buffer);

			# Verify that it's a valid segment.
			if ($marker ne $MARKER) {
				# Was it there?
				$err_msg = "JPEG marker not found";
				next Err;
				}
			elsif ((ord($code) >= $SIZE_FIRST) && (ord($code) <= $SIZE_LAST)) {
				# Segments that contain size info
				$length = 5;

				read(FILE, $buffer, $length);

				($y, $x) = unpack("xnn", $buffer);
				last;
				}
			else {
				# Dummy read to skip over data
				read(FILE, $buffer, $length - 2);
				}
			}
		last Err;
		}
	return ($err_msg, $x, $y, $filesize);
	}



=item SetDefaults($%)

Usage:
	my $text = &SetDefaults( $html, \%params );

Takes $html, which is an HTML fragment including FORM elements, and sets all default attributes to match %params.

Requires strict format:

	<INPUT TYPE=radio NAME="name" VALUE="value">
	<INPUT TYPE=checkbox NAME="name" VALUE="value">
	<INPUT NAME="foo">
	<SELECT NAME="name".*?><OPTION VALUE="value"><OPTION VALUE="value"></SELECT>

Dependencies:
	&html_encode

=cut

sub SetDefaults {
	my ($text, $p_params) = @_;
	my @fragments = ();
	foreach (split(m!<INPUT !is, $text)) {
		if (m!^TYPE=(radio|checkbox) NAME="(.+?)" VALUE="(.+?)"(.*)$!is) {
			my ($type, $name, $value, $end) = ($1, $2, $3, $4);
			if ((defined($$p_params{$name})) and ($$p_params{$name} eq $value)) {
				$_ = "TYPE=\"$type\" NAME=\"$name\" CHECKED VALUE=\"$value\"$end";
				}
			}
		elsif (m!^TYPE=(radio|checkbox) NAME="(.+?)" VALUE=([^\s\>\"]+)(.*)$!is) {
			my ($type, $name, $value, $end) = ($1, $2, $3, $4);
			if ((defined($$p_params{$name})) and ($$p_params{$name} eq $value)) {
				$_ = "TYPE=\"$type\" NAME=\"$name\" CHECKED VALUE=\"$value\"$end";
				}
			}
		elsif (m!^NAME=\"(.+?)\"(.*)$!is) {
			my ($name, $end) = ($1, $2);
			if (defined($$p_params{$name})) {
				my $value = &html_encode( $$p_params{$name} );
				$_ = "VALUE=\"$value\" NAME=\"$name\"$end";
				}
			}
		push(@fragments, $_);
		}

	my $finaltext = join('<INPUT ', @fragments);
	@fragments = ();

	my $stub = '';
	foreach $stub (split(m!<SELECT !is, $finaltext)) {
		if ($stub =~ m!^NAME=\"(.+?)\"(.*?)</SELECT>(.*)$!is) {
			my ($name, $options, $end) = ($1, $2, $3);

			if (defined($$p_params{$name})) {
				$stub = "NAME=\"$name\"";

				my @frags = ();
				foreach (split(m!<OPTION !is, $options)) {
					if (m!^VALUE=\"(.*?)\"(.*)$!is) {
						if (lc($$p_params{$name}) eq lc($1)) {
							$_ = "SELECTED VALUE=\"$1\"$2";
							}
						}
					push(@frags, $_);
					}
				$stub .= join('<OPTION ', @frags);
				$stub .= "</SELECT>$end";
				}
			}
		push(@fragments, $stub);
		}
	$finaltext = join('<SELECT ', @fragments);

	@fragments = ();
	foreach $stub (split(m!<TEXTAREA !is, $finaltext)) {
		if ($stub =~ m!^NAME=\"(.+?)\"(.*?)>(.*?)</TEXTAREA>(.*)$!is) {
			my ($name, $attribs, $value, $end) = ($1, $2, $3, $4);
			if (defined($$p_params{$name})) {
				$stub = "NAME=\"$name\" $attribs>" . &html_encode( $$p_params{$name} ) . "</TEXTAREA>$end";
				}
			}
		push(@fragments, $stub);
		}
	$finaltext = join('<TEXTAREA ', @fragments);

	return $finaltext;
	}



=item where_tf

Usage:
	my ($err_msg, $path_to_script, $path_to_folder, $path_to_base, $url_to_script, $url_to_folder, $url_to_base) = &where_tf();
	if ($err_msg) {
		print "<P><B>Error:</B> $err_msg.</P>\n";
		}

Attempts to parse the location of this CGI script, in terms of the absolute file system path and the absolute URL path.  Draws data from $0 and %ENV.

To make formatting easier later on, removes trailing slashes on returned folders.

Bugs:
	treats all URL's as "http://" - doesn't account for https:// possibility or others

=cut

sub where_tf {
	my $err_msg = '';
	my @paths = ();
	Err: {
		local $_;

		my $abs_file_path = '';

		foreach ($0, &query_env('SCRIPT_FILENAME'), &query_env('PATH_TRANSLATED')) {
			s!\\!/!g;
			next unless (m!/|:!);
			$abs_file_path = $_;
			last;
			}

		unless ($abs_file_path) {
			$err_msg = "unable to determine absolute file path - \$0 or SCRIPT_FILENAME or PATH_TRANSLATED not defined";
			next Err;
			}
		unless (-e $abs_file_path) {
			$err_msg = "file discovery returned '$abs_file_path' as absolute file path, but -e existence check failed";
			next Err;
			}

		if (-d $abs_file_path) {
			my $test = $abs_file_path . &query_env('SCRIPT_NAME');
			$test =~ s!\\!/!g;
			if ((-e $test) and (not -d $test)) {
				$abs_file_path = $test;
				}
			}


		my $abs_url = '';
		my $script_name = &query_env('SCRIPT_NAME','/');

		foreach ('HTTP_HOST', 'SERVER_NAME') {
			my $var = &query_env($_);
			next unless ($var);
			$abs_url = "http://$var$script_name";
			last;
			}
		unless ($abs_url) {
			my $http_referer = &query_env('HTTP_REFERER');
			if ($http_referer) {
				$abs_url = $http_referer;
				$abs_url =~ s!(\?|\$\|\#)(.*)!!o;
				}
			}

		unless ($abs_url) {
			$err_msg = "unable to determine absolute file path - HTTP_HOST or SERVER_NAME or HTTP_REFERER not defined";
			next Err;
			}

		my $qm_rel_url = '';
		if ($abs_url =~ m!^http://([^/]+)/(.*?)$!) {
			$qm_rel_url = quotemeta($2);
			}

		$paths[0] = $paths[1] = $paths[2] = &onetru_path($abs_file_path);
		$paths[1] =~ s!/([^/]+)$!!o;
		$paths[2] =~ s!/$qm_rel_url!!o;

		$paths[3] = $abs_url;
		$paths[4] = $abs_url;
		$paths[5] = $abs_url;

		$paths[4] =~ s!/([^/]+)$!!o;
		$paths[5] =~ s!/$qm_rel_url!!o;

		last Err;
		}
	return ($err_msg, @paths);
	}



sub clean_path {
	local $_ = defined($_[0]) ? $_[0] : '';

	# trim whitespace:
	$_ = &Trim($_);

	# strip pound signs and all that follows (links internal to a page)
	s!\#.*$!!;

	# map "/./" to "/"
	s!/+\./+!/!g;

	# map trailing "/." to "/"
	s!/+\.$!/!g;

	# map "/folder/../" => "/"
	while (s!([^/]+)/+\.\./+!/!) {}

	# map /../foo => /foo
	while (s!^/+\.\./+!/!) {}

	s!^/+\.\.$!/!;

	# collapse back-to-back slashes:
	s!/+!/!g;

	return $_;
	}

sub Trim {
	local $_ = defined($_[0]) ? $_[0] : '';
	s!^[\r\n\s]+!!o;
	s![\r\n\s]+$!!o;
	return $_;
	}

sub untaintme {
	my ($p_val) = @_;
	$$p_val = $1 if ($$p_val =~ m!^(.*)$!s);
	}



sub web_auth_new {
	my %options = @_;
	my $self = {};
	bless($self);

	$self->{'data_folder'} = '.';
	$self->{'make_starter_accounts'} = 0;
	$self->{'seed'} = 'sX';
	my ($name, $value) = ();
	while (($name, $value) = each %options) {
		$self->{$name} = $value;
		}
	$self->{'data_folder'} =~ s!\\!/!g;
	$self->{'data_folder'} .= '/';
	$self->{'data_folder'} =~ s!//!/!g;
	$self->{'AuthFile'} = $self->{'data_folder'} . '.webauth_passwd';
	$self->{'TokenFile'} = $self->{'data_folder'} . '.webauth_tokens';
	return $self;
	}

sub InventPassword {
	my ($self) = @_;
	my $NewPassword = '';
	my @consonants = ('b', 'c', 'd', 'f', 'g', 'k', 'm', 'n', 'p', 'r', 's', 't', 'v');
	my $s_c = scalar @consonants;
	$NewPassword .= $consonants[int($s_c * rand())];
	$NewPassword .= ('a','e','i','o','u')[int(5 * rand())];
	$NewPassword .= $consonants[int($s_c * rand())];
	$NewPassword .= $consonants[int($s_c * rand())];
	$NewPassword .= ('a','e','i','o','u')[int(5 * rand())];
	$NewPassword .= $consonants[int($s_c * rand())];
	$NewPassword .= 10 + int(89 * rand());
	return $NewPassword;
	}



sub DeleteUser {
	my ($self, $username) = @_;
	my @lang_strings = @{ $self->{'lang_strings'} };
	my $err_msg = '';
	Err: {
		my $file = $self->{'AuthFile'};
		my $text = '';
		if (-e $file) {
			unless (open(FILE, "<$file")) {
				$err_msg = sprintf( $lang_strings[8], $file, $! );
				next Err;
				}
			unless (binmode(FILE)) {
				$err_msg = sprintf( $lang_strings[12], $file, $! );
				next Err;
				}
			while (<FILE>) {
				next unless (m!^(.*?)\:(.*?)\r?$!);
				my ($user, $crypt) = ($1, $2);
				next if ($user eq $username);
				$text .= "$user:$crypt\n";
				}
			close(FILE);
			}
		unless (open(FILE, ">$file")) {
			$err_msg = sprintf( $lang_strings[9], $file, $! );
			next Err;
			}
		unless (binmode(FILE)) {
			$err_msg = sprintf( $lang_strings[12], $file, $! );
			next Err;
			}
		print FILE $text;
		close(FILE);
		$err_msg = $self->flush_tokens( $username );
		next Err if ($err_msg);

		}
	return $err_msg;
	}


sub SetPassword {
	my ($self, $username, $password) = @_;
	my @lang_strings = @{ $self->{'lang_strings'} };
	my $err_msg = '';
	Err: {
		if (($const{'mode'} == 0) and ($username eq 'webmaster')) {
			$err_msg = "the password for user '$username' has been locked - it cannot be reset";
			next Err;
			}


		my $file = $self->{'AuthFile'};
		my $crypt = $self->CryptEx( $password );
		$err_msg = $self->DeleteUser( $username );
		next Err if ($err_msg);
		unless (open(FILE, ">>$file")) {
			$err_msg = sprintf( $lang_strings[10], $file, $! );
			next Err;
			}
		unless (binmode(FILE)) {
			$err_msg = sprintf( $lang_strings[12], $file, $! );
			next Err;
			}
		print FILE "$username:$crypt\n";
		close(FILE);
		}
	return $err_msg;
	}


sub ValidatePassword {
	my ($self, $username, $password) = @_;
	my @lang_strings = @{ $self->{'lang_strings'} };
	my $is_valid = 0;
	my $err_msg = '';
	Err: {
		my $file = $self->{'AuthFile'};
		unless (open(FILE, "<$file")) {
			$err_msg = sprintf( $lang_strings[8], $file, $! );
			next Err;
			}
		unless (binmode(FILE)) {
			$err_msg = sprintf( $lang_strings[12], $file, $! );
			next Err;
			}
		while (<FILE>) {
			next unless (m!^(.*?)\:(.*?)\r?$!);
			my ($user, $crypt) = ($1, $2);
			if ($user eq $username) {
				if ($crypt eq $self->CryptEx( $password )) {
					$is_valid = 1;
					}
				last;
				}
			}
		close(FILE);
		}
	return ($err_msg, $is_valid);
	}


=item logout()

Usage:
	$auth->logout();
	exit;

Clears user's cookies and tokens.  Presents the login page.

=cut

sub logout {
	my ($self) = @_;
	$self->Challenge( 0, 1 );
	}


=item Challenge($$)

my ($is_auth, $private_token, $auth_username) = $obj->Challenge( \%FORM, $b_logout );

=cut

sub Challenge {
	my ($self, $p_FORM, $b_logout) = @_;

	my $trace = '';

	my @lang_strings = @{ $self->{'lang_strings'} };
	my ($private_token, $public_token, $form_username, $form_password) = ('', '', '', '');

	my $test_cookie = '0';
	my $is_cookies_aware = 0;
	my $http_cookie = &query_env('HTTP_COOKIE');
	if ($http_cookie =~ m!web_auth_cp=([^\;]+)!) {
		$is_cookies_aware = 1;
		my $auth_cookie = $1;
		if ($auth_cookie ne $test_cookie) {
			$private_token = $auth_cookie;
			}
		}
	if (($p_FORM) and ('HASH' eq ref($p_FORM))) {
		if ($$p_FORM{'web_auth_cp'}) {
			$private_token = $$p_FORM{'web_auth_cp'};
			}
		if ($$p_FORM{'web_auth_user'}) {
			$form_username = $$p_FORM{'web_auth_user'};
			}
		if ($$p_FORM{'web_auth_pass'}) {
			$form_password = $$p_FORM{'web_auth_pass'};
			}
		}

	$trace .= "<P>Your auth_token is: '$private_token'</P>\n";



	my ($is_auth, $auth_username) = (0, '');

	my $script_name = &query_env('SCRIPT_NAME',$0);

	my $session_lifetime = 3600; # 1 hour
	my $grace_period = 600; # 10 min

	my ($status_msg, %auth_tokens) = ('');


	my $clear_cookie = 0;

	my $present_auth_form = 1;
	my $err_msg = '';
	Err: {



		if ($self->{'make_starter_accounts'}) {
			unless (-e $self->{'AuthFile'}) {
				$err_msg = $self->SetPassword( 'webmaster', '658uwantit' );
				if ($err_msg) {
					$present_auth_form = 0;
					next Err;
					}
				}
			}