web-lib-funcs.pl

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