web-lib-funcs.pl

   1 =head1 web-lib-funcs.pl
   2
   3 Common functions for Webmin CGI scripts. This file gets in-directly included
   4 by all scripts that use web-lib.pl.
   5 Example code:
   6
   7   use WebminCore;
   8   init_config();
   9   ui_print_header(undef, 'My Module', '');
  10   print 'This is Webmin version ',get_webmin_version(),'<p>\n';
  11   ui_print_footer();
  12
  13 =cut
  14
  15 #use warnings;
  16 use Socket;
  17 use POSIX;
  18 eval "use Socket6";
  19 $ipv6_module_error = $@;
  20
  21 use vars qw($user_risk_level $loaded_theme_library $wait_for_input
  22             $done_webmin_header $trust_unknown_referers $unsafe_index_cgi
  23             %done_foreign_require $webmin_feedback_address
  24             $user_skill_level $pragma_no_cache $foreign_args);
  25 # Globals
  26 use vars qw($module_index_name $number_to_month_map $month_to_number_map
  27             $umask_already $default_charset $licence_status $os_type
  28             $licence_message $script_name $loaded_theme_oo_library
  29             $done_web_lib_funcs $os_version $module_index_link
  30             $called_from_webmin_core $ipv6_module_error);
  31
  32 =head2 read_file(file, &hash, [&order], [lowercase], [split-char])
  33
  34 Fill the given hash reference with name=value pairs from a file. The required
  35 parameters are :
  36
  37 =item file - The file to head, which must be text with each line like name=value
  38
  39 =item hash - The hash reference to add values read from the file to.
  40
  41 =item order - If given, an array reference to add names to in the order they were read
  42
  43 =item lowercase - If set to 1, names are converted to lower case
  44
  45 =item split-char - If set, names and values are split on this character instead of =
  46
  47 =cut
  48 sub read_file
  49 {
  50 local $_;
  51 my $split = defined($_[4]) ? $_[4] : "=";
  52 my $realfile = &translate_filename($_[0]);
  53 &open_readfile(ARFILE, $_[0]) || return 0;
  54 while(<ARFILE>) {
  55         chomp;
  56         my $hash = index($_, "#");
  57         my $eq = index($_, $split);
  58         if ($hash != 0 && $eq >= 0) {
  59                 my $n = substr($_, 0, $eq);
  60                 my $v = substr($_, $eq+1);
  61                 chomp($v);
  62                 $_[1]->{$_[3] ? lc($n) : $n} = $v;
  63                 push(@{$_[2]}, $n) if ($_[2]);
  64                 }
  65         }
  66 close(ARFILE);
  67 $main::read_file_missing{$realfile} = 0;        # It exists now
  68 if (defined($main::read_file_cache{$realfile})) {
  69         %{$main::read_file_cache{$realfile}} = %{$_[1]};
  70         }
  71 return 1;
  72 }
  73
  74 =head2 read_file_cached(file, &hash, [&order], [lowercase], [split-char])
  75
  76 Like read_file, but reads from an in-memory cache if the file has already been
  77 read in this Webmin script. Recommended, as it behaves exactly the same as
  78 read_file, but can be much faster.
  79
  80 =cut
  81 sub read_file_cached
  82 {
  83 my $realfile = &translate_filename($_[0]);
  84 if (defined($main::read_file_cache{$realfile})) {
  85         # Use cached data
  86         %{$_[1]} = ( %{$_[1]}, %{$main::read_file_cache{$realfile}} );
  87         return 1;
  88         }
  89 elsif ($main::read_file_missing{$realfile}) {
  90         # Doesn't exist, so don't re-try read
  91         return 0;
  92         }
  93 else {
  94         # Actually read the file
  95         my %d;
  96         if (&read_file($_[0], \%d, $_[2], $_[3], $_[4])) {
  97                 %{$main::read_file_cache{$realfile}} = %d;
  98                 %{$_[1]} = ( %{$_[1]}, %d );
  99                 return 1;
 100                 }
 101         else {
 102                 # Flag as non-existant
 103                 $main::read_file_missing{$realfile} = 1;
 104                 return 0;
 105                 }
 106         }
 107 }
 108
 109 =head2 write_file(file, &hash, [join-char])
 110
 111 Write out the contents of a hash as name=value lines. The parameters are :
 112
 113 =item file - Full path to write to
 114
 115 =item hash - A hash reference containing names and values to output
 116
 117 =item join-char - If given, names and values are separated by this instead of =
 118
 119 =cut
 120 sub write_file
 121 {
 122 my (%old, @order);
 123 my $join = defined($_[2]) ? $_[2] : "=";
 124 my $realfile = &translate_filename($_[0]);
 125 &read_file($_[0], \%old, \@order);
 126 &open_tempfile(ARFILE, ">$_[0]");
 127 foreach $k (@order) {
 128         if (exists($_[1]->{$k})) {
 129                 (print ARFILE $k,$join,$_[1]->{$k},"\n") ||
 130                         &error(&text("efilewrite", $realfile, $!));
 131                 }
 132         }
 133 foreach $k (keys %{$_[1]}) {
 134         if (!exists($old{$k})) {
 135                 (print ARFILE $k,$join,$_[1]->{$k},"\n") ||
 136                         &error(&text("efilewrite", $realfile, $!));
 137                 }
 138         }
 139 &close_tempfile(ARFILE);
 140 if (defined($main::read_file_cache{$realfile})) {
 141         %{$main::read_file_cache{$realfile}} = %{$_[1]};
 142         }
 143 if (defined($main::read_file_missing{$realfile})) {
 144         $main::read_file_missing{$realfile} = 0;
 145         }
 146 }
 147
 148 =head2 html_escape(string)
 149
 150 Converts &, < and > codes in text to HTML entities, and returns the new string.
 151 This should be used when including data read from other sources in HTML pages.
 152
 153 =cut
 154 sub html_escape
 155 {
 156 my ($tmp) = @_;
 157 $tmp =~ s/&/&amp;/g;
 158 $tmp =~ s/</&lt;/g;
 159 $tmp =~ s/>/&gt;/g;
 160 $tmp =~ s/\"/&quot;/g;
 161 $tmp =~ s/\'/&#39;/g;
 162 $tmp =~ s/=/&#61;/g;
 163 return $tmp;
 164 }
 165
 166 =head2 quote_escape(string, [only-quote])
 167
 168 Converts ' and " characters in a string into HTML entities, and returns it.
 169 Useful for outputing HTML tag values.
 170
 171 =cut
 172 sub quote_escape
 173 {
 174 my ($tmp, $only) = @_;
 175 if ($tmp !~ /\&[a-zA-Z]+;/ && $tmp !~ /\&#/) {
 176         # convert &, unless it is part of &#nnn; or &foo;
 177         $tmp =~ s/&([^#])/&amp;$1/g;
 178         }
 179 $tmp =~ s/&$/&amp;/g;
 180 $tmp =~ s/\"/&quot;/g if ($only eq '' || $only eq '"');
 181 $tmp =~ s/\'/&#39;/g if ($only eq '' || $only eq "'");
 182 return $tmp;
 183 }
 184
 185 =head2 tempname([filename])
 186
 187 Returns a mostly random temporary file name, typically under the /tmp/.webmin
 188 directory. If filename is given, this will be the base name used. Otherwise
 189 a unique name is selected randomly.
 190
 191 =cut
 192 sub tempname
 193 {
 194 my $tmp_base = $gconfig{'tempdir_'.&get_module_name()} ?
 195                         $gconfig{'tempdir_'.&get_module_name()} :
 196                   $gconfig{'tempdir'} ? $gconfig{'tempdir'} :
 197                   $ENV{'TEMP'} ? $ENV{'TEMP'} :
 198                   $ENV{'TMP'} ? $ENV{'TMP'} :
 199                   -d "c:/temp" ? "c:/temp" : "/tmp/.webmin";
 200 my $tmp_dir = -d $remote_user_info[7] && !$gconfig{'nohometemp'} ?
 201                         "$remote_user_info[7]/.tmp" :
 202                  @remote_user_info ? $tmp_base."-".$remote_user :
 203                  $< != 0 ? $tmp_base."-".getpwuid($<) :
 204                                      $tmp_base;
 205 if ($gconfig{'os_type'} eq 'windows' || $tmp_dir =~ /^[a-z]:/i) {
 206         # On Windows system, just create temp dir if missing
 207         if (!-d $tmp_dir) {
 208                 mkdir($tmp_dir, 0755) ||
 209                         &error("Failed to create temp directory $tmp_dir : $!");
 210                 }
 211         }
 212 else {
 213         # On Unix systems, need to make sure temp dir is valid
 214         my $tries = 0;
 215         while($tries++ < 10) {
 216                 my @st = lstat($tmp_dir);
 217                 last if ($st[4] == $< && (-d _) && ($st[2] & 0777) == 0755);
 218                 if (@st) {
 219                         unlink($tmp_dir) || rmdir($tmp_dir) ||
 220                                 system("/bin/rm -rf ".quotemeta($tmp_dir));
 221                         }
 222                 mkdir($tmp_dir, 0755) || next;
 223                 chown($<, $(, $tmp_dir);
 224                 chmod(0755, $tmp_dir);
 225                 }
 226         if ($tries >= 10) {
 227                 my @st = lstat($tmp_dir);
 228                 &error("Failed to create temp directory $tmp_dir : uid=$st[4] mode=$st[2]");
 229                 }
 230         }
 231 my $rv;
 232 if (defined($_[0]) && $_[0] !~ /\.\./) {
 233         $rv = "$tmp_dir/$_[0]";
 234         }
 235 else {
 236         $main::tempfilecount++;
 237         &seed_random();
 238         $rv = $tmp_dir."/".int(rand(1000000))."_".
 239                $main::tempfilecount."_".$scriptname;
 240         }
 241 return $rv;
 242 }
 243
 244 =head2 transname([filename])
 245
 246 Behaves exactly like tempname, but records the temp file for deletion when the
 247 current Webmin script process exits.
 248
 249 =cut
 250 sub transname
 251 {
 252 my $rv = &tempname(@_);
 253 push(@main::temporary_files, $rv);
 254 return $rv;
 255 }
 256
 257 =head2 trunc(string, maxlen)
 258
 259 Truncates a string to the shortest whole word less than or equal to the
 260 given width. Useful for word wrapping.
 261
 262 =cut
 263 sub trunc
 264 {
 265 if (length($_[0]) <= $_[1]) {
 266         return $_[0];
 267         }
 268 my $str = substr($_[0],0,$_[1]);
 269 my $c;
 270 do {
 271         $c = chop($str);
 272         } while($c !~ /\S/);
 273 $str =~ s/\s+$//;
 274 return $str;
 275 }
 276
 277 =head2 indexof(string, value, ...)
 278
 279 Returns the index of some value in an array of values, or -1 if it was not
 280 found.
 281
 282 =cut
 283 sub indexof
 284 {
 285 for(my $i=1; $i <= $#_; $i++) {
 286         if ($_[$i] eq $_[0]) { return $i - 1; }
 287         }
 288 return -1;
 289 }
 290
 291 =head2 indexoflc(string, value, ...)
 292
 293 Like indexof, but does a case-insensitive match
 294
 295 =cut
 296 sub indexoflc
 297 {
 298 my $str = lc(shift(@_));
 299 my @arr = map { lc($_) } @_;
 300 return &indexof($str, @arr);
 301 }
 302
 303 =head2 sysprint(handle, [string]+)
 304
 305 Outputs some strings to a file handle, but bypassing IO buffering. Can be used
 306 as a replacement for print when writing to pipes or sockets.
 307
 308 =cut
 309 sub sysprint
 310 {
 311 my $fh = &callers_package($_[0]);
 312 my $str = join('', @_[1..$#_]);
 313 syswrite $fh, $str, length($str);
 314 }
 315
 316 =head2 check_ipaddress(ip)
 317
 318 Check if some IPv4 address is properly formatted, returning 1 if so or 0 if not.
 319
 320 =cut
 321 sub check_ipaddress
 322 {
 323 return $_[0] =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/ &&
 324         $1 >= 0 && $1 <= 255 &&
 325         $2 >= 0 && $2 <= 255 &&
 326         $3 >= 0 && $3 <= 255 &&
 327         $4 >= 0 && $4 <= 255;
 328 }
 329
 330 =head2 check_ip6address(ip)
 331
 332 Check if some IPv6 address is properly formatted, and returns 1 if so.
 333
 334 =cut
 335 sub check_ip6address
 336 {
 337   my @blocks = split(/:/, $_[0]);
 338   return 0 if (@blocks == 0 || @blocks > 8);
 339
 340   # The address/netmask format is accepted. So we're looking for a "/" to isolate a possible netmask.
 341   # After that, we delete the netmask to control the address only format, but we verify whether the netmask
 342   # value is in [0;128].
 343   my $ib = $#blocks;
 344   my $where = index($blocks[$ib],"/");
 345   my $m = 0;
 346   if ($where != -1) {
 347     my $b = substr($blocks[$ib],0,$where);
 348     $m = substr($blocks[$ib],$where+1,length($blocks[$ib])-($where+1));
 349     $blocks[$ib]=$b;
 350   }
 351
 352   # The netmask must take its value in [0;128]
 353   return 0 if ($m <0 || $m >128);
 354
 355   # Check the different blocks of the address : 16 bits block in hexa notation.
 356   # Possibility of 1 empty block or 2 if the address begins with "::".
 357   my $b;
 358   my $empty = 0;
 359   foreach $b (@blocks) {
 360           return 0 if ($b ne "" && $b !~ /^[0-9a-f]{1,4}$/i);
 361           $empty++ if ($b eq "");
 362           }
 363   return 0 if ($empty > 1 && !($_[0] =~ /^::/ && $empty == 2));
 364   return 1;
 365 }
 366
 367
 368
 369 =head2 generate_icon(image, title, link, [href], [width], [height], [before-title], [after-title])
 370
 371 Prints HTML for an icon image. The parameters are :
 372
 373 =item image - URL for the image, like images/foo.gif
 374
 375 =item title - Text to appear under the icon
 376
 377 =item link - Optional destination for the icon's link
 378
 379 =item href - Other HTML attributes to be added to the <a href> for the link
 380
 381 =item width - Optional width of the icon
 382
 383 =item height - Optional height of the icon
 384
 385 =item before-title - HTML to appear before the title link, but which is not actually in the link
 386
 387 =item after-title - HTML to appear after the title link, but which is not actually in the link
 388
 389 =cut
 390 sub generate_icon
 391 {
 392 &load_theme_library();
 393 if (defined(&theme_generate_icon)) {
 394         &theme_generate_icon(@_);
 395         return;
 396         }
 397 my $w = !defined($_[4]) ? "width=48" : $_[4] ? "width=$_[4]" : "";
 398 my $h = !defined($_[5]) ? "height=48" : $_[5] ? "height=$_[5]" : "";
 399 if ($tconfig{'noicons'}) {
 400         if ($_[2]) {
 401                 print "$_[6]<a href=\"$_[2]\" $_[3]>$_[1]</a>$_[7]\n";
 402                 }
 403         else {
 404                 print "$_[6]$_[1]$_[7]\n";
 405                 }
 406         }
 407 elsif ($_[2]) {
 408         print "<table border><tr><td width=48 height=48>\n",
 409               "<a href=\"$_[2]\" $_[3]><img src=\"$_[0]\" alt=\"\" border=0 ",
 410               "$w $h></a></td></tr></table>\n";
 411         print "$_[6]<a href=\"$_[2]\" $_[3]>$_[1]</a>$_[7]\n";
 412         }
 413 else {
 414         print "<table border><tr><td width=48 height=48>\n",
 415               "<img src=\"$_[0]\" alt=\"\" border=0 $w $h>",
 416               "</td></tr></table>\n$_[6]$_[1]$_[7]\n";
 417         }
 418 }
 419
 420 =head2 urlize
 421
 422 Converts a string to a form ok for putting in a URL, using % escaping.
 423
 424 =cut
 425 sub urlize
 426 {
 427 my ($rv) = @_;
 428 $rv =~ s/([^A-Za-z0-9])/sprintf("%%%2.2X", ord($1))/ge;
 429 return $rv;
 430 }
 431
 432 =head2 un_urlize(string)
 433
 434 Converts a URL-encoded string to it's original contents - the reverse of the
 435 urlize function.
 436
 437 =cut
 438 sub un_urlize
 439 {
 440 my ($rv) = @_;
 441 $rv =~ s/\+/ /g;
 442 $rv =~ s/%(..)/pack("c",hex($1))/ge;
 443 return $rv;
 444 }
 445
 446 =head2 include(filename)
 447
 448 Read and output the contents of the given file.
 449
 450 =cut
 451 sub include
 452 {
 453 local $_;
 454 open(INCLUDE, &translate_filename($_[0])) || return 0;
 455 while(<INCLUDE>) {
 456         print;
 457         }
 458 close(INCLUDE);
 459 return 1;
 460 }
 461
 462 =head2 copydata(in-handle, out-handle)
 463
 464 Read from one file handle and write to another, until there is no more to read.
 465
 466 =cut
 467 sub copydata
 468 {
 469 my ($in, $out) = @_;
 470 $in = &callers_package($in);
 471 $out = &callers_package($out);
 472 my $buf;
 473 while(read($in, $buf, 1024) > 0) {
 474         (print $out $buf) || return 0;
 475         }
 476 return 1;
 477 }
 478
 479 =head2 ReadParseMime([maximum], [&cbfunc, &cbargs])
 480
 481 Read data submitted via a POST request using the multipart/form-data coding,
 482 and store it in the global %in hash. The optional parameters are :
 483
 484 =item maximum - If the number of bytes of input exceeds this number, stop reading and call error.
 485
 486 =item cbfunc - A function reference to call after reading each block of data.
 487
 488 =item cbargs - Additional parameters to the callback function.
 489
 490 =cut
 491 sub ReadParseMime
 492 {
 493 my ($max, $cbfunc, $cbargs) = @_;
 494 my ($boundary, $line, $foo, $name, $got, $file);
 495 my $err = &text('readparse_max', $max);
 496 $ENV{'CONTENT_TYPE'} =~ /boundary=(.*)$/ || &error($text{'readparse_enc'});
 497 if ($ENV{'CONTENT_LENGTH'} && $max && $ENV{'CONTENT_LENGTH'} > $max) {
 498         &error($err);
 499         }
 500 &$cbfunc(0, $ENV{'CONTENT_LENGTH'}, $file, @$cbargs) if ($cbfunc);
 501 $boundary = $1;
 502 <STDIN>;        # skip first boundary
 503 while(1) {
 504         $name = "";
 505         # Read section headers
 506         my $lastheader;
 507         while(1) {
 508                 $line = <STDIN>;
 509                 $got += length($line);
 510                 &$cbfunc($got, $ENV{'CONTENT_LENGTH'}, @$cbargs) if ($cbfunc);
 511                 if ($max && $got > $max) {
 512                         &error($err)
 513                         }
 514                 $line =~ tr/\r\n//d;
 515                 last if (!$line);
 516                 if ($line =~ /^(\S+):\s*(.*)$/) {
 517                         $header{$lastheader = lc($1)} = $2;
 518                         }
 519                 elsif ($line =~ /^\s+(.*)$/) {
 520                         $header{$lastheader} .= $line;
 521                         }
 522                 }
 523
 524         # Parse out filename and type
 525         if ($header{'content-disposition'} =~ /^form-data(.*)/) {
 526                 $rest = $1;
 527                 while ($rest =~ /([a-zA-Z]*)=\"([^\"]*)\"(.*)/) {
 528                         if ($1 eq 'name') {
 529                                 $name = $2;
 530                                 }
 531                         else {
 532                                 $foo = $name . "_$1";
 533                                 $in{$foo} = $2;
 534                                 }
 535                         $rest = $3;
 536                         }
 537                 }
 538         else {
 539                 &error($text{'readparse_cdheader'});
 540                 }
 541         if ($header{'content-type'} =~ /^([^\s;]+)/) {
 542                 $foo = $name . "_content_type";
 543                 $in{$foo} = $1;
 544                 }
 545         $file = $in{$name."_filename"};
 546
 547         # Read data
 548         $in{$name} .= "\0" if (defined($in{$name}));
 549         while(1) {
 550                 $line = <STDIN>;
 551                 $got += length($line);
 552                 &$cbfunc($got, $ENV{'CONTENT_LENGTH'}, $file, @$cbargs)
 553                         if ($cbfunc);
 554                 if ($max && $got > $max) {
 555                         #print STDERR "over limit of $max\n";
 556                         #&error($err);
 557                         }
 558                 if (!$line) {
 559                         # Unexpected EOF?
 560                         &$cbfunc(-1, $ENV{'CONTENT_LENGTH'}, $file, @$cbargs)
 561                                 if ($cbfunc);
 562                         return;
 563                         }
 564                 my $ptline = $line;
 565                 $ptline =~ s/[^a-zA-Z0-9\-]/\./g;
 566                 if (index($line, $boundary) != -1) { last; }
 567                 $in{$name} .= $line;
 568                 }
 569         chop($in{$name}); chop($in{$name});
 570         if (index($line,"$boundary--") != -1) { last; }
 571         }
 572 &$cbfunc(-1, $ENV{'CONTENT_LENGTH'}, $file, @$cbargs) if ($cbfunc);
 573 }
 574
 575 =head2 ReadParse([&hash], [method], [noplus])
 576
 577 Fills the given hash reference with CGI parameters, or uses the global hash
 578 %in if none is given. Also sets the global variables $in and @in. The other
 579 parameters are :
 580
 581 =item method - For use of this HTTP method, such as GET
 582
 583 =item noplus - Don't convert + in parameters to spaces.
 584
 585 =cut
 586 sub ReadParse
 587 {
 588 my $a = $_[0] || \%in;
 589 %$a = ( );
 590 my $meth = $_[1] ? $_[1] : $ENV{'REQUEST_METHOD'};
 591 undef($in);
 592 if ($meth eq 'POST') {
 593         my $clen = $ENV{'CONTENT_LENGTH'};
 594         &read_fully(STDIN, \$in, $clen) == $clen ||
 595                 &error("Failed to read POST input : $!");
 596         }
 597 if ($ENV{'QUERY_STRING'}) {
 598         if ($in) { $in .= "&".$ENV{'QUERY_STRING'}; }
 599         else { $in = $ENV{'QUERY_STRING'}; }
 600         }
 601 @in = split(/\&/, $in);
 602 foreach my $i (@in) {
 603         my ($k, $v) = split(/=/, $i, 2);
 604         if (!$_[2]) {
 605                 $k =~ tr/\+/ /;
 606                 $v =~ tr/\+/ /;
 607                 }
 608         $k =~ s/%(..)/pack("c",hex($1))/ge;
 609         $v =~ s/%(..)/pack("c",hex($1))/ge;
 610         $a->{$k} = defined($a->{$k}) ? $a->{$k}."\0".$v : $v;
 611         }
 612 }
 613
 614 =head2 read_fully(fh, &buffer, length)
 615
 616 Read data from some file handle up to the given length, even in the face
 617 of partial reads. Reads the number of bytes read. Stores received data in the
 618 string pointed to be the buffer reference.
 619
 620 =cut
 621 sub read_fully
 622 {
 623 my ($fh, $buf, $len) = @_;
 624 $fh = &callers_package($fh);
 625 my $got = 0;
 626 while($got < $len) {
 627         my $r = read(STDIN, $$buf, $len-$got, $got);
 628         last if ($r <= 0);
 629         $got += $r;
 630         }
 631 return $got;
 632 }
 633
 634 =head2 read_parse_mime_callback(size, totalsize, upload-id)
 635
 636 Called by ReadParseMime as new data arrives from a form-data POST. Only updates
 637 the file on every 1% change though. For internal use by the upload progress
 638 tracker.
 639
 640 =cut
 641 sub read_parse_mime_callback
 642 {
 643 my ($size, $totalsize, $filename, $id) = @_;
 644 return if ($gconfig{'no_upload_tracker'});
 645 return if (!$id);
 646
 647 # Create the upload tracking directory - if running as non-root, this has to
 648 # be under the user's home
 649 my $vardir;
 650 if ($<) {
 651         my @uinfo = @remote_user_info ? @remote_user_info : getpwuid($<);
 652         $vardir = "$uinfo[7]/.tmp";
 653         }
 654 else {
 655         $vardir = $ENV{'WEBMIN_VAR'};
 656         }
 657 if (!-d $vardir) {
 658         &make_dir($vardir, 0755);
 659         }
 660
 661 # Remove any upload.* files more than 1 hour old
 662 if (!$main::read_parse_mime_callback_flushed) {
 663         my $now = time();
 664         opendir(UPDIR, $vardir);
 665         foreach my $f (readdir(UPDIR)) {
 666                 next if ($f !~ /^upload\./);
 667                 my @st = stat("$vardir/$f");
 668                 if ($st[9] < $now-3600) {
 669                         unlink("$vardir/$f");
 670                         }
 671                 }
 672         closedir(UPDIR);
 673         $main::read_parse_mime_callback_flushed++;
 674         }
 675
 676 # Only update file once per percent
 677 my $upfile = "$vardir/upload.$id";
 678 if ($totalsize && $size >= 0) {
 679         my $pc = int(100 * $size / $totalsize);
 680         if ($pc <= $main::read_parse_mime_callback_pc{$upfile}) {
 681                 return;
 682                 }
 683         $main::read_parse_mime_callback_pc{$upfile} = $pc;
 684         }
 685
 686 # Write to the file
 687 &open_tempfile(UPFILE, ">$upfile");
 688 print UPFILE $size,"\n";
 689 print UPFILE $totalsize,"\n";
 690 print UPFILE $filename,"\n";
 691 &close_tempfile(UPFILE);
 692 }
 693
 694 =head2 read_parse_mime_javascript(upload-id, [&fields])
 695
 696 Returns an onSubmit= Javascript statement to popup a window for tracking
 697 an upload with the given ID. For internal use by the upload progress tracker.
 698
 699 =cut
 700 sub read_parse_mime_javascript
 701 {
 702 my ($id, $fields) = @_;
 703 return "" if ($gconfig{'no_upload_tracker'});
 704 my $opener = "window.open(\"$gconfig{'webprefix'}/uptracker.cgi?id=$id&uid=$<\", \"uptracker\", \"toolbar=no,menubar=no,scrollbars=no,width=500,height=100\");";
 705 if ($fields) {
 706         my $if = join(" || ", map { "typeof($_) != \"undefined\" && $_.value != \"\"" } @$fields);
 707         return "onSubmit='if ($if) { $opener }'";
 708         }
 709 else {
 710         return "onSubmit='$opener'";
 711         }
 712 }
 713
 714 =head2 PrintHeader(charset)
 715
 716 Outputs the HTTP headers for an HTML page. The optional charset parameter
 717 can be used to set a character set. Normally this function is not called
 718 directly, but is rather called by ui_print_header or header.
 719
 720 =cut
 721 sub PrintHeader
 722 {
 723 if ($pragma_no_cache || $gconfig{'pragma_no_cache'}) {
 724         print "pragma: no-cache\n";
 725         print "Expires: Thu, 1 Jan 1970 00:00:00 GMT\n";
 726         print "Cache-Control: no-store, no-cache, must-revalidate\n";
 727         print "Cache-Control: post-check=0, pre-check=0\n";
 728         }
 729 if (defined($_[0])) {
 730         print "Content-type: text/html; Charset=$_[0]\n\n";
 731         }
 732 else {
 733         print "Content-type: text/html\n\n";
 734         }
 735 }
 736
 737 =head2 header(title, image, [help], [config], [nomodule], [nowebmin], [rightside], [head-stuff], [body-stuff], [below])
 738
 739 Outputs a Webmin HTML page header with a title, including HTTP headers. The
 740 parameters are :
 741
 742 =item title - The text to show at the top of the page
 743
 744 =item image - An image to show instead of the title text. This is typically left blank.
 745
 746 =item help - If set, this is the name of a help page that will be linked to in the title.
 747
 748 =item config - If set to 1, the title will contain a link to the module's config page.
 749
 750 =item nomodule - If set to 1, there will be no link in the title section to the module's index.
 751
 752 =item nowebmin - If set to 1, there will be no link in the title section to the Webmin index.
 753
 754 =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.
 755
 756 =item head-stuff - HTML to be included in the <head> section of the page.
 757
 758 =item body-stuff - HTML attributes to be include in the <body> tag.
 759
 760 =item below - HTML to be displayed below the title. Typically this is used for application or server version information.
 761
 762 =cut
 763 sub header
 764 {
 765 return if ($main::done_webmin_header++);
 766 my $ll;
 767 my $charset = defined($main::force_charset) ? $main::force_charset
 768                                             : &get_charset();
 769 &PrintHeader($charset);
 770 &load_theme_library();
 771 if (defined(&theme_header)) {
 772         $module_name = &get_module_name();
 773         &theme_header(@_);
 774         $miniserv::page_capture = 1;
 775         return;
 776         }
 777 print "<!doctype html public \"-//W3C//DTD HTML 3.2 Final//EN\">\n";
 778 print "<html>\n";
 779 print "<head>\n";
 780 if (defined(&theme_prehead)) {
 781         &theme_prehead(@_);
 782         }
 783 if ($charset) {
 784         print "<meta http-equiv=\"Content-Type\" ",
 785               "content=\"text/html; Charset=".&quote_escape($charset)."\">\n";
 786         }
 787 if (@_ > 0) {
 788         my $title = &get_html_title($_[0]);
 789         print "<title>$title</title>\n";
 790         print $_[7] if ($_[7]);
 791         print &get_html_status_line(0);
 792         }
 793 print "$tconfig{'headhtml'}\n" if ($tconfig{'headhtml'});
 794 if ($tconfig{'headinclude'}) {
 795         print &read_file_contents(
 796                 "$theme_root_directory/$tconfig{'headinclude'}");
 797         }
 798 print "</head>\n";
 799 my $bgcolor = defined($tconfig{'cs_page'}) ? $tconfig{'cs_page'} :
 800                  defined($gconfig{'cs_page'}) ? $gconfig{'cs_page'} : "ffffff";
 801 my $link = defined($tconfig{'cs_link'}) ? $tconfig{'cs_link'} :
 802               defined($gconfig{'cs_link'}) ? $gconfig{'cs_link'} : "0000ee";
 803 my $text = defined($tconfig{'cs_text'}) ? $tconfig{'cs_text'} :
 804               defined($gconfig{'cs_text'}) ? $gconfig{'cs_text'} : "000000";
 805 my $bgimage = defined($tconfig{'bgimage'}) ? "background=$tconfig{'bgimage'}"
 806                                               : "";
 807 my $dir = $current_lang_info->{'dir'} ? "dir=\"$current_lang_info->{'dir'}\""
 808                                          : "";
 809 print "<body bgcolor=#$bgcolor link=#$link vlink=#$link text=#$text ",
 810       "$bgimage $tconfig{'inbody'} $dir $_[8]>\n";
 811 if (defined(&theme_prebody)) {
 812         &theme_prebody(@_);
 813         }
 814 my $hostname = &get_display_hostname();
 815 my $version = &get_webmin_version();
 816 my $prebody = $tconfig{'prebody'};
 817 if ($prebody) {
 818         $prebody =~ s/%HOSTNAME%/$hostname/g;
 819         $prebody =~ s/%VERSION%/$version/g;
 820         $prebody =~ s/%USER%/$remote_user/g;
 821         $prebody =~ s/%OS%/$os_type $os_version/g;
 822         print "$prebody\n";
 823         }
 824 if ($tconfig{'prebodyinclude'}) {
 825         local $_;
 826         open(INC, "$theme_root_directory/$tconfig{'prebodyinclude'}");
 827         while(<INC>) {
 828                 print;
 829                 }
 830         close(INC);
 831         }
 832 if (@_ > 1) {
 833         print $tconfig{'preheader'};
 834         my %this_module_info = &get_module_info(&get_module_name());
 835         print "<table class='header' width=100%><tr>\n";
 836         if ($gconfig{'sysinfo'} == 2 && $remote_user) {
 837                 print "<td id='headln1' colspan=3 align=center>\n";
 838                 print &get_html_status_line(1);
 839                 print "</td></tr> <tr>\n";
 840                 }
 841         print "<td id='headln2l' width=15% valign=top align=left>";
 842         if ($ENV{'HTTP_WEBMIN_SERVERS'} && !$tconfig{'framed'}) {
 843                 print "<a href='$ENV{'HTTP_WEBMIN_SERVERS'}'>",
 844                       "$text{'header_servers'}</a><br>\n";
 845                 }
 846         if (!$_[5] && !$tconfig{'noindex'}) {
 847                 my @avail = &get_available_module_infos(1);
 848                 my $nolo = $ENV{'ANONYMOUS_USER'} ||
 849                               $ENV{'SSL_USER'} || $ENV{'LOCAL_USER'} ||
 850                               $ENV{'HTTP_USER_AGENT'} =~ /webmin/i;
 851                 if ($gconfig{'gotoone'} && $main::session_id && @avail == 1 &&
 852                     !$nolo) {
 853                         print "<a href='$gconfig{'webprefix'}/session_login.cgi?logout=1'>",
 854                               "$text{'main_logout'}</a><br>";
 855                         }
 856                 elsif ($gconfig{'gotoone'} && @avail == 1 && !$nolo) {
 857                         print "<a href=$gconfig{'webprefix'}/switch_user.cgi>",
 858                               "$text{'main_switch'}</a><br>";
 859                         }
 860                 elsif (!$gconfig{'gotoone'} || @avail > 1) {
 861                         print "<a href='$gconfig{'webprefix'}/?cat=",
 862                               $this_module_info{'category'},
 863                               "'>$text{'header_webmin'}</a><br>\n";
 864                         }
 865                 }
 866         if (!$_[4] && !$tconfig{'nomoduleindex'}) {
 867                 my $idx = $this_module_info{'index_link'};
 868                 my $mi = $module_index_link || "/".&get_module_name()."/$idx";
 869                 my $mt = $module_index_name || $text{'header_module'};
 870                 print "<a href=\"$gconfig{'webprefix'}$mi\">$mt</a><br>\n";
 871                 }
 872         if (ref($_[2]) eq "ARRAY" && !$ENV{'ANONYMOUS_USER'} &&
 873             !$tconfig{'nohelp'}) {
 874                 print &hlink($text{'header_help'}, $_[2]->[0], $_[2]->[1]),
 875                       "<br>\n";
 876                 }
 877         elsif (defined($_[2]) && !$ENV{'ANONYMOUS_USER'} &&
 878                !$tconfig{'nohelp'}) {
 879                 print &hlink($text{'header_help'}, $_[2]),"<br>\n";
 880                 }
 881         if ($_[3]) {
 882                 my %access = &get_module_acl();
 883                 if (!$access{'noconfig'} && !$config{'noprefs'}) {
 884                         my $cprog = $user_module_config_directory ?
 885                                         "uconfig.cgi" : "config.cgi";
 886                         print "<a href=\"$gconfig{'webprefix'}/$cprog?",
 887                               &get_module_name()."\">",
 888                               $text{'header_config'},"</a><br>\n";
 889                         }
 890                 }
 891         print "</td>\n";
 892         if ($_[1]) {
 893                 # Title is a single image
 894                 print "<td id='headln2c' align=center width=70%>",
 895                       "<img alt=\"$_[0]\" src=\"$_[1]\"></td>\n";
 896                 }
 897         else {
 898                 # Title is just text
 899                 my $ts = defined($tconfig{'titlesize'}) ?
 900                                 $tconfig{'titlesize'} : "+2";
 901                 print "<td id='headln2c' align=center width=70%>",
 902                       ($ts ? "<font size=$ts>" : ""),$_[0],
 903                       ($ts ? "</font>" : "");
 904                 print "<br>$_[9]\n" if ($_[9]);
 905                 print "</td>\n";
 906                 }
 907         print "<td id='headln2r' width=15% valign=top align=right>";
 908         print $_[6];
 909         print "</td></tr></table>\n";
 910         print $tconfig{'postheader'};
 911         }
 912 $miniserv::page_capture = 1;
 913 }
 914
 915 =head2 get_html_title(title)
 916
 917 Returns the full string to appear in the HTML <title> block.
 918
 919 =cut
 920 sub get_html_title
 921 {
 922 my ($msg) = @_;
 923 my $title;
 924 my $os_type = $gconfig{'real_os_type'} || $gconfig{'os_type'};
 925 my $os_version = $gconfig{'real_os_version'} || $gconfig{'os_version'};
 926 my $host = &get_display_hostname();
 927 if ($gconfig{'sysinfo'} == 1 && $remote_user) {
 928         $title = sprintf "%s : %s on %s (%s %s)\n",
 929                 $msg, $remote_user, $host,
 930                 $os_type, $os_version;
 931         }
 932 elsif ($gconfig{'sysinfo'} == 4 && $remote_user) {
 933         $title = sprintf "%s on %s (%s %s)\n",
 934                 $remote_user, $host,
 935                 $os_type, $os_version;
 936         }
 937 else {
 938         $title = $msg;
 939         }
 940 if ($gconfig{'showlogin'} && $remote_user) {
 941         $title = $remote_user.($title ? " : ".$title : "");
 942         }
 943 if ($gconfig{'showhost'}) {
 944         $title = $host.($title ? " : ".$title : "");
 945         }
 946 return $title;
 947 }
 948
 949 =head2 get_html_framed_title
 950
 951 Returns the title text for a framed theme main page.
 952
 953 =cut
 954 sub get_html_framed_title
 955 {
 956 my $ostr;
 957 my $os_type = $gconfig{'real_os_type'} || $gconfig{'os_type'};
 958 my $os_version = $gconfig{'real_os_version'} || $gconfig{'os_version'};
 959 my $title;
 960 if (($gconfig{'sysinfo'} == 4 || $gconfig{'sysinfo'} == 1) && $remote_user) {
 961         # Alternate title mode requested
 962         $title = sprintf "%s on %s (%s %s)\n",
 963                 $remote_user, &get_display_hostname(),
 964                 $os_type, $os_version;
 965         }
 966 else {
 967         # Title like 'Webmin x.yy on hostname (Linux 6)'
 968         if ($os_version eq "*") {
 969                 $ostr = $os_type;
 970                 }
 971         else {
 972                 $ostr = "$os_type $os_version";
 973                 }
 974         my $host = &get_display_hostname();
 975         my $ver = &get_webmin_version();
 976         $title = $gconfig{'nohostname'} ? $text{'main_title2'} :
 977                  $gconfig{'showhost'} ? &text('main_title3', $ver, $ostr) :
 978                                         &text('main_title', $ver, $host, $ostr);
 979         if ($gconfig{'showlogin'}) {
 980                 $title = $remote_user.($title ? " : ".$title : "");
 981                 }
 982         if ($gconfig{'showhost'}) {
 983                 $title = $host.($title ? " : ".$title : "");
 984                 }
 985         }
 986 return $title;
 987 }
 988
 989 =head2 get_html_status_line(text-only)
 990
 991 Returns HTML for a script block that sets the status line, or if text-only
 992 is set to 1, just return the status line text.
 993
 994 =cut
 995 sub get_html_status_line
 996 {
 997 my ($textonly) = @_;
 998 if (($gconfig{'sysinfo'} != 0 || !$remote_user) && !$textonly) {
 999         # Disabled in this mode
1000         return undef;
1001         }
1002 my $os_type = $gconfig{'real_os_type'} || $gconfig{'os_type'};
1003 my $os_version = $gconfig{'real_os_version'} || $gconfig{'os_version'};
1004 my $line = &text('header_statusmsg',
1005                  ($ENV{'ANONYMOUS_USER'} ? "Anonymous user"
1006                                            : $remote_user).
1007                  ($ENV{'SSL_USER'} ? " (SSL certified)" :
1008                   $ENV{'LOCAL_USER'} ? " (Local user)" : ""),
1009                  $text{'programname'},
1010                  &get_webmin_version(),
1011                  &get_display_hostname(),
1012                  $os_type.($os_version eq "*" ? "" :" $os_version"));
1013 if ($textonly) {
1014         return $line;
1015         }
1016 else {
1017         $line =~ s/\r|\n//g;
1018         return "<script language=JavaScript type=text/javascript>\n".
1019                "defaultStatus=\"".&quote_escape($line)."\";\n".
1020                "</script>\n";
1021         }
1022 }
1023
1024 =head2 popup_header([title], [head-stuff], [body-stuff], [no-body])
1025
1026 Outputs a page header, suitable for a popup window. If no title is given,
1027 absolutely no decorations are output. Also useful in framesets. The parameters
1028 are :
1029
1030 =item title - Title text for the popup window.
1031
1032 =item head-stuff - HTML to appear in the <head> section.
1033
1034 =item body-stuff - HTML attributes to be include in the <body> tag.
1035
1036 =item no-body - If set to 1, don't generate a body tag
1037
1038 =cut
1039 sub popup_header
1040 {
1041 return if ($main::done_webmin_header++);
1042 my $ll;
1043 my $charset = defined($main::force_charset) ? $main::force_charset
1044                                             : &get_charset();
1045 &PrintHeader($charset);
1046 &load_theme_library();
1047 if (defined(&theme_popup_header)) {
1048         &theme_popup_header(@_);
1049         $miniserv::page_capture = 1;
1050         return;
1051         }
1052 print "<!doctype html public \"-//W3C//DTD HTML 3.2 Final//EN\">\n";
1053 print "<html>\n";
1054 print "<head>\n";
1055 if (defined(&theme_popup_prehead)) {
1056         &theme_popup_prehead(@_);
1057         }
1058 print "<title>$_[0]</title>\n";
1059 print $_[1];
1060 print "$tconfig{'headhtml'}\n" if ($tconfig{'headhtml'});
1061 if ($tconfig{'headinclude'}) {
1062         print &read_file_contents(
1063                 "$theme_root_directory/$tconfig{'headinclude'}");
1064         }
1065 print "</head>\n";
1066 my $bgcolor = defined($tconfig{'cs_page'}) ? $tconfig{'cs_page'} :
1067                  defined($gconfig{'cs_page'}) ? $gconfig{'cs_page'} : "ffffff";
1068 my $link = defined($tconfig{'cs_link'}) ? $tconfig{'cs_link'} :
1069               defined($gconfig{'cs_link'}) ? $gconfig{'cs_link'} : "0000ee";
1070 my $text = defined($tconfig{'cs_text'}) ? $tconfig{'cs_text'} :
1071               defined($gconfig{'cs_text'}) ? $gconfig{'cs_text'} : "000000";
1072 my $bgimage = defined($tconfig{'bgimage'}) ? "background=$tconfig{'bgimage'}"
1073                                               : "";
1074 if (!$_[3]) {
1075         print "<body id='popup' bgcolor=#$bgcolor link=#$link vlink=#$link ",
1076               "text=#$text $bgimage $tconfig{'inbody'} $_[2]>\n";
1077         if (defined(&theme_popup_prebody)) {
1078                 &theme_popup_prebody(@_);
1079                 }
1080         }
1081 $miniserv::page_capture = 1;
1082 }
1083
1084 =head2 footer([page, name]+, [noendbody])
1085
1086 Outputs the footer for a Webmin HTML page, possibly with links back to other
1087 pages. The links are specified by pairs of parameters, the first of which is
1088 a link destination, and the second the link text. For example :
1089
1090  footer('/', 'Webmin index', '', 'Module menu');
1091
1092 =cut
1093 sub footer
1094 {
1095 $miniserv::page_capture = 0;
1096 &load_theme_library();
1097 my %this_module_info = &get_module_info(&get_module_name());
1098 if (defined(&theme_footer)) {
1099         $module_name = &get_module_name();      # Old themes use these
1100         %module_info = %this_module_info;
1101         &theme_footer(@_);
1102         return;
1103         }
1104 for(my $i=0; $i+1<@_; $i+=2) {
1105         my $url = $_[$i];
1106         if ($url ne '/' || !$tconfig{'noindex'}) {
1107                 if ($url eq '/') {
1108                         $url = "/?cat=$this_module_info{'category'}";
1109                         }
1110                 elsif ($url eq '' && &get_module_name()) {
1111                         $url = "/".&get_module_name()."/".
1112                                $this_module_info{'index_link'};
1113                         }
1114                 elsif ($url =~ /^\?/ && &get_module_name()) {
1115                         $url = "/".&get_module_name()."/$url";
1116                         }
1117                 $url = "$gconfig{'webprefix'}$url" if ($url =~ /^\//);
1118                 if ($i == 0) {
1119                         print "<a href=\"$url\"><img alt=\"<-\" align=middle border=0 src=$gconfig{'webprefix'}/images/left.gif></a>\n";
1120                         }
1121                 else {
1122                         print "&nbsp;|\n";
1123                         }
1124                 print "&nbsp;<a href=\"$url\">",&text('main_return', $_[$i+1]),"</a>\n";
1125                 }
1126         }
1127 print "<br>\n";
1128 if (!$_[$i]) {
1129         my $postbody = $tconfig{'postbody'};
1130         if ($postbody) {
1131                 my $hostname = &get_display_hostname();
1132                 my $version = &get_webmin_version();
1133                 my $os_type = $gconfig{'real_os_type'} ||
1134                               $gconfig{'os_type'};
1135                 my $os_version = $gconfig{'real_os_version'} ||
1136                                  $gconfig{'os_version'};
1137                 $postbody =~ s/%HOSTNAME%/$hostname/g;
1138                 $postbody =~ s/%VERSION%/$version/g;
1139                 $postbody =~ s/%USER%/$remote_user/g;
1140                 $postbody =~ s/%OS%/$os_type $os_version/g;
1141                 print "$postbody\n";
1142                 }
1143         if ($tconfig{'postbodyinclude'}) {
1144                 local $_;
1145                 open(INC, "$theme_root_directory/$tconfig{'postbodyinclude'}");
1146                 while(<INC>) {
1147                         print;
1148                         }
1149                 close(INC);
1150                 }
1151         if (defined(&theme_postbody)) {
1152                 &theme_postbody(@_);
1153                 }
1154         print "</body></html>\n";
1155         }
1156 }
1157
1158 =head2 popup_footer([no-body])
1159
1160 Outputs html for a footer for a popup window, started by popup_header.
1161
1162 =cut
1163 sub popup_footer
1164 {
1165 $miniserv::page_capture = 0;
1166 &load_theme_library();
1167 if (defined(&theme_popup_footer)) {
1168         &theme_popup_footer(@_);
1169         return;
1170         }
1171 if (!$_[0]) {
1172         print "</body>\n";
1173         }
1174 print "</html>\n";
1175 }
1176
1177 =head2 load_theme_library
1178
1179 Immediately loads the current theme's theme.pl file. Not generally useful for
1180 most module developers, as this is called automatically by the header function.
1181
1182 =cut
1183 sub load_theme_library
1184 {
1185 return if (!$current_theme || $loaded_theme_library++);
1186 for(my $i=0; $i<@theme_root_directories; $i++) {
1187         if ($theme_configs[$i]->{'functions'}) {
1188                 do $theme_root_directories[$i]."/".
1189                    $theme_configs[$i]->{'functions'};
1190                 }
1191         }
1192 }
1193
1194 =head2 redirect(url)
1195
1196 Output HTTP headers to redirect the browser to some page. The url parameter is
1197 typically a relative URL like index.cgi or list_users.cgi.
1198
1199 =cut
1200 sub redirect
1201 {
1202 my $port = $ENV{'SERVER_PORT'} == 443 && uc($ENV{'HTTPS'}) eq "ON" ? "" :
1203            $ENV{'SERVER_PORT'} == 80 && uc($ENV{'HTTPS'}) ne "ON" ? "" :
1204                 ":$ENV{'SERVER_PORT'}";
1205 my $prot = uc($ENV{'HTTPS'}) eq "ON" ? "https" : "http";
1206 my $wp = $gconfig{'webprefixnoredir'} ? undef : $gconfig{'webprefix'};
1207 my $url;
1208 if ($_[0] =~ /^(http|https|ftp|gopher):/) {
1209         # Absolute URL (like http://...)
1210         $url = $_[0];
1211         }
1212 elsif ($_[0] =~ /^\//) {
1213         # Absolute path (like /foo/bar.cgi)
1214         $url = "$prot://$ENV{'SERVER_NAME'}$port$wp$_[0]";
1215         }
1216 elsif ($ENV{'SCRIPT_NAME'} =~ /^(.*)\/[^\/]*$/) {
1217         # Relative URL (like foo.cgi)
1218         $url = "$prot://$ENV{'SERVER_NAME'}$port$wp$1/$_[0]";
1219         }
1220 else {
1221         $url = "$prot://$ENV{'SERVER_NAME'}$port/$wp$_[0]";
1222         }
1223 &load_theme_library();
1224 if (defined(&theme_redirect)) {
1225         $module_name = &get_module_name();      # Old themes use these
1226         %module_info = &get_module_info($module_name);
1227         &theme_redirect($_[0], $url);
1228         }
1229 else {
1230         print "Location: $url\n\n";
1231         }
1232 }
1233
1234 =head2 kill_byname(name, signal)
1235
1236 Finds a process whose command line contains the given name (such as httpd), and
1237 sends some signal to it. The signal can be numeric (like 9) or named
1238 (like KILL).
1239
1240 =cut
1241 sub kill_byname
1242 {
1243 my @pids = &find_byname($_[0]);
1244 return scalar(@pids) if (&is_readonly_mode());
1245 &webmin_debug_log('KILL', "signal=$_[1] name=$_[0]")
1246         if ($gconfig{'debug_what_procs'});
1247 if (@pids) { kill($_[1], @pids); return scalar(@pids); }
1248 else { return 0; }
1249 }
1250
1251 =head2 kill_byname_logged(name, signal)
1252
1253 Like kill_byname, but also logs the killing.
1254
1255 =cut
1256 sub kill_byname_logged
1257 {
1258 my @pids = &find_byname($_[0]);
1259 return scalar(@pids) if (&is_readonly_mode());
1260 if (@pids) { &kill_logged($_[1], @pids); return scalar(@pids); }
1261 else { return 0; }
1262 }
1263
1264 =head2 find_byname(name)
1265
1266 Finds processes searching for the given name in their command lines, and
1267 returns a list of matching PIDs.
1268
1269 =cut
1270 sub find_byname
1271 {
1272 if ($gconfig{'os_type'} =~ /-linux$/ && -r "/proc/$$/cmdline") {
1273         # Linux with /proc filesystem .. use cmdline files, as this is
1274         # faster than forking
1275         my @pids;
1276         opendir(PROCDIR, "/proc");
1277         foreach my $f (readdir(PROCDIR)) {
1278                 if ($f eq int($f) && $f != $$) {
1279                         my $line = &read_file_contents("/proc/$f/cmdline");
1280                         if ($line =~ /$_[0]/) {
1281                                 push(@pids, $f);
1282                                 }
1283                         }
1284                 }
1285         closedir(PROCDIR);
1286         return @pids;
1287         }
1288
1289 if (&foreign_check("proc")) {
1290         # Call the proc module
1291         &foreign_require("proc", "proc-lib.pl");
1292         if (defined(&proc::list_processes)) {
1293                 my @procs = &proc::list_processes();
1294                 my @pids;
1295                 foreach my $p (@procs) {
1296                         if ($p->{'args'} =~ /$_[0]/) {
1297                                 push(@pids, $p->{'pid'});
1298                                 }
1299                         }
1300                 @pids = grep { $_ != $$ } @pids;
1301                 return @pids;
1302                 }
1303         }
1304
1305 # Fall back to running a command
1306 my ($cmd, @pids);
1307 $cmd = $gconfig{'find_pid_command'};
1308 $cmd =~ s/NAME/"$_[0]"/g;
1309 $cmd = &translate_command($cmd);
1310 @pids = split(/\n/, `($cmd) <$null_file 2>$null_file`);
1311 @pids = grep { $_ != $$ } @pids;
1312 return @pids;
1313 }
1314
1315 =head2 error([message]+)
1316
1317 Display an error message and exit. This should be used by CGI scripts that
1318 encounter a fatal error or invalid user input to notify users of the problem.
1319 If error_setup has been called, the displayed error message will be prefixed
1320 by the message setup using that function.
1321
1322 =cut
1323 sub error
1324 {
1325 $main::no_miniserv_userdb = 1;
1326 my $msg = join("", @_);
1327 $msg =~ s/<[^>]*>//g;
1328 if (!$main::error_must_die) {
1329         print STDERR "Error: ",$msg,"\n";
1330         }
1331 &load_theme_library();
1332 if ($main::error_must_die) {
1333         if ($gconfig{'error_stack'}) {
1334                 print STDERR "Error: ",$msg,"\n";
1335                 for(my $i=0; my @stack = caller($i); $i++) {
1336                         print STDERR "File: $stack[1] Line: $stack[2] ",
1337                                      "Function: $stack[3]\n";
1338                         }
1339                 }
1340         die @_;
1341         }
1342 elsif (!$ENV{'REQUEST_METHOD'}) {
1343         # Show text-only error
1344         print STDERR "$text{'error'}\n";
1345         print STDERR "-----\n";
1346         print STDERR ($main::whatfailed ? "$main::whatfailed : " : ""),
1347                      $msg,"\n";
1348         print STDERR "-----\n";
1349         if ($gconfig{'error_stack'}) {
1350                 # Show call stack
1351                 print STDERR $text{'error_stack'},"\n";
1352                 for(my $i=0; my @stack = caller($i); $i++) {
1353                         print STDERR &text('error_stackline',
1354                                 $stack[1], $stack[2], $stack[3]),"\n";
1355                         }
1356                 }
1357
1358         }
1359 elsif (defined(&theme_error)) {
1360         &theme_error(@_);
1361         }
1362 else {
1363         &header($text{'error'}, "");
1364         print "<hr>\n";
1365         print "<h3>",($main::whatfailed ? "$main::whatfailed : " : ""),
1366                      @_,"</h3>\n";
1367         if ($gconfig{'error_stack'}) {
1368                 # Show call stack
1369                 print "<h3>$text{'error_stack'}</h3>\n";
1370                 print "<table>\n";
1371                 print "<tr> <td><b>$text{'error_file'}</b></td> ",
1372                       "<td><b>$text{'error_line'}</b></td> ",
1373                       "<td><b>$text{'error_sub'}</b></td> </tr>\n";
1374                 for($i=0; my @stack = caller($i); $i++) {
1375                         print "<tr>\n";
1376                         print "<td>$stack[1]</td>\n";
1377                         print "<td>$stack[2]</td>\n";
1378                         print "<td>$stack[3]</td>\n";
1379                         print "</tr>\n";
1380                         }
1381                 print "</table>\n";
1382                 }
1383         print "<hr>\n";
1384         if ($ENV{'HTTP_REFERER'} && $main::completed_referers_check) {
1385                 &footer($ENV{'HTTP_REFERER'}, $text{'error_previous'});
1386                 }
1387         else {
1388                 &footer();
1389                 }
1390         }
1391 &unlock_all_files();
1392 &cleanup_tempnames();
1393 exit(1);
1394 }
1395
1396 =head2 popup_error([message]+)
1397
1398 This function is almost identical to error, but displays the message with HTML
1399 headers suitable for a popup window.
1400
1401 =cut
1402 sub popup_error
1403 {
1404 $main::no_miniserv_userdb = 1;
1405 &load_theme_library();
1406 if ($main::error_must_die) {
1407         die @_;
1408         }
1409 elsif (defined(&theme_popup_error)) {
1410         &theme_popup_error(@_);
1411         }
1412 else {
1413         &popup_header($text{'error'}, "");
1414         print "<h3>",($main::whatfailed ? "$main::whatfailed : " : ""),@_,"</h3>\n";
1415         &popup_footer();
1416         }
1417 &unlock_all_files();
1418 &cleanup_tempnames();
1419 exit;
1420 }
1421
1422 =head2 error_setup(message)
1423
1424 Registers a message to be prepended to all error messages displayed by the
1425 error function.
1426
1427 =cut
1428 sub error_setup
1429 {
1430 $main::whatfailed = $_[0];
1431 }
1432
1433 =head2 wait_for(handle, regexp, regexp, ...)
1434
1435 Reads from the input stream until one of the regexps matches, and returns the
1436 index of the matching regexp, or -1 if input ended before any matched. This is
1437 very useful for parsing the output of interactive programs, and can be used with
1438 a two-way pipe to feed input to a program in response to output matched by
1439 this function.
1440
1441 If the matching regexp contains bracketed sub-expressions, their values will
1442 be placed in the global array @matches, indexed starting from 1. You cannot
1443 use the Perl variables $1, $2 and so on to capture matches.
1444
1445 Example code:
1446
1447  $rv = wait_for($loginfh, "username:");
1448  if ($rv == -1) {
1449    error("Didn't get username prompt");
1450  }
1451  print $loginfh "joe\n";
1452  $rv = wait_for($loginfh, "password:");
1453  if ($rv == -1) {
1454    error("Didn't get password prompt");
1455  }
1456  print $loginfh "smeg\n";
1457
1458 =cut
1459 sub wait_for
1460 {
1461 my ($c, $i, $sw, $rv, $ha);
1462 undef($wait_for_input);
1463 if ($wait_for_debug) {
1464         print STDERR "wait_for(",join(",", @_),")\n";
1465         }
1466 $ha = &callers_package($_[0]);
1467 if ($wait_for_debug) {
1468         print STDERR "File handle=$ha fd=",fileno($ha),"\n";
1469         }
1470 $codes =
1471 "my \$hit;\n".
1472 "while(1) {\n".
1473 " if ((\$c = getc(\$ha)) eq \"\") { return -1; }\n".
1474 " \$wait_for_input .= \$c;\n";
1475 if ($wait_for_debug) {
1476         $codes .= "print STDERR \$wait_for_input,\"\\n\";";
1477         }
1478 for($i=1; $i<@_; $i++) {
1479         $sw = $i>1 ? "elsif" : "if";
1480         $codes .= " $sw (\$wait_for_input =~ /$_[$i]/i) { \$hit = $i-1; }\n";
1481         }
1482 $codes .=
1483 " if (defined(\$hit)) {\n".
1484 "  \@matches = (-1, \$1, \$2, \$3, \$4, \$5, \$6, \$7, \$8, \$9);\n".
1485 "  return \$hit;\n".
1486 "  }\n".
1487 " }\n";
1488 $rv = eval $codes;
1489 if ($@) {
1490         &error("wait_for error : $@\n");
1491         }
1492 return $rv;
1493 }
1494
1495 =head2 fast_wait_for(handle, string, string, ...)
1496
1497 This function behaves very similar to wait_for (documented above), but instead
1498 of taking regular expressions as parameters, it takes strings. As soon as the
1499 input contains one of them, it will return the index of the matching string.
1500 If the input ends before any match, it returns -1.
1501
1502 =cut
1503 sub fast_wait_for
1504 {
1505 my ($inp, $maxlen, $ha, $i, $c, $inpl);
1506 for($i=1; $i<@_; $i++) {
1507         $maxlen = length($_[$i]) > $maxlen ? length($_[$i]) : $maxlen;
1508         }
1509 $ha = $_[0];
1510 while(1) {
1511         if (($c = getc($ha)) eq "") {
1512                 &error("fast_wait_for read error : $!");
1513                 }
1514         $inp .= $c;
1515         if (length($inp) > $maxlen) {
1516                 $inp = substr($inp, length($inp)-$maxlen);
1517                 }
1518         $inpl = length($inp);
1519         for($i=1; $i<@_; $i++) {
1520                 if ($_[$i] eq substr($inp, $inpl-length($_[$i]))) {
1521                         return $i-1;
1522                         }
1523                 }
1524         }
1525 }
1526
1527 =head2 has_command(command)
1528
1529 Returns the full path to the executable if some command is in the path, or
1530 undef if not found. If the given command is already an absolute path and
1531 exists, then the same path will be returned.
1532
1533 =cut
1534 sub has_command
1535 {
1536 if (!$_[0]) { return undef; }
1537 if (exists($main::has_command_cache{$_[0]})) {
1538         return $main::has_command_cache{$_[0]};
1539         }
1540 my $rv = undef;
1541 my $slash = $gconfig{'os_type'} eq 'windows' ? '\\' : '/';
1542 if ($_[0] =~ /^\// || $_[0] =~ /^[a-z]:[\\\/]/i) {
1543         # Absolute path given - just use it
1544         my $t = &translate_filename($_[0]);
1545         $rv = (-x $t && !-d _) ? $_[0] : undef;
1546         }
1547 else {
1548         # Check each directory in the path
1549         my %donedir;
1550         foreach my $d (split($path_separator, $ENV{'PATH'})) {
1551                 next if ($donedir{$d}++);
1552                 $d =~ s/$slash$// if ($d ne $slash);
1553                 my $t = &translate_filename("$d/$_[0]");
1554                 if (-x $t && !-d _) {
1555                         $rv = $d.$slash.$_[0];
1556                         last;
1557                         }
1558                 if ($gconfig{'os_type'} eq 'windows') {
1559                         foreach my $sfx (".exe", ".com", ".bat") {
1560                                 my $t = &translate_filename("$d/$_[0]").$sfx;
1561                                 if (-r $t && !-d _) {
1562                                         $rv = $d.$slash.$_[0].$sfx;
1563                                         last;
1564                                         }
1565                                 }
1566                         }
1567                 }
1568         }
1569 $main::has_command_cache{$_[0]} = $rv;
1570 return $rv;
1571 }
1572
1573 =head2 make_date(seconds, [date-only], [fmt])
1574
1575 Converts a Unix date/time in seconds to a human-readable form, by default
1576 formatted like dd/mmm/yyyy hh:mm:ss. Parameters are :
1577
1578 =item seconds - Unix time is seconds to convert.
1579
1580 =item date-only - If set to 1, exclude the time from the returned string.
1581
1582 =item fmt - Optional, one of dd/mon/yyyy, dd/mm/yyyy, mm/dd/yyyy or yyyy/mm/dd
1583
1584 =cut
1585 sub make_date
1586 {
1587 my ($secs, $only, $fmt) = @_;
1588 my @tm = localtime($secs);
1589 my $date;
1590 if (!$fmt) {
1591         $fmt = $gconfig{'dateformat'} || 'dd/mon/yyyy';
1592         }
1593 if ($fmt eq 'dd/mon/yyyy') {
1594         $date = sprintf "%2.2d/%s/%4.4d",
1595                         $tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900;
1596         }
1597 elsif ($fmt eq 'dd/mm/yyyy') {
1598         $date = sprintf "%2.2d/%2.2d/%4.4d", $tm[3], $tm[4]+1, $tm[5]+1900;
1599         }
1600 elsif ($fmt eq 'mm/dd/yyyy') {
1601         $date = sprintf "%2.2d/%2.2d/%4.4d", $tm[4]+1, $tm[3], $tm[5]+1900;
1602         }
1603 elsif ($fmt eq 'yyyy/mm/dd') {
1604         $date = sprintf "%4.4d/%2.2d/%2.2d", $tm[5]+1900, $tm[4]+1, $tm[3];
1605         }
1606 elsif ($fmt eq 'd. mon yyyy') {
1607         $date = sprintf "%d. %s %4.4d",
1608                         $tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900;
1609         }
1610 elsif ($fmt eq 'dd.mm.yyyy') {
1611         $date = sprintf "%2.2d.%2.2d.%4.4d", $tm[3], $tm[4]+1, $tm[5]+1900;
1612         }
1613 elsif ($fmt eq 'yyyy-mm-dd') {
1614         $date = sprintf "%4.4d-%2.2d-%2.2d", $tm[5]+1900, $tm[4]+1, $tm[3];
1615         }
1616 if (!$only) {
1617         $date .= sprintf " %2.2d:%2.2d", $tm[2], $tm[1];
1618         }
1619 return $date;
1620 }
1621
1622 =head2 file_chooser_button(input, type, [form], [chroot], [addmode])
1623
1624 Return HTML for a button that pops up a file chooser when clicked, and places
1625 the selected filename into another HTML field. The parameters are :
1626
1627 =item input - Name of the form field to store the filename in.
1628
1629 =item type - 0 for file or directory chooser, or 1 for directory only.
1630
1631 =item form - Index of the form containing the button.
1632
1633 =item chroot - If set to 1, the chooser will be limited to this directory.
1634
1635 =item addmode - If set to 1, the selected filename will be appended to the text box instead of replacing it's contents.
1636
1637 =cut
1638 sub file_chooser_button
1639 {
1640 return &theme_file_chooser_button(@_)
1641         if (defined(&theme_file_chooser_button));
1642 my $form = defined($_[2]) ? $_[2] : 0;
1643 my $chroot = defined($_[3]) ? $_[3] : "/";
1644 my $add = int($_[4]);
1645 my ($w, $h) = (400, 300);
1646 if ($gconfig{'db_sizefile'}) {
1647         ($w, $h) = split(/x/, $gconfig{'db_sizefile'});
1648         }
1649 return "<input type=button onClick='ifield = form.$_[0]; chooser = window.open(\"$gconfig{'webprefix'}/chooser.cgi?add=$add&type=$_[1]&chroot=$chroot&file=\"+escape(ifield.value), \"chooser\", \"toolbar=no,menubar=no,scrollbars=no,resizable=yes,width=$w,height=$h\"); chooser.ifield = ifield; window.ifield = ifield' value=\"...\">\n";
1650 }
1651
1652 =head2 popup_window_button(url, width, height, scrollbars?, &field-mappings)
1653
1654 Returns HTML for a button that will popup a chooser window of some kind. The
1655 parameters are :
1656
1657 =item url - Base URL of the popup window's contents
1658
1659 =item width - Width of the window in pixels
1660
1661 =item height - Height in pixels
1662
1663 =item scrollbars - Set to 1 if the window should have scrollbars
1664
1665 The field-mappings parameter is an array ref of array refs containing
1666
1667 =item - Attribute to assign field to in the popup window
1668
1669 =item - Form field name
1670
1671 =item - CGI parameter to URL for value, if any
1672
1673 =cut
1674 sub popup_window_button
1675 {
1676 return &theme_popup_window_button(@_) if (defined(&theme_popup_window_button));
1677 my ($url, $w, $h, $scroll, $fields) = @_;
1678 my $scrollyn = $scroll ? "yes" : "no";
1679 my $rv = "<input type=button onClick='";
1680 foreach my $m (@$fields) {
1681         $rv .= "$m->[0] = form.$m->[1]; ";
1682         }
1683 my $sep = $url =~ /\?/ ? "&" : "?";
1684 $rv .= "chooser = window.open(\"$url\"";
1685 foreach my $m (@$fields) {
1686         if ($m->[2]) {
1687                 $rv .= "+\"$sep$m->[2]=\"+escape($m->[0].value)";
1688                 $sep = "&";
1689                 }
1690         }
1691 $rv .= ", \"chooser\", \"toolbar=no,menubar=no,scrollbars=$scrollyn,resizable=yes,width=$w,height=$h\"); ";
1692 foreach my $m (@$fields) {
1693         $rv .= "chooser.$m->[0] = $m->[0]; ";
1694         $rv .= "window.$m->[0] = $m->[0]; ";
1695         }
1696 $rv .= "' value=\"...\">";
1697 return $rv;
1698 }
1699
1700 =head2 read_acl(&user-module-hash, &user-list-hash, [&only-users])
1701
1702 Reads the Webmin acl file into the given hash references. The first is indexed
1703 by a combined key of username,module , with the value being set to 1 when
1704 the user has access to that module. The second is indexed by username, with
1705 the value being an array ref of allowed modules.
1706
1707 This function is deprecated in favour of foreign_available, which performs a
1708 more comprehensive check of module availability.
1709
1710 If the only-users array ref parameter is given, the results may be limited to
1711 users in that list of names.
1712
1713 =cut
1714 sub read_acl
1715 {
1716 my ($usermod, $userlist, $only) = @_;
1717 if (!%main::acl_hash_cache) {
1718         # Read from local files
1719         local $_;
1720         open(ACL, &acl_filename());
1721         while(<ACL>) {
1722                 if (/^([^:]+):\s*(.*)/) {
1723                         my $user = $1;
1724                         my @mods = split(/\s+/, $2);
1725                         foreach my $m (@mods) {
1726                                 $main::acl_hash_cache{$user,$m}++;
1727                                 }
1728                         $main::acl_array_cache{$user} = \@mods;
1729                         }
1730                 }
1731         close(ACL);
1732         }
1733 %$usermod = %main::acl_hash_cache if ($usermod);
1734 %$userlist = %main::acl_array_cache if ($userlist);
1735
1736 # Read from user DB
1737 my $userdb = &get_userdb_string();
1738 my ($dbh, $proto, $prefix, $args) =
1739         $userdb ? &connect_userdb($userdb) : ( );
1740 if (ref($dbh)) {
1741         if ($proto eq "mysql" || $proto eq "postgresql") {
1742                 # Select usernames and modules from SQL DB
1743                 my $cmd = $dbh->prepare(
1744                         "select webmin_user.name,webmin_user_attr.value ".
1745                         "from webmin_user,webmin_user_attr ".
1746                         "where webmin_user.id = webmin_user_attr.id ".
1747                         "and webmin_user_attr.attr = 'modules' ".
1748                         ($only ? " and webmin_user.name in (".
1749                                  join(",", map { "'$_'" } @$only).")" : ""));
1750                 if ($cmd && $cmd->execute()) {
1751                         while(my ($user, $mods) = $cmd->fetchrow()) {
1752                                 my @mods = split(/\s+/, $mods);
1753                                 foreach my $m (@mods) {
1754                                         $usermod->{$user,$m}++ if ($usermod);
1755                                         }
1756                                 $userlist->{$user} = \@mods if ($userlist);
1757                                 }
1758                         }
1759                 $cmd->finish() if ($cmd);
1760                 }
1761         elsif ($proto eq "ldap") {
1762                 # Find users in LDAP
1763                 my $filter = '(objectClass='.$args->{'userclass'}.')';
1764                 if ($only) {
1765                         my $ufilter =
1766                                 "(|".join("", map { "(cn=$_)" } @$only).")";
1767                         $filter = "(&".$filter.$ufilter.")";
1768                         }
1769                 my $rv = $dbh->search(
1770                         base => $prefix,
1771                         filter => $filter,
1772                         scope => 'sub',
1773                         attrs => [ 'cn', 'webminModule' ]);
1774                 if ($rv && !$rv->code) {
1775                         foreach my $u ($rv->all_entries) {
1776                                 my $user = $u->get_value('cn');
1777                                 my @mods =$u->get_value('webminModule');
1778                                 foreach my $m (@mods) {
1779                                         $usermod->{$user,$m}++ if ($usermod);
1780                                         }
1781                                 $userlist->{$user} = \@mods if ($userlist);
1782                                 }
1783                         }
1784                 }
1785         &disconnect_userdb($userdb, $dbh);
1786         }
1787 }
1788
1789 =head2 acl_filename
1790
1791 Returns the file containing the webmin ACL, which is usually
1792 /etc/webmin/webmin.acl.
1793
1794 =cut
1795 sub acl_filename
1796 {
1797 return "$config_directory/webmin.acl";
1798 }
1799
1800 =head2 acl_check
1801
1802 Does nothing, but kept around for compatability.
1803
1804 =cut
1805 sub acl_check
1806 {
1807 }
1808
1809 =head2 get_miniserv_config(&hash)
1810
1811 Reads the Webmin webserver's (miniserv.pl) configuration file, usually located
1812 at /etc/webmin/miniserv.conf, and stores its names and values in the given
1813 hash reference.
1814
1815 =cut
1816 sub get_miniserv_config
1817 {
1818 return &read_file_cached(
1819         $ENV{'MINISERV_CONFIG'} || "$config_directory/miniserv.conf", $_[0]);
1820 }
1821
1822 =head2 put_miniserv_config(&hash)
1823
1824 Writes out the Webmin webserver configuration file from the contents of
1825 the given hash ref. This should be initially populated by get_miniserv_config,
1826 like so :
1827
1828  get_miniserv_config(\%miniserv);
1829  $miniserv{'port'} = 10005;
1830  put_miniserv_config(\%miniserv);
1831  restart_miniserv();
1832
1833 =cut
1834 sub put_miniserv_config
1835 {
1836 &write_file($ENV{'MINISERV_CONFIG'} || "$config_directory/miniserv.conf",
1837             $_[0]);
1838 }
1839
1840 =head2 restart_miniserv([nowait])
1841
1842 Kill the old miniserv process and re-start it, then optionally waits for
1843 it to restart. This will apply all configuration settings.
1844
1845 =cut
1846 sub restart_miniserv
1847 {
1848 my ($nowait) = @_;
1849 return undef if (&is_readonly_mode());
1850 my %miniserv;
1851 &get_miniserv_config(\%miniserv) || return;
1852
1853 my $i;
1854 if ($gconfig{'os_type'} ne 'windows') {
1855         # On Unix systems, we can restart with a signal
1856         my ($pid, $addr, $i);
1857         $miniserv{'inetd'} && return;
1858         my @oldst = stat($miniserv{'pidfile'});
1859         $pid = $ENV{'MINISERV_PID'};
1860         if (!$pid) {
1861                 open(PID, $miniserv{'pidfile'}) ||
1862                         &error("Failed to open PID file $miniserv{'pidfile'}");
1863                 chop($pid = <PID>);
1864                 close(PID);
1865                 $pid || &error("Invalid PID file $miniserv{'pidfile'}");
1866                 }
1867
1868         # Just signal miniserv to restart
1869         &kill_logged('HUP', $pid) || &error("Incorrect Webmin PID $pid");
1870
1871         # Wait till new PID is written, indicating a restart
1872         for($i=0; $i<60; $i++) {
1873                 sleep(1);
1874                 my @newst = stat($miniserv{'pidfile'});
1875                 last if ($newst[9] != $oldst[9]);
1876                 }
1877         $i < 60 || &error("Webmin server did not write new PID file");
1878
1879         ## Totally kill the process and re-run it
1880         #$SIG{'TERM'} = 'IGNORE';
1881         #&kill_logged('TERM', $pid);
1882         #&system_logged("$config_directory/start >/dev/null 2>&1 </dev/null");
1883         }
1884 else {
1885         # On Windows, we need to use the flag file
1886         open(TOUCH, ">$miniserv{'restartflag'}");
1887         close(TOUCH);
1888         }
1889
1890 if (!$nowait) {
1891         # Wait for miniserv to come back up
1892         my $addr = $miniserv{'bind'} || "127.0.0.1";
1893         my $ok = 0;
1894         for($i=0; $i<20; $i++) {
1895                 my $err;
1896                 sleep(1);
1897                 &open_socket($addr, $miniserv{'port'}, STEST, \$err);
1898                 close(STEST);
1899                 last if (!$err && ++$ok >= 2);
1900                 }
1901         $i < 20 || &error("Failed to restart Webmin server!");
1902         }
1903 }
1904
1905 =head2 reload_miniserv
1906
1907 Sends a USR1 signal to the miniserv process, telling it to read-read it's
1908 configuration files. Not all changes will be applied though, such as the
1909 IP addresses and ports to accept connections on.
1910
1911 =cut
1912 sub reload_miniserv
1913 {
1914 return undef if (&is_readonly_mode());
1915 my %miniserv;
1916 &get_miniserv_config(\%miniserv) || return;
1917
1918 if ($gconfig{'os_type'} ne 'windows') {
1919         # Send a USR1 signal to re-read the config
1920         my ($pid, $addr, $i);
1921         $miniserv{'inetd'} && return;
1922         $pid = $ENV{'MINISERV_PID'};
1923         if (!$pid) {
1924                 open(PID, $miniserv{'pidfile'}) ||
1925                         &error("Failed to open PID file $miniserv{'pidfile'}");
1926                 chop($pid = <PID>);
1927                 close(PID);
1928                 $pid || &error("Invalid PID file $miniserv{'pidfile'}");
1929                 }
1930         &kill_logged('USR1', $pid) || &error("Incorrect Webmin PID $pid");
1931
1932         # Make sure this didn't kill Webmin!
1933         sleep(1);
1934         if (!kill(0, $pid)) {
1935                 print STDERR "USR1 signal killed Webmin - restarting\n";
1936                 &system_logged("$config_directory/start >/dev/null 2>&1 </dev/null");
1937                 }
1938         }
1939 else {
1940         # On Windows, we need to use the flag file
1941         open(TOUCH, ">$miniserv{'reloadflag'}");
1942         close(TOUCH);
1943         }
1944 }
1945
1946 =head2 check_os_support(&minfo, [os-type, os-version], [api-only])
1947
1948 Returns 1 if some module is supported on the current operating system, or the
1949 OS supplies as parameters. The parameters are :
1950
1951 =item minfo - A hash ref of module information, as returned by get_module_info
1952
1953 =item os-type - The Webmin OS code to use instead of the system's real OS, such as redhat-linux
1954
1955 =item os-version - The Webmin OS version to use, such as 13.0
1956
1957 =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.
1958
1959 =cut
1960 sub check_os_support
1961 {
1962 my $oss = $_[0]->{'os_support'};
1963 if ($_[3] && $oss && $_[0]->{'api_os_support'}) {
1964         # May provide usable API
1965         $oss .= " ".$_[0]->{'api_os_support'};
1966         }
1967 if ($_[0]->{'nozone'} && &running_in_zone()) {
1968         # Not supported in a Solaris Zone
1969         return 0;
1970         }
1971 if ($_[0]->{'novserver'} && &running_in_vserver()) {
1972         # Not supported in a Linux Vserver
1973         return 0;
1974         }
1975 if ($_[0]->{'noopenvz'} && &running_in_openvz()) {
1976         # Not supported in an OpenVZ container
1977         return 0;
1978         }
1979 return 1 if (!$oss || $oss eq '*');
1980 my $osver = $_[2] || $gconfig{'os_version'};
1981 my $ostype = $_[1] || $gconfig{'os_type'};
1982 my $anyneg = 0;
1983 while(1) {
1984         my ($os, $ver, $codes);
1985         my ($neg) = ($oss =~ s/^!//);   # starts with !
1986         $anyneg++ if ($neg);
1987         if ($oss =~ /^([^\/\s]+)\/([^\{\s]+)\{([^\}]*)\}\s*(.*)$/) {
1988                 # OS/version{code}
1989                 $os = $1; $ver = $2; $codes = $3; $oss = $4;
1990                 }
1991         elsif ($oss =~ /^([^\/\s]+)\/([^\/\s]+)\s*(.*)$/) {
1992                 # OS/version
1993                 $os = $1; $ver = $2; $oss = $3;
1994                 }
1995         elsif ($oss =~ /^([^\{\s]+)\{([^\}]*)\}\s*(.*)$/) {
1996                 # OS/{code}
1997                 $os = $1; $codes = $2; $oss = $3;
1998                 }
1999         elsif ($oss =~ /^\{([^\}]*)\}\s*(.*)$/) {
2000                 # {code}
2001                 $codes = $1; $oss = $2;
2002                 }
2003         elsif ($oss =~ /^(\S+)\s*(.*)$/) {
2004                 # OS
2005                 $os = $1; $oss = $2;
2006                 }
2007         else { last; }
2008         next if ($os && !($os eq $ostype ||
2009                           $ostype =~ /^(\S+)-(\S+)$/ && $os eq "*-$2"));
2010         if ($ver =~ /^([0-9\.]+)\-([0-9\.]+)$/) {
2011                 next if ($osver < $1 || $osver > $2);
2012                 }
2013         elsif ($ver =~ /^([0-9\.]+)\-\*$/) {
2014                 next if ($osver < $1);
2015                 }
2016         elsif ($ver =~ /^\*\-([0-9\.]+)$/) {
2017                 next if ($osver > $1);
2018                 }
2019         elsif ($ver) {
2020                 next if ($ver ne $osver);
2021                 }
2022         next if ($codes && !eval $codes);
2023         return !$neg;
2024         }
2025 return $anyneg;
2026 }
2027
2028 =head2 http_download(host, port, page, destfile, [&error], [&callback], [sslmode], [user, pass], [timeout], [osdn-convert], [no-cache], [&headers])
2029
2030 Downloads data from a HTTP url to a local file or string. The parameters are :
2031
2032 =item host - The hostname part of the URL, such as www.google.com
2033
2034 =item port - The HTTP port number, such as 80
2035
2036 =item page - The filename part of the URL, like /index.html
2037
2038 =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.
2039
2040 =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.
2041
2042 =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.
2043
2044 =item sslmode - If set to 1, an HTTPS connection is used instead of HTTP.
2045
2046 =item user - If set, HTTP authentication is done with this username.
2047
2048 =item pass - The HTTP password to use with the username above.
2049
2050 =item timeout - A timeout in seconds to wait for the TCP connection to be established before failing.
2051
2052 =item osdn-convert - If set to 1, URL for downloads from sourceforge are converted to use an appropriate mirror site.
2053
2054 =item no-cache - If set to 1, Webmin's internal caching for this URL is disabled.
2055
2056 =item headers - If set to a hash ref of additional HTTP headers, they will be added to the request.
2057
2058 =cut
2059 sub http_download
2060 {
2061 my ($host, $port, $page, $dest, $error, $cbfunc, $ssl, $user, $pass,
2062     $timeout, $osdn, $nocache, $headers) = @_;
2063 if ($gconfig{'debug_what_net'}) {
2064         &webmin_debug_log('HTTP', "host=$host port=$port page=$page ssl=$ssl".
2065                                   ($user ? " user=$user pass=$pass" : "").
2066                                   (ref($dest) ? "" : " dest=$dest"));
2067         }
2068 if ($osdn) {
2069         # Convert OSDN URL first
2070         my $prot = $ssl ? "https://" : "http://";
2071         my $portstr = $ssl && $port == 443 ||
2072                          !$ssl && $port == 80 ? "" : ":$port";
2073         ($host, $port, $page, $ssl) = &parse_http_url(
2074                 &convert_osdn_url($prot.$host.$portstr.$page));
2075         }
2076
2077 # Check if we already have cached the URL
2078 my $url = ($ssl ? "https://" : "http://").$host.":".$port.$page;
2079 my $cfile = &check_in_http_cache($url);
2080 if ($cfile && !$nocache) {
2081         # Yes! Copy to dest file or variable
2082         &$cbfunc(6, $url) if ($cbfunc);
2083         if (ref($dest)) {
2084                 &open_readfile(CACHEFILE, $cfile);
2085                 local $/ = undef;
2086                 $$dest = <CACHEFILE>;
2087                 close(CACHEFILE);
2088                 }
2089         else {
2090                 &copy_source_dest($cfile, $dest);
2091                 }
2092         return;
2093         }
2094
2095 # Build headers
2096 my @headers;
2097 push(@headers, [ "Host", $host ]);
2098 push(@headers, [ "User-agent", "Webmin" ]);
2099 push(@headers, [ "Accept-language", "en" ]);
2100 if ($user) {
2101         my $auth = &encode_base64("$user:$pass");
2102         $auth =~ tr/\r\n//d;
2103         push(@headers, [ "Authorization", "Basic $auth" ]);
2104         }
2105 foreach my $hname (keys %$headers) {
2106         push(@headers, [ $hname, $headers->{$hname} ]);
2107         }
2108
2109 # Actually download it
2110 $main::download_timed_out = undef;
2111 local $SIG{ALRM} = \&download_timeout;
2112 alarm($timeout || 60);
2113 my $h = &make_http_connection($host, $port, $ssl, "GET", $page, \@headers);
2114 alarm(0);
2115 $h = $main::download_timed_out if ($main::download_timed_out);
2116 if (!ref($h)) {
2117         if ($error) { $$error = $h; return; }
2118         else { &error($h); }
2119         }
2120 &complete_http_download($h, $dest, $error, $cbfunc, $osdn, $host, $port,
2121                         $headers, $ssl, $nocache);
2122 if ((!$error || !$$error) && !$nocache) {
2123         &write_to_http_cache($url, $dest);
2124         }
2125 }
2126
2127 =head2 complete_http_download(handle, destfile, [&error], [&callback], [osdn], [oldhost], [oldport], [&send-headers], [old-ssl], [no-cache])
2128
2129 Do a HTTP download, after the headers have been sent. For internal use only,
2130 typically called by http_download.
2131
2132 =cut
2133 sub complete_http_download
2134 {
2135 local ($line, %header, @headers, $s);  # Kept local so that callback funcs
2136                                        # can access them.
2137 my $cbfunc = $_[3];
2138
2139 # read headers
2140 alarm(60);
2141 ($line = &read_http_connection($_[0])) =~ tr/\r\n//d;
2142 if ($line !~ /^HTTP\/1\..\s+(200|30[0-9])(\s+|$)/) {
2143         alarm(0);
2144         if ($_[2]) { ${$_[2]} = $line; return; }
2145         else { &error("Download failed : $line"); }
2146         }
2147 my $rcode = $1;
2148 &$cbfunc(1, $rcode >= 300 && $rcode < 400 ? 1 : 0)
2149         if ($cbfunc);
2150 while(1) {
2151         $line = &read_http_connection($_[0]);
2152         $line =~ tr/\r\n//d;
2153         $line =~ /^(\S+):\s+(.*)$/ || last;
2154         $header{lc($1)} = $2;
2155         push(@headers, [ lc($1), $2 ]);
2156         }
2157 alarm(0);
2158 if ($main::download_timed_out) {
2159         if ($_[2]) { ${$_[2]} = $main::download_timed_out; return 0; }
2160         else { &error($main::download_timed_out); }
2161         }
2162 &$cbfunc(2, $header{'content-length'}) if ($cbfunc);
2163 if ($rcode >= 300 && $rcode < 400) {
2164         # follow the redirect
2165         &$cbfunc(5, $header{'location'}) if ($cbfunc);
2166         my ($host, $port, $page, $ssl);
2167         if ($header{'location'} =~ /^(http|https):\/\/([^:]+):(\d+)(\/.*)?$/) {
2168                 $ssl = $1 eq 'https' ? 1 : 0;
2169                 $host = $2; $port = $3; $page = $4 || "/";
2170                 }
2171         elsif ($header{'location'} =~ /^(http|https):\/\/([^:\/]+)(\/.*)?$/) {
2172                 $ssl = $1 eq 'https' ? 1 : 0;
2173                 $host = $2; $port = 80; $page = $3 || "/";
2174                 }
2175         elsif ($header{'location'} =~ /^\// && $_[5]) {
2176                 # Relative to same server
2177                 $host = $_[5];
2178                 $port = $_[6];
2179                 $ssl = $_[8];
2180                 $page = $header{'location'};
2181                 }
2182         elsif ($header{'location'}) {
2183                 # Assume relative to same dir .. not handled
2184                 if ($_[2]) { ${$_[2]} = "Invalid Location header $header{'location'}"; return; }
2185                 else { &error("Invalid Location header $header{'location'}"); }
2186                 }
2187         else {
2188                 if ($_[2]) { ${$_[2]} = "Missing Location header"; return; }
2189                 else { &error("Missing Location header"); }
2190                 }
2191         my $params;
2192         ($page, $params) = split(/\?/, $page);
2193         $page =~ s/ /%20/g;
2194         $page .= "?".$params if (defined($params));
2195         &http_download($host, $port, $page, $_[1], $_[2], $cbfunc, $ssl,
2196                        undef, undef, undef, $_[4], $_[9], $_[7]);
2197         }
2198 else {
2199         # read data
2200         if (ref($_[1])) {
2201                 # Append to a variable
2202                 while(defined($buf = &read_http_connection($_[0], 1024))) {
2203                         ${$_[1]} .= $buf;
2204                         &$cbfunc(3, length(${$_[1]})) if ($cbfunc);
2205                         }
2206                 }
2207         else {
2208                 # Write to a file
2209                 my $got = 0;
2210                 if (!&open_tempfile(PFILE, ">$_[1]", 1)) {
2211                         if ($_[2]) { ${$_[2]} = "Failed to write to $_[1] : $!"; return; }
2212                         else { &error("Failed to write to $_[1] : $!"); }
2213                         }
2214                 binmode(PFILE);         # For windows
2215                 while(defined($buf = &read_http_connection($_[0], 1024))) {
2216                         &print_tempfile(PFILE, $buf);
2217                         $got += length($buf);
2218                         &$cbfunc(3, $got) if ($cbfunc);
2219                         }
2220                 &close_tempfile(PFILE);
2221                 if ($header{'content-length'} &&
2222                     $got != $header{'content-length'}) {
2223                         if ($_[2]) { ${$_[2]} = "Download incomplete"; return; }
2224                         else { &error("Download incomplete"); }
2225                         }
2226                 }
2227         &$cbfunc(4) if ($cbfunc);
2228         }
2229 &close_http_connection($_[0]);
2230 }
2231
2232
2233 =head2 ftp_download(host, file, destfile, [&error], [&callback], [user, pass], [port])
2234
2235 Download data from an FTP site to a local file. The parameters are :
2236
2237 =item host - FTP server hostname
2238
2239 =item file - File on the FTP server to download
2240
2241 =item destfile - File on the Webmin system to download data to
2242
2243 =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.
2244
2245 =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.
2246
2247 =item user - Username to login to the FTP server as. If missing, Webmin will login as anonymous.
2248
2249 =item pass - Password for the username above.
2250
2251 =item port - FTP server port number, which defaults to 21 if not set.
2252
2253 =cut
2254 sub ftp_download
2255 {
2256 my ($host, $file, $dest, $error, $cbfunc, $user, $pass, $port) = @_;
2257 $port ||= 21;
2258 if ($gconfig{'debug_what_net'}) {
2259         &webmin_debug_log('FTP', "host=$host port=$port file=$file".
2260                                  ($user ? " user=$user pass=$pass" : "").
2261                                  (ref($dest) ? "" : " dest=$dest"));
2262         }
2263 my ($buf, @n);
2264 $cbfunc = $_[4];
2265 if (&is_readonly_mode()) {
2266         if ($_[3]) { ${$_[3]} = "FTP connections not allowed in readonly mode";
2267                      return 0; }
2268         else { &error("FTP connections not allowed in readonly mode"); }
2269         }
2270
2271 # Check if we already have cached the URL
2272 my $url = "ftp://".$host.$file;
2273 my $cfile = &check_in_http_cache($url);
2274 if ($cfile) {
2275         # Yes! Copy to dest file or variable
2276         &$cbfunc(6, $url) if ($cbfunc);
2277         if (ref($dest)) {
2278                 &open_readfile(CACHEFILE, $cfile);
2279                 local $/ = undef;
2280                 $$dest = <CACHEFILE>;
2281                 close(CACHEFILE);
2282                 }
2283         else {
2284                 &copy_source_dest($cfile, $dest);
2285                 }
2286         return;
2287         }
2288
2289 # Actually download it
2290 $main::download_timed_out = undef;
2291 local $SIG{ALRM} = \&download_timeout;
2292 alarm(60);
2293 my $connected;
2294 if ($gconfig{'ftp_proxy'} =~ /^http:\/\/(\S+):(\d+)/ && !&no_proxy($_[0])) {
2295         # download through http-style proxy
2296         my $error;
2297         if (&open_socket($1, $2, "SOCK", \$error)) {
2298                 # Connected OK
2299                 if ($main::download_timed_out) {
2300                         alarm(0);
2301                         if ($_[3]) { ${$_[3]} = $main::download_timed_out; return 0; }
2302                         else { &error($main::download_timed_out); }
2303                         }
2304                 my $esc = $_[1]; $esc =~ s/ /%20/g;
2305                 my $up = "$_[5]:$_[6]\@" if ($_[5]);
2306                 my $portstr = $port == 21 ? "" : ":$port";
2307                 print SOCK "GET ftp://$up$_[0]$portstr$esc HTTP/1.0\r\n";
2308                 print SOCK "User-agent: Webmin\r\n";
2309                 if ($gconfig{'proxy_user'}) {
2310                         my $auth = &encode_base64(
2311                            "$gconfig{'proxy_user'}:$gconfig{'proxy_pass'}");
2312                         $auth =~ tr/\r\n//d;
2313                         print SOCK "Proxy-Authorization: Basic $auth\r\n";
2314                         }
2315                 print SOCK "\r\n";
2316                 &complete_http_download({ 'fh' => "SOCK" }, $_[2], $_[3], $_[4]);
2317                 $connected = 1;
2318                 }
2319         elsif (!$gconfig{'proxy_fallback'}) {
2320                 alarm(0);
2321                 if ($error) { $$error = $main::download_timed_out; return 0; }
2322                 else { &error($main::download_timed_out); }
2323                 }
2324         }
2325
2326 if (!$connected) {
2327         # connect to host and login with real FTP protocol
2328         &open_socket($_[0], $port, "SOCK", $_[3]) || return 0;
2329         alarm(0);
2330         if ($main::download_timed_out) {
2331                 if ($_[3]) { ${$_[3]} = $main::download_timed_out; return 0; }
2332                 else { &error($main::download_timed_out); }
2333                 }
2334         &ftp_command("", 2, $_[3]) || return 0;
2335         if ($_[5]) {
2336                 # Login as supplied user
2337                 my @urv = &ftp_command("USER $_[5]", [ 2, 3 ], $_[3]);
2338                 @urv || return 0;
2339                 if (int($urv[1]/100) == 3) {
2340                         &ftp_command("PASS $_[6]", 2, $_[3]) || return 0;
2341                         }
2342                 }
2343         else {
2344                 # Login as anonymous
2345                 my @urv = &ftp_command("USER anonymous", [ 2, 3 ], $_[3]);
2346                 @urv || return 0;
2347                 if (int($urv[1]/100) == 3) {
2348                         &ftp_command("PASS root\@".&get_system_hostname(), 2,
2349                                      $_[3]) || return 0;
2350                         }
2351                 }
2352         &$cbfunc(1, 0) if ($cbfunc);
2353
2354         if ($_[1]) {
2355                 # get the file size and tell the callback
2356                 &ftp_command("TYPE I", 2, $_[3]) || return 0;
2357                 my $size = &ftp_command("SIZE $_[1]", 2, $_[3]);
2358                 defined($size) || return 0;
2359                 if ($cbfunc) {
2360                         &$cbfunc(2, int($size));
2361                         }
2362
2363                 # request the file
2364                 my $pasv = &ftp_command("PASV", 2, $_[3]);
2365                 defined($pasv) || return 0;
2366                 $pasv =~ /\(([0-9,]+)\)/;
2367                 @n = split(/,/ , $1);
2368                 &open_socket("$n[0].$n[1].$n[2].$n[3]",
2369                         $n[4]*256 + $n[5], "CON", $_[3]) || return 0;
2370                 &ftp_command("RETR $_[1]", 1, $_[3]) || return 0;
2371
2372                 # transfer data
2373                 my $got = 0;
2374                 &open_tempfile(PFILE, ">$_[2]", 1);
2375                 while(read(CON, $buf, 1024) > 0) {
2376                         &print_tempfile(PFILE, $buf);
2377                         $got += length($buf);
2378                         &$cbfunc(3, $got) if ($cbfunc);
2379                         }
2380                 &close_tempfile(PFILE);
2381                 close(CON);
2382                 if ($got != $size) {
2383                         if ($_[3]) { ${$_[3]} = "Download incomplete"; return 0; }
2384                         else { &error("Download incomplete"); }
2385                         }
2386                 &$cbfunc(4) if ($cbfunc);
2387
2388                 &ftp_command("", 2, $_[3]) || return 0;
2389                 }
2390
2391         # finish off..
2392         &ftp_command("QUIT", 2, $_[3]) || return 0;
2393         close(SOCK);
2394         }
2395
2396 &write_to_http_cache($url, $dest);
2397 return 1;
2398 }
2399
2400 =head2 ftp_upload(host, file, srcfile, [&error], [&callback], [user, pass], [port])
2401
2402 Upload data from a local file to an FTP site. The parameters are :
2403
2404 =item host - FTP server hostname
2405
2406 =item file - File on the FTP server to write to
2407
2408 =item srcfile - File on the Webmin system to upload data from
2409
2410 =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.
2411
2412 =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.
2413
2414 =item user - Username to login to the FTP server as. If missing, Webmin will login as anonymous.
2415
2416 =item pass - Password for the username above.
2417
2418 =item port - FTP server port number, which defaults to 21 if not set.
2419
2420 =cut
2421 sub ftp_upload
2422 {
2423 my ($buf, @n);
2424 my $cbfunc = $_[4];
2425 if (&is_readonly_mode()) {
2426         if ($_[3]) { ${$_[3]} = "FTP connections not allowed in readonly mode";
2427                      return 0; }
2428         else { &error("FTP connections not allowed in readonly mode"); }
2429         }
2430
2431 $main::download_timed_out = undef;
2432 local $SIG{ALRM} = \&download_timeout;
2433 alarm(60);
2434
2435 # connect to host and login
2436 &open_socket($_[0], $_[7] || 21, "SOCK", $_[3]) || return 0;
2437 alarm(0);
2438 if ($main::download_timed_out) {
2439         if ($_[3]) { ${$_[3]} = $main::download_timed_out; return 0; }
2440         else { &error($main::download_timed_out); }
2441         }
2442 &ftp_command("", 2, $_[3]) || return 0;
2443 if ($_[5]) {
2444         # Login as supplied user
2445         my @urv = &ftp_command("USER $_[5]", [ 2, 3 ], $_[3]);
2446         @urv || return 0;
2447         if (int($urv[1]/100) == 3) {
2448                 &ftp_command("PASS $_[6]", 2, $_[3]) || return 0;
2449                 }
2450         }
2451 else {
2452         # Login as anonymous
2453         my @urv = &ftp_command("USER anonymous", [ 2, 3 ], $_[3]);
2454         @urv || return 0;
2455         if (int($urv[1]/100) == 3) {
2456                 &ftp_command("PASS root\@".&get_system_hostname(), 2,
2457                              $_[3]) || return 0;
2458                 }
2459         }
2460 &$cbfunc(1, 0) if ($cbfunc);
2461
2462 &ftp_command("TYPE I", 2, $_[3]) || return 0;
2463
2464 # get the file size and tell the callback
2465 my @st = stat($_[2]);
2466 if ($cbfunc) {
2467         &$cbfunc(2, $st[7]);
2468         }
2469
2470 # send the file
2471 my $pasv = &ftp_command("PASV", 2, $_[3]);
2472 defined($pasv) || return 0;
2473 $pasv =~ /\(([0-9,]+)\)/;
2474 @n = split(/,/ , $1);
2475 &open_socket("$n[0].$n[1].$n[2].$n[3]", $n[4]*256 + $n[5], "CON", $_[3]) || return 0;
2476 &ftp_command("STOR $_[1]", 1, $_[3]) || return 0;
2477
2478 # transfer data
2479 my $got;
2480 open(PFILE, $_[2]);
2481 while(read(PFILE, $buf, 1024) > 0) {
2482         print CON $buf;
2483         $got += length($buf);
2484         &$cbfunc(3, $got) if ($cbfunc);
2485         }
2486 close(PFILE);
2487 close(CON);
2488 if ($got != $st[7]) {
2489         if ($_[3]) { ${$_[3]} = "Upload incomplete"; return 0; }
2490         else { &error("Upload incomplete"); }
2491         }
2492 &$cbfunc(4) if ($cbfunc);
2493
2494 # finish off..
2495 &ftp_command("", 2, $_[3]) || return 0;
2496 &ftp_command("QUIT", 2, $_[3]) || return 0;
2497 close(SOCK);
2498
2499 return 1;
2500 }
2501
2502 =head2 no_proxy(host)
2503
2504 Checks if some host is on the no proxy list. For internal use by the
2505 http_download and ftp_download functions.
2506
2507 =cut
2508 sub no_proxy
2509 {
2510 my $ip = &to_ipaddress($_[0]);
2511 foreach my $n (split(/\s+/, $gconfig{'noproxy'})) {
2512         return 1 if ($_[0] =~ /\Q$n\E/ ||
2513                      $ip =~ /\Q$n\E/);
2514         }
2515 return 0;
2516 }
2517
2518 =head2 open_socket(host, port, handle, [&error])
2519
2520 Open a TCP connection to some host and port, using a file handle. The
2521 parameters are :
2522
2523 =item host - Hostname or IP address to connect to.
2524
2525 =item port - TCP port number.
2526
2527 =item handle - A file handle name to use for the connection.
2528
2529 =item error - A string reference to write any error message into. If not set, the error function is called on failure.
2530
2531 =cut
2532 sub open_socket
2533 {
2534 my ($host, $port, $fh, $err) = @_;
2535 $fh = &callers_package($fh);
2536
2537 if ($gconfig{'debug_what_net'}) {
2538         &webmin_debug_log('TCP', "host=$host port=$port");
2539         }
2540
2541 # Lookup IP address for the host. Try v4 first, and failing that v6
2542 my $ip;
2543 my $proto = getprotobyname("tcp");
2544 if ($ip = &to_ipaddress($host)) {
2545         # Create IPv4 socket and connection
2546         if (!socket($fh, PF_INET(), SOCK_STREAM, $proto)) {
2547                 my $msg = "Failed to create socket : $!";
2548                 if ($err) { $$err = $msg; return 0; }
2549                 else { &error($msg); }
2550                 }
2551         my $addr = inet_aton($ip);
2552         if ($gconfig{'bind_proxy'}) {
2553                 # BIND to outgoing IP
2554                 if (!bind($fh,pack_sockaddr_in(0, inet_aton($gconfig{'bind_proxy'})))) {
2555                         my $msg = "Failed to bind to source address : $!";
2556                         if ($err) { $$err = $msg; return 0; }
2557                         else { &error($msg); }
2558                         }
2559                 }
2560         if (!connect($fh, pack_sockaddr_in($port, $addr))) {
2561                 my $msg = "Failed to connect to $host:$port : $!";
2562                 if ($err) { $$err = $msg; return 0; }
2563                 else { &error($msg); }
2564                 }
2565         }
2566 elsif ($ip = &to_ip6address($host)) {
2567         # Create IPv6 socket and connection
2568         if (!&supports_ipv6()) {
2569                 $msg = "IPv6 connections are not supported";
2570                 if ($err) { $$err = $msg; return 0; }
2571                 else { &error($msg); }
2572                 }
2573         if (!socket($fh, Socket6::PF_INET6(), SOCK_STREAM, $proto)) {
2574                 my $msg = "Failed to create IPv6 socket : $!";
2575                 if ($err) { $$err = $msg; return 0; }
2576                 else { &error($msg); }
2577                 }
2578         my $addr = inet_pton(Socket6::AF_INET6(), $ip);
2579         if (!connect($fh, pack_sockaddr_in6($port, $addr))) {
2580                 my $msg = "Failed to IPv6 connect to $host:$port : $!";
2581                 if ($err) { $$err = $msg; return 0; }
2582                 else { &error($msg); }
2583                 }
2584         }
2585 else {
2586         # Resolution failed
2587         my $msg = "Failed to lookup IP address for $host";
2588         if ($err) { $$err = $msg; return 0; }
2589         else { &error($msg); }
2590         }
2591
2592 # Disable buffering
2593 my $old = select($fh);
2594 $| = 1;
2595 select($old);
2596 return 1;
2597 }
2598
2599 =head2 download_timeout
2600
2601 Called when a download times out. For internal use only.
2602
2603 =cut
2604 sub download_timeout
2605 {
2606 $main::download_timed_out = "Download timed out";
2607 }
2608
2609 =head2 ftp_command(command, expected, [&error], [filehandle])
2610
2611 Send an FTP command, and die if the reply is not what was expected. Mainly
2612 for internal use by the ftp_download and ftp_upload functions.
2613
2614 =cut
2615 sub ftp_command
2616 {
2617 my ($cmd, $expect, $err, $fh) = @_;
2618 $fh ||= "SOCK";
2619 $fh = &callers_package($fh);
2620
2621 my $line;
2622 my $what = $cmd ne "" ? "<i>$cmd</i>" : "initial connection";
2623 if ($cmd ne "") {
2624         print $fh "$cmd\r\n";
2625         }
2626 alarm(60);
2627 if (!($line = <$fh>)) {
2628         alarm(0);
2629         if ($err) { $$err = "Failed to read reply to $what"; return undef; }
2630         else { &error("Failed to read reply to $what"); }
2631         }
2632 $line =~ /^(...)(.)(.*)$/;
2633 my $found = 0;
2634 if (ref($expect)) {
2635         foreach my $c (@$expect) {
2636                 $found++ if (int($1/100) == $c);
2637                 }
2638         }
2639 else {
2640         $found++ if (int($1/100) == $_[1]);
2641         }
2642 if (!$found) {
2643         alarm(0);
2644         if ($err) { $$err = "$what failed : $3"; return undef; }
2645         else { &error("$what failed : $3"); }
2646         }
2647 my $rcode = $1;
2648 my $reply = $3;
2649 if ($2 eq "-") {
2650         # Need to skip extra stuff..
2651         while(1) {
2652                 if (!($line = <$fh>)) {
2653                         alarm(0);
2654                         if ($$err) { $$err = "Failed to read reply to $what";
2655                                      return undef; }
2656                         else { &error("Failed to read reply to $what"); }
2657                         }
2658                 $line =~ /^(....)(.*)$/; $reply .= $2;
2659                 if ($1 eq "$rcode ") { last; }
2660                 }
2661         }
2662 alarm(0);
2663 return wantarray ? ($reply, $rcode) : $reply;
2664 }
2665
2666 =head2 to_ipaddress(hostname)
2667
2668 Converts a hostname to an a.b.c.d format IP address, or returns undef if
2669 it cannot be resolved.
2670
2671 =cut
2672 sub to_ipaddress
2673 {
2674 if (&check_ipaddress($_[0])) {
2675         return $_[0];   # Already in v4 format
2676         }
2677 elsif (&check_ip6address($_[0])) {
2678         return undef;   # A v6 address cannot be converted to v4
2679         }
2680 else {
2681         my $hn = gethostbyname($_[0]);
2682         return undef if (!$hn);
2683         local @ip = unpack("CCCC", $hn);
2684         return join("." , @ip);
2685         }
2686 }
2687
2688 =head2 to_ip6address(hostname)
2689
2690 Converts a hostname to IPv6 address, or returns undef if it cannot be resolved.
2691
2692 =cut
2693 sub to_ip6address
2694 {
2695 if (&check_ip6address($_[0])) {
2696         return $_[0];   # Already in v6 format
2697         }
2698 elsif (&check_ipaddress($_[0])) {
2699         return undef;   # A v4 address cannot be v6
2700         }
2701 elsif (!&supports_ipv6()) {
2702         return undef;   # Cannot lookup
2703         }
2704 else {
2705         # Perform IPv6 DNS lookup
2706         my $inaddr;
2707         (undef, undef, undef, $inaddr) =
2708             getaddrinfo($_[0], undef, Socket6::AF_INET6(), SOCK_STREAM);
2709         return undef if (!$inaddr);
2710         my $addr;
2711         (undef, $addr) = unpack_sockaddr_in6($inaddr);
2712         return inet_ntop(Socket6::AF_INET6(), $addr);
2713         }
2714 }
2715
2716 =head2 to_hostname(ipv4|ipv6-address)
2717
2718 Reverse-resolves an IPv4 or 6 address to a hostname
2719
2720 =cut
2721 sub to_hostname
2722 {
2723 my ($addr) = @_;
2724 if (&check_ip6address($addr) && &supports_ipv6()) {
2725         return gethostbyaddr(inet_pton(Socket6::AF_INET6(), $addr),
2726                              Socket6::AF_INET6());
2727         }
2728 else {
2729         return gethostbyaddr(inet_aton($addr), AF_INET);
2730         }
2731 }
2732
2733 =head2 icons_table(&links, &titles, &icons, [columns], [href], [width], [height], &befores, &afters)
2734
2735 Renders a 4-column table of icons. The useful parameters are :
2736
2737 =item links - An array ref of link destination URLs for the icons.
2738
2739 =item titles - An array ref of titles to appear under the icons.
2740
2741 =item icons - An array ref of URLs for icon images.
2742
2743 =item columns - Number of columns to layout the icons with. Defaults to 4.
2744
2745 =cut
2746 sub icons_table
2747 {
2748 &load_theme_library();
2749 if (defined(&theme_icons_table)) {
2750         &theme_icons_table(@_);
2751         return;
2752         }
2753 my $need_tr;
2754 my $cols = $_[3] ? $_[3] : 4;
2755 my $per = int(100.0 / $cols);
2756 print "<table class='icons_table' width=100% cellpadding=5>\n";
2757 for(my $i=0; $i<@{$_[0]}; $i++) {
2758         if ($i%$cols == 0) { print "<tr>\n"; }
2759         print "<td width=$per% align=center valign=top>\n";
2760         &generate_icon($_[2]->[$i], $_[1]->[$i], $_[0]->[$i],
2761                        ref($_[4]) ? $_[4]->[$i] : $_[4], $_[5], $_[6],
2762                        $_[7]->[$i], $_[8]->[$i]);
2763         print "</td>\n";
2764         if ($i%$cols == $cols-1) { print "</tr>\n"; }
2765         }
2766 while($i++%$cols) { print "<td width=$per%></td>\n"; $need_tr++; }
2767 print "</tr>\n" if ($need_tr);
2768 print "</table>\n";
2769 }
2770
2771 =head2 replace_file_line(file, line, [newline]*)
2772
2773 Replaces one line in some file with 0 or more new lines. The parameters are :
2774
2775 =item file - Full path to some file, like /etc/hosts.
2776
2777 =item line - Line number to replace, starting from 0.
2778
2779 =item newline - Zero or more lines to put into the file at the given line number. These must be newline-terminated strings.
2780
2781 =cut
2782 sub replace_file_line
2783 {
2784 my @lines;
2785 my $realfile = &translate_filename($_[0]);
2786 open(FILE, $realfile);
2787 @lines = <FILE>;
2788 close(FILE);
2789 if (@_ > 2) { splice(@lines, $_[1], 1, @_[2..$#_]); }
2790 else { splice(@lines, $_[1], 1); }
2791 &open_tempfile(FILE, ">$realfile");
2792 &print_tempfile(FILE, @lines);
2793 &close_tempfile(FILE);
2794 }
2795
2796 =head2 read_file_lines(file, [readonly])
2797
2798 Returns a reference to an array containing the lines from some file. This
2799 array can be modified, and will be written out when flush_file_lines()
2800 is called. The parameters are :
2801
2802 =item file - Full path to the file to read.
2803
2804 =item readonly - Should be set 1 if the caller is only going to read the lines, and never write it out.
2805
2806 Example code :
2807
2808  $lref = read_file_lines("/etc/hosts");
2809  push(@$lref, "127.0.0.1 localhost");
2810  flush_file_lines("/etc/hosts");
2811
2812 =cut
2813 sub read_file_lines
2814 {
2815 if (!$_[0]) {
2816         my ($package, $filename, $line) = caller;
2817         print STDERR "Missing file to read at ${package}::${filename} line $line\n";
2818         }
2819 my $realfile = &translate_filename($_[0]);
2820 if (!$main::file_cache{$realfile}) {
2821         my (@lines, $eol);
2822         local $_;
2823         &webmin_debug_log('READ', $_[0]) if ($gconfig{'debug_what_read'});
2824         open(READFILE, $realfile);
2825         while(<READFILE>) {
2826                 if (!$eol) {
2827                         $eol = /\r\n$/ ? "\r\n" : "\n";
2828                         }
2829                 tr/\r\n//d;
2830                 push(@lines, $_);
2831                 }
2832         close(READFILE);
2833         $main::file_cache{$realfile} = \@lines;
2834         $main::file_cache_noflush{$realfile} = $_[1];
2835         $main::file_cache_eol{$realfile} = $eol || "\n";
2836         }
2837 else {
2838         # Make read-write if currently readonly
2839         if (!$_[1]) {
2840                 $main::file_cache_noflush{$realfile} = 0;
2841                 }
2842         }
2843 return $main::file_cache{$realfile};
2844 }
2845
2846 =head2 flush_file_lines([file], [eol])
2847
2848 Write out to a file previously read by read_file_lines to disk (except
2849 for those marked readonly). The parameters are :
2850
2851 =item file - The file to flush out.
2852
2853 =item eof - End-of-line character for each line. Defaults to \n.
2854
2855 =cut
2856 sub flush_file_lines
2857 {
2858 my @files;
2859 if ($_[0]) {
2860         local $trans = &translate_filename($_[0]);
2861         $main::file_cache{$trans} ||
2862                 &error("flush_file_lines called on non-loaded file $trans");
2863         push(@files, $trans);
2864         }
2865 else {
2866         @files = ( keys %main::file_cache );
2867         }
2868 foreach my $f (@files) {
2869         my $eol = $_[1] || $main::file_cache_eol{$f} || "\n";
2870         if (!$main::file_cache_noflush{$f}) {
2871                 no warnings; # XXX Bareword file handles should go away
2872                 &open_tempfile(FLUSHFILE, ">$f");
2873                 foreach my $line (@{$main::file_cache{$f}}) {
2874                         (print FLUSHFILE $line,$eol) ||
2875                                 &error(&text("efilewrite", $f, $!));
2876                         }
2877                 &close_tempfile(FLUSHFILE);
2878                 }
2879         delete($main::file_cache{$f});
2880         delete($main::file_cache_noflush{$f});
2881         }
2882 }
2883
2884 =head2 unflush_file_lines(file)
2885
2886 Clear the internal cache of some given file, previously read by read_file_lines.
2887
2888 =cut
2889 sub unflush_file_lines
2890 {
2891 my $realfile = &translate_filename($_[0]);
2892 delete($main::file_cache{$realfile});
2893 delete($main::file_cache_noflush{$realfile});
2894 }
2895
2896 =head2 unix_user_input(fieldname, user, [form])
2897
2898 Returns HTML for an input to select a Unix user. By default this is a text
2899 box with a user popup button next to it.
2900
2901 =cut
2902 sub unix_user_input
2903 {
2904 if (defined(&theme_unix_user_input)) {
2905         return &theme_unix_user_input(@_);
2906         }
2907 return "<input name=$_[0] size=13 value=\"$_[1]\"> ".
2908        &user_chooser_button($_[0], 0, $_[2] || 0)."\n";
2909 }
2910
2911 =head2 unix_group_input(fieldname, user, [form])
2912
2913 Returns HTML for an input to select a Unix group. By default this is a text
2914 box with a group popup button next to it.
2915
2916 =cut
2917 sub unix_group_input
2918 {
2919 if (defined(&theme_unix_group_input)) {
2920         return &theme_unix_group_input(@_);
2921         }
2922 return "<input name=$_[0] size=13 value=\"$_[1]\"> ".
2923        &group_chooser_button($_[0], 0, $_[2] || 0)."\n";
2924 }
2925
2926 =head2 hlink(text, page, [module], [width], [height])
2927
2928 Returns HTML for a link that when clicked on pops up a window for a Webmin
2929 help page. The parameters are :
2930
2931 =item text - Text for the link.
2932
2933 =item page - Help page code, such as 'intro'.
2934
2935 =item module - Module the help page is in. Defaults to the current module.
2936
2937 =item width - Width of the help popup window. Defaults to 600 pixels.
2938
2939 =item height - Height of the help popup window. Defaults to 400 pixels.
2940
2941 The actual help pages are in each module's help sub-directory, in files with
2942 .html extensions.
2943
2944 =cut
2945 sub hlink
2946 {
2947 if (defined(&theme_hlink)) {
2948         return &theme_hlink(@_);
2949         }
2950 my $mod = $_[2] ? $_[2] : &get_module_name();
2951 my $width = $_[3] || $tconfig{'help_width'} || $gconfig{'help_width'} || 600;
2952 my $height = $_[4] || $tconfig{'help_height'} || $gconfig{'help_height'} || 400;
2953 return "<a onClick='window.open(\"$gconfig{'webprefix'}/help.cgi/$mod/$_[1]\", \"help\", \"toolbar=no,menubar=no,scrollbars=yes,width=$width,height=$height,resizable=yes\"); return false' href=\"$gconfig{'webprefix'}/help.cgi/$mod/$_[1]\">$_[0]</a>";
2954 }
2955
2956 =head2 user_chooser_button(field, multiple, [form])
2957
2958 Returns HTML for a javascript button for choosing a Unix user or users.
2959 The parameters are :
2960
2961 =item field - Name of the HTML field to place the username into.
2962
2963 =item multiple - Set to 1 if multiple users can be selected.
2964
2965 =item form - Index of the form on the page.
2966
2967 =cut
2968 sub user_chooser_button
2969 {
2970 return undef if (!&supports_users());
2971 return &theme_user_chooser_button(@_)
2972         if (defined(&theme_user_chooser_button));
2973 my $form = defined($_[2]) ? $_[2] : 0;
2974 my $w = $_[1] ? 500 : 300;
2975 my $h = 200;
2976 if ($_[1] && $gconfig{'db_sizeusers'}) {
2977         ($w, $h) = split(/x/, $gconfig{'db_sizeusers'});
2978         }
2979 elsif (!$_[1] && $gconfig{'db_sizeuser'}) {
2980         ($w, $h) = split(/x/, $gconfig{'db_sizeuser'});
2981         }
2982 return "<input type=button onClick='ifield = form.$_[0]; chooser = window.open(\"$gconfig{'webprefix'}/user_chooser.cgi?multi=$_[1]&user=\"+escape(ifield.value), \"chooser\", \"toolbar=no,menubar=no,scrollbars=yes,resizable=yes,width=$w,height=$h\"); chooser.ifield = ifield; window.ifield = ifield' value=\"...\">\n";
2983 }
2984
2985 =head2 group_chooser_button(field, multiple, [form])
2986
2987 Returns HTML for a javascript button for choosing a Unix group or groups
2988 The parameters are :
2989
2990 =item field - Name of the HTML field to place the group name into.
2991
2992 =item multiple - Set to 1 if multiple groups can be selected.
2993
2994 =item form - Index of the form on the page.
2995
2996 =cut
2997 sub group_chooser_button
2998 {
2999 return undef if (!&supports_users());
3000 return &theme_group_chooser_button(@_)
3001         if (defined(&theme_group_chooser_button));
3002 my $form = defined($_[2]) ? $_[2] : 0;
3003 my $w = $_[1] ? 500 : 300;
3004 my $h = 200;
3005 if ($_[1] && $gconfig{'db_sizeusers'}) {
3006         ($w, $h) = split(/x/, $gconfig{'db_sizeusers'});
3007         }
3008 elsif (!$_[1] && $gconfig{'db_sizeuser'}) {
3009         ($w, $h) = split(/x/, $gconfig{'db_sizeuser'});
3010         }
3011 return "<input type=button onClick='ifield = form.$_[0]; chooser = window.open(\"$gconfig{'webprefix'}/group_chooser.cgi?multi=$_[1]&group=\"+escape(ifield.value), \"chooser\", \"toolbar=no,menubar=no,scrollbars=yes,resizable=yes,width=$w,height=$h\"); chooser.ifield = ifield; window.ifield = ifield' value=\"...\">\n";
3012 }
3013
3014 =head2 foreign_check(module, [api-only])
3015
3016 Checks if some other module exists and is supported on this OS. The parameters
3017 are :
3018
3019 =item module - Name of the module to check.
3020
3021 =item api-only - Set to 1 if you just want to check if the module provides an API that others can call, instead of the full web UI.
3022
3023 =cut
3024 sub foreign_check
3025 {
3026 my ($mod, $api) = @_;
3027 my %minfo;
3028 my $mdir = &module_root_directory($mod);
3029 &read_file_cached("$mdir/module.info", \%minfo) || return 0;
3030 return &check_os_support(\%minfo, undef, undef, $api);
3031 }
3032
3033 =head2 foreign_exists(module)
3034
3035 Checks if some other module exists. The module parameter is the short module
3036 name.
3037
3038 =cut
3039 sub foreign_exists
3040 {
3041 my $mdir = &module_root_directory($_[0]);
3042 return -r "$mdir/module.info";
3043 }
3044
3045 =head2 foreign_available(module)
3046
3047 Returns 1 if some module is installed, and acessible to the current user. The
3048 module parameter is the module directory name.
3049
3050 =cut
3051 sub foreign_available
3052 {
3053 return 0 if (!&foreign_check($_[0]) &&
3054              !$gconfig{'available_even_if_no_support'});
3055 my %foreign_module_info = &get_module_info($_[0]);
3056
3057 # Check list of allowed modules
3058 my %acl;
3059 &read_acl(\%acl, undef, [ $base_remote_user ]);
3060 return 0 if (!$acl{$base_remote_user,$_[0]} &&
3061              !$acl{$base_remote_user,'*'});
3062
3063 # Check for usermod restrictions
3064 my @usermods = &list_usermods();
3065 return 0 if (!&available_usermods( [ \%foreign_module_info ], \@usermods));
3066
3067 if (&get_product_name() eq "webmin") {
3068         # Check if the user has any RBAC privileges in this module
3069         if (&supports_rbac($_[0]) &&
3070             &use_rbac_module_acl(undef, $_[0])) {
3071                 # RBAC is enabled for this user and module - check if he
3072                 # has any rights
3073                 my $rbacs = &get_rbac_module_acl($remote_user, $_[0]);
3074                 return 0 if (!$rbacs);
3075                 }
3076         elsif ($gconfig{'rbacdeny_'.$base_remote_user}) {
3077                 # If denying access to modules not specifically allowed by
3078                 # RBAC, then prevent access
3079                 return 0;
3080                 }
3081         }
3082
3083 # Check readonly support
3084 if (&is_readonly_mode()) {
3085         return 0 if (!$foreign_module_info{'readonly'});
3086         }
3087
3088 # Check if theme vetos
3089 if (defined(&theme_foreign_available)) {
3090         return 0 if (!&theme_foreign_available($_[0]));
3091         }
3092
3093 # Check if licence module vetos
3094 if ($main::licence_module) {
3095         return 0 if (!&foreign_call($main::licence_module,
3096                                     "check_module_licence", $_[0]));
3097         }
3098
3099 return 1;
3100 }
3101
3102 =head2 foreign_require(module, [file], [package])
3103
3104 Brings in functions from another module, and places them in the Perl namespace
3105 with the same name as the module. The parameters are :
3106
3107 =item module - The source module's directory name, like sendmail.
3108
3109 =item file - The API file in that module, like sendmail-lib.pl. If missing, all API files are loaded.
3110
3111 =item package - Perl package to place the module's functions and global variables in.
3112
3113 If the original module name contains dashes, they will be replaced with _ in
3114 the package name.
3115
3116 =cut
3117 sub foreign_require
3118 {
3119 my ($mod, $file, $pkg) = @_;
3120 $pkg ||= $mod || "global";
3121 $pkg =~ s/[^A-Za-z0-9]/_/g;
3122 my @files;
3123 if ($file) {
3124         push(@files, $file);
3125         }
3126 else {
3127         # Auto-detect files
3128         my %minfo = &get_module_info($mod);
3129         if ($minfo{'library'}) {
3130                 @files = split(/\s+/, $minfo{'library'});
3131                 }
3132         else {
3133                 @files = ( $mod."-lib.pl" );
3134                 }
3135         }
3136 @files = grep { !$main::done_foreign_require{$pkg,$_} } @files;
3137 return 1 if (!@files);
3138 foreach my $f (@files) {
3139         $main::done_foreign_require{$pkg,$f}++;
3140         }
3141 my @OLDINC = @INC;
3142 my $mdir = &module_root_directory($mod);
3143 @INC = &unique($mdir, @INC);
3144 -d $mdir || &error("Module $mod does not exist");
3145 if (!&get_module_name() && $mod) {
3146         chdir($mdir);
3147         }
3148 my $old_fmn = $ENV{'FOREIGN_MODULE_NAME'};
3149 my $old_frd = $ENV{'FOREIGN_ROOT_DIRECTORY'};
3150 my $code = "package $pkg; ".
3151            "\$ENV{'FOREIGN_MODULE_NAME'} = '$mod'; ".
3152            "\$ENV{'FOREIGN_ROOT_DIRECTORY'} = '$root_directory'; ";
3153 foreach my $f (@files) {
3154         $code .= "do '$mdir/$f' || die \$@; ";
3155         }
3156 eval $code;
3157 if (defined($old_fmn)) {
3158         $ENV{'FOREIGN_MODULE_NAME'} = $old_fmn;
3159         }
3160 else {
3161         delete($ENV{'FOREIGN_MODULE_NAME'});
3162         }
3163 if (defined($old_frd)) {
3164         $ENV{'FOREIGN_ROOT_DIRECTORY'} = $old_frd;
3165         }
3166 else {
3167         delete($ENV{'FOREIGN_ROOT_DIRECTORY'});
3168         }
3169 @INC = @OLDINC;
3170 if ($@) { &error("Require $mod/$files[0] failed : <pre>$@</pre>"); }
3171 return 1;
3172 }
3173
3174 =head2 foreign_call(module, function, [arg]*)
3175
3176 Call a function in another module. The module parameter is the target module
3177 directory name, function is the perl sub to call, and the remaining parameters
3178 are the arguments. However, unless you need to call a function whose name
3179 is dynamic, it is better to use Perl's cross-module function call syntax
3180 like module::function(args).
3181
3182 =cut
3183 sub foreign_call
3184 {
3185 my $pkg = $_[0] || "global";
3186 $pkg =~ s/[^A-Za-z0-9]/_/g;
3187 my @args = @_[2 .. @_-1];
3188 $main::foreign_args = \@args;
3189 my @rv = eval <<EOF;
3190 package $pkg;
3191 &$_[1](\@{\$main::foreign_args});
3192 EOF
3193 if ($@) { &error("$_[0]::$_[1] failed : $@"); }
3194 return wantarray ? @rv : $rv[0];
3195 }
3196
3197 =head2 foreign_config(module, [user-config])
3198
3199 Get the configuration from another module, and return it as a hash. If the
3200 user-config parameter is set to 1, returns the Usermin user-level preferences
3201 for the current user instead.
3202
3203 =cut
3204 sub foreign_config
3205 {
3206 my ($mod, $uc) = @_;
3207 my %fconfig;
3208 if ($uc) {
3209         &read_file_cached("$root_directory/$mod/defaultuconfig", \%fconfig);
3210         &read_file_cached("$config_directory/$mod/uconfig", \%fconfig);
3211         &read_file_cached("$user_config_directory/$mod/config", \%fconfig);
3212         }
3213 else {
3214         &read_file_cached("$config_directory/$mod/config", \%fconfig);
3215         }
3216 return %fconfig;
3217 }
3218
3219 =head2 foreign_installed(module, mode)
3220
3221 Checks if the server for some module is installed, and possibly also checks
3222 if the module has been configured by Webmin.
3223 For mode 1, returns 2 if the server is installed and configured for use by
3224 Webmin, 1 if installed but not configured, or 0 otherwise.
3225 For mode 0, returns 1 if installed, 0 if not.
3226 If the module does not provide an install_check.pl script, assumes that
3227 the server is installed.
3228
3229 =cut
3230 sub foreign_installed
3231 {
3232 my ($mod, $configured) = @_;
3233 if (defined($main::foreign_installed_cache{$mod,$configured})) {
3234         # Already cached..
3235         return $main::foreign_installed_cache{$mod,$configured};
3236         }
3237 else {
3238         my $rv;
3239         if (!&foreign_check($mod)) {
3240                 # Module is missing
3241                 $rv = 0;
3242                 }
3243         else {
3244                 my $mdir = &module_root_directory($mod);
3245                 if (!-r "$mdir/install_check.pl") {
3246                         # Not known, assume OK
3247                         $rv = $configured ? 2 : 1;
3248                         }
3249                 else {
3250                         # Call function to check
3251                         &foreign_require($mod, "install_check.pl");
3252                         $rv = &foreign_call($mod, "is_installed", $configured);
3253                         }
3254                 }
3255         $main::foreign_installed_cache{$mod,$configured} = $rv;
3256         return $rv;
3257         }
3258 }
3259
3260 =head2 foreign_defined(module, function)
3261
3262 Returns 1 if some function is defined in another module. In general, it is
3263 simpler to use the syntax &defined(module::function) instead.
3264
3265 =cut
3266 sub foreign_defined
3267 {
3268 my ($pkg) = @_;
3269 $pkg =~ s/[^A-Za-z0-9]/_/g;
3270 my $func = "${pkg}::$_[1]";
3271 return defined(&$func);
3272 }
3273
3274 =head2 get_system_hostname([short])
3275
3276 Returns the hostname of this system. If the short parameter is set to 1,
3277 then the domain name is not prepended - otherwise, Webmin will attempt to get
3278 the fully qualified hostname, like foo.example.com.
3279
3280 =cut
3281 sub get_system_hostname
3282 {
3283 my $m = int($_[0]);
3284 if (!$main::get_system_hostname[$m]) {
3285         if ($gconfig{'os_type'} ne 'windows') {
3286                 # Try some common Linux hostname files first
3287                 my $fromfile;
3288                 if ($gconfig{'os_type'} eq 'redhat-linux') {
3289                         my %nc;
3290                         &read_env_file("/etc/sysconfig/network", \%nc);
3291                         if ($nc{'HOSTNAME'}) {
3292                                 $fromfile = $nc{'HOSTNAME'};
3293                                 }
3294                         }
3295                 elsif ($gconfig{'os_type'} eq 'debian-linux') {
3296                         my $hn = &read_file_contents("/etc/hostname");
3297                         if ($hn) {
3298                                 $hn =~ s/\r|\n//g;
3299                                 $fromfile = $hn;
3300                                 }
3301                         }
3302                 elsif ($gconfig{'os_type'} eq 'open-linux') {
3303                         my $hn = &read_file_contents("/etc/HOSTNAME");
3304                         if ($hn) {
3305                                 $hn =~ s/\r|\n//g;
3306                                 $fromfile = $hn;
3307                                 }
3308                         }
3309                 elsif ($gconfig{'os_type'} eq 'solaris') {
3310                         my $hn = &read_file_contents("/etc/nodename");
3311                         if ($hn) {
3312                                 $hn =~ s/\r|\n//g;
3313                                 $fromfile = $hn;
3314                                 }
3315                         }
3316
3317                 # If we found a hostname, use it if value
3318                 if ($fromfile && ($m || $fromfile =~ /\./)) {
3319                         if ($m) {
3320                                 $fromfile =~ s/\..*$//;
3321                                 }
3322                         $main::get_system_hostname[$m] = $fromfile;
3323                         return $fromfile;
3324                         }
3325
3326                 # Can use hostname command on Unix
3327                 &execute_command("hostname", undef,
3328                                  \$main::get_system_hostname[$m], undef, 0, 1);
3329                 chop($main::get_system_hostname[$m]);
3330                 if ($?) {
3331                         eval "use Sys::Hostname";
3332                         if (!$@) {
3333                                 $main::get_system_hostname[$m] = eval "hostname()";
3334                                 }
3335                         if ($@ || !$main::get_system_hostname[$m]) {
3336                                 $main::get_system_hostname[$m] = "UNKNOWN";
3337                                 }
3338                         }
3339                 elsif ($main::get_system_hostname[$m] !~ /\./ &&
3340                        $gconfig{'os_type'} =~ /linux$/ &&
3341                        !$gconfig{'no_hostname_f'} && !$_[0]) {
3342                         # Try with -f flag to get fully qualified name
3343                         my $flag;
3344                         my $ex = &execute_command("hostname -f", undef, \$flag,
3345                                                   undef, 0, 1);
3346                         chop($flag);
3347                         if ($ex || $flag eq "") {
3348                                 # -f not supported! We have probably set the
3349                                 # hostname to just '-f'. Fix the problem
3350                                 # (if we are root)
3351                                 if ($< == 0) {
3352                                         &execute_command("hostname ".
3353                                                 quotemeta($main::get_system_hostname[$m]),
3354                                                 undef, undef, undef, 0, 1);
3355                                         }
3356                                 }
3357                         else {
3358                                 $main::get_system_hostname[$m] = $flag;
3359                                 }
3360                         }
3361                 }
3362         else {
3363                 # On Windows, try computername environment variable
3364                 return $ENV{'computername'} if ($ENV{'computername'});
3365                 return $ENV{'COMPUTERNAME'} if ($ENV{'COMPUTERNAME'});
3366
3367                 # Fall back to net name command
3368                 my $out = `net name 2>&1`;
3369                 if ($out =~ /\-+\r?\n(\S+)/) {
3370                         $main::get_system_hostname[$m] = $1;
3371                         }
3372                 else {
3373                         $main::get_system_hostname[$m] = "windows";
3374                         }
3375                 }
3376         }
3377 return $main::get_system_hostname[$m];
3378 }
3379
3380 =head2 get_webmin_version
3381
3382 Returns the version of Webmin currently being run, such as 1.450.
3383
3384 =cut
3385 sub get_webmin_version
3386 {
3387 if (!$get_webmin_version) {
3388         open(VERSION, "$root_directory/version") || return 0;
3389         ($get_webmin_version = <VERSION>) =~ tr/\r|\n//d;
3390         close(VERSION);
3391         }
3392 return $get_webmin_version;
3393 }
3394
3395 =head2 get_module_acl([user], [module], [no-rbac], [no-default])
3396
3397 Returns a hash containing access control options for the given user and module.
3398 By default the current username and module name are used. If the no-rbac flag
3399 is given, the permissions will not be updated based on the user's RBAC role
3400 (as seen on Solaris). If the no-default flag is given, default permissions for
3401 the module will not be included.
3402
3403 =cut
3404 sub get_module_acl
3405 {
3406 my $u = defined($_[0]) ? $_[0] : $base_remote_user;
3407 my $m = defined($_[1]) ? $_[1] : &get_module_name();
3408 my $mdir = &module_root_directory($m);
3409 my %rv;
3410 if (!$_[3]) {
3411         # Read default ACL first, to be overridden by per-user settings
3412         &read_file_cached("$mdir/defaultacl", \%rv);
3413
3414         # If this isn't a master admin user, apply the negative permissions
3415         # so that he doesn't un-expectedly gain access to new features
3416         my %gacccess;
3417         &read_file_cached("$config_directory/$u.acl", \%gaccess);
3418         if ($gaccess{'negative'}) {
3419                 &read_file_cached("$mdir/negativeacl", \%rv);
3420                 }
3421         }
3422 my %usersacl;
3423 if (!$_[2] && &supports_rbac($m) && &use_rbac_module_acl($u, $m)) {
3424         # RBAC overrides exist for this user in this module
3425         my $rbac = &get_rbac_module_acl(
3426                         defined($_[0]) ? $_[0] : $remote_user, $m);
3427         foreach my $r (keys %$rbac) {
3428                 $rv{$r} = $rbac->{$r};
3429                 }
3430         }
3431 elsif ($gconfig{"risk_$u"} && $m) {
3432         # ACL is defined by user's risk level
3433         my $rf = $gconfig{"risk_$u"}.'.risk';
3434         &read_file_cached("$mdir/$rf", \%rv);
3435
3436         my $sf = $gconfig{"skill_$u"}.'.skill';
3437         &read_file_cached("$mdir/$sf", \%rv);
3438         }
3439 elsif ($u ne '') {
3440         # Use normal Webmin ACL, if a user is set
3441         my $userdb = &get_userdb_string();
3442         my $foundindb = 0;
3443         if ($userdb && ($u ne $base_remote_user || $remote_user_proto)) {
3444                 # Look for this user in the user/group DB, if one is defined
3445                 # and if the user might be in the DB
3446                 my ($dbh, $proto, $prefix, $args) = &connect_userdb($userdb);
3447                 ref($dbh) || &error(&text('euserdbacl', $dbh));
3448                 if ($proto eq "mysql" || $proto eq "postgresql") {
3449                         # Find the user in the SQL DB
3450                         my $cmd = $dbh->prepare(
3451                                 "select id from webmin_user where name = ?");
3452                         $cmd && $cmd->execute($u) ||
3453                                 &error(&text('euserdbacl', $dbh->errstr));
3454                         my ($id) = $cmd->fetchrow();
3455                         $foundindb = 1 if (defined($id));
3456                         $cmd->finish();
3457
3458                         # Fetch ACLs with SQL
3459                         if ($foundindb) {
3460                                 my $cmd = $dbh->prepare(
3461                                     "select attr,value from webmin_user_acl ".
3462                                     "where id = ? and module = ?");
3463                                 $cmd && $cmd->execute($id, $m) ||
3464                                     &error(&text('euserdbacl', $dbh->errstr));
3465                                 while(my ($a, $v) = $cmd->fetchrow()) {
3466                                         $rv{$a} = $v;
3467                                         }
3468                                 $cmd->finish();
3469                                 }
3470                         }
3471                 elsif ($proto eq "ldap") {
3472                         # Find user in LDAP
3473                         my $rv = $dbh->search(
3474                                 base => $prefix,
3475                                 filter => '(&(cn='.$u.')(objectClass='.
3476                                           $args->{'userclass'}.'))',
3477                                 scope => 'sub');
3478                         if (!$rv || $rv->code) {
3479                                 &error(&text('euserdbacl',
3480                                      $rv ? $rv->error : "Unknown error"));
3481                                 }
3482                         my ($user) = $rv->all_entries;
3483
3484                         # Find ACL sub-object for the module
3485                         my $ldapm = $m || "global";
3486                         if ($user) {
3487                                 my $rv = $dbh->search(
3488                                         base => $user->dn(),
3489                                         filter => '(cn='.$ldapm.')',
3490                                         scope => 'one');
3491                                 if (!$rv || $rv->code) {
3492                                         &error(&text('euserdbacl',
3493                                            $rv ? $rv->error : "Unknown error"));
3494                                         }
3495                                 my ($acl) = $rv->all_entries;
3496                                 if ($acl) {
3497                                         foreach my $av ($acl->get_value(
3498                                                         'webminAclEntry')) {
3499                                                 my ($a, $v) = split(/=/, $av,2);
3500                                                 $rv{$a} = $v;
3501                                                 }
3502                                         }
3503                                 }
3504                         }
3505                 &disconnect_userdb($userdb, $dbh);
3506                 }
3507
3508         if (!$foundindb) {
3509                 # Read from local files
3510                 &read_file_cached("$config_directory/$m/$u.acl", \%rv);
3511                 if ($remote_user ne $base_remote_user && !defined($_[0])) {
3512                         &read_file_cached(
3513                                 "$config_directory/$m/$remote_user.acl",\%rv);
3514                         }
3515                 }
3516         }
3517 if ($tconfig{'preload_functions'}) {
3518         &load_theme_library();
3519         }
3520 if (defined(&theme_get_module_acl)) {
3521         %rv = &theme_get_module_acl($u, $m, \%rv);
3522         }
3523 return %rv;
3524 }
3525
3526 =head2 get_group_module_acl(group, [module], [no-default])
3527
3528 Returns the ACL for a Webmin group, in an optional module (which defaults to
3529 the current module).
3530
3531 =cut
3532 sub get_group_module_acl
3533 {
3534 my $g = $_[0];
3535 my $m = defined($_[1]) ? $_[1] : &get_module_name();
3536 my $mdir = &module_root_directory($m);
3537 my %rv;
3538 if (!$_[2]) {
3539         &read_file_cached("$mdir/defaultacl", \%rv);
3540         }
3541
3542 my $userdb = &get_userdb_string();
3543 my $foundindb = 0;
3544 if ($userdb) {
3545         # Look for this group in the user/group DB
3546         my ($dbh, $proto, $prefix, $args) = &connect_userdb($userdb);
3547         ref($dbh) || &error(&text('egroupdbacl', $dbh));
3548         if ($proto eq "mysql" || $proto eq "postgresql") {
3549                 # Find the group in the SQL DB
3550                 my $cmd = $dbh->prepare(
3551                         "select id from webmin_group where name = ?");
3552                 $cmd && $cmd->execute($g) ||
3553                         &error(&text('egroupdbacl', $dbh->errstr));
3554                 my ($id) = $cmd->fetchrow();
3555                 $foundindb = 1 if (defined($id));
3556                 $cmd->finish();
3557
3558                 # Fetch ACLs with SQL
3559                 if ($foundindb) {
3560                         my $cmd = $dbh->prepare(
3561                             "select attr,value from webmin_group_acl ".
3562                             "where id = ? and module = ?");
3563                         $cmd && $cmd->execute($id, $m) ||
3564                             &error(&text('egroupdbacl', $dbh->errstr));
3565                         while(my ($a, $v) = $cmd->fetchrow()) {
3566                                 $rv{$a} = $v;
3567                                 }
3568                         $cmd->finish();
3569                         }
3570                 }
3571         elsif ($proto eq "ldap") {
3572                 # Find group in LDAP
3573                 my $rv = $dbh->search(
3574                         base => $prefix,
3575                         filter => '(&(cn='.$g.')(objectClass='.
3576                                   $args->{'groupclass'}.'))',
3577                         scope => 'sub');
3578                 if (!$rv || $rv->code) {
3579                         &error(&text('egroupdbacl',
3580                                      $rv ? $rv->error : "Unknown error"));
3581                         }
3582                 my ($group) = $rv->all_entries;
3583
3584                 # Find ACL sub-object for the module
3585                 my $ldapm = $m || "global";
3586                 if ($group) {
3587                         my $rv = $dbh->search(
3588                                 base => $group->dn(),
3589                                 filter => '(cn='.$ldapm.')',
3590                                 scope => 'one');
3591                         if (!$rv || $rv->code) {
3592                                 &error(&text('egroupdbacl',
3593                                      $rv ? $rv->error : "Unknown error"));
3594                                 }
3595                         my ($acl) = $rv->all_entries;
3596                         if ($acl) {
3597                                 foreach my $av ($acl->get_value(
3598                                                 'webminAclEntry')) {
3599                                         my ($a, $v) = split(/=/, $av, 2);
3600                                         $rv{$a} = $v;
3601                                         }
3602                                 }
3603                         }
3604                 }
3605         &disconnect_userdb($userdb, $dbh);
3606         }
3607 if (!$foundindb) {
3608         # Read from local files
3609         &read_file_cached("$config_directory/$m/$g.gacl", \%rv);
3610         }
3611 if (defined(&theme_get_module_acl)) {
3612         %rv = &theme_get_module_acl($g, $m, \%rv);
3613         }
3614 return %rv;
3615 }
3616
3617 =head2 save_module_acl(&acl, [user], [module], [never-update-group])
3618
3619 Updates the acl hash for some user and module. The parameters are :
3620
3621 =item acl - Hash reference for the new access control options, or undef to clear
3622
3623 =item user - User to update, defaulting to the current user.
3624
3625 =item module - Module to update, defaulting to the caller.
3626
3627 =item never-update-group - Never update the user's group's ACL
3628
3629 =cut
3630 sub save_module_acl
3631 {
3632 my $u = defined($_[1]) ? $_[1] : $base_remote_user;
3633 my $m = defined($_[2]) ? $_[2] : &get_module_name();
3634 if (!$_[3] && &foreign_check("acl")) {
3635         # Check if this user is a member of a group, and if he gets the
3636         # module from a group. If so, update its ACL as well
3637         &foreign_require("acl", "acl-lib.pl");
3638         my $group;
3639         foreach my $g (&acl::list_groups()) {
3640                 if (&indexof($u, @{$g->{'members'}}) >= 0 &&
3641                     &indexof($m, @{$g->{'modules'}}) >= 0) {
3642                         $group = $g;
3643                         last;
3644                         }
3645                 }
3646         if ($group) {
3647                 &save_group_module_acl($_[0], $group->{'name'}, $m);
3648                 }
3649         }
3650
3651 my $userdb = &get_userdb_string();
3652 my $foundindb = 0;
3653 if ($userdb && ($u ne $base_remote_user || $remote_user_proto)) {
3654         # Look for this user in the user/group DB
3655         my ($dbh, $proto, $prefix, $args) = &connect_userdb($userdb);
3656         ref($dbh) || &error(&text('euserdbacl', $dbh));
3657         if ($proto eq "mysql" || $proto eq "postgresql") {
3658                 # Find the user in the SQL DB
3659                 my $cmd = $dbh->prepare(
3660                         "select id from webmin_user where name = ?");
3661                 $cmd && $cmd->execute($u) ||
3662                         &error(&text('euserdbacl2', $dbh->errstr));
3663                 my ($id) = $cmd->fetchrow();
3664                 $foundindb = 1 if (defined($id));
3665                 $cmd->finish();
3666
3667                 # Replace ACLs for user
3668                 if ($foundindb) {
3669                         my $cmd = $dbh->prepare("delete from webmin_user_acl ".
3670                                                 "where id = ? and module = ?");
3671                         $cmd && $cmd->execute($id, $m) ||
3672                             &error(&text('euserdbacl', $dbh->errstr));
3673                         $cmd->finish();
3674                         if ($_[0]) {
3675                                 my $cmd = $dbh->prepare(
3676                                     "insert into webmin_user_acl ".
3677                                     "(id,module,attr,value) values (?,?,?,?)");
3678                                 $cmd || &error(&text('euserdbacl2',
3679                                                      $dbh->errstr));
3680                                 foreach my $a (keys %{$_[0]}) {
3681                                         $cmd->execute($id,$m,$a,$_[0]->{$a}) ||
3682                                             &error(&text('euserdbacl2',
3683                                                          $dbh->errstr));
3684                                         $cmd->finish();
3685                                         }
3686                                 }
3687                         }
3688                 }
3689         elsif ($proto eq "ldap") {
3690                 # Find the user in LDAP
3691                 my $rv = $dbh->search(
3692                         base => $prefix,
3693                         filter => '(&(cn='.$u.')(objectClass='.
3694                                   $args->{'userclass'}.'))',
3695                         scope => 'sub');
3696                 if (!$rv || $rv->code) {
3697                         &error(&text('euserdbacl',
3698                                      $rv ? $rv->error : "Unknown error"));
3699                         }
3700                 my ($user) = $rv->all_entries;
3701
3702                 if ($user) {
3703                         # Find the ACL sub-object for the module
3704                         $foundindb = 1;
3705                         my $ldapm = $m || "global";
3706                         my $rv = $dbh->search(
3707                                 base => $user->dn(),
3708                                 filter => '(cn='.$ldapm.')',
3709                                 scope => 'one');
3710                         if (!$rv || $rv->code) {
3711                                 &error(&text('euserdbacl',
3712                                      $rv ? $rv->error : "Unknown error"));
3713                                 }
3714                         my ($acl) = $rv->all_entries;
3715
3716                         my @al;
3717                         foreach my $a (keys %{$_[0]}) {
3718                                 push(@al, $a."=".$_[0]->{$a});
3719                                 }
3720                         if ($acl) {
3721                                 # Update attributes
3722                                 $rv = $dbh->modify($acl->dn(),
3723                                   replace => { "webminAclEntry", \@al });
3724                                 }
3725                         else {
3726                                 # Add a sub-object
3727                                 my @attrs = ( "cn", $ldapm,
3728                                               "objectClass", "webminAcl",
3729                                               "webminAclEntry", \@al );
3730                                 $rv = $dbh->add("cn=".$ldapm.",".$user->dn(),
3731                                                 attr => \@attrs);
3732                                 }
3733                         if (!$rv || $rv->code) {
3734                                 &error(&text('euserdbacl2',
3735                                      $rv ? $rv->error : "Unknown error"));
3736                                 }
3737                         }
3738                 }
3739         &disconnect_userdb($userdb, $dbh);
3740         }
3741
3742 if (!$foundindb) {
3743         # Save ACL to local file
3744         if (!-d "$config_directory/$m") {
3745                 mkdir("$config_directory/$m", 0755);
3746                 }
3747         if ($_[0]) {
3748                 &write_file("$config_directory/$m/$u.acl", $_[0]);
3749                 }
3750         else {
3751                 &unlink_file("$config_directory/$m/$u.acl");
3752                 }
3753         }
3754 }
3755
3756 =head2 save_group_module_acl(&acl, group, [module], [never-update-group])
3757
3758 Updates the acl hash for some group and module. The parameters are :
3759
3760 =item acl - Hash reference for the new access control options.
3761
3762 =item group - Group name to update.
3763
3764 =item module - Module to update, defaulting to the caller.
3765
3766 =item never-update-group - Never update the parent group's ACL
3767
3768 =cut
3769 sub save_group_module_acl
3770 {
3771 my $g = $_[1];
3772 my $m = defined($_[2]) ? $_[2] : &get_module_name();
3773 if (!$_[3] && &foreign_check("acl")) {
3774         # Check if this group is a member of a group, and if it gets the
3775         # module from a group. If so, update the parent ACL as well
3776         &foreign_require("acl", "acl-lib.pl");
3777         my $group;
3778         foreach my $pg (&acl::list_groups()) {
3779                 if (&indexof('@'.$g, @{$pg->{'members'}}) >= 0 &&
3780                     &indexof($m, @{$pg->{'modules'}}) >= 0) {
3781                         $group = $g;
3782                         last;
3783                         }
3784                 }
3785         if ($group) {
3786                 &save_group_module_acl($_[0], $group->{'name'}, $m);
3787                 }
3788         }
3789
3790 my $userdb = &get_userdb_string();
3791 my $foundindb = 0;
3792 if ($userdb) {
3793         # Look for this group in the user/group DB
3794         my ($dbh, $proto, $prefix, $args) = &connect_userdb($userdb);
3795         ref($dbh) || &error(&text('egroupdbacl', $dbh));
3796         if ($proto eq "mysql" || $proto eq "postgresql") {
3797                 # Find the group in the SQL DB
3798                 my $cmd = $dbh->prepare(
3799                         "select id from webmin_group where name = ?");
3800                 $cmd && $cmd->execute($g) ||
3801                         &error(&text('egroupdbacl2', $dbh->errstr));
3802                 my ($id) = $cmd->fetchrow();
3803                 $foundindb = 1 if (defined($id));
3804                 $cmd->finish();
3805
3806                 # Replace ACLs for group
3807                 if ($foundindb) {
3808                         my $cmd = $dbh->prepare("delete from webmin_group_acl ".
3809                                                 "where id = ? and module = ?");
3810                         $cmd && $cmd->execute($id, $m) ||
3811                             &error(&text('egroupdbacl', $dbh->errstr));
3812                         $cmd->finish();
3813                         if ($_[0]) {
3814                                 my $cmd = $dbh->prepare(
3815                                     "insert into webmin_group_acl ".
3816                                     "(id,module,attr,value) values (?,?,?,?)");
3817                                 $cmd || &error(&text('egroupdbacl2',
3818                                                      $dbh->errstr));
3819                                 foreach my $a (keys %{$_[0]}) {
3820                                         $cmd->execute($id,$m,$a,$_[0]->{$a}) ||
3821                                             &error(&text('egroupdbacl2',
3822                                                          $dbh->errstr));
3823                                         $cmd->finish();
3824                                         }
3825                                 }
3826                         }
3827                 }
3828         elsif ($proto eq "ldap") {
3829                 # Find the group in LDAP
3830                 my $rv = $dbh->search(
3831                         base => $prefix,
3832                         filter => '(&(cn='.$g.')(objectClass='.
3833                                   $args->{'groupclass'}.'))',
3834                         scope => 'sub');
3835                 if (!$rv || $rv->code) {
3836                         &error(&text('egroupdbacl',
3837                                      $rv ? $rv->error : "Unknown error"));
3838                         }
3839                 my ($group) = $rv->all_entries;
3840
3841                 my $ldapm = $m || "global";
3842                 if ($group) {
3843                         # Find the ACL sub-object for the module
3844                         $foundindb = 1;
3845                         my $rv = $dbh->search(
3846                                 base => $group->dn(),
3847                                 filter => '(cn='.$ldapm.')',
3848                                 scope => 'one');
3849                         if (!$rv || $rv->code) {
3850                                 &error(&text('egroupdbacl',
3851                                      $rv ? $rv->error : "Unknown error"));
3852                                 }
3853                         my ($acl) = $rv->all_entries;
3854
3855                         my @al;
3856                         foreach my $a (keys %{$_[0]}) {
3857                                 push(@al, $a."=".$_[0]->{$a});
3858                                 }
3859                         if ($acl) {
3860                                 # Update attributes
3861                                 $rv = $dbh->modify($acl->dn(),
3862                                         replace => { "webminAclEntry", \@al });
3863                                 }
3864                         else {
3865                                 # Add a sub-object
3866                                 my @attrs = ( "cn", $ldapm,
3867                                               "objectClass", "webminAcl",
3868                                               "webminAclEntry", \@al );
3869                                 $rv = $dbh->add("cn=".$ldapm.",".$group->dn(),
3870                                                 attr => \@attrs);
3871                                 }
3872                         if (!$rv || $rv->code) {
3873                                 &error(&text('egroupdbacl2',
3874                                      $rv ? $rv->error : "Unknown error"));
3875                                 }
3876                         }
3877                 }
3878         &disconnect_userdb($userdb, $dbh);
3879         }
3880
3881 if (!$foundindb) {
3882         # Save ACL to local file
3883         if (!-d "$config_directory/$m") {
3884                 mkdir("$config_directory/$m", 0755);
3885                 }
3886         if ($_[0]) {
3887                 &write_file("$config_directory/$m/$g.gacl", $_[0]);
3888                 }
3889         else {
3890                 &unlink_file("$config_directory/$m/$g.gacl");
3891                 }
3892         }
3893 }
3894
3895 =head2 init_config
3896
3897 This function must be called by all Webmin CGI scripts, either directly or
3898 indirectly via a per-module lib.pl file. It performs a number of initialization
3899 and housekeeping tasks, such as working out the module name, checking that the
3900 current user has access to the module, and populating global variables. Some
3901 of the variables set include :
3902
3903 =item $config_directory - Base Webmin config directory, typically /etc/webmin
3904
3905 =item $var_directory - Base logs directory, typically /var/webmin
3906
3907 =item %config - Per-module configuration.
3908
3909 =item %gconfig - Global configuration.
3910
3911 =item $scriptname - Base name of the current perl script.
3912
3913 =item $module_name - The name of the current module.
3914
3915 =item $module_config_directory - The config directory for this module.
3916
3917 =item $module_config_file - The config file for this module.
3918
3919 =item $module_root_directory - This module's code directory.
3920
3921 =item $webmin_logfile - The detailed logfile for webmin.
3922
3923 =item $remote_user - The actual username used to login to webmin.
3924
3925 =item $base_remote_user - The username whose permissions are in effect.
3926
3927 =item $current_theme - The theme currently in use.
3928
3929 =item $root_directory - The first root directory of this webmin install.
3930
3931 =item @root_directories - All root directories for this webmin install.
3932
3933 =cut
3934 sub init_config
3935 {
3936 # Record first process ID that called this, so we know when it exited to clean
3937 # up temp files
3938 $main::initial_process_id ||= $$;
3939
3940 # Configuration and spool directories
3941 if (!defined($ENV{'WEBMIN_CONFIG'})) {
3942         die "WEBMIN_CONFIG not set";
3943         }
3944 $config_directory = $ENV{'WEBMIN_CONFIG'};
3945 if (!defined($ENV{'WEBMIN_VAR'})) {
3946         open(VARPATH, "$config_directory/var-path");
3947         chop($var_directory = <VARPATH>);
3948         close(VARPATH);
3949         }
3950 else {
3951         $var_directory = $ENV{'WEBMIN_VAR'};
3952         }
3953 $main::http_cache_directory = $ENV{'WEBMIN_VAR'}."/cache";
3954 $main::default_debug_log_file = $ENV{'WEBMIN_VAR'}."/webmin.debug";
3955
3956 if ($ENV{'SESSION_ID'}) {
3957         # Hide this variable from called programs, but keep it for internal use
3958         $main::session_id = $ENV{'SESSION_ID'};
3959         delete($ENV{'SESSION_ID'});
3960         }
3961 if ($ENV{'REMOTE_PASS'}) {
3962         # Hide the password too
3963         $main::remote_pass = $ENV{'REMOTE_PASS'};
3964         delete($ENV{'REMOTE_PASS'});
3965         }
3966
3967 if ($> == 0 && $< != 0 && !$ENV{'FOREIGN_MODULE_NAME'}) {
3968         # Looks like we are running setuid, but the real UID hasn't been set.
3969         # Do so now, so that executed programs don't get confused
3970         $( = $);
3971         $< = $>;
3972         }
3973
3974 # Read the webmin global config file. This contains the OS type and version,
3975 # OS specific configuration and global options such as proxy servers
3976 $config_file = "$config_directory/config";
3977 %gconfig = ( );
3978 &read_file_cached($config_file, \%gconfig);
3979 $null_file = $gconfig{'os_type'} eq 'windows' ? "NUL" : "/dev/null";
3980 $path_separator = $gconfig{'os_type'} eq 'windows' ? ';' : ':';
3981
3982 # If debugging is enabled, open the debug log
3983 if ($gconfig{'debug_enabled'} && !$main::opened_debug_log++) {
3984         my $dlog = $gconfig{'debug_file'} || $main::default_debug_log_file;
3985         if ($gconfig{'debug_size'}) {
3986                 my @st = stat($dlog);
3987                 if ($st[7] > $gconfig{'debug_size'}) {
3988                         rename($dlog, $dlog.".0");
3989                         }
3990                 }
3991         open(main::DEBUGLOG, ">>$dlog");
3992         $main::opened_debug_log = 1;
3993
3994         if ($gconfig{'debug_what_start'}) {
3995                 my $script_name = $0 =~ /([^\/]+)$/ ? $1 : '-';
3996                 $main::debug_log_start_time = time();
3997                 &webmin_debug_log("START", "script=$script_name");
3998                 $main::debug_log_start_module = $module_name;
3999                 }
4000         }
4001
4002 # Set PATH and LD_LIBRARY_PATH
4003 if ($gconfig{'path'}) {
4004         if ($gconfig{'syspath'}) {
4005                 # Webmin only
4006                 $ENV{'PATH'} = $gconfig{'path'};
4007                 }
4008         else {
4009                 # Include OS too
4010                 $ENV{'PATH'} = $gconfig{'path'}.$path_separator.$ENV{'PATH'};
4011                 }
4012         }
4013 $ENV{$gconfig{'ld_env'}} = $gconfig{'ld_path'} if ($gconfig{'ld_env'});
4014
4015 # Set http_proxy and ftp_proxy environment variables, based on Webmin settings
4016 if ($gconfig{'http_proxy'}) {
4017         $ENV{'http_proxy'} = $gconfig{'http_proxy'};
4018         }
4019 if ($gconfig{'ftp_proxy'}) {
4020         $ENV{'ftp_proxy'} = $gconfig{'ftp_proxy'};
4021         }
4022 if ($gconfig{'noproxy'}) {
4023         $ENV{'no_proxy'} = $gconfig{'noproxy'};
4024         }
4025
4026 # Find all root directories
4027 my %miniserv;
4028 if (&get_miniserv_config(\%miniserv)) {
4029         @root_directories = ( $miniserv{'root'} );
4030         for($i=0; defined($miniserv{"extraroot_$i"}); $i++) {
4031                 push(@root_directories, $miniserv{"extraroot_$i"});
4032                 }
4033         }
4034
4035 # Work out which module we are in, and read the per-module config file
4036 $0 =~ s/\\/\//g;        # Force consistent path on Windows
4037 if (defined($ENV{'FOREIGN_MODULE_NAME'})) {
4038         # In a foreign call - use the module name given
4039         $root_directory = $ENV{'FOREIGN_ROOT_DIRECTORY'};
4040         $module_name = $ENV{'FOREIGN_MODULE_NAME'};
4041         @root_directories = ( $root_directory ) if (!@root_directories);
4042         }
4043 elsif ($ENV{'SCRIPT_NAME'}) {
4044         my $sn = $ENV{'SCRIPT_NAME'};
4045         $sn =~ s/^$gconfig{'webprefix'}//
4046                 if (!$gconfig{'webprefixnoredir'});
4047         if ($sn =~ /^\/([^\/]+)\//) {
4048                 # Get module name from CGI path
4049                 $module_name = $1;
4050                 }
4051         if ($ENV{'SERVER_ROOT'}) {
4052                 $root_directory = $ENV{'SERVER_ROOT'};
4053                 }
4054         elsif ($ENV{'SCRIPT_FILENAME'}) {
4055                 $root_directory = $ENV{'SCRIPT_FILENAME'};
4056                 $root_directory =~ s/$sn$//;
4057                 }
4058         @root_directories = ( $root_directory ) if (!@root_directories);
4059         }
4060 else {
4061         # Get root directory from miniserv.conf, and deduce module name from $0
4062         $root_directory = $root_directories[0];
4063         my $rok = 0;
4064         foreach my $r (@root_directories) {
4065                 if ($0 =~ /^$r\/([^\/]+)\/[^\/]+$/i) {
4066                         # Under a module directory
4067                         $module_name = $1;
4068                         $rok = 1;
4069                         last;
4070                         }
4071                 elsif ($0 =~ /^$root_directory\/[^\/]+$/i) {
4072                         # At the top level
4073                         $rok = 1;
4074                         last;
4075                         }
4076                 }
4077         &error("Script was not run with full path (failed to find $0 under $root_directory)") if (!$rok);
4078         }
4079
4080 # Work out of this is a web, command line or cron job
4081 if (!$main::webmin_script_type) {
4082         if ($ENV{'SCRIPT_NAME'}) {
4083                 # Run via a CGI
4084                 $main::webmin_script_type = 'web';
4085                 }
4086         else {
4087                 # Cron jobs have no TTY
4088                 if ($gconfig{'os_type'} eq 'windows' ||
4089                     open(DEVTTY, ">/dev/tty")) {
4090                         $main::webmin_script_type = 'cmd';
4091                         close(DEVTTY);
4092                         }
4093                 else {
4094                         $main::webmin_script_type = 'cron';
4095                         }
4096                 }
4097         }
4098
4099 # Set the umask based on config
4100 if ($gconfig{'umask'} && !$main::umask_already++) {
4101         umask(oct($gconfig{'umask'}));
4102         }
4103
4104 # If this is a cron job or other background task, set the nice level
4105 if (!$main::nice_already && $main::webmin_script_type eq 'cron') {
4106         # Set nice level
4107         if ($gconfig{'nice'}) {
4108                 eval 'POSIX::nice($gconfig{\'nice\'});';
4109                 }
4110
4111         # Set IO scheduling class and priority
4112         if ($gconfig{'sclass'} ne '' || $gconfig{'sprio'} ne '') {
4113                 my $cmd = "ionice";
4114                 $cmd .= " -c ".quotemeta($gconfig{'sclass'})
4115                         if ($gconfig{'sclass'} ne '');
4116                 $cmd .= " -n ".quotemeta($gconfig{'sprio'})
4117                         if ($gconfig{'sprio'} ne '');
4118                 $cmd .= " -p $$";
4119                 &execute_command("$cmd >/dev/null 2>&1");
4120                 }
4121         }
4122 $main::nice_already++;
4123
4124 # Get the username
4125 my $u = $ENV{'BASE_REMOTE_USER'} || $ENV{'REMOTE_USER'};
4126 $base_remote_user = $u;
4127 $remote_user = $ENV{'REMOTE_USER'};
4128
4129 # Work out if user is definitely in the DB, and if so get his attrs
4130 $remote_user_proto = $ENV{"REMOTE_USER_PROTO"};
4131 %remote_user_attrs = ( );
4132 if ($remote_user_proto) {
4133         my $userdb = &get_userdb_string();
4134         my ($dbh, $proto, $prefix, $args) =
4135                 $userdb ? &connect_userdb($userdb) : ( );
4136         if (ref($dbh)) {
4137                 if ($proto eq "mysql" || $proto eq "postgresql") {
4138                         # Read attrs from SQL
4139                         my $cmd = $dbh->prepare("select webmin_user_attr.attr,webmin_user_attr.value from webmin_user_attr,webmin_user where webmin_user_attr.id = webmin_user.id and webmin_user.name = ?");
4140                         if ($cmd && $cmd->execute($base_remote_user)) {
4141                                 while(my ($attr, $value) = $cmd->fetchrow()) {
4142                                         $remote_user_attrs{$attr} = $value;
4143                                         }
4144                                 $cmd->finish();
4145                                 }
4146                         }
4147                 elsif ($proto eq "ldap") {
4148                         # Read attrs from LDAP
4149                         my $rv = $dbh->search(
4150                                 base => $prefix,
4151                                 filter => '(&(cn='.$base_remote_user.')'.
4152                                           '(objectClass='.
4153                                           $args->{'userclass'}.'))',
4154                                 scope => 'sub');
4155                         my ($u) = $rv && !$rv->code ? $rv->all_entries : ( );
4156                         if ($u) {
4157                                 foreach $la ($u->get_value('webminAttr')) {
4158                                         my ($attr, $value) = split(/=/, $la, 2);
4159                                         $remote_user_attrs{$attr} = $value;
4160                                         }
4161                                 }
4162                         }
4163                 &disconnect_userdb($userdb, $dbh);
4164                 }
4165         }
4166
4167 if ($module_name) {
4168         # Find and load the configuration file for this module
4169         my (@ruinfo, $rgroup);
4170         $module_config_directory = "$config_directory/$module_name";
4171         if (&get_product_name() eq "usermin" &&
4172             -r "$module_config_directory/config.$remote_user") {
4173                 # Based on username
4174                 $module_config_file = "$module_config_directory/config.$remote_user";
4175                 }
4176         elsif (&get_product_name() eq "usermin" &&
4177             (@ruinfo = getpwnam($remote_user)) &&
4178             ($rgroup = getgrgid($ruinfo[3])) &&
4179             -r "$module_config_directory/config.\@$rgroup") {
4180                 # Based on group name
4181                 $module_config_file = "$module_config_directory/config.\@$rgroup";
4182                 }
4183         else {
4184                 # Global config
4185                 $module_config_file = "$module_config_directory/config";
4186                 }
4187         %config = ( );
4188         &read_file_cached($module_config_file, \%config);
4189
4190         # Fix up windows-specific substitutions in values
4191         foreach my $k (keys %config) {
4192                 if ($config{$k} =~ /\$\{systemroot\}/) {
4193                         my $root = &get_windows_root();
4194                         $config{$k} =~ s/\$\{systemroot\}/$root/g;
4195                         }
4196                 }
4197         }
4198
4199 # Record the initial module
4200 $main::initial_module_name ||= $module_name;
4201
4202 # Set some useful variables
4203 my $current_themes;
4204 $current_themes = $ENV{'MOBILE_DEVICE'} && defined($gconfig{'mobile_theme'}) ?
4205                     $gconfig{'mobile_theme'} :
4206                   defined($remote_user_attrs{'theme'}) ?
4207                     $remote_user_attrs{'theme'} :
4208                   defined($gconfig{'theme_'.$remote_user}) ?
4209                     $gconfig{'theme_'.$remote_user} :
4210                   defined($gconfig{'theme_'.$base_remote_user}) ?
4211                     $gconfig{'theme_'.$base_remote_user} :
4212                     $gconfig{'theme'};
4213 @current_themes = split(/\s+/, $current_themes);
4214 $current_theme = $current_themes[0];
4215 @theme_root_directories = map { "$root_directory/$_" } @current_themes;
4216 $theme_root_directory = $theme_root_directories[0];
4217 @theme_configs = ( );
4218 foreach my $troot (@theme_root_directories) {
4219         my %onetconfig;
4220         &read_file_cached("$troot/config", \%onetconfig);
4221         &read_file_cached("$troot/config", \%tconfig);
4222         push(@theme_configs, \%onetconfig);
4223         }
4224 $tb = defined($tconfig{'cs_header'}) ? "bgcolor=#$tconfig{'cs_header'}" :
4225       defined($gconfig{'cs_header'}) ? "bgcolor=#$gconfig{'cs_header'}" :
4226                                        "bgcolor=#9999ff";
4227 $cb = defined($tconfig{'cs_table'}) ? "bgcolor=#$tconfig{'cs_table'}" :
4228       defined($gconfig{'cs_table'}) ? "bgcolor=#$gconfig{'cs_table'}" :
4229                                       "bgcolor=#cccccc";
4230 $tb .= ' '.$tconfig{'tb'} if ($tconfig{'tb'});
4231 $cb .= ' '.$tconfig{'cb'} if ($tconfig{'cb'});
4232 if ($tconfig{'preload_functions'}) {
4233         # Force load of theme functions right now, if requested
4234         &load_theme_library();
4235         }
4236 if ($tconfig{'oofunctions'} && !$main::loaded_theme_oo_library++) {
4237         # Load the theme's Webmin:: package classes
4238         do "$theme_root_directory/$tconfig{'oofunctions'}";
4239         }
4240
4241 $0 =~ /([^\/]+)$/;
4242 $scriptname = $1;
4243 $webmin_logfile = $gconfig{'webmin_log'} ? $gconfig{'webmin_log'}
4244                                          : "$var_directory/webmin.log";
4245
4246 # Load language strings into %text
4247 my @langs = &list_languages();
4248 my $accepted_lang;
4249 if ($gconfig{'acceptlang'}) {
4250         foreach my $a (split(/,/, $ENV{'HTTP_ACCEPT_LANGUAGE'})) {
4251                 my ($al) = grep { $_->{'lang'} eq $a } @langs;
4252                 if ($al) {
4253                         $accepted_lang = $al->{'lang'};
4254                         last;
4255                         }
4256                 }
4257         }
4258 $current_lang = $force_lang ? $force_lang :
4259     $accepted_lang ? $accepted_lang :
4260     $remote_user_attrs{'lang'} ? $remote_user_attrs{'lang'} :
4261     $gconfig{"lang_$remote_user"} ? $gconfig{"lang_$remote_user"} :
4262     $gconfig{"lang_$base_remote_user"} ? $gconfig{"lang_$base_remote_user"} :
4263     $gconfig{"lang"} ? $gconfig{"lang"} : $default_lang;
4264 foreach my $l (@langs) {
4265         $current_lang_info = $l if ($l->{'lang'} eq $current_lang);
4266         }
4267 @lang_order_list = &unique($default_lang,
4268                            split(/:/, $current_lang_info->{'fallback'}),
4269                            $current_lang);
4270 %text = &load_language($module_name);
4271 %text || &error("Failed to determine Webmin root from SERVER_ROOT, SCRIPT_FILENAME or the full command line");
4272
4273 # Get the %module_info for this module
4274 if ($module_name) {
4275         my ($mi) = grep { $_->{'dir'} eq $module_name }
4276                          &get_all_module_infos(2);
4277         %module_info = %$mi;
4278         $module_root_directory = &module_root_directory($module_name);
4279         }
4280
4281 if ($module_name && !$main::no_acl_check &&
4282     !defined($ENV{'FOREIGN_MODULE_NAME'})) {
4283         # Check if the HTTP user can access this module
4284         if (!&foreign_available($module_name)) {
4285                 if (!&foreign_check($module_name)) {
4286                         &error(&text('emodulecheck',
4287                                      "<i>$module_info{'desc'}</i>"));
4288                         }
4289                 else {
4290                         &error(&text('emodule', "<i>$u</i>",
4291                                      "<i>$module_info{'desc'}</i>"));
4292                         }
4293                 }
4294         $main::no_acl_check++;
4295         }
4296
4297 # Check the Referer: header for nasty redirects
4298 my @referers = split(/\s+/, $gconfig{'referers'});
4299 my $referer_site;
4300 my $r = $ENV{'HTTP_REFERER'};
4301 if ($r =~ /^(http|https|ftp):\/\/([^:\/]+:[^@\/]+@)?\[([^\]]+)\]/ ||
4302     $r =~ /^(http|https|ftp):\/\/([^:\/]+:[^@\/]+@)?([^\/:@]+)/) {
4303         $referer_site = $3;
4304         }
4305 my $http_host = $ENV{'HTTP_HOST'};
4306 $http_host =~ s/:\d+$//;
4307 $http_host =~ s/^\[(\S+)\]$/$1/;
4308 my $unsafe_index = $unsafe_index_cgi ||
4309                    &get_module_variable('$unsafe_index_cgi');
4310 if ($0 &&
4311     ($ENV{'SCRIPT_NAME'} !~ /^\/(index.cgi)?$/ || $unsafe_index) &&
4312     ($ENV{'SCRIPT_NAME'} !~ /^\/([a-z0-9\_\-]+)\/(index.cgi)?$/i ||
4313      $unsafe_index) &&
4314     $0 !~ /(session_login|pam_login)\.cgi$/ && !$gconfig{'referer'} &&
4315     $ENV{'MINISERV_CONFIG'} && !$main::no_referers_check &&
4316     $ENV{'HTTP_USER_AGENT'} !~ /^Webmin/i &&
4317     ($referer_site && $referer_site ne $http_host &&
4318      &indexof($referer_site, @referers) < 0 ||
4319     !$referer_site && $gconfig{'referers_none'}) &&
4320     !$trust_unknown_referers &&
4321     !&get_module_variable('$trust_unknown_referers')) {
4322         # Looks like a link from elsewhere .. show an error
4323         &header($text{'referer_title'}, "", undef, 0, 1, 1);
4324
4325         $prot = lc($ENV{'HTTPS'}) eq 'on' ? "https" : "http";
4326         my $url = "<tt>".&html_escape("$prot://$ENV{'HTTP_HOST'}$ENV{'REQUEST_URI'}")."</tt>";
4327         if ($referer_site) {
4328                 # From a known host
4329                 print &text('referer_warn',
4330                             "<tt>".&html_escape($r)."</tt>", $url);
4331                 print "<p>\n";
4332                 print &text('referer_fix1', &html_escape($http_host)),"<p>\n";
4333                 print &text('referer_fix2', &html_escape($http_host)),"<p>\n";
4334                 }
4335         else {
4336                 # No referer info given
4337                 print &text('referer_warn_unknown', $url),"<p>\n";
4338                 print &text('referer_fix1u'),"<p>\n";
4339                 print &text('referer_fix2u'),"<p>\n";
4340                 }
4341         print "<p>\n";
4342
4343         &footer("/", $text{'index'});
4344         exit;
4345         }
4346 $main::no_referers_check++;
4347 $main::completed_referers_check++;
4348
4349 # Call theme post-init
4350 if (defined(&theme_post_init_config)) {
4351         &theme_post_init_config(@_);
4352         }
4353
4354 # Record that we have done the calling library in this package
4355 my ($callpkg, $lib) = caller();
4356 $lib =~ s/^.*\///;
4357 $main::done_foreign_require{$callpkg,$lib} = 1;
4358
4359 # If a licence checking is enabled, do it now
4360 if ($gconfig{'licence_module'} && !$main::done_licence_module_check &&
4361     &foreign_check($gconfig{'licence_module'}) &&
4362     -r "$root_directory/$gconfig{'licence_module'}/licence_check.pl") {
4363         my $oldpwd = &get_current_dir();
4364         $main::done_licence_module_check++;
4365         $main::licence_module = $gconfig{'licence_module'};
4366         &foreign_require($main::licence_module, "licence_check.pl");
4367         ($main::licence_status, $main::licence_message) =
4368                 &foreign_call($main::licence_module, "check_licence");
4369         chdir($oldpwd);
4370         }
4371
4372 # Export global variables to caller
4373 if ($main::export_to_caller) {
4374         foreach my $v ('$config_file', '%gconfig', '$null_file',
4375                        '$path_separator', '@root_directories',
4376                        '$root_directory', '$module_name',
4377                        '$base_remote_user', '$remote_user',
4378                        '$remote_user_proto', '%remote_user_attrs',
4379                        '$module_config_directory', '$module_config_file',
4380                        '%config', '@current_themes', '$current_theme',
4381                        '@theme_root_directories', '$theme_root_directory',
4382                        '%tconfig','@theme_configs', '$tb', '$cb', '$scriptname',
4383                        '$webmin_logfile', '$current_lang',
4384                        '$current_lang_info', '@lang_order_list', '%text',
4385                        '%module_info', '$module_root_directory') {
4386                 my ($vt, $vn) = split('', $v, 2);
4387                 eval "${vt}${callpkg}::${vn} = ${vt}${vn}";
4388                 }
4389         }
4390
4391 return 1;
4392 }
4393
4394 =head2 load_language([module], [directory])
4395
4396 Returns a hashtable mapping text codes to strings in the appropriate language,
4397 based on the $current_lang global variable, which is in turn set based on
4398 the Webmin user's selection. The optional module parameter tells the function
4399 which module to load strings for, and defaults to the calling module. The
4400 optional directory parameter can be used to load strings from a directory
4401 other than lang.
4402
4403 In regular module development you will never need to call this function
4404 directly, as init_config calls it for you, and places the module's strings
4405 into the %text hash.
4406
4407 =cut
4408 sub load_language
4409 {
4410 my %text;
4411 my $root = $root_directory;
4412 my $ol = $gconfig{'overlang'};
4413 my ($dir) = ($_[1] || "lang");
4414
4415 # Read global lang files
4416 foreach my $o (@lang_order_list) {
4417         my $ok = &read_file_cached("$root/$dir/$o", \%text);
4418         return () if (!$ok && $o eq $default_lang);
4419         }
4420 if ($ol) {
4421         foreach my $o (@lang_order_list) {
4422                 &read_file_cached("$root/$ol/$o", \%text);
4423                 }
4424         }
4425 &read_file_cached("$config_directory/custom-lang", \%text);
4426
4427 if ($_[0]) {
4428         # Read module's lang files
4429         my $mdir = &module_root_directory($_[0]);
4430         foreach my $o (@lang_order_list) {
4431                 &read_file_cached("$mdir/$dir/$o", \%text);
4432                 }
4433         if ($ol) {
4434                 foreach $o (@lang_order_list) {
4435                         &read_file_cached("$mdir/$ol/$o", \%text);
4436                         }
4437                 }
4438         &read_file_cached("$config_directory/$_[0]/custom-lang", \%text);
4439         }
4440 foreach $k (keys %text) {
4441         $text{$k} =~ s/\$(\{([^\}]+)\}|([A-Za-z0-9\.\-\_]+))/text_subs($2 || $3,\%text)/ge;
4442         }
4443
4444 if (defined(&theme_load_language)) {
4445         &theme_load_language(\%text, $_[0]);
4446         }
4447 return %text;
4448 }
4449
4450 =head2 text_subs(string)
4451
4452 Used internally by load_language to expand $code substitutions in language
4453 files.
4454
4455 =cut
4456 sub text_subs
4457 {
4458 if (substr($_[0], 0, 8) eq "include:") {
4459         local $_;
4460         my $rv;
4461         open(INCLUDE, substr($_[0], 8));
4462         while(<INCLUDE>) {
4463                 $rv .= $_;
4464                 }
4465         close(INCLUDE);
4466         return $rv;
4467         }
4468 else {
4469         my $t = $_[1]->{$_[0]};
4470         return defined($t) ? $t : '$'.$_[0];
4471         }
4472 }
4473
4474 =head2 text(message, [substitute]+)
4475
4476 Returns a translated message from %text, but with $1, $2, etc.. replaced with
4477 the substitute parameters. This makes it easy to use strings with placeholders
4478 that get replaced with programmatically generated text. For example :
4479
4480  print &text('index_hello', $remote_user),"<p>\n";
4481
4482 =cut
4483 sub text
4484 {
4485 my $t = &get_module_variable('%text', 1);
4486 my $rv = exists($t->{$_[0]}) ? $t->{$_[0]} : $text{$_[0]};
4487 for(my $i=1; $i<@_; $i++) {
4488         $rv =~ s/\$$i/$_[$i]/g;
4489         }
4490 return $rv;
4491 }
4492
4493 =head2 encode_base64(string)
4494
4495 Encodes a string into base64 format, for use in MIME email or HTTP
4496 authorization headers.
4497
4498 =cut
4499 sub encode_base64
4500 {
4501 my $res;
4502 pos($_[0]) = 0;                          # ensure start at the beginning
4503 while ($_[0] =~ /(.{1,57})/gs) {
4504         $res .= substr(pack('u57', $1), 1)."\n";
4505         chop($res);
4506         }
4507 $res =~ tr|\` -_|AA-Za-z0-9+/|;
4508 my $padding = (3 - length($_[0]) % 3) % 3;
4509 $res =~ s/.{$padding}$/'=' x $padding/e if ($padding);
4510 return $res;
4511 }
4512
4513 =head2 decode_base64(string)
4514
4515 Converts a base64-encoded string into plain text. The opposite of encode_base64.
4516
4517 =cut
4518 sub decode_base64
4519 {
4520 my ($str) = @_;
4521 my $res;
4522 $str =~ tr|A-Za-z0-9+=/||cd;            # remove non-base64 chars
4523 if (length($str) % 4) {
4524         return undef;
4525 }
4526 $str =~ s/=+$//;                        # remove padding
4527 $str =~ tr|A-Za-z0-9+/| -_|;            # convert to uuencoded format
4528 while ($str =~ /(.{1,60})/gs) {
4529         my $len = chr(32 + length($1)*3/4); # compute length byte
4530         $res .= unpack("u", $len . $1 );    # uudecode
4531         }
4532 return $res;
4533 }
4534
4535 =head2 get_module_info(module, [noclone], [forcache])
4536
4537 Returns a hash containg details of the given module. Some useful keys are :
4538
4539 =item dir - The module directory, like sendmail.
4540
4541 =item desc - Human-readable description, in the current users' language.
4542
4543 =item version - Optional module version number.
4544
4545 =item os_support - List of supported operating systems and versions.
4546
4547 =item category - Category on Webmin's left menu, like net.
4548
4549 =cut
4550 sub get_module_info
4551 {
4552 return () if ($_[0] =~ /^\./);
4553 my (%rv, $clone, $o);
4554 my $mdir = &module_root_directory($_[0]);
4555 &read_file_cached("$mdir/module.info", \%rv) || return ();
4556 if (-l $mdir) {
4557         # A clone is a module that links to another directory under the root
4558         foreach my $r (@root_directories) {
4559                 if (&is_under_directory($r, $mdir)) {
4560                         $clone = 1;
4561                         last;
4562                         }
4563                 }
4564         }
4565 foreach $o (@lang_order_list) {
4566         $rv{"desc"} = $rv{"desc_$o"} if ($rv{"desc_$o"});
4567         $rv{"longdesc"} = $rv{"longdesc_$o"} if ($rv{"longdesc_$o"});
4568         }
4569 if ($clone && !$_[1] && $config_directory) {
4570         $rv{'clone'} = $rv{'desc'};
4571         &read_file("$config_directory/$_[0]/clone", \%rv);
4572         }
4573 $rv{'dir'} = $_[0];
4574 my %module_categories;
4575 &read_file_cached("$config_directory/webmin.cats", \%module_categories);
4576 my $pn = &get_product_name();
4577 if (defined($rv{'category_'.$pn})) {
4578         # Can override category for webmin/usermin
4579         $rv{'category'} = $rv{'category_'.$pn};
4580         }
4581 $rv{'realcategory'} = $rv{'category'};
4582 $rv{'category'} = $module_categories{$_[0]}
4583         if (defined($module_categories{$_[0]}));
4584
4585 # Apply description overrides
4586 $rv{'realdesc'} = $rv{'desc'};
4587 my %descs;
4588 &read_file_cached("$config_directory/webmin.descs", \%descs);
4589 if ($descs{$_[0]." ".$current_lang}) {
4590         $rv{'desc'} = $descs{$_[0]." ".$current_lang};
4591         }
4592 elsif ($descs{$_[0]}) {
4593         $rv{'desc'} = $descs{$_[0]};
4594         }
4595
4596 if (!$_[2]) {
4597         # Apply per-user description overridde
4598         my %gaccess = &get_module_acl(undef, "");
4599         if ($gaccess{'desc_'.$_[0]}) {
4600                 $rv{'desc'} = $gaccess{'desc_'.$_[0]};
4601                 }
4602         }
4603
4604 if ($rv{'longdesc'}) {
4605         # All standard modules have an index.cgi
4606         $rv{'index_link'} = 'index.cgi';
4607         }
4608
4609 # Call theme-specific override function
4610 if (defined(&theme_get_module_info)) {
4611         %rv = &theme_get_module_info(\%rv, $_[0], $_[1], $_[2]);
4612         }
4613
4614 return %rv;
4615 }
4616
4617 =head2 get_all_module_infos(cachemode)
4618
4619 Returns a list contains the information on all modules in this webmin
4620 install, including clones. Uses caching to reduce the number of module.info
4621 files that need to be read. Each element of the array is a hash reference
4622 in the same format as returned by get_module_info. The cache mode flag can be :
4623 0 = read and write, 1 = don't read or write, 2 = read only
4624
4625 =cut
4626 sub get_all_module_infos
4627 {
4628 my (%cache, @rv);
4629
4630 # Is the cache out of date? (ie. have any of the root's changed?)
4631 my $cache_file = "$config_directory/module.infos.cache";
4632 my $changed = 0;
4633 if (&read_file_cached($cache_file, \%cache)) {
4634         foreach my $r (@root_directories) {
4635                 my @st = stat($r);
4636                 if ($st[9] != $cache{'mtime_'.$r}) {
4637                         $changed = 2;
4638                         last;
4639                         }
4640                 }
4641         }
4642 else {
4643         $changed = 1;
4644         }
4645
4646 if ($_[0] != 1 && !$changed && $cache{'lang'} eq $current_lang) {
4647         # Can use existing module.info cache
4648         my %mods;
4649         foreach my $k (keys %cache) {
4650                 if ($k =~ /^(\S+) (\S+)$/) {
4651                         $mods{$1}->{$2} = $cache{$k};
4652                         }
4653                 }
4654         @rv = map { $mods{$_} } (keys %mods) if (%mods);
4655         }
4656 else {
4657         # Need to rebuild cache
4658         %cache = ( );
4659         foreach my $r (@root_directories) {
4660                 opendir(DIR, $r);
4661                 foreach my $m (readdir(DIR)) {
4662                         next if ($m =~ /^(config-|\.)/ || $m =~ /\.(cgi|pl)$/);
4663                         my %minfo = &get_module_info($m, 0, 1);
4664                         next if (!%minfo || !$minfo{'dir'});
4665                         push(@rv, \%minfo);
4666                         foreach $k (keys %minfo) {
4667                                 $cache{"${m} ${k}"} = $minfo{$k};
4668                                 }
4669                         }
4670                 closedir(DIR);
4671                 my @st = stat($r);
4672                 $cache{'mtime_'.$r} = $st[9];
4673                 }
4674         $cache{'lang'} = $current_lang;
4675         &write_file($cache_file, \%cache) if (!$_[0] && $< == 0 && $> == 0);
4676         }
4677
4678 # Override descriptions for modules for current user
4679 my %gaccess = &get_module_acl(undef, "");
4680 foreach my $m (@rv) {
4681         if ($gaccess{"desc_".$m->{'dir'}}) {
4682                 $m->{'desc'} = $gaccess{"desc_".$m->{'dir'}};
4683                 }
4684         }
4685
4686 # Apply installed flags
4687 my %installed;
4688 &read_file_cached("$config_directory/installed.cache", \%installed);
4689 foreach my $m (@rv) {
4690         $m->{'installed'} = $installed{$m->{'dir'}};
4691         }
4692
4693 return @rv;
4694 }
4695
4696 =head2 get_theme_info(theme)
4697
4698 Returns a hash containing a theme's details, taken from it's theme.info file.
4699 Some useful keys are :
4700
4701 =item dir - The theme directory, like blue-theme.
4702
4703 =item desc - Human-readable description, in the current users' language.
4704
4705 =item version - Optional module version number.
4706
4707 =item os_support - List of supported operating systems and versions.
4708
4709 =cut
4710 sub get_theme_info
4711 {
4712 return () if ($_[0] =~ /^\./);
4713 my %rv;
4714 my $tdir = &module_root_directory($_[0]);
4715 &read_file("$tdir/theme.info", \%rv) || return ();
4716 foreach my $o (@lang_order_list) {
4717         $rv{"desc"} = $rv{"desc_$o"} if ($rv{"desc_$o"});
4718         }
4719 $rv{"dir"} = $_[0];
4720 return %rv;
4721 }
4722
4723 =head2 list_languages
4724
4725 Returns an array of supported languages, taken from Webmin's os_list.txt file.
4726 Each is a hash reference with the following keys :
4727
4728 =item lang - The short language code, like es for Spanish.
4729
4730 =item desc - A human-readable description, in English.
4731
4732 =item charset - An optional character set to use when displaying the language.
4733
4734 =item titles - Set to 1 only if Webmin has title images for the language.
4735
4736 =item fallback - The code for another language to use if a string does not exist in this one. For all languages, English is the ultimate fallback.
4737
4738 =cut
4739 sub list_languages
4740 {
4741 if (!@main::list_languages_cache) {
4742         my $o;
4743         local $_;
4744         open(LANG, "$root_directory/lang_list.txt");
4745         while(<LANG>) {
4746                 if (/^(\S+)\s+(.*)/) {
4747                         my $l = { 'desc' => $2 };
4748                         foreach $o (split(/,/, $1)) {
4749                                 if ($o =~ /^([^=]+)=(.*)$/) {
4750                                         $l->{$1} = $2;
4751                                         }
4752                                 }
4753                         $l->{'index'} = scalar(@rv);
4754                         push(@main::list_languages_cache, $l);
4755                         }
4756                 }
4757         close(LANG);
4758         @main::list_languages_cache = sort { $a->{'desc'} cmp $b->{'desc'} }
4759                                      @main::list_languages_cache;
4760         }
4761 return @main::list_languages_cache;
4762 }
4763
4764 =head2 read_env_file(file, &hash)
4765
4766 Similar to Webmin's read_file function, but handles files containing shell
4767 environment variables formatted like :
4768
4769   export FOO=bar
4770   SMEG="spod"
4771
4772 The file parameter is the full path to the file to read, and hash a Perl hash
4773 ref to read names and values into.
4774
4775 =cut
4776 sub read_env_file
4777 {
4778 local $_;
4779 &open_readfile(FILE, $_[0]) || return 0;
4780 while(<FILE>) {
4781         s/#.*$//g;
4782         if (/^\s*(export\s*)?([A-Za-z0-9_\.]+)\s*=\s*"(.*)"/i ||
4783             /^\s*(export\s*)?([A-Za-z0-9_\.]+)\s*=\s*'(.*)'/i ||
4784             /^\s*(export\s*)?([A-Za-z0-9_\.]+)\s*=\s*(.*)/i) {
4785                 $_[1]->{$2} = $3;
4786                 }
4787         }
4788 close(FILE);
4789 return 1;
4790 }
4791
4792 =head2 write_env_file(file, &hash, [export])
4793
4794 Writes out a hash to a file in name='value' format, suitable for use in a shell
4795 script. The parameters are :
4796
4797 =item file - Full path for a file to write to
4798
4799 =item hash - Hash reference of names and values to write.
4800
4801 =item export - If set to 1, preceed each variable setting with the word 'export'.
4802
4803 =cut
4804 sub write_env_file
4805 {
4806 my $exp = $_[2] ? "export " : "";
4807 &open_tempfile(FILE, ">$_[0]");
4808 foreach my $k (keys %{$_[1]}) {
4809         my $v = $_[1]->{$k};
4810         if ($v =~ /^\S+$/) {
4811                 &print_tempfile(FILE, "$exp$k=$v\n");
4812                 }
4813         else {
4814                 &print_tempfile(FILE, "$exp$k=\"$v\"\n");
4815                 }
4816         }
4817 &close_tempfile(FILE);
4818 }
4819
4820 =head2 lock_file(filename, [readonly], [forcefile])
4821
4822 Lock a file for exclusive access. If the file is already locked, spin
4823 until it is freed. Uses a .lock file, which is not 100% reliable, but seems
4824 to work OK. The parameters are :
4825
4826 =item filename - File or directory to lock.
4827
4828 =item readonly - If set, the lock is for reading the file only. More than one script can have a readonly lock, but only one can hold a write lock.
4829
4830 =item forcefile - Force the file to be considered as a real file and not a symlink for Webmin actions logging purposes.
4831
4832 =cut
4833 sub lock_file
4834 {
4835 my $realfile = &translate_filename($_[0]);
4836 return 0 if (!$_[0] || defined($main::locked_file_list{$realfile}));
4837 my $no_lock = !&can_lock_file($realfile);
4838 my $lock_tries_count = 0;
4839 while(1) {
4840         my $pid;
4841         if (!$no_lock && open(LOCKING, "$realfile.lock")) {
4842                 $pid = <LOCKING>;
4843                 $pid = int($pid);
4844                 close(LOCKING);
4845                 }
4846         if ($no_lock || !$pid || !kill(0, $pid) || $pid == $$) {
4847                 # Got the lock!
4848                 if (!$no_lock) {
4849                         # Create the .lock file
4850                         open(LOCKING, ">$realfile.lock") || return 0;
4851                         my $lck = eval "flock(LOCKING, 2+4)";
4852                         if (!$lck && !$@) {
4853                                 # Lock of lock file failed! Wait till later
4854                                 goto tryagain;
4855                                 }
4856                         print LOCKING $$,"\n";
4857                         eval "flock(LOCKING, 8)";
4858                         close(LOCKING);
4859                         }
4860                 $main::locked_file_list{$realfile} = int($_[1]);
4861                 push(@main::temporary_files, "$realfile.lock");
4862                 if (($gconfig{'logfiles'} || $gconfig{'logfullfiles'}) &&
4863                     !&get_module_variable('$no_log_file_changes') &&
4864                     !$_[1]) {
4865                         # Grab a copy of this file for later diffing
4866                         my $lnk;
4867                         $main::locked_file_data{$realfile} = undef;
4868                         if (-d $realfile) {
4869                                 $main::locked_file_type{$realfile} = 1;
4870                                 $main::locked_file_data{$realfile} = '';
4871                                 }
4872                         elsif (!$_[2] && ($lnk = readlink($realfile))) {
4873                                 $main::locked_file_type{$realfile} = 2;
4874                                 $main::locked_file_data{$realfile} = $lnk;
4875                                 }
4876                         elsif (open(ORIGFILE, $realfile)) {
4877                                 $main::locked_file_type{$realfile} = 0;
4878                                 $main::locked_file_data{$realfile} = '';
4879                                 local $_;
4880                                 while(<ORIGFILE>) {
4881                                         $main::locked_file_data{$realfile} .=$_;
4882                                         }
4883                                 close(ORIGFILE);
4884                                 }
4885                         }
4886                 last;
4887                 }
4888 tryagain:
4889         sleep(1);
4890         if ($lock_tries_count++ > 5*60) {
4891                 # Give up after 5 minutes
4892                 &error(&text('elock_tries', "<tt>$realfile</tt>", 5));
4893                 }
4894         }
4895 return 1;
4896 }
4897
4898 =head2 unlock_file(filename)
4899
4900 Release a lock on a file taken out by lock_file. If Webmin actions logging of
4901 file changes is enabled, then at unlock file a diff will be taken between the
4902 old and new contents, and stored under /var/webmin/diffs when webmin_log is
4903 called. This can then be viewed in the Webmin Actions Log module.
4904
4905 =cut
4906 sub unlock_file
4907 {
4908 my $realfile = &translate_filename($_[0]);
4909 return if (!$_[0] || !defined($main::locked_file_list{$realfile}));
4910 unlink("$realfile.lock") if (&can_lock_file($realfile));
4911 delete($main::locked_file_list{$realfile});
4912 if (exists($main::locked_file_data{$realfile})) {
4913         # Diff the new file with the old
4914         stat($realfile);
4915         my $lnk = readlink($realfile);
4916         my $type = -d _ ? 1 : $lnk ? 2 : 0;
4917         my $oldtype = $main::locked_file_type{$realfile};
4918         my $new = !defined($main::locked_file_data{$realfile});
4919         if ($new && !-e _) {
4920                 # file doesn't exist, and never did! do nothing ..
4921                 }
4922         elsif ($new && $type == 1 || !$new && $oldtype == 1) {
4923                 # is (or was) a directory ..
4924                 if (-d _ && !defined($main::locked_file_data{$realfile})) {
4925                         push(@main::locked_file_diff,
4926                              { 'type' => 'mkdir', 'object' => $realfile });
4927                         }
4928                 elsif (!-d _ && defined($main::locked_file_data{$realfile})) {
4929                         push(@main::locked_file_diff,
4930                              { 'type' => 'rmdir', 'object' => $realfile });
4931                         }
4932                 }
4933         elsif ($new && $type == 2 || !$new && $oldtype == 2) {
4934                 # is (or was) a symlink ..
4935                 if ($lnk && !defined($main::locked_file_data{$realfile})) {
4936                         push(@main::locked_file_diff,
4937                              { 'type' => 'symlink', 'object' => $realfile,
4938                                'data' => $lnk });
4939                         }
4940                 elsif (!$lnk && defined($main::locked_file_data{$realfile})) {
4941                         push(@main::locked_file_diff,
4942                              { 'type' => 'unsymlink', 'object' => $realfile,
4943                                'data' => $main::locked_file_data{$realfile} });
4944                         }
4945                 elsif ($lnk ne $main::locked_file_data{$realfile}) {
4946                         push(@main::locked_file_diff,
4947                              { 'type' => 'resymlink', 'object' => $realfile,
4948                                'data' => $lnk });
4949                         }
4950                 }
4951         else {
4952                 # is a file, or has changed type?!
4953                 my ($diff, $delete_file);
4954                 my $type = "modify";
4955                 if (!-r _) {
4956                         open(NEWFILE, ">$realfile");
4957                         close(NEWFILE);
4958                         $delete_file++;
4959                         $type = "delete";
4960                         }
4961                 if (!defined($main::locked_file_data{$realfile})) {
4962                         $type = "create";
4963                         }
4964                 open(ORIGFILE, ">$realfile.webminorig");
4965                 print ORIGFILE $main::locked_file_data{$realfile};
4966                 close(ORIGFILE);
4967                 $diff = &backquote_command(
4968                         "diff ".quotemeta("$realfile.webminorig")." ".
4969                                 quotemeta($realfile)." 2>/dev/null");
4970                 push(@main::locked_file_diff,
4971                      { 'type' => $type, 'object' => $realfile,
4972                        'data' => $diff } ) if ($diff);
4973                 unlink("$realfile.webminorig");
4974                 unlink($realfile) if ($delete_file);
4975                 }
4976
4977         if ($gconfig{'logfullfiles'}) {
4978                 # Add file details to list of those to fully log
4979                 $main::orig_file_data{$realfile} ||=
4980                         $main::locked_file_data{$realfile};
4981                 $main::orig_file_type{$realfile} ||=
4982                         $main::locked_file_type{$realfile};
4983                 }
4984
4985         delete($main::locked_file_data{$realfile});
4986         delete($main::locked_file_type{$realfile});
4987         }
4988 }
4989
4990 =head2 test_lock(file)
4991
4992 Returns 1 if some file is currently locked, 0 if not.
4993
4994 =cut
4995 sub test_lock
4996 {
4997 my $realfile = &translate_filename($_[0]);
4998 return 0 if (!$_[0]);
4999 return 1 if (defined($main::locked_file_list{$realfile}));
5000 return 0 if (!&can_lock_file($realfile));
5001 my $pid;
5002 if (open(LOCKING, "$realfile.lock")) {
5003         $pid = <LOCKING>;
5004         $pid = int($pid);
5005         close(LOCKING);
5006         }
5007 return $pid && kill(0, $pid);
5008 }
5009
5010 =head2 unlock_all_files
5011
5012 Unlocks all files locked by the current script.
5013
5014 =cut
5015 sub unlock_all_files
5016 {
5017 foreach $f (keys %main::locked_file_list) {
5018         &unlock_file($f);
5019         }
5020 }
5021
5022 =head2 can_lock_file(file)
5023
5024 Returns 1 if some file should be locked, based on the settings in the
5025 Webmin Configuration module. For internal use by lock_file only.
5026
5027 =cut
5028 sub can_lock_file
5029 {
5030 if (&is_readonly_mode()) {
5031         return 0;       # never lock in read-only mode
5032         }
5033 elsif ($gconfig{'lockmode'} == 0) {
5034         return 1;       # always
5035         }
5036 elsif ($gconfig{'lockmode'} == 1) {
5037         return 0;       # never
5038         }
5039 else {
5040         # Check if under any of the directories
5041         my $match;
5042         foreach my $d (split(/\t+/, $gconfig{'lockdirs'})) {
5043                 if (&same_file($d, $_[0]) ||
5044                     &is_under_directory($d, $_[0])) {
5045                         $match = 1;
5046                         }
5047                 }
5048         return $gconfig{'lockmode'} == 2 ? $match : !$match;
5049         }
5050 }
5051
5052 =head2 webmin_log(action, type, object, &params, [module], [host, script-on-host, client-ip])
5053
5054 Log some action taken by a user. This is typically called at the end of a
5055 script, once all file changes are complete and all commands run. The
5056 parameters are :
5057
5058 =item action - A short code for the action being performed, like 'create'.
5059
5060 =item type - A code for the type of object the action is performed to, like 'user'.
5061
5062 =item object - A short name for the object, like 'joe' if the Unix user 'joe' was just created.
5063
5064 =item params - A hash ref of additional information about the action.
5065
5066 =item module - Name of the module in which the action was performed, which defaults to the current module.
5067
5068 =item host - Remote host on which the action was performed. You should never need to set this (or the following two parameters), as they are used only for remote Webmin logging.
5069
5070 =item script-on-host - Script name like create_user.cgi on the host the action was performed on.
5071
5072 =item client-ip - IP address of the browser that performed the action.
5073
5074 =cut
5075 sub webmin_log
5076 {
5077 return if (!$gconfig{'log'} || &is_readonly_mode());
5078 my $m = $_[4] ? $_[4] : &get_module_name();
5079
5080 if ($gconfig{'logclear'}) {
5081         # check if it is time to clear the log
5082         my @st = stat("$webmin_logfile.time");
5083         my $write_logtime = 0;
5084         if (@st) {
5085                 if ($st[9]+$gconfig{'logtime'}*60*60 < time()) {
5086                         # clear logfile and all diff files
5087                         &unlink_file("$ENV{'WEBMIN_VAR'}/diffs");
5088                         &unlink_file("$ENV{'WEBMIN_VAR'}/files");
5089                         &unlink_file("$ENV{'WEBMIN_VAR'}/annotations");
5090                         unlink($webmin_logfile);
5091                         $write_logtime = 1;
5092                         }
5093                 }
5094         else {
5095                 $write_logtime = 1;
5096                 }
5097         if ($write_logtime) {
5098                 open(LOGTIME, ">$webmin_logfile.time");
5099                 print LOGTIME time(),"\n";
5100                 close(LOGTIME);
5101                 }
5102         }
5103
5104 # If an action script directory is defined, call the appropriate scripts
5105 if ($gconfig{'action_script_dir'}) {
5106     my ($action, $type, $object) = ($_[0], $_[1], $_[2]);
5107     my ($basedir) = $gconfig{'action_script_dir'};
5108
5109     for my $dir ($basedir/$type/$action, $basedir/$type, $basedir) {
5110         if (-d $dir) {
5111             my ($file);
5112             opendir(DIR, $dir) or die "Can't open $dir: $!";
5113             while (defined($file = readdir(DIR))) {
5114                 next if ($file =~ /^\.\.?$/); # skip '.' and '..'
5115                 if (-x "$dir/$file") {
5116                     # Call a script notifying it of the action
5117                     my %OLDENV = %ENV;
5118                     $ENV{'ACTION_MODULE'} = &get_module_name();
5119                     $ENV{'ACTION_ACTION'} = $_[0];
5120                     $ENV{'ACTION_TYPE'} = $_[1];
5121                     $ENV{'ACTION_OBJECT'} = $_[2];
5122                     $ENV{'ACTION_SCRIPT'} = $script_name;
5123                     foreach my $p (keys %param) {
5124                             $ENV{'ACTION_PARAM_'.uc($p)} = $param{$p};
5125                             }
5126                     system("$dir/$file", @_,
5127                            "<$null_file", ">$null_file", "2>&1");
5128                     %ENV = %OLDENV;
5129                     }
5130                 }
5131             }
5132         }
5133     }
5134
5135 # should logging be done at all?
5136 return if ($gconfig{'logusers'} && &indexof($base_remote_user,
5137            split(/\s+/, $gconfig{'logusers'})) < 0);
5138 return if ($gconfig{'logmodules'} && &indexof($m,
5139            split(/\s+/, $gconfig{'logmodules'})) < 0);
5140
5141 # log the action
5142 my $now = time();
5143 my @tm = localtime($now);
5144 my $script_name = $0 =~ /([^\/]+)$/ ? $1 : '-';
5145 my $id = sprintf "%d.%d.%d", $now, $$, $main::action_id_count;
5146 $main::action_id_count++;
5147 my $line = sprintf "%s [%2.2d/%s/%4.4d %2.2d:%2.2d:%2.2d] %s %s %s %s %s \"%s\" \"%s\" \"%s\"",
5148         $id, $tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900,
5149         $tm[2], $tm[1], $tm[0],
5150         $remote_user || '-',
5151         $main::session_id || '-',
5152         $_[7] || $ENV{'REMOTE_HOST'} || '-',
5153         $m, $_[5] ? "$_[5]:$_[6]" : $script_name,
5154         $_[0], $_[1] ne '' ? $_[1] : '-', $_[2] ne '' ? $_[2] : '-';
5155 my %param;
5156 foreach my $k (sort { $a cmp $b } keys %{$_[3]}) {
5157         my $v = $_[3]->{$k};
5158         my @pv;
5159         if ($v eq '') {
5160                 $line .= " $k=''";
5161                 @rv = ( "" );
5162                 }
5163         elsif (ref($v) eq 'ARRAY') {
5164                 foreach $vv (@$v) {
5165                         next if (ref($vv));
5166                         push(@pv, $vv);
5167                         $vv =~ s/(['"\\\r\n\t\%])/sprintf("%%%2.2X",ord($1))/ge;
5168                         $line .= " $k='$vv'";
5169                         }
5170                 }
5171         elsif (!ref($v)) {
5172                 foreach $vv (split(/\0/, $v)) {
5173                         push(@pv, $vv);
5174                         $vv =~ s/(['"\\\r\n\t\%])/sprintf("%%%2.2X",ord($1))/ge;
5175                         $line .= " $k='$vv'";
5176                         }
5177                 }
5178         $param{$k} = join(" ", @pv);
5179         }
5180 open(WEBMINLOG, ">>$webmin_logfile");
5181 print WEBMINLOG $line,"\n";
5182 close(WEBMINLOG);
5183 if ($gconfig{'logperms'}) {
5184         chmod(oct($gconfig{'logperms'}), $webmin_logfile);
5185         }
5186 else {
5187         chmod(0600, $webmin_logfile);
5188         }
5189
5190 if ($gconfig{'logfiles'} && !&get_module_variable('$no_log_file_changes')) {
5191         # Find and record the changes made to any locked files, or commands run
5192         my $i = 0;
5193         mkdir("$ENV{'WEBMIN_VAR'}/diffs", 0700);
5194         foreach my $d (@main::locked_file_diff) {
5195                 mkdir("$ENV{'WEBMIN_VAR'}/diffs/$id", 0700);
5196                 open(DIFFLOG, ">$ENV{'WEBMIN_VAR'}/diffs/$id/$i");
5197                 print DIFFLOG "$d->{'type'} $d->{'object'}\n";
5198                 print DIFFLOG $d->{'data'};
5199                 close(DIFFLOG);
5200                 if ($d->{'input'}) {
5201                         open(DIFFLOG, ">$ENV{'WEBMIN_VAR'}/diffs/$id/$i.input");
5202                         print DIFFLOG $d->{'input'};
5203                         close(DIFFLOG);
5204                         }
5205                 if ($gconfig{'logperms'}) {
5206                         chmod(oct($gconfig{'logperms'}),
5207                               "$ENV{'WEBMIN_VAR'}/diffs/$id/$i",
5208                               "$ENV{'WEBMIN_VAR'}/diffs/$id/$i.input");
5209                         }
5210                 $i++;
5211                 }
5212         @main::locked_file_diff = undef;
5213         }
5214
5215 if ($gconfig{'logfullfiles'}) {
5216         # Save the original contents of any modified files
5217         my $i = 0;
5218         mkdir("$ENV{'WEBMIN_VAR'}/files", 0700);
5219         foreach my $f (keys %main::orig_file_data) {
5220                 mkdir("$ENV{'WEBMIN_VAR'}/files/$id", 0700);
5221                 open(ORIGLOG, ">$ENV{'WEBMIN_VAR'}/files/$id/$i");
5222                 if (!defined($main::orig_file_type{$f})) {
5223                         print ORIGLOG -1," ",$f,"\n";
5224                         }
5225                 else {
5226                         print ORIGLOG $main::orig_file_type{$f}," ",$f,"\n";
5227                         }
5228                 print ORIGLOG $main::orig_file_data{$f};
5229                 close(ORIGLOG);
5230                 if ($gconfig{'logperms'}) {
5231                         chmod(oct($gconfig{'logperms'}),
5232                               "$ENV{'WEBMIN_VAR'}/files/$id.$i");
5233                         }
5234                 $i++;
5235                 }
5236         %main::orig_file_data = undef;
5237         %main::orig_file_type = undef;
5238         }
5239
5240 if ($miniserv::page_capture_out) {
5241         # Save the whole page output
5242         mkdir("$ENV{'WEBMIN_VAR'}/output", 0700);
5243         open(PAGEOUT, ">$ENV{'WEBMIN_VAR'}/output/$id");
5244         print PAGEOUT $miniserv::page_capture_out;
5245         close(PAGEOUT);
5246         if ($gconfig{'logperms'}) {
5247                 chmod(oct($gconfig{'logperms'}),
5248                       "$ENV{'WEBMIN_VAR'}/output/$id");
5249                 }
5250         $miniserv::page_capture_out = undef;
5251         }
5252
5253 # Log to syslog too
5254 if ($gconfig{'logsyslog'}) {
5255         eval 'use Sys::Syslog qw(:DEFAULT setlogsock);
5256               openlog(&get_product_name(), "cons,pid,ndelay", "daemon");
5257               setlogsock("inet");';
5258         if (!$@) {
5259                 # Syslog module is installed .. try to convert to a
5260                 # human-readable form
5261                 my $msg;
5262                 my $mod = &get_module_name();
5263                 my $mdir = module_root_directory($mod);
5264                 if (-r "$mdir/log_parser.pl") {
5265                         &foreign_require($mod, "log_parser.pl");
5266                         my %params;
5267                         foreach my $k (keys %{$_[3]}) {
5268                                 my $v = $_[3]->{$k};
5269                                 if (ref($v) eq 'ARRAY') {
5270                                         $params{$k} = join("\0", @$v);
5271                                         }
5272                                 else {
5273                                         $params{$k} = $v;
5274                                         }
5275                                 }
5276                         $msg = &foreign_call($mod, "parse_webmin_log",
5277                                 $remote_user, $script_name,
5278                                 $_[0], $_[1], $_[2], \%params);
5279                         $msg =~ s/<[^>]*>//g;   # Remove tags
5280                         }
5281                 elsif ($_[0] eq "_config_") {
5282                         my %wtext = &load_language("webminlog");
5283                         $msg = $wtext{'search_config'};
5284                         }
5285                 $msg ||= "$_[0] $_[1] $_[2]";
5286                 my %info = &get_module_info($m);
5287                 eval { syslog("info", "%s", "[$info{'desc'}] $msg"); };
5288                 }
5289         }
5290 }
5291
5292 =head2 additional_log(type, object, data, [input])
5293
5294 Records additional log data for an upcoming call to webmin_log, such
5295 as a command that was run or SQL that was executed. Typically you will never
5296 need to call this function directory.
5297
5298 =cut
5299 sub additional_log
5300 {
5301 if ($gconfig{'logfiles'} && !&get_module_variable('$no_log_file_changes')) {
5302         push(@main::locked_file_diff,
5303              { 'type' => $_[0], 'object' => $_[1], 'data' => $_[2],
5304                'input' => $_[3] } );
5305         }
5306 }
5307
5308 =head2 webmin_debug_log(type, message)
5309
5310 Write something to the Webmin debug log. For internal use only.
5311
5312 =cut
5313 sub webmin_debug_log
5314 {
5315 my ($type, $msg) = @_;
5316 return 0 if (!$main::opened_debug_log);
5317 return 0 if ($gconfig{'debug_no'.$main::webmin_script_type});
5318 if ($gconfig{'debug_modules'}) {
5319         my @dmods = split(/\s+/, $gconfig{'debug_modules'});
5320         return 0 if (&indexof($main::initial_module_name, @dmods) < 0);
5321         }
5322 my $now = time();
5323 my @tm = localtime($now);
5324 my $line = sprintf
5325         "%s [%2.2d/%s/%4.4d %2.2d:%2.2d:%2.2d] %s %s %s %s \"%s\"",
5326         $$, $tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900,
5327         $tm[2], $tm[1], $tm[0],
5328         $remote_user || "-",
5329         $ENV{'REMOTE_HOST'} || "-",
5330         &get_module_name() || "-",
5331         $type,
5332         $msg;
5333 seek(main::DEBUGLOG, 0, 2);
5334 print main::DEBUGLOG $line."\n";
5335 return 1;
5336 }
5337
5338 =head2 system_logged(command)
5339
5340 Just calls the Perl system() function, but also logs the command run.
5341
5342 =cut
5343 sub system_logged
5344 {
5345 if (&is_readonly_mode()) {
5346         print STDERR "Vetoing command $_[0]\n";
5347         return 0;
5348         }
5349 my @realcmd = ( &translate_command($_[0]), @_[1..$#_] );
5350 my $cmd = join(" ", @realcmd);
5351 my $and;
5352 if ($cmd =~ s/(\s*&\s*)$//) {
5353         $and = $1;
5354         }
5355 while($cmd =~ s/(\d*)(<|>)((\/(tmp|dev)\S+)|&\d+)\s*$//) { }
5356 $cmd =~ s/^\((.*)\)\s*$/$1/;
5357 $cmd .= $and;
5358 &additional_log('exec', undef, $cmd);
5359 return system(@realcmd);
5360 }
5361
5362 =head2 backquote_logged(command)
5363
5364 Executes a command and returns the output (like `command`), but also logs it.
5365
5366 =cut
5367 sub backquote_logged
5368 {
5369 if (&is_readonly_mode()) {
5370         $? = 0;
5371         print STDERR "Vetoing command $_[0]\n";
5372         return undef;
5373         }
5374 my $realcmd = &translate_command($_[0]);
5375 my $cmd = $realcmd;
5376 my $and;
5377 if ($cmd =~ s/(\s*&\s*)$//) {
5378         $and = $1;
5379         }
5380 while($cmd =~ s/(\d*)(<|>)((\/(tmp\/.webmin|dev)\S+)|&\d+)\s*$//) { }
5381 $cmd =~ s/^\((.*)\)\s*$/$1/;
5382 $cmd .= $and;
5383 &additional_log('exec', undef, $cmd);
5384 &webmin_debug_log('CMD', "cmd=$cmd") if ($gconfig{'debug_what_cmd'});
5385 return `$realcmd`;
5386 }
5387
5388 =head2 backquote_with_timeout(command, timeout, safe?, [maxlines])
5389
5390 Runs some command, waiting at most the given number of seconds for it to
5391 complete, and returns the output. The maxlines parameter sets the number
5392 of lines of output to capture. The safe parameter should be set to 1 if the
5393 command is safe for read-only mode users to run.
5394
5395 =cut
5396 sub backquote_with_timeout
5397 {
5398 my $realcmd = &translate_command($_[0]);
5399 &webmin_debug_log('CMD', "cmd=$realcmd timeout=$_[1]")
5400         if ($gconfig{'debug_what_cmd'});
5401 my $out;
5402 my $pid = &open_execute_command(OUT, "($realcmd) <$null_file", 1, $_[2]);
5403 my $start = time();
5404 my $timed_out = 0;
5405 my $linecount = 0;
5406 while(1) {
5407         my $elapsed = time() - $start;
5408         last if ($elapsed > $_[1]);
5409         my $rmask;
5410         vec($rmask, fileno(OUT), 1) = 1;
5411         my $sel = select($rmask, undef, undef, $_[1] - $elapsed);
5412         last if (!$sel || $sel < 0);
5413         my $line = <OUT>;
5414         last if (!defined($line));
5415         $out .= $line;
5416         $linecount++;
5417         if ($_[3] && $linecount >= $_[3]) {
5418                 # Got enough lines
5419                 last;
5420                 }
5421         }
5422 if (kill('TERM', $pid) && time() - $start >= $_[1]) {
5423         $timed_out = 1;
5424         }
5425 close(OUT);
5426 return wantarray ? ($out, $timed_out) : $out;
5427 }
5428
5429 =head2 backquote_command(command, safe?)
5430
5431 Executes a command and returns the output (like `command`), subject to
5432 command translation. The safe parameter should be set to 1 if the command
5433 is safe for read-only mode users to run.
5434
5435 =cut
5436 sub backquote_command
5437 {
5438 if (&is_readonly_mode() && !$_[1]) {
5439         print STDERR "Vetoing command $_[0]\n";
5440         $? = 0;
5441         return undef;
5442         }
5443 my $realcmd = &translate_command($_[0]);
5444 &webmin_debug_log('CMD', "cmd=$realcmd") if ($gconfig{'debug_what_cmd'});
5445 return `$realcmd`;
5446 }
5447
5448 =head2 kill_logged(signal, pid, ...)
5449
5450 Like Perl's built-in kill function, but also logs the fact that some process
5451 was killed. On Windows, falls back to calling process.exe to terminate a
5452 process.
5453
5454 =cut
5455 sub kill_logged
5456 {
5457 return scalar(@_)-1 if (&is_readonly_mode());
5458 &webmin_debug_log('KILL', "signal=$_[0] pids=".join(" ", @_[1..@_-1]))
5459         if ($gconfig{'debug_what_procs'});
5460 &additional_log('kill', $_[0], join(" ", @_[1..@_-1])) if (@_ > 1);
5461 if ($gconfig{'os_type'} eq 'windows') {
5462         # Emulate some kills with process.exe
5463         my $arg = $_[0] eq "KILL" ? "-k" :
5464                   $_[0] eq "TERM" ? "-q" :
5465                   $_[0] eq "STOP" ? "-s" :
5466                   $_[0] eq "CONT" ? "-r" : undef;
5467         my $ok = 0;
5468         foreach my $p (@_[1..@_-1]) {
5469                 if ($p < 0) {
5470                         $ok ||= kill($_[0], $p);
5471                         }
5472                 elsif ($arg) {
5473                         &execute_command("process $arg $p");
5474                         $ok = 1;
5475                         }
5476                 }
5477         return $ok;
5478         }
5479 else {
5480         # Normal Unix kill
5481         return kill(@_);
5482         }
5483 }
5484
5485 =head2 rename_logged(old, new)
5486
5487 Re-names a file and logs the rename. If the old and new files are on different
5488 filesystems, calls mv or the Windows rename function to do the job.
5489
5490 =cut
5491 sub rename_logged
5492 {
5493 &additional_log('rename', $_[0], $_[1]) if ($_[0] ne $_[1]);
5494 return &rename_file($_[0], $_[1]);
5495 }
5496
5497 =head2 rename_file(old, new)
5498
5499 Renames a file or directory. If the old and new files are on different
5500 filesystems, calls mv or the Windows rename function to do the job.
5501
5502 =cut
5503 sub rename_file
5504 {
5505 if (&is_readonly_mode()) {
5506         print STDERR "Vetoing rename from $_[0] to $_[1]\n";
5507         return 1;
5508         }
5509 my $src = &translate_filename($_[0]);
5510 my $dst = &translate_filename($_[1]);
5511 &webmin_debug_log('RENAME', "src=$src dst=$dst")
5512         if ($gconfig{'debug_what_ops'});
5513 my $ok = rename($src, $dst);
5514 if (!$ok && $! !~ /permission/i) {
5515         # Try the mv command, in case this is a cross-filesystem rename
5516         if ($gconfig{'os_type'} eq 'windows') {
5517                 # Need to use rename
5518                 my $out = &backquote_command("rename ".quotemeta($_[0]).
5519                                              " ".quotemeta($_[1])." 2>&1");
5520                 $ok = !$?;
5521                 $! = $out if (!$ok);
5522                 }
5523         else {
5524                 # Can use mv
5525                 my $out = &backquote_command("mv ".quotemeta($_[0]).
5526                                              " ".quotemeta($_[1])." 2>&1");
5527                 $ok = !$?;
5528                 $! = $out if (!$ok);
5529                 }
5530         }
5531 return $ok;
5532 }
5533
5534 =head2 symlink_logged(src, dest)
5535
5536 Create a symlink, and logs it. Effectively does the same thing as the Perl
5537 symlink function.
5538
5539 =cut
5540 sub symlink_logged
5541 {
5542 &lock_file($_[1]);
5543 my $rv = &symlink_file($_[0], $_[1]);
5544 &unlock_file($_[1]);
5545 return $rv;
5546 }
5547
5548 =head2 symlink_file(src, dest)
5549
5550 Creates a soft link, unless in read-only mode. Effectively does the same thing
5551 as the Perl symlink function.
5552
5553 =cut
5554 sub symlink_file
5555 {
5556 if (&is_readonly_mode()) {
5557         print STDERR "Vetoing symlink from $_[0] to $_[1]\n";
5558         return 1;
5559         }
5560 my $src = &translate_filename($_[0]);
5561 my $dst = &translate_filename($_[1]);
5562 &webmin_debug_log('SYMLINK', "src=$src dst=$dst")
5563         if ($gconfig{'debug_what_ops'});
5564 return symlink($src, $dst);
5565 }
5566
5567 =head2 link_file(src, dest)
5568
5569 Creates a hard link, unless in read-only mode. The existing new link file
5570 will be deleted if necessary. Effectively the same as Perl's link function.
5571
5572 =cut
5573 sub link_file
5574 {
5575 if (&is_readonly_mode()) {
5576         print STDERR "Vetoing link from $_[0] to $_[1]\n";
5577         return 1;
5578         }
5579 my $src = &translate_filename($_[0]);
5580 my $dst = &translate_filename($_[1]);
5581 &webmin_debug_log('LINK', "src=$src dst=$dst")
5582         if ($gconfig{'debug_what_ops'});
5583 unlink($dst);                   # make sure link works
5584 return link($src, $dst);
5585 }
5586
5587 =head2 make_dir(dir, perms, recursive)
5588
5589 Creates a directory and sets permissions on it, unless in read-only mode.
5590 The perms parameter sets the octal permissions to apply, which unlike Perl's
5591 mkdir will really get set. The recursive flag can be set to 1 to have the
5592 function create parent directories too.
5593
5594 =cut
5595 sub make_dir
5596 {
5597 my ($dir, $perms, $recur) = @_;
5598 if (&is_readonly_mode()) {
5599         print STDERR "Vetoing directory $dir\n";
5600         return 1;
5601         }
5602 $dir = &translate_filename($dir);
5603 my $exists = -d $dir ? 1 : 0;
5604 return 1 if ($exists && $recur);        # already exists
5605 &webmin_debug_log('MKDIR', $dir) if ($gconfig{'debug_what_ops'});
5606 my $rv = mkdir($dir, $perms);
5607 if (!$rv && $recur) {
5608         # Failed .. try mkdir -p
5609         my $param = $gconfig{'os_type'} eq 'windows' ? "" : "-p";
5610         my $ex = &execute_command("mkdir $param ".&quote_path($dir));
5611         if ($ex) {
5612                 return 0;
5613                 }
5614         }
5615 if (!$exists) {
5616         chmod($perms, $dir);
5617         }
5618 return 1;
5619 }
5620
5621 =head2 set_ownership_permissions(user, group, perms, file, ...)
5622
5623 Sets the user, group owner and permissions on some files. The parameters are :
5624
5625 =item user - UID or username to change the file owner to. If undef, then the owner is not changed.
5626
5627 =item group - GID or group name to change the file group to. If undef, then the group is set to the user's primary group.
5628
5629 =item perms - Octal permissions set to set on the file. If undef, they are left alone.
5630
5631 =item file - One or more files or directories to modify.
5632
5633 =cut
5634 sub set_ownership_permissions
5635 {
5636 my ($user, $group, $perms, @files) = @_;
5637 if (&is_readonly_mode()) {
5638         print STDERR "Vetoing permission changes on ",join(" ", @files),"\n";
5639         return 1;
5640         }
5641 @files = map { &translate_filename($_) } @files;
5642 if ($gconfig{'debug_what_ops'}) {
5643         foreach my $f (@files) {
5644                 &webmin_debug_log('PERMS',
5645                         "file=$f user=$user group=$group perms=$perms");
5646                 }
5647         }
5648 my $rv = 1;
5649 if (defined($user)) {
5650         my $uid = $user !~ /^\d+$/ ? getpwnam($user) : $user;
5651         my $gid;
5652         if (defined($group)) {
5653                 $gid = $group !~ /^\d+$/ ? getgrnam($group) : $group;
5654                 }
5655         else {
5656                 my @uinfo = getpwuid($uid);
5657                 $gid = $uinfo[3];
5658                 }
5659         $rv = chown($uid, $gid, @files);
5660         }
5661 if ($rv && defined($perms)) {
5662         $rv = chmod($perms, @files);
5663         }
5664 return $rv;
5665 }
5666
5667 =head2 unlink_logged(file, ...)
5668
5669 Like Perl's unlink function, but locks the files beforehand and un-locks them
5670 after so that the deletion is logged by Webmin.
5671
5672 =cut
5673 sub unlink_logged
5674 {
5675 my %locked;
5676 foreach my $f (@_) {
5677         if (!&test_lock($f)) {
5678                 &lock_file($f);
5679                 $locked{$f} = 1;
5680                 }
5681         }
5682 my @rv = &unlink_file(@_);
5683 foreach my $f (@_) {
5684         if ($locked{$f}) {
5685                 &unlock_file($f);
5686                 }
5687         }
5688 return wantarray ? @rv : $rv[0];
5689 }
5690
5691 =head2 unlink_file(file, ...)
5692
5693 Deletes some files or directories. Like Perl's unlink function, but also
5694 recursively deletes directories with the rm command if needed.
5695
5696 =cut
5697 sub unlink_file
5698 {
5699 return 1 if (&is_readonly_mode());
5700 my $rv = 1;
5701 my $err;
5702 foreach my $f (@_) {
5703         &unflush_file_lines($f);
5704         my $realf = &translate_filename($f);
5705         &webmin_debug_log('UNLINK', $realf) if ($gconfig{'debug_what_ops'});
5706         if (-d $realf) {
5707                 if (!rmdir($realf)) {
5708                         my $out;
5709                         if ($gconfig{'os_type'} eq 'windows') {
5710                                 # Call del and rmdir commands
5711                                 my $qm = $realf;
5712                                 $qm =~ s/\//\\/g;
5713                                 my $out = `del /q "$qm" 2>&1`;
5714                                 if (!$?) {
5715                                         $out = `rmdir "$qm" 2>&1`;
5716                                         }
5717                                 }
5718                         else {
5719                                 # Use rm command
5720                                 my $qm = quotemeta($realf);
5721                                 $out = `rm -rf $qm 2>&1`;
5722                                 }
5723                         if ($?) {
5724                                 $rv = 0;
5725                                 $err = $out;
5726                                 }
5727                         }
5728                 }
5729         else {
5730                 if (!unlink($realf)) {
5731                         $rv = 0;
5732                         $err = $!;
5733                         }
5734                 }
5735         }
5736 return wantarray ? ($rv, $err) : $rv;
5737 }
5738
5739 =head2 copy_source_dest(source, dest)
5740
5741 Copy some file or directory to a new location. Returns 1 on success, or 0
5742 on failure - also sets $! on failure. If the source is a directory, uses
5743 piped tar commands to copy a whole directory structure including permissions
5744 and special files.
5745
5746 =cut
5747 sub copy_source_dest
5748 {
5749 return (1, undef) if (&is_readonly_mode());
5750 my ($src, $dst) = @_;
5751 my $ok = 1;
5752 my ($err, $out);
5753 &webmin_debug_log('COPY', "src=$src dst=$dst")
5754         if ($gconfig{'debug_what_ops'});
5755 if ($gconfig{'os_type'} eq 'windows') {
5756         # No tar or cp on windows, so need to use copy command
5757         $src =~ s/\//\\/g;
5758         $dst =~ s/\//\\/g;
5759         if (-d $src) {
5760                 $out = &backquote_logged("xcopy \"$src\" \"$dst\" /Y /E /I 2>&1");
5761                 }
5762         else {
5763                 $out = &backquote_logged("copy /Y \"$src\" \"$dst\" 2>&1");
5764                 }
5765         if ($?) {
5766                 $ok = 0;
5767                 $err = $out;
5768                 }
5769         }
5770 elsif (-d $src) {
5771         # A directory .. need to copy with tar command
5772         my @st = stat($src);
5773         unlink($dst);
5774         mkdir($dst, 0755);
5775         &set_ownership_permissions($st[4], $st[5], $st[2], $dst);
5776         $out = &backquote_logged("(cd ".quotemeta($src)." ; tar cf - . | (cd ".quotemeta($dst)." ; tar xf -)) 2>&1");
5777         if ($?) {
5778                 $ok = 0;
5779                 $err = $out;
5780                 }
5781         }
5782 else {
5783         # Can just copy with cp
5784         my $out = &backquote_logged("cp -p ".quotemeta($src).
5785                                     " ".quotemeta($dst)." 2>&1");
5786         if ($?) {
5787                 $ok = 0;
5788                 $err = $out;
5789                 }
5790         }
5791 return wantarray ? ($ok, $err) : $ok;
5792 }
5793
5794 =head2 remote_session_name(host|&server)
5795
5796 Generates a session ID for some server. For this server, this will always
5797 be an empty string. For a server object it will include the hostname and
5798 port and PID. For a server name, it will include the hostname and PID. For
5799 internal use only.
5800
5801 =cut
5802 sub remote_session_name
5803 {
5804 return ref($_[0]) && $_[0]->{'host'} && $_[0]->{'port'} ?
5805                 "$_[0]->{'host'}:$_[0]->{'port'}.$$" :
5806        $_[0] eq "" || ref($_[0]) && $_[0]->{'id'} == 0 ? "" :
5807        ref($_[0]) ? "" : "$_[0].$$";
5808 }
5809
5810 =head2 remote_foreign_require(server, module, file)
5811
5812 Connects to rpc.cgi on a remote webmin server and have it open a session
5813 to a process that will actually do the require and run functions. This is the
5814 equivalent for foreign_require, but for a remote Webmin system. The server
5815 parameter can either be a hostname of a system registered in the Webmin
5816 Servers Index module, or a hash reference for a system from that module.
5817
5818 =cut
5819 sub remote_foreign_require
5820 {
5821 my $call = { 'action' => 'require',
5822              'module' => $_[1],
5823              'file' => $_[2] };
5824 my $sn = &remote_session_name($_[0]);
5825 if ($remote_session{$sn}) {
5826         $call->{'session'} = $remote_session{$sn};
5827         }
5828 else {
5829         $call->{'newsession'} = 1;
5830         }
5831 my $rv = &remote_rpc_call($_[0], $call);
5832 if ($rv->{'session'}) {
5833         $remote_session{$sn} = $rv->{'session'};
5834         $remote_session_server{$sn} = $_[0];
5835         }
5836 }
5837
5838 =head2 remote_foreign_call(server, module, function, [arg]*)
5839
5840 Call a function on a remote server. Must have been setup first with
5841 remote_foreign_require for the same server and module. Equivalent to
5842 foreign_call, but with the extra server parameter to specify the remote
5843 system's hostname.
5844
5845 =cut
5846 sub remote_foreign_call
5847 {
5848 return undef if (&is_readonly_mode());
5849 my $sn = &remote_session_name($_[0]);
5850 return &remote_rpc_call($_[0], { 'action' => 'call',
5851                                  'module' => $_[1],
5852                                  'func' => $_[2],
5853                                  'session' => $remote_session{$sn},
5854                                  'args' => [ @_[3 .. $#_] ] } );
5855 }
5856
5857 =head2 remote_foreign_check(server, module, [api-only])
5858
5859 Checks if some module is installed and supported on a remote server. Equivilant
5860 to foreign_check, but for the remote Webmin system specified by the server
5861 parameter.
5862
5863 =cut
5864 sub remote_foreign_check
5865 {
5866 return &remote_rpc_call($_[0], { 'action' => 'check',
5867                                  'module' => $_[1],
5868                                  'api' => $_[2] });
5869 }
5870
5871 =head2 remote_foreign_config(server, module)
5872
5873 Gets the configuration for some module from a remote server, as a hash.
5874 Equivalent to foreign_config, but for a remote system.
5875
5876 =cut
5877 sub remote_foreign_config
5878 {
5879 return &remote_rpc_call($_[0], { 'action' => 'config',
5880                                  'module' => $_[1] });
5881 }
5882
5883 =head2 remote_eval(server, module, code)
5884
5885 Evaluates some perl code in the context of a module on a remote webmin server.
5886 The server parameter must be the hostname of a remote system, module must
5887 be a module directory name, and code a string of Perl code to run. This can
5888 only be called after remote_foreign_require for the same server and module.
5889
5890 =cut
5891 sub remote_eval
5892 {
5893 return undef if (&is_readonly_mode());
5894 my $sn = &remote_session_name($_[0]);
5895 return &remote_rpc_call($_[0], { 'action' => 'eval',
5896                                  'module' => $_[1],
5897                                  'code' => $_[2],
5898                                  'session' => $remote_session{$sn} });
5899 }
5900
5901 =head2 remote_write(server, localfile, [remotefile], [remotebasename])
5902
5903 Transfers some local file to another server via Webmin's RPC protocol, and
5904 returns the resulting remote filename. If the remotefile parameter is given,
5905 that is the destination filename which will be used. Otherwise a randomly
5906 selected temporary filename will be used, and returned by the function.
5907
5908 =cut
5909 sub remote_write
5910 {
5911 return undef if (&is_readonly_mode());
5912 my ($data, $got);
5913 my $sn = &remote_session_name($_[0]);
5914 if (!$_[0] || $remote_server_version{$sn} >= 0.966) {
5915         # Copy data over TCP connection
5916         my $rv = &remote_rpc_call($_[0], { 'action' => 'tcpwrite',
5917                                            'file' => $_[2],
5918                                            'name' => $_[3] } );
5919         my $error;
5920         my $serv = ref($_[0]) ? $_[0]->{'host'} : $_[0];
5921         &open_socket($serv || "localhost", $rv->[1], TWRITE, \$error);
5922         return &$main::remote_error_handler("Failed to transfer file : $error")
5923                 if ($error);
5924         open(FILE, $_[1]);
5925         while(read(FILE, $got, 1024) > 0) {
5926                 print TWRITE $got;
5927                 }
5928         close(FILE);
5929         shutdown(TWRITE, 1);
5930         $error = <TWRITE>;
5931         if ($error && $error !~ /^OK/) {
5932                 # Got back an error!
5933                 return &$main::remote_error_handler("Failed to transfer file : $error");
5934                 }
5935         close(TWRITE);
5936         return $rv->[0];
5937         }
5938 else {
5939         # Just pass file contents as parameters
5940         open(FILE, $_[1]);
5941         while(read(FILE, $got, 1024) > 0) {
5942                 $data .= $got;
5943                 }
5944         close(FILE);
5945         return &remote_rpc_call($_[0], { 'action' => 'write',
5946                                          'data' => $data,
5947                                          'file' => $_[2],
5948                                          'session' => $remote_session{$sn} });
5949         }
5950 }
5951
5952 =head2 remote_read(server, localfile, remotefile)
5953
5954 Transfers a file from a remote server to this system, using Webmin's RPC
5955 protocol. The server parameter must be the hostname of a system registered
5956 in the Webmin Servers Index module, localfile is the destination path on this
5957 system, and remotefile is the file to fetch from the remote server.
5958
5959 =cut
5960 sub remote_read
5961 {
5962 my $sn = &remote_session_name($_[0]);
5963 if (!$_[0] || $remote_server_version{$sn} >= 0.966) {
5964         # Copy data over TCP connection
5965         my $rv = &remote_rpc_call($_[0], { 'action' => 'tcpread',
5966                                            'file' => $_[2] } );
5967         if (!$rv->[0]) {
5968                 return &$main::remote_error_handler("Failed to transfer file : $rv->[1]");
5969                 }
5970         my $error;
5971         my $serv = ref($_[0]) ? $_[0]->{'host'} : $_[0];
5972         &open_socket($serv || "localhost", $rv->[1], TREAD, \$error);
5973         return &$main::remote_error_handler("Failed to transfer file : $error")
5974                 if ($error);
5975         my $got;
5976         open(FILE, ">$_[1]");
5977         while(read(TREAD, $got, 1024) > 0) {
5978                 print FILE $got;
5979                 }
5980         close(FILE);
5981         close(TREAD);
5982         }
5983 else {
5984         # Just get data as return value
5985         my $d = &remote_rpc_call($_[0], { 'action' => 'read',
5986                                           'file' => $_[2],
5987                                           'session' => $remote_session{$sn} });
5988         open(FILE, ">$_[1]");
5989         print FILE $d;
5990         close(FILE);
5991         }
5992 }
5993
5994 =head2 remote_finished
5995
5996 Close all remote sessions. This happens automatically after a while
5997 anyway, but this function should be called to clean things up faster.
5998
5999 =cut
6000 sub remote_finished
6001 {
6002 foreach my $sn (keys %remote_session) {
6003         my $server = $remote_session_server{$sn};
6004         &remote_rpc_call($server, { 'action' => 'quit',
6005                                     'session' => $remote_session{$sn} } );
6006         delete($remote_session{$sn});
6007         delete($remote_session_server{$sn});
6008         }
6009 foreach my $fh (keys %fast_fh_cache) {
6010         close($fh);
6011         delete($fast_fh_cache{$fh});
6012         }
6013 }
6014
6015 =head2 remote_error_setup(&function)
6016
6017 Sets a function to be called instead of &error when a remote RPC operation
6018 fails. Useful if you want to have more control over your remote operations.
6019
6020 =cut
6021 sub remote_error_setup
6022 {
6023 $main::remote_error_handler = $_[0] || \&error;
6024 }
6025
6026 =head2 remote_rpc_call(server, &structure)
6027
6028 Calls rpc.cgi on some server and passes it a perl structure (hash,array,etc)
6029 and then reads back a reply structure. This is mainly for internal use only,
6030 and is called by the other remote_* functions.
6031
6032 =cut
6033 sub remote_rpc_call
6034 {
6035 my $serv;
6036 my $sn = &remote_session_name($_[0]);   # Will be undef for local connection
6037 if (ref($_[0])) {
6038         # Server structure was given
6039         $serv = $_[0];
6040         $serv->{'user'} || $serv->{'id'} == 0 ||
6041                 return &$main::remote_error_handler(
6042                         "No Webmin login set for server");
6043         }
6044 elsif ($_[0]) {
6045         # lookup the server in the webmin servers module if needed
6046         if (!%main::remote_servers_cache) {
6047                 &foreign_require("servers", "servers-lib.pl");
6048                 foreach $s (&foreign_call("servers", "list_servers")) {
6049                         $main::remote_servers_cache{$s->{'host'}} = $s;
6050                         $main::remote_servers_cache{$s->{'host'}.":".$s->{'port'}} = $s;
6051                         }
6052                 }
6053         $serv = $main::remote_servers_cache{$_[0]};
6054         $serv || return &$main::remote_error_handler(
6055                                 "No Webmin Servers entry for $_[0]");
6056         $serv->{'user'} || return &$main::remote_error_handler(
6057                                 "No login set for server $_[0]");
6058         }
6059 my $ip = $serv->{'ip'} || $serv->{'host'};
6060
6061 # Work out the username and password
6062 my ($user, $pass);
6063 if ($serv->{'sameuser'}) {
6064         $user = $remote_user;
6065         defined($main::remote_pass) || return &$main::remote_error_handler(
6066                                    "Password for this server is not available");
6067         $pass = $main::remote_pass;
6068         }
6069 else {
6070         $user = $serv->{'user'};
6071         $pass = $serv->{'pass'};
6072         }
6073
6074 if ($serv->{'fast'} || !$sn) {
6075         # Make TCP connection call to fastrpc.cgi
6076         if (!$fast_fh_cache{$sn} && $sn) {
6077                 # Need to open the connection
6078                 my $con = &make_http_connection(
6079                         $ip, $serv->{'port'}, $serv->{'ssl'},
6080                         "POST", "/fastrpc.cgi");
6081                 return &$main::remote_error_handler(
6082                     "Failed to connect to $serv->{'host'} : $con")
6083                         if (!ref($con));
6084                 &write_http_connection($con, "Host: $serv->{'host'}\r\n");
6085                 &write_http_connection($con, "User-agent: Webmin\r\n");
6086                 my $auth = &encode_base64("$user:$pass");
6087                 $auth =~ tr/\n//d;
6088                 &write_http_connection($con, "Authorization: basic $auth\r\n");
6089                 &write_http_connection($con, "Content-length: ",
6090                                              length($tostr),"\r\n");
6091                 &write_http_connection($con, "\r\n");
6092                 &write_http_connection($con, $tostr);
6093
6094                 # read back the response
6095                 my $line = &read_http_connection($con);
6096                 $line =~ tr/\r\n//d;
6097                 if ($line =~ /^HTTP\/1\..\s+401\s+/) {
6098                         return &$main::remote_error_handler("Login to RPC server as $user rejected");
6099                         }
6100                 $line =~ /^HTTP\/1\..\s+200\s+/ ||
6101                         return &$main::remote_error_handler("HTTP error : $line");
6102                 do {
6103                         $line = &read_http_connection($con);
6104                         $line =~ tr/\r\n//d;
6105                         } while($line);
6106                 $line = &read_http_connection($con);
6107                 if ($line =~ /^0\s+(.*)/) {
6108                         return &$main::remote_error_handler("RPC error : $1");
6109                         }
6110                 elsif ($line =~ /^1\s+(\S+)\s+(\S+)\s+(\S+)/ ||
6111                        $line =~ /^1\s+(\S+)\s+(\S+)/) {
6112                         # Started ok .. connect and save SID
6113                         &close_http_connection($con);
6114                         my ($port, $sid, $version, $error) = ($1, $2, $3);
6115                         &open_socket($ip, $port, $sid, \$error);
6116                         return &$main::remote_error_handler("Failed to connect to fastrpc.cgi : $error")
6117                                 if ($error);
6118                         $fast_fh_cache{$sn} = $sid;
6119                         $remote_server_version{$sn} = $version;
6120                         }
6121                 else {
6122                         while($stuff = &read_http_connection($con)) {
6123                                 $line .= $stuff;
6124                                 }
6125                         return &$main::remote_error_handler("Bad response from fastrpc.cgi : $line");
6126                         }
6127                 }
6128         elsif (!$fast_fh_cache{$sn}) {
6129                 # Open the connection by running fastrpc.cgi locally
6130                 pipe(RPCOUTr, RPCOUTw);
6131                 if (!fork()) {
6132                         untie(*STDIN);
6133                         untie(*STDOUT);
6134                         open(STDOUT, ">&RPCOUTw");
6135                         close(STDIN);
6136                         close(RPCOUTr);
6137                         $| = 1;
6138                         $ENV{'REQUEST_METHOD'} = 'GET';
6139                         $ENV{'SCRIPT_NAME'} = '/fastrpc.cgi';
6140                         $ENV{'SERVER_ROOT'} ||= $root_directory;
6141                         my %acl;
6142                         if ($base_remote_user ne 'root' &&
6143                             $base_remote_user ne 'admin') {
6144                                 # Need to fake up a login for the CGI!
6145                                 &read_acl(undef, \%acl, [ 'root' ]);
6146                                 $ENV{'BASE_REMOTE_USER'} =
6147                                         $ENV{'REMOTE_USER'} =
6148                                                 $acl{'root'} ? 'root' : 'admin';
6149                                 }
6150                         delete($ENV{'FOREIGN_MODULE_NAME'});
6151                         delete($ENV{'FOREIGN_ROOT_DIRECTORY'});
6152                         chdir($root_directory);
6153                         if (!exec("$root_directory/fastrpc.cgi")) {
6154                                 print "exec failed : $!\n";
6155                                 exit 1;
6156                                 }
6157                         }
6158                 close(RPCOUTw);
6159                 my $line;
6160                 do {
6161                         ($line = <RPCOUTr>) =~ tr/\r\n//d;
6162                         } while($line);
6163                 $line = <RPCOUTr>;
6164                 #close(RPCOUTr);
6165                 if ($line =~ /^0\s+(.*)/) {
6166                         return &$main::remote_error_handler("RPC error : $2");
6167                         }
6168                 elsif ($line =~ /^1\s+(\S+)\s+(\S+)/) {
6169                         # Started ok .. connect and save SID
6170                         close(SOCK);
6171                         my ($port, $sid, $error) = ($1, $2, undef);
6172                         &open_socket("localhost", $port, $sid, \$error);
6173                         return &$main::remote_error_handler("Failed to connect to fastrpc.cgi : $error") if ($error);
6174                         $fast_fh_cache{$sn} = $sid;
6175                         }
6176                 else {
6177                         local $_;
6178                         while(<RPCOUTr>) {
6179                                 $line .= $_;
6180                                 }
6181                         &error("Bad response from fastrpc.cgi : $line");
6182                         }
6183                 }
6184         # Got a connection .. send off the request
6185         my $fh = $fast_fh_cache{$sn};
6186         my $tostr = &serialise_variable($_[1]);
6187         print $fh length($tostr)," $fh\n";
6188         print $fh $tostr;
6189         my $rlen = int(<$fh>);
6190         my ($fromstr, $got);
6191         while(length($fromstr) < $rlen) {
6192                 return &$main::remote_error_handler("Failed to read from fastrpc.cgi")
6193                         if (read($fh, $got, $rlen - length($fromstr)) <= 0);
6194                 $fromstr .= $got;
6195                 }
6196         my $from = &unserialise_variable($fromstr);
6197         if (!$from) {
6198                 # No response at all
6199                 return &$main::remote_error_handler("Remote Webmin error");
6200                 }
6201         elsif (ref($from) ne 'HASH') {
6202                 # Not a hash?!
6203                 return &$main::remote_error_handler(
6204                         "Invalid remote Webmin response : $from");
6205                 }
6206         elsif (!$from->{'status'}) {
6207                 # Call failed
6208                 $from->{'rv'} =~ s/\s+at\s+(\S+)\s+line\s+(\d+)(,\s+<\S+>\s+line\s+(\d+))?//;
6209                 return &$main::remote_error_handler($from->{'rv'});
6210                 }
6211         if (defined($from->{'arv'})) {
6212                 return @{$from->{'arv'}};
6213                 }
6214         else {
6215                 return $from->{'rv'};
6216                 }
6217         }
6218 else {
6219         # Call rpc.cgi on remote server
6220         my $tostr = &serialise_variable($_[1]);
6221         my $error = 0;
6222         my $con = &make_http_connection($ip, $serv->{'port'},
6223                                         $serv->{'ssl'}, "POST", "/rpc.cgi");
6224         return &$main::remote_error_handler("Failed to connect to $serv->{'host'} : $con") if (!ref($con));
6225
6226         &write_http_connection($con, "Host: $serv->{'host'}\r\n");
6227         &write_http_connection($con, "User-agent: Webmin\r\n");
6228         my $auth = &encode_base64("$user:$pass");
6229         $auth =~ tr/\n//d;
6230         &write_http_connection($con, "Authorization: basic $auth\r\n");
6231         &write_http_connection($con, "Content-length: ",length($tostr),"\r\n");
6232         &write_http_connection($con, "\r\n");
6233         &write_http_connection($con, $tostr);
6234
6235         # read back the response
6236         my $line = &read_http_connection($con);
6237         $line =~ tr/\r\n//d;
6238         if ($line =~ /^HTTP\/1\..\s+401\s+/) {
6239                 return &$main::remote_error_handler("Login to RPC server as $user rejected");
6240                 }
6241         $line =~ /^HTTP\/1\..\s+200\s+/ || return &$main::remote_error_handler("RPC HTTP error : $line");
6242         do {
6243                 $line = &read_http_connection($con);
6244                 $line =~ tr/\r\n//d;
6245                 } while($line);
6246         my $fromstr;
6247         while($line = &read_http_connection($con)) {
6248                 $fromstr .= $line;
6249                 }
6250         close(SOCK);
6251         my $from = &unserialise_variable($fromstr);
6252         return &$main::remote_error_handler("Invalid RPC login to $serv->{'host'}") if (!$from->{'status'});
6253         if (defined($from->{'arv'})) {
6254                 return @{$from->{'arv'}};
6255                 }
6256         else {
6257                 return $from->{'rv'};
6258                 }
6259         }
6260 }
6261
6262 =head2 remote_multi_callback(&servers, parallel, &function, arg|&args, &returns, &errors, [module, library])
6263
6264 Executes some function in parallel on multiple servers at once. Fills in
6265 the returns and errors arrays respectively. If the module and library
6266 parameters are given, that module is remotely required on the server first,
6267 to check if it is connectable. The parameters are :
6268
6269 =item servers - A list of Webmin system hash references.
6270
6271 =item parallel - Number of parallel operations to perform.
6272
6273 =item function - Reference to function to call for each system.
6274
6275 =item args - Additional parameters to the function.
6276
6277 =item returns - Array ref to place return values into, in same order as servers.
6278
6279 =item errors - Array ref to place error messages into.
6280
6281 =item module - Optional module to require on the remote system first.
6282
6283 =item library - Optional library to require in the module.
6284
6285 =cut
6286 sub remote_multi_callback
6287 {
6288 my ($servs, $parallel, $func, $args, $rets, $errs, $mod, $lib) = @_;
6289 &remote_error_setup(\&remote_multi_callback_error);
6290
6291 # Call the functions
6292 my $p = 0;
6293 foreach my $g (@$servs) {
6294         my $rh = "READ$p";
6295         my $wh = "WRITE$p";
6296         pipe($rh, $wh);
6297         if (!fork()) {
6298                 close($rh);
6299                 $remote_multi_callback_err = undef;
6300                 if ($mod) {
6301                         # Require the remote lib
6302                         &remote_foreign_require($g->{'host'}, $mod, $lib);
6303                         if ($remote_multi_callback_err) {
6304                                 # Failed .. return error
6305                                 print $wh &serialise_variable(
6306                                         [ undef, $remote_multi_callback_err ]);
6307                                 exit(0);
6308                                 }
6309                         }
6310
6311                 # Call the function
6312                 my $a = ref($args) ? $args->[$p] : $args;
6313                 my $rv = &$func($g, $a);
6314
6315                 # Return the result
6316                 print $wh &serialise_variable(
6317                         [ $rv, $remote_multi_callback_err ]);
6318                 close($wh);
6319                 exit(0);
6320                 }
6321         close($wh);
6322         $p++;
6323         }
6324
6325 # Read back the results
6326 $p = 0;
6327 foreach my $g (@$servs) {
6328         my $rh = "READ$p";
6329         my $line = <$rh>;
6330         if (!$line) {
6331                 $errs->[$p] = "Failed to read response from $g->{'host'}";
6332                 }
6333         else {
6334                 my $rv = &unserialise_variable($line);
6335                 close($rh);
6336                 $rets->[$p] = $rv->[0];
6337                 $errs->[$p] = $rv->[1];
6338                 }
6339         $p++;
6340         }
6341
6342 &remote_error_setup(undef);
6343 }
6344
6345 sub remote_multi_callback_error
6346 {
6347 $remote_multi_callback_err = $_[0];
6348 }
6349
6350 =head2 serialise_variable(variable)
6351
6352 Converts some variable (maybe a scalar, hash ref, array ref or scalar ref)
6353 into a url-encoded string. In the cases of arrays and hashes, it is recursively
6354 called on each member to serialize the entire object.
6355
6356 =cut
6357 sub serialise_variable
6358 {
6359 if (!defined($_[0])) {
6360         return 'UNDEF';
6361         }
6362 my $r = ref($_[0]);
6363 my $rv;
6364 if (!$r) {
6365         $rv = &urlize($_[0]);
6366         }
6367 elsif ($r eq 'SCALAR') {
6368         $rv = &urlize(${$_[0]});
6369         }
6370 elsif ($r eq 'ARRAY') {
6371         $rv = join(",", map { &urlize(&serialise_variable($_)) } @{$_[0]});
6372         }
6373 elsif ($r eq 'HASH') {
6374         $rv = join(",", map { &urlize(&serialise_variable($_)).",".
6375                               &urlize(&serialise_variable($_[0]->{$_})) }
6376                             keys %{$_[0]});
6377         }
6378 elsif ($r eq 'REF') {
6379         $rv = &serialise_variable(${$_[0]});
6380         }
6381 elsif ($r eq 'CODE') {
6382         # Code not handled
6383         $rv = undef;
6384         }
6385 elsif ($r) {
6386         # An object - treat as a hash
6387         $r = "OBJECT ".&urlize($r);
6388         $rv = join(",", map { &urlize(&serialise_variable($_)).",".
6389                               &urlize(&serialise_variable($_[0]->{$_})) }
6390                             keys %{$_[0]});
6391         }
6392 return ($r ? $r : 'VAL').",".$rv;
6393 }
6394
6395 =head2 unserialise_variable(string)
6396
6397 Converts a string created by serialise_variable() back into the original
6398 scalar, hash ref, array ref or scalar ref. If the original variable was a Perl
6399 object, the same class is used on this system, if available.
6400
6401 =cut
6402 sub unserialise_variable
6403 {
6404 my @v = split(/,/, $_[0]);
6405 my $rv;
6406 if ($v[0] eq 'VAL') {
6407         @v = split(/,/, $_[0], -1);
6408         $rv = &un_urlize($v[1]);
6409         }
6410 elsif ($v[0] eq 'SCALAR') {
6411         local $r = &un_urlize($v[1]);
6412         $rv = \$r;
6413         }
6414 elsif ($v[0] eq 'ARRAY') {
6415         $rv = [ ];
6416         for(my $i=1; $i<@v; $i++) {
6417                 push(@$rv, &unserialise_variable(&un_urlize($v[$i])));
6418                 }
6419         }
6420 elsif ($v[0] eq 'HASH') {
6421         $rv = { };
6422         for(my $i=1; $i<@v; $i+=2) {
6423                 $rv->{&unserialise_variable(&un_urlize($v[$i]))} =
6424                         &unserialise_variable(&un_urlize($v[$i+1]));
6425                 }
6426         }
6427 elsif ($v[0] eq 'REF') {
6428         local $r = &unserialise_variable($v[1]);
6429         $rv = \$r;
6430         }
6431 elsif ($v[0] eq 'UNDEF') {
6432         $rv = undef;
6433         }
6434 elsif ($v[0] =~ /^OBJECT\s+(.*)$/) {
6435         # An object hash that we have to re-bless
6436         my $cls = $1;
6437         $rv = { };
6438         for(my $i=1; $i<@v; $i+=2) {
6439                 $rv->{&unserialise_variable(&un_urlize($v[$i]))} =
6440                         &unserialise_variable(&un_urlize($v[$i+1]));
6441                 }
6442         eval "use $cls";
6443         bless $rv, $cls;
6444         }
6445 return $rv;
6446 }
6447
6448 =head2 other_groups(user)
6449
6450 Returns a list of secondary groups a user is a member of, as a list of
6451 group names.
6452
6453 =cut
6454 sub other_groups
6455 {
6456 my ($user) = @_;
6457 my @rv;
6458 setgrent();
6459 while(my @g = getgrent()) {
6460         my @m = split(/\s+/, $g[3]);
6461         push(@rv, $g[2]) if (&indexof($user, @m) >= 0);
6462         }
6463 endgrent() if ($gconfig{'os_type'} ne 'hpux');
6464 return @rv;
6465 }
6466
6467 =head2 date_chooser_button(dayfield, monthfield, yearfield)
6468
6469 Returns HTML for a button that pops up a data chooser window. The parameters
6470 are :
6471
6472 =item dayfield - Name of the text field to place the day of the month into.
6473
6474 =item monthfield - Name of the select field to select the month of the year in, indexed from 1.
6475
6476 =item yearfield - Name of the text field to place the year into.
6477
6478 =cut
6479 sub date_chooser_button
6480 {
6481 return &theme_date_chooser_button(@_)
6482         if (defined(&theme_date_chooser_button));
6483 my ($w, $h) = (250, 225);
6484 if ($gconfig{'db_sizedate'}) {
6485         ($w, $h) = split(/x/, $gconfig{'db_sizedate'});
6486         }
6487 return "<input type=button onClick='window.dfield = form.$_[0]; window.mfield = form.$_[1]; window.yfield = form.$_[2]; window.open(\"$gconfig{'webprefix'}/date_chooser.cgi?day=\"+escape(dfield.value)+\"&month=\"+escape(mfield.selectedIndex)+\"&year=\"+yfield.value, \"chooser\", \"toolbar=no,menubar=no,scrollbars=yes,width=$w,height=$h\")' value=\"...\">\n";
6488 }
6489
6490 =head2 help_file(module, file)
6491
6492 Returns the path to a module's help file of some name, typically under the
6493 help directory with a .html extension.
6494
6495 =cut
6496 sub help_file
6497 {
6498 my $mdir = &module_root_directory($_[0]);
6499 my $dir = "$mdir/help";
6500 foreach my $o (@lang_order_list) {
6501         my $lang = "$dir/$_[1].$o.html";
6502         return $lang if (-r $lang);
6503         }
6504 return "$dir/$_[1].html";
6505 }
6506
6507 =head2 seed_random
6508
6509 Seeds the random number generator, if not already done in this script. On Linux
6510 this makes use of the current time, process ID and a read from /dev/urandom.
6511 On other systems, only the current time and process ID are used.
6512
6513 =cut
6514 sub seed_random
6515 {
6516 if (!$main::done_seed_random) {
6517         if (open(RANDOM, "/dev/urandom")) {
6518                 my $buf;
6519                 read(RANDOM, $buf, 4);
6520                 close(RANDOM);
6521                 srand(time() ^ $$ ^ $buf);
6522                 }
6523         else {
6524                 srand(time() ^ $$);
6525                 }
6526         $main::done_seed_random = 1;
6527         }
6528 }
6529
6530 =head2 disk_usage_kb(directory)
6531
6532 Returns the number of kB used by some directory and all subdirs. Implemented
6533 by calling the C<du -k> command.
6534
6535 =cut
6536 sub disk_usage_kb
6537 {
6538 my $dir = &translate_filename($_[0]);
6539 my $out;
6540 my $ex = &execute_command("du -sk ".quotemeta($dir), undef, \$out, undef, 0, 1);
6541 if ($ex) {
6542         &execute_command("du -s ".quotemeta($dir), undef, \$out, undef, 0, 1);
6543         }
6544 return $out =~ /^([0-9]+)/ ? $1 : "???";
6545 }
6546
6547 =head2 recursive_disk_usage(directory, [skip-regexp], [only-regexp])
6548
6549 Returns the number of bytes taken up by all files in some directory and all
6550 sub-directories, by summing up their lengths. The disk_usage_kb is more
6551 reflective of reality, as the filesystem typically pads file sizes to 1k or
6552 4k blocks.
6553
6554 =cut
6555 sub recursive_disk_usage
6556 {
6557 my $dir = &translate_filename($_[0]);
6558 my $skip = $_[1];
6559 my $only = $_[2];
6560 if (-l $dir) {
6561         return 0;
6562         }
6563 elsif (!-d $dir) {
6564         my @st = stat($dir);
6565         return $st[7];
6566         }
6567 else {
6568         my $rv = 0;
6569         opendir(DIR, $dir);
6570         my @files = readdir(DIR);
6571         closedir(DIR);
6572         foreach my $f (@files) {
6573                 next if ($f eq "." || $f eq "..");
6574                 next if ($skip && $f =~ /$skip/);
6575                 next if ($only && $f !~ /$only/);
6576                 $rv += &recursive_disk_usage("$dir/$f", $skip, $only);
6577                 }
6578         return $rv;
6579         }
6580 }
6581
6582 =head2 help_search_link(term, [ section, ... ] )
6583
6584 Returns HTML for a link to the man module for searching local and online
6585 docs for various search terms. The term parameter can either be a single
6586 word like 'bind', or a space-separated list of words. This function is typically
6587 used by modules that want to refer users to additional documentation in man
6588 pages or local system doc files.
6589
6590 =cut
6591 sub help_search_link
6592 {
6593 if (&foreign_available("man") && !$tconfig{'nosearch'}) {
6594         my $for = &urlize(shift(@_));
6595         return "<a href='$gconfig{'webprefix'}/man/search.cgi?".
6596                join("&", map { "section=$_" } @_)."&".
6597                "for=$for&exact=1&check=".&get_module_name()."'>".
6598                $text{'helpsearch'}."</a>\n";
6599         }
6600 else {
6601         return "";
6602         }
6603 }
6604
6605 =head2 make_http_connection(host, port, ssl, method, page, [&headers])
6606
6607 Opens a connection to some HTTP server, maybe through a proxy, and returns
6608 a handle object. The handle can then be used to send additional headers
6609 and read back a response. If anything goes wrong, returns an error string.
6610 The parameters are :
6611
6612 =item host - Hostname or IP address of the webserver to connect to.
6613
6614 =item port - HTTP port number to connect to.
6615
6616 =item ssl - Set to 1 to connect in SSL mode.
6617
6618 =item method - HTTP method, like GET or POST.
6619
6620 =item page - Page to request on the webserver, like /foo/index.html
6621
6622 =item headers - Array ref of additional HTTP headers, each of which is a 2-element array ref.
6623
6624 =cut
6625 sub make_http_connection
6626 {
6627 my ($host, $port, $ssl, $method, $page, $headers) = @_;
6628 my $htxt;
6629 if ($headers) {
6630         foreach my $h (@$headers) {
6631                 $htxt .= $h->[0].": ".$h->[1]."\r\n";
6632                 }
6633         $htxt .= "\r\n";
6634         }
6635 if (&is_readonly_mode()) {
6636         return "HTTP connections not allowed in readonly mode";
6637         }
6638 my $rv = { 'fh' => time().$$ };
6639 if ($ssl) {
6640         # Connect using SSL
6641         eval "use Net::SSLeay";
6642         $@ && return $text{'link_essl'};
6643         eval "Net::SSLeay::SSLeay_add_ssl_algorithms()";
6644         eval "Net::SSLeay::load_error_strings()";
6645         $rv->{'ssl_ctx'} = Net::SSLeay::CTX_new() ||
6646                 return "Failed to create SSL context";
6647         $rv->{'ssl_con'} = Net::SSLeay::new($rv->{'ssl_ctx'}) ||
6648                 return "Failed to create SSL connection";
6649         my $connected;
6650         if ($gconfig{'http_proxy'} =~ /^http:\/\/(\S+):(\d+)/ &&
6651             !&no_proxy($host)) {
6652                 # Via proxy
6653                 my $error;
6654                 &open_socket($1, $2, $rv->{'fh'}, \$error);
6655                 if (!$error) {
6656                         # Connected OK
6657                         my $fh = $rv->{'fh'};
6658                         print $fh "CONNECT $host:$port HTTP/1.0\r\n";
6659                         if ($gconfig{'proxy_user'}) {
6660                                 my $auth = &encode_base64(
6661                                    "$gconfig{'proxy_user'}:".
6662                                    "$gconfig{'proxy_pass'}");
6663                                 $auth =~ tr/\r\n//d;
6664                                 print $fh "Proxy-Authorization: Basic $auth\r\n";
6665                                 }
6666                         print $fh "\r\n";
6667                         my $line = <$fh>;
6668                         if ($line =~ /^HTTP(\S+)\s+(\d+)\s+(.*)/) {
6669                                 return "Proxy error : $3" if ($2 != 200);
6670                                 }
6671                         else {
6672                                 return "Proxy error : $line";
6673                                 }
6674                         $line = <$fh>;
6675                         $connected = 1;
6676                         }
6677                 elsif (!$gconfig{'proxy_fallback'}) {
6678                         # Connection to proxy failed - give up
6679                         return $error;
6680                         }
6681                 }
6682         if (!$connected) {
6683                 # Direct connection
6684                 my $error;
6685                 &open_socket($host, $port, $rv->{'fh'}, \$error);
6686                 return $error if ($error);
6687                 }
6688         Net::SSLeay::set_fd($rv->{'ssl_con'}, fileno($rv->{'fh'}));
6689         Net::SSLeay::connect($rv->{'ssl_con'}) ||
6690                 return "SSL connect() failed";
6691         my $rtxt = "$method $page HTTP/1.0\r\n".$htxt;
6692         Net::SSLeay::write($rv->{'ssl_con'}, $rtxt);
6693         }
6694 else {
6695         # Plain HTTP request
6696         my $connected;
6697         if ($gconfig{'http_proxy'} =~ /^http:\/\/(\S+):(\d+)/ &&
6698             !&no_proxy($host)) {
6699                 # Via a proxy
6700                 my $error;
6701                 &open_socket($1, $2, $rv->{'fh'}, \$error);
6702                 if (!$error) {
6703                         # Connected OK
6704                         $connected = 1;
6705                         my $fh = $rv->{'fh'};
6706                         my $rtxt = $method." ".
6707                                    "http://$host:$port$page HTTP/1.0\r\n";
6708                         if ($gconfig{'proxy_user'}) {
6709                                 my $auth = &encode_base64(
6710                                    "$gconfig{'proxy_user'}:".
6711                                    "$gconfig{'proxy_pass'}");
6712                                 $auth =~ tr/\r\n//d;
6713                                 $rtxt .= "Proxy-Authorization: Basic $auth\r\n";
6714                                 }
6715                         $rtxt .= $htxt;
6716                         print $fh $rtxt;
6717                         }
6718                 elsif (!$gconfig{'proxy_fallback'}) {
6719                         return $error;
6720                         }
6721                 }
6722         if (!$connected) {
6723                 # Connecting directly
6724                 my $error;
6725                 &open_socket($host, $port, $rv->{'fh'}, \$error);
6726                 return $error if ($error);
6727                 my $fh = $rv->{'fh'};
6728                 my $rtxt = "$method $page HTTP/1.0\r\n".$htxt;
6729                 print $fh $rtxt;
6730                 }
6731         }
6732 return $rv;
6733 }
6734
6735 =head2 read_http_connection(&handle, [bytes])
6736
6737 Reads either one line or up to the specified number of bytes from the handle,
6738 originally supplied by make_http_connection.
6739
6740 =cut
6741 sub read_http_connection
6742 {
6743 my ($h) = @_;
6744 my $rv;
6745 if ($h->{'ssl_con'}) {
6746         if (!$_[1]) {
6747                 my ($idx, $more);
6748                 while(($idx = index($h->{'buffer'}, "\n")) < 0) {
6749                         # need to read more..
6750                         if (!($more = Net::SSLeay::read($h->{'ssl_con'}))) {
6751                                 # end of the data
6752                                 $rv = $h->{'buffer'};
6753                                 delete($h->{'buffer'});
6754                                 return $rv;
6755                                 }
6756                         $h->{'buffer'} .= $more;
6757                         }
6758                 $rv = substr($h->{'buffer'}, 0, $idx+1);
6759                 $h->{'buffer'} = substr($h->{'buffer'}, $idx+1);
6760                 }
6761         else {
6762                 if (length($h->{'buffer'})) {
6763                         $rv = $h->{'buffer'};
6764                         delete($h->{'buffer'});
6765                         }
6766                 else {
6767                         $rv = Net::SSLeay::read($h->{'ssl_con'}, $_[1]);
6768                         }
6769                 }
6770         }
6771 else {
6772         if ($_[1]) {
6773                 read($h->{'fh'}, $rv, $_[1]) > 0 || return undef;
6774                 }
6775         else {
6776                 my $fh = $h->{'fh'};
6777                 $rv = <$fh>;
6778                 }
6779         }
6780 $rv = undef if ($rv eq "");
6781 return $rv;
6782 }
6783
6784 =head2 write_http_connection(&handle, [data+])
6785
6786 Writes the given data to the given HTTP connection handle.
6787
6788 =cut
6789 sub write_http_connection
6790 {
6791 my $h = shift(@_);
6792 my $fh = $h->{'fh'};
6793 my $allok = 1;
6794 if ($h->{'ssl_ctx'}) {
6795         foreach my $s (@_) {
6796                 my $ok = Net::SSLeay::write($h->{'ssl_con'}, $s);
6797                 $allok = 0 if (!$ok);
6798                 }
6799         }
6800 else {
6801         my $ok = (print $fh @_);
6802         $allok = 0 if (!$ok);
6803         }
6804 return $allok;
6805 }
6806
6807 =head2 close_http_connection(&handle)
6808
6809 Closes a connection to an HTTP server, identified by the given handle.
6810
6811 =cut
6812 sub close_http_connection
6813 {
6814 my ($h) = @_;
6815 close($h->{'fh'});
6816 }
6817
6818 =head2 clean_environment
6819
6820 Deletes any environment variables inherited from miniserv so that they
6821 won't be passed to programs started by webmin. This is useful when calling
6822 programs that check for CGI-related environment variables and modify their
6823 behaviour, and to avoid passing sensitive variables to un-trusted programs.
6824
6825 =cut
6826 sub clean_environment
6827 {
6828 %UNCLEAN_ENV = %ENV;
6829 foreach my $k (keys %ENV) {
6830         if ($k =~ /^(HTTP|VIRTUALSERVER|QUOTA|USERADMIN)_/) {
6831                 delete($ENV{$k});
6832                 }
6833         }
6834 foreach my $e ('WEBMIN_CONFIG', 'SERVER_NAME', 'CONTENT_TYPE', 'REQUEST_URI',
6835             'PATH_INFO', 'WEBMIN_VAR', 'REQUEST_METHOD', 'GATEWAY_INTERFACE',
6836             'QUERY_STRING', 'REMOTE_USER', 'SERVER_SOFTWARE', 'SERVER_PROTOCOL',
6837             'REMOTE_HOST', 'SERVER_PORT', 'DOCUMENT_ROOT', 'SERVER_ROOT',
6838             'MINISERV_CONFIG', 'SCRIPT_NAME', 'SERVER_ADMIN', 'CONTENT_LENGTH',
6839             'HTTPS', 'FOREIGN_MODULE_NAME', 'FOREIGN_ROOT_DIRECTORY',
6840             'SCRIPT_FILENAME', 'PATH_TRANSLATED', 'BASE_REMOTE_USER',
6841             'DOCUMENT_REALROOT', 'MINISERV_CONFIG', 'MYSQL_PWD',
6842             'MINISERV_PID') {
6843         delete($ENV{$e});
6844         }
6845 }
6846
6847 =head2 reset_environment
6848
6849 Puts the environment back how it was before clean_environment was callled.
6850
6851 =cut
6852 sub reset_environment
6853 {
6854 if (%UNCLEAN_ENV) {
6855         foreach my $k (keys %UNCLEAN_ENV) {
6856                 $ENV{$k} = $UNCLEAN_ENV{$k};
6857                 }
6858         undef(%UNCLEAN_ENV);
6859         }
6860 }
6861
6862 =head2 progress_callback
6863
6864 Never called directly, but useful for passing to &http_download to print
6865 out progress of an HTTP request.
6866
6867 =cut
6868 sub progress_callback
6869 {
6870 if (defined(&theme_progress_callback)) {
6871         # Call the theme override
6872         return &theme_progress_callback(@_);
6873         }
6874 if ($_[0] == 2) {
6875         # Got size
6876         print $progress_callback_prefix;
6877         if ($_[1]) {
6878                 $progress_size = $_[1];
6879                 $progress_step = int($_[1] / 10);
6880                 print &text('progress_size2', $progress_callback_url,
6881                             &nice_size($progress_size)),"<br>\n";
6882                 }
6883         else {
6884                 print &text('progress_nosize', $progress_callback_url),"<br>\n";
6885                 }
6886         $last_progress_time = $last_progress_size = undef;
6887         }
6888 elsif ($_[0] == 3) {
6889         # Got data update
6890         my $sp = $progress_callback_prefix.("&nbsp;" x 5);
6891         if ($progress_size) {
6892                 # And we have a size to compare against
6893                 my $st = int(($_[1] * 10) / $progress_size);
6894                 my $time_now = time();
6895                 if ($st != $progress_step ||
6896                     $time_now - $last_progress_time > 60) {
6897                         # Show progress every 10% or 60 seconds
6898                         print $sp,&text('progress_datan', &nice_size($_[1]),
6899                                         int($_[1]*100/$progress_size)),"<br>\n";
6900                         $last_progress_time = $time_now;
6901                         }
6902                 $progress_step = $st;
6903                 }
6904         else {
6905                 # No total size .. so only show in 100k jumps
6906                 if ($_[1] > $last_progress_size+100*1024) {
6907                         print $sp,&text('progress_data2n',
6908                                         &nice_size($_[1])),"<br>\n";
6909                         $last_progress_size = $_[1];
6910                         }
6911                 }
6912         }
6913 elsif ($_[0] == 4) {
6914         # All done downloading
6915         print $progress_callback_prefix,&text('progress_done'),"<br>\n";
6916         }
6917 elsif ($_[0] == 5) {
6918         # Got new location after redirect
6919         $progress_callback_url = $_[1];
6920         }
6921 elsif ($_[0] == 6) {
6922         # URL is in cache
6923         $progress_callback_url = $_[1];
6924         print &text('progress_incache', $progress_callback_url),"<br>\n";
6925         }
6926 }
6927
6928 =head2 switch_to_remote_user
6929
6930 Changes the user and group of the current process to that of the unix user
6931 with the same name as the current webmin login, or fails if there is none.
6932 This should be called by Usermin module scripts that only need to run with
6933 limited permissions.
6934
6935 =cut
6936 sub switch_to_remote_user
6937 {
6938 @remote_user_info = $remote_user ? getpwnam($remote_user) :
6939                                    getpwuid($<);
6940 @remote_user_info || &error(&text('switch_remote_euser', $remote_user));
6941 &create_missing_homedir(\@remote_user_info);
6942 if ($< == 0) {
6943         &switch_to_unix_user(\@remote_user_info);
6944         $ENV{'USER'} = $ENV{'LOGNAME'} = $remote_user;
6945         $ENV{'HOME'} = $remote_user_info[7];
6946         }
6947 # Export global variables to caller
6948 if ($main::export_to_caller) {
6949         my ($callpkg) = caller();
6950         eval "\@${callpkg}::remote_user_info = \@remote_user_info";
6951         }
6952 }
6953
6954 =head2 switch_to_unix_user(&user-details)
6955
6956 Switches the current process to the UID and group ID from the given list
6957 of user details, which must be in the format returned by getpwnam.
6958
6959 =cut
6960 sub switch_to_unix_user
6961 {
6962 my ($uinfo) = @_;
6963 if (!defined($uinfo->[0])) {
6964         # No username given, so just use given GID
6965         ($(, $)) = ( $uinfo->[3], "$uinfo->[3] $uinfo->[3]" );
6966         }
6967 else {
6968         # Use all groups from user
6969         ($(, $)) = ( $uinfo->[3],
6970                      "$uinfo->[3] ".join(" ", $uinfo->[3],
6971                                          &other_groups($uinfo->[0])) );
6972         }
6973 eval {
6974         POSIX::setuid($uinfo->[2]);
6975         };
6976 if ($< != $uinfo->[2] || $> != $uinfo->[2]) {
6977         ($>, $<) = ( $uinfo->[2], $uinfo->[2] );
6978         }
6979 }
6980
6981 =head2 eval_as_unix_user(username, &code)
6982
6983 Runs some code fragment with the effective UID and GID switch to that
6984 of the given Unix user, so that file IO takes place with his permissions.
6985
6986 =cut
6987
6988 sub eval_as_unix_user
6989 {
6990 my ($user, $code) = @_;
6991 my @uinfo = getpwnam($user);
6992 if (!scalar(@uinfo)) {
6993         &error("eval_as_unix_user called with invalid user $user");
6994         }
6995 $) = $uinfo[3]." ".join(" ", $uinfo[3], &other_groups($user));
6996 $> = $uinfo[2];
6997 my @rv;
6998 eval {
6999         local $main::error_must_die = 1;
7000         @rv = &$code();
7001         };
7002 my $err = $@;
7003 $) = 0;
7004 $> = 0;
7005 if ($err) {
7006         $err =~ s/\s+at\s+(\/\S+)\s+line\s+(\d+)\.?//;
7007         &error($err);
7008         }
7009 return wantarray ? @rv : $rv[0];
7010 }
7011
7012 =head2 create_user_config_dirs
7013
7014 Creates per-user config directories and sets $user_config_directory and
7015 $user_module_config_directory to them. Also reads per-user module configs
7016 into %userconfig. This should be called by Usermin module scripts that need
7017 to store per-user preferences or other settings.
7018
7019 =cut
7020 sub create_user_config_dirs
7021 {
7022 return if (!$gconfig{'userconfig'});
7023 my @uinfo = @remote_user_info ? @remote_user_info : getpwnam($remote_user);
7024 return if (!@uinfo || !$uinfo[7]);
7025 &create_missing_homedir(\@uinfo);
7026 $user_config_directory = "$uinfo[7]/$gconfig{'userconfig'}";
7027 if (!-d $user_config_directory) {
7028         mkdir($user_config_directory, 0700) ||
7029                 &error("Failed to create $user_config_directory : $!");
7030         if ($< == 0 && $uinfo[2]) {
7031                 chown($uinfo[2], $uinfo[3], $user_config_directory);
7032                 }
7033         }
7034 if (&get_module_name()) {
7035         $user_module_config_directory = $user_config_directory."/".
7036                                         &get_module_name();
7037         if (!-d $user_module_config_directory) {
7038                 mkdir($user_module_config_directory, 0700) ||
7039                         &error("Failed to create $user_module_config_directory : $!");
7040                 if ($< == 0 && $uinfo[2]) {
7041                         chown($uinfo[2], $uinfo[3], $user_config_directory);
7042                         }
7043                 }
7044         undef(%userconfig);
7045         &read_file_cached("$module_root_directory/defaultuconfig",
7046                           \%userconfig);
7047         &read_file_cached("$module_config_directory/uconfig", \%userconfig);
7048         &read_file_cached("$user_module_config_directory/config",
7049                           \%userconfig);
7050         }
7051
7052 # Export global variables to caller
7053 if ($main::export_to_caller) {
7054         my ($callpkg) = caller();
7055         foreach my $v ('$user_config_directory',
7056                        '$user_module_config_directory', '%userconfig') {
7057                 my ($vt, $vn) = split('', $v, 2);
7058                 eval "${vt}${callpkg}::${vn} = ${vt}${vn}";
7059                 }
7060         }
7061 }
7062
7063 =head2 create_missing_homedir(&uinfo)
7064
7065 If auto homedir creation is enabled, create one for this user if needed.
7066 For internal use only.
7067
7068 =cut
7069 sub create_missing_homedir
7070 {
7071 my ($uinfo) = @_;
7072 if (!-e $uinfo->[7] && $gconfig{'create_homedir'}) {
7073         # Use has no home dir .. make one
7074         system("mkdir -p ".quotemeta($uinfo->[7]));
7075         chown($uinfo->[2], $uinfo->[3], $uinfo->[7]);
7076         if ($gconfig{'create_homedir_perms'} ne '') {
7077                 chmod(oct($gconfig{'create_homedir_perms'}), $uinfo->[7]);
7078                 }
7079         }
7080 }
7081
7082 =head2 filter_javascript(text)
7083
7084 Disables all javascript <script>, onClick= and so on tags in the given HTML,
7085 and returns the new HTML. Useful for displaying HTML from an un-trusted source.
7086
7087 =cut
7088 sub filter_javascript
7089 {
7090 my ($rv) = @_;
7091 $rv =~ s/<\s*script[^>]*>([\000-\377]*?)<\s*\/script\s*>//gi;
7092 $rv =~ s/(on(Abort|Blur|Change|Click|DblClick|DragDrop|Error|Focus|KeyDown|KeyPress|KeyUp|Load|MouseDown|MouseMove|MouseOut|MouseOver|MouseUp|Move|Reset|Resize|Select|Submit|Unload)=)/x$1/gi;
7093 $rv =~ s/(javascript:)/x$1/gi;
7094 $rv =~ s/(vbscript:)/x$1/gi;
7095 return $rv;
7096 }
7097
7098 =head2 resolve_links(path)
7099
7100 Given a path that may contain symbolic links, returns the real path.
7101
7102 =cut
7103 sub resolve_links
7104 {
7105 my ($path) = @_;
7106 $path =~ s/\/+/\//g;
7107 $path =~ s/\/$// if ($path ne "/");
7108 my @p = split(/\/+/, $path);
7109 shift(@p);
7110 for(my $i=0; $i<@p; $i++) {
7111         my $sofar = "/".join("/", @p[0..$i]);
7112         my $lnk = readlink($sofar);
7113         if ($lnk eq $sofar) {
7114                 # Link to itself! Cannot do anything more really ..
7115                 last;
7116                 }
7117         elsif ($lnk =~ /^\//) {
7118                 # Link is absolute..
7119                 return &resolve_links($lnk."/".join("/", @p[$i+1 .. $#p]));
7120                 }
7121         elsif ($lnk) {
7122                 # Link is relative
7123                 return &resolve_links("/".join("/", @p[0..$i-1])."/".$lnk."/".join("/", @p[$i+1 .. $#p]));
7124                 }
7125         }
7126 return $path;
7127 }
7128
7129 =head2 simplify_path(path, bogus)
7130
7131 Given a path, maybe containing elements ".." and "." , convert it to a
7132 clean, absolute form. Returns undef if this is not possible.
7133
7134 =cut
7135 sub simplify_path
7136 {
7137 my ($dir) = @_;
7138 $dir =~ s/^\/+//g;
7139 $dir =~ s/\/+$//g;
7140 my @bits = split(/\/+/, $dir);
7141 my @fixedbits = ();
7142 $_[1] = 0;
7143 foreach my $b (@bits) {
7144         if ($b eq ".") {
7145                 # Do nothing..
7146                 }
7147         elsif ($b eq "..") {
7148                 # Remove last dir
7149                 if (scalar(@fixedbits) == 0) {
7150                         # Cannot! Already at root!
7151                         return undef;
7152                         }
7153                 pop(@fixedbits);
7154                 }
7155         else {
7156                 # Add dir to list
7157                 push(@fixedbits, $b);
7158                 }
7159         }
7160 return "/".join('/', @fixedbits);
7161 }
7162
7163 =head2 same_file(file1, file2)
7164
7165 Returns 1 if two files are actually the same
7166
7167 =cut
7168 sub same_file
7169 {
7170 return 1 if ($_[0] eq $_[1]);
7171 return 0 if ($_[0] !~ /^\// || $_[1] !~ /^\//);
7172 my @stat1 = $stat_cache{$_[0]} ? @{$stat_cache{$_[0]}}
7173                                : (@{$stat_cache{$_[0]}} = stat($_[0]));
7174 my @stat2 = $stat_cache{$_[1]} ? @{$stat_cache{$_[1]}}
7175                                : (@{$stat_cache{$_[1]}} = stat($_[1]));
7176 return 0 if (!@stat1 || !@stat2);
7177 return $stat1[0] == $stat2[0] && $stat1[1] == $stat2[1];
7178 }
7179
7180 =head2 flush_webmin_caches
7181
7182 Clears all in-memory and on-disk caches used by Webmin.
7183
7184 =cut
7185 sub flush_webmin_caches
7186 {
7187 undef(%main::read_file_cache);
7188 undef(%main::acl_hash_cache);
7189 undef(%main::acl_array_cache);
7190 undef(%main::has_command_cache);
7191 undef(@main::list_languages_cache);
7192 undef($main::got_list_usermods_cache);
7193 undef(@main::list_usermods_cache);
7194 undef(%main::foreign_installed_cache);
7195 unlink("$config_directory/module.infos.cache");
7196 &get_all_module_infos();
7197 }
7198
7199 =head2 list_usermods
7200
7201 Returns a list of additional module restrictions. For internal use in
7202 Usermin only.
7203
7204 =cut
7205 sub list_usermods
7206 {
7207 if (!$main::got_list_usermods_cache) {
7208         @main::list_usermods_cache = ( );
7209         local $_;
7210         open(USERMODS, "$config_directory/usermin.mods");
7211         while(<USERMODS>) {
7212                 if (/^([^:]+):(\+|-|):(.*)/) {
7213                         push(@main::list_usermods_cache,
7214                              [ $1, $2, [ split(/\s+/, $3) ] ]);
7215                         }
7216                 }
7217         close(USERMODS);
7218         $main::got_list_usermods_cache = 1;
7219         }
7220 return @main::list_usermods_cache;
7221 }
7222
7223 =head2 available_usermods(&allmods, &usermods)
7224
7225 Returns a list of modules that are available to the given user, based
7226 on usermod additional/subtractions. For internal use by Usermin only.
7227
7228 =cut
7229 sub available_usermods
7230 {
7231 return @{$_[0]} if (!@{$_[1]});
7232
7233 my %mods = map { $_->{'dir'}, 1 } @{$_[0]};
7234 my @uinfo = @remote_user_info;
7235 @uinfo = getpwnam($remote_user) if (!@uinfo);
7236 foreach my $u (@{$_[1]}) {
7237         my $applies;
7238         if ($u->[0] eq "*" || $u->[0] eq $remote_user) {
7239                 $applies++;
7240                 }
7241         elsif ($u->[0] =~ /^\@(.*)$/) {
7242                 # Check for group membership
7243                 my @ginfo = getgrnam($1);
7244                 $applies++ if (@ginfo && ($ginfo[2] == $uinfo[3] ||
7245                         &indexof($remote_user, split(/\s+/, $ginfo[3])) >= 0));
7246                 }
7247         elsif ($u->[0] =~ /^\//) {
7248                 # Check users and groups in file
7249                 local $_;
7250                 open(USERFILE, $u->[0]);
7251                 while(<USERFILE>) {
7252                         tr/\r\n//d;
7253                         if ($_ eq $remote_user) {
7254                                 $applies++;
7255                                 }
7256                         elsif (/^\@(.*)$/) {
7257                                 my @ginfo = getgrnam($1);
7258                                 $applies++
7259                                   if (@ginfo && ($ginfo[2] == $uinfo[3] ||
7260                                       &indexof($remote_user,
7261                                                split(/\s+/, $ginfo[3])) >= 0));
7262                                 }
7263                         last if ($applies);
7264                         }
7265                 close(USERFILE);
7266                 }
7267         if ($applies) {
7268                 if ($u->[1] eq "+") {
7269                         map { $mods{$_}++ } @{$u->[2]};
7270                         }
7271                 elsif ($u->[1] eq "-") {
7272                         map { delete($mods{$_}) } @{$u->[2]};
7273                         }
7274                 else {
7275                         undef(%mods);
7276                         map { $mods{$_}++ } @{$u->[2]};
7277                         }
7278                 }
7279         }
7280 return grep { $mods{$_->{'dir'}} } @{$_[0]};
7281 }
7282
7283 =head2 get_available_module_infos(nocache)
7284
7285 Returns a list of modules available to the current user, based on
7286 operating system support, access control and usermod restrictions. Useful
7287 in themes that need to display a list of modules the user can use.
7288 Each element of the returned array is a hash reference in the same format as
7289 returned by get_module_info.
7290
7291 =cut
7292 sub get_available_module_infos
7293 {
7294 my (%acl, %uacl);
7295 &read_acl(\%acl, \%uacl, [ $base_remote_user ]);
7296 my $risk = $gconfig{'risk_'.$base_remote_user};
7297 my @rv;
7298 foreach my $minfo (&get_all_module_infos($_[0])) {
7299         next if (!&check_os_support($minfo));
7300         if ($risk) {
7301                 # Check module risk level
7302                 next if ($risk ne 'high' && $minfo->{'risk'} &&
7303                          $minfo->{'risk'} !~ /$risk/);
7304                 }
7305         else {
7306                 # Check user's ACL
7307                 next if (!$acl{$base_remote_user,$minfo->{'dir'}} &&
7308                          !$acl{$base_remote_user,"*"});
7309                 }
7310         next if (&is_readonly_mode() && !$minfo->{'readonly'});
7311         push(@rv, $minfo);
7312         }
7313
7314 # Check usermod restrictions
7315 my @usermods = &list_usermods();
7316 @rv = sort { $a->{'desc'} cmp $b->{'desc'} }
7317             &available_usermods(\@rv, \@usermods);
7318
7319 # Check RBAC restrictions
7320 my @rbacrv;
7321 foreach my $m (@rv) {
7322         if (&supports_rbac($m->{'dir'}) &&
7323             &use_rbac_module_acl(undef, $m->{'dir'})) {
7324                 local $rbacs = &get_rbac_module_acl($remote_user,
7325                                                     $m->{'dir'});
7326                 if ($rbacs) {
7327                         # RBAC allows
7328                         push(@rbacrv, $m);
7329                         }
7330                 }
7331         else {
7332                 # Module or system doesn't support RBAC
7333                 push(@rbacrv, $m) if (!$gconfig{'rbacdeny_'.$base_remote_user});
7334                 }
7335         }
7336
7337 # Check theme vetos
7338 my @themerv;
7339 if (defined(&theme_foreign_available)) {
7340         foreach my $m (@rbacrv) {
7341                 if (&theme_foreign_available($m->{'dir'})) {
7342                         push(@themerv, $m);
7343                         }
7344                 }
7345         }
7346 else {
7347         @themerv = @rbacrv;
7348         }
7349
7350 # Check licence module vetos
7351 my @licrv;
7352 if ($main::licence_module) {
7353         foreach my $m (@themerv) {
7354                 if (&foreign_call($main::licence_module,
7355                                   "check_module_licence", $m->{'dir'})) {
7356                         push(@licrv, $m);
7357                         }
7358                 }
7359         }
7360 else {
7361         @licrv = @themerv;
7362         }
7363
7364 return @licrv;
7365 }
7366
7367 =head2 get_visible_module_infos(nocache)
7368
7369 Like get_available_module_infos, but excludes hidden modules from the list.
7370 Each element of the returned array is a hash reference in the same format as
7371 returned by get_module_info.
7372
7373 =cut
7374 sub get_visible_module_infos
7375 {
7376 my ($nocache) = @_;
7377 my $pn = &get_product_name();
7378 return grep { !$_->{'hidden'} &&
7379               !$_->{$pn.'_hidden'} } &get_available_module_infos($nocache);
7380 }
7381
7382 =head2 get_visible_modules_categories(nocache)
7383
7384 Returns a list of Webmin module categories, each of which is a hash ref
7385 with 'code', 'desc' and 'modules' keys. The modules value is an array ref
7386 of modules in the category, in the format returned by get_module_info.
7387 Un-used modules are automatically assigned to the 'unused' category, and
7388 those with no category are put into 'others'.
7389
7390 =cut
7391 sub get_visible_modules_categories
7392 {
7393 my ($nocache) = @_;
7394 my @mods = &get_visible_module_infos($nocache);
7395 my @unmods;
7396 if (&get_product_name() eq 'webmin') {
7397         @unmods = grep { $_->{'installed'} eq '0' } @mods;
7398         @mods = grep { $_->{'installed'} ne '0' } @mods;
7399         }
7400 my %cats = &list_categories(\@mods);
7401 my @rv;
7402 foreach my $c (keys %cats) {
7403         my $cat = { 'code' => $c || 'other',
7404                     'desc' => $cats{$c} };
7405         $cat->{'modules'} = [ grep { $_->{'category'} eq $c } @mods ];
7406         push(@rv, $cat);
7407         }
7408 @rv = sort { ($b->{'code'} eq "others" ? "" : $b->{'code'}) cmp
7409              ($a->{'code'} eq "others" ? "" : $a->{'code'}) } @rv;
7410 if (@unmods) {
7411         # Add un-installed modules in magic category
7412         my $cat = { 'code' => 'unused',
7413                     'desc' => $text{'main_unused'},
7414                     'unused' => 1,
7415                     'modules' => \@unmods };
7416         push(@rv, $cat);
7417         }
7418 return @rv;
7419 }
7420
7421 =head2 is_under_directory(directory, file)
7422
7423 Returns 1 if the given file is under the specified directory, 0 if not.
7424 Symlinks are taken into account in the file to find it's 'real' location.
7425
7426 =cut
7427 sub is_under_directory
7428 {
7429 my ($dir, $file) = @_;
7430 return 1 if ($dir eq "/");
7431 return 0 if ($file =~ /\.\./);
7432 my $ld = &resolve_links($dir);
7433 if ($ld ne $dir) {
7434         return &is_under_directory($ld, $file);
7435         }
7436 my $lp = &resolve_links($file);
7437 if ($lp ne $file) {
7438         return &is_under_directory($dir, $lp);
7439         }
7440 return 0 if (length($file) < length($dir));
7441 return 1 if ($dir eq $file);
7442 $dir =~ s/\/*$/\//;
7443 return substr($file, 0, length($dir)) eq $dir;
7444 }
7445
7446 =head2 parse_http_url(url, [basehost, baseport, basepage, basessl])
7447
7448 Given an absolute URL, returns the host, port, page and ssl flag components.
7449 If a username and password are given before the hostname, return those too.
7450 Relative URLs can also be parsed, if the base information is provided.
7451
7452 =cut
7453 sub parse_http_url
7454 {
7455 if ($_[0] =~ /^(http|https):\/\/([^\@]+\@)?\[([^\]]+)\](:(\d+))?(\/\S*)?$/ ||
7456     $_[0] =~ /^(http|https):\/\/([^\@]+\@)?([^:\/]+)(:(\d+))?(\/\S*)?$/) {
7457         # An absolute URL
7458         my $ssl = $1 eq 'https';
7459         my @rv = ($3, $4 ? $5 : $ssl ? 443 : 80, $6 || "/", $ssl);
7460         if ($2 =~ /^([^:]+):(\S+)\@/) {
7461                 push(@rv, $1, $2);
7462                 }
7463         return @rv;
7464         }
7465 elsif (!$_[1]) {
7466         # Could not parse
7467         return undef;
7468         }
7469 elsif ($_[0] =~ /^\/\S*$/) {
7470         # A relative to the server URL
7471         return ($_[1], $_[2], $_[0], $_[4], $_[5], $_[6]);
7472         }
7473 else {
7474         # A relative to the directory URL
7475         my $page = $_[3];
7476         $page =~ s/[^\/]+$//;
7477         return ($_[1], $_[2], $page.$_[0], $_[4], $_[5], $_[6]);
7478         }
7479 }
7480
7481 =head2 check_clicks_function
7482
7483 Returns HTML for a JavaScript function called check_clicks that returns
7484 true when first called, but false subsequently. Useful on onClick for
7485 critical buttons. Deprecated, as this method of preventing duplicate actions
7486 is un-reliable.
7487
7488 =cut
7489 sub check_clicks_function
7490 {
7491 return <<EOF;
7492 <script>
7493 clicks = 0;
7494 function check_clicks(form)
7495 {
7496 clicks++;
7497 if (clicks == 1)
7498         return true;
7499 else {
7500         if (form != null) {
7501                 for(i=0; i<form.length; i++)
7502                         form.elements[i].disabled = true;
7503                 }
7504         return false;
7505         }
7506 }
7507 </script>
7508 EOF
7509 }
7510
7511 =head2 load_entities_map
7512
7513 Returns a hash ref containing mappings between HTML entities (like ouml) and
7514 ascii values (like 246). Mainly for internal use.
7515
7516 =cut
7517 sub load_entities_map
7518 {
7519 if (!%entities_map_cache) {
7520         local $_;
7521         open(EMAP, "$root_directory/entities_map.txt");
7522         while(<EMAP>) {
7523                 if (/^(\d+)\s+(\S+)/) {
7524                         $entities_map_cache{$2} = $1;
7525                         }
7526                 }
7527         close(EMAP);
7528         }
7529 return \%entities_map_cache;
7530 }
7531
7532 =head2 entities_to_ascii(string)
7533
7534 Given a string containing HTML entities like &ouml; and &#55;, replace them
7535 with their ASCII equivalents.
7536
7537 =cut
7538 sub entities_to_ascii
7539 {
7540 my ($str) = @_;
7541 my $emap = &load_entities_map();
7542 $str =~ s/&([a-z]+);/chr($emap->{$1})/ge;
7543 $str =~ s/&#(\d+);/chr($1)/ge;
7544 return $str;
7545 }
7546
7547 =head2 get_product_name
7548
7549 Returns either 'webmin' or 'usermin', depending on which program the current
7550 module is in. Useful for modules that can be installed into either.
7551
7552 =cut
7553 sub get_product_name
7554 {
7555 return $gconfig{'product'} if (defined($gconfig{'product'}));
7556 return defined($gconfig{'userconfig'}) ? 'usermin' : 'webmin';
7557 }
7558
7559 =head2 get_charset
7560
7561 Returns the character set for the current language, such as iso-8859-1.
7562
7563 =cut
7564 sub get_charset
7565 {
7566 my $charset = defined($gconfig{'charset'}) ? $gconfig{'charset'} :
7567                  $current_lang_info->{'charset'} ?
7568                  $current_lang_info->{'charset'} : $default_charset;
7569 return $charset;
7570 }
7571
7572 =head2 get_display_hostname
7573
7574 Returns the system's hostname for UI display purposes. This may be different
7575 from the actual hostname if you administrator has configured it so in the
7576 Webmin Configuration module.
7577
7578 =cut
7579 sub get_display_hostname
7580 {
7581 if ($gconfig{'hostnamemode'} == 0) {
7582         return &get_system_hostname();
7583         }
7584 elsif ($gconfig{'hostnamemode'} == 3) {
7585         return $gconfig{'hostnamedisplay'};
7586         }
7587 else {
7588         my $h = $ENV{'HTTP_HOST'};
7589         $h =~ s/:\d+//g;
7590         if ($gconfig{'hostnamemode'} == 2) {
7591                 $h =~ s/^(www|ftp|mail)\.//i;
7592                 }
7593         return $h;
7594         }
7595 }
7596
7597 =head2 save_module_config([&config], [modulename])
7598
7599 Saves the configuration for some module. The config parameter is an optional
7600 hash reference of names and values to save, which defaults to the global
7601 %config hash. The modulename parameter is the module to update the config
7602 file, which defaults to the current module.
7603
7604 =cut
7605 sub save_module_config
7606 {
7607 my $c = $_[0] || { &get_module_variable('%config') };
7608 my $m = defined($_[1]) ? $_[1] : &get_module_name();
7609 &write_file("$config_directory/$m/config", $c);
7610 }
7611
7612 =head2 save_user_module_config([&config], [modulename])
7613
7614 Saves the user's Usermin preferences for some module. The config parameter is
7615 an optional hash reference of names and values to save, which defaults to the
7616 global %userconfig hash. The modulename parameter is the module to update the
7617 config file, which defaults to the current module.
7618
7619 =cut
7620 sub save_user_module_config
7621 {
7622 my $c = $_[0] || { &get_module_variable('%userconfig') };
7623 my $m = $_[1] || &get_module_name();
7624 my $ucd = $user_config_directory;
7625 if (!$ucd) {
7626         my @uinfo = @remote_user_info ? @remote_user_info
7627                                       : getpwnam($remote_user);
7628         return if (!@uinfo || !$uinfo[7]);
7629         $ucd = "$uinfo[7]/$gconfig{'userconfig'}";
7630         }
7631 &write_file("$ucd/$m/config", $c);
7632 }
7633
7634 =head2 nice_size(bytes, [min])
7635
7636 Converts a number of bytes into a number followed by a suffix like GB, MB
7637 or kB. Rounding is to two decimal digits. The optional min parameter sets the
7638 smallest units to use - so you could pass 1024*1024 to never show bytes or kB.
7639
7640 =cut
7641 sub nice_size
7642 {
7643 my ($units, $uname);
7644 if (abs($_[0]) > 1024*1024*1024*1024 || $_[1] >= 1024*1024*1024*1024) {
7645         $units = 1024*1024*1024*1024;
7646         $uname = "TB";
7647         }
7648 elsif (abs($_[0]) > 1024*1024*1024 || $_[1] >= 1024*1024*1024) {
7649         $units = 1024*1024*1024;
7650         $uname = "GB";
7651         }
7652 elsif (abs($_[0]) > 1024*1024 || $_[1] >= 1024*1024) {
7653         $units = 1024*1024;
7654         $uname = "MB";
7655         }
7656 elsif (abs($_[0]) > 1024 || $_[1] >= 1024) {
7657         $units = 1024;
7658         $uname = "kB";
7659         }
7660 else {
7661         $units = 1;
7662         $uname = "bytes";
7663         }
7664 my $sz = sprintf("%.2f", ($_[0]*1.0 / $units));
7665 $sz =~ s/\.00$//;
7666 return $sz." ".$uname;
7667 }
7668
7669 =head2 get_perl_path
7670
7671 Returns the path to Perl currently in use, such as /usr/bin/perl.
7672
7673 =cut
7674 sub get_perl_path
7675 {
7676 if (open(PERL, "$config_directory/perl-path")) {
7677         my $rv;
7678         chop($rv = <PERL>);
7679         close(PERL);
7680         return $rv;
7681         }
7682 return $^X if (-x $^X);
7683 return &has_command("perl");
7684 }
7685
7686 =head2 get_goto_module([&mods])
7687
7688 Returns the details of a module that the current user should be re-directed
7689 to after logging in, or undef if none. Useful for themes.
7690
7691 =cut
7692 sub get_goto_module
7693 {
7694 my @mods = $_[0] ? @{$_[0]} : &get_visible_module_infos();
7695 if ($gconfig{'gotomodule'}) {
7696         my ($goto) = grep { $_->{'dir'} eq $gconfig{'gotomodule'} } @mods;
7697         return $goto if ($goto);
7698         }
7699 if (@mods == 1 && $gconfig{'gotoone'}) {
7700         return $mods[0];
7701         }
7702 return undef;
7703 }
7704
7705 =head2 select_all_link(field, form, [text])
7706
7707 Returns HTML for a 'Select all' link that uses Javascript to select
7708 multiple checkboxes with the same name. The parameters are :
7709
7710 =item field - Name of the checkbox inputs.
7711
7712 =item form - Index of the form on the page.
7713
7714 =item text - Message for the link, defaulting to 'Select all'.
7715
7716 =cut
7717 sub select_all_link
7718 {
7719 return &theme_select_all_link(@_) if (defined(&theme_select_all_link));
7720 my ($field, $form, $text) = @_;
7721 $form = int($form);
7722 $text ||= $text{'ui_selall'};
7723 return "<a class='select_all' href='#' onClick='var ff = document.forms[$form].$field; ff.checked = true; for(i=0; i<ff.length; i++) { if (!ff[i].disabled) { ff[i].checked = true; } } return false'>$text</a>";
7724 }
7725
7726 =head2 select_invert_link(field, form, text)
7727
7728 Returns HTML for an 'Invert selection' link that uses Javascript to invert the
7729 selection on multiple checkboxes with the same name. The parameters are :
7730
7731 =item field - Name of the checkbox inputs.
7732
7733 =item form - Index of the form on the page.
7734
7735 =item text - Message for the link, defaulting to 'Invert selection'.
7736
7737 =cut
7738 sub select_invert_link
7739 {
7740 return &theme_select_invert_link(@_) if (defined(&theme_select_invert_link));
7741 my ($field, $form, $text) = @_;
7742 $form = int($form);
7743 $text ||= $text{'ui_selinv'};
7744 return "<a class='select_invert' href='#' onClick='var ff = document.forms[$form].$field; ff.checked = !ff.checked; for(i=0; i<ff.length; i++) { if (!ff[i].disabled) { ff[i].checked = !ff[i].checked; } } return false'>$text</a>";
7745 }
7746
7747 =head2 select_rows_link(field, form, text, &rows)
7748
7749 Returns HTML for a link that uses Javascript to select rows with particular
7750 values for their checkboxes. The parameters are :
7751
7752 =item field - Name of the checkbox inputs.
7753
7754 =item form - Index of the form on the page.
7755
7756 =item text - Message for the link, de
7757
7758 =item rows - Reference to an array of 1 or 0 values, indicating which rows to check.
7759
7760 =cut
7761 sub select_rows_link
7762 {
7763 return &theme_select_rows_link(@_) if (defined(&theme_select_rows_link));
7764 my ($field, $form, $text, $rows) = @_;
7765 $form = int($form);
7766 my $js = "var sel = { ".join(",", map { "\"".&quote_escape($_)."\":1" } @$rows)." }; ";
7767 $js .= "for(var i=0; i<document.forms[$form].${field}.length; i++) { var r = document.forms[$form].${field}[i]; r.checked = sel[r.value]; } ";
7768 $js .= "return false;";
7769 return "<a href='#' onClick='$js'>$text</a>";
7770 }
7771
7772 =head2 check_pid_file(file)
7773
7774 Given a pid file, returns the PID it contains if the process is running.
7775
7776 =cut
7777 sub check_pid_file
7778 {
7779 open(PIDFILE, $_[0]) || return undef;
7780 my $pid = <PIDFILE>;
7781 close(PIDFILE);
7782 $pid =~ /^\s*(\d+)/ || return undef;
7783 kill(0, $1) || return undef;
7784 return $1;
7785 }
7786
7787 =head2 get_mod_lib
7788
7789 Return the local os-specific library name to this module. For internal use only.
7790
7791 =cut
7792 sub get_mod_lib
7793 {
7794 my $mn = &get_module_name();
7795 my $md = &module_root_directory($mn);
7796 if (-r "$md/$mn-$gconfig{'os_type'}-$gconfig{'os_version'}-lib.pl") {
7797         return "$mn-$gconfig{'os_type'}-$gconfig{'os_version'}-lib.pl";
7798         }
7799 elsif (-r "$md/$mn-$gconfig{'os_type'}-lib.pl") {
7800         return "$mn-$gconfig{'os_type'}-lib.pl";
7801         }
7802 elsif (-r "$md/$mn-generic-lib.pl") {
7803         return "$mn-generic-lib.pl";
7804         }
7805 else {
7806         return "";
7807         }
7808 }
7809
7810 =head2 module_root_directory(module)
7811
7812 Given a module name, returns its root directory. On a typical Webmin install,
7813 all modules are under the same directory - but it is theoretically possible to
7814 have more than one.
7815
7816 =cut
7817 sub module_root_directory
7818 {
7819 my $d = ref($_[0]) ? $_[0]->{'dir'} : $_[0];
7820 if (@root_directories > 1) {
7821         foreach my $r (@root_directories) {
7822                 if (-d "$r/$d") {
7823                         return "$r/$d";
7824                         }
7825                 }
7826         }
7827 return "$root_directories[0]/$d";
7828 }
7829
7830 =head2 list_mime_types
7831
7832 Returns a list of all known MIME types and their extensions, as a list of hash
7833 references with keys :
7834
7835 =item type - The MIME type, like text/plain.
7836
7837 =item exts - A list of extensions, like .doc and .avi.
7838
7839 =item desc - A human-readable description for the MIME type.
7840
7841 =cut
7842 sub list_mime_types
7843 {
7844 if (!@list_mime_types_cache) {
7845         local $_;
7846         open(MIME, "$root_directory/mime.types");
7847         while(<MIME>) {
7848                 my $cmt;
7849                 s/\r|\n//g;
7850                 if (s/#\s*(.*)$//g) {
7851                         $cmt = $1;
7852                         }
7853                 my ($type, @exts) = split(/\s+/);
7854                 if ($type) {
7855                         push(@list_mime_types_cache, { 'type' => $type,
7856                                                        'exts' => \@exts,
7857                                                        'desc' => $cmt });
7858                         }
7859                 }
7860         close(MIME);
7861         }
7862 return @list_mime_types_cache;
7863 }
7864
7865 =head2 guess_mime_type(filename, [default])
7866
7867 Given a file name like xxx.gif or foo.html, returns a guessed MIME type.
7868 The optional default parameter sets a default type of use if none is found,
7869 which defaults to application/octet-stream.
7870
7871 =cut
7872 sub guess_mime_type
7873 {
7874 if ($_[0] =~ /\.([A-Za-z0-9\-]+)$/) {
7875         my $ext = $1;
7876         foreach my $t (&list_mime_types()) {
7877                 foreach my $e (@{$t->{'exts'}}) {
7878                         return $t->{'type'} if (lc($e) eq lc($ext));
7879                         }
7880                 }
7881         }
7882 return @_ > 1 ? $_[1] : "application/octet-stream";
7883 }
7884
7885 =head2 open_tempfile([handle], file, [no-error], [no-tempfile], [safe?])
7886
7887 Opens a file handle for writing to a temporary file, which will only be
7888 renamed over the real file when the handle is closed. This allows critical
7889 files like /etc/shadow to be updated safely, even if writing fails part way
7890 through due to lack of disk space. The parameters are :
7891
7892 =item handle - File handle to open, as you would use in Perl's open function.
7893
7894 =item file - Full path to the file to write, prefixed by > or >> to indicate over-writing or appending. In append mode, no temp file is used.
7895
7896 =item no-error - By default, this function will call error if the open fails. Setting this parameter to 1 causes it to return 0 on failure, and set $! with the error code.
7897
7898 =item no-tempfile - If set to 1, writing will be direct to the file instead of using a temporary file.
7899
7900 =item safe - Indicates to users in read-only mode that this write is safe and non-destructive.
7901
7902 =cut
7903 sub open_tempfile
7904 {
7905 if (@_ == 1) {
7906         # Just getting a temp file
7907         if (!defined($main::open_tempfiles{$_[0]})) {
7908                 $_[0] =~ /^(.*)\/(.*)$/ || return $_[0];
7909                 my $dir = $1 || "/";
7910                 my $tmp = "$dir/$2.webmintmp.$$";
7911                 $main::open_tempfiles{$_[0]} = $tmp;
7912                 push(@main::temporary_files, $tmp);
7913                 }
7914         return $main::open_tempfiles{$_[0]};
7915         }
7916 else {
7917         # Actually opening
7918         my ($fh, $file, $noerror, $notemp, $safe) = @_;
7919         $fh = &callers_package($fh);
7920
7921         my %gaccess = &get_module_acl(undef, "");
7922         my $db = $gconfig{'debug_what_write'};
7923         if ($file =~ /\r|\n|\0/) {
7924                 if ($noerror) { return 0; }
7925                 else { &error("Filename contains invalid characters"); }
7926                 }
7927         if (&is_readonly_mode() && $file =~ />/ && !$safe) {
7928                 # Read-only mode .. veto all writes
7929                 print STDERR "vetoing write to $file\n";
7930                 return open($fh, ">$null_file");
7931                 }
7932         elsif ($file =~ /^(>|>>|)nul$/i) {
7933                 # Write to Windows null device
7934                 &webmin_debug_log($1 eq ">" ? "WRITE" :
7935                           $1 eq ">>" ? "APPEND" : "READ", "nul") if ($db);
7936                 }
7937         elsif ($file =~ /^(>|>>)(\/dev\/.*)/ || lc($file) eq "nul") {
7938                 # Writes to /dev/null or TTYs don't need to be handled
7939                 &webmin_debug_log($1 eq ">" ? "WRITE" : "APPEND", $2) if ($db);
7940                 return open($fh, $file);
7941                 }
7942         elsif ($file =~ /^>\s*(([a-zA-Z]:)?\/.*)$/ && !$notemp) {
7943                 &webmin_debug_log("WRITE", $1) if ($db);
7944                 # Over-writing a file, via a temp file
7945                 $file = $1;
7946                 $file = &translate_filename($file);
7947                 while(-l $file) {
7948                         # Open the link target instead
7949                         $file = &resolve_links($file);
7950                         }
7951                 if (-d $file) {
7952                         # Cannot open a directory!
7953                         if ($noerror) { return 0; }
7954                         else { &error("Cannot write to directory $file"); }
7955                         }
7956                 my $tmp = &open_tempfile($file);
7957                 my $ex = open($fh, ">$tmp");
7958                 if (!$ex && $! =~ /permission/i) {
7959                         # Could not open temp file .. try opening actual file
7960                         # instead directly
7961                         $ex = open($fh, ">$file");
7962                         delete($main::open_tempfiles{$file});
7963                         }
7964                 else {
7965                         $main::open_temphandles{$fh} = $file;
7966                         }
7967                 binmode($fh);
7968                 if (!$ex && !$noerror) {
7969                         &error(&text("efileopen", $file, $!));
7970                         }
7971                 return $ex;
7972                 }
7973         elsif ($file =~ /^>\s*(([a-zA-Z]:)?\/.*)$/ && $notemp) {
7974                 # Just writing direct to a file
7975                 &webmin_debug_log("WRITE", $1) if ($db);
7976                 $file = $1;
7977                 $file = &translate_filename($file);
7978                 my @old_attributes = &get_clear_file_attributes($file);
7979                 my $ex = open($fh, ">$file");
7980                 &reset_file_attributes($file, \@old_attributes);
7981                 $main::open_temphandles{$fh} = $file;
7982                 if (!$ex && !$noerror) {
7983                         &error(&text("efileopen", $file, $!));
7984                         }
7985                 binmode($fh);
7986                 return $ex;
7987                 }
7988         elsif ($file =~ /^>>\s*(([a-zA-Z]:)?\/.*)$/) {
7989                 # Appending to a file .. nothing special to do
7990                 &webmin_debug_log("APPEND", $1) if ($db);
7991                 $file = $1;
7992                 $file = &translate_filename($file);
7993                 my @old_attributes = &get_clear_file_attributes($file);
7994                 my $ex = open($fh, ">>$file");
7995                 &reset_file_attributes($file, \@old_attributes);
7996                 $main::open_temphandles{$fh} = $file;
7997                 if (!$ex && !$noerror) {
7998                         &error(&text("efileopen", $file, $!));
7999                         }
8000                 binmode($fh);
8001                 return $ex;
8002                 }
8003         elsif ($file =~ /^([a-zA-Z]:)?\//) {
8004                 # Read mode .. nothing to do here
8005                 &webmin_debug_log("READ", $file) if ($db);
8006                 $file = &translate_filename($file);
8007                 return open($fh, $file);
8008                 }
8009         elsif ($file eq ">" || $file eq ">>") {
8010                 my ($package, $filename, $line) = caller;
8011                 if ($noerror) { return 0; }
8012                 else { &error("Missing file to open at ${package}::${filename} line $line"); }
8013                 }
8014         else {
8015                 my ($package, $filename, $line) = caller;
8016                 &error("Unsupported file or mode $file at ${package}::${filename} line $line");
8017                 }
8018         }
8019 }
8020
8021 =head2 close_tempfile(file|handle)
8022
8023 Copies a temp file to the actual file, assuming that all writes were
8024 successful. The handle must have been one passed to open_tempfile.
8025
8026 =cut
8027 sub close_tempfile
8028 {
8029 my $file;
8030 my $fh = &callers_package($_[0]);
8031
8032 if (defined($file = $main::open_temphandles{$fh})) {
8033         # Closing a handle
8034         close($fh) || &error(&text("efileclose", $file, $!));
8035         delete($main::open_temphandles{$fh});
8036         return &close_tempfile($file);
8037         }
8038 elsif (defined($main::open_tempfiles{$_[0]})) {
8039         # Closing a file
8040         &webmin_debug_log("CLOSE", $_[0]) if ($gconfig{'debug_what_write'});
8041         my @st = stat($_[0]);
8042         if (&is_selinux_enabled() && &has_command("chcon")) {
8043                 # Set original security context
8044                 system("chcon --reference=".quotemeta($_[0]).
8045                        " ".quotemeta($main::open_tempfiles{$_[0]}).
8046                        " >/dev/null 2>&1");
8047                 }
8048         my @old_attributes = &get_clear_file_attributes($_[0]);
8049         rename($main::open_tempfiles{$_[0]}, $_[0]) || &error("Failed to replace $_[0] with $main::open_tempfiles{$_[0]} : $!");
8050         if (@st) {
8051                 # Set original permissions and ownership
8052                 chmod($st[2], $_[0]);
8053                 chown($st[4], $st[5], $_[0]);
8054                 }
8055         &reset_file_attributes($_[0], \@old_attributes);
8056         delete($main::open_tempfiles{$_[0]});
8057         @main::temporary_files = grep { $_ ne $main::open_tempfiles{$_[0]} } @main::temporary_files;
8058         if ($main::open_templocks{$_[0]}) {
8059                 &unlock_file($_[0]);
8060                 delete($main::open_templocks{$_[0]});
8061                 }
8062         return 1;
8063         }
8064 else {
8065         # Must be closing a handle not associated with a file
8066         close($_[0]);
8067         return 1;
8068         }
8069 }
8070
8071 =head2 print_tempfile(handle, text, ...)
8072
8073 Like the normal print function, but calls &error on failure. Useful when
8074 combined with open_tempfile, to ensure that a criticial file is never
8075 only partially written.
8076
8077 =cut
8078 sub print_tempfile
8079 {
8080 my ($fh, @args) = @_;
8081 $fh = &callers_package($fh);
8082 (print $fh @args) || &error(&text("efilewrite",
8083                             $main::open_temphandles{$fh} || $fh, $!));
8084 }
8085
8086 =head2 is_selinux_enabled
8087
8088 Returns 1 if SElinux is supported on this system and enabled, 0 if not.
8089
8090 =cut
8091 sub is_selinux_enabled
8092 {
8093 if (!defined($main::selinux_enabled_cache)) {
8094         my %seconfig;
8095         if ($gconfig{'os_type'} !~ /-linux$/) {
8096                 # Not on linux, so no way
8097                 $main::selinux_enabled_cache = 0;
8098                 }
8099         elsif (&read_env_file("/etc/selinux/config", \%seconfig)) {
8100                 # Use global config file
8101                 $main::selinux_enabled_cache =
8102                         $seconfig{'SELINUX'} eq 'disabled' ||
8103                         !$seconfig{'SELINUX'} ? 0 : 1;
8104                 }
8105         else {
8106                 # Use selinuxenabled command
8107                 #$selinux_enabled_cache =
8108                 #       system("selinuxenabled >/dev/null 2>&1") ? 0 : 1;
8109                 $main::selinux_enabled_cache = 0;
8110                 }
8111         }
8112 return $main::selinux_enabled_cache;
8113 }
8114
8115 =head2 get_clear_file_attributes(file)
8116
8117 Finds file attributes that may prevent writing, clears them and returns them
8118 as a list. May call error. Mainly for internal use by open_tempfile and
8119 close_tempfile.
8120
8121 =cut
8122 sub get_clear_file_attributes
8123 {
8124 my ($file) = @_;
8125 my @old_attributes;
8126 if ($gconfig{'chattr'}) {
8127         # Get original immutable bit
8128         my $out = &backquote_command(
8129                 "lsattr ".quotemeta($file)." 2>/dev/null");
8130         if (!$?) {
8131                 $out =~ s/\s\S+\n//;
8132                 @old_attributes = grep { $_ ne '-' } split(//, $out);
8133                 }
8134         if (&indexof("i", @old_attributes) >= 0) {
8135                 my $err = &backquote_logged(
8136                         "chattr -i ".quotemeta($file)." 2>&1");
8137                 if ($?) {
8138                         &error("Failed to remove immutable bit on ".
8139                                "$file : $err");
8140                         }
8141                 }
8142         }
8143 return @old_attributes;
8144 }
8145
8146 =head2 reset_file_attributes(file, &attributes)
8147
8148 Put back cleared attributes on some file. May call error. Mainly for internal
8149 use by close_tempfile.
8150
8151 =cut
8152 sub reset_file_attributes
8153 {
8154 my ($file, $old_attributes) = @_;
8155 if (&indexof("i", @$old_attributes) >= 0) {
8156         my $err = &backquote_logged(
8157                 "chattr +i ".quotemeta($file)." 2>&1");
8158         if ($?) {
8159                 &error("Failed to restore immutable bit on ".
8160                        "$file : $err");
8161                 }
8162         }
8163 }
8164
8165 =head2 cleanup_tempnames
8166
8167 Remove all temporary files generated using transname. Typically only called
8168 internally when a Webmin script exits.
8169
8170 =cut
8171 sub cleanup_tempnames
8172 {
8173 foreach my $t (@main::temporary_files) {
8174         &unlink_file($t);
8175         }
8176 @main::temporary_files = ( );
8177 }
8178
8179 =head2 open_lock_tempfile([handle], file, [no-error])
8180
8181 Returns a temporary file for writing to some actual file, and also locks it.
8182 Effectively the same as calling lock_file and open_tempfile on the same file,
8183 but calls the unlock for you automatically when it is closed.
8184
8185 =cut
8186 sub open_lock_tempfile
8187 {
8188 my ($fh, $file, $noerror, $notemp, $safe) = @_;
8189 $fh = &callers_package($fh);
8190 my $lockfile = $file;
8191 $lockfile =~ s/^[^\/]*//;
8192 if ($lockfile =~ /^\//) {
8193         $main::open_templocks{$lockfile} = &lock_file($lockfile);
8194         }
8195 return &open_tempfile($fh, $file, $noerror, $notemp, $safe);
8196 }
8197
8198 sub END
8199 {
8200 $main::end_exit_status ||= $?;
8201 if ($$ == $main::initial_process_id) {
8202         # Exiting from initial process
8203         &cleanup_tempnames();
8204         if ($gconfig{'debug_what_start'} && $main::debug_log_start_time &&
8205             $main::debug_log_start_module eq &get_module_name()) {
8206                 my $len = time() - $main::debug_log_start_time;
8207                 &webmin_debug_log("STOP", "runtime=$len");
8208                 $main::debug_log_start_time = 0;
8209                 }
8210         if (!$ENV{'SCRIPT_NAME'} &&
8211             $main::initial_module_name eq &get_module_name()) {
8212                 # In a command-line script - call the real exit, so that the
8213                 # exit status gets properly propogated. In some cases this
8214                 # was not happening.
8215                 exit($main::end_exit_status);
8216                 }
8217         }
8218 }
8219
8220 =head2 month_to_number(month)
8221
8222 Converts a month name like feb to a number like 1.
8223
8224 =cut
8225 sub month_to_number
8226 {
8227 return $month_to_number_map{lc(substr($_[0], 0, 3))};
8228 }
8229
8230 =head2 number_to_month(number)
8231
8232 Converts a number like 1 to a month name like Feb.
8233
8234 =cut
8235 sub number_to_month
8236 {
8237 return ucfirst($number_to_month_map{$_[0]});
8238 }
8239
8240 =head2 get_rbac_module_acl(user, module)
8241
8242 Returns a hash reference of RBAC overrides ACLs for some user and module.
8243 May return undef if none exist (indicating access denied), or the string *
8244 if full access is granted.
8245
8246 =cut
8247 sub get_rbac_module_acl
8248 {
8249 my ($user, $mod) = @_;
8250 eval "use Authen::SolarisRBAC";
8251 return undef if ($@);
8252 my %rv;
8253 my $foundany = 0;
8254 if (Authen::SolarisRBAC::chkauth("webmin.$mod.admin", $user)) {
8255         # Automagic webmin.modulename.admin authorization exists .. allow access
8256         $foundany = 1;
8257         if (!Authen::SolarisRBAC::chkauth("webmin.$mod.config", $user)) {
8258                 %rv = ( 'noconfig' => 1 );
8259                 }
8260         else {
8261                 %rv = ( );
8262                 }
8263         }
8264 local $_;
8265 open(RBAC, &module_root_directory($mod)."/rbac-mapping");
8266 while(<RBAC>) {
8267         s/\r|\n//g;
8268         s/#.*$//;
8269         my ($auths, $acls) = split(/\s+/, $_);
8270         my @auths = split(/,/, $auths);
8271         next if (!$auths);
8272         my ($merge) = ($acls =~ s/^\+//);
8273         my $gotall = 1;
8274         if ($auths eq "*") {
8275                 # These ACLs apply to all RBAC users.
8276                 # Only if there is some that match a specific authorization
8277                 # later will they be used though.
8278                 }
8279         else {
8280                 # Check each of the RBAC authorizations
8281                 foreach my $a (@auths) {
8282                         if (!Authen::SolarisRBAC::chkauth($a, $user)) {
8283                                 $gotall = 0;
8284                                 last;
8285                                 }
8286                         }
8287                 $foundany++ if ($gotall);
8288                 }
8289         if ($gotall) {
8290                 # Found an RBAC authorization - return the ACLs
8291                 return "*" if ($acls eq "*");
8292                 my %acl = map { split(/=/, $_, 2) } split(/,/, $acls);
8293                 if ($merge) {
8294                         # Just add to current set
8295                         foreach my $a (keys %acl) {
8296                                 $rv{$a} = $acl{$a};
8297                                 }
8298                         }
8299                 else {
8300                         # Found final ACLs
8301                         return \%acl;
8302                         }
8303                 }
8304         }
8305 close(RBAC);
8306 return !$foundany ? undef : %rv ? \%rv : undef;
8307 }
8308
8309 =head2 supports_rbac([module])
8310
8311 Returns 1 if RBAC client support is available, such as on Solaris.
8312
8313 =cut
8314 sub supports_rbac
8315 {
8316 return 0 if ($gconfig{'os_type'} ne 'solaris');
8317 eval "use Authen::SolarisRBAC";
8318 return 0 if ($@);
8319 if ($_[0]) {
8320         #return 0 if (!-r &module_root_directory($_[0])."/rbac-mapping");
8321         }
8322 return 1;
8323 }
8324
8325 =head2 supports_ipv6()
8326
8327 Returns 1 if outgoing IPv6 connections can be made
8328
8329 =cut
8330 sub supports_ipv6
8331 {
8332 return $ipv6_module_error ? 0 : 1;
8333 }
8334
8335 =head2 use_rbac_module_acl(user, module)
8336
8337 Returns 1 if some user should use RBAC to get permissions for a module
8338
8339 =cut
8340 sub use_rbac_module_acl
8341 {
8342 my $u = defined($_[0]) ? $_[0] : $base_remote_user;
8343 my $m = defined($_[1]) ? $_[1] : &get_module_name();
8344 return 1 if ($gconfig{'rbacdeny_'.$u});         # RBAC forced for user
8345 my %access = &get_module_acl($u, $m, 1);
8346 return $access{'rbac'} ? 1 : 0;
8347 }
8348
8349 =head2 execute_command(command, stdin, stdout, stderr, translate-files?, safe?)
8350
8351 Runs some command, possibly feeding it input and capturing output to the
8352 give files or scalar references. The parameters are :
8353
8354 =item command - Full command to run, possibly including shell meta-characters.
8355
8356 =item stdin - File to read input from, or a scalar ref containing input, or undef if no input should be given.
8357
8358 =item stdout - File to write output to, or a scalar ref into which output should be placed, or undef if the output is to be discarded.
8359
8360 =item stderr - File to write error output to, or a scalar ref into which error output should be placed, or undef if the error output is to be discarded.
8361
8362 =item translate-files - Set to 1 to apply filename translation to any filenames. Usually has no effect.
8363
8364 =item safe - Set to 1 if this command is safe and does not modify the state of the system.
8365
8366 =cut
8367 sub execute_command
8368 {
8369 my ($cmd, $stdin, $stdout, $stderr, $trans, $safe) = @_;
8370 if (&is_readonly_mode() && !$safe) {
8371         print STDERR "Vetoing command $_[0]\n";
8372         $? = 0;
8373         return 0;
8374         }
8375 $cmd = &translate_command($cmd);
8376
8377 # Use ` operator where possible
8378 &webmin_debug_log('CMD', "cmd=$cmd") if ($gconfig{'debug_what_cmd'});
8379 if (!$stdin && ref($stdout) && !$stderr) {
8380         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
8381         $$stdout = `$cmd 2>$null_file`;
8382         return $?;
8383         }
8384 elsif (!$stdin && ref($stdout) && $stdout eq $stderr) {
8385         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
8386         $$stdout = `$cmd 2>&1`;
8387         return $?;
8388         }
8389 elsif (!$stdin && !$stdout && !$stderr) {
8390         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
8391         return system("$cmd >$null_file 2>$null_file <$null_file");
8392         }
8393
8394 # Setup pipes
8395 $| = 1;         # needed on some systems to flush before forking
8396 pipe(EXECSTDINr, EXECSTDINw);
8397 pipe(EXECSTDOUTr, EXECSTDOUTw);
8398 pipe(EXECSTDERRr, EXECSTDERRw);
8399 my $pid;
8400 if (!($pid = fork())) {
8401         untie(*STDIN);
8402         untie(*STDOUT);
8403         untie(*STDERR);
8404         open(STDIN, "<&EXECSTDINr");
8405         open(STDOUT, ">&EXECSTDOUTw");
8406         if (ref($stderr) && $stderr eq $stdout) {
8407                 open(STDERR, ">&EXECSTDOUTw");
8408                 }
8409         else {
8410                 open(STDERR, ">&EXECSTDERRw");
8411                 }
8412         $| = 1;
8413         close(EXECSTDINw);
8414         close(EXECSTDOUTr);
8415         close(EXECSTDERRr);
8416
8417         my $fullcmd = "($cmd)";
8418         if ($stdin && !ref($stdin)) {
8419                 $fullcmd .= " <$stdin";
8420                 }
8421         if ($stdout && !ref($stdout)) {
8422                 $fullcmd .= " >$stdout";
8423                 }
8424         if ($stderr && !ref($stderr)) {
8425                 if ($stderr eq $stdout) {
8426                         $fullcmd .= " 2>&1";
8427                         }
8428                 else {
8429                         $fullcmd .= " 2>$stderr";
8430                         }
8431                 }
8432         if ($gconfig{'os_type'} eq 'windows') {
8433                 exec($fullcmd);
8434                 }
8435         else {
8436                 exec("/bin/sh", "-c", $fullcmd);
8437                 }
8438         print "Exec failed : $!\n";
8439         exit(1);
8440         }
8441 close(EXECSTDINr);
8442 close(EXECSTDOUTw);
8443 close(EXECSTDERRw);
8444
8445 # Feed input and capture output
8446 local $_;
8447 if ($stdin && ref($stdin)) {
8448         print EXECSTDINw $$stdin;
8449         close(EXECSTDINw);
8450         }
8451 if ($stdout && ref($stdout)) {
8452         $$stdout = undef;
8453         while(<EXECSTDOUTr>) {
8454                 $$stdout .= $_;
8455                 }
8456         close(EXECSTDOUTr);
8457         }
8458 if ($stderr && ref($stderr) && $stderr ne $stdout) {
8459         $$stderr = undef;
8460         while(<EXECSTDERRr>) {
8461                 $$stderr .= $_;
8462                 }
8463         close(EXECSTDERRr);
8464         }
8465
8466 # Get exit status
8467 waitpid($pid, 0);
8468 return $?;
8469 }
8470
8471 =head2 open_readfile(handle, file)
8472
8473 Opens some file for reading. Returns 1 on success, 0 on failure. Pretty much
8474 exactly the same as Perl's open function.
8475
8476 =cut
8477 sub open_readfile
8478 {
8479 my ($fh, $file) = @_;
8480 $fh = &callers_package($fh);
8481 my $realfile = &translate_filename($file);
8482 &webmin_debug_log('READ', $file) if ($gconfig{'debug_what_read'});
8483 return open($fh, "<".$realfile);
8484 }
8485
8486 =head2 open_execute_command(handle, command, output?, safe?)
8487
8488 Runs some command, with the specified file handle set to either write to it if
8489 in-or-out is set to 0, or read to it if output is set to 1. The safe flag
8490 indicates if the command modifies the state of the system or not.
8491
8492 =cut
8493 sub open_execute_command
8494 {
8495 my ($fh, $cmd, $mode, $safe) = @_;
8496 $fh = &callers_package($fh);
8497 my $realcmd = &translate_command($cmd);
8498 if (&is_readonly_mode() && !$safe) {
8499         # Don't actually run it
8500         print STDERR "vetoing command $cmd\n";
8501         $? = 0;
8502         if ($mode == 0) {
8503                 return open($fh, ">$null_file");
8504                 }
8505         else {
8506                 return open($fh, $null_file);
8507                 }
8508         }
8509 # Really run it
8510 &webmin_debug_log('CMD', "cmd=$realcmd mode=$mode")
8511         if ($gconfig{'debug_what_cmd'});
8512 if ($mode == 0) {
8513         return open($fh, "| $cmd");
8514         }
8515 elsif ($mode == 1) {
8516         return open($fh, "$cmd 2>$null_file |");
8517         }
8518 elsif ($mode == 2) {
8519         return open($fh, "$cmd 2>&1 |");
8520         }
8521 }
8522
8523 =head2 translate_filename(filename)
8524
8525 Applies all relevant registered translation functions to a filename. Mostly
8526 for internal use, and typically does nothing.
8527
8528 =cut
8529 sub translate_filename
8530 {
8531 my ($realfile) = @_;
8532 my @funcs = grep { $_->[0] eq &get_module_name() ||
8533                    !defined($_->[0]) } @main::filename_callbacks;
8534 foreach my $f (@funcs) {
8535         my $func = $f->[1];
8536         $realfile = &$func($realfile, @{$f->[2]});
8537         }
8538 return $realfile;
8539 }
8540
8541 =head2 translate_command(filename)
8542
8543 Applies all relevant registered translation functions to a command. Mostly
8544 for internal use, and typically does nothing.
8545
8546 =cut
8547 sub translate_command
8548 {
8549 my ($realcmd) = @_;
8550 my @funcs = grep { $_->[0] eq &get_module_name() ||
8551                    !defined($_->[0]) } @main::command_callbacks;
8552 foreach my $f (@funcs) {
8553         my $func = $f->[1];
8554         $realcmd = &$func($realcmd, @{$f->[2]});
8555         }
8556 return $realcmd;
8557 }
8558
8559 =head2 register_filename_callback(module|undef, &function, &args)
8560
8561 Registers some function to be called when the specified module (or all
8562 modules) tries to open a file for reading and writing. The function must
8563 return the actual file to open. This allows you to override which files
8564 other code actually operates on, via the translate_filename function.
8565
8566 =cut
8567 sub register_filename_callback
8568 {
8569 my ($mod, $func, $args) = @_;
8570 push(@main::filename_callbacks, [ $mod, $func, $args ]);
8571 }
8572
8573 =head2 register_command_callback(module|undef, &function, &args)
8574
8575 Registers some function to be called when the specified module (or all
8576 modules) tries to execute a command. The function must return the actual
8577 command to run. This allows you to override which commands other other code
8578 actually runs, via the translate_command function.
8579
8580 =cut
8581 sub register_command_callback
8582 {
8583 my ($mod, $func, $args) = @_;
8584 push(@main::command_callbacks, [ $mod, $func, $args ]);
8585 }
8586
8587 =head2 capture_function_output(&function, arg, ...)
8588
8589 Captures output that some function prints to STDOUT, and returns it. Useful
8590 for functions outside your control that print data when you really want to
8591 manipulate it before output.
8592
8593 =cut
8594 sub capture_function_output
8595 {
8596 my ($func, @args) = @_;
8597 socketpair(SOCKET2, SOCKET1, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
8598 my $old = select(SOCKET1);
8599 my @rv = &$func(@args);
8600 select($old);
8601 close(SOCKET1);
8602 my $out;
8603 local $_;
8604 while(<SOCKET2>) {
8605         $out .= $_;
8606         }
8607 close(SOCKET2);
8608 return wantarray ? ($out, \@rv) : $out;
8609 }
8610
8611 =head2 capture_function_output_tempfile(&function, arg, ...)
8612
8613 Behaves the same as capture_function_output, but uses a temporary file
8614 to avoid buffer full problems.
8615
8616 =cut
8617 sub capture_function_output_tempfile
8618 {
8619 my ($func, @args) = @_;
8620 my $temp = &transname();
8621 open(BUFFER, ">$temp");
8622 my $old = select(BUFFER);
8623 my @rv = &$func(@args);
8624 select($old);
8625 close(BUFFER);
8626 my $out = &read_file_contents($temp);
8627 &unlink_file($temp);
8628 return wantarray ? ($out, \@rv) : $out;
8629 }
8630
8631 =head2 modules_chooser_button(field, multiple, [form])
8632
8633 Returns HTML for a button for selecting one or many Webmin modules.
8634 field - Name of the HTML field to place the module names into.
8635 multiple - Set to 1 if multiple modules can be selected.
8636 form - Index of the form on the page.
8637
8638 =cut
8639 sub modules_chooser_button
8640 {
8641 return &theme_modules_chooser_button(@_)
8642         if (defined(&theme_modules_chooser_button));
8643 my $form = defined($_[2]) ? $_[2] : 0;
8644 my $w = $_[1] ? 700 : 500;
8645 my $h = 200;
8646 if ($_[1] && $gconfig{'db_sizemodules'}) {
8647         ($w, $h) = split(/x/, $gconfig{'db_sizemodules'});
8648         }
8649 elsif (!$_[1] && $gconfig{'db_sizemodule'}) {
8650         ($w, $h) = split(/x/, $gconfig{'db_sizemodule'});
8651         }
8652 return "<input type=button onClick='ifield = document.forms[$form].$_[0]; chooser = window.open(\"$gconfig{'webprefix'}/module_chooser.cgi?multi=$_[1]&module=\"+escape(ifield.value), \"chooser\", \"toolbar=no,menubar=no,scrollbars=yes,width=$w,height=$h\"); chooser.ifield = ifield; window.ifield = ifield' value=\"...\">\n";
8653 }
8654
8655 =head2 substitute_template(text, &hash)
8656
8657 Given some text and a hash reference, for each ocurrance of $FOO or ${FOO} in
8658 the text replaces it with the value of the hash key foo. Also supports blocks
8659 like ${IF-FOO} ... ${ENDIF-FOO}, whose contents are only included if foo is
8660 non-zero, and ${IF-FOO} ... ${ELSE-FOO} ... ${ENDIF-FOO}.
8661
8662 =cut
8663 sub substitute_template
8664 {
8665 # Add some extra fixed parameters to the hash
8666 my %hash = %{$_[1]};
8667 $hash{'hostname'} = &get_system_hostname();
8668 $hash{'webmin_config'} = $config_directory;
8669 $hash{'webmin_etc'} = $config_directory;
8670 $hash{'module_config'} = &get_module_variable('$module_config_directory');
8671 $hash{'webmin_var'} = $var_directory;
8672
8673 # Add time-based parameters, for use in DNS
8674 $hash{'current_time'} = time();
8675 my @tm = localtime($hash{'current_time'});
8676 $hash{'current_year'} = $tm[5]+1900;
8677 $hash{'current_month'} = sprintf("%2.2d", $tm[4]+1);
8678 $hash{'current_day'} = sprintf("%2.2d", $tm[3]);
8679 $hash{'current_hour'} = sprintf("%2.2d", $tm[2]);
8680 $hash{'current_minute'} = sprintf("%2.2d", $tm[1]);
8681 $hash{'current_second'} = sprintf("%2.2d", $tm[0]);
8682
8683 # Actually do the substition
8684 my $rv = $_[0];
8685 foreach my $s (keys %hash) {
8686         next if ($s eq '');     # Prevent just $ from being subbed
8687         my $us = uc($s);
8688         my $sv = $hash{$s};
8689         $rv =~ s/\$\{\Q$us\E\}/$sv/g;
8690         $rv =~ s/\$\Q$us\E/$sv/g;
8691         if ($sv) {
8692                 # Replace ${IF}..${ELSE}..${ENDIF} block with first value,
8693                 # and ${IF}..${ENDIF} with value
8694                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/$2/g;
8695                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/$2/g;
8696
8697                 # Replace $IF..$ELSE..$ENDIF block with first value,
8698                 # and $IF..$ENDIF with value
8699                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ELSE-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/$2/g;
8700                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/$2/g;
8701
8702                 # Replace ${IFEQ}..${ENDIFEQ} block with first value if
8703                 # matching, nothing if not
8704                 $rv =~ s/\$\{IFEQ-\Q$us\E-\Q$sv\E\}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-\Q$sv\E\}(\n?)/$2/g;
8705                 $rv =~ s/\$\{IFEQ-\Q$us\E-[^\}]+}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-[^\}]+\}(\n?)//g;
8706
8707                 # Replace $IFEQ..$ENDIFEQ block with first value if
8708                 # matching, nothing if not
8709                 $rv =~ s/\$IFEQ-\Q$us\E-\Q$sv\E(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\Q$sv\E(\n?)/$2/g;
8710                 $rv =~ s/\$IFEQ-\Q$us\E-\S+(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\S+(\n?)//g;
8711                 }
8712         else {
8713                 # Replace ${IF}..${ELSE}..${ENDIF} block with second value,
8714                 # and ${IF}..${ENDIF} with nothing
8715                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/$4/g;
8716                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)//g;
8717
8718                 # Replace $IF..$ELSE..$ENDIF block with second value,
8719                 # and $IF..$ENDIF with nothing
8720                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ELSE-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/$4/g;
8721                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)//g;
8722
8723                 # Replace ${IFEQ}..${ENDIFEQ} block with nothing
8724                 $rv =~ s/\$\{IFEQ-\Q$us\E-[^\}]+}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-[^\}]+\}(\n?)//g;
8725                 $rv =~ s/\$IFEQ-\Q$us\E-\S+(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\S+(\n?)//g;
8726                 }
8727         }
8728
8729 # Now assume any $IF blocks whose variables are not present in the hash
8730 # evaluate to false.
8731 # $IF...$ELSE x $ENDIF => x
8732 $rv =~ s/\$\{IF\-([A-Z]+)\}.*?\$\{ELSE\-\1\}(.*?)\$\{ENDIF\-\1\}/$2/gs;
8733 # $IF...x...$ENDIF => (nothing)
8734 $rv =~ s/\$\{IF\-([A-Z]+)\}.*?\$\{ENDIF\-\1\}//gs;
8735 # ${var} => (nothing)
8736 $rv =~ s/\$\{[A-Z]+\}//g;
8737
8738 return $rv;
8739 }
8740
8741 =head2 running_in_zone
8742
8743 Returns 1 if the current Webmin instance is running in a Solaris zone. Used to
8744 disable module and features that are not appropriate, like those that modify
8745 mounted filesystems.
8746
8747 =cut
8748 sub running_in_zone
8749 {
8750 return 0 if ($gconfig{'os_type'} ne 'solaris' ||
8751              $gconfig{'os_version'} < 10);
8752 my $zn = `zonename 2>$null_file`;
8753 chop($zn);
8754 return $zn && $zn ne "global";
8755 }
8756
8757 =head2 running_in_vserver
8758
8759 Returns 1 if the current Webmin instance is running in a Linux VServer.
8760 Used to disable modules and features that are not appropriate.
8761
8762 =cut
8763 sub running_in_vserver
8764 {
8765 return 0 if ($gconfig{'os_type'} !~ /^\*-linux$/);
8766 my $vserver;
8767 local $_;
8768 open(MTAB, "/etc/mtab");
8769 while(<MTAB>) {
8770         my ($dev, $mp) = split(/\s+/, $_);
8771         if ($mp eq "/" && $dev =~ /^\/dev\/hdv/) {
8772                 $vserver = 1;
8773                 last;
8774                 }
8775         }
8776 close(MTAB);
8777 return $vserver;
8778 }
8779
8780 =head2 running_in_xen
8781
8782 Returns 1 if Webmin is running inside a Xen instance, by looking
8783 at /proc/xen/capabilities.
8784
8785 =cut
8786 sub running_in_xen
8787 {
8788 return 0 if (!-r "/proc/xen/capabilities");
8789 my $cap = &read_file_contents("/proc/xen/capabilities");
8790 return $cap =~ /control_d/ ? 0 : 1;
8791 }
8792
8793 =head2 running_in_openvz
8794
8795 Returns 1 if Webmin is running inside an OpenVZ container, by looking
8796 at /proc/vz/veinfo for a non-zero line.
8797
8798 =cut
8799 sub running_in_openvz
8800 {
8801 return 0 if (!-r "/proc/vz/veinfo");
8802 my $lref = &read_file_lines("/proc/vz/veinfo", 1);
8803 return 0 if (!$lref || !@$lref);
8804 foreach my $l (@$lref) {
8805         $l =~ s/^\s+//;
8806         my @ll = split(/\s+/, $l);
8807         return 0 if ($ll[0] eq '0');
8808         }
8809 return 1;
8810 }
8811
8812 =head2 list_categories(&modules, [include-empty])
8813
8814 Returns a hash mapping category codes to names, including any custom-defined
8815 categories. The modules parameter must be an array ref of module hash objects,
8816 as returned by get_all_module_infos.
8817
8818 =cut
8819 sub list_categories
8820 {
8821 my ($mods, $empty) = @_;
8822 my (%cats, %catnames);
8823 &read_file("$config_directory/webmin.catnames", \%catnames);
8824 foreach my $o (@lang_order_list) {
8825         &read_file("$config_directory/webmin.catnames.$o", \%catnames);
8826         }
8827 if ($empty) {
8828         %cats = %catnames;
8829         }
8830 foreach my $m (@$mods) {
8831         my $c = $m->{'category'};
8832         next if ($cats{$c});
8833         if (defined($catnames{$c})) {
8834                 $cats{$c} = $catnames{$c};
8835                 }
8836         elsif ($text{"category_$c"}) {
8837                 $cats{$c} = $text{"category_$c"};
8838                 }
8839         else {
8840                 # try to get category name from module ..
8841                 my %mtext = &load_language($m->{'dir'});
8842                 if ($mtext{"category_$c"}) {
8843                         $cats{$c} = $mtext{"category_$c"};
8844                         }
8845                 else {
8846                         $c = $m->{'category'} = "";
8847                         $cats{$c} = $text{"category_$c"};
8848                         }
8849                 }
8850         }
8851 return %cats;
8852 }
8853
8854 =head2 is_readonly_mode
8855
8856 Returns 1 if the current user is in read-only mode, and thus all writes
8857 to files and command execution should fail.
8858
8859 =cut
8860 sub is_readonly_mode
8861 {
8862 if (!defined($main::readonly_mode_cache)) {
8863         my %gaccess = &get_module_acl(undef, "");
8864         $main::readonly_mode_cache = $gaccess{'readonly'} ? 1 : 0;
8865         }
8866 return $main::readonly_mode_cache;
8867 }
8868
8869 =head2 command_as_user(user, with-env?, command, ...)
8870
8871 Returns a command to execute some command as the given user, using the
8872 su statement. If on Linux, the /bin/sh shell is forced in case the user
8873 does not have a valid shell. If with-env is set to 1, the -s flag is added
8874 to the su command to read the user's .profile or .bashrc file.
8875
8876 =cut
8877 sub command_as_user
8878 {
8879 my ($user, $env, @args) = @_;
8880 my @uinfo = getpwnam($user);
8881 if ($uinfo[8] ne "/bin/sh" && $uinfo[8] !~ /\/bash$/) {
8882         # User shell doesn't appear to be valid
8883         if ($gconfig{'os_type'} =~ /-linux$/) {
8884                 # Use -s /bin/sh to force it
8885                 $shellarg = " -s /bin/sh";
8886                 }
8887         elsif ($gconfig{'os_type'} eq 'freebsd' ||
8888                $gconfig{'os_type'} eq 'solaris' &&
8889                 $gconfig{'os_version'} >= 11 ||
8890                $gconfig{'os_type'} eq 'macos') {
8891                 # Use -m and force /bin/sh
8892                 @args = ( "/bin/sh", "-c", quotemeta(join(" ", @args)) );
8893                 $shellarg = " -m";
8894                 }
8895         }
8896 my $rv = "su".($env ? " -" : "").$shellarg.
8897          " ".quotemeta($user)." -c ".quotemeta(join(" ", @args));
8898 return $rv;
8899 }
8900
8901 =head2 list_osdn_mirrors(project, file)
8902
8903 This function is now deprecated in favor of letting sourceforge just
8904 redirect to the best mirror, and now just returns their primary download URL.
8905
8906 =cut
8907 sub list_osdn_mirrors
8908 {
8909 my ($project, $file) = @_;
8910 return ( { 'url' => "http://downloads.sourceforge.net/$project/$file",
8911            'default' => 0,
8912            'mirror' => 'downloads' } );
8913 }
8914
8915 =head2 convert_osdn_url(url)
8916
8917 Given a URL like http://osdn.dl.sourceforge.net/sourceforge/project/file.zip
8918 or http://prdownloads.sourceforge.net/project/file.zip , convert it
8919 to a real URL on the sourceforge download redirector.
8920
8921 =cut
8922 sub convert_osdn_url
8923 {
8924 my ($url) = @_;
8925 if ($url =~ /^http:\/\/[^\.]+.dl.sourceforge.net\/sourceforge\/([^\/]+)\/(.*)$/ ||
8926     $url =~ /^http:\/\/prdownloads.sourceforge.net\/([^\/]+)\/(.*)$/) {
8927         # Always use the Sourceforge mail download URL, which does
8928         # a location-based redirect for us
8929         my ($project, $file) = ($1, $2);
8930         $url = "http://prdownloads.sourceforge.net/sourceforge/".
8931                "$project/$file";
8932         return wantarray ? ( $url, 0 ) : $url;
8933         }
8934 else {
8935         # Some other source .. don't change
8936         return wantarray ? ( $url, 2 ) : $url;
8937         }
8938 }
8939
8940 =head2 get_current_dir
8941
8942 Returns the directory the current process is running in.
8943
8944 =cut
8945 sub get_current_dir
8946 {
8947 my $out;
8948 if ($gconfig{'os_type'} eq 'windows') {
8949         # Use cd command
8950         $out = `cd`;
8951         }
8952 else {
8953         # Use pwd command
8954         $out = `pwd`;
8955         $out =~ s/\\/\//g;
8956         }
8957 $out =~ s/\r|\n//g;
8958 return $out;
8959 }
8960
8961 =head2 supports_users
8962
8963 Returns 1 if the current OS supports Unix user concepts and functions like
8964 su , getpw* and so on. This will be true on Linux and other Unixes, but false
8965 on Windows.
8966
8967 =cut
8968 sub supports_users
8969 {
8970 return $gconfig{'os_type'} ne 'windows';
8971 }
8972
8973 =head2 supports_symlinks
8974
8975 Returns 1 if the current OS supports symbolic and hard links. This will not
8976 be the case on Windows.
8977
8978 =cut
8979 sub supports_symlinks
8980 {
8981 return $gconfig{'os_type'} ne 'windows';
8982 }
8983
8984 =head2 quote_path(path)
8985
8986 Returns a path with safe quoting for the current operating system.
8987
8988 =cut
8989 sub quote_path
8990 {
8991 my ($path) = @_;
8992 if ($gconfig{'os_type'} eq 'windows' || $path =~ /^[a-z]:/i) {
8993         # Windows only supports "" style quoting
8994         return "\"$path\"";
8995         }
8996 else {
8997         return quotemeta($path);
8998         }
8999 }
9000
9001 =head2 get_windows_root
9002
9003 Returns the base windows system directory, like c:/windows.
9004
9005 =cut
9006 sub get_windows_root
9007 {
9008 if ($ENV{'SystemRoot'}) {
9009         my $rv = $ENV{'SystemRoot'};
9010         $rv =~ s/\\/\//g;
9011         return $rv;
9012         }
9013 else {
9014         return -d "c:/windows" ? "c:/windows" : "c:/winnt";
9015         }
9016 }
9017
9018 =head2 read_file_contents(file)
9019
9020 Given a filename, returns its complete contents as a string. Effectively
9021 the same as the Perl construct `cat file`.
9022
9023 =cut
9024 sub read_file_contents
9025 {
9026 &open_readfile(FILE, $_[0]) || return undef;
9027 local $/ = undef;
9028 my $rv = <FILE>;
9029 close(FILE);
9030 return $rv;
9031 }
9032
9033 =head2 unix_crypt(password, salt)
9034
9035 Performs Unix encryption on a password, using the built-in crypt function or
9036 the Crypt::UnixCrypt module if the former does not work. The salt parameter
9037 must be either an already-hashed password, or a two-character alpha-numeric
9038 string.
9039
9040 =cut
9041 sub unix_crypt
9042 {
9043 my ($pass, $salt) = @_;
9044 return "" if ($salt !~ /^[a-zA-Z0-9\.\/]{2}/);   # same as real crypt
9045 my $rv = eval "crypt(\$pass, \$salt)";
9046 my $err = $@;
9047 return $rv if ($rv && !$@);
9048 eval "use Crypt::UnixCrypt";
9049 if (!$@) {
9050         return Crypt::UnixCrypt::crypt($pass, $salt);
9051         }
9052 else {
9053         &error("Failed to encrypt password : $err");
9054         }
9055 }
9056
9057 =head2 split_quoted_string(string)
9058
9059 Given a string like I<foo "bar baz" quux>, returns the array :
9060 foo, bar baz, quux
9061
9062 =cut
9063 sub split_quoted_string
9064 {
9065 my ($str) = @_;
9066 my @rv;
9067 while($str =~ /^"([^"]*)"\s*([\000-\377]*)$/ ||
9068       $str =~ /^'([^']*)'\s*([\000-\377]*)$/ ||
9069       $str =~ /^(\S+)\s*([\000-\377]*)$/) {
9070         push(@rv, $1);
9071         $str = $2;
9072         }
9073 return @rv;
9074 }
9075
9076 =head2 write_to_http_cache(url, file|&data)
9077
9078 Updates the Webmin cache with the contents of the given file, possibly also
9079 clearing out old data. Mainly for internal use by http_download.
9080
9081 =cut
9082 sub write_to_http_cache
9083 {
9084 my ($url, $file) = @_;
9085 return 0 if (!$gconfig{'cache_size'});
9086
9087 # Don't cache downloads that look dynamic
9088 if ($url =~ /cgi-bin/ || $url =~ /\?/) {
9089         return 0;
9090         }
9091
9092 # Check if the current module should do caching
9093 if ($gconfig{'cache_mods'} =~ /^\!(.*)$/) {
9094         # Caching all except some modules
9095         my @mods = split(/\s+/, $1);
9096         return 0 if (&indexof(&get_module_name(), @mods) != -1);
9097         }
9098 elsif ($gconfig{'cache_mods'}) {
9099         # Only caching some modules
9100         my @mods = split(/\s+/, $gconfig{'cache_mods'});
9101         return 0 if (&indexof(&get_module_name(), @mods) == -1);
9102         }
9103
9104 # Work out the size
9105 my $size;
9106 if (ref($file)) {
9107         $size = length($$file);
9108         }
9109 else {
9110         my @st = stat($file);
9111         $size = $st[7];
9112         }
9113
9114 if ($size > $gconfig{'cache_size'}) {
9115         # Bigger than the whole cache - so don't save it
9116         return 0;
9117         }
9118 my $cfile = $url;
9119 $cfile =~ s/\//_/g;
9120 $cfile = "$main::http_cache_directory/$cfile";
9121
9122 # See how much we have cached currently, clearing old files
9123 my $total = 0;
9124 mkdir($main::http_cache_directory, 0700) if (!-d $main::http_cache_directory);
9125 opendir(CACHEDIR, $main::http_cache_directory);
9126 foreach my $f (readdir(CACHEDIR)) {
9127         next if ($f eq "." || $f eq "..");
9128         my $path = "$main::http_cache_directory/$f";
9129         my @st = stat($path);
9130         if ($gconfig{'cache_days'} &&
9131             time()-$st[9] > $gconfig{'cache_days'}*24*60*60) {
9132                 # This file is too old .. trash it
9133                 unlink($path);
9134                 }
9135         else {
9136                 $total += $st[7];
9137                 push(@cached, [ $path, $st[7], $st[9] ]);
9138                 }
9139         }
9140 closedir(CACHEDIR);
9141 @cached = sort { $a->[2] <=> $b->[2] } @cached;
9142 while($total+$size > $gconfig{'cache_size'} && @cached) {
9143         # Cache is too big .. delete some files until the new one will fit
9144         unlink($cached[0]->[0]);
9145         $total -= $cached[0]->[1];
9146         shift(@cached);
9147         }
9148
9149 # Finally, write out the new file
9150 if (ref($file)) {
9151         &open_tempfile(CACHEFILE, ">$cfile");
9152         &print_tempfile(CACHEFILE, $$file);
9153         &close_tempfile(CACHEFILE);
9154         }
9155 else {
9156         my ($ok, $err) = &copy_source_dest($file, $cfile);
9157         }
9158
9159 return 1;
9160 }
9161
9162 =head2 check_in_http_cache(url)
9163
9164 If some URL is in the cache and valid, return the filename for it. Mainly
9165 for internal use by http_download.
9166
9167 =cut
9168 sub check_in_http_cache
9169 {
9170 my ($url) = @_;
9171 return undef if (!$gconfig{'cache_size'});
9172
9173 # Check if the current module should do caching
9174 if ($gconfig{'cache_mods'} =~ /^\!(.*)$/) {
9175         # Caching all except some modules
9176         my @mods = split(/\s+/, $1);
9177         return 0 if (&indexof(&get_module_name(), @mods) != -1);
9178         }
9179 elsif ($gconfig{'cache_mods'}) {
9180         # Only caching some modules
9181         my @mods = split(/\s+/, $gconfig{'cache_mods'});
9182         return 0 if (&indexof(&get_module_name(), @mods) == -1);
9183         }
9184
9185 my $cfile = $url;
9186 $cfile =~ s/\//_/g;
9187 $cfile = "$main::http_cache_directory/$cfile";
9188 my @st = stat($cfile);
9189 return undef if (!@st || !$st[7]);
9190 if ($gconfig{'cache_days'} && time()-$st[9] > $gconfig{'cache_days'}*24*60*60) {
9191         # Too old!
9192         unlink($cfile);
9193         return undef;
9194         }
9195 open(TOUCH, ">>$cfile");        # Update the file time, to keep it in the cache
9196 close(TOUCH);
9197 return $cfile;
9198 }
9199
9200 =head2 supports_javascript
9201
9202 Returns 1 if the current browser is assumed to support javascript.
9203
9204 =cut
9205 sub supports_javascript
9206 {
9207 if (defined(&theme_supports_javascript)) {
9208         return &theme_supports_javascript();
9209         }
9210 return $ENV{'MOBILE_DEVICE'} ? 0 : 1;
9211 }
9212
9213 =head2 get_module_name
9214
9215 Returns the name of the Webmin module that called this function. For internal
9216 use only by other API functions.
9217
9218 =cut
9219 sub get_module_name
9220 {
9221 return &get_module_variable('$module_name');
9222 }
9223
9224 =head2 get_module_variable(name, [ref])
9225
9226 Returns the value of some variable which is set in the caller's context, if
9227 using the new WebminCore package. For internal use only.
9228
9229 =cut
9230 sub get_module_variable
9231 {
9232 my ($v, $wantref) = @_;
9233 my $slash = $wantref ? "\\" : "";
9234 my $thispkg = &web_libs_package();
9235 if ($thispkg eq 'WebminCore') {
9236         my ($vt, $vn) = split('', $v, 2);
9237         my $callpkg;
9238         for(my $i=0; ($callpkg) = caller($i); $i++) {
9239                 last if ($callpkg ne $thispkg);
9240                 }
9241         return eval "${slash}${vt}${callpkg}::${vn}";
9242         }
9243 return eval "${slash}${v}";
9244 }
9245
9246 =head2 clear_time_locale()
9247
9248 Temporarily force the locale to C, until reset_time_locale is called. This is
9249 useful if your code is going to call C<strftime> from the POSIX package, and
9250 you want to ensure that the output is in a consistent format.
9251
9252 =cut
9253 sub clear_time_locale
9254 {
9255 if ($main::clear_time_locale_count == 0) {
9256         eval {
9257                 use POSIX;
9258                 $main::clear_time_locale_old = POSIX::setlocale(POSIX::LC_TIME);
9259                 POSIX::setlocale(POSIX::LC_TIME, "C");
9260                 };
9261         }
9262 $main::clear_time_locale_count++;
9263 }
9264
9265 =head2 reset_time_locale()
9266
9267 Revert the locale to whatever it was before clear_time_locale was called
9268
9269 =cut
9270 sub reset_time_locale
9271 {
9272 if ($main::clear_time_locale_count == 1) {
9273         eval {
9274                 POSIX::setlocale(POSIX::LC_TIME, $main::clear_time_locale_old);
9275                 $main::clear_time_locale_old = undef;
9276                 };
9277         }
9278 $main::clear_time_locale_count--;
9279 }
9280
9281 =head2 callers_package(filehandle)
9282
9283 Convert a non-module filehandle like FOO to one qualified with the
9284 caller's caller's package, like fsdump::FOO. For internal use only.
9285
9286 =cut
9287 sub callers_package
9288 {
9289 my ($fh) = @_;
9290 my $callpkg = (caller(1))[0];
9291 my $thispkg = &web_libs_package();
9292 if (!ref($fh) && $fh !~ /::/ &&
9293     $callpkg ne $thispkg && $thispkg eq 'WebminCore') {
9294         $fh = $callpkg."::".$fh;
9295         }
9296 return $fh;
9297 }
9298
9299 =head2 web_libs_package()
9300
9301 Returns the package this code is in. We can't always trust __PACKAGE__. For
9302 internal use only.
9303
9304 =cut
9305 sub web_libs_package
9306 {
9307 if ($called_from_webmin_core) {
9308         return "WebminCore";
9309         }
9310 return __PACKAGE__;
9311 }
9312
9313 =head2 get_userdb_string
9314
9315 Returns the URL-style string for connecting to the users and groups database
9316
9317 =cut
9318 sub get_userdb_string
9319 {
9320 return undef if ($main::no_miniserv_userdb);
9321 my %miniserv;
9322 &get_miniserv_config(\%miniserv);
9323 return $miniserv{'userdb'};
9324 }
9325
9326 =head2 connect_userdb(string)
9327
9328 Returns a handle for talking to a user database - may be a DBI or LDAP handle.
9329 On failure returns an error message string. In an array context, returns the
9330 protocol type too.
9331
9332 =cut
9333 sub connect_userdb
9334 {
9335 my ($str) = @_;
9336 my ($proto, $user, $pass, $host, $prefix, $args) = &split_userdb_string($str);
9337 if ($proto eq "mysql") {
9338         # Connect to MySQL with DBI
9339         my $drh = eval "use DBI; DBI->install_driver('mysql');";
9340         $drh || return $text{'sql_emysqldriver'};
9341         my ($host, $port) = split(/:/, $host);
9342         my $cstr = "database=$prefix;host=$host";
9343         $cstr .= ";port=$port" if ($port);
9344         my $dbh = $drh->connect($cstr, $user, $pass, { });
9345         $dbh || return &text('sql_emysqlconnect', $drh->errstr);
9346         return wantarray ? ($dbh, $proto, $prefix, $args) : $dbh;
9347         }
9348 elsif ($proto eq "postgresql") {
9349         # Connect to PostgreSQL with DBI
9350         my $drh = eval "use DBI; DBI->install_driver('Pg');";
9351         $drh || return $text{'sql_epostgresqldriver'};
9352         my ($host, $port) = split(/:/, $host);
9353         my $cstr = "dbname=$prefix;host=$host";
9354         $cstr .= ";port=$port" if ($port);
9355         my $dbh = $drh->connect($cstr, $user, $pass);
9356         $dbh || return &text('sql_epostgresqlconnect', $drh->errstr);
9357         return wantarray ? ($dbh, $proto, $prefix, $args) : $dbh;
9358         }
9359 elsif ($proto eq "ldap") {
9360         # Connect with perl LDAP module
9361         eval "use Net::LDAP";
9362         $@ && return $text{'sql_eldapdriver'};
9363         my ($host, $port) = split(/:/, $host);
9364         my $scheme = $args->{'scheme'} || 'ldap';
9365         if (!$port) {
9366                 $port = $scheme eq 'ldaps' ? 636 : 389;
9367                 }
9368         my $ldap = Net::LDAP->new($host,
9369                                   port => $port,
9370                                   'scheme' => $scheme);
9371         $ldap || return &text('sql_eldapconnect', $host);
9372         my $mesg;
9373         if ($args->{'tls'}) {
9374                 # Switch to TLS mode
9375                 eval { $mesg = $ldap->start_tls(); };
9376                 if ($@ || !$mesg || $mesg->code) {
9377                         return &text('sql_eldaptls',
9378                             $@ ? $@ : $mesg ? $mesg->error : "Unknown error");
9379                         }
9380                 }
9381         # Login to the server
9382         if ($pass) {
9383                 $mesg = $ldap->bind(dn => $user, password => $pass);
9384                 }
9385         else {
9386                 $mesg = $ldap->bind(dn => $user, anonymous => 1);
9387                 }
9388         if (!$mesg || $mesg->code) {
9389                 return &text('sql_eldaplogin', $user,
9390                              $mesg ? $mesg->error : "Unknown error");
9391                 }
9392         return wantarray ? ($ldap, $proto, $prefix, $args) : $ldap;
9393         }
9394 else {
9395         return "Unknown protocol $proto";
9396         }
9397 }
9398
9399 =head2 disconnect_userdb(string, &handle)
9400
9401 Closes a handle opened by connect_userdb
9402
9403 =cut
9404 sub disconnect_userdb
9405 {
9406 my ($str, $h) = @_;
9407 if ($str =~ /^(mysql|postgresql):/) {
9408         # DBI disconnnect
9409         if (!$h->{'AutoCommit'}) {
9410                 $h->commit();
9411                 }
9412         $h->disconnect();
9413         }
9414 elsif ($str =~ /^ldap:/) {
9415         # LDAP disconnect
9416         $h->unbind();
9417         $h->disconnect();
9418         }
9419 }
9420
9421 =head2 split_userdb_string(string)
9422
9423 Converts a string like mysql://user:pass@host/db into separate parts
9424
9425 =cut
9426 sub split_userdb_string
9427 {
9428 my ($str) = @_;
9429 if ($str =~ /^([a-z]+):\/\/([^:]*):([^\@]*)\@([a-z0-9\.\-\_]+)\/([^\?]+)(\?(.*))?$/) {
9430         my ($proto, $user, $pass, $host, $prefix, $argstr) =
9431                 ($1, $2, $3, $4, $5, $7);
9432         my %args = map { split(/=/, $_, 2) } split(/\&/, $argstr);
9433         return ($proto, $user, $pass, $host, $prefix, \%args);
9434         }
9435 return ( );
9436 }
9437
9438 $done_web_lib_funcs = 1;
9439
9440 1;