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