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