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