Skip to content
Permalink
master
Switch branches/tags
Go to file
 
 
Cannot retrieve contributors at this time
executable file 11770 lines (10340 sloc) 313 KB
=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;
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 $webmin_feedback_address
$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
{
local $_;
my $split = defined($_[4]) ? $_[4] : "=";
my $realfile = &translate_filename($_[0]);
&open_readfile(ARFILE, $_[0]) || return 0;
while(<ARFILE>) {
s/\r|\n//g;
my $hash = index($_, "#");
my $eq = index($_, $split);
if ($hash != 0 && $eq >= 0) {
my $n = substr($_, 0, $eq);
my $v = substr($_, $eq+1);
chomp($v);
$_[1]->{$_[3] ? lc($n) : $n} = $v;
push(@{$_[2]}, $n) if ($_[2]);
}
}
close(ARFILE);
$main::read_file_missing{$realfile} = 0; # It exists now
if (defined($main::read_file_cache{$realfile})) {
%{$main::read_file_cache{$realfile}} = %{$_[1]};
}
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});
}
my $rv = &read_file_cached(@_);
$main::read_file_cache_time{$realfile} = $st[9];
return $rv;
}
=head2 write_file(file, &data-hash, [join-char], [sort], [sorted-by], [sorted-by-preserved])
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-char - If given, names and values are separated by this instead of =
=item sort - If given, passed hash reference will be sorted by its keys
=item sorted-by - If given, hash reference that is being saved will be sorted by the keys of sorted-by hashref
=item sorted-by-sectioning-preserved - If sorted-by is used, then preserve the sectioning (line-breaks), and section comment as in hash reference
=cut
sub write_file
{
my ($file,
$data_hash,
$join_char,
$sort,
$sorted_by,
$sorted_by_sectioning_preserved) = @_;
my (%old, @order);
my $join = defined($join_char) ? $join_char : "=";
my $realfile = &translate_filename($file);
&read_file($sorted_by || $file, \%old, \@order);
&open_tempfile(ARFILE, ">$file");
if ($sort || $gconfig{'sortconfigs'}) {
foreach $k (sort keys %{$data_hash}) {
(print ARFILE $k,$join,$data_hash->{$k},"\n") ||
&error(&text("efilewrite", $realfile, $!));
}
}
else {
my %done;
foreach $k (@order) {
if (exists($data_hash->{$k}) && !$done{$k}++) {
(print ARFILE $k,$join,$data_hash->{$k},"\n") ||
&error(&text("efilewrite", $realfile, $!));
}
}
foreach $k (keys %{$data_hash}) {
if (!exists($old{$k}) && !$done{$k}++) {
(print ARFILE $k,$join,$data_hash->{$k},"\n") ||
&error(&text("efilewrite", $realfile, $!));
}
}
}
&close_tempfile(ARFILE);
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;
}
if ($sorted_by && $sorted_by_sectioning_preserved) {
my $target = read_file_contents($file);
my $model = read_file_contents($sorted_by);
# Extract version related comments for a block, e.g. #1.962
my %comments = reverse ($model =~ m/(#\s*[\d\.]+)[\n\s]+(.*?)=/gm);
# Build blocks of line's key separated with a new line break
my @lines = (($model =~ m/(.*?)$join|(^\s*$)/gm), undef, undef);
my @blocks;
my @block;
for (my $line = 0; $line < scalar(@lines) - 1; $line += 2) {
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 =~ /(\Q$line\E)=(.*)/) {
foreach my $comment (keys %comments) {
if (grep(/^\Q$comment\E$/, @{$blocks[$block]})) {
$target =~ 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 =~ /(\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 =~ s/(\Q$line\E)$join(.*)/$1=$2\n/) {
last;
}
}
}
write_file_contents($file, $target);
}
}
=head2 html_escape(string)
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) = @_;
if (!defined $tmp) {
return ''; # empty string
};
$tmp =~ s/&/&amp;/g;
$tmp =~ s/</&lt;/g;
$tmp =~ s/>/&gt;/g;
$tmp =~ s/\"/&quot;/g;
$tmp =~ s/\'/&#39;/g;
$tmp =~ s/=/&#61;/g;
return $tmp;
}
=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 outputing 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_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()
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'} :
-d "c:/temp" ? "c:/temp" : "/tmp/.webmin";
my $tmp_dir;
if (-d $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 the /tmp/.webmin
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
my $tries = 0;
my $mkdirerr;
while($tries++ < 10) {
my @st = lstat($tmp_dir);
last if ($st[4] == $< && (-d _) && ($st[2] & 0777) == 0755);
if (@st) {
unlink($tmp_dir) || rmdir($tmp_dir) ||
system("/bin/rm -rf ".quotemeta($tmp_dir));
}
mkdir($tmp_dir, 0755) || (($mkdirerr = $!), next);
chown($<, $(, $tmp_dir);
chmod(0755, $tmp_dir);
}
if ($tries >= 10) {
my @st = lstat($tmp_dir);
$mkdirerr = $mkdirerr ? " : $mkdirerr" : "";
&error("Failed to create temp directory $tmp_dir$mkdirerr");
}
# If running as root, check parent dir (usually /tmp) to make sure it's
# world-writable and owned by root
my $tmp_parent = $tmp_dir;
$tmp_parent =~ s/\/[^\/]+$//;
if ($tmp_parent eq "/tmp") {
my @st = stat($tmp_parent);
if (($st[2] & 0555) != 0555) {
&error("Base temp directory $tmp_parent is not world readable and listable");
}
}
}
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 preppend
=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]);
my $c;
do {
$c = chop($str);
} while($c !~ /\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 @blocks = split(/:/, $_[0]);
return 0 if (@blocks == 0 || @blocks > 8);
# The address/netmask format is accepted. So we're looking for a "/" to isolate a possible netmask.
# After that, we delete the netmask to control the address only format, but we verify whether the netmask
# value is in [0;128].
my $ib = $#blocks;
my $where = index($blocks[$ib],"/");
my $m = 0;
if ($where != -1) {
my $b = substr($blocks[$ib],0,$where);
$m = substr($blocks[$ib],$where+1,length($blocks[$ib])-($where+1));
$blocks[$ib]=$b;
}
# The netmask must take its value in [0;128]
return 0 if ($m <0 || $m >128);
# 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 $b;
my $empty = 0;
foreach $b (@blocks) {
return 0 if ($b ne "" && $b !~ /^[0-9a-f]{1,4}$/i);
$empty++ if ($b eq "");
}
return 0 if ($empty > 1 && !($_[0] =~ /^::/ && $empty == 2));
return 1;
}
=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 ReadParseMime([maximum], [&cbfunc, &cbargs], [array-mode])
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.
=cut
sub ReadParseMime
{
my ($max, $cbfunc, $cbargs, $arrays) = @_;
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);
$boundary = $1;
$count_lines = 0;
$max_lines = 1000;
<STDIN>; # skip first boundary
while(1) {
$name = "";
# Read section headers
my $lastheader;
while(1) {
$line = <STDIN>;
$got += length($line);
&$cbfunc($got, $ENV{'CONTENT_LENGTH'}, @$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 ($line =~ /^\s+(.*)$/) {
$header{$lastheader} .= $line;
}
}
# Parse out filename and type
my $file;
if ($header{'content-disposition'} =~ /^form-data(.*)/) {
$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'} =~ /^([^\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 = "";
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);
return;
}
if (index($line, $boundary) != -1) { last; }
$data .= $line;
}
chop($data); chop($data);
if ($arrays == 1) {
$in{$name} ||= [];
push(@{$in{$name}}, $data);
}
elsif ($arrays == 2) {
$in{$name} ||= $data;
}
else {
$in{$name} .= "\0" if (defined($in{$name}));
$in{$name} .= $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'};
}
if (!-d $vardir) {
&make_dir($vardir, 0755);
}
# 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 ($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])
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) = @_;
$mt ||= "text/html";
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 (!$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";
$html_body =~ s/\s+\>/>/g;
print $html_body;
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";
print "<a href=\"@{[&get_webprefix()]}/$cprog?",
&get_module_name()."\">",
$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;
return if $main::ignore_errors;
my $msg = join("", @_);
$msg =~ s/<[^>]*>//g;
my $error_details = (($ENV{'WEBMIN_DEBUG'} || $gconfig{'debug_enabled'}) ? "" : "\n");
my $error_output_right = sub {
my ($err_msg) = @_;
return $main::webmin_script_type eq 'cmd' ? entities_to_ascii($err_msg) : $err_msg;
};
if (!$main::error_must_die) {
print STDERR "Error: ", &$error_output_right($msg), "\n";
}
&load_theme_library();
if ($main::error_must_die) {
die "@_$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(@_);
}
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
);
print_json(\%jerror);
}
else {
&header($text{'error'}, "");
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 : " : ""),
@_,"</h3>\n";
}
else {
my $error_what = ($main::whatfailed ? "$main::whatfailed: " : "");
my $error_html = join(",", @_);
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";
for($i=0; my @stack = caller($i); $i++) {
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 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, ...)
Register a function that will be called when this process exits, such as by
calling &error
=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], [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 - If set to 1, exclude the time from the returned string.
=item fmt - Optional, one of dd/mon/yyyy, dd/mm/yyyy, mm/dd/yyyy or yyyy/mm/dd
=cut
sub make_date
{
&load_theme_library();
if (defined(&theme_make_date) &&
!$main::theme_prevent_make_date &&
(($main::header_content_type eq "text/html" &&
$main::webmin_script_type eq "web") ||
$main::theme_allow_make_date)) {
return &theme_make_date(@_);
}
my ($secs, $only, $fmt) = @_;
my @tm = localtime($secs);
my $date;
if (!$fmt) {
$fmt = $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 (!$only) {
$date .= sprintf " %2.2d:%2.2d", $tm[2], $tm[1];
}
return $date;
}
=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(&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
{
my ($nowait, $ignore) = @_;
return undef if (&is_readonly_mode());
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 {