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