web-lib-funcs.pl

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