# FILE: common.pl
# DESCRIPTION: Common subroutines and procedures
#-------------------------------------------------------------------------------
# DISCUS COPYRIGHT NOTICE
#
# Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
# The use of Discus is governed by the Discus License Agreement which is
# available from the Discus WWW site at:
#    http://www.discusware.com/discus/license
#
# Pursuant to the Discus License Agreement, this copyright notice may not be
# removed or altered in any way.
#-------------------------------------------------------------------------------

use strict;
use vars qw($GLOBAL_OPTIONS $PARAMS $DCONF);

#-------------------------------------------------------------------------------
# DEFINE PARAMETERS

undef $PARAMS;
$PARAMS->{'release'} = "4.00"; $PARAMS->{'revision'} = "9";
$PARAMS->{'serial'} = join("", ($DCONF->{pro} ? "1" : "0"), ".04.00.066");
$PARAMS->{'date'} = "04/07/2006";

#-------------------------------------------------------------------------------
# OTHER PARAMETERS, FOR CONVENIENCE & BACKWARD COMPATIBILITY

$PARAMS->{'url_to_default_image'} = "$DCONF->{'html_url'}/clipart/your_image.gif";
$PARAMS->{'cgiurl'} = "$DCONF->{'script_url'}/board-admin.$DCONF->{'cgi_extension'}";
$PARAMS->{'already_printed_header'} = 0;
$PARAMS->{'do_not_write_files'} = (-e "$DCONF->{admin_dir}/backups/QUOTA.txt");
$PARAMS->{'fs'} = '<font face="verdana,arial,helvetica" size="2">';
$PARAMS->{'files_locked_list'} = {};
$PARAMS->{'emergency_access'} = -f "$DCONF->{admin_dir}/data/emergency.txt";

#-------------------------------------------------------------------------------
# AMEND DISCUS.CONF PARAMETERS IF NOT ALREADY DEFINED

$DCONF->{'board_topics_file'} = "board-topics.html" if $DCONF->{'board_topics_file'} eq "";
$DCONF->{'perms0777'} = "0777" if $DCONF->{'perms0777'} eq "";
$DCONF->{'perms0666'} = "0666" if $DCONF->{'perms0666'} eq "";
$DCONF->{'perms0644'} = "0644" if $DCONF->{'perms0644'} eq "";
$DCONF->{'message_dir'} = "$DCONF->{html_dir}/messages" if $DCONF->{'message_dir'} eq "";
$DCONF->{'message_url'} = "$DCONF->{html_url}/messages" if $DCONF->{'message_url'} eq "";
$DCONF->{'secdir'} = "$DCONF->{admin_dir}/secure" if $DCONF->{'secdir'} eq "";
$DCONF->{'icon_dir'} = "icons" if $DCONF->{'icon_dir'} eq "";
$PARAMS->{'icon_url'} = defined $DCONF->{icon_url} ? $DCONF->{icon_url} : join("/", $DCONF->{html_url}, $DCONF->{icon_dir});
$DCONF->{'mail_charset'} = "us-ascii" if $DCONF->{mail_charset} eq "";
$DCONF->{'authorize_reader'} = "$DCONF->{script_url}/board-auth.$DCONF->{cgi_extension}" if ! defined $DCONF->{authorize_reader};

#-------------------------------------------------------------------------------
# CUSTOMIZED OR USER-INSTALLED PERL MODULES

unshift @INC, "$DCONF->{admin_dir}/perlpkgs" if ! defined $DCONF->{perl_package_dir};
unshift @INC, $DCONF->{perl_package_dir} if defined $DCONF->{perl_package_dir};

#-------------------------------------------------------------------------------
# RANDOM NUMBER SEED

srand(time);

#-------------------------------------------------------------------------------
# READ IN GLOBAL OPTIONS

if (! $DCONF->{no_read_options}) {
	undef $GLOBAL_OPTIONS;
	if (open (OPT, "$DCONF->{admin_dir}/options.txt")) {
		while (<OPT>) {
			$GLOBAL_OPTIONS->{$1} = unescape($2) if m|^(\w+)=(.*?)\s*$|;
		}
		close (OPT);
		if ($GLOBAL_OPTIONS->{enable_debugging}) {
			dreq("prgdebug");
			$GLOBAL_OPTIONS->{enable_debugging_user_hash} = program_debug_get_debugging_users($GLOBAL_OPTIONS->{debug_users});
		}
		$GLOBAL_OPTIONS->{'skinchoice'} = "tables2" if $GLOBAL_OPTIONS->{'skinchoice'} eq "";
	}
}

#-------------------------------------------------------------------------------
# PERFORMANCE MONITORING (IF ENABLED, MAINLY FOR DEBUGGING PURPOSES)

if ($GLOBAL_OPTIONS->{discus_taskman} == 0 && $GLOBAL_OPTIONS->{performance_monitoring} > 0) {
	my $pfm = $GLOBAL_OPTIONS->{performance_monitoring} == 1 ? ">" : ">>";
	if (open (PERFORMANCE_MONITOR, "$pfm $DCONF->{admin_dir}/data/performance.txt")) {
		performance_string("-" x 60);
		performance_string("Invoking at ", scalar(localtime(time)));
		performance_string("Opening $0");
		$PARAMS->{files_read} = 0;
		$PARAMS->{files_written} = 0;
		$PARAMS->{files_locked} = 0;
		$PARAMS->{files_unlocked} = 0;
		$PARAMS->{file_access} = {};
	}
}

#-------------------------------------------------------------------------------
# LIMIT SIMULTANEOUS ACCESSES BY YOUR GUESTS (PRO ONLY, IF CONFIGURED)

if ($DCONF->{pro} && $GLOBAL_OPTIONS->{limit_simultaneous_access_on} && $GLOBAL_OPTIONS->{limit_simultaneous_access} >= 1) {
	dreq("lim-accs-PRO");
	if (! limit_access_ok($ENV{'REMOTE_ADDR'})) {
		sleep 5;
		error_message("Access is Denied", "Host $ENV{'REMOTE_ADDR'} has accessed this page too often.", 0, 1);
	}
}

#-------------------------------------------------------------------------------
# START/CHECK DISCUS TASK MANAGER DAEMON

if ($GLOBAL_OPTIONS->{discus_taskman} == 1) {
	dreq("dtaskman"); taskman_init();
}

#-------------------------------------------------------------------------------
# IP BANNING (PRO ONLY)

if ($DCONF->{pro}) {
	dreq("bannedip-PRO");
	check_banned_ip($ENV{REMOTE_ADDR}, $ENV{REMOTE_HOST});
}

#-------------------------------------------------------------------------------
# DEFINE SUBROUTINES

###
### database_dbh
###
### As needed, in database mode, connect to database
###

sub database_dbh {
	return undef if $GLOBAL_OPTIONS->{database} == 0;
	return $PARAMS->{dbh} if defined $PARAMS->{dbh};
	dreq("dbint");
	$PARAMS->{dbh} = (db_connect(1))[0];
	return $PARAMS->{dbh};
}

###
### program_exit
###
### Replaces the "exit" function of Perl so that any necessary subroutines
### are called before you exit.
###

sub program_exit {
	my $status = shift;
	access_completed($ENV{'REMOTE_ADDR'}) if ($DCONF->{pro} && $GLOBAL_OPTIONS->{limit_simultaneous_access_on} && $GLOBAL_OPTIONS->{limit_simultaneous_access} >= 1);
	if (defined $PARAMS->{token_file}) {
		acs_write_token_file(undef, $PARAMS->{token_file}, { force_write => 1 });
	}
	if ($GLOBAL_OPTIONS->{performance_monitoring}) {
		performance_string("Closing via program_exit($status)");
		performance_string_dump();
		close (PERFORMANCE_MONITOR);
		chmod(oct($DCONF->{perms0666}), "$DCONF->{admin_dir}/data/performance.txt");
		unlock ("$DCONF->{admin_dir}/data/performance.txt");
	}
	if (defined $PARAMS->{dbh}) {
 		if (! $PARAMS->{dbh}->disconnect()) {
 			log_error("common.pl", "program_exit", join("", "Could not disconnect from database: ", $PARAMS->{dbh}->errstr()));
		}
	}
	if ($PARAMS->{debugging_on}) {
		program_debug_close();
	}
	exit($status);
}

###
### performance_string_dump
###
### Writes statistics to performance monitoring file
###

sub performance_string_dump {
	my ($identifier) = @_;
	performance_string("-" x 60);
	performance_string("Performance data for $identifier") if $identifier;
	performance_string(join("\t", times));
	performance_string("$PARAMS->{files_read} file(s) read, $PARAMS->{files_written} file(s) written");
	performance_string("$PARAMS->{files_locked} file(s) locked, $PARAMS->{files_unlocked} file(s) unlocked");
	foreach my $k (keys(%{ $PARAMS->{file_access} })) {
		performance_string("   * $PARAMS->{file_access}->{$k}->{read} read(s), $PARAMS->{file_access}->{$k}->{write} writes(s) on $k");
	}
	performance_string("-" x 60);
}

###
### performance_string
###
### Writes out a string in performance monitoring
###

sub performance_string {
	return undef if ! $GLOBAL_OPTIONS->{performance_monitoring};
	my $string = join("", @_);
	my ($sec, $min, $hour, $day, $nmonth, $year) = localtime(time);
	my $dt = sprintf("%04d-%02d-%02d %02d:%02d:%02d", 1900+$year, 1+$nmonth, $day, $hour, $min, $sec);
	print PERFORMANCE_MONITOR "$dt $$ $ENV{REMOTE_ADDR} $string\n";
	if (0) {
		if (ref $PARAMS->{lockfiles} eq 'HASH' && scalar keys %{$PARAMS->{lockfiles}} > 0) {
			foreach my $x (keys %{$PARAMS->{lockfiles}}) {
				print PERFORMANCE_MONITOR "\tLocked: $x\n";
			}
		}
	}
}

###
### cookie_string_format
###
### Generates a string to set a cookie
###

sub cookie_string_format {
	my ($cookie_name, $cookie_value, $expiration) = @_;
	my $str = join("", "Set-Cookie: $cookie_name$DCONF->{COOKIE_ID}=", escape($cookie_value), ";");
	$str .= " expires=$expiration;" if $expiration ne "";
	$str .= " path=/\n";
	return $str;
}

###
### directory_list
###
### Lists all files in a directory
###

sub directory_list {
	my ($basedir, $pat, $no_incl_basedir) = @_;
	my @o = ();
	if (opendir(DIR, $basedir)) {
		@o = map {"$basedir/$_"} grep {not /^\.\.?$/} readdir DIR if ! $no_incl_basedir;
		@o = map {$_} grep {not /^\.\.?$/} readdir DIR if $no_incl_basedir;
		closedir(DIR);
		@o = grep(/$pat/, @o) if defined $pat;
	}
	return \@o;
}

###
### get_message_path
###
### Gets path to message directory for a particular topic
###

sub get_message_path {
	my ($topic) = @_;
	return $PARAMS->{topic_message_path}->{$topic} if defined $PARAMS->{topic_message_path}->{$topic};
	my $in_topic = $topic; $topic =~ s/\D//g;
	error_message("Topic Format Error", "Invalid topic request [$in_topic]!", 0, 1) if $topic eq "";
	return join("/", $DCONF->{message_dir}, $topic) if ! $DCONF->{pro};
	if (-e "$DCONF->{secdir}/$topic") {
		$PARAMS->{topic_message_path}->{$topic} = join("/", $DCONF->{secdir}, $topic);
	} else {
		$PARAMS->{topic_message_path}->{$topic} = join("/", $DCONF->{message_dir}, $topic);
	}
	return $PARAMS->{topic_message_path}->{$topic};
}

###
### attachment_scan
###
### Finds what attachments are present within messages
###

sub attachment_scan {
	my ($message_in) = @_;
	my @m = ref $message_in eq 'ARRAY' ? @{$message_in} : ($message_in);
	my @att = ();
	my $murl = quotemeta($DCONF->{message_url});
	my $hurl = quotemeta($DCONF->{html_url});
	$murl =~ s%\\/%\\/\+%g;
	$hurl =~ s%\\/%\\/\+%g;
	my $ctr = -1;
	foreach my $msg (@m) {
		$ctr++;
		my $text = ref $msg eq 'HASH' ? $msg->{text} : $msg;
		my $postnum = ref $msg eq 'HASH' ? $msg->{number} : 0;
		# Version 3.10/4.00 GIFs and JPEGs
		while ($text =~ m%<IMG SRC="$murl/+(\d+)/(\d+)\.(gif|jpg)" ALT="(.*?)"%gi) {
			push @att, { counter => $ctr, postnum => $postnum, type => 'image', filename => join('.',$2,$3), mime => join("/", 'image', $3 eq "gif" ? $3 : "jpeg"), descr => $4 };
		}
		# Version 3.10/4.00 PNGs
		while ($text =~ m%<IMG SRC="$murl/+(\d+)/(\d+)\.(png)" ALT="(.*?)"%gi) {
			push @att, { counter => $ctr, postnum => $postnum, type => 'image', filename => join('.',$2,$3), mime => "image/x-png", descr => $4 };
		}
		# Thumbnailed version 4.00 GIFs and JPEGs
		while ($text =~ m%<IMG SRC="$murl/+(\d+)/(\d+)t\.(gif|jpg)" ALT="(.*?)"%gi) {
			push @att, { counter => $ctr, postnum => $postnum, type => 'image', filename => join('.',$2,$3), mime => join("/", 'image', $3 eq "gif" ? $3 : "jpeg"), descr => $4 };
			push @att, { counter => $ctr, postnum => $postnum, type => 'image', filename => join('',$2,"t.",$3), mime => join("/", 'image', $3 eq "gif" ? $3 : "jpeg"), descr => $4 };
		}
		# Thumbnailed version 4.00 PNGs
		while ($text =~ m%<IMG SRC="$murl/+(\d+)/(\d+)t\.(png)" ALT="(.*?)"%gi) {
			push @att, { counter => $ctr, postnum => $postnum, type => 'image', filename => join('.',$2,$3), mime => "image/x-png", descr => $4 };
			push @att, { counter => $ctr, postnum => $postnum, type => 'image', filename => join('',$2,"t.",$3), mime => "image/x-png", descr => $4 };
		}
		# Version 3.10 Attachments
		my $icdir = $DCONF->{icon_dir};
		while ($text =~ m%<!-attachment: (.*?)-!><center><table border=1><tr><td><img src="$hurl/+$icdir/(.*?)" align=left alt="(.*?)">(.*?)<br><a href="$murl/+(\d+)/\1"><b>(.*?)</b></a> \((.*?) k\)</td></tr></table></center><!-/attachment-!>%gi) {
			push @att, { counter => $ctr, postnum => $postnum, type => 'attach', filename => $1, mime => $3, showfile => $6, size => $7, descr => $4, icon => $2 };
		}
		# Version 4.00 Attachments
		while ($text =~ m%<!--attachment: (.*?)\*(.*?)\*(.*?)\*(.*?)\*(.*?)\*(.*?) -->%gi) {
			push @att, { counter => $ctr, postnum => $postnum, type => 'attach', filename => $1, icon => $2, mime => $3, size => $4, descr => unescape($5), showfile => unescape($6) };
		}
	}
	return \@att;
}

###
### discus
###
### This runs Discus, based on the file name of the script calling.
###

sub discus {
	my ($s, $FORMref, $cookie_str) = @_;
	$s = determine_script_name($s);
	$PARAMS->{calling_script} = $s;
	if ($s eq "board-viewtree") {
		maintenance_mode_error() if $GLOBAL_OPTIONS->{maintenance};
		dreq("treeview"); tree_control($FORMref, $cookie_str);
	}
	if ($s eq "board-post-form") {
		dreq("posting"); posting_control({ action => 'form' });
	}
	if ($s eq "board-post") {
		dreq("posting"); posting_control(undef, $FORMref, $cookie_str);
	}
	if ($s =~ m|^board-admin| || $s eq "admin") {
		dreq("admin-pl"); admin_control();
	}
	if ($s eq "board-auth") {
		error_message(read_language()->{FEATURE_NOT_SUPPORTED}, read_language()->{FEATURE_NOT_SUPPORTED_DESCR}) if ! $DCONF->{pro};
		dreq("authwrap-PRO"); auth_wrapper();
	}
	if ($s eq "board-profile") {
		dreq("ui-prfle"); user_interface_profile_control();
	}
	if ($s eq "discus" || $s eq "show") {
		dreq("ui-main"); user_interface_main_control();
	}
	if ($s eq "board-newmessages" || $s eq "board-search" || $s eq "search") {
		maintenance_mode_error() if $GLOBAL_OPTIONS->{maintenance};
		dreq("search"); search_control($FORMref, $cookie_str);
	}
	if ($s eq "board-contact") {
		dreq("contact"); contact_control();
	}
	if ($s eq "board-image-lister") {
		maintenance_mode_error() if $GLOBAL_OPTIONS->{maintenance};
		dreq("img-list"); image_lister_control();
	}
	if ($s eq "allusers") {
		error_message(read_language()->{FEATURE_NOT_SUPPORTED}, read_language()->{FEATURE_NOT_SUPPORTED_DESCR}) if ! $DCONF->{pro};
		maintenance_mode_error() if $GLOBAL_OPTIONS->{maintenance};
		dreq("allusers-PRO"); user_list_control($FORMref, $cookie_str);
	}
	if ($s eq "reply-email") {
		program_exit(0) if $GLOBAL_OPTIONS->{maintenance};
		dreq("em-reply"); reply_pipe_input();
	}
	if ($s eq "cron-email") {
		program_exit(0) if $GLOBAL_OPTIONS->{maintenance};
		dreq("cronhook"); hook_manager();
	}
	if ($s eq "diagnose") {
		dreq("diags"); diags();
	}
	error_message("Invalid Script", "Script <b>$s</b> does not have an action associated with it, or execution failed.", 0, 1);
}

sub determine_script_name {
	my $s = case_lower($_[0]);
	$s = $2 if $s =~ m|^(.*)[\\/](.*)|;
	$s = $` if $s =~ m|\.|;
	return $s if $s =~ /^[\w\-]+$/;
	my @envs = ('SCRIPT_FILENAME', 'REQUEST_URI', 'SCRIPT_NAME', 'DOCUMENT_URI');
	foreach my $e (@envs) {
		next if $ENV{$e} eq "";
		my $s2 = $ENV{$e};
		$s2 = $2 if $s2 =~ m|^(.*)[\\/](.*)|;
		$s2 = $` if $s2 =~ m|\.|;
		return $s2 if $s2 =~ /^[\w\-]+$/;
	}
	return $s;
}

###
### header
###
### Prints the standard header, and the cookie string if needed, and sets $|=1
### so the server displays any errors more gracefully.  If you have a bizarre
### server you may need to reverse the "Content-type" line and the $cookie
### line.
###

sub header {
	my ($cookie, $alternate_mime_type, $content_disposition) = @_;
	return 0 if $PARAMS->{'already_printed_header'};
	if ($cookie ne "") {
		my $c = {};
		my @ckstr = split(/\n/, $cookie);
		foreach my $l (@ckstr) {
			$c->{$1} = $l if $l =~ m|^set-cookie: (\w+)$DCONF->{COOKIE_ID}=|i;
		}
		$cookie = "";
		my $k = 0;
		foreach my $l (keys(%{ $c })) {
			$cookie .= "$c->{$l}\n";
		}
	}
	$PARAMS->{'already_printed_header'} = 1;
	$| = 1;
	print "Content-type: text/html\n" if $alternate_mime_type eq "";
	print "Content-type: $alternate_mime_type\n" if $alternate_mime_type ne "";
	print "Content-disposition: inline; filename=$content_disposition\n" if $content_disposition ne "";
	print $cookie if $cookie ne "";
	print "\n";
}

###
### read_language
###
### Reads the language.conf, language_pro.conf, language_400.conf, etc.,
### files from the appropriate directories, and stores the result in
### $PARAMS->{L}.
###

sub read_language {
	my ($topic) = @_;
	return $PARAMS->{L} if defined $PARAMS->{L};
	my $langdir = $DCONF->{admin_dir};
	$langdir = get_message_path($topic) if defined $topic;
	my @lfiles = ('language', 'language_pro', 'lang40');
	my $L = {};
	foreach my $file (@lfiles) {
		undef my @lang;
		if (open(FILE, "$langdir/$file.conf")) {
			@lang = <FILE>;
			close (FILE);
		} elsif (open(FILE, "$DCONF->{admin_dir}/$file.conf")) {
			@lang = <FILE>;
			close (FILE);
		} else {
			next;
		}
		@lang = grep(!/^#/, @lang);
		@lang = grep(/\S/, @lang);
		undef my $cur;
		undef my $del;
		foreach my $line (@lang) {
			$line =~ s/##(.*)//;
			$line =~ s/^\s+//;
			$line =~ s/\s+$//;
			if ($line =~ m|^\$(\w+)|) {
				$cur = $1; $del = "";
			} elsif ($line =~ m|^\@(\w+)\((.)\)|) {
				$cur = $1; $del = $2;
			} elsif ($del ne "") {
				my @arr = split(/$del/, $line);
				foreach my $a (@arr) {
					$a =~ s/^\s+//;
					$a =~ s/\s+$//;
				}
				$L->{$cur} = \@arr;
			} elsif ($cur ne "") {
				$line =~ s/\\\s*$/\n/;
				$L->{$cur} .= $line . " ";
			}
		}
		foreach my $key (keys(%{$L})) {
			$L->{$key} =~ s/^ +//;
			$L->{$key} =~ s/ +$//;
		}
	}
	$PARAMS->{L} = $L;
	return $L;
}

###
### dreq
###
### Discus REQuire subroutine: reads in required "source" subroutines as needed,
### but only once.  For some, replacement Discus Pro files are provided, resulting
### in two possibilities, separated by the |, with the first entry being the file
### to load for freeware Discus, and the second one the Discus Pro file.
###

sub dreq {
	while (my $file = shift(@_)) {
		if ($file =~ m%^(.*)\|(.*)$%) {
			$file = ($DCONF->{pro} ? $2 : $1);
		}
		next if $PARAMS->{'ALREADY_READ'}->{$file};
		performance_string("\% Reading subroutine: $file");
		if ($file =~ m|-PRO$|) {
			my $path = join("/", $DCONF->{admin_dir}, "source", "PRO_$DCONF->{pro_fileid}", "$`.pl");
			require $path || error_message("Require Error", "Could not require file $file.pl");
		} else {
			require "$DCONF->{admin_dir}/source/$file.pl" || error_message("Require Error", "Could not require file $file.pl");
		}
		$PARAMS->{'ALREADY_READ'}->{$file} = 1;
	}
	return 1;
}

###
### parse_form
###
### Reads in form variables from standard input (POST method) or the URL QUERY_STRING
### (GET method)
###

sub parse_form {
	my ($query_string, $content_length, $forceform) = @_;
	undef my $FORM;
	my $null = pack("c", 0);
	$content_length = $ENV{CONTENT_LENGTH} if $content_length == 0;
	if ($ENV{CONTENT_TYPE} =~ m|^multipart/form-data|) {
		dreq("fcn-mtp"); $FORM = parse_multipart($content_length);
	} else {
		if ($content_length != 0) {
			binmode(STDIN);
			read(STDIN, my $buffer, $content_length);
			my @pairs = split(/&/, $buffer);
			foreach my $pair (@pairs) {
				my ($name, $value) = split(/=/, $pair);
				$value =~ tr/+/ /;
				$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
				$value =~ s/<!--#(\w*)(\s*)(\w*)(\s*)=(\s*)"([^"]*)"(.*)-->//g;
				$value =~ s/\r//g;
				$value =~ s/$null//g;
				if ($FORM->{$name} eq "") {
					$FORM->{$name} = $value;
				} else {
					$FORM->{$name} .= ",$value";
				}
			}
		}
		$query_string =~ s/#(.*)$//;
		if ($query_string ne "") {
			my @query_pairs = split(/&/, $query_string);
			foreach my $qpair (@query_pairs) {
				my ($qname, $qvalue) = split(/=/, $qpair);
				$qvalue = unescape($qvalue);
				$qvalue =~ s/<!--#(\w*)(\s*)(\w*)(\s*)=(\s*)"([^"]*)"(.*)-->//g;
				$qvalue =~ s/$null//g;
				$FORM->{$qname} .= ",$qvalue" if $FORM->{$qname} ne "";
				$FORM->{$qname} = $qvalue if $FORM->{$qname} eq "";
			}
		}
	}
	my $cbuffer = $ENV{'HTTP_COOKIE'};
	if ($ENV{'HTTP_COOKIE'} eq "" && $ENV{'COOKIE'} ne "") {
		$cbuffer = $ENV{'COOKIE'};  #O'Reilly WebSitePro
	}
	my @cpairs = split(/; /, $cbuffer);
	my $ckid = defined $DCONF->{COOKIE_ID} ? quotemeta($DCONF->{COOKIE_ID}) : "";
	foreach my $cpair (@cpairs) {
		my ($cname, $cvalue) = split(/=/, $cpair);
		next if $cname !~ /$ckid$/;
		$cname =~ s/$DCONF->{COOKIE_ID}$//;
		$FORM->{'COOKIE'}->{$cname} = unescape($cvalue);
	}
	if (defined $forceform) {
		foreach my $i (keys(%{ $forceform })) {
			$FORM->{$i} = $forceform->{$i};
		}
	}
	if ($GLOBAL_OPTIONS->{enable_debugging}) {
		dreq("authpass");
		my $user = $FORM->{username};
		$user = $FORM->{COOKIE}->{user} if $user eq "";
		$user = $FORM->{COOKIE}->{admuser} if $user eq "";
		$user = prepare_userpass($user);
		program_debug_invoke($FORM, $user) if $GLOBAL_OPTIONS->{enable_debugging_user_hash}->{$user};
	}
	if ($FORM->{COOKIE}->{access} == 1 && $DCONF->{pro} && $FORM->{pg} ne "logout") {
		if (! $GLOBAL_OPTIONS->{no_banned_user_ban}) {
			dreq("ipaddr-PRO");
			ban_ip_address([{ip => $ENV{REMOTE_ADDR}, reason => read_language()->{BAN_DUE_TO_COOKIE}}]);
		}
		error_message(read_language()->{IP_BANNED}, read_language()->{IP_BANNED_MESSAGE}, 0, 1);
	}
	close (STDIN);
	return $FORM;
}

###
### escape
###
### Quotes strings in standard format
###

sub escape {
	my $i = shift;
	$i =~ s/([^\w ])/sprintf("%%%02lx", ord($1))/eg; $i =~ tr/ /+/;
	return $i;
}

###
### unescape
###
### Inverse of "escape" function
###

sub unescape {
	my $i = shift;
	$i =~ tr/+/ /; $i =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
	return $i;
}


###
### case_equal
###
### Sees if two text strings are equal, ignoring case
###

sub case_equal {
	my ($arg1, $arg2) = @_;
	return case_lower($arg1) eq case_lower($arg2);
}

###
### case_lower
###
### Lower-cases a string
###

sub case_lower {
	my ($string) = @_;
	if (defined read_language()->{TBL_CAPS} && defined read_language()->{TBL_SMALL}) {
		my @tbl_1 = split(//, read_language()->{TBL_CAPS});
		my @tbl_2 = split(//, read_language()->{TBL_SMALL});
		while (my $x = shift @tbl_1) {
			if (my $y = shift @tbl_2) {
				$x = quotemeta($x);
				$string =~ s/$x/$y/;
			}
		}
		return $string;
	} else {
		return lc($string);
	}
}

###
### case_upper
###
### Upper-cases a string
###

sub case_upper {
	my ($string) = @_;
	if (defined read_language()->{TBL_CAPS} && defined read_language()->{TBL_SMALL}) {
		my @tbl_1 = split(//, read_language()->{TBL_CAPS});
		my @tbl_2 = split(//, read_language()->{TBL_SMALL});
		while (my $x = shift @tbl_2) {
			if (my $y = shift @tbl_1) {
				$x = quotemeta($x);
				$string =~ s/$x/$y/;
			}
		}
		return $string;
	} else {
		return uc($string);
	}
}

###
### char_convert
###
### Converts selected characters to their HTML equivalents, controlled by
### charconvert.conf file, found in administration directory.  Can go
### either way depending on how it's called.
###

sub char_convert {
	my ($stringin, $context, $args) = @_;
	undef my @CHARCONVERT;
	if (!defined($PARAMS->{'CHARCONVERT'})) {
		if (open(CHAR, "$DCONF->{'admin_dir'}/charconvert.conf")) {
			my @char = <CHAR>;
			close (CHAR);
			@char = grep(!/^\s*#/, @char);
			@char = grep(/\S/, @char);
			foreach my $line (@char) {
				if ($line =~ m|^\s*(\S+)\s*(.+)|) {
					my ($tag, $conv) = ($1, $2);
					$conv =~ s/\s+$//;
					if ($conv =~ m%\s*\<\|\s*$%) {
						$conv = $`;
						$conv =~ s/\$html_url/$DCONF->{'html_url'}/g;
						$conv =~ s/\$ext/$DCONF->{'ext'}/g;
						$conv =~ s/\$script_url/$DCONF->{'script_url'}/g;
						$conv =~ s/\$cgi_extension/$DCONF->{'cgi_extension'}/g;
						$conv =~ s/\$message_url/$DCONF->{'message_url'}/g;
						$conv =~ s/\$titlej/$DCONF->{'titlej'}/g;
						$conv =~ s/\$title/$DCONF->{'title'}/g;
						$conv =~ s/\$topic/$args->{'topic_number'}/g;
						$conv =~ s/\$page/$args->{'me_number'}/g;
					}
					push (@CHARCONVERT, "$tag\t$conv");
				}
			}
			$PARAMS->{'CHARCONVERT'} = \@CHARCONVERT;
		} else {
			$_ = $stringin;
			if ($context == 0) {
				s/&/&amp;/g; s/</\&#60;/g; s/>/\&#62;/g; s/"/&#34;/g; s/\\\\/&#92;/g;
				s/\\\{/&#123;/g; s/\\\}/&#125;/g; s/\\,/&#44;/g; s/\(/&#40;/g;
				s/\)/&#41;/g; s/\[/&#91;/g; s/\]/&#93;/g; s/\*/&#42;/g; s/\+/&#43;/g;
				s/\|/&#124;/g; s/'/&#39;/g;
				return $_;
			} else {
				s/&#39;/'/g; s/&#124;/\|/g; s/&#43;/\+/g; s/&#42;/\*/g;
				s/&#93;/\]/g; s/&#91;/\[/g; s/&#41;/\)/g; s/&#40;/\(/g;
				s/&#44;/,/g; s/&#125;/\}/g; s/&#123;/\{/g; s/&#92;/\\/g;
				s/&#34;/"/g; s/&#62;/>/g; s/&#60;/</g; s/&amp;/&/g;
				if ($args->{'JSP'} == 1) {
					$_ =~ s/<IMG SRC="[^"]*" ALT="([^"]*)"[^>]*>/\[$1\]/gi;
					$_ =~ s/<([^>]*)>//g if $args->{'nostrip'} == 0;
					$_ =~ s/\n//g;
					$_ =~ s/&#(\d+);//g;
					$_ =~ s/'//g;
					$_ =~ s/"//g;
					$_ =~ s/&quot;//g;
					$_ =~ s/&amp;//g;
				}
				return $_;
			}
		}
	}
	if ($context == 0) {
		foreach my $tag (@{ $PARAMS->{'CHARCONVERT'} }) {
			$tag =~ m|(\S+)\t(.*)|; my $conv = $2; my $line = quotemeta($1);
			next if $conv =~ /\s*\|\>\s*$/;
			$conv =~ s/\s*\<\>\s*$//;
			$stringin =~ s/$line/$conv/g;
		}
		$stringin =~ s/\r\n/\n/g;
		$stringin =~ s/\r/\n/g;
		$stringin =~ s/\n/ <BR>/g;
	} else {
		$stringin =~ s/ <BR>/\n/g;
		foreach my $tag (reverse(@{ $PARAMS->{'CHARCONVERT'} })) {
			if ($tag =~ m|(\S+)\t(.*)|) {
				my $line = $1; my $conv = $2;
				next if $conv =~ /\s*\<\>\s*$/;
				$conv =~ s/\s*\|\>\s*$//; $conv = quotemeta($conv);
				$stringin =~ s/$conv/$line/g;
			}
		}
		$stringin =~ s/\r\n/\n/g;
		$stringin =~ s/\r/\n/g;
		$stringin =~ s/&nbsp;/ /g;
	}
	if ($args->{'JSP'} == 1) {
		$stringin =~ s/<IMG SRC="[^"]*" ALT="([^"]*)"[^>]*>/\[$1\]/gi;
		$stringin =~ s/<([^>]*)>//g if $args->{'nostrip'} == 0;
		if ($args->{'convert_html'} == 1) {
			$stringin =~ s/([^\w&#; ])/makeord($1)/ge;
			$stringin =~ s/\n//g;
		} elsif ($args->{'convert_html'} == 2) {
			$stringin =~ s/&#(\d+);/chr($1)/ge;
			$stringin =~ s/&quot;/"/g;
			$stringin =~ s/&amp;/&/g;
		} elsif ($args->{'convert_html'} == 0) {
			$stringin =~ s/&#(\d+);//g;
			$stringin =~ s/'//g;
			$stringin =~ s/"//g;
			$stringin =~ s/&quot;//g;
			$stringin =~ s/&amp;//g;
			$stringin =~ s/\n//g;
		}
	}
	return $stringin;
}

###
### error_message
###
### Exits gracefully should an error message be needed
###

sub error_message {
	my ($reason, $explanation, $flag, $noerr, $nobug) = @_;
	dreq("template");
	my $subst = {};
	$subst->{'general'}->{'reason'} = $reason;
	$subst->{'general'}->{'explanation'} = $explanation;
	$subst->{'general'}->{'flag'} = $flag;
	$subst->{'general'}->{'noerr'} = $noerr;
	$subst->{'general'}->{'nobug'} = $nobug;
	$subst->{'general'}->{'excl_pt'} = $!;
	$subst->{'general'}->{'perl'} = $];
	$subst->{'general'}->{'cookies'} = $ENV{HTTP_COOKIE_STRING};
	$subst->{'general'}->{'os'} = $^O;
	return templ_int("errormsg", $subst) if $PARAMS->{no_exit};
	screen_out("errormsg", $subst);
}

###
### seturl
###
### Redirects the browser to a new location.  If you have a REALLY old server
### (like Personal Web Server 1.0) where the "Location: " header doesn't work
### right, you may need to add "nph_server=1" to discus.conf.
###

sub seturl {
	my ($targeturl, $noexit) = @_;
	return "OK" if $PARAMS->{no_exit};
	if (!($DCONF->{'nph_server'})) {
		print "Location: $targeturl\n\n";
		program_exit(0) if ! $noexit;
	} else {
		header();
		print "<META HTTP-EQUIV=\"Refresh\" CONTENT=\"0; URL=$targeturl\">\n";
		program_exit(0) if ! $noexit;
	}
}

###
### lock
###
### Locks a file or files.
###

sub lock {
	my $arg = ref $_[0] eq "HASH" ? shift @_ : undef;
	my @files = @_;
	my $subr_locker = $files[0] !~ m|[/\*\.]| ? shift @files : "";
	my $max = (defined $arg->{max} ? $arg->{max} : 7);
	if ($GLOBAL_OPTIONS->{performance_monitoring}) {
		foreach my $file (@files) {
			performance_string("-> [$subr_locker] Lock request on $file");
			$PARAMS->{lockfiles}->{$file} = 1;
		}
	}
	if ($GLOBAL_OPTIONS->{database}) {
		dreq("dbint");
		return sql_lock(\@files, $subr_locker, $max);
	}
	if ($GLOBAL_OPTIONS->{'lock_with_file'} == 1) {
		dreq("lockfile");
		while (my $f = unshift(@files)) {file_based_file_lock($f);}
		return 1;
	}
	if ($GLOBAL_OPTIONS->{'lock_with_directory_file'}) {
		dreq("locking");
		return directory_file_based_file_lock(\@files, $subr_locker, $max);
	}
	foreach my $file (@files) {
		my $filenm = $file =~ m|.*/(.*)| ? $1 : $file;
		performance_string("# LOCK: requested on $file") if $GLOBAL_OPTIONS->{performance_monitoring};
		$PARAMS->{files_locked}++;
		if ($file eq "*") {
			my $success = file_lock_do("GLOBAL");
			if (! $success) {
				my $es = read_language()->{'FILELOCKREGEN'}; $es =~ s/\%sec/7/g;
				log_error("common.pl", "lock", "Request for lock on $filenm failed... [$$] (GLOBAL LOCK exists)");
				error_message(read_language()->{'FILELOCKERROR'}, "$es [$filenm]", 0, 1);
			}
			next;
		} else {
			my $Z = file_name_escape("GLOBAL");
			my $lock_file = join("/", $DCONF->{admin_dir}, "locks", $Z);
			if (-e $lock_file) {
				file_check_lock("GLOBAL");
				if (-e $lock_file) {
					my $es = read_language()->{'FILELOCKREGEN'}; $es =~ s/\%sec/7/g;
					log_error("common.pl", "file_lock", "Request for lock on $filenm failed... [$$] (GLOBAL LOCK exists)");
					error_message(read_language()->{'FILELOCKERROR'}, "$es [$filenm]", 0, 1);
				}
			}
			next if file_lock_do($filenm);
			return 0 if $filenm eq "$DCONF->{board_topics_file}";
			performance_string("# LOCK: *FAILED* lock on $file") if $GLOBAL_OPTIONS->{performance_monitoring};
			log_error("common.pl", "file_lock", "Request for lock on $filenm failed");
			error_message(read_language()->{'FILELOCKERROR'}, join("<br>", read_language()->{FILEISLOCKED}, "[$filenm]"), 0, 1);
		}
	}
	return 1;
}

###
### unlock
###
### Unlocks a file or files.
###

sub unlock {
	my @files = @_;
	my $arg = undef;
	$arg = shift @files if ref $files[0] eq "HASH";
	shift @files if $files[0] !~ m|[\*/\.]|;
	my $tcache = time;
	if ($GLOBAL_OPTIONS->{performance_monitoring}) {
		foreach my $file (@files) {
			performance_string("-> Unlock request on $file");
			delete $PARAMS->{lockfiles}->{$file};
		}
	}
	if ($GLOBAL_OPTIONS->{database}) {
		dreq("dbint");
		return sql_unlock(\@files);
	}
	if ($GLOBAL_OPTIONS->{'lock_with_file'} == 1) {
		dreq("lockfile");
		file_based_file_unlock(@files);
		return 1;
	}
	if ($GLOBAL_OPTIONS->{'lock_with_directory_file'}) {
		dreq("locking");
		return directory_file_based_file_unlock(\@files);
	}
	foreach my $file (@files) {
		my $filenm = $file =~ m|.*/(.*)| ? $1 : $file;
		performance_string("# UNLOCK: requested on $file") if $GLOBAL_OPTIONS->{performance_monitoring};
		$PARAMS->{files_unlocked}++;
		my $fn = $file eq "*" ? "GLOBAL" : $filenm;
		my $Z = file_name_escape($fn);
		if (-e "$DCONF->{admin_dir}/locks/$Z") {
			if (! rmdir "$DCONF->{admin_dir}/locks/$Z") {
				my $d1 = $!;
				if (! unlink "$DCONF->{admin_dir}/locks/$Z") {
					log_error("common.pl", "unlock", "Unlocking of file '$file' failed: (rmdir: $d1; unlink: $!)");
					error_message("File Locking Malfunction", "File locking does not function properly on this server.", 0, 1);
				}
			}
		}
	}
	return 1;
}

###
### file_lock_do
###
### Actually does a file lock
###

sub file_lock_do {
	my ($file) = @_;
	my $Z = file_name_escape($file);
	error_message("Illegal Lock Name", "[$Z]", 0, 1) if $Z !~ /^\w+$/;
	my $lock_file = join("/", $DCONF->{admin_dir}, "locks", $Z);
	my $tries = 0;
	while ($tries <= 5) {
		my $q = mkdir($lock_file, oct($DCONF->{perms0777}));
		if ($q) {
			chmod oct($DCONF->{perms0777}), $lock_file;
			return 1;
		}
		if ($tries == 0) {
			log_error("common.pl", "file_lock_do", "Could not create directory to lock '$file' due to: $!");
		}
		file_check_lock($file, $tries);
		$tries++;
	}
	return 0;
}

###
### file_check_lock
###
### Checks to see if a file is locked, and removes stale locks
###

sub file_check_lock {
	my ($file, $tries) = @_;
	my $Z = file_name_escape($file);
	my $lock_file = join("/", $DCONF->{admin_dir}, "locks", $Z);
	my $timecache = time;
	my $lock_mtime = file_get_mtime($lock_file);
	if ($timecache - $lock_mtime >= 10 && -e $lock_file) {
		log_error("common.pl", "file_check_lock", "Stale lock detected on $file: " . ($timecache-$lock_mtime) . " seconds old");
		my $success = $file eq "GLOBAL" ? unlock("*") : unlock($file);
		return 1 if $success;
		file_lock_directory_cleanup($lock_file);
		$success = unlock($file);
		return 1 if $success;
		error_message("File Locking Malfunction", "File locking does not function properly on this server.", 0, 1);
	} elsif ($tries == 5 && -e $lock_file) {
		log_error("common.pl", "file_check_lock", "Lock is valid: " . ($timecache-$lock_mtime) . " seconds old");
	} elsif (! -e $lock_file) {
		return 1;
	}
	return 0;
}

###
### file_name_escape
###
### Converts a file name into a unique string
###

sub file_name_escape {
	my ($filename) = @_;
	my $escname = "";
	while ($filename =~ /(.)/sg) {
		$escname .= sprintf("%02lx", ord($1));
	}
	return $escname;
}

###
### file_get_mtime
###
### Gets the modified time of a file/directory
###

sub file_get_mtime {
	return (stat $_[0])[9];
}

###
### file_lock_directory_cleanup
###
### Recursively deletes everything under a particular directory
###

sub file_lock_directory_cleanup {
	my ($directory, $tries) = @_;
	log_error("common.pl", "file_lock_directory_cleanup", "Cleanup called on directory $directory (level = $tries)");
	if (opendir(DIR, $directory)) {
		my @dir = map { "$directory/$_" } grep { ! /^\.+$/ } readdir(DIR);
		closedir(DIR);
		foreach my $filename (@dir) {
			if (-f $filename) {
				unlink $filename || log_error("common.pl", "file_lock_directory_cleanup", "File delete error: could not delete $filename ($!)");
			} elsif (-d $filename) {
				if ($tries > 2) {
					error_message("Recursive Directory Delete Error", "Directory $directory appears to be illegally recursive or complex.", 0, 1);
				}
				file_lock_directory_cleanup($filename, 1+$tries);
			}
		}
	}
}

###
### log_error
###
### Prints helpful debugging information in the errors.txt file should things go
### wrong.
###

sub log_error {
	my ($place, $sub, $message) = @_;
	my ($sec, $min, $hour, $day, $nmonth, $year, $wday, $yday, $isdst);
	if ($GLOBAL_OPTIONS->{'usegmtime'} == 1) {
		($sec, $min, $hour, $day, $nmonth, $year, $wday, $yday, $isdst) = gmtime(time);
	} else {
		($sec, $min, $hour, $day, $nmonth, $year, $wday, $yday, $isdst) = localtime(time);
	}
	open(ERROR_LOG, "$DCONF->{admin_dir}/errors.txt");
	my @error = <ERROR_LOG>;
	close (ERROR_LOG);
	foreach my $line (@error) {
		$line = "" if $line !~ m|\[\*\]|;
	}
	@error = grep(/\S/, @error);
	if (scalar(@error) > 300) {
		my $num = scalar(@error);
		@error = splice(@error, $num-300, 300);
	}
	$hour = "0$hour" if $hour < 10;
	$min = "0$min" if $min < 10;
	$sec = "0$sec" if $sec < 10;
	$nmonth += 1; $year += 1900;
	open (ERROR_LOG, ">$DCONF->{admin_dir}/errors.txt");
	print ERROR_LOG @error;
	print ERROR_LOG "-" x 60, "\n";
	print ERROR_LOG "[*] $nmonth/$day/$year $hour:$min:$sec $place/$sub $message\n";
	close (ERROR_LOG);
}


###
### determine_addmessage
###
### Determines if an "Add a Message" box should reflect private or public posting,
### and whether anonymous posting is enabled.  Also returns per-topic selections
### like disabling full name or e-mail addresses on posts.
###

sub determine_addmessage {
	my ($topic, $privilege_in, $letter, $array_back) = @_;
	dreq("fcn-usrp");
	my $priv = (defined $privilege_in ? $privilege_in : read_topic_privilege_file(1));
	$letter = (defined $letter ? $letter : "p");
	undef my $result;
	my $x = $priv->{$topic}->{$letter};
	$result->{disabled} = 1 if ($x->{ip}->{':list:'} eq "" && $x->{user}->{':list:'} eq "" && $x->{moderator}->{':list:'} eq "" && $x->{special} eq "");
	$result->{public} = 1 if $x->{ip}->{':list:'} ne "";
	if ($DCONF->{pro} && ! $result->{public}) {
		dreq("ipaddr-PRO");
		$result->{public} = is_it_public($x->{ip}->{':list:'});
	}
	$result->{anonymous_posting} = 1;
	$result->{anonymous_posting} = 0 if $priv->{$topic}->{'o'}->{'anon'};
	$result->{anonymous_posting} = 0 if ! $GLOBAL_OPTIONS->{'anonymous'};
	return ($result, $priv) if $array_back;
	return $result;
}

###
### extract_info
###
### Called if tree file is corrupt to determine necessary parameters for
### generating a subtopic list.
###

sub extract_info {
	my ($topic, $page, $arg) = @_;
	my $hashref = {};
	my $get_page = GetPage($topic, $page, $arg);
	$hashref->{topic} = $get_page->{head}->{topic_number};
	$hashref->{page} = $get_page->{head}->{me_number};
	$hashref->{number} = $get_page->{head}->{me_number};
	$hashref->{name} = $get_page->{head}->{me_name};
	$hashref->{parent} = $get_page->{head}->{parent};
	$hashref->{properties} = $get_page->{head}->{properties};
	$hashref->{param} = $get_page->{head}->{param};
	return $hashref;
}

###
### GetPage
###
### Reads in all information from a message page and puts it into a format
### that's easily manipulated.  This can handle board-generated pages from
### version 3.10 and 4.00+
###

sub GetPage {
	my ($topic, $page, $arg, $fileref) = @_;
	undef my $hashref;
	undef my $head;
	$head->{pageversion} = "4.0";
	my $q = get_message_path($topic);
	my $filename = join("/", $q, "$page.$DCONF->{ext}");
	my $arguments = {};
	$arguments->{no_lock} = $arg->{lock} == 1 ? 0 : 1;
	$arguments->{no_unlock} = $arg->{unlock} == 1 ? 0 : 1;
	$arguments->{zero_ok} = $arg->{zero_ok} == 1 ? 1 : 0;
	if (! defined $fileref) {
		error_message("Invalid GetPage Argument", "Topic [$topic] contains invalid characters!", 0, 1) if $topic =~ m|\D|;
		error_message("Invalid GetPage Argument", "Page [$page] contains invalid characters!", 0, 1) if $page =~ m|\D|;
		performance_string("& GetPage for $topic/$page ", keyspew($arg)) if $GLOBAL_OPTIONS->{performance_monitoring};
		if (! -f $filename) {
			error_message(read_language()->{GET_PAGE_OPEN_ERROR}, read_language()->{GET_PAGE_OPEN_ERROR_DESCR} . "</p><p>$topic/$page", 0, 1) if !$arg->{no_error};
			return {};
		}
		$fileref = readfile($filename, "GetPage", $arguments);
		chmod(oct($DCONF->{perms0666}), $filename);
	}
	$hashref->{secure} = $q eq $DCONF->{secdir} ? 1 : 0;
	my @level = ();
	my @sublist = ();
	my @messages = ();
	my @empty = ();
	undef my $subref;
	undef my $postref;
	undef my @sublist_raw;
	undef my @messages_raw;
	undef my @header_string;
	my $flag = 0;
	my $filelen = 0;
	my $stflag = 0;
	my $srflag = 0;
	my $mrflag = 0;
	my $stsarr = {};
	my $post = "";
	my $storeflag = "";
	my $seenpost = {};
	foreach $_ (@{ $fileref }) {
		$filelen += length($_);
		if ($flag || $stflag || $storeflag || $srflag || $mrflag || m|<!--?.*-[-!]>|) {
			if (m|^<!--Topic: (\d+)/(.*)-->\s*$|) {
				($head->{'topic_number'}, $head->{'topic_name'}) = ($1, $2);
				push (@header_string, $_);
			} elsif (m|<!--Me: (\d+)/(.*)-->\s*$|) {
				$head->{me_number} = $1; $head->{me_name} = $2;
				push (@header_string, $_);
			} elsif (m|<!--Level (\d+): (\d+)/(.*)-->\s*$|) {
				$level[$1] = {level_number => $2, level_name => $3};
				push (@header_string, $_);
			} elsif (m|^<!--Param: (\w+)-->\s*$|) {
				$head->{'param'} = $1;
				push (@header_string, $_);
			} elsif (m|^<!--Parent: (\d+)-->\s*$|) {
				$head->{'parent'} = $1;
				push (@header_string, $_);
			} elsif (m|^<!--Properties: (.*)-->|) {
				$head->{'properties'} = $1;
				push (@header_string, $_);
			} elsif (m|^<!--Owner:\s*(.*)-->|) {
				$head->{'pageversion'} = "3.1";
				$head->{'owner'} = $1;
			} elsif (m|^\s*<!--Store: (\w+)-->\s*$|i) {
				$storeflag = $1;
			} elsif ($storeflag ne "") {
				if (m|^\s*<!--/Store-->\s*$|i) {
					$storeflag = "";
				} else {
					$hashref->{store}->{$storeflag} .= $_;
				}
			} elsif (m|^\s*<!--?Top: (\d+)-[!\-]>|i) {
				if ($stsarr->{$1}) {
					$stflag = 0;
					$subref = {};
					next;
				}
				my $aft = $';
				$subref = {};
				$subref->{'number'} = $1;
				$subref->{'type'} = 0;
				if ($aft =~ /^\s*$/) {
					$stflag = 1;
				} else {
					push @sublist, $subref;
					$stsarr->{$subref->{number}} = 1;
				}
				push @sublist_raw, $_;
				$subref->{'descr'} = $1 if m|<!--Descr-->(.*?)<!--/Descr-->|i;
			} elsif (m|<!--/Top-->| || $stflag == 1) {
				next if $subref->{number} == 0;
				push @sublist_raw, $_;
				$stflag = 0 if m|<!--/Top-->|;
				$subref->{'descr'} = $1 if m|<!--Descr-->(.*?)<!--/Descr-->|i;
				if (m|<!--/Top-->|) {
					push @sublist, $subref;
					$stsarr->{$subref->{number}} = 1;
				}
			} elsif (m|^\s*<!--?URL: (\d+)-[\!\-]>|) {
				push @sublist_raw, $_;
				my $aft = $';
				$subref = {};
				$subref->{'islink'} = 1;
				$subref->{'number'} = $1;
				$subref->{'type'} = 1;
				$subref->{'descr'} = $1 if m|<!--Descr-->(.*?)<!--/Descr-->|i;
				if (m|<!--Name-->(.*?)<!--/Name-->|) {
					$subref->{name} = $1;
				} elsif (m|<a.*?>(.*?)</a>|i) {
					$subref->{name} = $1;
				}
				if ($aft =~ m|<!--Data: ([^\-]*)-([^\-]*)-([^\-]*) -->|i) {
					$aft = $'; my $b4 = $`;
					$subref->{url} = unescape($1);
					$subref->{target} = unescape($2);
					$subref->{props} = unescape($3);
					$subref = hash_merge($subref, generate_properties_hash($subref->{props}), 1);
					if ($aft =~ /^\s*$/ && $b4 =~ /^\s*$/) {
						$stflag = 2;
					} else {
						push @sublist, $subref;
					}
				} elsif ($aft =~ /^\s*$/) {
					$stflag = 2;
				} else {
					$subref->{url} = $1 if m|<a href="([^"]+)"|i;
					$subref->{target} = $1 if m| target="([^"]+)"|i;
					push @sublist, $subref;
				}
			} elsif (m|<!--/URL-->| || $stflag == 2) {
				push @sublist_raw, $_;
				$stflag = 0 if m|<!--/URL-->|;
				$subref->{'descr'} = $1 if m|<!--Descr-->(.*?)<!--/Descr-->|i;
				if (m|<!--Name-->(.*?)<!--/Name-->|) {
					$subref->{name} = $1;
				} elsif ($subref->{name} eq "" && m|<a.*?>(.*?)</a>|i) {
					$subref->{name} = $1;
				}
				if (m|<!--Data: ([^\-]*)-([^\-]*)-([^\-]*) -->|i) {
					$subref->{url} = unescape($1);
					$subref->{target} = unescape($2);
					$subref->{props} = unescape($3);
					$subref = hash_merge($subref, generate_properties_hash($subref->{props}), 1);
				} elsif ($subref->{url} eq "") {
					$subref->{url} = $1 if m|<a href="([^"]+)"|i;
					$subref->{target} = $1 if m| target="([^"]+)"|i;
				}
				push @sublist, $subref if m|<!--/URL-->|;
			} elsif (m|^\s*<!--?Post: (\d+)-[!\-]><!--?Time: (\d+)-[!\-]>|i) {
				my ($pn, $tn) = ($1, $2); my $pntn = join(":", $pn, $tn);
				if ($seenpost->{$pntn}) {
					log_error("common.pl", "GetPage", "Duplicate post number $pn on page $topic/$page");
					next;
				}
				$seenpost->{$pntn} = 1;
				$flag = 1; $stflag = 0;
				undef $postref;
				$postref->{'number'} = $1;
				$postref->{'time'} = $tn > 0 ? $tn : time;
				$postref->{'fields'} = [];
				push (@messages_raw, $_);
			} elsif (m|^\s*<!--?Post: (\d+)-[!\-]>|i) {
				if ($seenpost->{"$1:0"}) {
					log_error("common.pl", "GetPage", "Duplicate post number $1 on page $topic/$page");
					next;
				}
				$seenpost->{"$1:0"} = 1;
				$flag = 1; $stflag = 0;
				$postref = {};
				$postref->{'number'} = $1;
				$postref->{'time'} = time;
				$postref->{'fields'} = [];
				push (@messages_raw, $_);
				$post = $_;
			} elsif ($flag == 1 && m|<!--?/Post: (\d+)-[!\-]>|i) {
				$flag = 0; $stflag = 0;
				push (@messages_raw, $_);
				$_ = join("", $post, $_); $post = "";
				$postref->{'text'} = $1 if m|<!--?Text-[!\-]>(.*?)<!--?/Text-[!\-]>|is;
				$postref->{'author'} = $1 if m|<!--?Name-[!\-]>(.*?)<!--?/Name-[!\-]>|i;
				$postref->{'email'} = $1 if m|<!--?Email-[!\-]>(.*?)<!--?/Email-[!\-]>|i;
				$postref->{'email'} = $1 if $postref->{'email'} =~ m|href="(.*?)"|i;
				if ($postref->{email} =~ m|profile=(.*?)-(\w+)|) {
					$postref->{'email'} = "$DCONF->{script_url}/board-profile.$DCONF->{cgi_extension}?action=view_profile&profile=$1-";
					$postref->{'email'} .= $2 eq "MODERATOR" ? $2 : "users";
				}
				$postref->{'email'} = "" if $postref->{'email'} =~ m|javascript:alert|;
				if (m|<!--f|) {
					my $used_field = {};
					my $temp = $_;
W2:					while ($temp =~ m|<!--f(ield)?/(.*?):(.*?)-->|i) {
						my ($one, $two) = ($2, $3); $temp = join("", $`, $');
						next W2 if $used_field->{$one};
						$used_field->{$one} = 1;
						$postref->{"field_$one"} = unescape($two);
						push @{ $postref->{fields} }, { name => $one, value => unescape($two) };
					}
W1:					while ($temp =~ m|<!--f(ield)?:(.*?)-->(.*?)<!--/f(ield)?-?-?>|i) {
						my ($one, $two) = ($2, $3); $temp = $';
						next W1 if $used_field->{$one};
						$used_field->{$one} = 1;
						$two = $2 if $two =~ m|<!--u(se)?:\s?(.*?)-->|i;
						$postref->{"field_$one"} = $two;
						push @{ $postref->{fields} }, { name => $one, value => $two };
					}
				}
				if (/<!--p(rop|roperty|roperties)?:(.*?)-->/) {
					my (@pairs) = split(/&/, $2);
					foreach my $pair (@pairs) {
						my ($name, $value) = split(/=/, $pair);
						$postref->{"property_$name"} = unescape($value);
					}
				}
				# Hack for free version so skins work right
				if (! $DCONF->{pro} && $postref->{field_registered} ne "") {
					$postref->{author_status} = 3 if $postref->{author_status} <= 2;
				}
				push (@messages, $postref);
			} elsif ($flag == 1) {
				push (@messages_raw, $_);
				$post .= $_;
			} elsif (m|^<!--Begin Subtopic List-->\s*$|) {
				$srflag = 1;
			} elsif (m|^<!--End Subtopic List-->\s*$|) {
				$srflag = 0;
			} elsif (m|^<!--Begin Message List-->\s*$|) {
				$mrflag = 1;
			} elsif (m|^<!--End Message List-->\s*$|) {
				$mrflag = 0;
			} elsif (m|^<!--Announcement-->|) {
				$flag = 2;
			} elsif (m|^<!--/Announcement-->|) {
				$flag = 0;
			} elsif (m|^<!--Announcement Source:|) {
				$flag = 0;
			} elsif (m|^<!--Source:|) {
				$flag = 0;
			} elsif (m|^<!--About-->|) {
				$flag = 3;
			} elsif (m|^<!--/About-->|) {
				$flag = 0;
			} elsif ($flag == 2 || $flag == 3) {
				next if m|^<!--?Skip-[!\-]>|;
				next if m|^-->|;
				next if m|^\s*<HR>\s*$|i;
				next if m|^<!--|;
				$hashref->{'pginfo'}->{'announcement'} .= $_ if $flag == 2 && m|\S|;
				$hashref->{'pginfo'}->{'about'} .= $_ if $flag == 3 && m|\S|;
			} elsif ($mrflag) {
				push @messages_raw, $_;
			} elsif ($srflag) {
				push @sublist_raw, $_;
			}
		} elsif (m%^<META\s*(?:NAME|HTTP-EQUIV)="([^"]+)"\s*(?:CONTENT|VALUE)="([^"]*)">\s*$%i) {
			$stflag = 0;
			my $keyname = join("_", "meta", trim(lc($1)));
			$hashref->{$keyname} = $2;
		} elsif (m|^\s*</HTML>\s*$|i) {
			$hashref->{'pginfo'}->{'complete'} = 1;
		}
	}
	$head->{'levels'} = \@level;
	$hashref->{'head'} = $head;
	$hashref->{'head'}->{'topic_number'} = $topic;
	$hashref->{'head'}->{'me_number'} = $page if $page;
	$hashref->{'sublist'} = \@sublist;
	$hashref->{'messages'} = \@messages;
	$hashref->{'sublist_raw'} = join("", @sublist_raw);
	$hashref->{'messages_raw'} = join("", @messages_raw);
	$hashref->{pginfo}->{'headers_asstring'} = join("", @header_string);
	$hashref->{'general'}->{'subtopic_raw'} = 1;
	$hashref->{'general'}->{'messages_raw'} = 1;
	$hashref->{'general'}->{'levels'} = scalar(@level);
	$hashref->{'general'}->{'length'} = $filelen;
	return $hashref;
}

###
### SetPage
###
### Writes out a message file.
###

sub SetPage {
	my ($hashref, $args) = @_;
	my $subst = $hashref;
	my $topic = $hashref->{'head'}->{'topic_number'};
	my $page = $hashref->{'head'}->{'me_number'};
	performance_string("& SetPage for $topic/$page ", keyspew($args)) if $GLOBAL_OPTIONS->{performance_monitoring};
	undef my $arguments;
	$arguments->{no_lock} = ($args->{lock} == 1 ? 0 : 1);
	$arguments->{no_unlock} = ($args->{unlock} == 1 ? 0 : 1);
	my $params = $hashref;
	undef my @header_string;
	push (@header_string, "<!--Topic: $params->{head}->{topic_number}/$params->{head}->{topic_name}-->");
	push (@header_string, "<!--Me: $params->{head}->{me_number}/$params->{head}->{me_name}-->");
	my $ctr = 1; my $seen = 0;
	foreach my $x (@{ $params->{head}->{levels} }) {
		next if $x->{level_number} == 0;
		push (@header_string, "<!--Level $ctr: $x->{level_number}/$x->{level_name}-->");
		$ctr++;
		$seen = 1 if $x->{level_number} == $params->{head}->{me_number};
	}
	if ($seen == 0 && $params->{head}->{topic_number} != $params->{head}->{me_number}) {
		push (@header_string, "<!--Level $ctr: $params->{head}->{me_number}/$params->{head}->{me_name}-->");
	}
	push (@header_string, "<!--Properties: $params->{head}->{properties}-->");
	push (@header_string, "<!--Param: $params->{head}->{param}-->");
	push (@header_string, "<!--Parent: $params->{head}->{parent}-->");
	push (@header_string, "<!--Owner: $params->{head}->{owner}-->") if $params->{head}->{owner};
	$subst->{pginfo}->{headers_asstring} = join("\n", @header_string, "");
	dreq("template");
	my $template = "";
	$subst->{'general'}->{'warning'} = "<!-- WARNING: Do not edit this file with an HTML editor! -->\n";
	$subst->{'subtopics'} = $hashref->{'sublist'};
	$subst->{'pginfo'}->{'sublist_raw'} = $hashref->{'sublist_raw'};
	$subst->{'pginfo'}->{'messages_raw'} = $hashref->{'messages_raw'};
	$subst->{'pginfo'}->{'meta_description'} = $hashref->{'meta_description'};
	$subst->{'pginfo'}->{'meta_keywords'} = $hashref->{'meta_keywords'};
	$subst->{'pginfo'}->{'meta_robots'} = $hashref->{'meta_robots'};
	$subst->{'pginfo'}->{'subtopics_regular'} = 0;
	$subst->{'pginfo'}->{'subtopics_archives'} = 0;
	if (ref $subst->{'subtopics'} eq 'ARRAY') {
		foreach my $subtopic (@{ $subst->{'subtopics'} }) {
			if ($subtopic->{param} =~ /Archive/) {
				$subst->{'pginfo'}->{'subtopics_archives'}++;
			} else {
				$subst->{'pginfo'}->{'subtopics_regular'}++;
			}
		}
	}
	$subst->{'levels'} = $hashref->{'head'}->{'levels'};
	my @msg = ();
	if (ref $hashref->{messages} eq "ARRAY") {
		foreach my $message (@{ $hashref->{messages} }) {
			my @k = grep(/^property_/, keys(%{ $message })); my @u = ();
			foreach my $k (@k) {
				$k =~ /^property_/; my $l = $';
				push @u, join("=", $l, escape($message->{$k}));
			}
			$message->{property} = join("&", @u);
			push @msg, $message;
		}
	}
	$subst->{'messages'} = \@msg;
	my $file = join("/", get_message_path($topic), "$page.$DCONF->{ext}");
	$subst->{general}->{showadminfromhere} = 1;
	if ($params->{head}->{param} =~ m|Add|) {
		$subst->{addmessage} = determine_addmessage($hashref->{head}->{topic_number}, $args->{privcache});
	}
	if ($args->{return_val}) {
		return templ_int("*$params->{head}->{topic_number}page", $subst);
	} else {
		my $text = templ_int("*$params->{head}->{topic_number}page", $subst);
		my @text = ( $text );
		writefile($file, \@text, "SetPage", $arguments );
		return $hashref;
	}
}

###
### expand_sublist
###
### Combines tree information with the subtopic list to be sure each subtopic
### in a list has the proper information.  Also determines the icon to display
### next to each subtopic.
###

sub expand_sublist {
	my ($subref, $topic, $special_in) = @_;
	if (defined $special_in || ! defined($PARAMS->{"lookup:$topic"})) {
		my $rdtree = defined $special_in ? $special_in : read_tree($topic, undef);
		$PARAMS->{"lookup:$topic"} = {};
		foreach my $x (@{ $rdtree }) {
			$PARAMS->{"lookup:$topic"}->{ $x->{page} } = $x;
		}
	}
	foreach my $t (@{ $subref }) {
		my $y = $PARAMS->{"lookup:$topic"}->{ $t->{number} };
		foreach my $v (split(/;/, $y->{properties})) {
			my ($var, $val) = split(/=/, $v);
			$y->{"property_$var"} = $val;
		}
		if (ref $y->{props} eq "HASH") {
			foreach my $k (keys(%{ $y->{props} })) {
				$y->{"property_$k"} = $y->{props}->{$k};
			}
			$y->{properties} = generate_properties(hash_merge(generate_properties_hash($y->{properties}),$y->{props},1));
		}
		$t->{msg_count} = $y->{posts};
		$t->{param} = $y->{param};
		$t->{name} = $y->{name};
		$t->{subs} = $y->{subs};
		$t->{last_poster} = $y->{last_poster};
		$t->{originator} = $y->{originator};
		$t->{lastmod} = $y->{lastmod};
		$t->{url} = $y->{url};
		$t->{islink} = $y->{islink};
		$t->{icon} = tree_icon_chooser($y->{icon}, $y->{param}, $y->{islink});
		$t->{properties} = $y->{properties};
		$t->{property_emot} = $y->{property_emot};
	}
	return $subref;
}

###
### tree_icon_chooser
###
### Chooses default icons depending on parameters of the page
###

sub tree_icon_chooser {
	my ($icon, $param, $islink, $letteronly) = @_;
	my $r = "";
	$r = $icon if $icon ne "" && $icon ne "0";
	$r = "tree_t" if ($r eq "" && $param =~ m|Archive| && $param =~ m|Sublist|);
	$r = "tree_u" if ($r eq "" && $param =~ m|Archive|);
	$r = "tree_r" if ($r eq "" && $param =~ m|Add|);
	$r = "tree_o" if ($r eq "" && $param =~ m|Messages|);
	$r = "tree_m" if ($r eq "" && $islink);
	$r = "tree_n" if $r eq "";
	$r =~ s/^tree_// if $letteronly;
	return $r;
}

###
### sort_archive_method
###
### Pushes archives to the bottom of a subtopic list
###

sub sort_archive_method {
	my ($ap, $bp) = ($a->{param}, $b->{param});
	return 1 if $a->{lastmod} == 1 && $b->{lastmod} != 1;
	return -1 if $a->{lastmod} != 1 && $b->{lastmod} == 1;
	return 0 if $a->{lastmod} == 1 && $b->{lastmod} == 1;
	return 1  if $ap =~ /Archive/ && $bp !~ /Archive/;
	return -1 if $ap !~ /Archive/ && $bp =~ /Archive/;
	return 0 if $ap !~ /Archive/ && $bp !~ /Archive/;
	return $a->{lastmod} <=> $b->{lastmod} if $GLOBAL_OPTIONS->{sort_archive_method_choice} >= 0;
	return $b->{lastmod} <=> $a->{lastmod};
}

###
### topic_tree_to_main
###
### Writes the first line of a ###-tree.txt file to the main tree.txt file.
###

sub topic_tree_to_main {
	my ($topicref, $tree_in, $arg) = @_;
	my $tree = defined $tree_in ? $tree_in : readfile("$DCONF->{admin_dir}/tree.txt", "topic_tree_to_main", { no_unlock => 1 });
	my $written = 0;
	foreach my $t_l (@{ $tree }) {
		my @c2 = split(/\t/, $t_l);
		if ($c2[1] == $topicref->[0]->{topic}) {
			$t_l = (generate_tree_line($topicref->[0]))[0];
			$written = 1;
			last;
		}
	}
	push (@{ $tree }, (generate_tree_line($topicref->[0]))[0]) if !$written;
	writefile("$DCONF->{admin_dir}/tree.txt", $tree, "topic_tree_to_main", { no_lock => 1 }) if ! $arg->{no_write};
	return $tree;
}

###
### tree_line_as_hash
###
### Takes a line from the tree.txt file and generates a hash that is easily manipulated
### by the program.  Inverse is "generate_tree_line".
###

sub tree_line_as_hash {
	my ($line) = @_;
	return undef if $line !~ m|^\d|;
	chomp $line;
	undef my $h;
	($h->{'level'}, $h->{'topic'}, $h->{'page'}, $h->{'parent'}, $h->{'name_esc'}, $h->{'param'}, $h->{'url_esc'}, $h->{'posts'}, $h->{'properties'}, $h->{'lastmod'}, $h->{'originator_esc'}, $h->{'post_list'}, $h->{'subs'}, $h->{'last_poster_esc'}) = split(/\t/,$line);
	$h->{'parent'} = 0 if $h->{'topic'} == $h->{'page'};
	$h->{'name'} = unescape($h->{'name_esc'});
	undef $h->{name_esc};
	$h->{'originator'} = unescape($h->{'originator_esc'});
	undef $h->{originator_esc};
	$h->{'last_poster'} = unescape($h->{'last_poster_esc'});
	undef $h->{last_poster_esc};
	if ($h->{'param'} =~ m|^LINK:|) {
		$h->{'islink'} = 1;
		$h->{'target'} = $';
		$h->{'url'} = unescape($h->{'url_esc'});
	} else {
		undef $h->{'islink'};
		undef $h->{'target'};
		undef $h->{'url'};
	}
	undef $h->{url_esc};
	$h->{'posts'} = 0 if $h->{'posts'} == 0;
	$h->{'subs'} = 0 if $h->{'subs'} == 0;
	foreach my $p (split(/;/, $h->{properties})) {
		$h->{"property_$1"} = $2 if $p =~ m|^(\w+)=(\w+)|;
	}
	$h->{icon} = $h->{property_icon} if defined $h->{property_icon};
#	$h->{icon} = tree_icon_chooser($h->{property_icon}, $h->{param}, $h->{islink});
	return $h;
}

###
### generate_tree_line
###
### Generates a line for the tree.txt file based on incoming input, ensuring that
### no entry is left blank by substituting in default values.  Inverse is
### "tree_line_as_hash".
###

sub generate_tree_line {
	my ($params) = @_;
	undef my $result;
	$result->{'level'} = ( defined($params->{'level'}) ? $params->{'level'} : 0 );
	$result->{'topic'} = ( defined($params->{'topic'}) ? $params->{'topic'} : 0 );
	$result->{'page'} = ( defined($params->{'page'}) ? $params->{'page'} : 0 );
	$result->{'parent'} = ( defined($params->{'parent'}) ? $params->{'parent'} : 0 );
	$result->{'name_esc'} = ( defined($params->{'name_esc'}) ? $params->{'name_esc'} : escape($params->{name}) );
	$result->{'param'} = ( defined($params->{'islink'}) ? "LINK:$params->{target}" : $params->{'param'} );
	$result->{'url_esc'} = ( defined($params->{'url_esc'}) ? $params->{'url_esc'} : escape($params->{url}) );
	$result->{'posts'} = ( defined($params->{'posts'}) ? $params->{'posts'} : 0 );
	$result->{'properties'} = ( defined($params->{'properties'}) ? $params->{'properties'} : generate_properties($params->{props}) );
	$result->{'lastmod'} = ( defined($params->{'lastmod'}) ? $params->{'lastmod'} : time );
	$result->{'originator_esc'} = ( defined($params->{'originator_esc'}) ? $params->{'originator_esc'} : escape($params->{originator}));
	$result->{'post_list'} = ( defined($params->{'post_list'}) ? $params->{'post_list'} : "" );
	$result->{'subs'} = ( defined($params->{'subs'}) ? $params->{'subs'} : 0 );
	$result->{'last_poster_esc'} = ( defined($params->{'last_poster_esc'}) ? $params->{'last_poster_esc'} : escape($params->{last_poster}) );
	my $r = $result;
	my $line = join("\t", $r->{level}, $r->{topic}, $r->{page}, $r->{parent}, $r->{name_esc}, $r->{param}, $r->{url_esc}, $r->{posts}, $r->{properties}, $r->{lastmod}, $r->{originator_esc}, $r->{post_list}, $r->{subs}, $r->{last_poster_esc});
	$line =~ s/[\r\n]//g;
	$line .= "\n";
	return ($line, $result);
}

###
### generate_properties
###
### Generates a "properties" string suitable to write into a file or include into
### the tree file, from a hash reference of properties.
###

sub generate_properties {
	my ($hash_in) = @_;
	undef my @arr_out;
	foreach my $key (keys(%{$hash_in})) {
		push (@arr_out, "$key=$hash_in->{$key}");
	}
	return join(";", @arr_out);
}

###
### generate_properties_hash
###
### Inverse of generate_properties
###

sub generate_properties_hash {
	my ($string_in) = @_;
	my @arr = split(/;/, $string_in);
	my $hash = {};
	foreach my $z (@arr) {
		my ($key, $val) = split(/=/, $z, 2);
		$hash->{$key} = $val;
	}
	return $hash;
}

###
### hash_merge
###
### Merges a second hash into a first
###

sub hash_merge {
	my ($self, $newdata, $overwrite) = @_;
	foreach my $z (keys(%{$newdata})) {
		next if defined $self->{$z} && ! $overwrite;
		$self->{$z} = $newdata->{$z};
	}
	return $self;
}

###
### read_tree
###
### Reads in a tree file and returns results in a format that is easily manipulated
### by the program.
###

sub read_tree {
	my ($topic, $arg) = @_;
	undef my $resultref;
	undef my $file;
	if ($topic == 0) {
		$file = readfile("$DCONF->{admin_dir}/tree.txt", "read_tree", $arg);
	} else {
		$file = readfile("$DCONF->{admin_dir}/msg_index/$topic-tree.txt", "read_tree", $arg);
	}
	my @res_ref = ();
	foreach my $line (@{ $file }) {
		next if $line =~ /^#/;
		push @res_ref, tree_line_as_hash($line);
	}
	return \@res_ref;
}

###
### write_tree
###
### Writes out the tree file from the program's internal tree format.
###

sub write_tree {
	my ($topic, $tree, $arg) = @_;
	my @output = ();
	foreach my $xref (@{ $tree }) {
		next if ! defined $xref->{page};
		my $r = (generate_tree_line($xref))[0];
		push (@output, $r) if defined $r;
	}
	if ($topic == 0) {
		writefile("$DCONF->{admin_dir}/tree.txt", \@output, "write_tree", $arg) if !$arg->{no_write};
	} else {
		writefile("$DCONF->{admin_dir}/msg_index/$topic-tree.txt", \@output, "write_tree", $arg) if !$arg->{no_write};
	}
	return \@output;
}

###
### trim
###
### Trims off leading and trailing spaces, and collapses multiple spaces
### into one
###

sub trim {
	my @o = ();
	while (scalar( @_ )) {
		my $s = shift @_;
		$s =~ s/^\s+//;
		$s =~ s/\s+$//;
		$s =~ s/\s+/ /g;
		push @o, $s;
	}
	return @o if scalar(@o) != 1;
	return $o[0];
}

###
### rename_file
###
### Renames a file, unless you're on NT, when it copies the old file and then
### removes it ("rename" function doesn't get along well with NT).
###

sub rename_file {
	my ($filename, $fsize_desired, $new_file_name) = @_;
	my ($fsize, $code, @file, $old_file, $new_file);
	if ($new_file_name ne "") {
		$old_file = $filename;
		$new_file = $new_file_name;
	} else {
		$old_file = "$filename.NEW";
		$new_file = $filename;
	}
	if (-e "$old_file") {
		$fsize = -s "$old_file";
		if ($fsize < $fsize_desired) {
			undef $!;
			unlink ("$old_file");
			if ($GLOBAL_OPTIONS->{'diskquota_disable'} == 1 || $GLOBAL_OPTIONS->{'diskquota_disable'} eq "") {
				open (BACKUPS, ">$DCONF->{admin_dir}/backups/QUOTA.txt");
				print BACKUPS time, "\n";
				print BACKUPS escape("Write to $new_file: wrong size (expected: $fsize_desired; actual: $fsize"), "\n";
				close (BACKUPS);
			}
			my $fn = ""; $fn = $' if $new_file =~ /.*\//;
			quota_err($fn, $fsize_desired, $fsize);
		}
		if (defined($DCONF->{NT}) || $DCONF->{platform} =~ m|NT|i) {
			$code = 0;
		} else {
			$code = rename("$old_file", "$new_file");
		}
		if ($code != 1 || !-e $new_file) {
			open (FILE, "$old_file");
			@file = <FILE>;
			close (FILE);
			open (FILE, ">$new_file");
			print FILE @file;
			close (FILE);
			$fsize = -s "$new_file";
			if ($fsize < $fsize_desired) {
				unlink($new_file);
				if ($GLOBAL_OPTIONS->{'diskquota_disable'} == 1 || $GLOBAL_OPTIONS->{'diskquota_disable'} eq "") {
					open (BACKUPS, ">$DCONF->{admin_dir}/backups/QUOTA.txt");
					print BACKUPS time, "\n";
					print BACKUPS escape("Write to $new_file: wrong size (expected: $fsize_desired; actual: $fsize"), "\n";
					close (BACKUPS);
				}
				my $fn = ""; $fn = $' if $new_file =~ /.*\//;
				quota_err($fn, $fsize_desired, $fsize);
			}
			unlink ("$old_file");
		}
		chmod (oct($DCONF->{perms0666}), $new_file);
	} else {
		error_message("File Save - Write Error", "Could not open $old_file for reading.") if $fsize_desired != -1;
	}
	return 1;
}

###
### get_date_time
###
### Converts from a numerical time stamp to a human-readable time, based on language.conf
### parameters and supplied desired format.
###

sub get_date_time {
	my ($format, $timer, $block_tz) = @_;
	$timer = time if $timer == 0;
	$timer += ($GLOBAL_OPTIONS->{'timezone'}*3600) if $block_tz != 591;
	my ($sec, $min, $hour, $day, $nmonth, $year, $wday, $yday, $isdst);
	if ($GLOBAL_OPTIONS->{'usegmtime'} == 1) {
		($sec, $min, $hour, $day, $nmonth, $year, $wday, $yday, $isdst) = gmtime($timer);
	} else {
		($sec, $min, $hour, $day, $nmonth, $year, $wday, $yday, $isdst) = localtime($timer);
	}
	my $ampm = "";
	my $twentyfour_hour = $hour;
	if (read_language()->{HRCLOCK} == 12) {
		if ($hour > 12) {
			$hour -= 12; $ampm = read_language()->{PM};
		} elsif ($hour == 12) {
			$ampm = read_language()->{PM};
		} else {
			$ampm = read_language()->{AM};
		}
		$hour = 12 if $hour == 0;
	}
	$year += 1900;
	my $lt_year = sprintf "%02d", $year % 100;
	my $week = (@{ read_language()->{DAY} })[$wday];
	my $month = (@{ read_language()->{MONTH} })[$nmonth];
	my $month_abbr = (@{ read_language()->{MONTH_ABBR} })[$nmonth];
	my $day_abbr = (@{ read_language()->{ABBRDAY} })[$wday];
	my $hour_format_string = $GLOBAL_OPTIONS->{dates_hour_zero} == 1 ? "%02d" : "%d";
	my $month_format_string = $GLOBAL_OPTIONS->{dates_month_zero} == 1 ? "%02d" : "%d";
	my $day_format_string = $GLOBAL_OPTIONS->{dates_zero} == 1 ? "%02d" : "%d";
	my $HOUR = sprintf $hour_format_string, $hour;
	my $T24HOUR = sprintf $hour_format_string, $twentyfour_hour;
	my $MONTH = sprintf $month_format_string, 1+$nmonth;
	my $DAY = sprintf $day_format_string, $day;
	$min = sprintf "%02d", $min;
	$sec = sprintf "%02d", $sec;
	my $ls = "";
	if ($format =~ m|\%|) {
		$ls = $format;
	} else {
		my $lookups = {
			long => read_language()->{LONGDATE},
			short => read_language()->{SHORTDATE},
			shorter => (defined read_language()->{SHORTERDATE} ? read_language()->{SHORTERDATE} : read_language()->{SHORTDATE}),
			message => (defined read_language()->{MESSAGEDATE} ? read_language()->{MESSAGEDATE} : read_language()->{LONGDATE}),
			realshort => read_language()->{REALSHORTDATE},
			dateonly => read_language()->{DATEONLY},
		};
		$ls = $lookups->{$format};
	}
	$ls =~ s/\%weekday/$week/g;
	$ls =~ s/\%wkdy\./$day_abbr/g;
	$ls =~ s/\%hour/$HOUR/g;
	$ls =~ s/\%minute/$min/g;
	$ls =~ s/\%month/$month/g;
	$ls =~ s/\%mon\./$month_abbr/g;
	my $mabbr2 = $month_abbr; $mabbr2 =~ s/\.//g;
	$ls =~ s/\%mon_/$mabbr2/g;
	my $dabbr2 = $day_abbr; $dabbr2 =~ s/\.//g;
	$ls =~ s/\%wkdy_/$dabbr2/g;
	$ls =~ s/\%nmonth/$MONTH/g;
	$ls =~ s/\%year/$year/g;
	$ls =~ s/\%ampm/$ampm/g;
	$ls =~ s/\%second/$sec/g;
	$ls =~ s/\%day/$DAY/g;
	$ls =~ s/\%24hour/$T24HOUR/g;
	$ls =~ s/\%2year/$lt_year/g;
	$ls =~ s/\s+$//;
	return $ls;
}

###
### screen_out
###
### Writes a screen from a template
###

sub screen_out {
	my ($screen, $subst, $cookie, $escape) = @_;
	$subst->{DYNAMIC}->{server_time} = time;
	dreq("template");
	header($cookie);
	print templ_int($screen, $subst);
	return 1 if $escape;
	print "<!--HTTP Cookie: $ENV{HTTP_COOKIE} -->\n";
	print "<!--Setting Cookies:\n $cookie -->\n";
	program_exit(0);
}

###
### keyspew
###
### Converts a hash into a string
###

sub keyspew {
	my ($hash) = @_;
	my @x = ();
	foreach my $k (sort keys(%{ $hash })) {
		push @x, join("=>", $k, $hash->{$k});
	}
	return join(" ", @x);
}

###
### readfile
###
### Low-level file reader (includes locking functions)
###

sub readfile {
	my ($file, $caller, $args) = @_;
	my @tellresult = ();
	my @array = ();
	$file =~ m|(.*)/|;
	my $shortfile = $';
	lock($file) if !$args->{no_lock};
	performance_string("< readfile for $caller on $file: ", keyspew($args)) if $GLOBAL_OPTIONS->{performance_monitoring};
	$PARAMS->{files_read}++;
	$PARAMS->{file_access}->{$file}->{read} += 1;
	$PARAMS->{file_access}->{$file}->{write} += 0;
	if (open (READFILE, "< $file")) {
		if ($args->{'tell'}) {
			binmode READFILE;
			while (<READFILE>) {
				push @tellresult, (tell READFILE) - length($_);
				s/\r\n$/\n/;
				push @array, $_;
			}
			close (READFILE);
		} else {
			@array = <READFILE>;
			close (READFILE);
		}
	} else {
		if ($args->{create}) {
			@array = ();
		} else {
			error_message("Open[r] file error", "Couldn't open file [$shortfile] for [$caller]!");
		}
	}
	unlock($file) if !$args->{no_unlock};
	unlink $file if $args->{delfile};
	@array = grep(/\S/, @array);
	if (!$args->{ok_zero} && !$args->{zero_ok} && !$args->{create} && scalar(@array) == 0) {
		error_message("Open[r] file error", "File [$shortfile] has zero length in reading for [$caller]!", 0, 1);
	}
	return \@array if $args->{'tell'} == 0;
	return (\@array, \@tellresult);
}

###
### touch_createfile
###
### Creates a blank file if it doesn't exist already
###

sub touch_createfile {
	my ($filename, $deleteit) = @_;
	return 1 if $deleteit == 0 && -e $filename;
	if (open(FILE, "> $filename")) {
		close (FILE);
		chmod(oct($DCONF->{perms0666}), $filename);
		return 1;
	} else {
		return 0;
	}
}

###
### readfile_binary
###
### Reads a single string of information into a file
###

sub readfile_binary {
	my ($file) = @_;
	performance_string("< readfile_binary on $file") if $GLOBAL_OPTIONS->{performance_monitoring};
	$PARAMS->{file_access}->{$file}->{read} += 1;
	$PARAMS->{file_access}->{$file}->{write} += 0;
	my $tmp = $/;
	undef $/;
	if (open(FILE, "< $file")) {
		binmode(FILE);
		my $data = <FILE>;
		close (FILE);
		$/ = $tmp;
		return $data;
	}
	$/ = $tmp;
	return undef;
}

###
### writefile_binary
###
### Writes a single string of information into a file
###

sub writefile_binary {
	my ($file, $data) = @_;
	performance_string("> writefile_binary on $file, data size ", length($data)) if $GLOBAL_OPTIONS->{performance_monitoring};
	$PARAMS->{files_written}++;
	$PARAMS->{file_access}->{$file}->{read} += 0;
	$PARAMS->{file_access}->{$file}->{write} += 1;
	if (open(FILE, "> $file")) {
		binmode (FILE);
		print FILE $data;
		close (FILE);
		return 1;
	} else {
		return 0;
	}
}

###
### writefile
###
### Low-level file writer (includes locking functions and verification that part of
### the file wasn't lost due to a disk quota condition)
###

sub writefile {
	my ($file, $data, $caller, $args) = @_;
	$file =~ m|(.*)/|;
	my $shortfile = $';
	my $unique_string = join("", time, $ENV{'REMOTE_ADDR'}, $$);
	$unique_string =~ s/\D//g;
	my $str = "";
	$str = ( ref $data eq "ARRAY" ? join("\n", @{$data}) : $data );
	if (ref $data eq "ARRAY") {
		$str =~ s/\r//g; $str =~ s/\n+/\n/g;
	}
	my $exp_len = length($str);
	performance_string("> writefile for $caller on $file, data size $exp_len: ", keyspew($args)) if $GLOBAL_OPTIONS->{performance_monitoring};
	$PARAMS->{file_access}->{$file}->{write}++;
	$PARAMS->{files_written}++;
	$PARAMS->{file_access}->{$file}->{read} += 0;
	lock($file) if !$args->{no_lock};
	$args->{no_backup} = 1 if $GLOBAL_OPTIONS->{quota_check_off};
	if (!$args->{no_backup}) {
		open (FILE, "> $DCONF->{admin_dir}/backups/$unique_string-$shortfile") || error_message("Open[w] file error", "Couldn't open temporary file backups/$unique_string-$shortfile for [$caller]!");
		binmode(FILE);
		print FILE $str;
		close (FILE);
		my $size1 = -s "$DCONF->{admin_dir}/backups/$unique_string-$shortfile";
		performance_string("   Backup file write for backups/$unique_string-$shortfile, size $size1 (expected $exp_len)") if $GLOBAL_OPTIONS->{performance_monitoring};
		quota_err($shortfile, $exp_len, $size1) if $exp_len > $size1;
	}
	open (FILE, "> $file") || error_message("Open[w] file error", "Couldn't open file [$shortfile] for update for [$caller]!");
	binmode(FILE);
	print FILE $str;
	close (FILE);
	performance_string("   Wrote $file for $caller, size ", -s $file) if $GLOBAL_OPTIONS->{performance_monitoring};
	chmod (oct($DCONF->{perms0666}), $file);
	unlock($file) if !$args->{no_unlock};
	if (!$args->{no_sizecheck} && !$GLOBAL_OPTIONS->{quota_check_off}) {
		my $size2 = -s $file;
		quota_err($shortfile, $exp_len, $size2) if $exp_len > $size2;
	}
	if (!$args->{no_backup}) {
		unlink("$DCONF->{admin_dir}/backups/$unique_string-$shortfile") || quota_err($shortfile, -1, undef);
		performance_string("   Removed backup file backups/$unique_string-$shortfile") if $GLOBAL_OPTIONS->{performance_monitoring};
	}
	return $exp_len;
}

###
### appendfile
###
### Low-level file appender
###

sub appendfile {
	my ($file, $data, $caller, $args) = @_;
	performance_string(">> appendfile for $caller on $file: ", keyspew($args)) if $GLOBAL_OPTIONS->{performance_monitoring};
	$PARAMS->{file_access}->{$file}->{write}++;
	$PARAMS->{file_access}->{$file}->{read} += 0;
	$PARAMS->{files_written}++;
	$file =~ m|(.*)/|; my $shortfile = $';
	lock($file) if !$args->{no_lock};
	open (FILE, ">> $file") || error_message("Open[a] file error", "Couldn't open file [$shortfile] for append for [$caller]!");
	print FILE @{$data};
	close (FILE);
	unlock($file) if !$args->{no_unlock};
	return 1;
}

###
### maintenance_mode_error
###
### Error message for when the board is in maintenance mode
###

sub maintenance_mode_error {
	error_message(read_language()->{MAINTENANCE_MODE_HEADER}, read_language()->{MAINTENANCE_MODE_EXPL}, 0, 1);
}

###
### quota_err
###
### Error message when disk quota is exceeded
###

sub quota_err {
	my ($filename, $expected_length, $actual_length) = @_;
	my $e1 = read_language()->{QUOTA_CONDITION};
	my $e2 = read_language()->{DISK_QUOTA_ERROR};
	if ($filename ne "") {
		$e2 .= "<p><font face=\"courier new\" size=2>$filename<br>$expected_length<br>$actual_length</font></p>";
	}
	error_message($e1, $e2, 0, 1);
}

###
### board_topics
###
### Reads topics on board and returns a conveniently manipulated array containing
### parameters of each topic.  This handles version 3.00+ topic files (and maybe
### past versions too -- untested).
###

sub board_topics {
	my ($argument, $file, $tree, $noerr, $nolock) = @_;
	if (! defined $tree) {
		$tree = readfile("$DCONF->{admin_dir}/tree.txt", "board_topics", { zero_ok => 1}) if ! $nolock;
		$tree = readfile("$DCONF->{admin_dir}/tree.txt", "board_topics", { no_lock => 1, no_unlock => 1, zero_ok => 1}) if $nolock;
	}
	undef my $array;
	foreach my $tl (@{$tree}) {
		undef my $hash;
		if ($hash = tree_line_as_hash($tl)) {
			if ($hash->{topic} == $argument && $argument > 0) {
				return $hash;
			}
			$array->{ $hash->{topic} } = $hash;
		}
	}
	if (! defined($file)) {
		my $lockstuff = $nolock == 1 ? { no_lock => 1, no_unlock => 1 } : {} ;
		if (! $DCONF->{pro} || (! $GLOBAL_OPTIONS->{secure_topics_file} && ! $GLOBAL_OPTIONS->{topics_to_show})) {
			return [] if $noerr && (! -e "$DCONF->{message_dir}/$DCONF->{board_topics_file}" || -s "$DCONF->{message_dir}/$DCONF->{board_topics_file}" == 0);
			$file = readfile("$DCONF->{message_dir}/$DCONF->{board_topics_file}", "board_topics", $lockstuff);
		} else {
			return [] if $noerr && (! -e "$DCONF->{secdir}/$DCONF->{board_topics_file}" || -s "$DCONF->{secdir}/$DCONF->{board_topics_file}" == 0);
			$argument = hash_merge($argument, $lockstuff, 1);
			dreq("authwrap-PRO");
			$file = wrapped_topics_file($argument);
		}
	}
	my @array = ();
	my $flag = 0;
	my @these = ();
	foreach my $fline (@{$file}) {
		next if $flag == 0 && $fline !~ m|^<!-|;
		if ($fline =~ m|^<!--?Top: (\d+)-[!\-]>|) {
			push @array, _board_topics_topic(\@these, $array) if $flag == 1;
			push @array, _board_topics_cat(\@these, $array) if $flag == 2;
			@these = ($fline);
			$flag = 1;
		} elsif ($fline =~ m|^<!--Category: (\d+)-->|) {
			push @array, _board_topics_topic(\@these, $array) if $flag == 1;
			push @array, _board_topics_cat(\@these, $array) if $flag == 2;
			@these = ($fline);
			$flag = 2;
		} elsif ($fline =~ m|<!--/Top-->| || $fline =~ m|<!--/Category-->| || $fline =~ m|<!--End Topics-->|) {
			push @these, $fline;
			push @array, _board_topics_topic(\@these, $array) if $flag == 1;
			push @array, _board_topics_cat(\@these, $array) if $flag == 2;
			$flag = 0;
			last if $fline =~ m|<!--End Topics-->|;
			@these = ();
		} elsif ($flag > 0) {
			push @these, $fline;
		}
	}
	push @array, _board_topics_topic(\@these, $array) if $flag == 1;
	push @array, _board_topics_cat(\@these, $array) if $flag == 2;
	return \@array;
}

sub _board_topics_topic {
	my ($these, $array) = @_;
	my $fline = join("", @{$these});
	$fline =~ s/\r\n/ /g;
	$fline =~ s/\r/ /g;
	$fline =~ s/\n/ /g;
	my $href = {};
	if ($fline =~ m|<!--?Top: (\d+)-[!\-]>|) {
		my $tn = $1;
		$href->{number} = $tn;
		if (defined($array->{$tn})) {
			foreach my $x ('name', 'params', 'posts', 'properties', 'lastmod', 'subs', 'last_poster') {
				$href->{$x} = ( $array->{$tn}->{$x} ne "" ? $array->{$tn}->{$x} : "&nbsp;");
			}
		} else {
			$href = extract_info($href->{number}, $href->{number}, { no_error => 1 });
			$href->{'lastmod'} = "0";
			$href->{'posts'} = "?";
			$href->{'subs'} = "?";
			$href->{'originator'} = "";
			$href->{'last_poster'} = "";
		}
		foreach my $y (split(/;/, $href->{properties})) {
			$y =~ s/\s//g;
			my ($y1, $y2) = split(/=/, $y, 2);
			$href->{'props'}->{$y1} = $y2;
		}
		$href->{icon} = (defined($href->{props}->{icon}) ? $href->{props}->{icon} : "tree_n");
		$href->{hidden} = $href->{props}->{hidden};
		$href->{type} = 1;
		$href->{descr} = $1 if ($fline =~ m|<!--?Descr-[!\-]>(.*?)<!--?/Descr-[!\-]>|);
		if (-e "$DCONF->{message_dir}/$tn") {
			$href->{secure} = 0;
			$href->{url} = "$DCONF->{message_url}/$tn/$tn.$DCONF->{ext}";
			$href->{url} .= "?$href->{lastmod}" if !$DCONF->{noqm};
		} else {
			$href->{secure} = 1;
			$href->{url} = "$DCONF->{authorize_reader}?file=/$tn/$tn.$DCONF->{ext}&lm=$href->{lastmod}";
		}
	}
	return $href;
}

sub _board_topics_cat {
	my ($these, $array) = @_;
	my $fline = join("", @{$these});
	$fline =~ s/\r\n/ /g;
	$fline =~ s/\r/ /g;
	$fline =~ s/\n/ /g;
	my $cref = {};
	if ($fline =~ m|^<!--Category: (\d+)-->|) {
		my $cn = $1;
		$cref->{number} = $cn;
		$cref->{text} = $1 if $fline =~ m|<!--Text-->(.*?)<!--/Text-->|;
		$cref->{descr} = $1 if $fline =~ m|<!--Descr-->(.*?)<!--/Descr-->|;
		$cref->{descr} = "" if $cref->{descr} !~ /\S/;
		$cref->{bgcolor} = $1 if $fline =~ m|<!--bgcolor:(.*?)-->|;
		$cref->{type} = 2;
	}
	return $cref;
}

###
### makeord
###
### Conversion of characters to their HTML equivalents if charconvert.conf
### is not functioning.
###

sub makeord {
	my ($o, $num) = @_;
	if (ord($o) <= 126 || ord($o) == 255) {
		$num = ord($o);
		return "&#$num;";
	} else {
		return $o;
	}
}

###
### remove_html
###
### Removes HTML code from text
###

sub remove_html {
	my ($string, $flag) = @_;
	$string =~ s/<IMG SRC="[^"]*" ALT="([^"]*)"[^>]*>/\[$1\]/gi;
	$string =~ s/<[^>]*>//g;
	$string =~ s/&#(\d+);//g if $flag == 0;
	return $string;
}

###
### alpha_sort
###
### Case-insensitive alphabetical sort
###

sub alpha_sort {
	my ($_a, $_b) = (lc(trim($a->{name})), lc(trim($b->{name})));
	return $_a cmp $_b;
}

###
### get_number
###
### Generates a new unique index from the data.txt file
###

sub get_number {
	my ($lock_arg) = @_;
	return sql_counter_increment("data", $lock_arg) if $GLOBAL_OPTIONS->{database};
	my $fref = readfile("$DCONF->{admin_dir}/data.txt", "get_number", { no_unlock => 1, no_lock => 0+$lock_arg });
	my $num = $fref->[0]; chomp $num; $num += 1;
	writefile("$DCONF->{admin_dir}/data.txt", [ $num ], "get_number", { no_lock => 1, no_unlock => 0+$lock_arg });
	return $num;
}

###
### sql_counter_increment
###
### Increments a counter in MySQL database and returns the value
###

sub sql_counter_increment {
	my ($counter, $lock_arg) = @_;
	my $counter_lookup = { data => 1, postindex => 2 };
	lock("sql_counter_increment", "$DCONF->{admin_dir}/$counter.txt") if ! $lock_arg;
	db_query("UPDATE $PARAMS->{db_prefix}counters SET value = value + 1 WHERE ID = ?;", undef, 0, [$counter_lookup->{$counter}]);
	my $val = db_sql_query(undef, "counters", "select", { ID => $counter_lookup->{$counter} }, undef);
	unlock("sql_counter_increment", "$DCONF->{admin_dir}/$counter.txt") if ! $lock_arg;
	return $val->[0]->{value};
}

1;
