Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
executable file 10928 lines (9616 sloc) 291 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($user_risk_level $loaded_theme_library $wait_for_input
$done_webmin_header $trust_unknown_referers $unsafe_index_cgi
%done_foreign_require $webmin_feedback_address
$user_skill_level $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>) {
chomp;
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, &hash, [join-char])
Write out the contents of a hash as name=value lines. The parameters are :
=item file - Full path to write to
=item hash - A hash reference containing names and values to output
=item join-char - If given, names and values are separated by this instead of =
=cut
sub write_file
{
my (%old, @order);
my $join = defined($_[2]) ? $_[2] : "=";
my $realfile = &translate_filename($_[0]);
&read_file($_[0], \%old, \@order);
&open_tempfile(ARFILE, ">$_[0]");
foreach $k (@order) {
if (exists($_[1]->{$k})) {
(print ARFILE $k,$join,$_[1]->{$k},"\n") ||
&error(&text("efilewrite", $realfile, $!));
}
}
foreach $k (keys %{$_[1]}) {
if (!exists($old{$k})) {
(print ARFILE $k,$join,$_[1]->{$k},"\n") ||
&error(&text("efilewrite", $realfile, $!));
}
}
&close_tempfile(ARFILE);
if (defined($main::read_file_cache{$realfile})) {
%{$main::read_file_cache{$realfile}} = %{$_[1]};
}
if (defined($main::read_file_missing{$realfile})) {
$main::read_file_missing{$realfile} = 0;
}
}
=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 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;
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) || next;
chown($<, $(, $tmp_dir);
chmod(0755, $tmp_dir);
}
if ($tries >= 10) {
my @st = lstat($tmp_dir);
&error("Failed to create temp directory $tmp_dir");
}
# 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 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) = @_;
$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;
while(read($in, $buf, 32768) > 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(\"$gconfig{'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'}) {
print "Content-Security-Policy: script-src 'self' 'unsafe-inline' 'unsafe-eval'; frame-src 'self'; child-src 'self'\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='$gconfig{'webprefix'}/session_login.cgi?logout=1'>",
"$text{'main_logout'}</a><br>";
}
elsif ($gconfig{'gotoone'} && @avail == 1 && !$nolo) {
print "<a href=$gconfig{'webprefix'}/switch_user.cgi>",
"$text{'main_switch'}</a><br>";
}
elsif (!$gconfig{'gotoone'} || @avail > 1) {
print "<a href='$gconfig{'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=\"$gconfig{'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=\"$gconfig{'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 = "$gconfig{'webprefix'}$url" if ($url =~ /^\//);
if ($i == 0) {
print "<a href=\"$url\"><img alt=\"<-\" align='middle' border='0' src='$gconfig{'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_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'}) {
do $theme_root_directories[$i]."/".
$theme_configs[$i]->{'functions'};
}
}
}
=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 $port = $ENV{'SERVER_PORT'} == 443 && uc($ENV{'HTTPS'}) eq "ON" ? "" :
$ENV{'SERVER_PORT'} == 80 && uc($ENV{'HTTPS'}) ne "ON" ? "" :
":$ENV{'SERVER_PORT'}";
my $prot = uc($ENV{'HTTPS'}) eq "ON" ? "https" : "http";
my $wp = $gconfig{'webprefixnoredir'} ? undef : $gconfig{'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://$ENV{'SERVER_NAME'}$port$wp$_[0]";
}
}
elsif ($ENV{'SCRIPT_NAME'} =~ /^(.*)\/[^\/]*$/) {
# Relative URL (like foo.cgi)
if ($gconfig{'relative_redir'}) {
$url = "$wp$1/$_[0]";
}
else {
$url = "$prot://$ENV{'SERVER_NAME'}$port$wp$1/$_[0]";
}
}
else {
if ($gconfig{'relative_redir'}) {
$url = "$wp$_[0]";
}
else {
$url = "$prot://$ENV{'SERVER_NAME'}$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;
my $msg = join("", @_);
$msg =~ s/<[^>]*>//g;
if (!$main::error_must_die) {
print STDERR "Error: ",$msg,"\n";
}
&load_theme_library();
if ($main::error_must_die) {
die @_;
}
&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 : " : ""),
$msg,"\n";
print STDERR "-----\n";
if ($gconfig{'error_stack'}) {
# Show 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";
}
}
}
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'}, "");
print "<hr>\n";
print "<h3>",($main::whatfailed ? "$main::whatfailed : " : ""),
@_,"</h3>\n";
if ($gconfig{'error_stack'}) {
# Show call stack
print "<h3>$text{'error_stack'}</h3>\n";
print "<table>\n";
print "<tr> <td><b>$text{'error_file'}</b></td> ",
"<td><b>$text{'error_line'}</b></td> ",
"<td><b>$text{'error_sub'}</b></td> </tr>\n";
for($i=0; my @stack = caller($i); $i++) {
print "<tr>\n";
print "<td>$stack[1]</td>\n";
print "<td>$stack[2]</td>\n";
print "<td>$stack[3]</td>\n";
print "</tr>\n";
}
print "</table>\n";
}
print "<hr>\n";
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 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::header_content_type eq "text/html" &&
$main::webmin_script_type eq "web") {
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(\"$gconfig{'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(&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(
$ENV{'MINISERV_CONFIG'} || "$config_directory/miniserv.conf", $_[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($ENV{'MINISERV_CONFIG'} || "$config_directory/miniserv.conf",
$_[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;
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
if (!&kill_logged('HUP', $pid)) {
&error("Incorrect Webmin PID $pid") if (!$ignore);
}
# 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, ">$miniserv{'restartflag'}");
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
{
my ($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;
}
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])
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.
=cut
sub http_download
{
my ($host, $port, $page, $dest, $error, $cbfunc, $ssl, $user, $pass,
$timeout, $osdn, $nocache, $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) {
push(@headers, [ $hname, $headers->{$hname} ]);
}
# 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)) {
if ($error) { $$error = $h; return; }
else { &error(&html_escape($h)); }
}
&complete_http_download($h, $dest, $error, $cbfunc, $osdn, $host, $port,
$headers, $ssl, $nocache, $timeout);
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])
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) = @_;
local ($line, %header, @headers, $s); # Kept local so that callback funcs
# can access them.
# 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+(200|30[0-9]|400)(\s+|$)/) {
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 ]);
}
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'} =~ /^\// && $_[5]) {
# Relative to same server
$host = $_[5];
$port = $_[6];
$ssl = $_[8];
$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, $_[4], $_[9], $_[7]);
}
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])
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
=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.
=cut
sub http_post
{
my ($host, $port, $page, $content, $dest, $error, $cbfunc, $ssl, $user, $pass,
$timeout, $osdn, $nocache, $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));
}
# Build headers
my @headers;
push(@headers, [ "Host", $host ]);
push(@headers, [ "User-agent", "Webmin" ]);
push(@headers, [ "Accept-language", "en" ]);
push(@headers, [ "Content-type", "application/x-www-form-urlencoded" ]);
if (defined($content)) {
push(@headers, [ "Content-length", length($content) ]);
}
if ($user) {
my $auth = &encode_base64("$user:$pass");
$auth =~ tr/\r\n//d;
push(@headers, [ "Authorization", "Basic $auth" ]);
}
foreach my $hname (keys %$headers) {
push(@headers, [ $hname, $headers->{$hname} ]);
}
# 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, "POST", $page, \@headers);
alarm(0) if ($timeout);
$h = $main::download_timed_out if ($main::download_timed_out);
if (!ref($h)) {
if ($error) { $$error = $h; return; }
else { &error($h); }
}
&write_http_connection($h, $content."\r\n");
&complete_http_download($h, $dest, $error, $cbfunc, $osdn, $host, $port,
$headers, $ssl, $nocache);
}
=head2 ftp_download(host, file, destfile, [&error], [&callback], [user, pass], [port], [no-cache])
Download data from an FTP site to a local file. The parameters are :
=item host - FTP server hostname
=item file - File on the FTP server to download
=item destfile - File on the Webmin system to download data to
=item error - If set to a string ref, any error message is written into this string and the function returns 0 on failure, 1 on success. Otherwise, error is called on failure.
=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 user - Username to login to the FTP server as. If missing, Webmin will login as anonymous.
=item pass - Password for the username above.
=item port - FTP server port number, which defaults to 21 if not set.
=item no-cache - If set to 1, Webmin's internal caching for this URL is disabled.
=item timeout - Timeout for connections, defaults to 60s
=cut
sub ftp_download
{
my ($host, $file, $dest, $error, $cbfunc, $user, $pass, $port, $nocache, $timeout) = @_;
$port ||= 21;
$timeout = 60 if (!defined($timeout));
if ($gconfig{'debug_what_net'}) {
&webmin_debug_log('FTP', "host=$host port=$port file=$file".
($user ? " user=$user pass=$pass" : "").
(ref($dest) ? "" : " dest=$dest"));
}
my ($buf, @n);
if (&is_readonly_mode()) {
if ($error) {
$$error = "FTP connections not allowed in readonly mode";
return 0;
}
else {
&error("FTP connections not allowed in readonly mode");
}
}
# Check if we already have cached the URL
my $url = "ftp://".$host.$file;
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;
}
# Actually download it
$main::download_timed_out = undef;
local $SIG{ALRM} = \&download_timeout;
alarm($timeout) if ($timeout);
my $connected;
if ($gconfig{'ftp_proxy'} =~ /^http:\/\/(\S+):(\d+)/ && !&no_proxy($_[0])) {
# download through http-style proxy
my $error;
if (&open_socket($1, $2, "SOCK", \$error)) {
# Connected OK
if ($main::download_timed_out) {
alarm(0) if ($timeout);
if ($error) {
$$error = $main::download_timed_out;
return 0;
}
else {
&error($main::download_timed_out);
}
}
my $esc = $file; $esc =~ s/ /%20/g;
my $up = "${user}:${pass}\@" if ($user);
my $portstr = $port == 21 ? "" : ":$port";
print SOCK "GET ftp://${up}${host}${portstr}${esc} HTTP/1.0\r\n";
print SOCK "User-agent: Webmin\r\n";
if ($gconfig{'proxy_user'}) {
my $auth = &encode_base64(
"$gconfig{'proxy_user'}:$gconfig{'proxy_pass'}");
$auth =~ tr/\r\n//d;
print SOCK "Proxy-Authorization: Basic $auth\r\n";
}
print SOCK "\r\n";
&complete_http_download(
{ 'fh' => "SOCK" }, $dest, $error, $cbfunc,
undef, undef, undef, undef, 0, $nocache);
$connected = 1;
}
elsif (!$gconfig{'proxy_fallback'}) {
alarm(0) if ($timeout);
if ($error) {
$$error = $main::download_timed_out;
return 0;
}
else {
&error($main::download_timed_out);
}
}
}
if (!$connected) {
# connect to host and login with real FTP protocol
&open_socket($host, $port, "SOCK", $_[3]) || return 0;
alarm(0) if ($timeout);
if ($main::download_timed_out) {
if ($error) {
$$error = $main::download_timed_out;
return 0;
}
else {
&error($main::download_timed_out);
}
}
&ftp_command("", 2, $error) || return 0;
if ($user) {
# Login as supplied user
my @urv = &ftp_command("USER $user", [ 2, 3 ], $error);
@urv || return 0;
if (int($urv[1]/100) == 3) {
&ftp_command("PASS $pass", 2, $error) || return 0;
}
}
else {
# Login as anonymous
my @urv = &ftp_command("USER anonymous", [ 2, 3 ], $error);
@urv || return 0;
if (int($urv[1]/100) == 3) {
&ftp_command("PASS root\@".&get_system_hostname(), 2,
$error) || return 0;
}
}
&$cbfunc(1, 0) if ($cbfunc);
if ($file) {
# get the file size and tell the callback
&ftp_command("TYPE I", 2, $error) || return 0;
my $size = &ftp_command("SIZE $file", 2, $error);
defined($size) || return 0;
if ($cbfunc) {
&$cbfunc(2, int($size));
}
# are we using IPv6?
my $v6 = !&to_ipaddress($host) &&
&to_ip6address($host);
if ($v6) {
# request the file over a EPSV port
my $epsv = &ftp_command("EPSV", 2, $error);
defined($epsv) || return 0;
$epsv =~ /\|(\d+)\|/ || return 0;
my $epsvport = $1;
&open_socket($host, $epsvport, CON, $error) || return 0;
}
else {
# request the file over a PASV connection
my $pasv = &ftp_command("PASV", 2, $error);
defined($pasv) || return 0;
$pasv =~ /\(([0-9,]+)\)/ || return 0;
@n = split(/,/ , $1);
&open_socket("$n[0].$n[1].$n[2].$n[3]",
$n[4]*256 + $n[5], "CON", $_[3]) || return 0;
}
&ftp_command("RETR $file", 1, $error) || return 0;
# transfer data
my $got = 0;
&open_tempfile(PFILE, ">$dest", 1);
while(read(CON, $buf, 1024) > 0) {
&print_tempfile(PFILE, $buf);
$got += length($buf);
&$cbfunc(3, $got) if ($cbfunc);
}
&close_tempfile(PFILE);
close(CON);
if ($got != $size) {
if ($error) {
$$error = "Download incomplete";
return 0;
}
else {
&error("Download incomplete");
}
}
&$cbfunc(4) if ($cbfunc);
&ftp_command("", 2, $error) || return 0;
}
# finish off..
&ftp_command("QUIT", 2, $error) || return 0;
close(SOCK);
}
&write_to_http_cache($url, $dest);
return 1;
}
=head2 ftp_upload(host, file, srcfile, [&error], [&callback], [user, pass], [port])
Upload data from a local file to an FTP site. The parameters are :
=item host - FTP server hostname
=item file - File on the FTP server to write to
=item srcfile - File on the Webmin system to upload data from
=item error - If set to a string ref, any error message is written into this string and the function returns 0 on failure, 1 on success. Otherwise, error is called on failure.
=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 upload progress.
=item user - Username to login to the FTP server as. If missing, Webmin will login as anonymous.
=item pass - Password for the username above.
=item port - FTP server port number, which defaults to 21 if not set.
=cut
sub ftp_upload
{
my ($buf, @n);
my $cbfunc = $_[4];
if (&is_readonly_mode()) {
if ($_[3]) { ${$_[3]} = "FTP connections not allowed in readonly mode";
return 0; }
else { &error("FTP connections not allowed in readonly mode"); }
}
$main::download_timed_out = undef;
local $SIG{ALRM} = \&download_timeout;
alarm(60);
# connect to host and login
&open_socket($_[0], $_[7] || 21, "SOCK", $_[3]) || return 0;
alarm(0);
if ($main::download_timed_out) {
if ($_[3]) { ${$_[3]} = $main::download_timed_out; return 0; }
else { &error($main::download_timed_out); }
}
&ftp_command("", 2, $_[3]) || return 0;
if ($_[5]) {
# Login as supplied user
my @urv = &ftp_command("USER $_[5]", [ 2, 3 ], $_[3]);
@urv || return 0;
if (int($urv[1]/100) == 3) {
if (!&ftp_command("PASS $_[6]", 2, $_[3])) {
${$_[3]} =~ s/PASS\s+\S+/PASS \*\*\*\*\*/ if ($_[3]);
return 0;
}
}
}
else {
# Login as anonymous
my @urv = &ftp_command("USER anonymous", [ 2, 3 ], $_[3]);
@urv || return 0;
if (int($urv[1]/100) == 3) {
if (!&ftp_command("PASS root\@".&get_system_hostname(), 2,
$_[3])) {
${$_[3]} =~ s/PASS\s+\S+/PASS \*\*\*\*\*/ if ($_[3]);
return 0;
}
}
}
&$cbfunc(1, 0) if ($cbfunc);
&ftp_command("TYPE I", 2, $_[3]) || return 0;
# get the file size and tell the callback
my @st = stat($_[2]);
if ($cbfunc) {
&$cbfunc(2, $st[7]);
}
# are we using IPv6?
my $v6 = !&to_ipaddress($_[0]) && &to_ip6address($_[0]);
if ($v6) {
# send the file over a EPSV port
my $epsv = &ftp_command("EPSV", 2, $_[3]);
defined($epsv) || return 0;
$epsv =~ /\|(\d+)\|/ || return 0;
my $epsvport = $1;
&open_socket($_[0], $epsvport, "CON", $_[3]) || return 0;
}
else {
# send the file over a PASV connection
my $pasv = &ftp_command("PASV", 2, $_[3]);
defined($pasv) || return 0;
$pasv =~ /\(([0-9,]+)\)/ || return 0;
@n = split(/,/ , $1);
&open_socket("$n[0].$n[1].$n[2].$n[3]", $n[4]*256 + $n[5], "CON", $_[3]) || return 0;
}
&ftp_command("STOR $_[1]", 1, $_[3]) || return 0;
# transfer data
my $got;
open(PFILE, $_[2]);
while(read(PFILE, $buf, 1024) > 0) {
print CON $buf;
$got += length($buf);
&$cbfunc(3, $got) if ($cbfunc);
}
close(PFILE);
close(CON);
if ($got != $st[7]) {
if ($_[3]) { ${$_[3]} = "Upload incomplete"; return 0; }
else { &error("Upload incomplete"); }
}
&$cbfunc(4) if ($cbfunc);
# finish off..
&ftp_command("", 2, $_[3]) || return 0;
&ftp_command("QUIT", 2, $_[3]) || return 0;
close(SOCK);
return 1;
}
=head2 no_proxy(host)
Checks if some host is on the no proxy list. For internal use by the
http_download and ftp_download functions.
=cut
sub no_proxy
{
my $ip = &to_ipaddress($_[0]);
foreach my $n (split(/\s+/, $gconfig{'noproxy'})) {
return 1 if ($_[0] =~ /\Q$n\E/ ||
$ip =~ /\Q$n\E/);
}
return 0;
}
=head2 open_socket(host, port, handle, [&error])
Open a TCP connection to some host and port, using a file handle. The
parameters are :
=item host - Hostname or IP address to connect to.
=item port - TCP port number.
=item handle - A file handle name to use for the connection.
=item error - A string reference to write any error message into. If not set, the error function is called on failure.
=item bindip - Local IP address to bind to for outgoing connections
=cut
sub open_socket
{
my ($host, $port, $fh, $err, $bindip) = @_;
$fh = &callers_package($fh);
$bindip ||= $gconfig{'bind_proxy'};
if ($gconfig{'debug_what_net'}) {
&webmin_debug_log('TCP', "host=$host port=$port");
}
# Lookup IP address for the host. Try v4 first, and failing that v6
my $ip;
my $proto = getprotobyname("tcp");
if ($ip = &to_ipaddress($host)) {
# Create IPv4 socket and connection
if (!socket($fh, PF_INET(), SOCK_STREAM, $proto)) {
my $msg = "Failed to create socket : $!";
if ($err) { $$err = $msg; return 0; }
else { &error($msg); }
}
my $addr = inet_aton($ip);
if ($gconfig{'bind_proxy'}) {
# BIND to outgoing IP
if (!bind($fh, pack_sockaddr_in(0, inet_aton($bindip)))) {
my $msg = "Failed to bind to source address : $!";
if ($err) { $$err = $msg; return 0; }
else { &error($msg); }
}
}
if (!connect($fh, pack_sockaddr_in($port, $addr))) {
my $msg = "Failed to connect to $host:$port : $!";
if ($err) { $$err = $msg; return 0; }
else { &error($msg); }
}
}
elsif ($ip = &to_ip6address($host)) {
# Create IPv6 socket and connection
if (!&supports_ipv6()) {
$msg = "IPv6 connections are not supported";
if ($err) { $$err = $msg; return 0; }
else { &error($msg); }
}
if (!socket($fh, PF_INET6(), SOCK_STREAM, $proto)) {
my $msg = "Failed to create IPv6 socket : $!";
if ($err) { $$err = $msg; return 0; }
else { &error($msg); }
}
my $addr = inet_pton(AF_INET6(), $ip);
if (!connect($fh, pack_sockaddr_in6($port, $addr))) {
my $msg = "Failed to IPv6 connect to $host:$port : $!";
if ($err) { $$err = $msg; return 0; }
else { &error($msg); }
}
}
else {
# Resolution failed
my $msg = "Failed to lookup IP address for $host";
if ($err) { $$err = $msg; return 0; }
else { &error($msg); }
}
# Disable buffering
my $old = select($fh);
$| = 1;
select($old);
return 1;
}
=head2 download_timeout
Called when a download times out. For internal use only.
=cut
sub download_timeout
{
$main::download_timed_out = "Download timed out";
}
=head2 ftp_command(command, expected, [&error], [filehandle])
Send an FTP command, and die if the reply is not what was expected. Mainly
for internal use by the ftp_download and ftp_upload functions.
=cut
sub ftp_command
{
my ($cmd, $expect, $err, $fh) = @_;
$fh ||= "SOCK";
$fh = &callers_package($fh);
my $line;
my $what = $cmd ne "" ? "<i>$cmd</i>" : "initial connection";
if ($cmd ne "") {
print $fh "$cmd\r\n";
}
alarm(60);
if (!($line = <$fh>)) {
alarm(0);
if ($err) { $$err = "Failed to read reply to $what"; return undef; }
else { &error("Failed to read reply to $what"); }
}
$line =~ /^(...)(.)(.*)$/;
my $found = 0;
if (ref($expect)) {
foreach my $c (@$expect) {
$found++ if (int($1/100) == $c);
}
}
else {
$found++ if (int($1/100) == $_[1]);
}
if (!$found) {
alarm(0);
if ($err) { $$err = "$what failed : $3"; return undef; }
else { &error("$what failed : $3"); }
}
my $rcode = $1;
my $reply = $3;
if ($2 eq "-") {
# Need to skip extra stuff..
while(1) {
if (!($line = <$fh>)) {
alarm(0);
if ($err) { $$err = "Failed to read reply to $what";
return undef; }
else { &error("Failed to read reply to $what"); }
}
$line =~ /^(....)(.*)$/; $reply .= $2;
if ($1 eq "$rcode ") { last; }
}
}
alarm(0);
return wantarray ? ($reply, $rcode) : $reply;
}
=head2 to_ipaddress(hostname)
Converts a hostname to an a.b.c.d format IP address, or returns undef if
it cannot be resolved.
=cut
sub to_ipaddress
{
if (&check_ipaddress($_[0])) {
return $_[0]; # Already in v4 format
}
elsif (&check_ip6address($_[0])) {
return undef; # A v6 address cannot be converted to v4
}
else {
my $hn = gethostbyname($_[0]);
return undef if (!$hn);
local @ip = unpack("CCCC", $hn);
return join("." , @ip);
}
}
=head2 to_ip6address(hostname)
Converts a hostname to IPv6 address, or returns undef if it cannot be resolved.
=cut
sub to_ip6address
{
if (&check_ip6address($_[0])) {
return $_[0]; # Already in v6 format
}
elsif (&check_ipaddress($_[0])) {
return undef; # A v4 address cannot be v6
}
elsif (!&supports_ipv6()) {
return undef; # Cannot lookup
}
else {
# Perform IPv6 DNS lookup
my $inaddr;
(undef, undef, undef, $inaddr) =
getaddrinfo($_[0], undef, AF_INET6(), SOCK_STREAM);
return undef if (!$inaddr);
my $addr;
(undef, $addr) = unpack_sockaddr_in6($inaddr);
return inet_ntop(AF_INET6(), $addr);
}
}
=head2 to_hostname(ipv4|ipv6-address)
Reverse-resolves an IPv4 or 6 address to a hostname
=cut
sub to_hostname
{
my ($addr) = @_;
if (&check_ip6address($addr) && &supports_ipv6()) {
return gethostbyaddr(inet_pton(AF_INET6(), $addr), AF_INET6());
}
else {
return gethostbyaddr(inet_aton($addr), AF_INET);
}
}
=head2 icons_table(&links, &titles, &icons, [columns], [href], [width], [height], &befores, &afters)
Renders a 4-column table of icons. The useful parameters are :
=item links - An array ref of link destination URLs for the icons.
=item titles - An array ref of titles to appear under the icons.
=item icons - An array ref of URLs for icon images.
=item columns - Number of columns to layout the icons with. Defaults to 4.
=cut
sub icons_table
{
&load_theme_library();
if (defined(&theme_icons_table)) {
&theme_icons_table(@_);
return;
}
my $need_tr;
my $cols = $_[3] ? $_[3] : 4;
my $per = int(100.0 / $cols);
print "<table class='icons_table' width='100%' cellpadding='5'>\n";
for(my $i=0; $i<@{$_[0]}; $i++) {
if ($i%$cols == 0) { print "<tr>\n"; }
print "<td width='$per%' align='center' valign='top'>\n";
&generate_icon($_[2]->[$i], $_[1]->[$i], $_[0]->[$i],
ref($_[4]) ? $_[4]->[$i] : $_[4], $_[5], $_[6],
$_[7]->[$i], $_[8]->[$i]);
print "</td>\n";
if ($i%$cols == $cols-1) { print "</tr>\n"; }
}
while($i++%$cols) { print "<td width='$per%'></td>\n"; $need_tr++; }
print "</tr>\n" if ($need_tr);
print "</table>\n";
}
=head2 replace_meta($string)
Replaces all occurrences of meta words
=item string - String value to search/replace in
=cut
sub replace_meta
{
my ($string) = @_;
my $hostname = &get_display_hostname();
my $version = &get_webmin_version();
my $os_type = $gconfig{'real_os_type'} || $gconfig{'os_type'};
my $os_version = $gconfig{'real_os_version'} || $gconfig{'os_version'};
$string =~ s/%HOSTNAME%/$hostname/g;
$string =~ s/%VERSION%/$version/g;
$string =~ s/%USER%/$remote_user/g;
$string =~ s/%OS%/$os_type $os_version/g;
return $string;
}
=head2 replace_file_line(file, line, [newline]*)
Replaces one line in some file with 0 or more new lines. The parameters are :
=item file - Full path to some file, like /etc/hosts.
=item line - Line number to replace, starting from 0.
=item newline - Zero or more lines to put into the file at the given line number. These must be newline-terminated strings.
=cut
sub replace_file_line
{
my @lines;
my $realfile = &translate_filename($_[0]);
open(FILE, $realfile);
@lines = <FILE>;
close(FILE);
if (@_ > 2) { splice(@lines, $_[1], 1, @_[2..$#_]); }
else { splice(@lines, $_[1], 1); }
&open_tempfile(FILE, ">$realfile");
&print_tempfile(FILE, @lines);
&close_tempfile(FILE);
}
=head2 read_file_lines(file, [readonly])
Returns a reference to an array containing the lines from some file. This
array can be modified, and will be written out when flush_file_lines()
is called. The parameters are :
=item file - Full path to the file to read.
=item readonly - Should be set 1 if the caller is only going to read the lines, and never write it out.
Example code :
$lref = read_file_lines("/etc/hosts");
push(@$lref, "127.0.0.1 localhost");
flush_file_lines("/etc/hosts");
=cut
sub read_file_lines
{
my ($file, $readonly) = @_;
if (!$file) {
my ($package, $filename, $line) = caller;
&error("Missing file to read at ${package}::${filename} line $line");
}
my $realfile = &translate_filename($file);
if (!$main::file_cache{$realfile}) {
my (@lines, $eol);
local $_;
&webmin_debug_log('READ', $file) if ($gconfig{'debug_what_read'});
open(READFILE, $realfile);
while(<READFILE>) {
if (!$eol) {
$eol = /\r\n$/ ? "\r\n" : "\n";
}
tr/\r\n//d;
push(@lines, $_);
}
close(READFILE);
$main::file_cache{$realfile} = \@lines;
$main::file_cache_noflush{$realfile} = $readonly;
$main::file_cache_eol{$realfile} = $eol || "\n";
}
else {
# Make read-write if currently readonly
if (!$readonly) {
$main::file_cache_noflush{$realfile} = 0;
}
}
return $main::file_cache{$realfile};
}
=head2 flush_file_lines([file], [eol], [ignore-unloaded])
Write out to a file previously read by read_file_lines to disk (except
for those marked readonly). The parameters are :
=item file - The file to flush out.
=item eof - End-of-line character for each line. Defaults to \n.
=item ignore-unloaded - Don't fail if the file isn't loaded
=cut
sub flush_file_lines
{
my ($file, $eof, $ignore) = @_;
my @files;
if ($file) {
local $trans = &translate_filename($file);
if (!$main::file_cache{$trans}) {
if ($ignore) {
return 0;
}
else {
&error("flush_file_lines called on non-loaded file $trans");
}
}
push(@files, $trans);
}
else {
@files = ( keys %main::file_cache );
}
foreach my $f (@files) {
my $eol = $eof || $main::file_cache_eol{$f} || "\n";
if (!$main::file_cache_noflush{$f}) {
no warnings; # XXX Bareword file handles should go away
&open_tempfile(FLUSHFILE, ">$f");
foreach my $line (@{$main::file_cache{$f}}) {
(print FLUSHFILE $line,$eol) ||
&error(&text("efilewrite", $f, $!));
}
&close_tempfile(FLUSHFILE);
}
delete($main::file_cache{$f});
delete($main::file_cache_noflush{$f});
}
return scalar(@files);
}
=head2 unflush_file_lines(file)
Clear the internal cache of some given file, previously read by read_file_lines.
=cut
sub unflush_file_lines
{
my $realfile = &translate_filename($_[0]);
delete($main::file_cache{$realfile});
delete($main::file_cache_noflush{$realfile});
}
=head2 unix_user_input(fieldname, user, [form])
Returns HTML for an input to select a Unix user. By default this is a text
box with a user popup button next to it.
=cut
sub unix_user_input
{
if (defined(&theme_unix_user_input)) {
return &theme_unix_user_input(@_);
}
return "<input name=$_[0] size=13 value=\"$_[1]\"> ".
&user_chooser_button($_[0], 0, $_[2] || 0)."\n";
}
=head2 unix_group_input(fieldname, user, [form])
Returns HTML for an input to select a Unix group. By default this is a text
box with a group popup button next to it.
=cut
sub unix_group_input
{
if (defined(&theme_unix_group_input)) {
return &theme_unix_group_input(@_);
}
return "<input name='$_[0]' size=13 value=\"$_[1]\"> ".
&group_chooser_button($_[0], 0, $_[2] || 0)."\n";
}
=head2 hlink(text, page, [module], [width], [height])
Returns HTML for a link that when clicked on pops up a window for a Webmin