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]);   # Will be undef for local connection
5423 if (ref($_[0])) {
5424         # Server structure was given
5425         $serv = $_[0];
5426         $serv->{'user'} || $serv->{'id'} == 0 ||
5427                 return &$main::remote_error_handler(
5428                         "No Webmin login set for server");
5429         }
5430 elsif ($_[0]) {
5431         # lookup the server in the webmin servers module if needed
5432         if (!defined(%main::remote_servers_cache)) {
5433                 &foreign_require("servers", "servers-lib.pl");
5434                 foreach $s (&foreign_call("servers", "list_servers")) {
5435                         $main::remote_servers_cache{$s->{'host'}} = $s;
5436                         $main::remote_servers_cache{$s->{'host'}.":".$s->{'port'}} = $s;
5437                         }
5438                 }
5439         $serv = $main::remote_servers_cache{$_[0]};
5440         $serv || return &$main::remote_error_handler(
5441                                 "No Webmin Servers entry for $_[0]");
5442         $serv->{'user'} || return &$main::remote_error_handler(
5443                                 "No login set for server $_[0]");
5444         }
5445
5446 # Work out the username and password
5447 my ($user, $pass);
5448 if ($serv->{'sameuser'}) {
5449         $user = $remote_user;
5450         defined($main::remote_pass) || return &$main::remote_error_handler(
5451                                    "Password for this server is not available");
5452         $pass = $main::remote_pass;
5453         }
5454 else {
5455         $user = $serv->{'user'};
5456         $pass = $serv->{'pass'};
5457         }
5458
5459 if ($serv->{'fast'} || !$sn) {
5460         # Make TCP connection call to fastrpc.cgi
5461         if (!$fast_fh_cache{$sn} && $sn) {
5462                 # Need to open the connection
5463                 my $con = &make_http_connection(
5464                         $serv->{'host'}, $serv->{'port'}, $serv->{'ssl'},
5465                         "POST", "/fastrpc.cgi");
5466                 return &$main::remote_error_handler(
5467                     "Failed to connect to $serv->{'host'} : $con")
5468                         if (!ref($con));
5469                 &write_http_connection($con, "Host: $serv->{'host'}\r\n");
5470                 &write_http_connection($con, "User-agent: Webmin\r\n");
5471                 my $auth = &encode_base64("$user:$pass");
5472                 $auth =~ tr/\n//d;
5473                 &write_http_connection($con, "Authorization: basic $auth\r\n");
5474                 &write_http_connection($con, "Content-length: ",
5475                                              length($tostr),"\r\n");
5476                 &write_http_connection($con, "\r\n");
5477                 &write_http_connection($con, $tostr);
5478
5479                 # read back the response
5480                 my $line = &read_http_connection($con);
5481                 $line =~ tr/\r\n//d;
5482                 if ($line =~ /^HTTP\/1\..\s+401\s+/) {
5483                         return &$main::remote_error_handler("Login to RPC server as $user rejected");
5484                         }
5485                 $line =~ /^HTTP\/1\..\s+200\s+/ ||
5486                         return &$main::remote_error_handler("HTTP error : $line");
5487                 do {
5488                         $line = &read_http_connection($con);
5489                         $line =~ tr/\r\n//d;
5490                         } while($line);
5491                 $line = &read_http_connection($con);
5492                 if ($line =~ /^0\s+(.*)/) {
5493                         return &$main::remote_error_handler("RPC error : $1");
5494                         }
5495                 elsif ($line =~ /^1\s+(\S+)\s+(\S+)\s+(\S+)/ ||
5496                        $line =~ /^1\s+(\S+)\s+(\S+)/) {
5497                         # Started ok .. connect and save SID
5498                         &close_http_connection($con);
5499                         my ($port, $sid, $version, $error) = ($1, $2, $3);
5500                         &open_socket($serv->{'host'}, $port, $sid, \$error);
5501                         return &$main::remote_error_handler("Failed to connect to fastrpc.cgi : $error")
5502                                 if ($error);
5503                         $fast_fh_cache{$sn} = $sid;
5504                         $remote_server_version{$sn} = $version;
5505                         }
5506                 else {
5507                         while($stuff = &read_http_connection($con)) {
5508                                 $line .= $stuff;
5509                                 }
5510                         return &$main::remote_error_handler("Bad response from fastrpc.cgi : $line");
5511                         }
5512                 }
5513         elsif (!$fast_fh_cache{$sn}) {
5514                 # Open the connection by running fastrpc.cgi locally
5515                 pipe(RPCOUTr, RPCOUTw);
5516                 if (!fork()) {
5517                         untie(*STDIN);
5518                         untie(*STDOUT);
5519                         open(STDOUT, ">&RPCOUTw");
5520                         close(STDIN);
5521                         close(RPCOUTr);
5522                         $| = 1;
5523                         $ENV{'REQUEST_METHOD'} = 'GET';
5524                         $ENV{'SCRIPT_NAME'} = '/fastrpc.cgi';
5525                         $ENV{'SERVER_ROOT'} ||= $root_directory;
5526                         my %acl;
5527                         if ($base_remote_user ne 'root' &&
5528                             $base_remote_user ne 'admin') {
5529                                 # Need to fake up a login for the CGI!
5530                                 &read_acl(undef, \%acl);
5531                                 $ENV{'BASE_REMOTE_USER'} =
5532                                         $ENV{'REMOTE_USER'} =
5533                                                 $acl{'root'} ? 'root' : 'admin';
5534                                 }
5535                         delete($ENV{'FOREIGN_MODULE_NAME'});
5536                         delete($ENV{'FOREIGN_ROOT_DIRECTORY'});
5537                         chdir($root_directory);
5538                         if (!exec("$root_directory/fastrpc.cgi")) {
5539                                 print "exec failed : $!\n";
5540                                 exit 1;
5541                                 }
5542                         }
5543                 close(RPCOUTw);
5544                 my $line;
5545                 do {
5546                         ($line = <RPCOUTr>) =~ tr/\r\n//d;
5547                         } while($line);
5548                 $line = <RPCOUTr>;
5549                 #close(RPCOUTr);
5550                 if ($line =~ /^0\s+(.*)/) {
5551                         return &$main::remote_error_handler("RPC error : $2");
5552                         }
5553                 elsif ($line =~ /^1\s+(\S+)\s+(\S+)/) {
5554                         # Started ok .. connect and save SID
5555                         close(SOCK);
5556                         my ($port, $sid, $error) = ($1, $2, undef);
5557                         &open_socket("localhost", $port, $sid, \$error);
5558                         return &$main::remote_error_handler("Failed to connect to fastrpc.cgi : $error") if ($error);
5559                         $fast_fh_cache{$sn} = $sid;
5560                         }
5561                 else {
5562                         local $_;
5563                         while(<RPCOUTr>) {
5564                                 $line .= $_;
5565                                 }
5566                         &error("Bad response from fastrpc.cgi : $line");
5567                         }
5568                 }
5569         # Got a connection .. send off the request
5570         my $fh = $fast_fh_cache{$sn};
5571         my $tostr = &serialise_variable($_[1]);
5572         print $fh length($tostr)," $fh\n";
5573         print $fh $tostr;
5574         my $rlen = int(<$fh>);
5575         my ($fromstr, $got);
5576         while(length($fromstr) < $rlen) {
5577                 return &$main::remote_error_handler("Failed to read from fastrpc.cgi")
5578                         if (read($fh, $got, $rlen - length($fromstr)) <= 0);
5579                 $fromstr .= $got;
5580                 }
5581         my $from = &unserialise_variable($fromstr);
5582         if (!$from) {
5583                 return &$main::remote_error_handler("Remote Webmin error");
5584                 }
5585         if (defined($from->{'arv'})) {
5586                 return @{$from->{'arv'}};
5587                 }
5588         else {
5589                 return $from->{'rv'};
5590                 }
5591         }
5592 else {
5593         # Call rpc.cgi on remote server
5594         my $tostr = &serialise_variable($_[1]);
5595         my $error = 0;
5596         my $con = &make_http_connection($serv->{'host'}, $serv->{'port'},
5597                                         $serv->{'ssl'}, "POST", "/rpc.cgi");
5598         return &$main::remote_error_handler("Failed to connect to $serv->{'host'} : $con") if (!ref($con));
5599
5600         &write_http_connection($con, "Host: $serv->{'host'}\r\n");
5601         &write_http_connection($con, "User-agent: Webmin\r\n");
5602         my $auth = &encode_base64("$user:$pass");
5603         $auth =~ tr/\n//d;
5604         &write_http_connection($con, "Authorization: basic $auth\r\n");
5605         &write_http_connection($con, "Content-length: ",length($tostr),"\r\n");
5606         &write_http_connection($con, "\r\n");
5607         &write_http_connection($con, $tostr);
5608
5609         # read back the response
5610         my $line = &read_http_connection($con);
5611         $line =~ tr/\r\n//d;
5612         if ($line =~ /^HTTP\/1\..\s+401\s+/) {
5613                 return &$main::remote_error_handler("Login to RPC server as $user rejected");
5614                 }
5615         $line =~ /^HTTP\/1\..\s+200\s+/ || return &$main::remote_error_handler("RPC HTTP error : $line");
5616         do {
5617                 $line = &read_http_connection($con);
5618                 $line =~ tr/\r\n//d;
5619                 } while($line);
5620         my $fromstr;
5621         while($line = &read_http_connection($con)) {
5622                 $fromstr .= $line;
5623                 }
5624         close(SOCK);
5625         my $from = &unserialise_variable($fromstr);
5626         return &$main::remote_error_handler("Invalid RPC login to $serv->{'host'}") if (!$from->{'status'});
5627         if (defined($from->{'arv'})) {
5628                 return @{$from->{'arv'}};
5629                 }
5630         else {
5631                 return $from->{'rv'};
5632                 }
5633         }
5634 }
5635
5636 =head2 remote_multi_callback(&servers, parallel, &function, arg|&args, &returns, &errors, [module, library])
5637
5638 Executes some function in parallel on multiple servers at once. Fills in
5639 the returns and errors arrays respectively. If the module and library
5640 parameters are given, that module is remotely required on the server first,
5641 to check if it is connectable. The parameters are :
5642
5643 =item servers - A list of Webmin system hash references.
5644
5645 =item parallel - Number of parallel operations to perform.
5646
5647 =item function - Reference to function to call for each system.
5648
5649 =item args - Additional parameters to the function.
5650
5651 =item returns - Array ref to place return values into, in same order as servers.
5652
5653 =item errors - Array ref to place error messages into.
5654
5655 =item module - Optional module to require on the remote system first.
5656
5657 =item library - Optional library to require in the module.
5658
5659 =cut
5660 sub remote_multi_callback
5661 {
5662 my ($servs, $parallel, $func, $args, $rets, $errs, $mod, $lib) = @_;
5663 &remote_error_setup(\&remote_multi_callback_error);
5664
5665 # Call the functions
5666 my $p = 0;
5667 foreach my $g (@$servs) {
5668         my $rh = "READ$p";
5669         my $wh = "WRITE$p";
5670         pipe($rh, $wh);
5671         if (!fork()) {
5672                 close($rh);
5673                 $remote_multi_callback_err = undef;
5674                 if ($mod) {
5675                         # Require the remote lib
5676                         &remote_foreign_require($g->{'host'}, $mod, $lib);
5677                         if ($remote_multi_callback_err) {
5678                                 # Failed .. return error
5679                                 print $wh &serialise_variable(
5680                                         [ undef, $remote_multi_callback_err ]);
5681                                 exit(0);
5682                                 }
5683                         }
5684
5685                 # Call the function
5686                 my $a = ref($args) ? $args->[$p] : $args;
5687                 my $rv = &$func($g, $a);
5688
5689                 # Return the result
5690                 print $wh &serialise_variable(
5691                         [ $rv, $remote_multi_callback_err ]);
5692                 close($wh);
5693                 exit(0);
5694                 }
5695         close($wh);
5696         $p++;
5697         }
5698
5699 # Read back the results
5700 $p = 0;
5701 foreach my $g (@$servs) {
5702         my $rh = "READ$p";
5703         my $line = <$rh>;
5704         if (!$line) {
5705                 $errs->[$p] = "Failed to read response from $g->{'host'}";
5706                 }
5707         else {
5708                 my $rv = &unserialise_variable($line);
5709                 close($rh);
5710                 $rets->[$p] = $rv->[0];
5711                 $errs->[$p] = $rv->[1];
5712                 }
5713         $p++;
5714         }
5715
5716 &remote_error_setup(undef);
5717 }
5718
5719 sub remote_multi_callback_error
5720 {
5721 $remote_multi_callback_err = $_[0];
5722 }
5723
5724 =head2 serialise_variable(variable)
5725
5726 Converts some variable (maybe a scalar, hash ref, array ref or scalar ref)
5727 into a url-encoded string. In the cases of arrays and hashes, it is recursively
5728 called on each member to serialize the entire object.
5729
5730 =cut
5731 sub serialise_variable
5732 {
5733 if (!defined($_[0])) {
5734         return 'UNDEF';
5735         }
5736 my $r = ref($_[0]);
5737 my $rv;
5738 if (!$r) {
5739         $rv = &urlize($_[0]);
5740         }
5741 elsif ($r eq 'SCALAR') {
5742         $rv = &urlize(${$_[0]});
5743         }
5744 elsif ($r eq 'ARRAY') {
5745         $rv = join(",", map { &urlize(&serialise_variable($_)) } @{$_[0]});
5746         }
5747 elsif ($r eq 'HASH') {
5748         $rv = join(",", map { &urlize(&serialise_variable($_)).",".
5749                               &urlize(&serialise_variable($_[0]->{$_})) }
5750                             keys %{$_[0]});
5751         }
5752 elsif ($r eq 'REF') {
5753         $rv = &serialise_variable(${$_[0]});
5754         }
5755 elsif ($r eq 'CODE') {
5756         # Code not handled
5757         $rv = undef;
5758         }
5759 elsif ($r) {
5760         # An object - treat as a hash
5761         $r = "OBJECT ".&urlize($r);
5762         $rv = join(",", map { &urlize(&serialise_variable($_)).",".
5763                               &urlize(&serialise_variable($_[0]->{$_})) }
5764                             keys %{$_[0]});
5765         }
5766 return ($r ? $r : 'VAL').",".$rv;
5767 }
5768
5769 =head2 unserialise_variable(string)
5770
5771 Converts a string created by serialise_variable() back into the original
5772 scalar, hash ref, array ref or scalar ref. If the original variable was a Perl
5773 object, the same class is used on this system, if available.
5774
5775 =cut
5776 sub unserialise_variable
5777 {
5778 my @v = split(/,/, $_[0]);
5779 my $rv;
5780 if ($v[0] eq 'VAL') {
5781         @v = split(/,/, $_[0], -1);
5782         $rv = &un_urlize($v[1]);
5783         }
5784 elsif ($v[0] eq 'SCALAR') {
5785         local $r = &un_urlize($v[1]);
5786         $rv = \$r;
5787         }
5788 elsif ($v[0] eq 'ARRAY') {
5789         $rv = [ ];
5790         for(my $i=1; $i<@v; $i++) {
5791                 push(@$rv, &unserialise_variable(&un_urlize($v[$i])));
5792                 }
5793         }
5794 elsif ($v[0] eq 'HASH') {
5795         $rv = { };
5796         for(my $i=1; $i<@v; $i+=2) {
5797                 $rv->{&unserialise_variable(&un_urlize($v[$i]))} =
5798                         &unserialise_variable(&un_urlize($v[$i+1]));
5799                 }
5800         }
5801 elsif ($v[0] eq 'REF') {
5802         local $r = &unserialise_variable($v[1]);
5803         $rv = \$r;
5804         }
5805 elsif ($v[0] eq 'UNDEF') {
5806         $rv = undef;
5807         }
5808 elsif ($v[0] =~ /^OBJECT\s+(.*)$/) {
5809         # An object hash that we have to re-bless
5810         my $cls = $1;
5811         $rv = { };
5812         for(my $i=1; $i<@v; $i+=2) {
5813                 $rv->{&unserialise_variable(&un_urlize($v[$i]))} =
5814                         &unserialise_variable(&un_urlize($v[$i+1]));
5815                 }
5816         eval "use $cls";
5817         bless $rv, $cls;
5818         }
5819 return $rv;
5820 }
5821
5822 =head2 other_groups(user)
5823
5824 Returns a list of secondary groups a user is a member of, as a list of
5825 group names.
5826
5827 =cut
5828 sub other_groups
5829 {
5830 my ($user) = @_;
5831 my @rv;
5832 setgrent();
5833 while(my @g = getgrent()) {
5834         my @m = split(/\s+/, $g[3]);
5835         push(@rv, $g[2]) if (&indexof($user, @m) >= 0);
5836         }
5837 endgrent() if ($gconfig{'os_type'} ne 'hpux');
5838 return @rv;
5839 }
5840
5841 =head2 date_chooser_button(dayfield, monthfield, yearfield)
5842
5843 Returns HTML for a button that pops up a data chooser window. The parameters
5844 are :
5845
5846 =item dayfield - Name of the text field to place the day of the month into.
5847
5848 =item monthfield - Name of the select field to select the month of the year in, indexed from 1.
5849
5850 =item yearfield - Name of the text field to place the year into.
5851
5852 =cut
5853 sub date_chooser_button
5854 {
5855 return &theme_date_chooser_button(@_)
5856         if (defined(&theme_date_chooser_button));
5857 my ($w, $h) = (250, 225);
5858 if ($gconfig{'db_sizedate'}) {
5859         ($w, $h) = split(/x/, $gconfig{'db_sizedate'});
5860         }
5861 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";
5862 }
5863
5864 =head2 help_file(module, file)
5865
5866 Returns the path to a module's help file of some name, typically under the
5867 help directory with a .html extension.
5868
5869 =cut
5870 sub help_file
5871 {
5872 my $mdir = &module_root_directory($_[0]);
5873 my $dir = "$mdir/help";
5874 foreach my $o (@lang_order_list) {
5875         my $lang = "$dir/$_[1].$current_lang.html";
5876         return $lang if (-r $lang);
5877         }
5878 return "$dir/$_[1].html";
5879 }
5880
5881 =head2 seed_random
5882
5883 Seeds the random number generator, if not already done in this script. On Linux
5884 this makes use of the current time, process ID and a read from /dev/urandom.
5885 On other systems, only the current time and process ID are used.
5886
5887 =cut
5888 sub seed_random
5889 {
5890 if (!$main::done_seed_random) {
5891         if (open(RANDOM, "/dev/urandom")) {
5892                 my $buf;
5893                 read(RANDOM, $buf, 4);
5894                 close(RANDOM);
5895                 srand(time() ^ $$ ^ $buf);
5896                 }
5897         else {
5898                 srand(time() ^ $$);
5899                 }
5900         $main::done_seed_random = 1;
5901         }
5902 }
5903
5904 =head2 disk_usage_kb(directory)
5905
5906 Returns the number of kB used by some directory and all subdirs. Implemented
5907 by calling the C<du -k> command.
5908
5909 =cut
5910 sub disk_usage_kb
5911 {
5912 my $dir = &translate_filename($_[0]);
5913 my $out;
5914 my $ex = &execute_command("du -sk ".quotemeta($dir), undef, \$out, undef, 0, 1);
5915 if ($ex) {
5916         &execute_command("du -s ".quotemeta($dir), undef, \$out, undef, 0, 1);
5917         }
5918 return $out =~ /^([0-9]+)/ ? $1 : "???";
5919 }
5920
5921 =head2 recursive_disk_usage(directory)
5922
5923 Returns the number of bytes taken up by all files in some directory and all
5924 sub-directories, by summing up their lengths. The disk_usage_kb is more
5925 reflective of reality, as the filesystem typically pads file sizes to 1k or
5926 4k blocks.
5927
5928 =cut
5929 sub recursive_disk_usage
5930 {
5931 my $dir = &translate_filename($_[0]);
5932 if (-l $dir) {
5933         return 0;
5934         }
5935 elsif (!-d $dir) {
5936         my @st = stat($dir);
5937         return $st[7];
5938         }
5939 else {
5940         my $rv = 0;
5941         opendir(DIR, $dir);
5942         my @files = readdir(DIR);
5943         closedir(DIR);
5944         foreach my $f (@files) {
5945                 next if ($f eq "." || $f eq "..");
5946                 $rv += &recursive_disk_usage("$dir/$f");
5947                 }
5948         return $rv;
5949         }
5950 }
5951
5952 =head2 help_search_link(term, [ section, ... ] )
5953
5954 Returns HTML for a link to the man module for searching local and online
5955 docs for various search terms. The term parameter can either be a single
5956 word like 'bind', or a space-separated list of words. This function is typically
5957 used by modules that want to refer users to additional documentation in man
5958 pages or local system doc files.
5959
5960 =cut
5961 sub help_search_link
5962 {
5963 if (&foreign_available("man") && !$tconfig{'nosearch'}) {
5964         my $for = &urlize(shift(@_));
5965         return "<a href='$gconfig{'webprefix'}/man/search.cgi?".
5966                join("&", map { "section=$_" } @_)."&".
5967                "for=$for&exact=1&check=".&get_module_name()."'>".
5968                $text{'helpsearch'}."</a>\n";
5969         }
5970 else {
5971         return "";
5972         }
5973 }
5974
5975 =head2 make_http_connection(host, port, ssl, method, page, [&headers])
5976
5977 Opens a connection to some HTTP server, maybe through a proxy, and returns
5978 a handle object. The handle can then be used to send additional headers
5979 and read back a response. If anything goes wrong, returns an error string.
5980 The parameters are :
5981
5982 =item host - Hostname or IP address of the webserver to connect to.
5983
5984 =item port - HTTP port number to connect to.
5985
5986 =item ssl - Set to 1 to connect in SSL mode.
5987
5988 =item method - HTTP method, like GET or POST.
5989
5990 =item page - Page to request on the webserver, like /foo/index.html
5991
5992 =item headers - Array ref of additional HTTP headers, each of which is a 2-element array ref.
5993
5994 =cut
5995 sub make_http_connection
5996 {
5997 my ($host, $port, $ssl, $method, $page, $headers) = @_;
5998 my $htxt;
5999 if ($headers) {
6000         foreach my $h (@$headers) {
6001                 $htxt .= $h->[0].": ".$h->[1]."\r\n";
6002                 }
6003         $htxt .= "\r\n";
6004         }
6005 if (&is_readonly_mode()) {
6006         return "HTTP connections not allowed in readonly mode";
6007         }
6008 my $rv = { 'fh' => time().$$ };
6009 if ($ssl) {
6010         # Connect using SSL
6011         eval "use Net::SSLeay";
6012         $@ && return $text{'link_essl'};
6013         eval "Net::SSLeay::SSLeay_add_ssl_algorithms()";
6014         eval "Net::SSLeay::load_error_strings()";
6015         $rv->{'ssl_ctx'} = Net::SSLeay::CTX_new() ||
6016                 return "Failed to create SSL context";
6017         $rv->{'ssl_con'} = Net::SSLeay::new($rv->{'ssl_ctx'}) ||
6018                 return "Failed to create SSL connection";
6019         my $connected;
6020         if ($gconfig{'http_proxy'} =~ /^http:\/\/(\S+):(\d+)/ &&
6021             !&no_proxy($host)) {
6022                 # Via proxy
6023                 my $error;
6024                 &open_socket($1, $2, $rv->{'fh'}, \$error);
6025                 if (!$error) {
6026                         # Connected OK
6027                         my $fh = $rv->{'fh'};
6028                         print $fh "CONNECT $host:$port HTTP/1.0\r\n";
6029                         if ($gconfig{'proxy_user'}) {
6030                                 my $auth = &encode_base64(
6031                                    "$gconfig{'proxy_user'}:".
6032                                    "$gconfig{'proxy_pass'}");
6033                                 $auth =~ tr/\r\n//d;
6034                                 print $fh "Proxy-Authorization: Basic $auth\r\n";
6035                                 }
6036                         print $fh "\r\n";
6037                         my $line = <$fh>;
6038                         if ($line =~ /^HTTP(\S+)\s+(\d+)\s+(.*)/) {
6039                                 return "Proxy error : $3" if ($2 != 200);
6040                                 }
6041                         else {
6042                                 return "Proxy error : $line";
6043                                 }
6044                         $line = <$fh>;
6045                         $connected = 1;
6046                         }
6047                 elsif (!$gconfig{'proxy_fallback'}) {
6048                         # Connection to proxy failed - give up
6049                         return $error;
6050                         }
6051                 }
6052         if (!$connected) {
6053                 # Direct connection
6054                 my $error;
6055                 &open_socket($host, $port, $rv->{'fh'}, \$error);
6056                 return $error if ($error);
6057                 }
6058         Net::SSLeay::set_fd($rv->{'ssl_con'}, fileno($rv->{'fh'}));
6059         Net::SSLeay::connect($rv->{'ssl_con'}) ||
6060                 return "SSL connect() failed";
6061         my $rtxt = "$method $page HTTP/1.0\r\n".$htxt;
6062         Net::SSLeay::write($rv->{'ssl_con'}, $rtxt);
6063         }
6064 else {
6065         # Plain HTTP request
6066         my $connected;
6067         if ($gconfig{'http_proxy'} =~ /^http:\/\/(\S+):(\d+)/ &&
6068             !&no_proxy($host)) {
6069                 # Via a proxy
6070                 my $error;
6071                 &open_socket($1, $2, $rv->{'fh'}, \$error);
6072                 if (!$error) {
6073                         # Connected OK
6074                         $connected = 1;
6075                         my $fh = $rv->{'fh'};
6076                         my $rtxt = $method." ".
6077                                    "http://$host:$port$page HTTP/1.0\r\n";
6078                         if ($gconfig{'proxy_user'}) {
6079                                 my $auth = &encode_base64(
6080                                    "$gconfig{'proxy_user'}:".
6081                                    "$gconfig{'proxy_pass'}");
6082                                 $auth =~ tr/\r\n//d;
6083                                 $rtxt .= "Proxy-Authorization: Basic $auth\r\n";
6084                                 }
6085                         $rtxt .= $htxt;
6086                         print $fh $rtxt;
6087                         }
6088                 elsif (!$gconfig{'proxy_fallback'}) {
6089                         return $error;
6090                         }
6091                 }
6092         if (!$connected) {
6093                 # Connecting directly
6094                 my $error;
6095                 &open_socket($host, $port, $rv->{'fh'}, \$error);
6096                 return $error if ($error);
6097                 my $fh = $rv->{'fh'};
6098                 my $rtxt = "$method $page HTTP/1.0\r\n".$htxt;
6099                 print $fh $rtxt;
6100                 }
6101         }
6102 return $rv;
6103 }
6104
6105 =head2 read_http_connection(&handle, [bytes])
6106
6107 Reads either one line or up to the specified number of bytes from the handle,
6108 originally supplied by make_http_connection.
6109
6110 =cut
6111 sub read_http_connection
6112 {
6113 my ($h) = @_;
6114 my $rv;
6115 if ($h->{'ssl_con'}) {
6116         if (!$_[1]) {
6117                 my ($idx, $more);
6118                 while(($idx = index($h->{'buffer'}, "\n")) < 0) {
6119                         # need to read more..
6120                         if (!($more = Net::SSLeay::read($h->{'ssl_con'}))) {
6121                                 # end of the data
6122                                 $rv = $h->{'buffer'};
6123                                 delete($h->{'buffer'});
6124                                 return $rv;
6125                                 }
6126                         $h->{'buffer'} .= $more;
6127                         }
6128                 $rv = substr($h->{'buffer'}, 0, $idx+1);
6129                 $h->{'buffer'} = substr($h->{'buffer'}, $idx+1);
6130                 }
6131         else {
6132                 if (length($h->{'buffer'})) {
6133                         $rv = $h->{'buffer'};
6134                         delete($h->{'buffer'});
6135                         }
6136                 else {
6137                         $rv = Net::SSLeay::read($h->{'ssl_con'}, $_[1]);
6138                         }
6139                 }
6140         }
6141 else {
6142         if ($_[1]) {
6143                 read($h->{'fh'}, $rv, $_[1]) > 0 || return undef;
6144                 }
6145         else {
6146                 my $fh = $h->{'fh'};
6147                 $rv = <$fh>;
6148                 }
6149         }
6150 $rv = undef if ($rv eq "");
6151 return $rv;
6152 }
6153
6154 =head2 write_http_connection(&handle, [data+])
6155
6156 Writes the given data to the given HTTP connection handle.
6157
6158 =cut
6159 sub write_http_connection
6160 {
6161 my $h = shift(@_);
6162 my $fh = $h->{'fh'};
6163 my $allok = 1;
6164 if ($h->{'ssl_ctx'}) {
6165         foreach my $s (@_) {
6166                 my $ok = Net::SSLeay::write($h->{'ssl_con'}, $s);
6167                 $allok = 0 if (!$ok);
6168                 }
6169         }
6170 else {
6171         my $ok = (print $fh @_);
6172         $allok = 0 if (!$ok);
6173         }
6174 return $allok;
6175 }
6176
6177 =head2 close_http_connection(&handle)
6178
6179 Closes a connection to an HTTP server, identified by the given handle.
6180
6181 =cut
6182 sub close_http_connection
6183 {
6184 close($h->{'fh'});
6185 }
6186
6187 =head2 clean_environment
6188
6189 Deletes any environment variables inherited from miniserv so that they
6190 won't be passed to programs started by webmin. This is useful when calling
6191 programs that check for CGI-related environment variables and modify their
6192 behaviour, and to avoid passing sensitive variables to un-trusted programs.
6193
6194 =cut
6195 sub clean_environment
6196 {
6197 %UNCLEAN_ENV = %ENV;
6198 foreach my $k (keys %ENV) {
6199         if ($k =~ /^(HTTP|VIRTUALSERVER|QUOTA|USERADMIN)_/) {
6200                 delete($ENV{$k});
6201                 }
6202         }
6203 foreach my $e ('WEBMIN_CONFIG', 'SERVER_NAME', 'CONTENT_TYPE', 'REQUEST_URI',
6204             'PATH_INFO', 'WEBMIN_VAR', 'REQUEST_METHOD', 'GATEWAY_INTERFACE',
6205             'QUERY_STRING', 'REMOTE_USER', 'SERVER_SOFTWARE', 'SERVER_PROTOCOL',
6206             'REMOTE_HOST', 'SERVER_PORT', 'DOCUMENT_ROOT', 'SERVER_ROOT',
6207             'MINISERV_CONFIG', 'SCRIPT_NAME', 'SERVER_ADMIN', 'CONTENT_LENGTH',
6208             'HTTPS', 'FOREIGN_MODULE_NAME', 'FOREIGN_ROOT_DIRECTORY',
6209             'SCRIPT_FILENAME', 'PATH_TRANSLATED', 'BASE_REMOTE_USER',
6210             'DOCUMENT_REALROOT', 'MINISERV_CONFIG', 'MYSQL_PWD') {
6211         delete($ENV{$e});
6212         }
6213 }
6214
6215 =head2 reset_environment
6216
6217 Puts the environment back how it was before clean_environment was callled.
6218
6219 =cut
6220 sub reset_environment
6221 {
6222 if (defined(%UNCLEAN_ENV)) {
6223         foreach my $k (keys %UNCLEAN_ENV) {
6224                 $ENV{$k} = $UNCLEAN_ENV{$k};
6225                 }
6226         undef(%UNCLEAN_ENV);
6227         }
6228 }
6229
6230 =head2 progress_callback
6231
6232 Never called directly, but useful for passing to &http_download to print
6233 out progress of an HTTP request.
6234
6235 =cut
6236 sub progress_callback
6237 {
6238 if (defined(&theme_progress_callback)) {
6239         # Call the theme override
6240         return &theme_progress_callback(@_);
6241         }
6242 if ($_[0] == 2) {
6243         # Got size
6244         print $progress_callback_prefix;
6245         if ($_[1]) {
6246                 $progress_size = $_[1];
6247                 $progress_step = int($_[1] / 10);
6248                 print &text('progress_size', $progress_callback_url,
6249                             $progress_size),"<br>\n";
6250                 }
6251         else {
6252                 print &text('progress_nosize', $progress_callback_url),"<br>\n";
6253                 }
6254         $last_progress_time = $last_progress_size = undef;
6255         }
6256 elsif ($_[0] == 3) {
6257         # Got data update
6258         my $sp = $progress_callback_prefix.("&nbsp;" x 5);
6259         if ($progress_size) {
6260                 # And we have a size to compare against
6261                 my $st = int(($_[1] * 10) / $progress_size);
6262                 my $time_now = time();
6263                 if ($st != $progress_step ||
6264                     $time_now - $last_progress_time > 60) {
6265                         # Show progress every 10% or 60 seconds
6266                         print $sp,&text('progress_data', $_[1], int($_[1]*100/$progress_size)),"<br>\n";
6267                         $last_progress_time = $time_now;
6268                         }
6269                 $progress_step = $st;
6270                 }
6271         else {
6272                 # No total size .. so only show in 100k jumps
6273                 if ($_[1] > $last_progress_size+100*1024) {
6274                         print $sp,&text('progress_data2', $_[1]),"<br>\n";
6275                         $last_progress_size = $_[1];
6276                         }
6277                 }
6278         }
6279 elsif ($_[0] == 4) {
6280         # All done downloading
6281         print $progress_callback_prefix,&text('progress_done'),"<br>\n";
6282         }
6283 elsif ($_[0] == 5) {
6284         # Got new location after redirect
6285         $progress_callback_url = $_[1];
6286         }
6287 elsif ($_[0] == 6) {
6288         # URL is in cache
6289         $progress_callback_url = $_[1];
6290         print &text('progress_incache', $progress_callback_url),"<br>\n";
6291         }
6292 }
6293
6294 =head2 switch_to_remote_user
6295
6296 Changes the user and group of the current process to that of the unix user
6297 with the same name as the current webmin login, or fails if there is none.
6298 This should be called by Usermin module scripts that only need to run with
6299 limited permissions.
6300
6301 =cut
6302 sub switch_to_remote_user
6303 {
6304 @remote_user_info = $remote_user ? getpwnam($remote_user) :
6305                                    getpwuid($<);
6306 @remote_user_info || &error(&text('switch_remote_euser', $remote_user));
6307 &create_missing_homedir(\@remote_user_info);
6308 if ($< == 0) {
6309         &switch_to_unix_user(\@remote_user_info);
6310         $ENV{'USER'} = $ENV{'LOGNAME'} = $remote_user;
6311         $ENV{'HOME'} = $remote_user_info[7];
6312         }
6313 # Export global variables to caller
6314 if ($main::export_to_caller) {
6315         my ($callpkg) = caller();
6316         eval "\@${callpkg}::remote_user_info = \@remote_user_info";
6317         }
6318 }
6319
6320 =head2 switch_to_unix_user(&user-details)
6321
6322 Switches the current process to the UID and group ID from the given list
6323 of user details, which must be in the format returned by getpwnam.
6324
6325 =cut
6326 sub switch_to_unix_user
6327 {
6328 my ($uinfo) = @_;
6329 if (!defined($uinfo->[0])) {
6330         # No username given, so just use given GID
6331         ($(, $)) = ( $uinfo->[3], "$uinfo->[3] $uinfo->[3]" );
6332         }
6333 else {
6334         # Use all groups from user
6335         ($(, $)) = ( $uinfo->[3],
6336                      "$uinfo->[3] ".join(" ", $uinfo->[3],
6337                                          &other_groups($uinfo->[0])) );
6338         }
6339 eval {
6340         POSIX::setuid($uinfo->[2]);
6341         };
6342 if ($< != $uinfo->[2] || $> != $uinfo->[2]) {
6343         ($>, $<) = ( $uinfo->[2], $uinfo->[2] );
6344         }
6345 }
6346
6347 =head2 eval_as_unix_user(username, &code)
6348
6349 Runs some code fragment with the effective UID and GID switch to that
6350 of the given Unix user, so that file IO takes place with his permissions.
6351
6352 =cut
6353
6354 sub eval_as_unix_user
6355 {
6356 my ($user, $code) = @_;
6357 my @uinfo = getpwnam($user);
6358 defined(@uinfo) || &error("eval_as_unix_user called with invalid user $user");
6359 $) = $uinfo[3]." ".join(" ", $uinfo[3], &other_groups($user));
6360 $> = $uinfo[2];
6361 my @rv;
6362 eval {
6363         local $main::error_must_die = 1;
6364         @rv = &$code();
6365         };
6366 my $err = $@;
6367 $) = 0;
6368 $> = 0;
6369 if ($err) {
6370         $err =~ s/\s+at\s+(\/\S+)\s+line\s+(\d+)\.?//;
6371         &error($err);
6372         }
6373 return wantarray ? @rv : $rv[0];
6374 }
6375
6376 =head2 create_user_config_dirs
6377
6378 Creates per-user config directories and sets $user_config_directory and
6379 $user_module_config_directory to them. Also reads per-user module configs
6380 into %userconfig. This should be called by Usermin module scripts that need
6381 to store per-user preferences or other settings.
6382
6383 =cut
6384 sub create_user_config_dirs
6385 {
6386 return if (!$gconfig{'userconfig'});
6387 my @uinfo = @remote_user_info ? @remote_user_info : getpwnam($remote_user);
6388 return if (!@uinfo || !$uinfo[7]);
6389 &create_missing_homedir(\@uinfo);
6390 $user_config_directory = "$uinfo[7]/$gconfig{'userconfig'}";
6391 if (!-d $user_config_directory) {
6392         mkdir($user_config_directory, 0700) ||
6393                 &error("Failed to create $user_config_directory : $!");
6394         if ($< == 0 && $uinfo[2]) {
6395                 chown($uinfo[2], $uinfo[3], $user_config_directory);
6396                 }
6397         }
6398 if (&get_module_name()) {
6399         $user_module_config_directory = $user_config_directory."/".
6400                                         &get_module_name();
6401         if (!-d $user_module_config_directory) {
6402                 mkdir($user_module_config_directory, 0700) ||
6403                         &error("Failed to create $user_module_config_directory : $!");
6404                 if ($< == 0 && $uinfo[2]) {
6405                         chown($uinfo[2], $uinfo[3], $user_config_directory);
6406                         }
6407                 }
6408         undef(%userconfig);
6409         &read_file_cached("$module_root_directory/defaultuconfig",
6410                           \%userconfig);
6411         &read_file_cached("$module_config_directory/uconfig", \%userconfig);
6412         &read_file_cached("$user_module_config_directory/config",
6413                           \%userconfig);
6414         }
6415
6416 # Export global variables to caller
6417 if ($main::export_to_caller) {
6418         my ($callpkg) = caller();
6419         foreach my $v ('$user_config_directory',
6420                        '$user_module_config_directory', '%userconfig') {
6421                 my ($vt, $vn) = split('', $v, 2);
6422                 eval "${vt}${callpkg}::${vn} = ${vt}${vn}";
6423                 }
6424         }
6425 }
6426
6427 =head2 create_missing_homedir(&uinfo)
6428
6429 If auto homedir creation is enabled, create one for this user if needed.
6430 For internal use only.
6431
6432 =cut
6433 sub create_missing_homedir
6434 {
6435 my ($uinfo) = @_;
6436 if (!-e $uinfo->[7] && $gconfig{'create_homedir'}) {
6437         # Use has no home dir .. make one
6438         system("mkdir -p ".quotemeta($uinfo->[7]));
6439         chown($uinfo->[2], $uinfo->[3], $uinfo->[7]);
6440         if ($gconfig{'create_homedir_perms'} ne '') {
6441                 chmod(oct($gconfig{'create_homedir_perms'}), $uinfo->[7]);
6442                 }
6443         }
6444 }
6445
6446 =head2 filter_javascript(text)
6447
6448 Disables all javascript <script>, onClick= and so on tags in the given HTML,
6449 and returns the new HTML. Useful for displaying HTML from an un-trusted source.
6450
6451 =cut
6452 sub filter_javascript
6453 {
6454 my ($rv) = @_;
6455 $rv =~ s/<\s*script[^>]*>([\000-\377]*?)<\s*\/script\s*>//gi;
6456 $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;
6457 $rv =~ s/(javascript:)/x$1/gi;
6458 $rv =~ s/(vbscript:)/x$1/gi;
6459 return $rv;
6460 }
6461
6462 =head2 resolve_links(path)
6463
6464 Given a path that may contain symbolic links, returns the real path.
6465
6466 =cut
6467 sub resolve_links
6468 {
6469 my ($path) = @_;
6470 $path =~ s/\/+/\//g;
6471 $path =~ s/\/$// if ($path ne "/");
6472 my @p = split(/\/+/, $path);
6473 shift(@p);
6474 for(my $i=0; $i<@p; $i++) {
6475         my $sofar = "/".join("/", @p[0..$i]);
6476         my $lnk = readlink($sofar);
6477         if ($lnk =~ /^\//) {
6478                 # Link is absolute..
6479                 return &resolve_links($lnk."/".join("/", @p[$i+1 .. $#p]));
6480                 }
6481         elsif ($lnk) {
6482                 # Link is relative
6483                 return &resolve_links("/".join("/", @p[0..$i-1])."/".$lnk."/".join("/", @p[$i+1 .. $#p]));
6484                 }
6485         }
6486 return $path;
6487 }
6488
6489 =head2 simplify_path(path, bogus)
6490
6491 Given a path, maybe containing elements ".." and "." , convert it to a
6492 clean, absolute form. Returns undef if this is not possible.
6493
6494 =cut
6495 sub simplify_path
6496 {
6497 my ($dir) = @_;
6498 $dir =~ s/^\/+//g;
6499 $dir =~ s/\/+$//g;
6500 my @bits = split(/\/+/, $dir);
6501 my @fixedbits = ();
6502 $_[1] = 0;
6503 foreach my $b (@bits) {
6504         if ($b eq ".") {
6505                 # Do nothing..
6506                 }
6507         elsif ($b eq "..") {
6508                 # Remove last dir
6509                 if (scalar(@fixedbits) == 0) {
6510                         # Cannot! Already at root!
6511                         return undef;
6512                         }
6513                 pop(@fixedbits);
6514                 }
6515         else {
6516                 # Add dir to list
6517                 push(@fixedbits, $b);
6518                 }
6519         }
6520 return "/".join('/', @fixedbits);
6521 }
6522
6523 =head2 same_file(file1, file2)
6524
6525 Returns 1 if two files are actually the same
6526
6527 =cut
6528 sub same_file
6529 {
6530 return 1 if ($_[0] eq $_[1]);
6531 return 0 if ($_[0] !~ /^\// || $_[1] !~ /^\//);
6532 my @stat1 = $stat_cache{$_[0]} ? @{$stat_cache{$_[0]}}
6533                                : (@{$stat_cache{$_[0]}} = stat($_[0]));
6534 my @stat2 = $stat_cache{$_[1]} ? @{$stat_cache{$_[1]}}
6535                                : (@{$stat_cache{$_[1]}} = stat($_[1]));
6536 return 0 if (!@stat1 || !@stat2);
6537 return $stat1[0] == $stat2[0] && $stat1[1] == $stat2[1];
6538 }
6539
6540 =head2 flush_webmin_caches
6541
6542 Clears all in-memory and on-disk caches used by Webmin.
6543
6544 =cut
6545 sub flush_webmin_caches
6546 {
6547 undef(%main::read_file_cache);
6548 undef(%main::acl_hash_cache);
6549 undef(%main::acl_array_cache);
6550 undef(%main::has_command_cache);
6551 undef(@main::list_languages_cache);
6552 undef($main::got_list_usermods_cache);
6553 undef(@main::list_usermods_cache);
6554 undef(%main::foreign_installed_cache);
6555 unlink("$config_directory/module.infos.cache");
6556 &get_all_module_infos();
6557 }
6558
6559 =head2 list_usermods
6560
6561 Returns a list of additional module restrictions. For internal use in
6562 Usermin only.
6563
6564 =cut
6565 sub list_usermods
6566 {
6567 if (!$main::got_list_usermods_cache) {
6568         @main::list_usermods_cache = ( );
6569         local $_;
6570         open(USERMODS, "$config_directory/usermin.mods");
6571         while(<USERMODS>) {
6572                 if (/^([^:]+):(\+|-|):(.*)/) {
6573                         push(@main::list_usermods_cache,
6574                              [ $1, $2, [ split(/\s+/, $3) ] ]);
6575                         }
6576                 }
6577         close(USERMODS);
6578         $main::got_list_usermods_cache = 1;
6579         }
6580 return @main::list_usermods_cache;
6581 }
6582
6583 =head2 available_usermods(&allmods, &usermods)
6584
6585 Returns a list of modules that are available to the given user, based
6586 on usermod additional/subtractions. For internal use by Usermin only.
6587
6588 =cut
6589 sub available_usermods
6590 {
6591 return @{$_[0]} if (!@{$_[1]});
6592
6593 my %mods = map { $_->{'dir'}, 1 } @{$_[0]};
6594 my @uinfo = @remote_user_info;
6595 @uinfo = getpwnam($remote_user) if (!@uinfo);
6596 foreach my $u (@{$_[1]}) {
6597         my $applies;
6598         if ($u->[0] eq "*" || $u->[0] eq $remote_user) {
6599                 $applies++;
6600                 }
6601         elsif ($u->[0] =~ /^\@(.*)$/) {
6602                 # Check for group membership
6603                 my @ginfo = getgrnam($1);
6604                 $applies++ if (@ginfo && ($ginfo[2] == $uinfo[3] ||
6605                         &indexof($remote_user, split(/\s+/, $ginfo[3])) >= 0));
6606                 }
6607         elsif ($u->[0] =~ /^\//) {
6608                 # Check users and groups in file
6609                 local $_;
6610                 open(USERFILE, $u->[0]);
6611                 while(<USERFILE>) {
6612                         tr/\r\n//d;
6613                         if ($_ eq $remote_user) {
6614                                 $applies++;
6615                                 }
6616                         elsif (/^\@(.*)$/) {
6617                                 my @ginfo = getgrnam($1);
6618                                 $applies++
6619                                   if (@ginfo && ($ginfo[2] == $uinfo[3] ||
6620                                       &indexof($remote_user,
6621                                                split(/\s+/, $ginfo[3])) >= 0));
6622                                 }
6623                         last if ($applies);
6624                         }
6625                 close(USERFILE);
6626                 }
6627         if ($applies) {
6628                 if ($u->[1] eq "+") {
6629                         map { $mods{$_}++ } @{$u->[2]};
6630                         }
6631                 elsif ($u->[1] eq "-") {
6632                         map { delete($mods{$_}) } @{$u->[2]};
6633                         }
6634                 else {
6635                         undef(%mods);
6636                         map { $mods{$_}++ } @{$u->[2]};
6637                         }
6638                 }
6639         }
6640 return grep { $mods{$_->{'dir'}} } @{$_[0]};
6641 }
6642
6643 =head2 get_available_module_infos(nocache)
6644
6645 Returns a list of modules available to the current user, based on
6646 operating system support, access control and usermod restrictions. Useful
6647 in themes that need to display a list of modules the user can use.
6648 Each element of the returned array is a hash reference in the same format as
6649 returned by get_module_info.
6650
6651 =cut
6652 sub get_available_module_infos
6653 {
6654 my (%acl, %uacl);
6655 &read_acl(\%acl, \%uacl);
6656 my $risk = $gconfig{'risk_'.$base_remote_user};
6657 my @rv;
6658 foreach my $minfo (&get_all_module_infos($_[0])) {
6659         next if (!&check_os_support($minfo));
6660         if ($risk) {
6661                 # Check module risk level
6662                 next if ($risk ne 'high' && $minfo->{'risk'} &&
6663                          $minfo->{'risk'} !~ /$risk/);
6664                 }
6665         else {
6666                 # Check user's ACL
6667                 next if (!$acl{$base_remote_user,$minfo->{'dir'}} &&
6668                          !$acl{$base_remote_user,"*"});
6669                 }
6670         next if (&is_readonly_mode() && !$minfo->{'readonly'});
6671         push(@rv, $minfo);
6672         }
6673
6674 # Check usermod restrictions
6675 my @usermods = &list_usermods();
6676 @rv = sort { $a->{'desc'} cmp $b->{'desc'} }
6677             &available_usermods(\@rv, \@usermods);
6678
6679 # Check RBAC restrictions
6680 my @rbacrv;
6681 foreach my $m (@rv) {
6682         if (&supports_rbac($m->{'dir'}) &&
6683             &use_rbac_module_acl(undef, $m->{'dir'})) {
6684                 local $rbacs = &get_rbac_module_acl($remote_user,
6685                                                     $m->{'dir'});
6686                 if ($rbacs) {
6687                         # RBAC allows
6688                         push(@rbacrv, $m);
6689                         }
6690                 }
6691         else {
6692                 # Module or system doesn't support RBAC
6693                 push(@rbacrv, $m) if (!$gconfig{'rbacdeny_'.$base_remote_user});
6694                 }
6695         }
6696
6697 # Check theme vetos
6698 my @themerv;
6699 if (defined(&theme_foreign_available)) {
6700         foreach my $m (@rbacrv) {
6701                 if (&theme_foreign_available($m->{'dir'})) {
6702                         push(@themerv, $m);
6703                         }
6704                 }
6705         }
6706 else {
6707         @themerv = @rbacrv;
6708         }
6709
6710 # Check licence module vetos
6711 my @licrv;
6712 if ($main::licence_module) {
6713         foreach my $m (@themerv) {
6714                 if (&foreign_call($main::licence_module,
6715                                   "check_module_licence", $m->{'dir'})) {
6716                         push(@licrv, $m);
6717                         }
6718                 }
6719         }
6720 else {
6721         @licrv = @themerv;
6722         }
6723
6724 return @licrv;
6725 }
6726
6727 =head2 get_visible_module_infos(nocache)
6728
6729 Like get_available_module_infos, but excludes hidden modules from the list.
6730 Each element of the returned array is a hash reference in the same format as
6731 returned by get_module_info.
6732
6733 =cut
6734 sub get_visible_module_infos
6735 {
6736 my ($nocache) = @_;
6737 my $pn = &get_product_name();
6738 return grep { !$_->{'hidden'} &&
6739               !$_->{$pn.'_hidden'} } &get_available_module_infos($nocache);
6740 }
6741
6742 =head2 get_visible_modules_categories(nocache)
6743
6744 Returns a list of Webmin module categories, each of which is a hash ref
6745 with 'code', 'desc' and 'modules' keys. The modules value is an array ref
6746 of modules in the category, in the format returned by get_module_info.
6747 Un-used modules are automatically assigned to the 'unused' category, and
6748 those with no category are put into 'others'.
6749
6750 =cut
6751 sub get_visible_modules_categories
6752 {
6753 my ($nocache) = @_;
6754 my @mods = &get_visible_module_infos($nocache);
6755 my @unmods;
6756 if (&get_product_name() eq 'webmin') {
6757         @unmods = grep { $_->{'installed'} eq '0' } @mods;
6758         @mods = grep { $_->{'installed'} ne '0' } @mods;
6759         }
6760 my %cats = &list_categories(\@mods);
6761 my @rv;
6762 foreach my $c (keys %cats) {
6763         my $cat = { 'code' => $c || 'other',
6764                     'desc' => $cats{$c} };
6765         $cat->{'modules'} = [ grep { $_->{'category'} eq $c } @mods ];
6766         push(@rv, $cat);
6767         }
6768 @rv = sort { ($b->{'code'} eq "others" ? "" : $b->{'code'}) cmp
6769              ($a->{'code'} eq "others" ? "" : $a->{'code'}) } @rv;
6770 if (@unmods) {
6771         # Add un-installed modules in magic category
6772         my $cat = { 'code' => 'unused',
6773                     'desc' => $text{'main_unused'},
6774                     'unused' => 1,
6775                     'modules' => \@unmods };
6776         push(@rv, $cat);
6777         }
6778 return @rv;
6779 }
6780
6781 =head2 is_under_directory(directory, file)
6782
6783 Returns 1 if the given file is under the specified directory, 0 if not.
6784 Symlinks are taken into account in the file to find it's 'real' location.
6785
6786 =cut
6787 sub is_under_directory
6788 {
6789 my ($dir, $file) = @_;
6790 return 1 if ($dir eq "/");
6791 return 0 if ($file =~ /\.\./);
6792 my $ld = &resolve_links($dir);
6793 if ($ld ne $dir) {
6794         return &is_under_directory($ld, $file);
6795         }
6796 my $lp = &resolve_links($file);
6797 if ($lp ne $file) {
6798         return &is_under_directory($dir, $lp);
6799         }
6800 return 0 if (length($file) < length($dir));
6801 return 1 if ($dir eq $file);
6802 $dir =~ s/\/*$/\//;
6803 return substr($file, 0, length($dir)) eq $dir;
6804 }
6805
6806 =head2 parse_http_url(url, [basehost, baseport, basepage, basessl])
6807
6808 Given an absolute URL, returns the host, port, page and ssl flag components.
6809 Relative URLs can also be parsed, if the base information is provided.
6810
6811 =cut
6812 sub parse_http_url
6813 {
6814 if ($_[0] =~ /^(http|https):\/\/([^:\/]+)(:(\d+))?(\/\S*)?$/) {
6815         # An absolute URL
6816         my $ssl = $1 eq 'https';
6817         return ($2, $3 ? $4 : $ssl ? 443 : 80, $5 || "/", $ssl);
6818         }
6819 elsif (!$_[1]) {
6820         # Could not parse
6821         return undef;
6822         }
6823 elsif ($_[0] =~ /^\/\S*$/) {
6824         # A relative to the server URL
6825         return ($_[1], $_[2], $_[0], $_[4]);
6826         }
6827 else {
6828         # A relative to the directory URL
6829         my $page = $_[3];
6830         $page =~ s/[^\/]+$//;
6831         return ($_[1], $_[2], $page.$_[0], $_[4]);
6832         }
6833 }
6834
6835 =head2 check_clicks_function
6836
6837 Returns HTML for a JavaScript function called check_clicks that returns
6838 true when first called, but false subsequently. Useful on onClick for
6839 critical buttons. Deprecated, as this method of preventing duplicate actions
6840 is un-reliable.
6841
6842 =cut
6843 sub check_clicks_function
6844 {
6845 return <<EOF;
6846 <script>
6847 clicks = 0;
6848 function check_clicks(form)
6849 {
6850 clicks++;
6851 if (clicks == 1)
6852         return true;
6853 else {
6854         if (form != null) {
6855                 for(i=0; i<form.length; i++)
6856                         form.elements[i].disabled = true;
6857                 }
6858         return false;
6859         }
6860 }
6861 </script>
6862 EOF
6863 }
6864
6865 =head2 load_entities_map
6866
6867 Returns a hash ref containing mappings between HTML entities (like ouml) and
6868 ascii values (like 246). Mainly for internal use.
6869
6870 =cut
6871 sub load_entities_map
6872 {
6873 if (!defined(%entities_map_cache)) {
6874         local $_;
6875         open(EMAP, "$root_directory/entities_map.txt");
6876         while(<EMAP>) {
6877                 if (/^(\d+)\s+(\S+)/) {
6878                         $entities_map_cache{$2} = $1;
6879                         }
6880                 }
6881         close(EMAP);
6882         }
6883 return \%entities_map_cache;
6884 }
6885
6886 =head2 entities_to_ascii(string)
6887
6888 Given a string containing HTML entities like &ouml; and &#55;, replace them
6889 with their ASCII equivalents.
6890
6891 =cut
6892 sub entities_to_ascii
6893 {
6894 my ($str) = @_;
6895 my $emap = &load_entities_map();
6896 $str =~ s/&([a-z]+);/chr($emap->{$1})/ge;
6897 $str =~ s/&#(\d+);/chr($1)/ge;
6898 return $str;
6899 }
6900
6901 =head2 get_product_name
6902
6903 Returns either 'webmin' or 'usermin', depending on which program the current
6904 module is in. Useful for modules that can be installed into either.
6905
6906 =cut
6907 sub get_product_name
6908 {
6909 return $gconfig{'product'} if (defined($gconfig{'product'}));
6910 return defined($gconfig{'userconfig'}) ? 'usermin' : 'webmin';
6911 }
6912
6913 =head2 get_charset
6914
6915 Returns the character set for the current language, such as iso-8859-1.
6916
6917 =cut
6918 sub get_charset
6919 {
6920 my $charset = defined($gconfig{'charset'}) ? $gconfig{'charset'} :
6921                  $current_lang_info->{'charset'} ?
6922                  $current_lang_info->{'charset'} : $default_charset;
6923 return $charset;
6924 }
6925
6926 =head2 get_display_hostname
6927
6928 Returns the system's hostname for UI display purposes. This may be different
6929 from the actual hostname if you administrator has configured it so in the
6930 Webmin Configuration module.
6931
6932 =cut
6933 sub get_display_hostname
6934 {
6935 if ($gconfig{'hostnamemode'} == 0) {
6936         return &get_system_hostname();
6937         }
6938 elsif ($gconfig{'hostnamemode'} == 3) {
6939         return $gconfig{'hostnamedisplay'};
6940         }
6941 else {
6942         my $h = $ENV{'HTTP_HOST'};
6943         $h =~ s/:\d+//g;
6944         if ($gconfig{'hostnamemode'} == 2) {
6945                 $h =~ s/^(www|ftp|mail)\.//i;
6946                 }
6947         return $h;
6948         }
6949 }
6950
6951 =head2 save_module_config([&config], [modulename])
6952
6953 Saves the configuration for some module. The config parameter is an optional
6954 hash reference of names and values to save, which defaults to the global
6955 %config hash. The modulename parameter is the module to update the config
6956 file, which defaults to the current module.
6957
6958 =cut
6959 sub save_module_config
6960 {
6961 my $c = $_[0] || { &get_module_variable('%config') };
6962 my $m = defined($_[1]) ? $_[1] : &get_module_name();
6963 &write_file("$config_directory/$m/config", $c);
6964 }
6965
6966 =head2 save_user_module_config([&config], [modulename])
6967
6968 Saves the user's Usermin preferences for some module. The config parameter is
6969 an optional hash reference of names and values to save, which defaults to the
6970 global %userconfig hash. The modulename parameter is the module to update the
6971 config file, which defaults to the current module.
6972
6973 =cut
6974 sub save_user_module_config
6975 {
6976 my $c = $_[0] || { &get_module_variable('%userconfig') };
6977 my $m = $_[1] || &get_module_name();
6978 my $ucd = $user_config_directory;
6979 if (!$ucd) {
6980         my @uinfo = @remote_user_info ? @remote_user_info
6981                                       : getpwnam($remote_user);
6982         return if (!@uinfo || !$uinfo[7]);
6983         $ucd = "$uinfo[7]/$gconfig{'userconfig'}";
6984         }
6985 &write_file("$ucd/$m/config", $c);
6986 }
6987
6988 =head2 nice_size(bytes, [min])
6989
6990 Converts a number of bytes into a number followed by a suffix like GB, MB
6991 or kB. Rounding is to two decimal digits. The optional min parameter sets the
6992 smallest units to use - so you could pass 1024*1024 to never show bytes or kB.
6993
6994 =cut
6995 sub nice_size
6996 {
6997 my ($units, $uname);
6998 if (abs($_[0]) > 1024*1024*1024*1024 || $_[1] >= 1024*1024*1024*1024) {
6999         $units = 1024*1024*1024*1024;
7000         $uname = "TB";
7001         }
7002 elsif (abs($_[0]) > 1024*1024*1024 || $_[1] >= 1024*1024*1024) {
7003         $units = 1024*1024*1024;
7004         $uname = "GB";
7005         }
7006 elsif (abs($_[0]) > 1024*1024 || $_[1] >= 1024*1024) {
7007         $units = 1024*1024;
7008         $uname = "MB";
7009         }
7010 elsif (abs($_[0]) > 1024 || $_[1] >= 1024) {
7011         $units = 1024;
7012         $uname = "kB";
7013         }
7014 else {
7015         $units = 1;
7016         $uname = "bytes";
7017         }
7018 my $sz = sprintf("%.2f", ($_[0]*1.0 / $units));
7019 $sz =~ s/\.00$//;
7020 return $sz." ".$uname;
7021 }
7022
7023 =head2 get_perl_path
7024
7025 Returns the path to Perl currently in use, such as /usr/bin/perl.
7026
7027 =cut
7028 sub get_perl_path
7029 {
7030 if (open(PERL, "$config_directory/perl-path")) {
7031         my $rv;
7032         chop($rv = <PERL>);
7033         close(PERL);
7034         return $rv;
7035         }
7036 return $^X if (-x $^X);
7037 return &has_command("perl");
7038 }
7039
7040 =head2 get_goto_module([&mods])
7041
7042 Returns the details of a module that the current user should be re-directed
7043 to after logging in, or undef if none. Useful for themes.
7044
7045 =cut
7046 sub get_goto_module
7047 {
7048 my @mods = $_[0] ? @{$_[0]} : &get_visible_module_infos();
7049 if ($gconfig{'gotomodule'}) {
7050         my ($goto) = grep { $_->{'dir'} eq $gconfig{'gotomodule'} } @mods;
7051         return $goto if ($goto);
7052         }
7053 if (@mods == 1 && $gconfig{'gotoone'}) {
7054         return $mods[0];
7055         }
7056 return undef;
7057 }
7058
7059 =head2 select_all_link(field, form, [text])
7060
7061 Returns HTML for a 'Select all' link that uses Javascript to select
7062 multiple checkboxes with the same name. The parameters are :
7063
7064 =item field - Name of the checkbox inputs.
7065
7066 =item form - Index of the form on the page.
7067
7068 =item text - Message for the link, defaulting to 'Select all'.
7069
7070 =cut
7071 sub select_all_link
7072 {
7073 return &theme_select_all_link(@_) if (defined(&theme_select_all_link));
7074 my ($field, $form, $text) = @_;
7075 $form = int($form);
7076 $text ||= $text{'ui_selall'};
7077 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>";
7078 }
7079
7080 =head2 select_invert_link(field, form, text)
7081
7082 Returns HTML for an 'Invert selection' link that uses Javascript to invert the
7083 selection on multiple checkboxes with the same name. The parameters are :
7084
7085 =item field - Name of the checkbox inputs.
7086
7087 =item form - Index of the form on the page.
7088
7089 =item text - Message for the link, defaulting to 'Invert selection'.
7090
7091 =cut
7092 sub select_invert_link
7093 {
7094 return &theme_select_invert_link(@_) if (defined(&theme_select_invert_link));
7095 my ($field, $form, $text) = @_;
7096 $form = int($form);
7097 $text ||= $text{'ui_selinv'};
7098 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>";
7099 }
7100
7101 =head2 select_rows_link(field, form, text, &rows)
7102
7103 Returns HTML for a link that uses Javascript to select rows with particular
7104 values for their checkboxes. The parameters are :
7105
7106 =item field - Name of the checkbox inputs.
7107
7108 =item form - Index of the form on the page.
7109
7110 =item text - Message for the link, de
7111
7112 =item rows - Reference to an array of 1 or 0 values, indicating which rows to check.
7113
7114 =cut
7115 sub select_rows_link
7116 {
7117 return &theme_select_rows_link(@_) if (defined(&theme_select_rows_link));
7118 my ($field, $form, $text, $rows) = @_;
7119 $form = int($form);
7120 my $js = "var sel = { ".join(",", map { "\"".&quote_escape($_)."\":1" } @$rows)." }; ";
7121 $js .= "for(var i=0; i<document.forms[$form].${field}.length; i++) { var r = document.forms[$form].${field}[i]; r.checked = sel[r.value]; } ";
7122 $js .= "return false;";
7123 return "<a href='#' onClick='$js'>$text</a>";
7124 }
7125
7126 =head2 check_pid_file(file)
7127
7128 Given a pid file, returns the PID it contains if the process is running.
7129
7130 =cut
7131 sub check_pid_file
7132 {
7133 open(PIDFILE, $_[0]) || return undef;
7134 my $pid = <PIDFILE>;
7135 close(PIDFILE);
7136 $pid =~ /^\s*(\d+)/ || return undef;
7137 kill(0, $1) || return undef;
7138 return $1;
7139 }
7140
7141 =head2 get_mod_lib
7142
7143 Return the local os-specific library name to this module. For internal use only.
7144
7145 =cut
7146 sub get_mod_lib
7147 {
7148 my $mn = &get_module_name();
7149 my $md = &module_root_directory($mn);
7150 if (-r "$md/$mn-$gconfig{'os_type'}-$gconfig{'os_version'}-lib.pl") {
7151         return "$mn-$gconfig{'os_type'}-$gconfig{'os_version'}-lib.pl";
7152         }
7153 elsif (-r "$md/$mn-$gconfig{'os_type'}-lib.pl") {
7154         return "$mn-$gconfig{'os_type'}-lib.pl";
7155         }
7156 elsif (-r "$md/$mn-generic-lib.pl") {
7157         return "$mn-generic-lib.pl";
7158         }
7159 else {
7160         return "";
7161         }
7162 }
7163
7164 =head2 module_root_directory(module)
7165
7166 Given a module name, returns its root directory. On a typical Webmin install,
7167 all modules are under the same directory - but it is theoretically possible to
7168 have more than one.
7169
7170 =cut
7171 sub module_root_directory
7172 {
7173 my $d = ref($_[0]) ? $_[0]->{'dir'} : $_[0];
7174 if (@root_directories > 1) {
7175         foreach my $r (@root_directories) {
7176                 if (-d "$r/$d") {
7177                         return "$r/$d";
7178                         }
7179                 }
7180         }
7181 return "$root_directories[0]/$d";
7182 }
7183
7184 =head2 list_mime_types
7185
7186 Returns a list of all known MIME types and their extensions, as a list of hash
7187 references with keys :
7188
7189 =item type - The MIME type, like text/plain.
7190
7191 =item exts - A list of extensions, like .doc and .avi.
7192
7193 =item desc - A human-readable description for the MIME type.
7194
7195 =cut
7196 sub list_mime_types
7197 {
7198 if (!@list_mime_types_cache) {
7199         local $_;
7200         open(MIME, "$root_directory/mime.types");
7201         while(<MIME>) {
7202                 my $cmt;
7203                 s/\r|\n//g;
7204                 if (s/#\s*(.*)$//g) {
7205                         $cmt = $1;
7206                         }
7207                 my ($type, @exts) = split(/\s+/);
7208                 if ($type) {
7209                         push(@list_mime_types_cache, { 'type' => $type,
7210                                                        'exts' => \@exts,
7211                                                        'desc' => $cmt });
7212                         }
7213                 }
7214         close(MIME);
7215         }
7216 return @list_mime_types_cache;
7217 }
7218
7219 =head2 guess_mime_type(filename, [default])
7220
7221 Given a file name like xxx.gif or foo.html, returns a guessed MIME type.
7222 The optional default parameter sets a default type of use if none is found,
7223 which defaults to application/octet-stream.
7224
7225 =cut
7226 sub guess_mime_type
7227 {
7228 if ($_[0] =~ /\.([A-Za-z0-9\-]+)$/) {
7229         my $ext = $1;
7230         foreach my $t (&list_mime_types()) {
7231                 foreach my $e (@{$t->{'exts'}}) {
7232                         return $t->{'type'} if (lc($e) eq lc($ext));
7233                         }
7234                 }
7235         }
7236 return @_ > 1 ? $_[1] : "application/octet-stream";
7237 }
7238
7239 =head2 open_tempfile([handle], file, [no-error], [no-tempfile], [safe?])
7240
7241 Opens a file handle for writing to a temporary file, which will only be
7242 renamed over the real file when the handle is closed. This allows critical
7243 files like /etc/shadow to be updated safely, even if writing fails part way
7244 through due to lack of disk space. The parameters are :
7245
7246 =item handle - File handle to open, as you would use in Perl's open function.
7247
7248 =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.
7249
7250 =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.
7251
7252 =item no-tempfile - If set to 1, writing will be direct to the file instead of using a temporary file.
7253
7254 =item safe - Indicates to users in read-only mode that this write is safe and non-destructive.
7255
7256 =cut
7257 sub open_tempfile
7258 {
7259 if (@_ == 1) {
7260         # Just getting a temp file
7261         if (!defined($main::open_tempfiles{$_[0]})) {
7262                 $_[0] =~ /^(.*)\/(.*)$/ || return $_[0];
7263                 my $dir = $1 || "/";
7264                 my $tmp = "$dir/$2.webmintmp.$$";
7265                 $main::open_tempfiles{$_[0]} = $tmp;
7266                 push(@main::temporary_files, $tmp);
7267                 }
7268         return $main::open_tempfiles{$_[0]};
7269         }
7270 else {
7271         # Actually opening
7272         my ($fh, $file, $noerror, $notemp, $safe) = @_;
7273         $fh = &callers_package($fh);
7274
7275         my %gaccess = &get_module_acl(undef, "");
7276         my $db = $gconfig{'debug_what_write'};
7277         if ($file =~ /\r|\n|\0/) {
7278                 if ($noerror) { return 0; }
7279                 else { &error("Filename contains invalid characters"); }
7280                 }
7281         if (&is_readonly_mode() && $file =~ />/ && !$safe) {
7282                 # Read-only mode .. veto all writes
7283                 print STDERR "vetoing write to $file\n";
7284                 return open($fh, ">$null_file");
7285                 }
7286         elsif ($file =~ /^(>|>>|)nul$/i) {
7287                 # Write to Windows null device
7288                 &webmin_debug_log($1 eq ">" ? "WRITE" :
7289                           $l eq ">>" ? "APPEND" : "READ", "nul") if ($db);
7290                 }
7291         elsif ($file =~ /^(>|>>)(\/dev\/.*)/ || lc($file) eq "nul") {
7292                 # Writes to /dev/null or TTYs don't need to be handled
7293                 &webmin_debug_log($1 eq ">" ? "WRITE" : "APPEND", $2) if ($db);
7294                 return open($fh, $file);
7295                 }
7296         elsif ($file =~ /^>\s*(([a-zA-Z]:)?\/.*)$/ && !$notemp) {
7297                 &webmin_debug_log("WRITE", $1) if ($db);
7298                 # Over-writing a file, via a temp file
7299                 $file = $1;
7300                 $file = &translate_filename($file);
7301                 while(-l $file) {
7302                         # Open the link target instead
7303                         $file = &resolve_links($file);
7304                         }
7305                 if (-d $file) {
7306                         # Cannot open a directory!
7307                         if ($noerror) { return 0; }
7308                         else { &error("Cannot write to directory $file"); }
7309                         }
7310                 my $tmp = &open_tempfile($file);
7311                 my $ex = open($fh, ">$tmp");
7312                 if (!$ex && $! =~ /permission/i) {
7313                         # Could not open temp file .. try opening actual file
7314                         # instead directly
7315                         $ex = open($fh, ">$file");
7316                         delete($main::open_tempfiles{$file});
7317                         }
7318                 else {
7319                         $main::open_temphandles{$fh} = $file;
7320                         }
7321                 binmode($fh);
7322                 if (!$ex && !$noerror) {
7323                         &error(&text("efileopen", $file, $!));
7324                         }
7325                 return $ex;
7326                 }
7327         elsif ($file =~ /^>\s*(([a-zA-Z]:)?\/.*)$/ && $notemp) {
7328                 # Just writing direct to a file
7329                 &webmin_debug_log("WRITE", $1) if ($db);
7330                 $file = $1;
7331                 $file = &translate_filename($file);
7332                 my @old_attributes = &get_clear_file_attributes($file);
7333                 my $ex = open($fh, ">$file");
7334                 &reset_file_attributes($file, \@old_attributes);
7335                 $main::open_temphandles{$fh} = $file;
7336                 if (!$ex && !$noerror) {
7337                         &error(&text("efileopen", $file, $!));
7338                         }
7339                 binmode($fh);
7340                 return $ex;
7341                 }
7342         elsif ($file =~ /^>>\s*(([a-zA-Z]:)?\/.*)$/) {
7343                 # Appending to a file .. nothing special to do
7344                 &webmin_debug_log("APPEND", $1) if ($db);
7345                 $file = $1;
7346                 $file = &translate_filename($file);
7347                 my @old_attributes = &get_clear_file_attributes($file);
7348                 my $ex = open($fh, ">>$file");
7349                 &reset_file_attributes($file, \@old_attributes);
7350                 $main::open_temphandles{$fh} = $file;
7351                 if (!$ex && !$noerror) {
7352                         &error(&text("efileopen", $file, $!));
7353                         }
7354                 binmode($fh);
7355                 return $ex;
7356                 }
7357         elsif ($file =~ /^([a-zA-Z]:)?\//) {
7358                 # Read mode .. nothing to do here
7359                 &webmin_debug_log("READ", $file) if ($db);
7360                 $file = &translate_filename($file);
7361                 return open($fh, $file);
7362                 }
7363         elsif ($file eq ">" || $file eq ">>") {
7364                 my ($package, $filename, $line) = caller;
7365                 if ($noerror) { return 0; }
7366                 else { &error("Missing file to open at ${package}::${filename} line $line"); }
7367                 }
7368         else {
7369                 my ($package, $filename, $line) = caller;
7370                 &error("Unsupported file or mode $file at ${package}::${filename} line $line");
7371                 }
7372         }
7373 }
7374
7375 =head2 close_tempfile(file|handle)
7376
7377 Copies a temp file to the actual file, assuming that all writes were
7378 successful. The handle must have been one passed to open_tempfile.
7379
7380 =cut
7381 sub close_tempfile
7382 {
7383 my $file;
7384 my $fh = &callers_package($_[0]);
7385
7386 if (defined($file = $main::open_temphandles{$fh})) {
7387         # Closing a handle
7388         close($fh) || &error(&text("efileclose", $file, $!));
7389         delete($main::open_temphandles{$fh});
7390         return &close_tempfile($file);
7391         }
7392 elsif (defined($main::open_tempfiles{$_[0]})) {
7393         # Closing a file
7394         &webmin_debug_log("CLOSE", $_[0]) if ($gconfig{'debug_what_write'});
7395         my @st = stat($_[0]);
7396         if (&is_selinux_enabled() && &has_command("chcon")) {
7397                 # Set original security context
7398                 system("chcon --reference=".quotemeta($_[0]).
7399                        " ".quotemeta($main::open_tempfiles{$_[0]}).
7400                        " >/dev/null 2>&1");
7401                 }
7402         my @old_attributes = &get_clear_file_attributes($_[0]);
7403         rename($main::open_tempfiles{$_[0]}, $_[0]) || &error("Failed to replace $_[0] with $main::open_tempfiles{$_[0]} : $!");
7404         if (@st) {
7405                 # Set original permissions and ownership
7406                 chmod($st[2], $_[0]);
7407                 chown($st[4], $st[5], $_[0]);
7408                 }
7409         &reset_file_attributes($_[0], \@old_attributes);
7410         delete($main::open_tempfiles{$_[0]});
7411         @main::temporary_files = grep { $_ ne $main::open_tempfiles{$_[0]} } @main::temporary_files;
7412         if ($main::open_templocks{$_[0]}) {
7413                 &unlock_file($_[0]);
7414                 delete($main::open_templocks{$_[0]});
7415                 }
7416         return 1;
7417         }
7418 else {
7419         # Must be closing a handle not associated with a file
7420         close($_[0]);
7421         return 1;
7422         }
7423 }
7424
7425 =head2 print_tempfile(handle, text, ...)
7426
7427 Like the normal print function, but calls &error on failure. Useful when
7428 combined with open_tempfile, to ensure that a criticial file is never
7429 only partially written.
7430
7431 =cut
7432 sub print_tempfile
7433 {
7434 my ($fh, @args) = @_;
7435 $fh = &callers_package($fh);
7436 (print $fh @args) || &error(&text("efilewrite",
7437                             $main::open_temphandles{$fh} || $fh, $!));
7438 }
7439
7440 =head2 is_selinux_enabled
7441
7442 Returns 1 if SElinux is supported on this system and enabled, 0 if not.
7443
7444 =cut
7445 sub is_selinux_enabled
7446 {
7447 if (!defined($main::selinux_enabled_cache)) {
7448         my %seconfig;
7449         if ($gconfig{'os_type'} !~ /-linux$/) {
7450                 # Not on linux, so no way
7451                 $main::selinux_enabled_cache = 0;
7452                 }
7453         elsif (&read_env_file("/etc/selinux/config", \%seconfig)) {
7454                 # Use global config file
7455                 $main::selinux_enabled_cache =
7456                         $seconfig{'SELINUX'} eq 'disabled' ||
7457                         !$seconfig{'SELINUX'} ? 0 : 1;
7458                 }
7459         else {
7460                 # Use selinuxenabled command
7461                 #$selinux_enabled_cache =
7462                 #       system("selinuxenabled >/dev/null 2>&1") ? 0 : 1;
7463                 $main::selinux_enabled_cache = 0;
7464                 }
7465         }
7466 return $main::selinux_enabled_cache;
7467 }
7468
7469 =head2 get_clear_file_attributes(file)
7470
7471 Finds file attributes that may prevent writing, clears them and returns them
7472 as a list. May call error. Mainly for internal use by open_tempfile and
7473 close_tempfile.
7474
7475 =cut
7476 sub get_clear_file_attributes
7477 {
7478 my ($file) = @_;
7479 my @old_attributes;
7480 if ($gconfig{'chattr'}) {
7481         # Get original immutable bit
7482         my $out = &backquote_command(
7483                 "lsattr ".quotemeta($file)." 2>/dev/null");
7484         if (!$?) {
7485                 $out =~ s/\s\S+\n//;
7486                 @old_attributes = grep { $_ ne '-' } split(//, $out);
7487                 }
7488         if (&indexof("i", @old_attributes) >= 0) {
7489                 my $err = &backquote_logged(
7490                         "chattr -i ".quotemeta($file)." 2>&1");
7491                 if ($?) {
7492                         &error("Failed to remove immutable bit on ".
7493                                "$file : $err");
7494                         }
7495                 }
7496         }
7497 return @old_attributes;
7498 }
7499
7500 =head2 reset_file_attributes(file, &attributes)
7501
7502 Put back cleared attributes on some file. May call error. Mainly for internal
7503 use by close_tempfile.
7504
7505 =cut
7506 sub reset_file_attributes
7507 {
7508 my ($file, $old_attributes) = @_;
7509 if (&indexof("i", @$old_attributes) >= 0) {
7510         my $err = &backquote_logged(
7511                 "chattr +i ".quotemeta($file)." 2>&1");
7512         if ($?) {
7513                 &error("Failed to restore immutable bit on ".
7514                        "$file : $err");
7515                 }
7516         }
7517 }
7518
7519 =head2 cleanup_tempnames
7520
7521 Remove all temporary files generated using transname. Typically only called
7522 internally when a Webmin script exits.
7523
7524 =cut
7525 sub cleanup_tempnames
7526 {
7527 foreach my $t (@main::temporary_files) {
7528         &unlink_file($t);
7529         }
7530 @main::temporary_files = ( );
7531 }
7532
7533 =head2 open_lock_tempfile([handle], file, [no-error])
7534
7535 Returns a temporary file for writing to some actual file, and also locks it.
7536 Effectively the same as calling lock_file and open_tempfile on the same file,
7537 but calls the unlock for you automatically when it is closed.
7538
7539 =cut
7540 sub open_lock_tempfile
7541 {
7542 my ($fh, $file, $noerror, $notemp, $safe) = @_;
7543 $fh = &callers_package($fh);
7544 my $lockfile = $file;
7545 $lockfile =~ s/^[^\/]*//;
7546 if ($lockfile =~ /^\//) {
7547         $main::open_templocks{$lockfile} = &lock_file($lockfile);
7548         }
7549 return &open_tempfile($fh, $file, $noerror, $notemp, $safe);
7550 }
7551
7552 sub END
7553 {
7554 $main::end_exit_status ||= $?;
7555 if ($$ == $main::initial_process_id) {
7556         # Exiting from initial process
7557         &cleanup_tempnames();
7558         if ($gconfig{'debug_what_start'} && $main::debug_log_start_time &&
7559             $main::debug_log_start_module eq &get_module_name()) {
7560                 my $len = time() - $main::debug_log_start_time;
7561                 &webmin_debug_log("STOP", "runtime=$len");
7562                 $main::debug_log_start_time = 0;
7563                 }
7564         if (!$ENV{'SCRIPT_NAME'} &&
7565             $main::initial_module_name eq &get_module_name()) {
7566                 # In a command-line script - call the real exit, so that the
7567                 # exit status gets properly propogated. In some cases this
7568                 # was not happening.
7569                 exit($main::end_exit_status);
7570                 }
7571         }
7572 }
7573
7574 =head2 month_to_number(month)
7575
7576 Converts a month name like feb to a number like 1.
7577
7578 =cut
7579 sub month_to_number
7580 {
7581 return $month_to_number_map{lc(substr($_[0], 0, 3))};
7582 }
7583
7584 =head2 number_to_month(number)
7585
7586 Converts a number like 1 to a month name like Feb.
7587
7588 =cut
7589 sub number_to_month
7590 {
7591 return ucfirst($number_to_month_map{$_[0]});
7592 }
7593
7594 =head2 get_rbac_module_acl(user, module)
7595
7596 Returns a hash reference of RBAC overrides ACLs for some user and module.
7597 May return undef if none exist (indicating access denied), or the string *
7598 if full access is granted.
7599
7600 =cut
7601 sub get_rbac_module_acl
7602 {
7603 my ($user, $mod) = @_;
7604 eval "use Authen::SolarisRBAC";
7605 return undef if ($@);
7606 my %rv;
7607 my $foundany = 0;
7608 if (Authen::SolarisRBAC::chkauth("webmin.$mod.admin", $user)) {
7609         # Automagic webmin.modulename.admin authorization exists .. allow access
7610         $foundany = 1;
7611         if (!Authen::SolarisRBAC::chkauth("webmin.$mod.config", $user)) {
7612                 %rv = ( 'noconfig' => 1 );
7613                 }
7614         else {
7615                 %rv = ( );
7616                 }
7617         }
7618 local $_;
7619 open(RBAC, &module_root_directory($mod)."/rbac-mapping");
7620 while(<RBAC>) {
7621         s/\r|\n//g;
7622         s/#.*$//;
7623         my ($auths, $acls) = split(/\s+/, $_);
7624         my @auths = split(/,/, $auths);
7625         next if (!$auths);
7626         my ($merge) = ($acls =~ s/^\+//);
7627         my $gotall = 1;
7628         if ($auths eq "*") {
7629                 # These ACLs apply to all RBAC users.
7630                 # Only if there is some that match a specific authorization
7631                 # later will they be used though.
7632                 }
7633         else {
7634                 # Check each of the RBAC authorizations
7635                 foreach my $a (@auths) {
7636                         if (!Authen::SolarisRBAC::chkauth($a, $user)) {
7637                                 $gotall = 0;
7638                                 last;
7639                                 }
7640                         }
7641                 $foundany++ if ($gotall);
7642                 }
7643         if ($gotall) {
7644                 # Found an RBAC authorization - return the ACLs
7645                 return "*" if ($acls eq "*");
7646                 my %acl = map { split(/=/, $_, 2) } split(/,/, $acls);
7647                 if ($merge) {
7648                         # Just add to current set
7649                         foreach my $a (keys %acl) {
7650                                 $rv{$a} = $acl{$a};
7651                                 }
7652                         }
7653                 else {
7654                         # Found final ACLs
7655                         return \%acl;
7656                         }
7657                 }
7658         }
7659 close(RBAC);
7660 return !$foundany ? undef : defined(%rv) ? \%rv : undef;
7661 }
7662
7663 =head2 supports_rbac([module])
7664
7665 Returns 1 if RBAC client support is available, such as on Solaris.
7666
7667 =cut
7668 sub supports_rbac
7669 {
7670 return 0 if ($gconfig{'os_type'} ne 'solaris');
7671 eval "use Authen::SolarisRBAC";
7672 return 0 if ($@);
7673 if ($_[0]) {
7674         #return 0 if (!-r &module_root_directory($_[0])."/rbac-mapping");
7675         }
7676 return 1;
7677 }
7678
7679 =head2 use_rbac_module_acl(user, module)
7680
7681 Returns 1 if some user should use RBAC to get permissions for a module
7682
7683 =cut
7684 sub use_rbac_module_acl
7685 {
7686 my $u = defined($_[0]) ? $_[0] : $base_remote_user;
7687 my $m = defined($_[1]) ? $_[1] : &get_module_name();
7688 return 1 if ($gconfig{'rbacdeny_'.$u});         # RBAC forced for user
7689 my %access = &get_module_acl($u, $m, 1);
7690 return $access{'rbac'} ? 1 : 0;
7691 }
7692
7693 =head2 execute_command(command, stdin, stdout, stderr, translate-files?, safe?)
7694
7695 Runs some command, possibly feeding it input and capturing output to the
7696 give files or scalar references. The parameters are :
7697
7698 =item command - Full command to run, possibly including shell meta-characters.
7699
7700 =item stdin - File to read input from, or a scalar ref containing input, or undef if no input should be given.
7701
7702 =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.
7703
7704 =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.
7705
7706 =item translate-files - Set to 1 to apply filename translation to any filenames. Usually has no effect.
7707
7708 =item safe - Set to 1 if this command is safe and does not modify the state of the system.
7709
7710 =cut
7711 sub execute_command
7712 {
7713 my ($cmd, $stdin, $stdout, $stderr, $trans, $safe) = @_;
7714 if (&is_readonly_mode() && !$safe) {
7715         print STDERR "Vetoing command $_[0]\n";
7716         $? = 0;
7717         return 0;
7718         }
7719 my $cmd = &translate_command($cmd);
7720
7721 # Use ` operator where possible
7722 if (!$stdin && ref($stdout) && !$stderr) {
7723         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
7724         $$stdout = `$cmd 2>$null_file`;
7725         return $?;
7726         }
7727 elsif (!$stdin && ref($stdout) && $stdout eq $stderr) {
7728         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
7729         $$stdout = `$cmd 2>&1`;
7730         return $?;
7731         }
7732 elsif (!$stdin && !$stdout && !$stderr) {
7733         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
7734         return system("$cmd >$null_file 2>$null_file <$null_file");
7735         }
7736 &webmin_debug_log('CMD', "cmd=$cmd") if ($gconfig{'debug_what_cmd'});
7737
7738 # Setup pipes
7739 $| = 1;         # needed on some systems to flush before forking
7740 pipe(EXECSTDINr, EXECSTDINw);
7741 pipe(EXECSTDOUTr, EXECSTDOUTw);
7742 pipe(EXECSTDERRr, EXECSTDERRw);
7743 my $pid;
7744 if (!($pid = fork())) {
7745         untie(*STDIN);
7746         untie(*STDOUT);
7747         untie(*STDERR);
7748         open(STDIN, "<&EXECSTDINr");
7749         open(STDOUT, ">&EXECSTDOUTw");
7750         if (ref($stderr) && $stderr eq $stdout) {
7751                 open(STDERR, ">&EXECSTDOUTw");
7752                 }
7753         else {
7754                 open(STDERR, ">&EXECSTDERRw");
7755                 }
7756         $| = 1;
7757         close(EXECSTDINw);
7758         close(EXECSTDOUTr);
7759         close(EXECSTDERRr);
7760
7761         my $fullcmd = "($cmd)";
7762         if ($stdin && !ref($stdin)) {
7763                 $fullcmd .= " <$stdin";
7764                 }
7765         if ($stdout && !ref($stdout)) {
7766                 $fullcmd .= " >$stdout";
7767                 }
7768         if ($stderr && !ref($stderr)) {
7769                 if ($stderr eq $stdout) {
7770                         $fullcmd .= " 2>&1";
7771                         }
7772                 else {
7773                         $fullcmd .= " 2>$stderr";
7774                         }
7775                 }
7776         if ($gconfig{'os_type'} eq 'windows') {
7777                 exec($fullcmd);
7778                 }
7779         else {
7780                 exec("/bin/sh", "-c", $fullcmd);
7781                 }
7782         print "Exec failed : $!\n";
7783         exit(1);
7784         }
7785 close(EXECSTDINr);
7786 close(EXECSTDOUTw);
7787 close(EXECSTDERRw);
7788
7789 # Feed input and capture output
7790 local $_;
7791 if ($stdin && ref($stdin)) {
7792         print EXECSTDINw $$stdin;
7793         close(EXECSTDINw);
7794         }
7795 if ($stdout && ref($stdout)) {
7796         $$stdout = undef;
7797         while(<EXECSTDOUTr>) {
7798                 $$stdout .= $_;
7799                 }
7800         close(EXECSTDOUTr);
7801         }
7802 if ($stderr && ref($stderr) && $stderr ne $stdout) {
7803         $$stderr = undef;
7804         while(<EXECSTDERRr>) {
7805                 $$stderr .= $_;
7806                 }
7807         close(EXECSTDERRr);
7808         }
7809
7810 # Get exit status
7811 waitpid($pid, 0);
7812 return $?;
7813 }
7814
7815 =head2 open_readfile(handle, file)
7816
7817 Opens some file for reading. Returns 1 on success, 0 on failure. Pretty much
7818 exactly the same as Perl's open function.
7819
7820 =cut
7821 sub open_readfile
7822 {
7823 my ($fh, $file) = @_;
7824 $fh = &callers_package($fh);
7825 my $realfile = &translate_filename($file);
7826 &webmin_debug_log('READ', $file) if ($gconfig{'debug_what_read'});
7827 return open($fh, "<".$realfile);
7828 }
7829
7830 =head2 open_execute_command(handle, command, output?, safe?)
7831
7832 Runs some command, with the specified file handle set to either write to it if
7833 in-or-out is set to 0, or read to it if output is set to 1. The safe flag
7834 indicates if the command modifies the state of the system or not.
7835
7836 =cut
7837 sub open_execute_command
7838 {
7839 my ($fh, $cmd, $mode, $safe) = @_;
7840 $fh = &callers_package($fh);
7841 my $realcmd = &translate_command($cmd);
7842 if (&is_readonly_mode() && !$safe) {
7843         # Don't actually run it
7844         print STDERR "vetoing command $cmd\n";
7845         $? = 0;
7846         if ($mode == 0) {
7847                 return open($fh, ">$null_file");
7848                 }
7849         else {
7850                 return open($fh, $null_file);
7851                 }
7852         }
7853 # Really run it
7854 &webmin_debug_log('CMD', "cmd=$realcmd mode=$mode")
7855         if ($gconfig{'debug_what_cmd'});
7856 if ($mode == 0) {
7857         return open($fh, "| $cmd");
7858         }
7859 elsif ($mode == 1) {
7860         return open($fh, "$cmd 2>$null_file |");
7861         }
7862 elsif ($mode == 2) {
7863         return open($fh, "$cmd 2>&1 |");
7864         }
7865 }
7866
7867 =head2 translate_filename(filename)
7868
7869 Applies all relevant registered translation functions to a filename. Mostly
7870 for internal use, and typically does nothing.
7871
7872 =cut
7873 sub translate_filename
7874 {
7875 my ($realfile) = @_;
7876 my @funcs = grep { $_->[0] eq &get_module_name() ||
7877                    !defined($_->[0]) } @main::filename_callbacks;
7878 foreach my $f (@funcs) {
7879         my $func = $f->[1];
7880         $realfile = &$func($realfile, @{$f->[2]});
7881         }
7882 return $realfile;
7883 }
7884
7885 =head2 translate_command(filename)
7886
7887 Applies all relevant registered translation functions to a command. Mostly
7888 for internal use, and typically does nothing.
7889
7890 =cut
7891 sub translate_command
7892 {
7893 my ($realcmd) = @_;
7894 my @funcs = grep { $_->[0] eq &get_module_name() ||
7895                    !defined($_->[0]) } @main::command_callbacks;
7896 foreach my $f (@funcs) {
7897         my $func = $f->[1];
7898         $realcmd = &$func($realcmd, @{$f->[2]});
7899         }
7900 return $realcmd;
7901 }
7902
7903 =head2 register_filename_callback(module|undef, &function, &args)
7904
7905 Registers some function to be called when the specified module (or all
7906 modules) tries to open a file for reading and writing. The function must
7907 return the actual file to open. This allows you to override which files
7908 other code actually operates on, via the translate_filename function.
7909
7910 =cut
7911 sub register_filename_callback
7912 {
7913 my ($mod, $func, $args) = @_;
7914 push(@main::filename_callbacks, [ $mod, $func, $args ]);
7915 }
7916
7917 =head2 register_command_callback(module|undef, &function, &args)
7918
7919 Registers some function to be called when the specified module (or all
7920 modules) tries to execute a command. The function must return the actual
7921 command to run. This allows you to override which commands other other code
7922 actually runs, via the translate_command function.
7923
7924 =cut
7925 sub register_command_callback
7926 {
7927 my ($mod, $func, $args) = @_;
7928 push(@main::command_callbacks, [ $mod, $func, $args ]);
7929 }
7930
7931 =head2 capture_function_output(&function, arg, ...)
7932
7933 Captures output that some function prints to STDOUT, and returns it. Useful
7934 for functions outside your control that print data when you really want to
7935 manipulate it before output.
7936
7937 =cut
7938 sub capture_function_output
7939 {
7940 my ($func, @args) = @_;
7941 socketpair(SOCKET2, SOCKET1, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
7942 my $old = select(SOCKET1);
7943 my @rv = &$func(@args);
7944 select($old);
7945 close(SOCKET1);
7946 my $out;
7947 local $_;
7948 while(<SOCKET2>) {
7949         $out .= $_;
7950         }
7951 close(SOCKET2);
7952 return wantarray ? ($out, \@rv) : $out;
7953 }
7954
7955 =head2 capture_function_output_tempfile(&function, arg, ...)
7956
7957 Behaves the same as capture_function_output, but uses a temporary file
7958 to avoid buffer full problems.
7959
7960 =cut
7961 sub capture_function_output_tempfile
7962 {
7963 my ($func, @args) = @_;
7964 my $temp = &transname();
7965 open(BUFFER, ">$temp");
7966 my $old = select(BUFFER);
7967 my @rv = &$func(@args);
7968 select($old);
7969 close(BUFFER);
7970 my $out = &read_file_contents($temp);
7971 &unlink_file($temp);
7972 return wantarray ? ($out, \@rv) : $out;
7973 }
7974
7975 =head2 modules_chooser_button(field, multiple, [form])
7976
7977 Returns HTML for a button for selecting one or many Webmin modules.
7978 field - Name of the HTML field to place the module names into.
7979 multiple - Set to 1 if multiple modules can be selected.
7980 form - Index of the form on the page.
7981
7982 =cut
7983 sub modules_chooser_button
7984 {
7985 return &theme_modules_chooser_button(@_)
7986         if (defined(&theme_modules_chooser_button));
7987 my $form = defined($_[2]) ? $_[2] : 0;
7988 my $w = $_[1] ? 700 : 500;
7989 my $h = 200;
7990 if ($_[1] && $gconfig{'db_sizemodules'}) {
7991         ($w, $h) = split(/x/, $gconfig{'db_sizemodules'});
7992         }
7993 elsif (!$_[1] && $gconfig{'db_sizemodule'}) {
7994         ($w, $h) = split(/x/, $gconfig{'db_sizemodule'});
7995         }
7996 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";
7997 }
7998
7999 =head2 substitute_template(text, &hash)
8000
8001 Given some text and a hash reference, for each ocurrance of $FOO or ${FOO} in
8002 the text replaces it with the value of the hash key foo. Also supports blocks
8003 like ${IF-FOO} ... ${ENDIF-FOO}, whose contents are only included if foo is
8004 non-zero, and ${IF-FOO} ... ${ELSE-FOO} ... ${ENDIF-FOO}.
8005
8006 =cut
8007 sub substitute_template
8008 {
8009 # Add some extra fixed parameters to the hash
8010 my %hash = %{$_[1]};
8011 $hash{'hostname'} = &get_system_hostname();
8012 $hash{'webmin_config'} = $config_directory;
8013 $hash{'webmin_etc'} = $config_directory;
8014 $hash{'module_config'} = &get_module_variable('$module_config_directory');
8015 $hash{'webmin_var'} = $var_directory;
8016
8017 # Add time-based parameters, for use in DNS
8018 $hash{'current_time'} = time();
8019 my @tm = localtime($hash{'current_time'});
8020 $hash{'current_year'} = $tm[5]+1900;
8021 $hash{'current_month'} = sprintf("%2.2d", $tm[4]+1);
8022 $hash{'current_day'} = sprintf("%2.2d", $tm[3]);
8023 $hash{'current_hour'} = sprintf("%2.2d", $tm[2]);
8024 $hash{'current_minute'} = sprintf("%2.2d", $tm[1]);
8025 $hash{'current_second'} = sprintf("%2.2d", $tm[0]);
8026
8027 # Actually do the substition
8028 my $rv = $_[0];
8029 foreach my $s (keys %hash) {
8030         next if ($s eq '');     # Prevent just $ from being subbed
8031         my $us = uc($s);
8032         my $sv = $hash{$s};
8033         $rv =~ s/\$\{\Q$us\E\}/$sv/g;
8034         $rv =~ s/\$\Q$us\E/$sv/g;
8035         if ($sv) {
8036                 # Replace ${IF}..${ELSE}..${ENDIF} block with first value,
8037                 # and ${IF}..${ENDIF} with value
8038                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/\2/g;
8039                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/\2/g;
8040
8041                 # Replace $IF..$ELSE..$ENDIF block with first value,
8042                 # and $IF..$ENDIF with value
8043                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ELSE-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/\2/g;
8044                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/\2/g;
8045
8046                 # Replace ${IFEQ}..${ENDIFEQ} block with first value if
8047                 # matching, nothing if not
8048                 $rv =~ s/\$\{IFEQ-\Q$us\E-\Q$sv\E\}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-\Q$sv\E\}(\n?)/\2/g;
8049                 $rv =~ s/\$\{IFEQ-\Q$us\E-[^\}]+}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-[^\}]+\}(\n?)//g;
8050
8051                 # Replace $IFEQ..$ENDIFEQ block with first value if
8052                 # matching, nothing if not
8053                 $rv =~ s/\$IFEQ-\Q$us\E-\Q$sv\E(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\Q$sv\E(\n?)/\2/g;
8054                 $rv =~ s/\$IFEQ-\Q$us\E-\S+(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\S+(\n?)//g;
8055                 }
8056         else {
8057                 # Replace ${IF}..${ELSE}..${ENDIF} block with second value,
8058                 # and ${IF}..${ENDIF} with nothing
8059                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/\4/g;
8060                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)//g;
8061
8062                 # Replace $IF..$ELSE..$ENDIF block with second value,
8063                 # and $IF..$ENDIF with nothing
8064                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ELSE-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/\4/g;
8065                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)//g;
8066
8067                 # Replace ${IFEQ}..${ENDIFEQ} block with nothing
8068                 $rv =~ s/\$\{IFEQ-\Q$us\E-[^\}]+}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-[^\}]+\}(\n?)//g;
8069                 $rv =~ s/\$IFEQ-\Q$us\E-\S+(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\S+(\n?)//g;
8070                 }
8071         }
8072
8073 # Now assume any $IF blocks whose variables are not present in the hash
8074 # evaluate to false.
8075 # $IF...$ELSE x $ENDIF => x
8076 $rv =~ s/\$\{IF\-([A-Z]+)\}.*?\$\{ELSE\-\1\}(.*?)\$\{ENDIF\-\1\}/$2/gs;
8077 # $IF...x...$ENDIF => (nothing)
8078 $rv =~ s/\$\{IF\-([A-Z]+)\}.*?\$\{ENDIF\-\1\}//gs;
8079 # ${var} => (nothing)
8080 $rv =~ s/\$\{[A-Z]+\}//g;
8081
8082 return $rv;
8083 }
8084
8085 =head2 running_in_zone
8086
8087 Returns 1 if the current Webmin instance is running in a Solaris zone. Used to
8088 disable module and features that are not appropriate, like those that modify
8089 mounted filesystems.
8090
8091 =cut
8092 sub running_in_zone
8093 {
8094 return 0 if ($gconfig{'os_type'} ne 'solaris' ||
8095              $gconfig{'os_version'} < 10);
8096 my $zn = `zonename 2>$null_file`;
8097 chop($zn);
8098 return $zn && $zn ne "global";
8099 }
8100
8101 =head2 running_in_vserver
8102
8103 Returns 1 if the current Webmin instance is running in a Linux VServer.
8104 Used to disable modules and features that are not appropriate.
8105
8106 =cut
8107 sub running_in_vserver
8108 {
8109 return 0 if ($gconfig{'os_type'} !~ /^\*-linux$/);
8110 my $vserver;
8111 local $_;
8112 open(MTAB, "/etc/mtab");
8113 while(<MTAB>) {
8114         my ($dev, $mp) = split(/\s+/, $_);
8115         if ($mp eq "/" && $dev =~ /^\/dev\/hdv/) {
8116                 $vserver = 1;
8117                 last;
8118                 }
8119         }
8120 close(MTAB);
8121 return $vserver;
8122 }
8123
8124 =head2 running_in_xen
8125
8126 Returns 1 if Webmin is running inside a Xen instance, by looking
8127 at /proc/xen/capabilities.
8128
8129 =cut
8130 sub running_in_xen
8131 {
8132 return 0 if (!-r "/proc/xen/capabilities");
8133 my $cap = &read_file_contents("/proc/xen/capabilities");
8134 return $cap =~ /control_d/ ? 0 : 1;
8135 }
8136
8137 =head2 list_categories(&modules, [include-empty])
8138
8139 Returns a hash mapping category codes to names, including any custom-defined
8140 categories. The modules parameter must be an array ref of module hash objects,
8141 as returned by get_all_module_infos.
8142
8143 =cut
8144 sub list_categories
8145 {
8146 my ($mods, $empty) = @_;
8147 my (%cats, %catnames);
8148 &read_file("$config_directory/webmin.catnames", \%catnames);
8149 foreach my $o (@lang_order_list) {
8150         &read_file("$config_directory/webmin.catnames.$o", \%catnames);
8151         }
8152 if ($empty) {
8153         %cats = %catnames;
8154         }
8155 foreach my $m (@$mods) {
8156         my $c = $m->{'category'};
8157         next if ($cats{$c});
8158         if (defined($catnames{$c})) {
8159                 $cats{$c} = $catnames{$c};
8160                 }
8161         elsif ($text{"category_$c"}) {
8162                 $cats{$c} = $text{"category_$c"};
8163                 }
8164         else {
8165                 # try to get category name from module ..
8166                 my %mtext = &load_language($m->{'dir'});
8167                 if ($mtext{"category_$c"}) {
8168                         $cats{$c} = $mtext{"category_$c"};
8169                         }
8170                 else {
8171                         $c = $m->{'category'} = "";
8172                         $cats{$c} = $text{"category_$c"};
8173                         }
8174                 }
8175         }
8176 return %cats;
8177 }
8178
8179 =head2 is_readonly_mode
8180
8181 Returns 1 if the current user is in read-only mode, and thus all writes
8182 to files and command execution should fail.
8183
8184 =cut
8185 sub is_readonly_mode
8186 {
8187 if (!defined($main::readonly_mode_cache)) {
8188         my %gaccess = &get_module_acl(undef, "");
8189         $main::readonly_mode_cache = $gaccess{'readonly'} ? 1 : 0;
8190         }
8191 return $main::readonly_mode_cache;
8192 }
8193
8194 =head2 command_as_user(user, with-env?, command, ...)
8195
8196 Returns a command to execute some command as the given user, using the
8197 su statement. If on Linux, the /bin/sh shell is forced in case the user
8198 does not have a valid shell. If with-env is set to 1, the -s flag is added
8199 to the su command to read the user's .profile or .bashrc file.
8200
8201 =cut
8202 sub command_as_user
8203 {
8204 my ($user, $env, @args) = @_;
8205 my @uinfo = getpwnam($user);
8206 if ($uinfo[8] ne "/bin/sh" && $uinfo[8] !~ /\/bash$/) {
8207         # User shell doesn't appear to be valid
8208         if ($gconfig{'os_type'} =~ /-linux$/) {
8209                 # Use -s /bin/sh to force it
8210                 $shellarg = " -s /bin/sh";
8211                 }
8212         elsif ($gconfig{'os_type'} eq 'freebsd' ||
8213                $gconfig{'os_type'} eq 'solaris' &&
8214                 $gconfig{'os_version'} >= 11 ||
8215                $gconfig{'os_type'} eq 'macos') {
8216                 # Use -m and force /bin/sh
8217                 @args = ( "/bin/sh", "-c", quotemeta(join(" ", @args)) );
8218                 $shellarg = " -m";
8219                 }
8220         }
8221 my $rv = "su".($env ? " -" : "").$shellarg.
8222          " ".quotemeta($user)." -c ".quotemeta(join(" ", @args));
8223 return $rv;
8224 }
8225
8226 =head2 list_osdn_mirrors(project, file)
8227
8228 Given a OSDN project and filename, returns a list of mirror URLs from
8229 which it can be downloaded. Mainly for internal use by the http_download
8230 function.
8231
8232 =cut
8233 sub list_osdn_mirrors
8234 {
8235 my ($project, $file) = @_;
8236
8237 # Convert the sourceforge project name to a group ID
8238 my ($idpage, $iderror);
8239 &http_download($osdn_download_host, $osdn_download_port,
8240                "/$project/", \$idpage, \$iderror,
8241                undef, 0, undef, undef, 0, 0, 1);
8242 my $group_id;
8243 if ($idpage =~ /showfiles.php\?group_id=(\d+)/) {
8244         $group_id = $1;
8245         }
8246
8247 # Query the mirror picker page
8248 my ($page, $error, @rv);
8249 if ($group_id) {
8250         &http_download($osdn_download_host, $osdn_download_port,
8251                        "/project/mirror_picker.php?group_id=".&urlize($group_id).
8252                         "&filename=".&urlize($file),
8253                        \$page, \$error, undef, 0, undef, undef, 0, 0, 1,
8254                        \%headers);
8255         while($page =~ /<input[^>]*name="use_mirror"\s+value="(\S+)"[^>]*>([^,]+),\s*([^<]*)<([\000-\377]*)/i) {
8256                 # Got a country and city
8257                 push(@rv, { 'country' => $3,
8258                             'city' => $2,
8259                             'mirror' => $1,
8260                             'url' => "http://$1.dl.sourceforge.net/sourceforge/$project/$file" });
8261                 $page = $4;
8262                 }
8263         }
8264
8265 if (!@rv) {
8266         # None found! Try some known mirrors
8267         foreach my $m ("superb-east", "superb-west", "osdn", "downloads") {
8268                 my $url = $m eq "downloads" ?
8269                     "http://downloads.sourceforge.net/$project/$file" :
8270                     "http://$m.dl.sourceforge.net/sourceforge/$project/$file";
8271                 $main::download_timed_out = undef;
8272                 local $SIG{ALRM} = \&download_timeout;
8273                 alarm(10);
8274                 my ($host, $port, $page, $ssl) = &parse_http_url($url);
8275                 my $h = &make_http_connection(
8276                         $host, $port, $ssl, "HEAD", $page);
8277                 alarm(0);
8278                 next if (!ref($h) || $main::download_timed_out);
8279
8280                 # Make a HEAD request
8281                 &write_http_connection($h, "Host: $host\r\n");
8282                 &write_http_connection($h, "User-agent: Webmin\r\n");
8283                 &write_http_connection($h, "\r\n");
8284                 $line = &read_http_connection($h);
8285                 $line =~ s/\r|\n//g;
8286                 &close_http_connection($h);
8287                 if ($line =~ /^HTTP\/1\..\s+(200)\s+/) {
8288                         push(@rv, { 'mirror' => $m,
8289                                     'default' => $m eq 'osdn',
8290                                     'url' => $url });
8291                         last;
8292                         }
8293                 }
8294         }
8295 return @rv;
8296 }
8297
8298 =head2 convert_osdn_url(url)
8299
8300 Given a URL like http://osdn.dl.sourceforge.net/sourceforge/project/file.zip
8301 or http://prdownloads.sourceforge.net/project/file.zip , convert it
8302 to a real URL on the best mirror.
8303
8304 =cut
8305 sub convert_osdn_url
8306 {
8307 my ($url) = @_;
8308 if ($url =~ /^http:\/\/[^\.]+.dl.sourceforge.net\/sourceforge\/([^\/]+)\/(.*)$/ ||
8309     $url =~ /^http:\/\/prdownloads.sourceforge.net\/([^\/]+)\/(.*)$/) {
8310         # Find best site
8311         my ($project, $file) = ($1, $2);
8312         my @mirrors = &list_osdn_mirrors($project, $file);
8313         my $pref = $gconfig{'osdn_mirror'};
8314         my $site;
8315         if ($pref) {
8316                 ($site) = grep { $_->{'mirror'} eq $pref } @mirrors;
8317                 }
8318         if (!$site) {
8319                 # Fall back to automatic mirror selection via Sourceforge
8320                 # redirect
8321                 $site = { 'url' => "http://prdownloads.sourceforge.net/sourceforge/$project/$file",
8322                           'default' => 0 };
8323                 }
8324         return wantarray ? ( $site->{'url'}, $site->{'default'} )
8325                          : $site->{'url'};
8326         }
8327 else {
8328         # Some other source .. don't change
8329         return wantarray ? ( $url, 2 ) : $url;
8330         }
8331 }
8332
8333 =head2 get_current_dir
8334
8335 Returns the directory the current process is running in.
8336
8337 =cut
8338 sub get_current_dir
8339 {
8340 my $out;
8341 if ($gconfig{'os_type'} eq 'windows') {
8342         # Use cd command
8343         $out = `cd`;
8344         }
8345 else {
8346         # Use pwd command
8347         $out = `pwd`;
8348         $out =~ s/\\/\//g;
8349         }
8350 $out =~ s/\r|\n//g;
8351 return $out;
8352 }
8353
8354 =head2 supports_users
8355
8356 Returns 1 if the current OS supports Unix user concepts and functions like
8357 su , getpw* and so on. This will be true on Linux and other Unixes, but false
8358 on Windows.
8359
8360 =cut
8361 sub supports_users
8362 {
8363 return $gconfig{'os_type'} ne 'windows';
8364 }
8365
8366 =head2 supports_symlinks
8367
8368 Returns 1 if the current OS supports symbolic and hard links. This will not
8369 be the case on Windows.
8370
8371 =cut
8372 sub supports_symlinks
8373 {
8374 return $gconfig{'os_type'} ne 'windows';
8375 }
8376
8377 =head2 quote_path(path)
8378
8379 Returns a path with safe quoting for the current operating system.
8380
8381 =cut
8382 sub quote_path
8383 {
8384 my ($path) = @_;
8385 if ($gconfig{'os_type'} eq 'windows' || $path =~ /^[a-z]:/i) {
8386         # Windows only supports "" style quoting
8387         return "\"$path\"";
8388         }
8389 else {
8390         return quotemeta($path);
8391         }
8392 }
8393
8394 =head2 get_windows_root
8395
8396 Returns the base windows system directory, like c:/windows.
8397
8398 =cut
8399 sub get_windows_root
8400 {
8401 if ($ENV{'SystemRoot'}) {
8402         my $rv = $ENV{'SystemRoot'};
8403         $rv =~ s/\\/\//g;
8404         return $rv;
8405         }
8406 else {
8407         return -d "c:/windows" ? "c:/windows" : "c:/winnt";
8408         }
8409 }
8410
8411 =head2 read_file_contents(file)
8412
8413 Given a filename, returns its complete contents as a string. Effectively
8414 the same as the Perl construct `cat file`.
8415
8416 =cut
8417 sub read_file_contents
8418 {
8419 &open_readfile(FILE, $_[0]) || return undef;
8420 local $/ = undef;
8421 my $rv = <FILE>;
8422 close(FILE);
8423 return $rv;
8424 }
8425
8426 =head2 unix_crypt(password, salt)
8427
8428 Performs Unix encryption on a password, using the built-in crypt function or
8429 the Crypt::UnixCrypt module if the former does not work. The salt parameter
8430 must be either an already-hashed password, or a two-character alpha-numeric
8431 string.
8432
8433 =cut
8434 sub unix_crypt
8435 {
8436 my ($pass, $salt) = @_;
8437 return "" if ($salt !~ /^[a-zA-Z0-9\.\/]{2}/);   # same as real crypt
8438 my $rv = eval "crypt(\$pass, \$salt)";
8439 my $err = $@;
8440 return $rv if ($rv && !$@);
8441 eval "use Crypt::UnixCrypt";
8442 if (!$@) {
8443         return Crypt::UnixCrypt::crypt($pass, $salt);
8444         }
8445 else {
8446         &error("Failed to encrypt password : $err");
8447         }
8448 }
8449
8450 =head2 split_quoted_string(string)
8451
8452 Given a string like I<foo "bar baz" quux>, returns the array :
8453 foo, bar baz, quux
8454
8455 =cut
8456 sub split_quoted_string
8457 {
8458 my ($str) = @_;
8459 my @rv;
8460 while($str =~ /^"([^"]*)"\s*([\000-\377]*)$/ ||
8461       $str =~ /^'([^']*)'\s*([\000-\377]*)$/ ||
8462       $str =~ /^(\S+)\s*([\000-\377]*)$/) {
8463         push(@rv, $1);
8464         $str = $2;
8465         }
8466 return @rv;
8467 }
8468
8469 =head2 write_to_http_cache(url, file|&data)
8470
8471 Updates the Webmin cache with the contents of the given file, possibly also
8472 clearing out old data. Mainly for internal use by http_download.
8473
8474 =cut
8475 sub write_to_http_cache
8476 {
8477 my ($url, $file) = @_;
8478 return 0 if (!$gconfig{'cache_size'});
8479
8480 # Don't cache downloads that look dynamic
8481 if ($url =~ /cgi-bin/ || $url =~ /\?/) {
8482         return 0;
8483         }
8484
8485 # Check if the current module should do caching
8486 if ($gconfig{'cache_mods'} =~ /^\!(.*)$/) {
8487         # Caching all except some modules
8488         my @mods = split(/\s+/, $1);
8489         return 0 if (&indexof(&get_module_name(), @mods) != -1);
8490         }
8491 elsif ($gconfig{'cache_mods'}) {
8492         # Only caching some modules
8493         my @mods = split(/\s+/, $gconfig{'cache_mods'});
8494         return 0 if (&indexof(&get_module_name(), @mods) == -1);
8495         }
8496
8497 # Work out the size
8498 my $size;
8499 if (ref($file)) {
8500         $size = length($$file);
8501         }
8502 else {
8503         my @st = stat($file);
8504         $size = $st[7];
8505         }
8506
8507 if ($size > $gconfig{'cache_size'}) {
8508         # Bigger than the whole cache - so don't save it
8509         return 0;
8510         }
8511 my $cfile = $url;
8512 $cfile =~ s/\//_/g;
8513 $cfile = "$main::http_cache_directory/$cfile";
8514
8515 # See how much we have cached currently, clearing old files
8516 my $total = 0;
8517 mkdir($main::http_cache_directory, 0700) if (!-d $main::http_cache_directory);
8518 opendir(CACHEDIR, $main::http_cache_directory);
8519 foreach my $f (readdir(CACHEDIR)) {
8520         next if ($f eq "." || $f eq "..");
8521         my $path = "$main::http_cache_directory/$f";
8522         my @st = stat($path);
8523         if ($gconfig{'cache_days'} &&
8524             time()-$st[9] > $gconfig{'cache_days'}*24*60*60) {
8525                 # This file is too old .. trash it
8526                 unlink($path);
8527                 }
8528         else {
8529                 $total += $st[7];
8530                 push(@cached, [ $path, $st[7], $st[9] ]);
8531                 }
8532         }
8533 closedir(CACHEDIR);
8534 @cached = sort { $a->[2] <=> $b->[2] } @cached;
8535 while($total+$size > $gconfig{'cache_size'} && @cached) {
8536         # Cache is too big .. delete some files until the new one will fit
8537         unlink($cached[0]->[0]);
8538         $total -= $cached[0]->[1];
8539         shift(@cached);
8540         }
8541
8542 # Finally, write out the new file
8543 if (ref($file)) {
8544         &open_tempfile(CACHEFILE, ">$cfile");
8545         &print_tempfile(CACHEFILE, $$file);
8546         &close_tempfile(CACHEFILE);
8547         }
8548 else {
8549         my ($ok, $err) = &copy_source_dest($file, $cfile);
8550         }
8551
8552 return 1;
8553 }
8554
8555 =head2 check_in_http_cache(url)
8556
8557 If some URL is in the cache and valid, return the filename for it. Mainly
8558 for internal use by http_download.
8559
8560 =cut
8561 sub check_in_http_cache
8562 {
8563 my ($url) = @_;
8564 return undef if (!$gconfig{'cache_size'});
8565
8566 # Check if the current module should do caching
8567 if ($gconfig{'cache_mods'} =~ /^\!(.*)$/) {
8568         # Caching all except some modules
8569         my @mods = split(/\s+/, $1);
8570         return 0 if (&indexof(&get_module_name(), @mods) != -1);
8571         }
8572 elsif ($gconfig{'cache_mods'}) {
8573         # Only caching some modules
8574         my @mods = split(/\s+/, $gconfig{'cache_mods'});
8575         return 0 if (&indexof(&get_module_name(), @mods) == -1);
8576         }
8577
8578 my $cfile = $url;
8579 $cfile =~ s/\//_/g;
8580 $cfile = "$main::http_cache_directory/$cfile";
8581 my @st = stat($cfile);
8582 return undef if (!@st || !$st[7]);
8583 if ($gconfig{'cache_days'} && time()-$st[9] > $gconfig{'cache_days'}*24*60*60) {
8584         # Too old!
8585         unlink($cfile);
8586         return undef;
8587         }
8588 open(TOUCH, ">>$cfile");        # Update the file time, to keep it in the cache
8589 close(TOUCH);
8590 return $cfile;
8591 }
8592
8593 =head2 supports_javascript
8594
8595 Returns 1 if the current browser is assumed to support javascript.
8596
8597 =cut
8598 sub supports_javascript
8599 {
8600 if (defined(&theme_supports_javascript)) {
8601         return &theme_supports_javascript();
8602         }
8603 return $ENV{'MOBILE_DEVICE'} ? 0 : 1;
8604 }
8605
8606 =head2 get_module_name
8607
8608 Returns the name of the Webmin module that called this function. For internal
8609 use only by other API functions.
8610
8611 =cut
8612 sub get_module_name
8613 {
8614 return &get_module_variable('$module_name');
8615 }
8616
8617 =head2 get_module_variable(name, [ref])
8618
8619 Returns the value of some variable which is set in the caller's context, if
8620 using the new WebminCore package. For internal use only.
8621
8622 =cut
8623 sub get_module_variable
8624 {
8625 my ($v, $wantref) = @_;
8626 my $slash = $wantref ? "\\" : "";
8627 my $thispkg = &web_libs_package();
8628 if ($thispkg eq 'WebminCore') {
8629         my ($vt, $vn) = split('', $v, 2);
8630         my $callpkg;
8631         for(my $i=0; ($callpkg) = caller($i); $i++) {
8632                 last if ($callpkg ne $thispkg);
8633                 }
8634         return eval "${slash}${vt}${callpkg}::${vn}";
8635         }
8636 return eval "${slash}${v}";
8637 }
8638
8639 =head2 clear_time_locale()
8640
8641 Temporarily force the locale to C, until reset_time_locale is called. This is
8642 useful if your code is going to call C<strftime> from the POSIX package, and
8643 you want to ensure that the output is in a consistent format.
8644
8645 =cut
8646 sub clear_time_locale
8647 {
8648 if ($main::clear_time_locale_count == 0) {
8649         eval {
8650                 use POSIX;
8651                 $main::clear_time_locale_old = POSIX::setlocale(POSIX::LC_TIME);
8652                 POSIX::setlocale(POSIX::LC_TIME, "C");
8653                 };
8654         }
8655 $main::clear_time_locale_count++;
8656 }
8657
8658 =head2 reset_time_locale()
8659
8660 Revert the locale to whatever it was before clear_time_locale was called
8661
8662 =cut
8663 sub reset_time_locale
8664 {
8665 if ($main::clear_time_locale_count == 1) {
8666         eval {
8667                 POSIX::setlocale(POSIX::LC_TIME, $main::clear_time_locale_old);
8668                 $main::clear_time_locale_old = undef;
8669                 };
8670         }
8671 $main::clear_time_locale_count--;
8672 }
8673
8674 =head2 callers_package(filehandle)
8675
8676 Convert a non-module filehandle like FOO to one qualified with the
8677 caller's caller's package, like fsdump::FOO. For internal use only.
8678
8679 =cut
8680 sub callers_package
8681 {
8682 my ($fh) = @_;
8683 my $callpkg = (caller(1))[0];
8684 my $thispkg = &web_libs_package();
8685 if (!ref($fh) && $fh !~ /::/ &&
8686     $callpkg ne $thispkg && $thispkg eq 'WebminCore') {
8687         $fh = $callpkg."::".$fh;
8688         }
8689 return $fh;
8690 }
8691
8692 =head2 web_libs_package()
8693
8694 Returns the package this code is in. We can't always trust __PACKAGE__. For
8695 internal use only.
8696
8697 =cut
8698 sub web_libs_package
8699 {
8700 if ($called_from_webmin_core) {
8701         return "WebminCore";
8702         }
8703 return __PACKAGE__;
8704 }
8705
8706 $done_web_lib_funcs = 1;
8707
8708 1;