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