File Manager - BorneoXploit

Editing: web-lib-funcs.pl

=head1 web-lib-funcs.pl

Common functions for Webmin CGI scripts. This file gets in-directly included
by all scripts that use web-lib.pl.
Example code:

use WebminCore;
  init_config();
  ui_print_header(undef, 'My Module', '');
  print 'This is Webmin version ',get_webmin_version(),'<p>\n';
  ui_print_footer();

=cut

##use warnings;
use Socket;
use POSIX;
use IO::Handle;
use bytes ();
use feature 'state';
eval "use Socket6";
$ipv6_module_error = $@;
our $error_handler_funcs = [ ];

use vars qw($loaded_theme_library $wait_for_input
	    $done_webmin_header $trust_unknown_referers $unsafe_index_cgi
	    %done_foreign_require $pragma_no_cache $foreign_args);
# Globals
use vars qw($module_index_name $number_to_month_map $month_to_number_map
	    $umask_already $default_charset $licence_status $os_type
	    $licence_message $script_name $loaded_theme_oo_library
	    $done_web_lib_funcs $os_version $module_index_link
	    $called_from_webmin_core $ipv6_module_error);

=head2 read_file(file, &hash, [&order], [lowercase], [split-char])

Fill the given hash reference with name=value pairs from a file. The required
parameters are :

=item file - The file to head, which must be text with each line like name=value

=item hash - The hash reference to add values read from the file to.

=item order - If given, an array reference to add names to in the order they were read

=item lowercase - If set to 1, names are converted to lower case

=item split-char - If set, names and values are split on this character instead of =

=cut
sub read_file
{
my ($file, $hash, $order, $lowercase, $split) = @_;
$split = "=" if (!defined($split));
my $realfile = &translate_filename($file);
&open_readfile(ARFILE, $file) || return 0;
local $_;
while(<ARFILE>) {
	s/\r|\n//g;
	my $cmt = index($_, "#");
	my $eq = index($_, $split);
	if ($cmt != 0 && $eq >= 0) {
		my $n = substr($_, 0, $eq);
		my $v = substr($_, $eq+1);
		chomp($v);
		$hash->{$lowercase ? lc($n) : $n} = $v;
		push(@$order, $n) if ($order);
        	}
        }
close(ARFILE);
$main::read_file_missing{$realfile} = 0;	# It exists now
if (defined($main::read_file_cache{$realfile})) {
	%{$main::read_file_cache{$realfile}} = %$hash;
	}
return 1;
}

=head2 read_file_cached(file, &hash, [&order], [lowercase], [split-char])

Like read_file, but reads from an in-memory cache if the file has already been
read in this Webmin script. Recommended, as it behaves exactly the same as
read_file, but can be much faster.

=cut
sub read_file_cached
{
my $realfile = &translate_filename($_[0]);
if (defined($main::read_file_cache{$realfile})) {
	# Use cached data
	%{$_[1]} = ( %{$_[1]}, %{$main::read_file_cache{$realfile}} );
	return 1;
	}
elsif ($main::read_file_missing{$realfile}) {
	# Doesn't exist, so don't re-try read
	return 0;
	}
else {
	# Actually read the file
	my %d;
	if (&read_file($_[0], \%d, $_[2], $_[3], $_[4])) {
		%{$main::read_file_cache{$realfile}} = %d;
		%{$_[1]} = ( %{$_[1]}, %d );
		return 1;
		}
	else {
		# Flag as non-existant
		$main::read_file_missing{$realfile} = 1;
		return 0;
		}
	}
}

=head2 read_file_cached_with_stat(file, &hash, [&order], [lowercase], [split-char])

Like read_file, but reads from an in-memory cache if the file has already been
read in this Webmin script AND has not changed.

=cut
sub read_file_cached_with_stat
{
my $realfile = &translate_filename($_[0]);
my $t = $main::read_file_cache_time{$realfile};
my @st = stat($realfile);
if ($t && $st[9] != $t) {
	# Changed, invalidate cache
	delete($main::read_file_cache{$realfile});
	delete($main::read_file_missing{$realfile});
	}
my $rv = &read_file_cached(@_);
$main::read_file_cache_time{$realfile} = $st[9];
return $rv;
}

=head2 write_file(file, &data-hash, [join], [sort])

Write out the contents of a hash as name=value lines. The parameters are :

=item file - Full path to write to

=item data-hash - A hash reference containing names and values to output

=item join - If given, names and values are separated by this instead of =

=item sort - If given, passed hash reference will be sorted by its keys

=cut
sub write_file
{
my ($file, $data_hash, $join, $sort) = @_;
my (%old, @order);
$join //= "=";
my $realfile = &translate_filename($file);
&read_file($file, \%old, \@order);
&open_tempfile(ARFILE, ">$file");
if ($sort || $gconfig{'sortconfigs'}) {
	# Always sort by keys
	foreach my $k (sort keys %{$data_hash}) {
		my $v = &write_file_cleanup($data_hash->{$k});
		(print ARFILE $k,$join,$v,"\n") ||
			&error(&text("efilewrite", $realfile, $!));
		}
	}
else {
	# Where possible, write out in the original order
	my %done;
	foreach my $k (@order) {
		if (exists($data_hash->{$k}) && !$done{$k}++) {
			my $v = &write_file_cleanup($data_hash->{$k});
			(print ARFILE $k,$join,$v,"\n") ||
				&error(&text("efilewrite", $realfile, $!));
			}
		}
	foreach my $k (keys %{$data_hash}) {
		if (!exists($old{$k}) && !$done{$k}++) {
			my $v = &write_file_cleanup($data_hash->{$k});
			(print ARFILE $k,$join,$v,"\n") ||
				&error(&text("efilewrite", $realfile, $!));
			}
		}
	}
&close_tempfile(ARFILE, %{$data_hash} ? 1 : 0);

# Update in-memory caches
if (defined($main::read_file_cache{$realfile})) {
	%{$main::read_file_cache{$realfile}} = %{$data_hash};
	}
if (defined($main::read_file_missing{$realfile})) {
	$main::read_file_missing{$realfile} = 0;
	}
}

=head2 write_file_cleanup(value)

Removes newline and any characters after it from a value to be written to
a data file by write_file.

=cut
sub write_file_cleanup
{
my ($v) = @_;
$v =~ s/\n[\000-\377]*$//;
return $v;
}

=head2 sort_file_by(file, sorted-by-file, [join])

Handles sorting of keys in one file based on another preserving
line-breaks and comments.

For example, used for one language file (i.e. en) to sort another language
file (i.e. de) preserving comments and line-breaks.

=item file - Full path to target file write to

=item sorted-by-file - Full path to a file to use for sorting preserving line-breaks and comments

=item join - If given, names and values are separated by this instead of =

=cut
sub sort_file_by
{
my ($file, $sorted_by_file, $join) = @_;
$join //= "=";

# Sort all the lines in the target file first
my (%data_target, %data_source, @data_order, %keys_checked);
my $fh = 'file';
&read_file($file, \%data_target);
&read_file($sorted_by_file, \%data_source, \@data_order);
&open_tempfile($fh, ">$file");
my $realfile = &translate_filename($file);
foreach (@data_order) {
	(print $fh $_,$join,$data_target{$_},"\n") ||
		&error(&text("efilewrite", $realfile, $!))
			if (exists($data_target{$_}) && !$keys_checked{$_}++);
	}
foreach (keys %data_target) {
	(print $fh $_,$join,$data_target{$_},"\n") ||
		&error(&text("efilewrite", $realfile, $!))
			if (!exists($data_source{$_}) && !$keys_checked{$_}++);
	}
&close_tempfile($fh, %data_target ? 1 : 0);
%{$main::read_file_cache{$realfile}} = %data_target
	if (defined($main::read_file_cache{$realfile}));

# Preserve comments and line-breaks
my $target_data = read_file_contents($file);
my $model_data = read_file_contents($sorted_by_file);
my %comments = reverse ($model_data =~ m/(#\s*[\d\.]+)[\n\s]+(.*?)=/gm);
my @lines = (($model_data =~ m/(.*?)$join|(^\s*$)/gm), undef, undef);
my @blocks;
my @block;
for (my $line = 0; $line < scalar(@lines) - 1; $line += 2) {
	# Build blocks of line's key separated with a new line break
	if ($lines[$line] =~ /\S+/) {
		push(@block, $lines[$line]);
		}
	else {
		push(@blocks, [@block]);
		@block = ();
		}
	}
for (my $block = 0; $block <= scalar(@blocks) - 1; $block++) {
	foreach my $line (@{$blocks[$block]}) {
		# Add a comment to the first block element
		if ($target_data =~ /(\Q$line\E)=(.*)/) {
			foreach my $comment (keys %comments) {
				if (grep(/^\Q$comment\E$/, @{$blocks[$block]})) {
					$target_data =~ s/(\Q$line\E)=(.*)/$comments{$comment}\n$1=$2/;
					last;
				}
			}
		last;
		}
	}
	foreach my $line (reverse @{$blocks[$block]}) {
		if (
			# Go to another block immediately
			# if new line already exists
			$target_data =~ /(\Q$line\E)$join.*?(\r?\n|\r\n?)+$/m ||

# Add new line to the last element of
			# the block and go to another block
			$target_data =~ s/(\Q$line\E)$join(.*)/$1=$2\n/) {
			last;
			}
		}
	}
&write_file_contents($file, $target_data);
}

=head2 html_escape(string, [no-double-amp-escape])

Converts &, < and > codes in text to HTML entities, and returns the new string.
This should be used when including data read from other sources in HTML pages.

=cut
sub html_escape
{
my ($tmp, $nodblamp) = @_;
if (!defined $tmp) {
	return ''; # empty string
	};
# Before escaping ampersand use negative lookahead to see if occurrence
# is not an HTML entity already to prevent double escaping (optionally)
$tmp =~ s/&(?!([a-zA-Z]+|#\d+|#[xX][0-9A-Fa-f]+);)/&amp;/g if ($nodblamp);
# Always escape all ampersands by default
# to make sure they are displayed per se
$tmp =~ s/&/&amp;/g if (!$nodblamp);
# Just always escape the following
$tmp =~ s/</&lt;/g;
$tmp =~ s/>/&gt;/g;
$tmp =~ s/\"/&quot;/g;
$tmp =~ s/\'/&#39;/g;
$tmp =~ s/=/&#61;/g;
return $tmp;
}

=head2 html_unescape(string)

Converts HTML entities to the corresponding character

=cut
sub html_unescape
{
my ($str) = @_;
if (!defined $str) {
	return ''; # empty string
	};
$str =~ s/&amp;/&/g;
$str =~ s/&lt;/</g;
$str =~ s/&gt;/>/g;
$str =~ s/&quot;/"/g;
$str =~ s/&#39;/'/g;
$str =~ s/&#61;/=/g;
$str =~ s/&nbsp;/ /g;
eval "use HTML::Entities";
if (!$@) {
	$str = decode_entities($str);
	}
return $str;
}

=head2 html_strip(string, replacement)

Removes any HTML from a string, replacing with nothing or given chars

=cut
sub html_strip
{
my ($str, $replacement) = @_;
$replacement ||= "";
$str =~ s/<(?:[^>'"]*|(['"]).*?\1)*>/$replacement/gs;
return $str;
}

=head2 quote_escape(string, [only-quote])

Converts ' and " characters in a string into HTML entities, and returns it.
Useful for outputting HTML tag values.

=cut
sub quote_escape
{
my ($tmp, $only) = @_;
if (!defined $tmp) {
    return ''; # empty string
};
if ($tmp !~ /\&[a-zA-Z]+;/ && $tmp !~ /\&#/) {
	# convert &, unless it is part of &#nnn; or &foo;
	$tmp =~ s/&([^#])/&amp;$1/g;
	}
$tmp =~ s/&$/&amp;/g;
$tmp =~ s/\"/&quot;/g if (!$only || $only eq '"');
$tmp =~ s/\'/&#39;/g if (!$only || $only eq "'");
return $tmp;
}

=head2 quote_literal_escape(string, [quote-char])

Escapes a string for safe inclusion in a Perl string literal. By default,
escapes for single-quoted strings. If quote-char is C<">, escapes for
double-quoted strings too.

=cut
sub quote_literal_escape
{
my ($str, $quote) = @_;
return '' if (!defined($str));
$quote ||= "'";

# Backslashes are escape leaders in both literal types
$str =~ s/\\/\\\\/g;
if ($quote eq '"') {
	# Double-quoted Perl strings also interpolate sigils
	$str =~ s/"/\\"/g;
	$str =~ s/\$/\\\$/g;
	$str =~ s/\@/\\\@/g;
	}
else {
	$str =~ s/'/\\'/g;
	}
return $str;
}

=head2 quote_javascript(string)

Quote all characters that are unsafe for inclusion in javascript strings in HTML

=cut
sub quote_javascript
{
my ($str) = @_;
$str =~ s/["'<>&\\]/sprintf('\x%02x', ord $&)/ge;
return $str;
}

=head2 tempname_dir_sys()

Returns a shared base directory for system-wide temporary files. This directory
does not depend on the current user. The directory is chosen once per process
and verified by creating a temporary probe file.

The result is cached for the lifetime of the current Perl process.

=cut
sub tempname_dir_sys
{
# Cache per module
state %base;
my @can_dirs;

# Return cached value if already determined
my $mod = &get_module_name() || '';
return $base{$mod} if (defined $base{$mod});

# Check configured system temp dirs (module override first)
my $modk = $mod ? "tempdir_sys_$mod" : undef;
push(@can_dirs, $gconfig{$modk}) if ($modk && $gconfig{$modk});
push(@can_dirs, $gconfig{'tempdir_sys'}) if ($gconfig{'tempdir_sys'});

# Common fallbacks
push(@can_dirs, "/dev/shm", "/tmp", "/var/tmp", "/usr/tmp");

# Remove duplicate entries, which can happen when both configured dirs are set
# to the same path, or when a configured path matches one of the built-in
# defaults
@can_dirs = &unique(@can_dirs);

# Test each candidate in turn
for my $dir (@can_dirs) {
	next if (!-d $dir);
	next if (!-w $dir);

# Confirm we can actually create a file
	my $tmp = "$dir/.webmin_${$}_".int(rand(1e16));
	if (open(my $fh, ">", $tmp)) {
		close($fh);
		unlink($tmp);
		$base{$mod} = $dir;	# Success, cache and return
		return $base{$mod};
		}
	}

my $keys = ($modk && $gconfig{$modk}) ? "$modk or tempdir_sys" : "tempdir_sys";
&error("No usable system temp directory found. Set $keys to a writable ".
       "directory in $config_directory/config and try again.");
}

=head2 webmin_temp_dir_name()

Returns the final directory name used for Webmin-private temp directories.
This defaults to .webmin, and can be changed with the hidden tempdirname
configuration option.

=cut
sub webmin_temp_dir_name
{
my $name = $gconfig{'tempdirname'} || ".webmin";
$name =~ s/^\s+//;
$name =~ s/\s+$//;
return $name =~ /^[^\/\\]+$/ && $name ne "." && $name ne ".." ?
	$name : ".webmin";
}

=head2 webmin_temp_dir_path(path)

Returns a temporary directory path ending in the configured Webmin-private
directory name.

=cut
sub webmin_temp_dir_path
{
my ($dir) = @_;
my $name = &webmin_temp_dir_name();
return $dir if (!defined($dir) || $dir eq "");
if ($gconfig{'os_type'} eq 'windows' || $dir =~ /^[a-z]:/i) {
	my $slash = $dir =~ /\// && $dir !~ /\\/ ? "/" : "\\";
	$dir =~ s/[\/\\]+$// if ($dir !~ /^[a-z]:[\/\\]?$/i);
	return $dir if ($dir =~ /[\/\\]\Q$name\E$/);
	return $dir =~ /^[a-z]:[\/\\]?$/i ? "$dir$name" :
	       "$dir$slash$name";
	}
$dir =~ s/\/+$// if ($dir ne "/");
return $dir if ($dir =~ /(^|\/)\Q$name\E$/);
return $dir eq "/" ? "/$name" : "$dir/$name";
}

=head2 default_webmin_temp_dir()

Returns the built-in Webmin temporary directory path used when no tempdir
configuration or environment override is set.

=cut
sub default_webmin_temp_dir
{
return -d "c:/temp" ? "c:/temp" : "/tmp/".&webmin_temp_dir_name();
}

=head2 tempname_dir()

Returns the base directory under which temp files can be created.

=cut
sub tempname_dir
{
my $tmp_base = $gconfig{'tempdir_'.&get_module_name()} ?
			$gconfig{'tempdir_'.&get_module_name()} :
		  $gconfig{'tempdir'} ? $gconfig{'tempdir'} :
		  $ENV{'TEMP'} && $ENV{'TEMP'} ne "/tmp" ? $ENV{'TEMP'} :
		  $ENV{'TMP'} && $ENV{'TMP'} ne "/tmp" ? $ENV{'TMP'} :
		  &default_webmin_temp_dir();
my $tmp_dir;
if (@remote_user_info && -d $remote_user_info[7] &&
    -w $remote_user_info[7] && !$gconfig{'nohometemp'}) {
	$tmp_dir = "$remote_user_info[7]/.tmp";
	}
elsif (@remote_user_info) {
	$tmp_dir = $tmp_base."-".$remote_user_info[2]."-".$remote_user;
	}
elsif ($< != 0) {
	my $u = getpwuid($<);
	if ($u) {
		$tmp_dir = $tmp_base."-".$<."-".$u;
		}
	else {
		$tmp_dir = $tmp_base."-".$<;
		}
	}
else {
	$tmp_dir = $tmp_base;
	}
return $tmp_dir;
}

=head2 tempname([filename])

Returns a mostly random temporary file name, typically under Webmin's default
temp directory. If filename is given, this will be the base name used.
Otherwise a unique name is selected randomly.

=cut
sub tempname
{
my ($filename) = @_;
my $tmp_dir = &tempname_dir();
if ($gconfig{'os_type'} eq 'windows' || $tmp_dir =~ /^[a-z]:/i) {
	# On Windows system, just create temp dir if missing
	if (!-d $tmp_dir) {
		mkdir($tmp_dir, 0755) ||
			&error("Failed to create temp directory $tmp_dir : $!");
		}
	}
else {
	# On Unix systems, need to make sure temp dir is valid
	if ($tmp_dir ne "/dev/shm" && $tmp_dir ne "/tmp" &&
	    $tmp_dir ne "/var/tmp" && $tmp_dir ne "/usr/tmp") {
		my $tries = 0;
		my $mkdirerr;
		while($tries++ < 10) {
			my @st = lstat($tmp_dir);
			if (@st) {
				my $mode = $st[2] & 07777;
				# Accept only Webmin-private dirs here. Shared
				# system temp roots are skipped above.
				last if ($st[4] == $< && (-d _) &&
					 $mode == 0755);
				unlink($tmp_dir) || rmdir($tmp_dir) ||
					system("/bin/rm -rf ".
					       quotemeta($tmp_dir));
				}
			# Directory may exist but has wrong permissions
			if (!-d $tmp_dir) {
				mkdir($tmp_dir, 0755) || (($mkdirerr = $!), next);
				}
			chown($<, $(, $tmp_dir) || (($mkdirerr = $!), next);
			chmod(0755, $tmp_dir) || (($mkdirerr = $!), next);
			}
		if ($tries >= 10) {
			my @st = lstat($tmp_dir);
			$mkdirerr = $mkdirerr ? " : $mkdirerr" : "";
			&error("Failed to setup temp directory ".
			       $tmp_dir.$mkdirerr);
			}
		}
	# If running as root, check parent dir (usually /tmp) to make sure it
	# is searchable by group and others.
	my $tmp_parent = $tmp_dir;
	$tmp_parent =~ s/\/[^\/]+$//;
	if ($tmp_parent eq "/tmp") {
		my @st = stat($tmp_parent);
		if (($st[2] & 0011) != 0011) {
			&error("Base temp directory $tmp_parent must be ".
			       "group and other executable");
			}
		}
	}
my $rv;
if (defined($filename) && $filename !~ /\.\./) {
	$rv = "$tmp_dir/$filename";
	}
else {
	$main::tempfilecount++;
	&seed_random();
	$rv = $tmp_dir."/".int(rand(1000000))."_".$$."_".
	       $main::tempfilecount."_".$scriptname;
	}
return $rv;
}

=head2 transname([filename])

Behaves exactly like tempname, but records the temp file for deletion when the
current Webmin script process exits.

=cut
sub transname
{
my $rv = &tempname(@_);
push(@main::temporary_files, $rv);
return $rv;
}

=head2 transname_timestamped([filename], [extension])

Behaves exactly like transname, but returns a filename with current timestamp

=item filename - Optional filename prefix to prepend

=item extension - Optional extension for a filename to append

=cut
sub transname_timestamped
{
my ($fname, $fextension) = @_;
my $fdate = strftime('%Y%m%d_%H%M%S', localtime());
$fname = "${fname}-" if ($fname);
return &transname("$fname$fdate$fextension");
}

=head2 trunc(string, maxlen)

Truncates a string to the shortest whole word less than or equal to the
given width. Useful for word wrapping.

=cut
sub trunc
{
if (length($_[0]) <= $_[1]) {
	return $_[0];
	}
my $str = substr($_[0], 0, $_[1]);
# If the cut landed inside a word (next char in the original is
# non-whitespace), back the partial word out — but only when there's
# a word boundary inside $str to back up to. If the first word is
# longer than maxlen, return that partial word rather than empty.
if (substr($_[0], $_[1], 1) =~ /\S/ && $str =~ /\s/) {
	$str =~ s/\S+$//;
	}
$str =~ s/\s+$//;
return $str;
}

=head2 indexof(string, value, ...)

Returns the index of some value in an array of values, or -1 if it was not
found.

=cut
sub indexof
{
for(my $i=1; $i <= $#_; $i++) {
	if ($_[$i] eq $_[0]) { return $i - 1; }
	}
return -1;
}

=head2 indexoflc(string, value, ...)

Like indexof, but does a case-insensitive match

=cut
sub indexoflc
{
my $str = lc(shift(@_));
my @arr = map { lc($_) } @_;
return &indexof($str, @arr);
}

=head2 sysprint(handle, [string]+)

Outputs some strings to a file handle, but bypassing IO buffering. Can be used
as a replacement for print when writing to pipes or sockets.

=cut
sub sysprint
{
my $fh = &callers_package($_[0]);
my $str = join('', @_[1..$#_]);
syswrite $fh, $str, length($str);
}

=head2 check_ipaddress(ip)

Check if some IPv4 address is properly formatted, returning 1 if so or 0 if not.

=cut
sub check_ipaddress
{
return $_[0] =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/ &&
	$1 >= 0 && $1 <= 255 &&
	$2 >= 0 && $2 <= 255 &&
	$3 >= 0 && $3 <= 255 &&
	$4 >= 0 && $4 <= 255;
}

=head2 check_ip6address(ip)

Check if some IPv6 address is properly formatted, and returns 1 if so.

=cut
sub check_ip6address
{
my $addr = $_[0];
my $m = 0;

# Strip an optional /N netmask before splitting. Doing this on the
# raw string (rather than from the last split element) keeps split()'s
# trailing-empty accounting intact for inputs like "2001:db8::/32",
# where the netmask would otherwise hide the trailing "::" shorthand.
if ($addr =~ s{/(\d+)\z}{}) {
	$m = $1;
	}
return 0 if ($m < 0 || $m > 128);

# Special case for unspecified address (analogous to 0.0.0.0 in IPv4),
# both bare and with a netmask.
return 1 if ($addr eq "::");

my @blocks = split(/:/, $addr);
return 0 if (@blocks == 0);

# Accept the IPv4-in-IPv6 forms (RFC 4291 §2.5.5: "::ffff:N.N.N.N"
# IPv4-mapped, and the more general "X:X:X:X:X:X:N.N.N.N"). If the
# last block is a dotted-quad, validate the octets and count it as two
# 16-bit groups for the overall 8-group ceiling. The leading ":" guard
# distinguishes IPv4-tailed IPv6 from a bare IPv4 address — callers
# like ip_match() rely on this sub returning false for "10.0.0.1".
my $count = scalar(@blocks);
if ($addr =~ /:/ &&
    $blocks[-1] =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)\z/) {
	return 0 if ($1 > 255 || $2 > 255 || $3 > 255 || $4 > 255);
	$count++;
	pop(@blocks);
	}
return 0 if ($count > 8);

# Check the different blocks of the address : 16 bits block in hexa notation.
# Possibility of 1 empty block or 2 if the address begins with "::".
my $empty = 0;
foreach my $b (@blocks) {
	return 0 if ($b ne "" && $b !~ /^[0-9a-f]{1,4}$/i);
	$empty++ if ($b eq "");
	}
return 0 if ($empty > 1 && !($addr =~ /^::/ && $empty == 2));
return 1;
}

=head2 is_non_public_ipaddress(ip)

Returns 1 if an IP is non-public (private, local, link-local, reserved,
multicast), otherwise 0.

=cut
sub is_non_public_ipaddress
{
my ($ip) = @_;
if (&check_ipaddress($ip)) {
	my @o = split(/\./, $ip);
	return 1 if ($o[0] == 0 || $o[0] == 10 || $o[0] == 127);
	return 1 if ($o[0] == 169 && $o[1] == 254);
	return 1 if ($o[0] == 172 && $o[1] >= 16 && $o[1] <= 31);
	return 1 if ($o[0] == 192 && $o[1] == 168);
	return 1 if ($o[0] == 192 && $o[1] == 0 &&
		     ($o[2] == 0 || $o[2] == 2));
	return 1 if ($o[0] == 192 && $o[1] == 88 && $o[2] == 99);
	return 1 if ($o[0] == 100 && $o[1] >= 64 && $o[1] <= 127);
	return 1 if ($o[0] == 198 && ($o[1] == 18 || $o[1] == 19));
	return 1 if ($o[0] == 198 && $o[1] == 51 && $o[2] == 100);
	return 1 if ($o[0] == 203 && $o[1] == 0 && $o[2] == 113);
	return 1 if ($o[0] >= 224);
	}
elsif (&check_ip6address($ip)) {
	my $l = lc($ip);
	$l =~ s{/\d+$}{};
	return 1 if ($l eq "::1" || $l eq "::");
	return 1 if ($l =~ /^fe[89ab]/);
	return 1 if ($l =~ /^fe[c-f]/);
	return 1 if ($l =~ /^f[cd]/);
	return 1 if ($l =~ /^ff/);
	my $packed = eval { inet_pton(AF_INET6(), $l) };
	if (defined($packed) &&
	    substr($packed, 0, 12) eq pack("H*", "0064ff9b0000000000000000")) {
		my $ip4 = join(".", unpack("C4", substr($packed, 12, 4)));
		return &is_non_public_ipaddress($ip4);
		}
	if (defined($packed) && substr($packed, 0, 2) eq "\x20\x02") {
		my $ip4 = join(".", unpack("C4", substr($packed, 2, 4)));
		return &is_non_public_ipaddress($ip4);
		}
	return 1 if (&ipaddress_matches_network($l, "64:ff9b:1::/48"));
	return 1 if (&ipaddress_matches_network($l, "100::/64"));
	return 1 if (&ipaddress_matches_network($l, "2001:db8::/32"));
	if (defined($packed) &&
	    (substr($packed, 0, 12) eq "\0" x 12 ||
	     substr($packed, 0, 10) eq "\0" x 10 &&
	     substr($packed, 10, 2) eq "\xff" x 2)) {
		my $ip4 = join(".", unpack("C4", substr($packed, 12, 4)));
		return &is_non_public_ipaddress($ip4);
		}
	}
return 0;
}

=head2 ipaddress_matches_network(ip, address-or-network)

Returns 1 if an IPv4 or IPv6 address matches an exact address or CIDR network.

=cut
sub ipaddress_matches_network
{
my ($ip, $network) = @_;
return 0 if (!defined($ip) || !defined($network));
$network =~ s/^\s+|\s+$//g;
my ($base, $prefix) = split(/\//, $network, 2);
my ($family, $bits);
# Permit an IPv4 exception to match the equivalent mapped IPv6 destination.
if (&check_ip6address($ip) && &check_ipaddress($base)) {
	my $packed = eval { inet_pton(AF_INET6(), $ip) };
	if (defined($packed) &&
	    (substr($packed, 0, 12) eq "\0" x 12 ||
	     substr($packed, 0, 10) eq "\0" x 10 &&
	     substr($packed, 10, 2) eq "\xff" x 2)) {
		my $ip4 = join(".", unpack("C4", substr($packed, 12, 4)));
		return &ipaddress_matches_network(
			$ip4, $base.(defined($prefix) ? "/$prefix" : ""));
		}
	}
if (&check_ipaddress($ip) && &check_ipaddress($base)) {
	$family = AF_INET();
	$bits = 32;
	}
elsif (&check_ip6address($ip) && &check_ip6address($base)) {
	$family = eval { AF_INET6() };
	return 0 if (!defined($family));
	$bits = 128;
	}
else {
	return 0;
	}
$prefix = $bits if (!defined($prefix));
return 0 if ($prefix !~ /^\d+$/ || $prefix > $bits);
my ($packed_ip, $packed_base);
if ($family == AF_INET()) {
	$packed_ip = inet_aton($ip);
	$packed_base = inet_aton($base);
	}
else {
	$packed_ip = eval { inet_pton($family, $ip) };
	$packed_base = eval { inet_pton($family, $base) };
	}
return 0 if (!defined($packed_ip) || !defined($packed_base));
my $bytes = int($prefix / 8);
return 0 if (substr($packed_ip, 0, $bytes) ne
		     substr($packed_base, 0, $bytes));
my $remaining = $prefix % 8;
if ($remaining) {
	my $mask = (0xff << (8-$remaining)) & 0xff;
	return 0 if ((ord(substr($packed_ip, $bytes, 1)) & $mask) !=
		     (ord(substr($packed_base, $bytes, 1)) & $mask));
	}
return 1;
}

=head2 get_download_address_callback(mode, [allowed-addresses])

Returns a callback for checking resolved download addresses against a policy.
The mode can be "public", "listed" or "all". In listed mode, non-public
addresses are allowed when they match a whitespace-separated list of IP
addresses or CIDR networks. Returns undef when no checks are required.

=cut
sub get_download_address_callback
{
my ($mode, $allowed) = @_;
return undef if (!defined($mode) || $mode eq "all");
$mode = 'public' if ($mode ne 'listed');

return sub {
	my ($host, $addresses) = @_;
	foreach my $ip (@$addresses) {
		next if (!&is_non_public_ipaddress($ip));
		if ($mode eq 'listed') {
			my $matched = 0;
			foreach my $network (split(/\s+/, $allowed || "")) {
				if (&ipaddress_matches_network($ip, $network)) {
					$matched = 1;
					last;
					}
				}
			next if ($matched);
			}
		return "Download from non-public IP address $ip is not allowed";
		}
	return undef;
	};
}

=head2 check_download_address(host, [&callback], [&resolved-addresses])

Resolves a download hostname and passes the resulting IP addresses to an
optional callback. The callback receives the hostname and an array reference
of addresses, and returns an error message to reject them or undef to allow
them. Returns an error message when resolution or validation fails. If the
resolved-addresses array reference is set, it is populated with the checked
addresses.

=cut
sub check_download_address
{
my ($host, $callback, $resolved_addresses) = @_;
my @addresses = &to_ipaddress($host);
push(@addresses, &to_ip6address($host));
return "Failed to lookup IP address for $host" if (!@addresses);
if ($callback) {
	my $error = &$callback($host, \@addresses);
	return $error if ($error);
	}
@$resolved_addresses = @addresses if ($resolved_addresses);
return undef;
}

=head2 generate_icon(image, title, link, [href], [width], [height], [before-title], [after-title])

Prints HTML for an icon image. The parameters are :

=item image - URL for the image, like images/foo.gif

=item title - Text to appear under the icon

=item link - Optional destination for the icon's link

=item href - Other HTML attributes to be added to the <a href> for the link

=item width - Optional width of the icon

=item height - Optional height of the icon

=item before-title - HTML to appear before the title link, but which is not actually in the link

=item after-title - HTML to appear after the title link, but which is not actually in the link

=cut
sub generate_icon
{
&load_theme_library();
if (defined(&theme_generate_icon)) {
	&theme_generate_icon(@_);
	return;
	}
my $w = !defined($_[4]) ? "width='48'" : $_[4] ? "width='$_[4]'" : "";
my $h = !defined($_[5]) ? "height='48'" : $_[5] ? "height='$_[5]'" : "";
if ($tconfig{'noicons'}) {
	if ($_[2]) {
		print "$_[6]<a href=\"$_[2]\" $_[3]>$_[1]</a>$_[7]\n";
		}
	else {
		print "$_[6]$_[1]$_[7]\n";
		}
	}
elsif ($_[2]) {
	print "<table border><tr><td width='48' height='48'>\n",
	      "<a href=\"$_[2]\" $_[3]><img src=\"$_[0]\" alt=\"\" border='0' ",
	      "$w $h></a></td></tr></table>\n";
	print "$_[6]<a href=\"$_[2]\" $_[3]>$_[1]</a>$_[7]\n";
	}
else {
	print "<table border><tr><td width='48' height='48'>\n",
	      "<img src=\"$_[0]\" alt=\"\" border='0' $w $h>",
	      "</td></tr></table>\n$_[6]$_[1]$_[7]\n";
	}
}

=head2 urlize

Converts a string to a form ok for putting in a URL, using % escaping.

=cut
sub urlize
{
my ($rv) = @_;
$rv =~ s/([^A-Za-z0-9])/sprintf("%%%2.2X", ord($1))/ge;
return $rv;
}

=head2 un_urlize(string)

Converts a URL-encoded string to it's original contents - the reverse of the
urlize function.

=cut
sub un_urlize
{
my ($rv, $plus) = @_;
if (!$plus) {
	$rv =~ s/\+/ /g;
	}
$rv =~ s/%(..)/pack("c",hex($1))/ge;
return $rv;
}

=head2 include(filename)

Read and output the contents of the given file.

=cut
sub include
{
local $_;
open(INCLUDE, "<".&translate_filename($_[0])) || return 0;
while(<INCLUDE>) {
	print;
	}
close(INCLUDE);
return 1;
}

=head2 copydata(in-handle, out-handle)

Read from one file handle and write to another, until there is no more to read.

=cut
sub copydata
{
my ($in, $out) = @_;
$in = &callers_package($in);
$out = &callers_package($out);
my $buf;
my $bs = &get_buffer_size();
while(read($in, $buf, $bs) > 0) {
	(print $out $buf) || return 0;
	}
return 1;
}

=head2 copydata_len(in-handle, out-handle|&writer, length, [buffer-size])

Read a fixed number of bytes from one file handle and write them to another,
or pass each chunk to a writer function. The writer must synchronously consume
the entire chunk and return true on success. Returns the number of bytes
copied, or undef if a read or write fails.

=cut
sub copydata_len
{
my ($in, $out, $len, $bs) = @_;
$in = &callers_package($in);
$out = &callers_package($out) if (ref($out) ne 'CODE');
$bs ||= &get_buffer_size();
my $got = 0;
while($got < $len) {
	my $want = $len - $got;
	$want = $bs if ($want > $bs);
	my $buf;
	my $r = read($in, $buf, $want);
	if (!defined($r)) {
		next if ($!{'EINTR'});
		return undef;
		}
	last if (!$r);
	my $ok = ref($out) eq 'CODE' ? &$out($buf) : print $out $buf;
	return undef if (!$ok);
	$got += $r;
	}
return $got;
}

=head2 ReadParseMime([maximum], [&cbfunc, &cbargs], [array-mode], [&direct-write])

Read data submitted via a POST request using the multipart/form-data coding,
and store it in the global %in hash. The optional parameters are :

=item maximum - If the number of bytes of input exceeds this number, stop reading and call error.

=item cbfunc - A function reference to call after reading each block of data.

=item cbargs - Additional parameters to the callback function.

=item array-mode - If set to 1, values in %in are arrays. If set to 0, multiple values are joined with \0. If set to 2, only the first value is used.

=item direct-dir - If given write file directly to disk temp given directory

=cut
sub ReadParseMime
{
my ($max, $cbfunc, $cbargs, $arrays, $direct_dir) = @_;
$cbargs ||= [ ];
my ($boundary, $line, $name, $got, $file, $count_lines, $max_lines);
my $err = &text('readparse_max', $max);
$ENV{'CONTENT_TYPE'} =~ /boundary=(.*)$/ || &error($text{'readparse_enc'});
if ($ENV{'CONTENT_LENGTH'} && $max && $ENV{'CONTENT_LENGTH'} > $max) {
	&error($err);
	}
&$cbfunc(0, $ENV{'CONTENT_LENGTH'}, $file, @$cbargs) if ($cbfunc);
$got = 0;
$boundary = $1;
$count_lines = 0;
$max_lines = 1000;
<STDIN>;	# skip first boundary
while(1) {
	$name = "";
	# Read section headers
	my $lastheader;
	my %header;
	while(1) {
		$line = <STDIN>;
		$got += length($line);
		&$cbfunc($got, $ENV{'CONTENT_LENGTH'}, $file, @$cbargs)
			if ($cbfunc);
		if ($max && $got > $max) {
			&error($err)
			}
		$line =~ tr/\r\n//d;
		last if (!$line);
		if ($line =~ /^(\S+):\s*(.*)$/) {
			$header{$lastheader = lc($1)} = $2;
			}
		elsif ($lastheader && $line =~ /^\s+(.*)$/) {
			$header{$lastheader} .= $1;
			}
		}

# Parse out filename and type
	$file = undef;
	if ($header{'content-disposition'} &&
	    $header{'content-disposition'} =~ /^form-data(.*)/) {
		my $rest = $1;
		while ($rest =~ /([a-zA-Z]*)=\"([^\"]*)\"(.*)/) {
			if ($1 eq 'name') {
				$name = $2;
				}
			else {
				my $foo = $name."_".$1;
				if ($1 eq "filename") {
					$file = $2;
					}
				if ($arrays == 1) {
					$in{$foo} ||= [];
					push(@{$in{$foo}}, $2);
					}
				elsif ($arrays == 2) {
					$in{$foo} ||= $2;
					}
				else {
					$in{$foo} .= "\0"
						if (defined($in{$foo}));
					$in{$foo} .= $2;
					}
				}
			$rest = $3;
			}
		}
	else {
		&error($text{'readparse_cdheader'});
		}

# Save content type separately
	if ($header{'content-type'} &&
	    $header{'content-type'} =~ /^([^\s;]+)/) {
		my $foo = $name."_content_type";
		if ($arrays == 1) {
			$in{$foo} ||= [];
			push(@{$in{$foo}}, $1);
			}
		elsif ($arrays == 2) {
			$in{$foo} ||= $1;
			}
		else {
			$in{$foo} .= "\0" if (defined($in{$foo}));
			$in{$foo} .= $1;
			}
		}

# Read data
	my $data = "";
	my $dfile;
	my $fh;
	if ($direct_dir && $file) {
		# Save directly to disk
		$file =~ s/.*[\\\/]//;
		$file || &error($text{'readparse_nofile'});
		my $uppath = "$direct_dir/$file";
		open($fh, ">", $uppath) ||
			&error(&text('readparse_cannotdir', $uppath, $!));
		# Return file name, no data
		$dfile = $file;
		}
	while (1) {
		$line = <STDIN>;
		$got += length($line);
		$count_lines++;
		if ($count_lines == $max_lines) {
			&$cbfunc($got, $ENV{'CONTENT_LENGTH'}, $file, @$cbargs)
				if ($cbfunc);
			$count_lines = 0;
			}
		if ($max && $got > $max) {
			#print STDERR "over limit of $max\n";
			#&error($err);
			}
		if (!$line) {
			# Unexpected EOF?
			&$cbfunc(-1, $ENV{'CONTENT_LENGTH'}, $file, @$cbargs)
				if ($cbfunc);
			close($fh) if ($fh);
			return;
			}
		last if (index($line, $boundary) != -1);
		if ($fh) {
			print($fh $line);  # Write directly to file
			}
		else {
			$data .= $line; # Store in memory
			}
		}

# Last two bytes are newlines
	if ($fh) {
		seek($fh, -2, 2);
		truncate($fh, tell($fh));
		close($fh);
		}
	else {
		chop($data); chop($data);
		}

# Add value to return hash
	if ($arrays == 1) {
		$in{$name} ||= [];
		push(@{$in{$name}}, $dfile || $data);
		}
	elsif ($arrays == 2) {
		$in{$name} ||= ($dfile || $data);
		}
	else {
		$in{$name} .= "\0" if (defined($in{$name}));
		$in{$name} .= ($dfile || $data);
		}
	if (index($line,"$boundary--") != -1) { last; }
	}
&$cbfunc(-1, $ENV{'CONTENT_LENGTH'}, $file, @$cbargs) if ($cbfunc);
}

=head2 ReadParse([&hash], [method], [noplus], [array-mode])

Fills the given hash reference with CGI parameters, or uses the global hash
%in if none is given. Also sets the global variables $in and @in. The other
parameters are :

=item method - For use of this HTTP method, such as GET

=item noplus - Don't convert + in parameters to spaces.

=item array-mode - If set to 1, values in %in are arrays. If set to 0, multiple values are joined with \0. If set to 2, only the first value is used.

=cut
sub ReadParse
{
my $a = $_[0] || \%in;
%$a = ( );
my $meth = $_[1] ? $_[1] : $ENV{'REQUEST_METHOD'};
undef($in);
if ($meth eq 'POST') {
	my $clen = $ENV{'CONTENT_LENGTH'};
	&read_fully(STDIN, \$in, $clen) == $clen ||
		&error("Failed to read POST input : $!");
	}
if ($ENV{'QUERY_STRING'}) {
	if ($in) { $in .= "&".$ENV{'QUERY_STRING'}; }
	else { $in = $ENV{'QUERY_STRING'}; }
	}
@in = split(/\&/, $in);
foreach my $i (@in) {
	$i =~ /\0/ && &error("Null byte in query string");
	my ($k, $v) = split(/=/, $i, 2);
	if (!$_[2]) {
		$k =~ tr/\+/ /;
		$v =~ tr/\+/ /;
		}
	$k =~ s/%(..)/pack("c",hex($1))/ge;
	$v =~ s/%(..)/pack("c",hex($1))/ge;
	if ($_[3] == 1) {
		$a->{$k} ||= [];
		push(@{$a->{$k}}, $v);
		}
	elsif ($_[3] == 2) {
		$a->{$k} ||= $v;
		}
	else {
		$a->{$k} = defined($a->{$k}) ? $a->{$k}."\0".$v : $v;
		}
	}
}

=head2 read_fully(fh, &buffer, length)

Read data from some file handle up to the given length, even in the face
of partial reads. Reads the number of bytes read. Stores received data in the
string pointed to be the buffer reference.

=cut
sub read_fully
{
my ($fh, $buf, $len) = @_;
$fh = &callers_package($fh);
my $got = 0;
while($got < $len) {
	my $r = read(STDIN, $$buf, $len-$got, $got);
	last if ($r <= 0);
	$got += $r;
	}
return $got;
}

=head2 read_parse_mime_callback(size, totalsize, upload-id)

Called by ReadParseMime as new data arrives from a form-data POST. Only updates
the file on every 1% change though. For internal use by the upload progress
tracker.

=cut
sub read_parse_mime_callback
{
my ($size, $totalsize, $filename, $id) = @_;
return if ($gconfig{'no_upload_tracker'});
return if (!$id);

# Create the upload tracking directory - if running as non-root, this has to
# be under the user's home
my $vardir;
if ($<) {
	my @uinfo = @remote_user_info ? @remote_user_info : getpwuid($<);
	$vardir = "$uinfo[7]/.tmp";
	}
else {
	$vardir = "$ENV{'WEBMIN_VAR'}/uploads";
	}
if (!-d $vardir) {
	&make_dir($vardir, 0750);
	}

# Remove any upload.* files more than 1 hour old
if (!$main::read_parse_mime_callback_flushed) {
	my $now = time();
	opendir(UPDIR, $vardir);
	foreach my $f (readdir(UPDIR)) {
		next if ($f !~ /^upload\./);
		my @st = stat("$vardir/$f");
		if ($st[9] < $now-3600) {
			unlink("$vardir/$f");
			}
		}
	closedir(UPDIR);
	$main::read_parse_mime_callback_flushed++;
	}

# Only update file once per percent
my $upfile = "$vardir/upload.$id";
if ($totalsize && $size >= 0) {
	my $pc = int(100 * $size / $totalsize);
	if (defined($main::read_parse_mime_callback_pc{$upfile}) &&
	    $pc <= $main::read_parse_mime_callback_pc{$upfile}) {
		return;
		}
	$main::read_parse_mime_callback_pc{$upfile} = $pc;
	}

# Write to the file
&open_tempfile(UPFILE, ">$upfile");
print UPFILE $size,"\n";
print UPFILE $totalsize,"\n";
print UPFILE $filename,"\n";
&close_tempfile(UPFILE);
}

=head2 read_parse_mime_javascript(upload-id, [&fields])

Returns an onSubmit= Javascript statement to popup a window for tracking
an upload with the given ID. For internal use by the upload progress tracker.

=cut
sub read_parse_mime_javascript
{
my ($id, $fields) = @_;
return "" if ($gconfig{'no_upload_tracker'});
my $opener = "window.open(\"@{[&get_webprefix()]}/uptracker.cgi?id=$id&uid=$<\", \"uptracker\", \"toolbar=no,menubar=no,scrollbars=no,width=500,height=128\");";
if ($fields) {
	my $if = join(" || ", map { "typeof($_) != \"undefined\" && $_.value != \"\"" } @$fields);
	return "onSubmit='if ($if) { $opener }'";
	}
else {
	return "onSubmit='$opener'";
	}
}

=head2 PrintHeader([charset], [mime-type], [headers])

Outputs the HTTP headers for an HTML page. The optional charset parameter
can be used to set a character set. Normally this function is not called
directly, but is rather called by ui_print_header or header.

=cut
sub PrintHeader
{
my ($cs, $mt, $headers) = @_;
$mt ||= "text/html";
if (uc($ENV{'HTTPS'}) eq "ON") {
	if ($ENV{'SSL_HSTS'}) {
		print "Strict-Transport-Security: max-age=31536000;\n";
		}
	else {
		print "Strict-Transport-Security: max-age=0;\n";
		}
	}
if ($pragma_no_cache || $gconfig{'pragma_no_cache'}) {
	print "pragma: no-cache\n";
	print "Expires: Thu, 1 Jan 1970 00:00:00 GMT\n";
	print "Cache-Control: no-store, no-cache, must-revalidate\n";
	print "Cache-Control: post-check=0, pre-check=0\n";
	}
if ($gconfig{'extra_headers'}) {
	foreach my $l (split(/\t+/, $gconfig{'extra_headers'})) {
		print $l."\n";
		}
	}
if ($headers) {
	foreach my $h (@{$headers}) {
		my ($name, $value) = @{$h};
		print "$name: $value\n";
	    }
	}
if (!$gconfig{'no_frame_options'}) {
	print "X-Frame-Options: SAMEORIGIN\n";
	}
if (!$gconfig{'no_content_security_policy'} &&
	 $gconfig{'extra_headers'} !~ /Content-Security-Policy:/) {
	if ($tconfig{'csp_headers'}) {
		print "Content-Security-Policy: $tconfig{'csp_headers'}\n";
		} 
	else {
		print "Content-Security-Policy: script-src 'self' 'unsafe-inline' 'unsafe-eval'; frame-src 'self'; child-src 'self'\n";
		}
	}
print "X-Content-Type-Options: nosniff\n";
if ($tconfig{'nolinks'}) {
	print "X-no-links: 1\n";
	}
if (defined($cs)) {
	print "Content-type: $mt; Charset=$cs\n\n";
	}
else {
	print "Content-type: $mt\n\n";
	}
$main::header_content_type = $mt;
}

=head2 header(title, image, [help], [config], [nomodule], [nowebmin], [rightside], [head-stuff], [body-stuff], [below])

Outputs a Webmin HTML page header with a title, including HTTP headers. The
parameters are :

=item title - The text to show at the top of the page

=item image - An image to show instead of the title text. This is typically left blank.

=item help - If set, this is the name of a help page that will be linked to in the title.

=item config - If set to 1, the title will contain a link to the module's config page.

=item nomodule - If set to 1, there will be no link in the title section to the module's index.

=item nowebmin - If set to 1, there will be no link in the title section to the Webmin index.

=item rightside - HTML to be shown on the right-hand side of the title. Can contain multiple lines, separated by <br>. Typically this is used for links to stop, start or restart servers.

=item head-stuff - HTML to be included in the <head> section of the page.

=item body-stuff - HTML attributes to be include in the <body> tag.

=item below - HTML to be displayed below the title. Typically this is used for application or server version information.

=cut
sub header
{
return if ($main::done_webmin_header++);
my $ll;
my $charset = defined($main::force_charset) ? $main::force_charset
					    : &get_charset();
&PrintHeader($charset);
&load_theme_library();
if (defined(&theme_header)) {
	$module_name = &get_module_name();
	&theme_header(@_);
	$miniserv::page_capture = 1;
	return;
	}
print "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n";
print "<html style=\"height:100%\">\n";
print "<head>\n";
if (defined(&theme_prehead)) {
	&theme_prehead(@_);
	}
if ($charset) {
	print "<meta http-equiv=\"Content-Type\" ",
	      "content=\"text/html; Charset=".&quote_escape($charset)."\">\n";
	}
if (@_ > 0) {
	my $title = &get_html_title($_[0]);
        print "<title>$title</title>\n" if ($_[7] !~ /<title>/i);
	print $_[7] if ($_[7]);
	print &get_html_status_line(0);
	}
print "$tconfig{'headhtml'}\n" if ($tconfig{'headhtml'});
if ($tconfig{'headinclude'}) {
	my ($theme, $overlay) = split(' ', $gconfig{'theme'});
	my $file_contents = read_file_contents("$root_directory/$overlay/$tconfig{'headinclude'}");;
	$file_contents = replace_meta($file_contents);
	print $file_contents;
	}
print "</head>\n";
my $bgcolor = defined($tconfig{'cs_page'}) ? $tconfig{'cs_page'} :
		 defined($gconfig{'cs_page'}) ? $gconfig{'cs_page'} : "ffffff";
my $link = defined($tconfig{'cs_link'}) ? $tconfig{'cs_link'} :
	      defined($gconfig{'cs_link'}) ? $gconfig{'cs_link'} : "0000ee";
my $text = defined($tconfig{'cs_text'}) ? $tconfig{'cs_text'} :
	      defined($gconfig{'cs_text'}) ? $gconfig{'cs_text'} : "000000";
my $bgimage = defined($tconfig{'bgimage'}) ? "background=$tconfig{'bgimage'}" : "";
my $dir = $current_lang_info->{'dir'} ? "dir=\"$current_lang_info->{'dir'}\"" : "";
my $html_body = "<body bgcolor=\"#$bgcolor\" link=\"#$link\" vlink=\"#$link\" text=\"#$text\" style=\"height:100%\" $bgimage $tconfig{'inbody'} $dir $_[8]>\n";
print &ui_switch_theme_javascript()
	if ($main::session_id && defined(&ui_switch_theme_javascript));
$html_body =~ s/\s+\>/>/g;
print $html_body;
print "<script>function _document_cookie_set_client_height(){document.cookie='client_height='+document.documentElement.clientHeight+'';}_document_cookie_set_client_height();window.onresize=_document_cookie_set_client_height</script>\n";

if (defined(&theme_prebody)) {
	&theme_prebody(@_);
	}

my $prebody = $tconfig{'prebody'};
if ($prebody) {
	$prebody = replace_meta($prebody);
	print "$prebody\n";
}
if ($tconfig{'prebodyinclude'}) {
	my ($theme, $overlay) = split(' ', $gconfig{'theme'});
	my $file_contents = read_file_contents("$root_directory/$overlay/$tconfig{'prebodyinclude'}");
	$file_contents = replace_meta($file_contents);
	print $file_contents;
	}
if (@_ > 1) {
	print $tconfig{'preheader'};
	my %this_module_info = &get_module_info(&get_module_name());
	print "<table class='header' width='100%'><tr>\n";
	if ($gconfig{'sysinfo'} == 2 && $remote_user) {
		print "<td id='headln1' colspan='3' align='center'>\n";
		print &get_html_status_line(1);
		print "</td></tr> <tr>\n";
		}
	print "<td id='headln2l' width='15%' valign='top' align='left'>";
	if ($ENV{'HTTP_WEBMIN_SERVERS'} && !$tconfig{'framed'}) {
		print "<a href='$ENV{'HTTP_WEBMIN_SERVERS'}'>",
		      "$text{'header_servers'}</a><br>\n";
		}
	if (!$_[5] && !$tconfig{'noindex'}) {
		my @avail = &get_available_module_infos(1);
		my $nolo = $ENV{'ANONYMOUS_USER'} ||
			      $ENV{'SSL_USER'} || $ENV{'LOCAL_USER'} ||
			      $ENV{'HTTP_USER_AGENT'} =~ /webmin/i;
		if ($gconfig{'gotoone'} && $main::session_id && @avail == 1 &&
		    !$nolo) {
			print "<a href='@{[&get_webprefix()]}/session_login.cgi?logout=1'>",
			      "$text{'main_logout'}</a><br>";
			}
		elsif ($gconfig{'gotoone'} && @avail == 1 && !$nolo) {
			print "<a href=@{[&get_webprefix()]}/switch_user.cgi>",
			      "$text{'main_switch'}</a><br>";
			}
		elsif (!$gconfig{'gotoone'} || @avail > 1) {
			print "<a href='@{[&get_webprefix()]}/?cat=",
			      $this_module_info{'category'},
			      "'>$text{'header_webmin'}</a><br>\n";
			}
		}
	if (!$_[4] && !$tconfig{'nomoduleindex'}) {
		my $idx = $this_module_info{'index_link'};
		my $mi = $module_index_link || "/".&get_module_name()."/$idx";
		my $mt = $module_index_name || $text{'header_module'};
		print "<a href=\"@{[&get_webprefix()]}$mi\">$mt</a><br>\n";
		}
	if (ref($_[2]) eq "ARRAY" && !$ENV{'ANONYMOUS_USER'} &&
	    !$tconfig{'nohelp'}) {
		print &hlink($text{'header_help'}, $_[2]->[0], $_[2]->[1]),
		      "<br>\n";
		}
	elsif (defined($_[2]) && !$ENV{'ANONYMOUS_USER'} &&
	       !$tconfig{'nohelp'}) {
		print &hlink($text{'header_help'}, $_[2]),"<br>\n";
		}
	if ($_[3]) {
		my %access = &get_module_acl();
		if (!$access{'noconfig'} && !$config{'noprefs'}) {
			my $cprog = $user_module_config_directory ?
					"uconfig.cgi" : "config.cgi";
			my $params = "";
			if ($ENV{'REQUEST_METHOD'} eq 'GET') {
				my %in;
				&ReadParse(\%in);
				foreach my $k (keys %in) {
					foreach my $v (split(/\0/, $in{$k})) {
						$params .= "&_cparam_".
						  &urlize($k)."=".&urlize($v);
						}
					}
				$params .= "&_cscript=".&urlize($scriptname);
				$params .= $_[3] eq '1' ? "" : $_[3];
				}
			print "<a href=\"@{[&get_webprefix()]}/$cprog?",
			      "module=".&get_module_name().$params."\">",
			      $text{'header_config'},"</a><br>\n";
			}
		}
	print "</td>\n";
	if ($_[1]) {
		# Title is a single image
		print "<td id='headln2c' align='center' width='70%'>",
		      "<img alt=\"$_[0]\" src=\"$_[1]\"></td>\n";
		}
	else {
		# Title is just text
		my $ts = defined($tconfig{'titlesize'}) ?
				$tconfig{'titlesize'} : "+2";
		print "<td id='headln2c' align='center' width='70%'>",
		      ($ts ? "<font size='$ts'>" : ""),$_[0],
		      ($ts ? "</font>" : "");
		print "<br>$_[9]\n" if ($_[9]);
		print "</td>\n";
		}
	print "<td id='headln2r' width='15%' valign='top' align='right'>";
	print $_[6];
	print "</td></tr></table>\n";
	print $tconfig{'postheader'};
	}
$miniserv::page_capture = 1;
}

=head2 get_html_title(title)

Returns the full string to appear in the HTML <title> block.

=cut
sub get_html_title
{
my ($msg) = @_;
my $title;
my $os_type = $gconfig{'real_os_type'} || $gconfig{'os_type'};
my $os_version = $gconfig{'real_os_version'} || $gconfig{'os_version'};
my $host = &get_display_hostname();
if ($gconfig{'sysinfo'} == 1 && $remote_user) {
	$title = sprintf "%s : %s on %s (%s %s)\n",
		$msg, $remote_user, $host,
		$os_type, $os_version;
	}
elsif ($gconfig{'sysinfo'} == 4 && $remote_user) {
	$title = sprintf "%s on %s (%s %s)\n",
		$remote_user, $host,
		$os_type, $os_version;
	}
else {
	$title = $msg;
	}
if ($gconfig{'showlogin'} && $remote_user) {
	$title = $remote_user.($title ? " : ".$title : "");
	}
if ($gconfig{'showhost'}) {
	$title = $host.($title ? " : ".$title : "");
	}
return $title;
}

=head2 get_html_framed_title

Returns the title text for a framed theme main page.

=cut
sub get_html_framed_title
{
my $ostr;
my $os_type = $gconfig{'real_os_type'} || $gconfig{'os_type'};
my $os_version = $gconfig{'real_os_version'} || $gconfig{'os_version'};
my $title;
if (($gconfig{'sysinfo'} == 4 || $gconfig{'sysinfo'} == 1) && $remote_user) {
	# Alternate title mode requested
	$title = sprintf "%s on %s (%s %s)\n",
		$remote_user, &get_display_hostname(),
		$os_type, $os_version;
	}
else {
	# Title like 'Webmin x.yy on hostname (Linux 6)'
	if ($os_version eq "*") {
		$ostr = $os_type;
		}
	else {
		$ostr = "$os_type $os_version";
		}
	my $host = &get_display_hostname();
	my $ver = &get_webmin_version();
	$title = $gconfig{'nohostname'} ? $text{'main_title2'} :
		 $gconfig{'showhost'} ? &text('main_title3', $ver, $ostr) :
					&text('main_title', $ver, $host, $ostr);
	if ($gconfig{'showlogin'}) {
		$title = $remote_user.($title ? " : ".$title : "");
		}
	if ($gconfig{'showhost'}) {
		$title = $host.($title ? " : ".$title : "");
		}
	}
return $title;
}

=head2 get_html_status_line(text-only)

Returns HTML for a script block that sets the status line, or if text-only
is set to 1, just return the status line text.

=cut
sub get_html_status_line
{
my ($textonly) = @_;
if (($gconfig{'sysinfo'} != 0 || !$remote_user) && !$textonly) {
	# Disabled in this mode
	return undef;
	}
my $os_type = $gconfig{'real_os_type'} || $gconfig{'os_type'};
my $os_version = $gconfig{'real_os_version'} || $gconfig{'os_version'};
my $line = &text('header_statusmsg',
		 ($ENV{'ANONYMOUS_USER'} ? "Anonymous user"
					   : $remote_user).
		 ($ENV{'SSL_USER'} ? " (SSL certified)" :
		  $ENV{'LOCAL_USER'} ? " (Local user)" : ""),
		 $text{'programname'},
		 &get_webmin_version(),
		 &get_display_hostname(),
		 $os_type.($os_version eq "*" ? "" :" $os_version"));
if ($textonly) {
	return $line;
	}
else {
	$line =~ s/\r|\n//g;
	return "<script type='text/javascript'>\n".
	       "window.defaultStatus=\"".&quote_escape($line)."\";\n".
	       "</script>\n";
	}
}

=head2 popup_header([title], [head-stuff], [body-stuff], [no-body])

Outputs a page header, suitable for a popup window. If no title is given,
absolutely no decorations are output. Also useful in framesets. The parameters
are :

=item title - Title text for the popup window.

=item head-stuff - HTML to appear in the <head> section.

=item body-stuff - HTML attributes to be include in the <body> tag.

=item no-body - If set to 1, don't generate a body tag

=cut
sub popup_header
{
return if ($main::done_webmin_header++);
my $ll;
my $charset = defined($main::force_charset) ? $main::force_charset
					    : &get_charset();
&PrintHeader($charset);
&load_theme_library();
if (defined(&theme_popup_header)) {
	&theme_popup_header(@_);
	$miniserv::page_capture = 1;
	return;
	}
print "<!DOCTYPE html PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\" \"http://www.w3.org/TR/html4/loose.dtd\">\n";
print "<html>\n";
print "<head>\n";
if (defined(&theme_popup_prehead)) {
	&theme_popup_prehead(@_);
	}
print "<title>$_[0]</title>\n";
print $_[1];
print "$tconfig{'headhtml'}\n" if ($tconfig{'headhtml'});
if ($tconfig{'headinclude'}) {
	print &read_file_contents(
		"$theme_root_directory/$tconfig{'headinclude'}");
	}
print "</head>\n";
my $bgcolor = defined($tconfig{'cs_page'}) ? $tconfig{'cs_page'} :
		 defined($gconfig{'cs_page'}) ? $gconfig{'cs_page'} : "ffffff";
my $link = defined($tconfig{'cs_link'}) ? $tconfig{'cs_link'} :
	      defined($gconfig{'cs_link'}) ? $gconfig{'cs_link'} : "0000ee";
my $text = defined($tconfig{'cs_text'}) ? $tconfig{'cs_text'} :
	      defined($gconfig{'cs_text'}) ? $gconfig{'cs_text'} : "000000";
my $bgimage = defined($tconfig{'bgimage'}) ? "background='$tconfig{'bgimage'}'"
					      : "";
if (!$_[3]) {
	print "<body id='popup' bgcolor='#$bgcolor' link='#$link' vlink='#$link' ",
	      "text='#$text' $bgimage $tconfig{'inbody'} $_[2]>\n";
	if (defined(&theme_popup_prebody)) {
		&theme_popup_prebody(@_);
		}
	}
$miniserv::page_capture = 1;
}

=head2 footer([page, name]+, [noendbody])

Outputs the footer for a Webmin HTML page, possibly with links back to other
pages. The links are specified by pairs of parameters, the first of which is
a link destination, and the second the link text. For example :

footer('/', 'Webmin index', '', 'Module menu');

=cut
sub footer
{
$miniserv::page_capture = 0;
&load_theme_library();
my %this_module_info = &get_module_info(&get_module_name());
if (defined(&theme_footer)) {
	$module_name = &get_module_name();	# Old themes use these
	%module_info = %this_module_info;
	&theme_footer(@_);
	return;
	}
for(my $i=0; $i+1<@_; $i+=2) {
	my $url = $_[$i];
	if ($url ne '/' || !$tconfig{'noindex'}) {
		if ($url eq '/') {
			$url = "/?cat=$this_module_info{'category'}";
			}
		elsif ($url eq '' && &get_module_name()) {
			$url = "/".&get_module_name()."/".
			       $this_module_info{'index_link'};
			}
		elsif ($url =~ /^\?/ && &get_module_name()) {
			$url = "/".&get_module_name()."/$url";
			}
		$url = "@{[&get_webprefix()]}$url" if ($url =~ /^\//);
		if ($i == 0) {
			print "<a href=\"$url\"><img alt=\"<-\" align='middle' border='0' src='@{[&get_webprefix()]}/images/left.gif'></a>\n";
			}
		else {
			print "&nbsp;|\n";
			}
		print "&nbsp;<a href=\"$url\">",&text('main_return', $_[$i+1]),"</a>\n";
		}
	}
print "<br>\n";
if (!$_[$i]) {
	my $postbody = $tconfig{'postbody'};
	if ($postbody) {
		$postbody = replace_meta($postbody);
		print "$postbody\n";
		}
	if ($tconfig{'postbodyinclude'}) {
		my ($theme, $overlay) = split(' ', $gconfig{'theme'});
		my $file_contents = read_file_contents("$root_directory/$overlay/$tconfig{'postbodyinclude'}");
		$file_contents = replace_meta($file_contents);
		print $file_contents;
		}
	if (defined(&theme_postbody)) {
		&theme_postbody(@_);
		}
	print "</body></html>\n";
	}
}

=head2 popup_footer([no-body])

Outputs html for a footer for a popup window, started by popup_header.

=cut
sub popup_footer
{
$miniserv::page_capture = 0;
&load_theme_library();
if (defined(&theme_popup_footer)) {
	&theme_popup_footer(@_);
	return;
	}
if (!$_[0]) {
	print "</body>\n";
	}
print "</html>\n";
}

=head2 load_module_preferences(module, &config)

Check if user preferences can be loaded for given
module based on module's prefs.info special file.

=cut
sub load_module_preferences
{
my ($module, $curr_config) = @_;
my $module_prefs_acls = &get_module_preferences_acl($module, 'allowed');
my $current_user_prefs = "$config_directory/$module/prefs.$remote_user";
if ($module_prefs_acls && -r $current_user_prefs) {
	if ($module_prefs_acls eq "*") {
		&read_file($current_user_prefs, \%$curr_config);
		}
	else {
		my %newconfigtmp;
		&read_file($current_user_prefs, \%newconfigtmp);
		foreach my $key (keys %newconfigtmp) {
		if (grep(/^$key$/, split(",", $module_prefs_acls))) {
				$curr_config->{$key} = $newconfigtmp{$key};
				}
			}
		}
	}
}

=head2 get_module_preferences_acl(module, type)

Return one of module's prefs params (if described by module in prefs.info).

=cut
sub get_module_preferences_acl
{
my ($module, $type) = @_;
my $module_dir = &module_root_directory($module);
my $module_prefs_conf_file = "$module_dir/prefs.info";
if (-r $module_prefs_conf_file) {
	my %module_prefs_conf;
	&read_file($module_prefs_conf_file, \%module_prefs_conf);
	return $module_prefs_conf{$type};
	}
return undef;
}

=head2 load_theme_library

Immediately loads the current theme's theme.pl file. Not generally useful for
most module developers, as this is called automatically by the header function.

=cut
sub load_theme_library
{
return if (!$current_theme || $loaded_theme_library++);
for(my $i=0; $i<@theme_root_directories; $i++) {
	if ($theme_configs[$i]->{'functions'}) {
		my @theme_funcs = split(/\s+/, $theme_configs[$i]->{'functions'});
		foreach my $theme_func (@theme_funcs) {
			do "$theme_root_directories[$i]/$theme_func";
			}
		}
	}
}

=head2 redirect(url)

Output HTTP headers to redirect the browser to some page. The url parameter is
typically a relative URL like index.cgi or list_users.cgi.

=cut
sub redirect
{
my %miniserv;
&get_miniserv_config(\%miniserv);
my $redirhost = $miniserv{'redirect_host'} || $ENV{'SERVER_NAME'};
my $redirport = $miniserv{'redirect_port'} || $ENV{'SERVER_PORT'};
my $redirssl = $miniserv{'redirect_ssl'} ne '' ? $miniserv{'redirect_ssl'} :
	       uc($ENV{'HTTPS'}) eq "ON" ? 1 : 0;
my $port = $redirport == 443 && $redirssl ? "" :
	   $redirport == 80 && !$redirssl ? "" : ":".$redirport;
my $prot = $redirssl ? "https" : "http";
my $wp = $gconfig{'webprefixnoredir'} ? undef : &get_webprefix();
my $url;
if ($_[0] =~ /^(http|https|ftp|gopher):/) {
	# Absolute URL (like http://...)
	$url = $_[0];
	}
elsif ($_[0] =~ /^\//) {
	# Absolute path (like /foo/bar.cgi)
	if ($gconfig{'relative_redir'}) {
		$url = "$wp$_[0]";
		}
	else {
		$url = "$prot://$redirhost$port$wp$_[0]";
		}
	}
elsif ($ENV{'SCRIPT_NAME'} =~ /^(.*)\/[^\/]*$/) {
	# Relative URL (like foo.cgi)
	if ($gconfig{'relative_redir'}) {
		$url = "$wp$1/$_[0]";
		}
	else {
		$url = "$prot://$redirhost$port$wp$1/$_[0]";
		}
	}
else {
	if ($gconfig{'relative_redir'}) {
		$url = "$wp$_[0]";
		}
	else {
		$url = "$prot://$redirhost$port/$wp$_[0]";
		}
	}
&load_theme_library();
if (defined(&theme_redirect)) {
	$module_name = &get_module_name();	# Old themes use these
	%module_info = &get_module_info($module_name);
	&theme_redirect($_[0], $url);
	}
else {
	print "Location: $url\n\n";
	}
}

=head2 kill_byname(name, signal)

Finds a process whose command line contains the given name (such as httpd), and
sends some signal to it. The signal can be numeric (like 9) or named
(like KILL).

=cut
sub kill_byname
{
my @pids = &find_byname($_[0]);
return scalar(@pids) if (&is_readonly_mode());
&webmin_debug_log('KILL', "signal=$_[1] name=$_[0]")
	if ($gconfig{'debug_what_procs'});
if (@pids) { kill($_[1], @pids); return scalar(@pids); }
else { return 0; }
}

=head2 kill_byname_logged(name, signal)

Like kill_byname, but also logs the killing.

=cut
sub kill_byname_logged
{
my @pids = &find_byname($_[0]);
return scalar(@pids) if (&is_readonly_mode());
if (@pids) { &kill_logged($_[1], @pids); return scalar(@pids); }
else { return 0; }
}

=head2 find_byname(name)

Finds processes searching for the given name in their command lines, and
returns a list of matching PIDs.

=cut
sub find_byname
{
if ($gconfig{'os_type'} =~ /-linux$/ && -r "/proc/$$/cmdline") {
	# Linux with /proc filesystem .. use cmdline files, as this is
	# faster than forking
	my @pids;
	opendir(PROCDIR, "/proc");
	foreach my $f (readdir(PROCDIR)) {
		if ($f eq int($f) && $f != $$) {
			my $line = &read_file_contents("/proc/$f/cmdline");
			if ($line =~ /$_[0]/) {
				push(@pids, $f);
				}
			}
		}
	closedir(PROCDIR);
	return @pids;
	}

if (&foreign_check("proc")) {
	# Call the proc module
	&foreign_require("proc", "proc-lib.pl");
	if (defined(&proc::list_processes)) {
		my @procs = &proc::list_processes();
		my @pids;
		foreach my $p (@procs) {
			if ($p->{'args'} =~ /$_[0]/) {
				push(@pids, $p->{'pid'});
				}
			}
		@pids = grep { $_ != $$ } @pids;
		return @pids;
		}
	}

# Fall back to running a command
my ($cmd, @pids);
$cmd = $gconfig{'find_pid_command'};
$cmd =~ s/NAME/"$_[0]"/g;
$cmd = &translate_command($cmd);
@pids = split(/\n/, `($cmd) <$null_file 2>$null_file`);
@pids = grep { $_ != $$ } @pids;
return @pids;
}

=head2 error([message]+)

Display an error message and exit. This should be used by CGI scripts that
encounter a fatal error or invalid user input to notify users of the problem.
If error_setup has been called, the displayed error message will be prefixed
by the message setup using that function.

=cut
sub error
{
$main::no_miniserv_userdb = 1;
&setvar('error-fatal', 1);
my $msg = join("", @_);
$msg =~ s/<[^>]*>//g;
my (@msg) = @_;
my @stack;
for(my $i=0; my @stack_ = caller($i); $i++) {
	push(@stack, \@stack_);
	}
my $err_caller;
if ($stack[0]->[1] && $stack[0]->[2]) {
	$err_caller = "$stack[0]->[1] (line $stack[0]->[2])";
	$err_caller =~ s/$root_directory\///;
	$err_caller = $msg ? "$msg $err_caller" : $err_caller;
	}
my $error_details = (($ENV{'WEBMIN_DEBUG'} || $gconfig{'debug_enabled'}) ? "" : "\n");
my $error_output_right = sub {
	my ($err_msg) = @_;
	return $main::webmin_script_type ne 'web' ?
		&html_strip(&entities_to_ascii($err_msg)) : $err_msg;
	};
if (!$main::error_must_die) {
	&error_stderr(&$error_output_right($msg));
	}
&load_theme_library();
if ($main::error_must_die) {
	die "@msg$error_details";
	}
&call_error_handlers();
if (!$ENV{'REQUEST_METHOD'}) {
	# Show text-only error
	print STDERR "$text{'error'}\n";
	print STDERR "-----\n";
	print STDERR ($main::whatfailed ? "$main::whatfailed : " : ""),
			&$error_output_right($msg),"\n";
	print STDERR "-----\n";
	&print_call_stack() if ($gconfig{'error_stack'});
	}
elsif (defined(&theme_error)) {
	&theme_error({err => \@_, stack => \@stack, err_caller => $err_caller});
	}
elsif ($ENV{'REQUEST_URI'} =~ /json-error=1/) {
	my %jerror;
	my $error_what = ($main::whatfailed ? "$main::whatfailed: " : "");
	my $error_message = join(",", @_);
	my $error = ($error_what . $error_message);
	%jerror = (error => $error,
		   error_fatal => 1, 
		   error_what => $error_what, 
		   error_message => $error_message,
		   error_caller => $err_caller,
		  );
	print_json(\%jerror);
	}
else {
	&header($text{'error'}, "", undef, 0, &get_module_name() ? 0 : 1);
	my $hh = $miniserv::page_capture ? " captured" : "";
	my $err_style = &read_file_contents("$root_directory/unauthenticated/errors.css");
	if ($err_style) {
		$err_style =~ s/[\n\r]//g;
		$err_style =~ s/\s+/ /g;
		$err_style = "<style data-err type=\"text/css\">$err_style</style>";
		print "\n$err_style\n";
		}
	print "<hr>\n" if ($hh);
	if ($hh) {
		print "<h3 data-fatal-error-text>",($main::whatfailed ? "$main::whatfailed : " : ""),
			     @msg,"</h3>\n";
		}
	else {
		my $error_what = ($main::whatfailed ? "$main::whatfailed: " : "");
		my $error_html = join(",", @msg);
		my $error_text;
		if ($error_html !~ /<pre.*?>/) {
			$error_text = " &mdash; $error_html";
			$error_html = undef;
			}
		print "<title>$text{'error'}</title><h3 class=\"err-head\" data-fatal-error-text>$text{'error'}$error_text</h3>$error_html<br>\n";
		}
	if ($gconfig{'error_stack'}) {
		# Show call stack
		my $cls_err_caption = " class=\"err-head$hh\"";
		my $cls_err_td = $hh ? " class=\"@{[&trim($hh)]}\"" : "";
		print "<hr>\n" if ($hh);
		print "<table class=\"err-stack$hh\"><caption$cls_err_caption>$text{'error_stack'}</caption>\n";
		print "<tr> <td$cls_err_td><b>$text{'error_file'}</b></td> ",
		      "<td$cls_err_td><b>$text{'error_line'}</b></td> ",
		      "<td$cls_err_td><b>$text{'error_sub'}</b></td> </tr>\n";
		foreach my $stack (@stack) {
			print "<tr>\n";
			print "<td$cls_err_td>$stack->[1]</td>\n";
			print "<td$cls_err_td>$stack->[2]</td>\n";
			print "<td$cls_err_td>$stack->[3]</td>\n";
			print "</tr>\n";
			}
		print "</table>\n";
		}
	print "<hr>\n" if ($hh);
	if ($ENV{'HTTP_REFERER'} && $main::completed_referers_check) {
		&footer("javascript:history.back()", $text{'error_previous'});
		}
	else {
		&footer();
		}
	}
&unlock_all_files();
&cleanup_tempnames();
exit(1);
}

=head2 error_stderr(err, [return])

Output to STDERR or return error line

=cut
sub error_stderr
{
my ($err, $ret) = @_;
my (@tm, @month, @gmt, $days, $hours, $mins, $timezone,
    $make_datestr, $remote_host, $page);
@tm = localtime(time());
@month = ( "Jan", "Feb", "Mar", "Apr", "May", "Jun",
           "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" );
@gmt = gmtime(time());
$days = $tm[3] - $gmt[3];
$hours =
  ($days < -1 ? 24 : 1 < $days ? -24 : $days * 24) +
    $tm[2] - $gmt[2];
$mins = $hours * 60 + $tm[1] - $gmt[1];
$timezone = ($mins < 0 ? "-" : "+"); $mins = abs($mins);
$timezone .= sprintf("%2.2d%2.2d", $mins/60, $mins%60);
$make_datestr =
  sprintf("%2.2d/%s/%4.4d:%2.2d:%2.2d:%2.2d %s",
    $tm[3], $month[$tm[4]], $tm[5]+1900,
      $tm[2], $tm[1], $tm[0], $timezone);
$remote_host = $ENV{"REMOTE_HOST"};
$page = $ENV{"REQUEST_URI"};
$err = &html_strip(&entities_to_ascii($err));
$err =~ s/[\n\r]+/ /g;
$err =~ s/\s\?$//g;
$err =
  "[$make_datestr] " .
	($remote_host ? ( "[$remote_host] " ) : ( )) .
	  ($page ? ( "$page : " ) : ( )) . "$err\n";
return $err if ($ret);
print STDERR $err;
}

=head2 print_call_stack()

Output the call stack of the current function to STDERR

=cut
sub print_call_stack
{
print STDERR $text{'error_stack'},"\n";
for(my $i=0; my @stack = caller($i); $i++) {
	print STDERR &text('error_stackline',
		$stack[1], $stack[2], $stack[3]),"\n";
	}
}

=head2 popup_error([message]+)

This function is almost identical to error, but displays the message with HTML
headers suitable for a popup window.

=cut
sub popup_error
{
$main::no_miniserv_userdb = 1;
&load_theme_library();
if ($main::error_must_die) {
	die @_;
	}
&call_error_handlers();
if (defined(&theme_popup_error)) {
	&theme_popup_error(@_);
	}
else {
	&popup_header($text{'error'}, "");
	print "<h3>",($main::whatfailed ? "$main::whatfailed : " : ""),@_,"</h3>\n";
	&popup_footer();
	}
&unlock_all_files();
&cleanup_tempnames();
exit;
}

=head2 register_error_handler(&func, arg, ...)

=cut
sub register_error_handler
{
my ($f, @args) = @_;
push(@$error_handler_funcs, [ $f, @args ]);
}

=head2 call_error_handlers()

Internal function to call all registered error handlers

=cut
sub call_error_handlers
{
my @funcs = @$error_handler_funcs;
$error_handler_funcs = [ ];
foreach my $e (@funcs) {
	my ($f, @args) = @$e;
	&$f(@args);
	}
}

=head2 error_setup(message)

Registers a message to be prepended to all error messages displayed by the
error function.

=cut
sub error_setup
{
$main::whatfailed = $_[0];
}

=head2 wait_for(handle, regexp, regexp, ...)

Reads from the input stream until one of the regexps matches, and returns the
index of the matching regexp, or -1 if input ended before any matched. This is
very useful for parsing the output of interactive programs, and can be used with
a two-way pipe to feed input to a program in response to output matched by
this function.

If the matching regexp contains bracketed sub-expressions, their values will
be placed in the global array @matches, indexed starting from 1. You cannot
use the Perl variables $1, $2 and so on to capture matches.

Example code:

$rv = wait_for($loginfh, "username:");
 if ($rv == -1) {
   error("Didn't get username prompt");
 }
 print $loginfh "joe\n";
 $rv = wait_for($loginfh, "password:");
 if ($rv == -1) {
   error("Didn't get password prompt");
 }
 print $loginfh "smeg\n";

=cut
sub wait_for
{
my ($c, $i, $sw, $rv, $ha);
undef($wait_for_input);
if ($wait_for_debug) {
	print STDERR "wait_for(",join(",", @_),")\n";
	}
$ha = &callers_package($_[0]);
if ($wait_for_debug) {
	print STDERR "File handle=$ha fd=",fileno($ha),"\n";
	}
$codes =
"my \$hit;\n".
"while(1) {\n".
" if ((\$c = getc(\$ha)) eq \"\") { return -1; }\n".
" \$wait_for_input .= \$c;\n";
if ($wait_for_debug) {
	$codes .= "print STDERR \$wait_for_input,\"\\n\";";
	}
for($i=1; $i<@_; $i++) {
        $sw = $i>1 ? "elsif" : "if";
        $codes .= " $sw (\$wait_for_input =~ /$_[$i]/i) { \$hit = $i-1; }\n";
        }
$codes .=
" if (defined(\$hit)) {\n".
"  \@matches = (-1, \$1, \$2, \$3, \$4, \$5, \$6, \$7, \$8, \$9);\n".
"  return \$hit;\n".
"  }\n".
" }\n";
$rv = eval $codes;
if ($@) {
	&error("wait_for error : $@\n");
	}
return $rv;
}

=head2 fast_wait_for(handle, string, string, ...)

This function behaves very similar to wait_for (documented above), but instead
of taking regular expressions as parameters, it takes strings. As soon as the
input contains one of them, it will return the index of the matching string.
If the input ends before any match, it returns -1.

=cut
sub fast_wait_for
{
my ($inp, $maxlen, $ha, $i, $c, $inpl);
for($i=1; $i<@_; $i++) {
	$maxlen = length($_[$i]) > $maxlen ? length($_[$i]) : $maxlen;
	}
$ha = $_[0];
while(1) {
	if (($c = getc($ha)) eq "") {
		&error("fast_wait_for read error : $!");
		}
	$inp .= $c;
	if (length($inp) > $maxlen) {
		$inp = substr($inp, length($inp)-$maxlen);
		}
	$inpl = length($inp);
	for($i=1; $i<@_; $i++) {
		if ($_[$i] eq substr($inp, $inpl-length($_[$i]))) {
			return $i-1;
			}
		}
	}
}

=head2 has_command(command)

Returns the full path to the executable if some command is in the path, or
undef if not found. If the given command is already an absolute path and
exists, then the same path will be returned.

=cut
sub has_command
{
if (!$_[0]) { return undef; }
if (exists($main::has_command_cache{$_[0]})) {
	return $main::has_command_cache{$_[0]};
	}
my $rv = undef;
my $slash = $gconfig{'os_type'} eq 'windows' ? '\\' : '/';
if ($_[0] =~ /^\// || $_[0] =~ /^[a-z]:[\\\/]/i) {
	# Absolute path given - just use it
	my $t = &translate_filename($_[0]);
	$rv = (-x $t && !-d _) ? $_[0] : undef;
	}
else {
	# Check each directory in the path
	my %donedir;
	foreach my $d (split($path_separator || ":", $ENV{'PATH'})) {
		next if ($donedir{$d}++);
		$d =~ s/$slash$// if ($d ne $slash);
		my $t = &translate_filename("$d/$_[0]");
		if (-x $t && !-d _) {
			$rv = $d.$slash.$_[0];
			last;
			}
		if ($gconfig{'os_type'} eq 'windows') {
			foreach my $sfx (".exe", ".com", ".bat") {
				my $t = &translate_filename("$d/$_[0]").$sfx;
				if (-r $t && !-d _) {
					$rv = $d.$slash.$_[0].$sfx;
					last;
					}
				}
			}
		}
	}
$main::has_command_cache{$_[0]} = $rv;
return $rv;
}

=head2 make_date(seconds, [date-only-or-opts], [fmt])

Converts a Unix date/time in seconds to a human-readable form, by default
formatted like dd/mmm/yyyy hh:mm:ss. Parameters are :

=item seconds - Unix time is seconds to convert.

=item date-only-or-opts - If set to 1 exclude the time from the returned string.

In case this param is a hash reference use it for options in a new
DateTime::Locale code or preserve the original, old logic

=item fmt - Optional, one of dd/mon/yyyy, dd/mm/yyyy, mm/dd/yyyy or yyyy/mm/dd

=cut
sub make_date
{
my ($secs, $only, $fmt) = @_;
state $locale_military_name;
$secs ||= 0;
eval "use DateTime; use DateTime::Locale; use DateTime::TimeZone;";
if (!$@ && $] > 5.011) {
	my $opts = ref($only) ? $only : {};
	my $locale_default = &get_default_system_locale();
	my $locale_auto = &parse_accepted_language();
	my $locale_name = $opts->{'locale'} ||
	   $gconfig{'locale_'.$base_remote_user} ||
	   $gconfig{'locale_'.$remote_user} || $locale_auto ||
	   $gconfig{'locale'} || &get_default_system_locale();
	my $tz = $opts->{'tz'};
	if (!$tz) {
		eval {
			$tz = DateTime::TimeZone->new(
			  name => strftime("%z", localtime()))->name(); # +0200
			};
		if ($@) {
			eval {
				$tz = DateTime::TimeZone->new(
				  name => 'local')->name();  # Asia/Nicosia
				};
			if ($@) {
				$tz = DateTime::TimeZone->new(
				  name => 'UTC')->name();    # UTC
				}
			}
		}
	# Pre-process time locale
	my $locale_military_status = sub {
		return ($locale_military_name &&
			$locale_military_name =~ /[a-z]/i) ? 2 :
		       ($locale_military_name == 1) ? 1 : 0;
		};
	# Allow locales with military time (in 24h format)
	my $locale_name_loaded = &$locale_military_status() == 2 ?
			$locale_military_name : $locale_name;
	my $locale_name_initial = $locale_name;
	if ($locale_name =~ /[a-z]{2}24$/i && &$locale_military_status() == 0) {
		$locale_name =~ s/^(.*?)24$/$1/;
		$locale_name_loaded = $locale_name;
		$locale_military_name = 1;
		}
	# Load given locale
	my $locale = DateTime::Locale->load($locale_name_loaded);
	# Create a new locale out of base locale
	if (&$locale_military_status() == 1) {
		my %locale_data = $locale->locale_data;
		$locale_data{'code'} = $locale_name_initial;

# Force 24h time
		$locale_data{'glibc_date_1_format'} = '%a %b %e %H:%M:%S %Z %Y';
		$locale_data{'glibc_datetime_format'} = '%a %d %b %Y %T %Z';
		$locale_data{'glibc_time_format'} = '%T';
		DateTime::Locale->register_from_data(%locale_data);

# Load newly cloned locale in 24h time format
		$locale_military_name = $locale_name_loaded =
			$locale_name_initial;
		$locale = DateTime::Locale->load($locale_name_loaded);
		}
	my $locale_format_full_tz = $locale->glibc_date_1_format;    # Sat 20 Nov 2286 17:46:39 UTC
	my $locale_format_full = $locale->glibc_datetime_format;     # Sat 20 Nov 2286 17:46:39
	my $locale_format_short = $locale->glibc_date_format;        # 20/11/86
	my $locale_format_time = $locale->glibc_time_format;         # 17:46:39
	my $locale_format_delimiter = "/";
	if ($opts->{'delimiter'}) {
		$locale_format_delimiter = $opts->{'delimiter'};
		}
	elsif ($locale_format_short =~ /\%.*?\[a-zA-Z]\s*(?<delimiter>.)/) {
		$locale_format_delimiter = "$+{delimiter}";
		}

# Return fully detailed object
	if (ref($only)) {
		# Can we get ago time
		my $ago;
		my $ago_secs = time() - $secs;
		eval "use Time::Seconds";
		if (!$@ && $ago_secs) {
			my $ago_obj = Time::Seconds->new($ago_secs);
			$ago = {
				"seconds" => int($ago_obj->seconds),
				"minutes" =>  int($ago_obj->minutes),
				"hours" => int($ago_obj->hours),
				"days" => int($ago_obj->days),
				"weeks" => int($ago_obj->weeks),
				"months"  => int($ago_obj->months),
				"years" => int($ago_obj->years),
				"pretty" => $ago_obj->pretty
			};
		}
		my $data = {
			# Wed Feb 8 05:09:39 PM UTC 2023
			'full-tz-utc' => DateTime->from_epoch(
			    locale => $locale_name_loaded,
			    epoch => $secs)->strftime($locale_format_full_tz),
			# Wed Feb 8 07:10:01 PM EET 2023 
			'full-tz' => DateTime->from_epoch(
			    locale => $locale_name_loaded,
			    epoch => $secs,
			    time_zone => $tz)->strftime($locale_format_full_tz),
			# Wed 08 Feb 2023 07:11:26 PM EET
			'full' => DateTime->from_epoch(
			    locale => $locale_name_loaded,
			    epoch => $secs,
			    time_zone => $tz)->strftime($locale_format_full),
			# 02/08/2023
			'short' => DateTime->from_epoch(
			    locale => $locale_name_loaded,
			    epoch => $secs,
			    time_zone => $tz)->strftime($locale_format_short),
			# 07:12:07 PM
			'time' => DateTime->from_epoch(
			    locale => $locale_name_loaded,
			    epoch => $secs,
			    time_zone => $tz)->strftime($locale_format_time),
			'ago' => $ago,
			'tz' => $tz,
			'delimiter' => $locale_format_delimiter,
			'timestamp' => $secs,
			'_locale' => $opts->{'getFull'} ? $locale : undef,
			};
		# Add time short, e.g. 17:46 or 5:46 PM
		$data->{'timeshort'} = $data->{'time'};
		$data->{'timeshort'} =~ s/(\d+):(\d+):(\d+)(.*?)/$1:$2$4/;

# %c alternative with full week and month and no seconds
		# in time (complete)
		# Wednesday, February 8, 2023, 8:18 PM or 星期三,
		# 2023年2月8日 20:18 or miércoles, 8 febrero 2023, 20:28
		$data->{'monthfull'} = DateTime->from_epoch(
			locale => $locale_name_loaded, epoch => $secs,
			time_zone => $tz)->strftime("%B");
		foreach (split(/\s+/, DateTime->from_epoch(
				locale => $locale_name_loaded, epoch => $secs,
				time_zone => $tz)->strftime("%A, %c"))) {
			if ($data->{'monthfull'} =~ /^$_/) {
				$data->{'complete'} .= "$data->{'monthfull'} "
				}
			else {
				$data->{'complete'} .= "$_ "
				}
			};
		$data->{'year'} = DateTime->from_epoch(
			locale => $locale_name_loaded, epoch => $secs,
			time_zone => $tz)->strftime("%Y");
		$data->{'day'} = DateTime->from_epoch(
			locale => $locale_name_loaded, epoch => $secs,
			time_zone => $tz)->strftime("%d");
		$data->{'week'} = DateTime->from_epoch(
			locale => $locale_name_loaded, epoch => $secs,
			time_zone => $tz)->strftime("%a");
		$data->{'weekfull'} = DateTime->from_epoch(
			locale => $locale_name_loaded, epoch => $secs,
			time_zone => $tz)->strftime("%A");
		$data->{'month'} = DateTime->from_epoch(
			locale => $locale_name_loaded, epoch => $secs,
			time_zone => $tz)->strftime("%b");
		$data->{'complete'} =~ s/(\d+):(\d+):(\d+)(.*?)/$1:$2$4/;
		($data->{'complete_short'} = $data->{'complete'}) =~
			s/(.*?)([\s\,]*\Q$data->{'year'}\E.*)/$1/;

if ($opts->{'get'}) {
			return $data->{$opts->{'get'}};
			}
		return $data;
		}

# Support old style to force date format
	my $timeshort = length($fmt) == 3 ? 1 : 0;
	if ($fmt) {
		my $date = $fmt;
		my @date;
		$date[$-[1]] = '%m'
		    if ($date =~ /(m|M)/);
		$date[$-[1]] = '%d'
		    if ($date =~ /(d|D)/);
		if ($date =~ /(yyyy)/i ||
		   ($date =~ /(y|Y)/ && $timeshort)) {
		    $date[$-[1]] = '%Y'
		    }
		elsif ($date =~ /(y|Y)/) {
		    $date[$-[1]] = '%y'
		    }
		@date = grep { /\%/ } @date;
		$locale_format_short = join($locale_format_delimiter, @date);
		}
	my $date_format_short = DateTime->from_epoch(locale => $locale_name_loaded, epoch => $secs, time_zone => $tz)->strftime($locale_format_short);
	if (!ref($only) && $only) {
		return &theme_ui_make_date($date_format_short, $secs)
			if (defined(&theme_ui_make_date));
		return $date_format_short;
		}
	else {
		my $date_format_time = DateTime->from_epoch(locale => $locale_name_loaded, epoch => $secs, time_zone => $tz)->strftime($locale_format_time);
		$date_format_time = $date_format_time;
		$date_format_time =~ s/(\d+):(\d+):(\d+)(.*?)/$1:$2$4/;
		my $date_format_full = "$date_format_short $date_format_time";
		return &theme_ui_make_date($date_format_full, $secs)
			if (defined(&theme_ui_make_date));
		return $date_format_full;
		}
	}

# Fall back to built-in formatting
my @tm = localtime($secs);
my $date;
if (!$fmt) {
	$fmt = $gconfig{'dateformat_'.$remote_user} || $gconfig{'dateformat'} || 'dd/mon/yyyy';
	}
if ($fmt eq 'dd/mon/yyyy') {
	$date = sprintf "%2.2d/%s/%4.4d",
			$tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900;
	}
elsif ($fmt eq 'dd/mm/yyyy') {
	$date = sprintf "%2.2d/%2.2d/%4.4d", $tm[3], $tm[4]+1, $tm[5]+1900;
	}
elsif ($fmt eq 'mm/dd/yyyy') {
	$date = sprintf "%2.2d/%2.2d/%4.4d", $tm[4]+1, $tm[3], $tm[5]+1900;
	}
elsif ($fmt eq 'yyyy/mm/dd') {
	$date = sprintf "%4.4d/%2.2d/%2.2d", $tm[5]+1900, $tm[4]+1, $tm[3];
	}
elsif ($fmt eq 'd. mon yyyy') {
	$date = sprintf "%d. %s %4.4d",
			$tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900;
	}
elsif ($fmt eq 'dd.mm.yyyy') {
	$date = sprintf "%2.2d.%2.2d.%4.4d", $tm[3], $tm[4]+1, $tm[5]+1900;
	}
elsif ($fmt eq 'yyyy-mm-dd') {
	$date = sprintf "%4.4d-%2.2d-%2.2d", $tm[5]+1900, $tm[4]+1, $tm[3];
	}
if (ref($only) || !$only) {
	$date .= sprintf " %2.2d:%2.2d", $tm[2], $tm[1];
	}
return $date;
}

# make_date_relative(timestamp)
# Return localized relative time from now or to the future
# for a given timestamp, or undef if not a valid timestamp
sub make_date_relative
{
my $ts = shift;
return undef unless(defined($ts) && $ts =~ /^-?\d+(?:\.\d+)?$/);
$ts = 0 + $ts;
my $last_login;
my $now = time();
my $diff = $ts - $now; # >0 future, <0 past
my $abs = abs($diff);
return $text{'time_now'} if ($abs < 10); # within ±10 seconds is now
my @units = (
    [ 31536000, 'year',  'years'  ],
    [ 2592000,  'month', 'months' ],
    [ 604800,   'week',  'weeks'  ],
    [ 86400,    'day',   'days'   ],
    [ 3600,     'hour',  'hours'  ],
    [ 60,       'min',   'mins'   ],
    [ 1,        'sec',   'secs'   ],
);
my ($val, $sing, $plur);
foreach my $unit (@units) {
	my ($secs, $s, $p) = @$unit;
	next if ($abs < $secs);
	$val = int($abs / $secs);
	($sing, $plur) = ($s, $p);
	last;
	}
if (defined($val) && $val > 0) {
	my $key = ($diff > 0 ? 'time_in_' : 'time_ago_').
		  ($val == 1 ? $sing : $plur);
	$last_login = &text($key, $val);
	}
else {
	$last_login = $text{'time_now'};
	}
return $last_login;
}

=head2 file_chooser_button(input, type, [form], [chroot], [addmode])

Return HTML for a button that pops up a file chooser when clicked, and places
the selected filename into another HTML field. The parameters are :

=item input - Name of the form field to store the filename in.

=item type - 0 for file or directory chooser, or 1 for directory only.

=item form - Index of the form containing the button.

=item chroot - If set to 1, the chooser will be limited to this directory.

=item addmode - If set to 1, the selected filename will be appended to the text box instead of replacing it's contents.

=cut
sub file_chooser_button
{
return &theme_file_chooser_button(@_)
	if (defined(&theme_file_chooser_button));
my $form = defined($_[2]) ? $_[2] : 0;
my $chroot = defined($_[3]) ? $_[3] : "/";
my $add = int($_[4]);
my ($w, $h) = (400, 300);
if ($gconfig{'db_sizefile'}) {
	($w, $h) = split(/x/, $gconfig{'db_sizefile'});
	}
return "<input type=button onClick='ifield = form.$_[0]; chooser = window.open(\"@{[&get_webprefix()]}/chooser.cgi?add=$add&type=$_[1]&chroot=$chroot&file=\"+encodeURIComponent(ifield.value), \"chooser\", \"toolbar=no,menubar=no,scrollbars=no,resizable=yes,width=$w,height=$h\"); chooser.ifield = ifield; window.ifield = ifield' value=\"...\">\n";
}

=head2 popup_window_button(url, width, height, scrollbars?, &field-mappings)

Returns HTML for a button that will popup a chooser window of some kind. The
parameters are :

=item url - Base URL of the popup window's contents

=item width - Width of the window in pixels

=item height - Height in pixels

=item scrollbars - Set to 1 if the window should have scrollbars

=item fields - See below

=item disabled - The button is disabled if non-zero

The field-mappings parameter is an array ref of array refs containing

=item - Attribute to assign field to in the popup window

=item - Form field name

=item - CGI parameter to URL for value, if any

=cut
sub popup_window_button
{
return &theme_popup_window_button(@_) if (defined(&theme_popup_window_button));
my ($url, $w, $h, $scroll, $fields, $disabled) = @_;
my $scrollyn = $scroll ? "yes" : "no";
my $rv = "<input type=button onClick='";
foreach my $m (@$fields) {
	$rv .= "$m->[0] = form.$m->[1]; ";
	}
my $sep = $url =~ /\?/ ? "&" : "?";
$rv .= "chooser = window.open(\"$url\"";
foreach my $m (@$fields) {
	if ($m->[2]) {
		$rv .= "+\"$sep$m->[2]=\"+escape($m->[0].value)";
		$sep = "&";
		}
	}
$rv .= ", \"chooser\", \"toolbar=no,menubar=no,scrollbars=$scrollyn,resizable=yes,width=$w,height=$h\"); ";
foreach my $m (@$fields) {
	$rv .= "chooser.$m->[0] = $m->[0]; ";
	$rv .= "window.$m->[0] = $m->[0]; ";
	}
$rv .= "' value=\"...\"";
if ($disabled) {
	$rv .= " disabled";
	}
$rv .= ">";
return $rv;
}

=head2 popup_window_link(url, title, width, height, scrollbar, &field-mappings)

Returns HTML for a link that will popup a chooser window of some kind. The
parameters are :

=item url - Base URL of the popup window's contents

=item title - Text of the link

=item width - Width of the window in pixels

=item height - Height in pixels

=item scrollbars - Set to 1 if the window should have scrollbars

=item fields - See below

The field-mappings parameter is an array ref of array refs containing

=item - Attribute to assign field to in the popup window

=item - Form field name

=item - CGI parameter to URL for value, if any

=cut
sub popup_window_link
{
return &theme_popup_window_link(@_) if (defined(&theme_popup_window_link));
my ($url, $title, $w, $h, $scrollyn, $fields) = @_;
my $scrollyn = $scroll ? "yes" : "no";
my $rv = "onClick='";
foreach my $m (@$fields) {
	$rv .= "$m->[0] = form.$m->[1]; ";
	}
my $sep = $url =~ /\?/ ? "&" : "?";
$rv .= "chooser = window.open(\"$url\"";
foreach my $m (@$fields) {
	if ($m->[2]) {
		$rv .= "+\"$sep$m->[2]=\"+escape($m->[0].value)";
		$sep = "&";
		}
	}
$rv .= ", \"chooser\", \"toolbar=no,menubar=no,scrollbars=$scrollyn,resizable=yes,width=$w,height=$h\"); ";
foreach my $m (@$fields) {
	$rv .= "chooser.$m->[0] = $m->[0]; ";
	$rv .= "window.$m->[0] = $m->[0]; ";
	}
$rv .= "return false;'";
return &ui_link($url, $title, undef, $rv);
}

=head2 read_acl(&user-module-hash, &user-list-hash, [&only-users])

Reads the Webmin acl file into the given hash references. The first is indexed
by a combined key of username,module , with the value being set to 1 when
the user has access to that module. The second is indexed by username, with
the value being an array ref of allowed modules.

This function is deprecated in favour of foreign_available, which performs a
more comprehensive check of module availability.

If the only-users array ref parameter is given, the results may be limited to
users in that list of names.

=cut
sub read_acl
{
my ($usermod, $userlist, $only) = @_;
if (!%main::acl_hash_cache) {
	# Read from local files
	local $_;
	open(ACL, "<".&acl_filename());
	while(<ACL>) {
		if (/^([^:]+):\s*(.*)/) {
			my $user = $1;
			my @mods = split(/\s+/, $2);
			foreach my $m (@mods) {
				$main::acl_hash_cache{$user,$m}++;
				}
			$main::acl_array_cache{$user} = \@mods;
			}
		}
	close(ACL);
	}
%$usermod = %main::acl_hash_cache if ($usermod);
%$userlist = %main::acl_array_cache if ($userlist);

# Read from user DB
my $userdb = &get_userdb_string();
my ($dbh, $proto, $prefix, $args) =
	$userdb ? &connect_userdb($userdb) : ( );
if (ref($dbh)) {
	if ($proto eq "mysql" || $proto eq "postgresql") {
		# Select usernames and modules from SQL DB
		my $cmd = $dbh->prepare(
			"select webmin_user.name,webmin_user_attr.value ".
			"from webmin_user,webmin_user_attr ".
			"where webmin_user.id = webmin_user_attr.id ".
			"and webmin_user_attr.attr = 'modules' ".
			($only ? " and webmin_user.name in (".
				 join(",", map { "'$_'" } @$only).")" : ""));
		if ($cmd && $cmd->execute()) {
			while(my ($user, $mods) = $cmd->fetchrow()) {
				my @mods = split(/\s+/, $mods);
				foreach my $m (@mods) {
					$usermod->{$user,$m}++ if ($usermod);
					}
				$userlist->{$user} = \@mods if ($userlist);
				}
			}
		$cmd->finish() if ($cmd);
		}
	elsif ($proto eq "ldap") {
		# Find users in LDAP
		my $filter = '(objectClass='.$args->{'userclass'}.')';
		if ($only) {
			my $ufilter =
				"(|".join("", map { "(cn=$_)" } @$only).")";
			$filter = "(&".$filter.$ufilter.")";
			}
		my $rv = $dbh->search(
			base => $prefix,
			filter => $filter,
			scope => 'sub',
			attrs => [ 'cn', 'webminModule' ]);
		if ($rv && !$rv->code) {
			foreach my $u ($rv->all_entries) {
				my $user = $u->get_value('cn');
				my @mods =$u->get_value('webminModule');
				foreach my $m (@mods) {
					$usermod->{$user,$m}++ if ($usermod);
					}
				$userlist->{$user} = \@mods if ($userlist);
				}
			}
		}
	&disconnect_userdb($userdb, $dbh);
	}
}

=head2 acl_filename

Returns the file containing the webmin ACL, which is usually
/etc/webmin/webmin.acl.

=cut
sub acl_filename
{
return "$config_directory/webmin.acl";
}

=head2 acl_check

Does nothing, but kept around for compatibility.

=cut
sub acl_check
{
}

=head2 get_miniserv_config_file

Returns the full path to the Miniserv config file.

=cut
sub get_miniserv_config_file
{
return $ENV{'MINISERV_CONFIG'} || "$config_directory/miniserv.conf";
}

=head2 get_miniserv_config(&hash)

Reads the Webmin webserver's (miniserv.pl) configuration file, usually located
at /etc/webmin/miniserv.conf, and stores its names and values in the given
hash reference.

=cut
sub get_miniserv_config
{
return &read_file_cached_with_stat(&get_miniserv_config_file(), $_[0]);
}

=head2 put_miniserv_config(&hash)

Writes out the Webmin webserver configuration file from the contents of
the given hash ref. This should be initially populated by get_miniserv_config,
like so :

get_miniserv_config(\%miniserv);
 $miniserv{'port'} = 10005;
 put_miniserv_config(\%miniserv);
 restart_miniserv();

=cut
sub put_miniserv_config
{
&write_file(&get_miniserv_config_file(), $_[0]);
}

=head2 restart_miniserv([nowait], [ignore-errors])

Kill the old miniserv process and re-start it, then optionally waits for
it to restart. This will apply all configuration settings.

=cut
sub restart_miniserv
{
return undef if (&is_readonly_mode());
my ($nowait, $ignore) = @_;
my %miniserv;
&get_miniserv_config(\%miniserv) || return;
if ($main::webmin_script_type eq 'web' && !$ENV{"MINISERV_CONFIG"} &&
    !$ENV{'MINISERV_PID'}) {
	# Running under some web server other than miniserv, so do nothing
	return;
	}

my $i;
my $flag = $miniserv{'restartflag'} || $var_directory."/restart-flag";
if ($gconfig{'os_type'} ne 'windows') {
	# On Unix systems, we can restart with a signal
	my ($pid, $addr, $i);
	$miniserv{'inetd'} && return;
	my @oldst = stat($miniserv{'pidfile'});
	$pid = $ENV{'MINISERV_PID'};
	if (!$pid || !kill(0, $pid)) {
		if (!open(PID, "<".$miniserv{'pidfile'})) {
			print STDERR "PID file $miniserv{'pidfile'} does ",
				     "not exist\n" if (!$ignore);
			return;
			}
		chop($pid = <PID>);
		close(PID);
		if (!$pid) {
			print STDERR "Invalid PID file $miniserv{'pidfile'}\n"
				if (!$ignore);
			return;
			}
		if (!kill(0, $pid)) {
			print STDERR "PID $pid from file $miniserv{'pidfile'} ",
			             "is not valid\n" if (!$ignore);
			return;
			}
		}

# Just signal miniserv to restart, and also create the flag file in
	# case signals aren't being processed
	if (!&kill_logged('HUP', $pid)) {
		&error("Incorrect Webmin PID $pid") if (!$ignore);
		}
	open(TOUCH, ">$flag");
	close(TOUCH);

# Wait till new PID is written, indicating a restart
	for($i=0; $i<60; $i++) {
		sleep(1);
		my @newst = stat($miniserv{'pidfile'});
		last if ($newst[9] != $oldst[9]);
		}
	$i < 60 || $ignore || &error("Webmin server did not write new PID file");

## Totally kill the process and re-run it
	#$SIG{'TERM'} = 'IGNORE';
	#&kill_logged('TERM', $pid);
	#&system_logged("$config_directory/start >/dev/null 2>&1 </dev/null");
	}
else {
	# On Windows, we need to use the flag file
	open(TOUCH, ">$flag");
	close(TOUCH);
	}

if (!$nowait) {
	# Wait for miniserv to come back up
	my $addr = $miniserv{'bind'} || "127.0.0.1";
	my $ok = 0;
	for($i=0; $i<20; $i++) {
		my $err;
		sleep(1);
		&open_socket($addr, $miniserv{'port'}, STEST, \$err);
		close(STEST);
		last if (!$err && ++$ok >= 2);
		}
	$i < 20 || $ignore || &error("Failed to restart Webmin server!");
	}
}

=head2 reload_miniserv([ignore-errors])

Sends a USR1 signal to the miniserv process, telling it to read-read it's
configuration files. Not all changes will be applied though, such as the
IP addresses and ports to accept connections on.

=cut
sub reload_miniserv
{
return undef if (&is_readonly_mode());
my ($ignore) = @_;
my %miniserv;
&get_miniserv_config(\%miniserv) || return;
if ($main::webmin_script_type eq 'web' && !$ENV{"MINISERV_CONFIG"} &&
    !$ENV{'MINISERV_PID'}) {
	# Running under some web server other than miniserv, so do nothing
	return;
	}

if ($gconfig{'os_type'} ne 'windows') {
	# Send a USR1 signal to re-read the config
	my ($pid, $addr, $i);
	$miniserv{'inetd'} && return;
	$pid = $ENV{'MINISERV_PID'};
	if (!$pid || !kill(0, $pid)) {
		if (!open(PID, "<".$miniserv{'pidfile'})) {
			print STDERR "PID file $miniserv{'pidfile'} does ",
				     "not exist\n" if (!$ignore);
			return;
			}
		chop($pid = <PID>);
		close(PID);
		if (!$pid) {
			print STDERR "Invalid PID file $miniserv{'pidfile'}\n"
				if (!$ignore);
			return;
			}
		if (!kill(0, $pid)) {
			print STDERR "PID $pid from file $miniserv{'pidfile'} ",
			             "is not valid\n" if (!$ignore);
			return;
			}
		}
	if (!&kill_logged('USR1', $pid)) {
		&error("Incorrect Webmin PID $pid") if (!$ignore);
		}

# Make sure this didn't kill Webmin!
	sleep(1);
	if (!kill(0, $pid)) {
		print STDERR "USR1 signal killed Webmin - restarting\n"
			if (!$ignore);
		&system_logged("$config_directory/start >/dev/null 2>&1 </dev/null");
		}
	}
else {
	# On Windows, we need to use the flag file
	open(TOUCH, ">$miniserv{'reloadflag'}");
	close(TOUCH);
	}
}

=head2 check_os_support(&minfo, [os-type, os-version], [api-only])

Returns 1 if some module is supported on the current operating system, or the
OS supplies as parameters. The parameters are :

=item minfo - A hash ref of module information, as returned by get_module_info

=item os-type - The Webmin OS code to use instead of the system's real OS, such as redhat-linux

=item os-version - The Webmin OS version to use, such as 13.0

=item api-only - If set to 1, considers a module supported if it provides an API to other modules on this OS, even if the majority of its functionality is not supported.

=cut
sub check_os_support
{
my $oss = $_[0]->{'os_support'};
if ($_[3] && $oss && $_[0]->{'api_os_support'}) {
	# May provide usable API
	$oss .= " ".$_[0]->{'api_os_support'};
	}
if ($_[0]->{'nozone'} && &running_in_zone()) {
	# Not supported in a Solaris Zone
	return 0;
	}
if ($_[0]->{'novserver'} && &running_in_vserver()) {
	# Not supported in a Linux Vserver
	return 0;
	}
if ($_[0]->{'noopenvz'} && &running_in_openvz()) {
	# Not supported in an OpenVZ container
	return 0;
	}
return 1 if (!$oss || $oss eq '*');
my $osver = $_[2] || $gconfig{'os_version'};
my $ostype = $_[1] || $gconfig{'os_type'};
my $anyneg = 0;
while(1) {
	my ($os, $ver, $codes);
	my ($neg) = ($oss =~ s/^!//);	# starts with !
	$anyneg++ if ($neg);
	if ($oss =~ /^([^\/\s]+)\/([^\{\s]+)\{([^\}]*)\}\s*(.*)$/) {
		# OS/version{code}
		$os = $1; $ver = $2; $codes = $3; $oss = $4;
		}
	elsif ($oss =~ /^([^\/\s]+)\/([^\/\s]+)\s*(.*)$/) {
		# OS/version
		$os = $1; $ver = $2; $oss = $3;
		}
	elsif ($oss =~ /^([^\{\s]+)\{([^\}]*)\}\s*(.*)$/) {
		# OS/{code}
		$os = $1; $codes = $2; $oss = $3;
		}
	elsif ($oss =~ /^\{([^\}]*)\}\s*(.*)$/) {
		# {code}
		$codes = $1; $oss = $2;
		}
	elsif ($oss =~ /^(\S+)\s*(.*)$/) {
		# OS
		$os = $1; $oss = $2;
		}
	else { last; }
	next if ($os && !($os eq $ostype ||
			  $ostype =~ /^(\S+)-(\S+)$/ && $os eq "*-$2"));
	if ($ver =~ /^([0-9\.]+)\-([0-9\.]+)$/) {
		next if ($osver < $1 || $osver > $2);
		}
	elsif ($ver =~ /^([0-9\.]+)\-\*$/) {
		next if ($osver < $1);
		}
	elsif ($ver =~ /^\*\-([0-9\.]+)$/) {
		next if ($osver > $1);
		}
	elsif ($ver) {
		next if ($ver ne $osver);
		}
	next if ($codes && !eval $codes);
	return !$neg;
	}
return $anyneg;
}

=head2 http_download(host, port, page, destfile, [&error], [&callback], [sslmode], [user], [pass], [timeout], [osdn-convert], [no-cache], [&headers], [&response-headers])

Downloads data from a HTTP url to a local file or string. The parameters are :

=item host - The hostname part of the URL, such as www.google.com

=item port - The HTTP port number, such as 80

=item page - The filename part of the URL, like /index.html

=item destfile - The local file to save the URL data to, like /tmp/index.html. This can also be a scalar reference, in which case the data will be appended to that scalar.

=item error - If set to a scalar ref, the function will store any error message in this scalar and return 0 on failure, or 1 on success. If not set, it will simply call the error function if the download fails.

=item callback - If set to a function ref, it will be called after each block of data is received. This is typically set to \&progress_callback, for printing download progress.

=item sslmode - If set to 1, an HTTPS connection is used instead of HTTP.

=item user - If set, HTTP authentication is done with this username.

=item pass - The HTTP password to use with the username above.

=item timeout - A timeout in seconds to wait for the TCP connection to be established before failing.

=item osdn-convert - If set to 1, URL for downloads from sourceforge are converted to use an appropriate mirror site.

=item no-cache - If set to 1, Webmin's internal caching for this URL is disabled.

=item headers - If set to a hash ref of additional HTTP headers, they will be added to the request.

=item response_headers - If set returns a hash ref of response HTTP headers.

If the callback function is defined, it will be called at each step of the download process with a mode parameter and
additional args. The mode will be one of :

=item 1 - Completed reading headers, arg is 1 for a redirect, 0 otherwise

=item 2 - Received content length, arg is the response size in bytes

=item 3 - Received data, arg is the bytes returned so far

=item 4 - Finished receiving data

=item 5 - Following a redirect, arg is the new URL

=item 6 - Data was found in cache, arg is the full cached URL

=item 7 - TCP connection made, arg is the remote IP (if known)

=cut
sub http_download
{
my ($host, $port, $page, $dest, $error, $cbfunc, $ssl, $user, $pass,
    $timeout, $osdn, $nocache, $headers, $response_headers) = @_;
if ($gconfig{'debug_what_net'}) {
	&webmin_debug_log('HTTP', "host=$host port=$port page=$page ssl=$ssl".
				  ($user ? " user=$user pass=$pass" : "").
				  (ref($dest) ? "" : " dest=$dest"));
	}
if ($osdn) {
	# Convert OSDN URL first
	my $prot = $ssl ? "https://" : "http://";
	my $portstr = $ssl && $port == 443 ||
			 !$ssl && $port == 80 ? "" : ":$port";
	($host, $port, $page, $ssl) = &parse_http_url(
		&convert_osdn_url($prot.$host.$portstr.$page));
	}

# Check if we already have cached the URL
my $url = ($ssl ? "https://" : "http://").$host.":".$port.$page;
my $cfile = &check_in_http_cache($url);
if ($cfile && !$nocache) {
	# Yes! Copy to dest file or variable
	&$cbfunc(6, $url) if ($cbfunc);
	if (ref($dest)) {
		&open_readfile(CACHEFILE, $cfile);
		local $/ = undef;
		$$dest = <CACHEFILE>;
		close(CACHEFILE);
		}
	else {
		&copy_source_dest($cfile, $dest);
		}
	return;
	}

# Build headers
my @headers;
push(@headers, [ "Host", $host ]);
push(@headers, [ "User-agent", "Webmin" ]);
push(@headers, [ "Accept-language", "en" ]);
if ($user) {
	my $auth = &encode_base64("$user:$pass");
	$auth =~ tr/\r\n//d;
	push(@headers, [ "Authorization", "Basic $auth" ]);
	}
foreach my $hname (keys %$headers) {
	my $hv = $headers->{$hname};
	$hv = [ $hv ] if (!ref($hv));
	foreach my $v (@$hv) {
		push(@headers, [ $hname, $v ]);
		}
	}

# Actually download it
$main::download_timed_out = undef;
local $SIG{ALRM} = \&download_timeout;
$timeout = 60 if (!defined($timeout));
alarm($timeout) if ($timeout);
my $h = &make_http_connection($host, $port, $ssl, "GET", $page, \@headers);
alarm(0) if ($timeout);
$h = $main::download_timed_out if ($main::download_timed_out);
if (!ref($h)) {
	$h ||= "Unknown error";
	if ($error) { $$error = $h; return; }
	else { &error(&html_escape($h)); }
	}
&$cbfunc(7, $h->{'ip'}) if ($cbfunc);
&complete_http_download($h, $dest, $error, $cbfunc, $osdn, $host, $port,
			$headers, $ssl, $nocache, $timeout, $response_headers);
if ((!$error || !$$error) && !$nocache) {
	&write_to_http_cache($url, $dest);
	}
}

=head2 complete_http_download(handle, destfile, [&error], [&callback], [osdn],
			      [oldhost], [oldport], [&send-headers], [old-ssl],
			      [no-cache], [timeout], [response-header])

Do a HTTP download, after the headers have been sent. For internal use only,
typically called by http_download.

=cut
sub complete_http_download
{
my ($h, $destfile, $error, $cbfunc, $osdn, $oldhost, $oldport, $headers,
    $oldssl, $nocache, $timeout, $response_headers) = @_;

# Kept local so that callback funcs # can access them.
local ($line, %header, @headers, $s);

# read headers
$timeout = 60 if (!defined($timeout));
alarm($timeout) if ($timeout);
($line = &read_http_connection($h)) =~ tr/\r\n//d;
if ($line !~ /^HTTP\/1\..\s+(20[0-9]|30[0-9]|400)(\s+|$)/) {
	$line ||= "Failed to read HTTP response line";
	alarm(0) if ($timeout);
	&close_http_connection($h);
	if ($error) { ${$error} = $line; return; }
	else { &error("Download failed : ".&html_escape($line)); }
	}
my $rcode = $1;
&$cbfunc(1, $rcode >= 300 && $rcode < 400 ? 1 : 0)
	if ($cbfunc);
while(1) {
	$line = &read_http_connection($h);
	$line =~ tr/\r\n//d;
	$line =~ /^(\S+):\s*(.*)$/ || last;
	$header{lc($1)} = $2;
	push(@headers, [ lc($1), $2 ]);
	}
$$response_headers = \%header
	if (defined($response_headers));
alarm(0) if ($timeout);
if ($main::download_timed_out) {
	&close_http_connection($h);
	if ($error) { ${$error} = $main::download_timed_out; return 0; }
	else { &error($main::download_timed_out); }
	}
&$cbfunc(2, $header{'content-length'}) if ($cbfunc);
if ($rcode >= 300 && $rcode < 400) {
	# follow the redirect
	&$cbfunc(5, $header{'location'}) if ($cbfunc);
	my ($host, $port, $page, $ssl);
	if ($header{'location'} =~ /^(http|https):\/\/([^:]+):(\d+)(\/.*)?$/) {
		$ssl = $1 eq 'https' ? 1 : 0;
		$host = $2;
		$port = $3;
		$page = $4 || "/";
		}
	elsif ($header{'location'} =~ /^(http|https):\/\/([^:\/]+)(\/.*)?$/) {
		$ssl = $1 eq 'https' ? 1 : 0;
		$host = $2;
		$port = $ssl ? 443 : 80;
		$page = $3 || "/";
		}
	elsif ($header{'location'} =~ /^\// && $oldhost) {
		# Relative to same server
		$host = $oldhost;
		$port = $oldport;
		$ssl = $oldssl;
		$page = $header{'location'};
		}
	elsif ($header{'location'}) {
		# Assume relative to same dir .. not handled
		&close_http_connection($h);
		if ($error) { ${$error} = "Invalid Location header $header{'location'}"; return; }
		else { &error("Invalid Location header ".
			      &html_escape($header{'location'})); }
		}
	else {
		&close_http_connection($h);
		if ($error) { ${$error} = "Missing Location header"; return; }
		else { &error("Missing Location header"); }
		}
	my $params;
	($page, $params) = split(/\?/, $page);
	$page =~ s/ /%20/g;
	$page .= "?".$params if (defined($params));
	&http_download($host, $port, $page, $destfile, $error, $cbfunc, $ssl,
		       undef, undef, undef, $osdn, $nocache, $headers);
	}
else {
	# read data
	if (ref($destfile)) {
		# Append to a variable
		while(defined($buf = &read_http_connection($h, 1024))) {
			${$destfile} .= $buf;
			&$cbfunc(3, length(${$destfile})) if ($cbfunc);
			}
		}
	else {
		# Write to a file
		my $got = 0;
		if (!&open_tempfile(PFILE, ">$destfile", 1)) {
			&close_http_connection($h);
			if ($error) { ${$error} = "Failed to write to $destfile : $!"; return; }
			else { &error("Failed to write to ".&html_escape($destfile)." : ".&html_escape("$!")); }
			}
		binmode(PFILE);		# For windows
		while(defined($buf = &read_http_connection($h, 1024))) {
			&print_tempfile(PFILE, $buf);
			$got += length($buf);
			&$cbfunc(3, $got) if ($cbfunc);
			}
		&close_tempfile(PFILE);
		if ($header{'content-length'} &&
		    $got != $header{'content-length'}) {
			&close_http_connection($h);
			if ($error) { ${$error} = "Download incomplete"; return; }
			else { &error("Download incomplete"); }
			}
		}
	&$cbfunc(4) if ($cbfunc);
	}
&close_http_connection($h);
}

=head2 http_post(host, port, page, content, destfile, [&error], [&callback], [sslmode],
		 [user, pass], [timeout], [osdn-convert], [no-cache], [&headers],
		 [&response_headers])

Posts data to an HTTP url and downloads the response to a local file or string. The parameters are :

=item host - The hostname part of the URL, such as www.google.com

=item port - The HTTP port number, such as 80

=item page - The filename part of the URL, like /index.html

=item content - The data to post