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 eval_as_unix_user(username, &code)
6346
6347 Runs some code fragment with the effective UID and GID switch to that
6348 of the given Unix user, so that file IO takes place with his permissions.
6349
6350 =cut
6351
6352 sub eval_as_unix_user
6353 {
6354 my ($user, $code) = @_;
6355 my @uinfo = getpwnam($user);
6356 defined(@uinfo) || &error("eval_as_unix_user called with invalid user $user");
6357 $) = $uinfo[3]." ".join(" ", $uinfo[3], &other_groups($user));
6358 $> = $uinfo[2];
6359 my @rv;
6360 eval {
6361         local $main::error_must_die = 1;
6362         @rv = &$code();
6363         };
6364 my $err = $@;
6365 $) = 0;
6366 $> = 0;
6367 if ($err) {
6368         $err =~ s/\s+at\s+(\/\S+)\s+line\s+(\d+)\.?//;
6369         &error($err);
6370         }
6371 return wantarray ? @rv : $rv[0];
6372 }
6373
6374 =head2 create_user_config_dirs
6375
6376 Creates per-user config directories and sets $user_config_directory and
6377 $user_module_config_directory to them. Also reads per-user module configs
6378 into %userconfig. This should be called by Usermin module scripts that need
6379 to store per-user preferences or other settings.
6380
6381 =cut
6382 sub create_user_config_dirs
6383 {
6384 return if (!$gconfig{'userconfig'});
6385 my @uinfo = @remote_user_info ? @remote_user_info : getpwnam($remote_user);
6386 return if (!@uinfo || !$uinfo[7]);
6387 &create_missing_homedir(\@uinfo);
6388 $user_config_directory = "$uinfo[7]/$gconfig{'userconfig'}";
6389 if (!-d $user_config_directory) {
6390         mkdir($user_config_directory, 0700) ||
6391                 &error("Failed to create $user_config_directory : $!");
6392         if ($< == 0 && $uinfo[2]) {
6393                 chown($uinfo[2], $uinfo[3], $user_config_directory);
6394                 }
6395         }
6396 if (&get_module_name()) {
6397         $user_module_config_directory = $user_config_directory."/".
6398                                         &get_module_name();
6399         if (!-d $user_module_config_directory) {
6400                 mkdir($user_module_config_directory, 0700) ||
6401                         &error("Failed to create $user_module_config_directory : $!");
6402                 if ($< == 0 && $uinfo[2]) {
6403                         chown($uinfo[2], $uinfo[3], $user_config_directory);
6404                         }
6405                 }
6406         undef(%userconfig);
6407         &read_file_cached("$module_root_directory/defaultuconfig",
6408                           \%userconfig);
6409         &read_file_cached("$module_config_directory/uconfig", \%userconfig);
6410         &read_file_cached("$user_module_config_directory/config",
6411                           \%userconfig);
6412         }
6413
6414 # Export global variables to caller
6415 if ($main::export_to_caller) {
6416         my ($callpkg) = caller();
6417         foreach my $v ('$user_config_directory',
6418                        '$user_module_config_directory', '%userconfig') {
6419                 my ($vt, $vn) = split('', $v, 2);
6420                 eval "${vt}${callpkg}::${vn} = ${vt}${vn}";
6421                 }
6422         }
6423 }
6424
6425 =head2 create_missing_homedir(&uinfo)
6426
6427 If auto homedir creation is enabled, create one for this user if needed.
6428 For internal use only.
6429
6430 =cut
6431 sub create_missing_homedir
6432 {
6433 my ($uinfo) = @_;
6434 if (!-e $uinfo->[7] && $gconfig{'create_homedir'}) {
6435         # Use has no home dir .. make one
6436         system("mkdir -p ".quotemeta($uinfo->[7]));
6437         chown($uinfo->[2], $uinfo->[3], $uinfo->[7]);
6438         if ($gconfig{'create_homedir_perms'} ne '') {
6439                 chmod(oct($gconfig{'create_homedir_perms'}), $uinfo->[7]);
6440                 }
6441         }
6442 }
6443
6444 =head2 filter_javascript(text)
6445
6446 Disables all javascript <script>, onClick= and so on tags in the given HTML,
6447 and returns the new HTML. Useful for displaying HTML from an un-trusted source.
6448
6449 =cut
6450 sub filter_javascript
6451 {
6452 my ($rv) = @_;
6453 $rv =~ s/<\s*script[^>]*>([\000-\377]*?)<\s*\/script\s*>//gi;
6454 $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;
6455 $rv =~ s/(javascript:)/x$1/gi;
6456 $rv =~ s/(vbscript:)/x$1/gi;
6457 return $rv;
6458 }
6459
6460 =head2 resolve_links(path)
6461
6462 Given a path that may contain symbolic links, returns the real path.
6463
6464 =cut
6465 sub resolve_links
6466 {
6467 my ($path) = @_;
6468 $path =~ s/\/+/\//g;
6469 $path =~ s/\/$// if ($path ne "/");
6470 my @p = split(/\/+/, $path);
6471 shift(@p);
6472 for(my $i=0; $i<@p; $i++) {
6473         my $sofar = "/".join("/", @p[0..$i]);
6474         my $lnk = readlink($sofar);
6475         if ($lnk =~ /^\//) {
6476                 # Link is absolute..
6477                 return &resolve_links($lnk."/".join("/", @p[$i+1 .. $#p]));
6478                 }
6479         elsif ($lnk) {
6480                 # Link is relative
6481                 return &resolve_links("/".join("/", @p[0..$i-1])."/".$lnk."/".join("/", @p[$i+1 .. $#p]));
6482                 }
6483         }
6484 return $path;
6485 }
6486
6487 =head2 simplify_path(path, bogus)
6488
6489 Given a path, maybe containing elements ".." and "." , convert it to a
6490 clean, absolute form. Returns undef if this is not possible.
6491
6492 =cut
6493 sub simplify_path
6494 {
6495 my ($dir) = @_;
6496 $dir =~ s/^\/+//g;
6497 $dir =~ s/\/+$//g;
6498 my @bits = split(/\/+/, $dir);
6499 my @fixedbits = ();
6500 $_[1] = 0;
6501 foreach my $b (@bits) {
6502         if ($b eq ".") {
6503                 # Do nothing..
6504                 }
6505         elsif ($b eq "..") {
6506                 # Remove last dir
6507                 if (scalar(@fixedbits) == 0) {
6508                         # Cannot! Already at root!
6509                         return undef;
6510                         }
6511                 pop(@fixedbits);
6512                 }
6513         else {
6514                 # Add dir to list
6515                 push(@fixedbits, $b);
6516                 }
6517         }
6518 return "/".join('/', @fixedbits);
6519 }
6520
6521 =head2 same_file(file1, file2)
6522
6523 Returns 1 if two files are actually the same
6524
6525 =cut
6526 sub same_file
6527 {
6528 return 1 if ($_[0] eq $_[1]);
6529 return 0 if ($_[0] !~ /^\// || $_[1] !~ /^\//);
6530 my @stat1 = $stat_cache{$_[0]} ? @{$stat_cache{$_[0]}}
6531                                : (@{$stat_cache{$_[0]}} = stat($_[0]));
6532 my @stat2 = $stat_cache{$_[1]} ? @{$stat_cache{$_[1]}}
6533                                : (@{$stat_cache{$_[1]}} = stat($_[1]));
6534 return 0 if (!@stat1 || !@stat2);
6535 return $stat1[0] == $stat2[0] && $stat1[1] == $stat2[1];
6536 }
6537
6538 =head2 flush_webmin_caches
6539
6540 Clears all in-memory and on-disk caches used by Webmin.
6541
6542 =cut
6543 sub flush_webmin_caches
6544 {
6545 undef(%main::read_file_cache);
6546 undef(%main::acl_hash_cache);
6547 undef(%main::acl_array_cache);
6548 undef(%main::has_command_cache);
6549 undef(@main::list_languages_cache);
6550 undef($main::got_list_usermods_cache);
6551 undef(@main::list_usermods_cache);
6552 undef(%main::foreign_installed_cache);
6553 unlink("$config_directory/module.infos.cache");
6554 &get_all_module_infos();
6555 }
6556
6557 =head2 list_usermods
6558
6559 Returns a list of additional module restrictions. For internal use in
6560 Usermin only.
6561
6562 =cut
6563 sub list_usermods
6564 {
6565 if (!$main::got_list_usermods_cache) {
6566         @main::list_usermods_cache = ( );
6567         local $_;
6568         open(USERMODS, "$config_directory/usermin.mods");
6569         while(<USERMODS>) {
6570                 if (/^([^:]+):(\+|-|):(.*)/) {
6571                         push(@main::list_usermods_cache,
6572                              [ $1, $2, [ split(/\s+/, $3) ] ]);
6573                         }
6574                 }
6575         close(USERMODS);
6576         $main::got_list_usermods_cache = 1;
6577         }
6578 return @main::list_usermods_cache;
6579 }
6580
6581 =head2 available_usermods(&allmods, &usermods)
6582
6583 Returns a list of modules that are available to the given user, based
6584 on usermod additional/subtractions. For internal use by Usermin only.
6585
6586 =cut
6587 sub available_usermods
6588 {
6589 return @{$_[0]} if (!@{$_[1]});
6590
6591 my %mods = map { $_->{'dir'}, 1 } @{$_[0]};
6592 my @uinfo = @remote_user_info;
6593 @uinfo = getpwnam($remote_user) if (!@uinfo);
6594 foreach my $u (@{$_[1]}) {
6595         my $applies;
6596         if ($u->[0] eq "*" || $u->[0] eq $remote_user) {
6597                 $applies++;
6598                 }
6599         elsif ($u->[0] =~ /^\@(.*)$/) {
6600                 # Check for group membership
6601                 my @ginfo = getgrnam($1);
6602                 $applies++ if (@ginfo && ($ginfo[2] == $uinfo[3] ||
6603                         &indexof($remote_user, split(/\s+/, $ginfo[3])) >= 0));
6604                 }
6605         elsif ($u->[0] =~ /^\//) {
6606                 # Check users and groups in file
6607                 local $_;
6608                 open(USERFILE, $u->[0]);
6609                 while(<USERFILE>) {
6610                         tr/\r\n//d;
6611                         if ($_ eq $remote_user) {
6612                                 $applies++;
6613                                 }
6614                         elsif (/^\@(.*)$/) {
6615                                 my @ginfo = getgrnam($1);
6616                                 $applies++
6617                                   if (@ginfo && ($ginfo[2] == $uinfo[3] ||
6618                                       &indexof($remote_user,
6619                                                split(/\s+/, $ginfo[3])) >= 0));
6620                                 }
6621                         last if ($applies);
6622                         }
6623                 close(USERFILE);
6624                 }
6625         if ($applies) {
6626                 if ($u->[1] eq "+") {
6627                         map { $mods{$_}++ } @{$u->[2]};
6628                         }
6629                 elsif ($u->[1] eq "-") {
6630                         map { delete($mods{$_}) } @{$u->[2]};
6631                         }
6632                 else {
6633                         undef(%mods);
6634                         map { $mods{$_}++ } @{$u->[2]};
6635                         }
6636                 }
6637         }
6638 return grep { $mods{$_->{'dir'}} } @{$_[0]};
6639 }
6640
6641 =head2 get_available_module_infos(nocache)
6642
6643 Returns a list of modules available to the current user, based on
6644 operating system support, access control and usermod restrictions. Useful
6645 in themes that need to display a list of modules the user can use.
6646 Each element of the returned array is a hash reference in the same format as
6647 returned by get_module_info.
6648
6649 =cut
6650 sub get_available_module_infos
6651 {
6652 my (%acl, %uacl);
6653 &read_acl(\%acl, \%uacl);
6654 my $risk = $gconfig{'risk_'.$base_remote_user};
6655 my @rv;
6656 foreach my $minfo (&get_all_module_infos($_[0])) {
6657         next if (!&check_os_support($minfo));
6658         if ($risk) {
6659                 # Check module risk level
6660                 next if ($risk ne 'high' && $minfo->{'risk'} &&
6661                          $minfo->{'risk'} !~ /$risk/);
6662                 }
6663         else {
6664                 # Check user's ACL
6665                 next if (!$acl{$base_remote_user,$minfo->{'dir'}} &&
6666                          !$acl{$base_remote_user,"*"});
6667                 }
6668         next if (&is_readonly_mode() && !$minfo->{'readonly'});
6669         push(@rv, $minfo);
6670         }
6671
6672 # Check usermod restrictions
6673 my @usermods = &list_usermods();
6674 @rv = sort { $a->{'desc'} cmp $b->{'desc'} }
6675             &available_usermods(\@rv, \@usermods);
6676
6677 # Check RBAC restrictions
6678 my @rbacrv;
6679 foreach my $m (@rv) {
6680         if (&supports_rbac($m->{'dir'}) &&
6681             &use_rbac_module_acl(undef, $m->{'dir'})) {
6682                 local $rbacs = &get_rbac_module_acl($remote_user,
6683                                                     $m->{'dir'});
6684                 if ($rbacs) {
6685                         # RBAC allows
6686                         push(@rbacrv, $m);
6687                         }
6688                 }
6689         else {
6690                 # Module or system doesn't support RBAC
6691                 push(@rbacrv, $m) if (!$gconfig{'rbacdeny_'.$base_remote_user});
6692                 }
6693         }
6694
6695 # Check theme vetos
6696 my @themerv;
6697 if (defined(&theme_foreign_available)) {
6698         foreach my $m (@rbacrv) {
6699                 if (&theme_foreign_available($m->{'dir'})) {
6700                         push(@themerv, $m);
6701                         }
6702                 }
6703         }
6704 else {
6705         @themerv = @rbacrv;
6706         }
6707
6708 # Check licence module vetos
6709 my @licrv;
6710 if ($main::licence_module) {
6711         foreach my $m (@themerv) {
6712                 if (&foreign_call($main::licence_module,
6713                                   "check_module_licence", $m->{'dir'})) {
6714                         push(@licrv, $m);
6715                         }
6716                 }
6717         }
6718 else {
6719         @licrv = @themerv;
6720         }
6721
6722 return @licrv;
6723 }
6724
6725 =head2 get_visible_module_infos(nocache)
6726
6727 Like get_available_module_infos, but excludes hidden modules from the list.
6728 Each element of the returned array is a hash reference in the same format as
6729 returned by get_module_info.
6730
6731 =cut
6732 sub get_visible_module_infos
6733 {
6734 my ($nocache) = @_;
6735 my $pn = &get_product_name();
6736 return grep { !$_->{'hidden'} &&
6737               !$_->{$pn.'_hidden'} } &get_available_module_infos($nocache);
6738 }
6739
6740 =head2 get_visible_modules_categories(nocache)
6741
6742 Returns a list of Webmin module categories, each of which is a hash ref
6743 with 'code', 'desc' and 'modules' keys. The modules value is an array ref
6744 of modules in the category, in the format returned by get_module_info.
6745 Un-used modules are automatically assigned to the 'unused' category, and
6746 those with no category are put into 'others'.
6747
6748 =cut
6749 sub get_visible_modules_categories
6750 {
6751 my ($nocache) = @_;
6752 my @mods = &get_visible_module_infos($nocache);
6753 my @unmods;
6754 if (&get_product_name() eq 'webmin') {
6755         @unmods = grep { $_->{'installed'} eq '0' } @mods;
6756         @mods = grep { $_->{'installed'} ne '0' } @mods;
6757         }
6758 my %cats = &list_categories(\@mods);
6759 my @rv;
6760 foreach my $c (keys %cats) {
6761         my $cat = { 'code' => $c || 'other',
6762                     'desc' => $cats{$c} };
6763         $cat->{'modules'} = [ grep { $_->{'category'} eq $c } @mods ];
6764         push(@rv, $cat);
6765         }
6766 @rv = sort { ($b->{'code'} eq "others" ? "" : $b->{'code'}) cmp
6767              ($a->{'code'} eq "others" ? "" : $a->{'code'}) } @rv;
6768 if (@unmods) {
6769         # Add un-installed modules in magic category
6770         my $cat = { 'code' => 'unused',
6771                     'desc' => $text{'main_unused'},
6772                     'unused' => 1,
6773                     'modules' => \@unmods };
6774         push(@rv, $cat);
6775         }
6776 return @rv;
6777 }
6778
6779 =head2 is_under_directory(directory, file)
6780
6781 Returns 1 if the given file is under the specified directory, 0 if not.
6782 Symlinks are taken into account in the file to find it's 'real' location.
6783
6784 =cut
6785 sub is_under_directory
6786 {
6787 my ($dir, $file) = @_;
6788 return 1 if ($dir eq "/");
6789 return 0 if ($file =~ /\.\./);
6790 my $ld = &resolve_links($dir);
6791 if ($ld ne $dir) {
6792         return &is_under_directory($ld, $file);
6793         }
6794 my $lp = &resolve_links($file);
6795 if ($lp ne $file) {
6796         return &is_under_directory($dir, $lp);
6797         }
6798 return 0 if (length($file) < length($dir));
6799 return 1 if ($dir eq $file);
6800 $dir =~ s/\/*$/\//;
6801 return substr($file, 0, length($dir)) eq $dir;
6802 }
6803
6804 =head2 parse_http_url(url, [basehost, baseport, basepage, basessl])
6805
6806 Given an absolute URL, returns the host, port, page and ssl flag components.
6807 Relative URLs can also be parsed, if the base information is provided.
6808
6809 =cut
6810 sub parse_http_url
6811 {
6812 if ($_[0] =~ /^(http|https):\/\/([^:\/]+)(:(\d+))?(\/\S*)?$/) {
6813         # An absolute URL
6814         my $ssl = $1 eq 'https';
6815         return ($2, $3 ? $4 : $ssl ? 443 : 80, $5 || "/", $ssl);
6816         }
6817 elsif (!$_[1]) {
6818         # Could not parse
6819         return undef;
6820         }
6821 elsif ($_[0] =~ /^\/\S*$/) {
6822         # A relative to the server URL
6823         return ($_[1], $_[2], $_[0], $_[4]);
6824         }
6825 else {
6826         # A relative to the directory URL
6827         my $page = $_[3];
6828         $page =~ s/[^\/]+$//;
6829         return ($_[1], $_[2], $page.$_[0], $_[4]);
6830         }
6831 }
6832
6833 =head2 check_clicks_function
6834
6835 Returns HTML for a JavaScript function called check_clicks that returns
6836 true when first called, but false subsequently. Useful on onClick for
6837 critical buttons. Deprecated, as this method of preventing duplicate actions
6838 is un-reliable.
6839
6840 =cut
6841 sub check_clicks_function
6842 {
6843 return <<EOF;
6844 <script>
6845 clicks = 0;
6846 function check_clicks(form)
6847 {
6848 clicks++;
6849 if (clicks == 1)
6850         return true;
6851 else {
6852         if (form != null) {
6853                 for(i=0; i<form.length; i++)
6854                         form.elements[i].disabled = true;
6855                 }
6856         return false;
6857         }
6858 }
6859 </script>
6860 EOF
6861 }
6862
6863 =head2 load_entities_map
6864
6865 Returns a hash ref containing mappings between HTML entities (like ouml) and
6866 ascii values (like 246). Mainly for internal use.
6867
6868 =cut
6869 sub load_entities_map
6870 {
6871 if (!defined(%entities_map_cache)) {
6872         local $_;
6873         open(EMAP, "$root_directory/entities_map.txt");
6874         while(<EMAP>) {
6875                 if (/^(\d+)\s+(\S+)/) {
6876                         $entities_map_cache{$2} = $1;
6877                         }
6878                 }
6879         close(EMAP);
6880         }
6881 return \%entities_map_cache;
6882 }
6883
6884 =head2 entities_to_ascii(string)
6885
6886 Given a string containing HTML entities like &ouml; and &#55;, replace them
6887 with their ASCII equivalents.
6888
6889 =cut
6890 sub entities_to_ascii
6891 {
6892 my ($str) = @_;
6893 my $emap = &load_entities_map();
6894 $str =~ s/&([a-z]+);/chr($emap->{$1})/ge;
6895 $str =~ s/&#(\d+);/chr($1)/ge;
6896 return $str;
6897 }
6898
6899 =head2 get_product_name
6900
6901 Returns either 'webmin' or 'usermin', depending on which program the current
6902 module is in. Useful for modules that can be installed into either.
6903
6904 =cut
6905 sub get_product_name
6906 {
6907 return $gconfig{'product'} if (defined($gconfig{'product'}));
6908 return defined($gconfig{'userconfig'}) ? 'usermin' : 'webmin';
6909 }
6910
6911 =head2 get_charset
6912
6913 Returns the character set for the current language, such as iso-8859-1.
6914
6915 =cut
6916 sub get_charset
6917 {
6918 my $charset = defined($gconfig{'charset'}) ? $gconfig{'charset'} :
6919                  $current_lang_info->{'charset'} ?
6920                  $current_lang_info->{'charset'} : $default_charset;
6921 return $charset;
6922 }
6923
6924 =head2 get_display_hostname
6925
6926 Returns the system's hostname for UI display purposes. This may be different
6927 from the actual hostname if you administrator has configured it so in the
6928 Webmin Configuration module.
6929
6930 =cut
6931 sub get_display_hostname
6932 {
6933 if ($gconfig{'hostnamemode'} == 0) {
6934         return &get_system_hostname();
6935         }
6936 elsif ($gconfig{'hostnamemode'} == 3) {
6937         return $gconfig{'hostnamedisplay'};
6938         }
6939 else {
6940         my $h = $ENV{'HTTP_HOST'};
6941         $h =~ s/:\d+//g;
6942         if ($gconfig{'hostnamemode'} == 2) {
6943                 $h =~ s/^(www|ftp|mail)\.//i;
6944                 }
6945         return $h;
6946         }
6947 }
6948
6949 =head2 save_module_config([&config], [modulename])
6950
6951 Saves the configuration for some module. The config parameter is an optional
6952 hash reference of names and values to save, which defaults to the global
6953 %config hash. The modulename parameter is the module to update the config
6954 file, which defaults to the current module.
6955
6956 =cut
6957 sub save_module_config
6958 {
6959 my $c = $_[0] || { &get_module_variable('%config') };
6960 my $m = defined($_[1]) ? $_[1] : &get_module_name();
6961 &write_file("$config_directory/$m/config", $c);
6962 }
6963
6964 =head2 save_user_module_config([&config], [modulename])
6965
6966 Saves the user's Usermin preferences for some module. The config parameter is
6967 an optional hash reference of names and values to save, which defaults to the
6968 global %userconfig hash. The modulename parameter is the module to update the
6969 config file, which defaults to the current module.
6970
6971 =cut
6972 sub save_user_module_config
6973 {
6974 my $c = $_[0] || { &get_module_variable('%userconfig') };
6975 my $m = $_[1] || &get_module_name();
6976 my $ucd = $user_config_directory;
6977 if (!$ucd) {
6978         my @uinfo = @remote_user_info ? @remote_user_info
6979                                       : getpwnam($remote_user);
6980         return if (!@uinfo || !$uinfo[7]);
6981         $ucd = "$uinfo[7]/$gconfig{'userconfig'}";
6982         }
6983 &write_file("$ucd/$m/config", $c);
6984 }
6985
6986 =head2 nice_size(bytes, [min])
6987
6988 Converts a number of bytes into a number followed by a suffix like GB, MB
6989 or kB. Rounding is to two decimal digits. The optional min parameter sets the
6990 smallest units to use - so you could pass 1024*1024 to never show bytes or kB.
6991
6992 =cut
6993 sub nice_size
6994 {
6995 my ($units, $uname);
6996 if (abs($_[0]) > 1024*1024*1024*1024 || $_[1] >= 1024*1024*1024*1024) {
6997         $units = 1024*1024*1024*1024;
6998         $uname = "TB";
6999         }
7000 elsif (abs($_[0]) > 1024*1024*1024 || $_[1] >= 1024*1024*1024) {
7001         $units = 1024*1024*1024;
7002         $uname = "GB";
7003         }
7004 elsif (abs($_[0]) > 1024*1024 || $_[1] >= 1024*1024) {
7005         $units = 1024*1024;
7006         $uname = "MB";
7007         }
7008 elsif (abs($_[0]) > 1024 || $_[1] >= 1024) {
7009         $units = 1024;
7010         $uname = "kB";
7011         }
7012 else {
7013         $units = 1;
7014         $uname = "bytes";
7015         }
7016 my $sz = sprintf("%.2f", ($_[0]*1.0 / $units));
7017 $sz =~ s/\.00$//;
7018 return $sz." ".$uname;
7019 }
7020
7021 =head2 get_perl_path
7022
7023 Returns the path to Perl currently in use, such as /usr/bin/perl.
7024
7025 =cut
7026 sub get_perl_path
7027 {
7028 if (open(PERL, "$config_directory/perl-path")) {
7029         my $rv;
7030         chop($rv = <PERL>);
7031         close(PERL);
7032         return $rv;
7033         }
7034 return $^X if (-x $^X);
7035 return &has_command("perl");
7036 }
7037
7038 =head2 get_goto_module([&mods])
7039
7040 Returns the details of a module that the current user should be re-directed
7041 to after logging in, or undef if none. Useful for themes.
7042
7043 =cut
7044 sub get_goto_module
7045 {
7046 my @mods = $_[0] ? @{$_[0]} : &get_visible_module_infos();
7047 if ($gconfig{'gotomodule'}) {
7048         my ($goto) = grep { $_->{'dir'} eq $gconfig{'gotomodule'} } @mods;
7049         return $goto if ($goto);
7050         }
7051 if (@mods == 1 && $gconfig{'gotoone'}) {
7052         return $mods[0];
7053         }
7054 return undef;
7055 }
7056
7057 =head2 select_all_link(field, form, [text])
7058
7059 Returns HTML for a 'Select all' link that uses Javascript to select
7060 multiple checkboxes with the same name. The parameters are :
7061
7062 =item field - Name of the checkbox inputs.
7063
7064 =item form - Index of the form on the page.
7065
7066 =item text - Message for the link, defaulting to 'Select all'.
7067
7068 =cut
7069 sub select_all_link
7070 {
7071 return &theme_select_all_link(@_) if (defined(&theme_select_all_link));
7072 my ($field, $form, $text) = @_;
7073 $form = int($form);
7074 $text ||= $text{'ui_selall'};
7075 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>";
7076 }
7077
7078 =head2 select_invert_link(field, form, text)
7079
7080 Returns HTML for an 'Invert selection' link that uses Javascript to invert the
7081 selection on multiple checkboxes with the same name. The parameters are :
7082
7083 =item field - Name of the checkbox inputs.
7084
7085 =item form - Index of the form on the page.
7086
7087 =item text - Message for the link, defaulting to 'Invert selection'.
7088
7089 =cut
7090 sub select_invert_link
7091 {
7092 return &theme_select_invert_link(@_) if (defined(&theme_select_invert_link));
7093 my ($field, $form, $text) = @_;
7094 $form = int($form);
7095 $text ||= $text{'ui_selinv'};
7096 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>";
7097 }
7098
7099 =head2 select_rows_link(field, form, text, &rows)
7100
7101 Returns HTML for a link that uses Javascript to select rows with particular
7102 values for their checkboxes. The parameters are :
7103
7104 =item field - Name of the checkbox inputs.
7105
7106 =item form - Index of the form on the page.
7107
7108 =item text - Message for the link, de
7109
7110 =item rows - Reference to an array of 1 or 0 values, indicating which rows to check.
7111
7112 =cut
7113 sub select_rows_link
7114 {
7115 return &theme_select_rows_link(@_) if (defined(&theme_select_rows_link));
7116 my ($field, $form, $text, $rows) = @_;
7117 $form = int($form);
7118 my $js = "var sel = { ".join(",", map { "\"".&quote_escape($_)."\":1" } @$rows)." }; ";
7119 $js .= "for(var i=0; i<document.forms[$form].${field}.length; i++) { var r = document.forms[$form].${field}[i]; r.checked = sel[r.value]; } ";
7120 $js .= "return false;";
7121 return "<a href='#' onClick='$js'>$text</a>";
7122 }
7123
7124 =head2 check_pid_file(file)
7125
7126 Given a pid file, returns the PID it contains if the process is running.
7127
7128 =cut
7129 sub check_pid_file
7130 {
7131 open(PIDFILE, $_[0]) || return undef;
7132 my $pid = <PIDFILE>;
7133 close(PIDFILE);
7134 $pid =~ /^\s*(\d+)/ || return undef;
7135 kill(0, $1) || return undef;
7136 return $1;
7137 }
7138
7139 =head2 get_mod_lib
7140
7141 Return the local os-specific library name to this module. For internal use only.
7142
7143 =cut
7144 sub get_mod_lib
7145 {
7146 my $mn = &get_module_name();
7147 my $md = &module_root_directory($mn);
7148 if (-r "$md/$mn-$gconfig{'os_type'}-$gconfig{'os_version'}-lib.pl") {
7149         return "$mn-$gconfig{'os_type'}-$gconfig{'os_version'}-lib.pl";
7150         }
7151 elsif (-r "$md/$mn-$gconfig{'os_type'}-lib.pl") {
7152         return "$mn-$gconfig{'os_type'}-lib.pl";
7153         }
7154 elsif (-r "$md/$mn-generic-lib.pl") {
7155         return "$mn-generic-lib.pl";
7156         }
7157 else {
7158         return "";
7159         }
7160 }
7161
7162 =head2 module_root_directory(module)
7163
7164 Given a module name, returns its root directory. On a typical Webmin install,
7165 all modules are under the same directory - but it is theoretically possible to
7166 have more than one.
7167
7168 =cut
7169 sub module_root_directory
7170 {
7171 my $d = ref($_[0]) ? $_[0]->{'dir'} : $_[0];
7172 if (@root_directories > 1) {
7173         foreach my $r (@root_directories) {
7174                 if (-d "$r/$d") {
7175                         return "$r/$d";
7176                         }
7177                 }
7178         }
7179 return "$root_directories[0]/$d";
7180 }
7181
7182 =head2 list_mime_types
7183
7184 Returns a list of all known MIME types and their extensions, as a list of hash
7185 references with keys :
7186
7187 =item type - The MIME type, like text/plain.
7188
7189 =item exts - A list of extensions, like .doc and .avi.
7190
7191 =item desc - A human-readable description for the MIME type.
7192
7193 =cut
7194 sub list_mime_types
7195 {
7196 if (!@list_mime_types_cache) {
7197         local $_;
7198         open(MIME, "$root_directory/mime.types");
7199         while(<MIME>) {
7200                 my $cmt;
7201                 s/\r|\n//g;
7202                 if (s/#\s*(.*)$//g) {
7203                         $cmt = $1;
7204                         }
7205                 my ($type, @exts) = split(/\s+/);
7206                 if ($type) {
7207                         push(@list_mime_types_cache, { 'type' => $type,
7208                                                        'exts' => \@exts,
7209                                                        'desc' => $cmt });
7210                         }
7211                 }
7212         close(MIME);
7213         }
7214 return @list_mime_types_cache;
7215 }
7216
7217 =head2 guess_mime_type(filename, [default])
7218
7219 Given a file name like xxx.gif or foo.html, returns a guessed MIME type.
7220 The optional default parameter sets a default type of use if none is found,
7221 which defaults to application/octet-stream.
7222
7223 =cut
7224 sub guess_mime_type
7225 {
7226 if ($_[0] =~ /\.([A-Za-z0-9\-]+)$/) {
7227         my $ext = $1;
7228         foreach my $t (&list_mime_types()) {
7229                 foreach my $e (@{$t->{'exts'}}) {
7230                         return $t->{'type'} if (lc($e) eq lc($ext));
7231                         }
7232                 }
7233         }
7234 return @_ > 1 ? $_[1] : "application/octet-stream";
7235 }
7236
7237 =head2 open_tempfile([handle], file, [no-error], [no-tempfile], [safe?])
7238
7239 Opens a file handle for writing to a temporary file, which will only be
7240 renamed over the real file when the handle is closed. This allows critical
7241 files like /etc/shadow to be updated safely, even if writing fails part way
7242 through due to lack of disk space. The parameters are :
7243
7244 =item handle - File handle to open, as you would use in Perl's open function.
7245
7246 =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.
7247
7248 =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.
7249
7250 =item no-tempfile - If set to 1, writing will be direct to the file instead of using a temporary file.
7251
7252 =item safe - Indicates to users in read-only mode that this write is safe and non-destructive.
7253
7254 =cut
7255 sub open_tempfile
7256 {
7257 if (@_ == 1) {
7258         # Just getting a temp file
7259         if (!defined($main::open_tempfiles{$_[0]})) {
7260                 $_[0] =~ /^(.*)\/(.*)$/ || return $_[0];
7261                 my $dir = $1 || "/";
7262                 my $tmp = "$dir/$2.webmintmp.$$";
7263                 $main::open_tempfiles{$_[0]} = $tmp;
7264                 push(@main::temporary_files, $tmp);
7265                 }
7266         return $main::open_tempfiles{$_[0]};
7267         }
7268 else {
7269         # Actually opening
7270         my ($fh, $file, $noerror, $notemp, $safe) = @_;
7271         $fh = &callers_package($fh);
7272
7273         my %gaccess = &get_module_acl(undef, "");
7274         my $db = $gconfig{'debug_what_write'};
7275         if ($file =~ /\r|\n|\0/) {
7276                 if ($noerror) { return 0; }
7277                 else { &error("Filename contains invalid characters"); }
7278                 }
7279         if (&is_readonly_mode() && $file =~ />/ && !$safe) {
7280                 # Read-only mode .. veto all writes
7281                 print STDERR "vetoing write to $file\n";
7282                 return open($fh, ">$null_file");
7283                 }
7284         elsif ($file =~ /^(>|>>|)nul$/i) {
7285                 # Write to Windows null device
7286                 &webmin_debug_log($1 eq ">" ? "WRITE" :
7287                           $l eq ">>" ? "APPEND" : "READ", "nul") if ($db);
7288                 }
7289         elsif ($file =~ /^(>|>>)(\/dev\/.*)/ || lc($file) eq "nul") {
7290                 # Writes to /dev/null or TTYs don't need to be handled
7291                 &webmin_debug_log($1 eq ">" ? "WRITE" : "APPEND", $2) if ($db);
7292                 return open($fh, $file);
7293                 }
7294         elsif ($file =~ /^>\s*(([a-zA-Z]:)?\/.*)$/ && !$notemp) {
7295                 &webmin_debug_log("WRITE", $1) if ($db);
7296                 # Over-writing a file, via a temp file
7297                 $file = $1;
7298                 $file = &translate_filename($file);
7299                 while(-l $file) {
7300                         # Open the link target instead
7301                         $file = &resolve_links($file);
7302                         }
7303                 if (-d $file) {
7304                         # Cannot open a directory!
7305                         if ($noerror) { return 0; }
7306                         else { &error("Cannot write to directory $file"); }
7307                         }
7308                 my $tmp = &open_tempfile($file);
7309                 my $ex = open($fh, ">$tmp");
7310                 if (!$ex && $! =~ /permission/i) {
7311                         # Could not open temp file .. try opening actual file
7312                         # instead directly
7313                         $ex = open($fh, ">$file");
7314                         delete($main::open_tempfiles{$file});
7315                         }
7316                 else {
7317                         $main::open_temphandles{$fh} = $file;
7318                         }
7319                 binmode($fh);
7320                 if (!$ex && !$noerror) {
7321                         &error(&text("efileopen", $file, $!));
7322                         }
7323                 return $ex;
7324                 }
7325         elsif ($file =~ /^>\s*(([a-zA-Z]:)?\/.*)$/ && $notemp) {
7326                 # Just writing direct to a file
7327                 &webmin_debug_log("WRITE", $1) if ($db);
7328                 $file = $1;
7329                 $file = &translate_filename($file);
7330                 my @old_attributes = &get_clear_file_attributes($file);
7331                 my $ex = open($fh, ">$file");
7332                 &reset_file_attributes($file, \@old_attributes);
7333                 $main::open_temphandles{$fh} = $file;
7334                 if (!$ex && !$noerror) {
7335                         &error(&text("efileopen", $file, $!));
7336                         }
7337                 binmode($fh);
7338                 return $ex;
7339                 }
7340         elsif ($file =~ /^>>\s*(([a-zA-Z]:)?\/.*)$/) {
7341                 # Appending to a file .. nothing special to do
7342                 &webmin_debug_log("APPEND", $1) if ($db);
7343                 $file = $1;
7344                 $file = &translate_filename($file);
7345                 my @old_attributes = &get_clear_file_attributes($file);
7346                 my $ex = open($fh, ">>$file");
7347                 &reset_file_attributes($file, \@old_attributes);
7348                 $main::open_temphandles{$fh} = $file;
7349                 if (!$ex && !$noerror) {
7350                         &error(&text("efileopen", $file, $!));
7351                         }
7352                 binmode($fh);
7353                 return $ex;
7354                 }
7355         elsif ($file =~ /^([a-zA-Z]:)?\//) {
7356                 # Read mode .. nothing to do here
7357                 &webmin_debug_log("READ", $file) if ($db);
7358                 $file = &translate_filename($file);
7359                 return open($fh, $file);
7360                 }
7361         elsif ($file eq ">" || $file eq ">>") {
7362                 my ($package, $filename, $line) = caller;
7363                 if ($noerror) { return 0; }
7364                 else { &error("Missing file to open at ${package}::${filename} line $line"); }
7365                 }
7366         else {
7367                 my ($package, $filename, $line) = caller;
7368                 &error("Unsupported file or mode $file at ${package}::${filename} line $line");
7369                 }
7370         }
7371 }
7372
7373 =head2 close_tempfile(file|handle)
7374
7375 Copies a temp file to the actual file, assuming that all writes were
7376 successful. The handle must have been one passed to open_tempfile.
7377
7378 =cut
7379 sub close_tempfile
7380 {
7381 my $file;
7382 my $fh = &callers_package($_[0]);
7383
7384 if (defined($file = $main::open_temphandles{$fh})) {
7385         # Closing a handle
7386         close($fh) || &error(&text("efileclose", $file, $!));
7387         delete($main::open_temphandles{$fh});
7388         return &close_tempfile($file);
7389         }
7390 elsif (defined($main::open_tempfiles{$_[0]})) {
7391         # Closing a file
7392         &webmin_debug_log("CLOSE", $_[0]) if ($gconfig{'debug_what_write'});
7393         my @st = stat($_[0]);
7394         if (&is_selinux_enabled() && &has_command("chcon")) {
7395                 # Set original security context
7396                 system("chcon --reference=".quotemeta($_[0]).
7397                        " ".quotemeta($main::open_tempfiles{$_[0]}).
7398                        " >/dev/null 2>&1");
7399                 }
7400         my @old_attributes = &get_clear_file_attributes($_[0]);
7401         rename($main::open_tempfiles{$_[0]}, $_[0]) || &error("Failed to replace $_[0] with $main::open_tempfiles{$_[0]} : $!");
7402         if (@st) {
7403                 # Set original permissions and ownership
7404                 chmod($st[2], $_[0]);
7405                 chown($st[4], $st[5], $_[0]);
7406                 }
7407         &reset_file_attributes($_[0], \@old_attributes);
7408         delete($main::open_tempfiles{$_[0]});
7409         @main::temporary_files = grep { $_ ne $main::open_tempfiles{$_[0]} } @main::temporary_files;
7410         if ($main::open_templocks{$_[0]}) {
7411                 &unlock_file($_[0]);
7412                 delete($main::open_templocks{$_[0]});
7413                 }
7414         return 1;
7415         }
7416 else {
7417         # Must be closing a handle not associated with a file
7418         close($_[0]);
7419         return 1;
7420         }
7421 }
7422
7423 =head2 print_tempfile(handle, text, ...)
7424
7425 Like the normal print function, but calls &error on failure. Useful when
7426 combined with open_tempfile, to ensure that a criticial file is never
7427 only partially written.
7428
7429 =cut
7430 sub print_tempfile
7431 {
7432 my ($fh, @args) = @_;
7433 $fh = &callers_package($fh);
7434 (print $fh @args) || &error(&text("efilewrite",
7435                             $main::open_temphandles{$fh} || $fh, $!));
7436 }
7437
7438 =head2 is_selinux_enabled
7439
7440 Returns 1 if SElinux is supported on this system and enabled, 0 if not.
7441
7442 =cut
7443 sub is_selinux_enabled
7444 {
7445 if (!defined($main::selinux_enabled_cache)) {
7446         my %seconfig;
7447         if ($gconfig{'os_type'} !~ /-linux$/) {
7448                 # Not on linux, so no way
7449                 $main::selinux_enabled_cache = 0;
7450                 }
7451         elsif (&read_env_file("/etc/selinux/config", \%seconfig)) {
7452                 # Use global config file
7453                 $main::selinux_enabled_cache =
7454                         $seconfig{'SELINUX'} eq 'disabled' ||
7455                         !$seconfig{'SELINUX'} ? 0 : 1;
7456                 }
7457         else {
7458                 # Use selinuxenabled command
7459                 #$selinux_enabled_cache =
7460                 #       system("selinuxenabled >/dev/null 2>&1") ? 0 : 1;
7461                 $main::selinux_enabled_cache = 0;
7462                 }
7463         }
7464 return $main::selinux_enabled_cache;
7465 }
7466
7467 =head2 get_clear_file_attributes(file)
7468
7469 Finds file attributes that may prevent writing, clears them and returns them
7470 as a list. May call error. Mainly for internal use by open_tempfile and
7471 close_tempfile.
7472
7473 =cut
7474 sub get_clear_file_attributes
7475 {
7476 my ($file) = @_;
7477 my @old_attributes;
7478 if ($gconfig{'chattr'}) {
7479         # Get original immutable bit
7480         my $out = &backquote_command(
7481                 "lsattr ".quotemeta($file)." 2>/dev/null");
7482         if (!$?) {
7483                 $out =~ s/\s\S+\n//;
7484                 @old_attributes = grep { $_ ne '-' } split(//, $out);
7485                 }
7486         if (&indexof("i", @old_attributes) >= 0) {
7487                 my $err = &backquote_logged(
7488                         "chattr -i ".quotemeta($file)." 2>&1");
7489                 if ($?) {
7490                         &error("Failed to remove immutable bit on ".
7491                                "$file : $err");
7492                         }
7493                 }
7494         }
7495 return @old_attributes;
7496 }
7497
7498 =head2 reset_file_attributes(file, &attributes)
7499
7500 Put back cleared attributes on some file. May call error. Mainly for internal
7501 use by close_tempfile.
7502
7503 =cut
7504 sub reset_file_attributes
7505 {
7506 my ($file, $old_attributes) = @_;
7507 if (&indexof("i", @$old_attributes) >= 0) {
7508         my $err = &backquote_logged(
7509                 "chattr +i ".quotemeta($file)." 2>&1");
7510         if ($?) {
7511                 &error("Failed to restore immutable bit on ".
7512                        "$file : $err");
7513                 }
7514         }
7515 }
7516
7517 =head2 cleanup_tempnames
7518
7519 Remove all temporary files generated using transname. Typically only called
7520 internally when a Webmin script exits.
7521
7522 =cut
7523 sub cleanup_tempnames
7524 {
7525 foreach my $t (@main::temporary_files) {
7526         &unlink_file($t);
7527         }
7528 @main::temporary_files = ( );
7529 }
7530
7531 =head2 open_lock_tempfile([handle], file, [no-error])
7532
7533 Returns a temporary file for writing to some actual file, and also locks it.
7534 Effectively the same as calling lock_file and open_tempfile on the same file,
7535 but calls the unlock for you automatically when it is closed.
7536
7537 =cut
7538 sub open_lock_tempfile
7539 {
7540 my ($fh, $file, $noerror, $notemp, $safe) = @_;
7541 $fh = &callers_package($fh);
7542 my $lockfile = $file;
7543 $lockfile =~ s/^[^\/]*//;
7544 if ($lockfile =~ /^\//) {
7545         $main::open_templocks{$lockfile} = &lock_file($lockfile);
7546         }
7547 return &open_tempfile($fh, $file, $noerror, $notemp, $safe);
7548 }
7549
7550 sub END
7551 {
7552 $main::end_exit_status ||= $?;
7553 if ($$ == $main::initial_process_id) {
7554         # Exiting from initial process
7555         &cleanup_tempnames();
7556         if ($gconfig{'debug_what_start'} && $main::debug_log_start_time &&
7557             $main::debug_log_start_module eq &get_module_name()) {
7558                 my $len = time() - $main::debug_log_start_time;
7559                 &webmin_debug_log("STOP", "runtime=$len");
7560                 $main::debug_log_start_time = 0;
7561                 }
7562         if (!$ENV{'SCRIPT_NAME'} &&
7563             $main::initial_module_name eq &get_module_name()) {
7564                 # In a command-line script - call the real exit, so that the
7565                 # exit status gets properly propogated. In some cases this
7566                 # was not happening.
7567                 exit($main::end_exit_status);
7568                 }
7569         }
7570 }
7571
7572 =head2 month_to_number(month)
7573
7574 Converts a month name like feb to a number like 1.
7575
7576 =cut
7577 sub month_to_number
7578 {
7579 return $month_to_number_map{lc(substr($_[0], 0, 3))};
7580 }
7581
7582 =head2 number_to_month(number)
7583
7584 Converts a number like 1 to a month name like Feb.
7585
7586 =cut
7587 sub number_to_month
7588 {
7589 return ucfirst($number_to_month_map{$_[0]});
7590 }
7591
7592 =head2 get_rbac_module_acl(user, module)
7593
7594 Returns a hash reference of RBAC overrides ACLs for some user and module.
7595 May return undef if none exist (indicating access denied), or the string *
7596 if full access is granted.
7597
7598 =cut
7599 sub get_rbac_module_acl
7600 {
7601 my ($user, $mod) = @_;
7602 eval "use Authen::SolarisRBAC";
7603 return undef if ($@);
7604 my %rv;
7605 my $foundany = 0;
7606 if (Authen::SolarisRBAC::chkauth("webmin.$mod.admin", $user)) {
7607         # Automagic webmin.modulename.admin authorization exists .. allow access
7608         $foundany = 1;
7609         if (!Authen::SolarisRBAC::chkauth("webmin.$mod.config", $user)) {
7610                 %rv = ( 'noconfig' => 1 );
7611                 }
7612         else {
7613                 %rv = ( );
7614                 }
7615         }
7616 local $_;
7617 open(RBAC, &module_root_directory($mod)."/rbac-mapping");
7618 while(<RBAC>) {
7619         s/\r|\n//g;
7620         s/#.*$//;
7621         my ($auths, $acls) = split(/\s+/, $_);
7622         my @auths = split(/,/, $auths);
7623         next if (!$auths);
7624         my ($merge) = ($acls =~ s/^\+//);
7625         my $gotall = 1;
7626         if ($auths eq "*") {
7627                 # These ACLs apply to all RBAC users.
7628                 # Only if there is some that match a specific authorization
7629                 # later will they be used though.
7630                 }
7631         else {
7632                 # Check each of the RBAC authorizations
7633                 foreach my $a (@auths) {
7634                         if (!Authen::SolarisRBAC::chkauth($a, $user)) {
7635                                 $gotall = 0;
7636                                 last;
7637                                 }
7638                         }
7639                 $foundany++ if ($gotall);
7640                 }
7641         if ($gotall) {
7642                 # Found an RBAC authorization - return the ACLs
7643                 return "*" if ($acls eq "*");
7644                 my %acl = map { split(/=/, $_, 2) } split(/,/, $acls);
7645                 if ($merge) {
7646                         # Just add to current set
7647                         foreach my $a (keys %acl) {
7648                                 $rv{$a} = $acl{$a};
7649                                 }
7650                         }
7651                 else {
7652                         # Found final ACLs
7653                         return \%acl;
7654                         }
7655                 }
7656         }
7657 close(RBAC);
7658 return !$foundany ? undef : defined(%rv) ? \%rv : undef;
7659 }
7660
7661 =head2 supports_rbac([module])
7662
7663 Returns 1 if RBAC client support is available, such as on Solaris.
7664
7665 =cut
7666 sub supports_rbac
7667 {
7668 return 0 if ($gconfig{'os_type'} ne 'solaris');
7669 eval "use Authen::SolarisRBAC";
7670 return 0 if ($@);
7671 if ($_[0]) {
7672         #return 0 if (!-r &module_root_directory($_[0])."/rbac-mapping");
7673         }
7674 return 1;
7675 }
7676
7677 =head2 use_rbac_module_acl(user, module)
7678
7679 Returns 1 if some user should use RBAC to get permissions for a module
7680
7681 =cut
7682 sub use_rbac_module_acl
7683 {
7684 my $u = defined($_[0]) ? $_[0] : $base_remote_user;
7685 my $m = defined($_[1]) ? $_[1] : &get_module_name();
7686 return 1 if ($gconfig{'rbacdeny_'.$u});         # RBAC forced for user
7687 my %access = &get_module_acl($u, $m, 1);
7688 return $access{'rbac'} ? 1 : 0;
7689 }
7690
7691 =head2 execute_command(command, stdin, stdout, stderr, translate-files?, safe?)
7692
7693 Runs some command, possibly feeding it input and capturing output to the
7694 give files or scalar references. The parameters are :
7695
7696 =item command - Full command to run, possibly including shell meta-characters.
7697
7698 =item stdin - File to read input from, or a scalar ref containing input, or undef if no input should be given.
7699
7700 =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.
7701
7702 =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.
7703
7704 =item translate-files - Set to 1 to apply filename translation to any filenames. Usually has no effect.
7705
7706 =item safe - Set to 1 if this command is safe and does not modify the state of the system.
7707
7708 =cut
7709 sub execute_command
7710 {
7711 my ($cmd, $stdin, $stdout, $stderr, $trans, $safe) = @_;
7712 if (&is_readonly_mode() && !$safe) {
7713         print STDERR "Vetoing command $_[0]\n";
7714         $? = 0;
7715         return 0;
7716         }
7717 my $cmd = &translate_command($cmd);
7718
7719 # Use ` operator where possible
7720 if (!$stdin && ref($stdout) && !$stderr) {
7721         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
7722         $$stdout = `$cmd 2>$null_file`;
7723         return $?;
7724         }
7725 elsif (!$stdin && ref($stdout) && $stdout eq $stderr) {
7726         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
7727         $$stdout = `$cmd 2>&1`;
7728         return $?;
7729         }
7730 elsif (!$stdin && !$stdout && !$stderr) {
7731         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
7732         return system("$cmd >$null_file 2>$null_file <$null_file");
7733         }
7734 &webmin_debug_log('CMD', "cmd=$cmd") if ($gconfig{'debug_what_cmd'});
7735
7736 # Setup pipes
7737 $| = 1;         # needed on some systems to flush before forking
7738 pipe(EXECSTDINr, EXECSTDINw);
7739 pipe(EXECSTDOUTr, EXECSTDOUTw);
7740 pipe(EXECSTDERRr, EXECSTDERRw);
7741 my $pid;
7742 if (!($pid = fork())) {
7743         untie(*STDIN);
7744         untie(*STDOUT);
7745         untie(*STDERR);
7746         open(STDIN, "<&EXECSTDINr");
7747         open(STDOUT, ">&EXECSTDOUTw");
7748         if (ref($stderr) && $stderr eq $stdout) {
7749                 open(STDERR, ">&EXECSTDOUTw");
7750                 }
7751         else {
7752                 open(STDERR, ">&EXECSTDERRw");
7753                 }
7754         $| = 1;
7755         close(EXECSTDINw);
7756         close(EXECSTDOUTr);
7757         close(EXECSTDERRr);
7758
7759         my $fullcmd = "($cmd)";
7760         if ($stdin && !ref($stdin)) {
7761                 $fullcmd .= " <$stdin";
7762                 }
7763         if ($stdout && !ref($stdout)) {
7764                 $fullcmd .= " >$stdout";
7765                 }
7766         if ($stderr && !ref($stderr)) {
7767                 if ($stderr eq $stdout) {
7768                         $fullcmd .= " 2>&1";
7769                         }
7770                 else {
7771                         $fullcmd .= " 2>$stderr";
7772                         }
7773                 }
7774         if ($gconfig{'os_type'} eq 'windows') {
7775                 exec($fullcmd);
7776                 }
7777         else {
7778                 exec("/bin/sh", "-c", $fullcmd);
7779                 }
7780         print "Exec failed : $!\n";
7781         exit(1);
7782         }
7783 close(EXECSTDINr);
7784 close(EXECSTDOUTw);
7785 close(EXECSTDERRw);
7786
7787 # Feed input and capture output
7788 local $_;
7789 if ($stdin && ref($stdin)) {
7790         print EXECSTDINw $$stdin;
7791         close(EXECSTDINw);
7792         }
7793 if ($stdout && ref($stdout)) {
7794         $$stdout = undef;
7795         while(<EXECSTDOUTr>) {
7796                 $$stdout .= $_;
7797                 }
7798         close(EXECSTDOUTr);
7799         }
7800 if ($stderr && ref($stderr) && $stderr ne $stdout) {
7801         $$stderr = undef;
7802         while(<EXECSTDERRr>) {
7803                 $$stderr .= $_;
7804                 }
7805         close(EXECSTDERRr);
7806         }
7807
7808 # Get exit status
7809 waitpid($pid, 0);
7810 return $?;
7811 }
7812
7813 =head2 open_readfile(handle, file)
7814
7815 Opens some file for reading. Returns 1 on success, 0 on failure. Pretty much
7816 exactly the same as Perl's open function.
7817
7818 =cut
7819 sub open_readfile
7820 {
7821 my ($fh, $file) = @_;
7822 $fh = &callers_package($fh);
7823 my $realfile = &translate_filename($file);
7824 &webmin_debug_log('READ', $file) if ($gconfig{'debug_what_read'});
7825 return open($fh, "<".$realfile);
7826 }
7827
7828 =head2 open_execute_command(handle, command, output?, safe?)
7829
7830 Runs some command, with the specified file handle set to either write to it if
7831 in-or-out is set to 0, or read to it if output is set to 1. The safe flag
7832 indicates if the command modifies the state of the system or not.
7833
7834 =cut
7835 sub open_execute_command
7836 {
7837 my ($fh, $cmd, $mode, $safe) = @_;
7838 $fh = &callers_package($fh);
7839 my $realcmd = &translate_command($cmd);
7840 if (&is_readonly_mode() && !$safe) {
7841         # Don't actually run it
7842         print STDERR "vetoing command $cmd\n";
7843         $? = 0;
7844         if ($mode == 0) {
7845                 return open($fh, ">$null_file");
7846                 }
7847         else {
7848                 return open($fh, $null_file);
7849                 }
7850         }
7851 # Really run it
7852 &webmin_debug_log('CMD', "cmd=$realcmd mode=$mode")
7853         if ($gconfig{'debug_what_cmd'});
7854 if ($mode == 0) {
7855         return open($fh, "| $cmd");
7856         }
7857 elsif ($mode == 1) {
7858         return open($fh, "$cmd 2>$null_file |");
7859         }
7860 elsif ($mode == 2) {
7861         return open($fh, "$cmd 2>&1 |");
7862         }
7863 }
7864
7865 =head2 translate_filename(filename)
7866
7867 Applies all relevant registered translation functions to a filename. Mostly
7868 for internal use, and typically does nothing.
7869
7870 =cut
7871 sub translate_filename
7872 {
7873 my ($realfile) = @_;
7874 my @funcs = grep { $_->[0] eq &get_module_name() ||
7875                    !defined($_->[0]) } @main::filename_callbacks;
7876 foreach my $f (@funcs) {
7877         my $func = $f->[1];
7878         $realfile = &$func($realfile, @{$f->[2]});
7879         }
7880 return $realfile;
7881 }
7882
7883 =head2 translate_command(filename)
7884
7885 Applies all relevant registered translation functions to a command. Mostly
7886 for internal use, and typically does nothing.
7887
7888 =cut
7889 sub translate_command
7890 {
7891 my ($realcmd) = @_;
7892 my @funcs = grep { $_->[0] eq &get_module_name() ||
7893                    !defined($_->[0]) } @main::command_callbacks;
7894 foreach my $f (@funcs) {
7895         my $func = $f->[1];
7896         $realcmd = &$func($realcmd, @{$f->[2]});
7897         }
7898 return $realcmd;
7899 }
7900
7901 =head2 register_filename_callback(module|undef, &function, &args)
7902
7903 Registers some function to be called when the specified module (or all
7904 modules) tries to open a file for reading and writing. The function must
7905 return the actual file to open. This allows you to override which files
7906 other code actually operates on, via the translate_filename function.
7907
7908 =cut
7909 sub register_filename_callback
7910 {
7911 my ($mod, $func, $args) = @_;
7912 push(@main::filename_callbacks, [ $mod, $func, $args ]);
7913 }
7914
7915 =head2 register_command_callback(module|undef, &function, &args)
7916
7917 Registers some function to be called when the specified module (or all
7918 modules) tries to execute a command. The function must return the actual
7919 command to run. This allows you to override which commands other other code
7920 actually runs, via the translate_command function.
7921
7922 =cut
7923 sub register_command_callback
7924 {
7925 my ($mod, $func, $args) = @_;
7926 push(@main::command_callbacks, [ $mod, $func, $args ]);
7927 }
7928
7929 =head2 capture_function_output(&function, arg, ...)
7930
7931 Captures output that some function prints to STDOUT, and returns it. Useful
7932 for functions outside your control that print data when you really want to
7933 manipulate it before output.
7934
7935 =cut
7936 sub capture_function_output
7937 {
7938 my ($func, @args) = @_;
7939 socketpair(SOCKET2, SOCKET1, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
7940 my $old = select(SOCKET1);
7941 my @rv = &$func(@args);
7942 select($old);
7943 close(SOCKET1);
7944 my $out;
7945 local $_;
7946 while(<SOCKET2>) {
7947         $out .= $_;
7948         }
7949 close(SOCKET2);
7950 return wantarray ? ($out, \@rv) : $out;
7951 }
7952
7953 =head2 capture_function_output_tempfile(&function, arg, ...)
7954
7955 Behaves the same as capture_function_output, but uses a temporary file
7956 to avoid buffer full problems.
7957
7958 =cut
7959 sub capture_function_output_tempfile
7960 {
7961 my ($func, @args) = @_;
7962 my $temp = &transname();
7963 open(BUFFER, ">$temp");
7964 my $old = select(BUFFER);
7965 my @rv = &$func(@args);
7966 select($old);
7967 close(BUFFER);
7968 my $out = &read_file_contents($temp);
7969 &unlink_file($temp);
7970 return wantarray ? ($out, \@rv) : $out;
7971 }
7972
7973 =head2 modules_chooser_button(field, multiple, [form])
7974
7975 Returns HTML for a button for selecting one or many Webmin modules.
7976 field - Name of the HTML field to place the module names into.
7977 multiple - Set to 1 if multiple modules can be selected.
7978 form - Index of the form on the page.
7979
7980 =cut
7981 sub modules_chooser_button
7982 {
7983 return &theme_modules_chooser_button(@_)
7984         if (defined(&theme_modules_chooser_button));
7985 my $form = defined($_[2]) ? $_[2] : 0;
7986 my $w = $_[1] ? 700 : 500;
7987 my $h = 200;
7988 if ($_[1] && $gconfig{'db_sizemodules'}) {
7989         ($w, $h) = split(/x/, $gconfig{'db_sizemodules'});
7990         }
7991 elsif (!$_[1] && $gconfig{'db_sizemodule'}) {
7992         ($w, $h) = split(/x/, $gconfig{'db_sizemodule'});
7993         }
7994 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";
7995 }
7996
7997 =head2 substitute_template(text, &hash)
7998
7999 Given some text and a hash reference, for each ocurrance of $FOO or ${FOO} in
8000 the text replaces it with the value of the hash key foo. Also supports blocks
8001 like ${IF-FOO} ... ${ENDIF-FOO}, whose contents are only included if foo is
8002 non-zero, and ${IF-FOO} ... ${ELSE-FOO} ... ${ENDIF-FOO}.
8003
8004 =cut
8005 sub substitute_template
8006 {
8007 # Add some extra fixed parameters to the hash
8008 my %hash = %{$_[1]};
8009 $hash{'hostname'} = &get_system_hostname();
8010 $hash{'webmin_config'} = $config_directory;
8011 $hash{'webmin_etc'} = $config_directory;
8012 $hash{'module_config'} = &get_module_variable('$module_config_directory');
8013 $hash{'webmin_var'} = $var_directory;
8014
8015 # Add time-based parameters, for use in DNS
8016 $hash{'current_time'} = time();
8017 my @tm = localtime($hash{'current_time'});
8018 $hash{'current_year'} = $tm[5]+1900;
8019 $hash{'current_month'} = sprintf("%2.2d", $tm[4]+1);
8020 $hash{'current_day'} = sprintf("%2.2d", $tm[3]);
8021 $hash{'current_hour'} = sprintf("%2.2d", $tm[2]);
8022 $hash{'current_minute'} = sprintf("%2.2d", $tm[1]);
8023 $hash{'current_second'} = sprintf("%2.2d", $tm[0]);
8024
8025 # Actually do the substition
8026 my $rv = $_[0];
8027 foreach my $s (keys %hash) {
8028         next if ($s eq '');     # Prevent just $ from being subbed
8029         my $us = uc($s);
8030         my $sv = $hash{$s};
8031         $rv =~ s/\$\{\Q$us\E\}/$sv/g;
8032         $rv =~ s/\$\Q$us\E/$sv/g;
8033         if ($sv) {
8034                 # Replace ${IF}..${ELSE}..${ENDIF} block with first value,
8035                 # and ${IF}..${ENDIF} with value
8036                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/\2/g;
8037                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/\2/g;
8038
8039                 # Replace $IF..$ELSE..$ENDIF block with first value,
8040                 # and $IF..$ENDIF with value
8041                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ELSE-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/\2/g;
8042                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/\2/g;
8043
8044                 # Replace ${IFEQ}..${ENDIFEQ} block with first value if
8045                 # matching, nothing if not
8046                 $rv =~ s/\$\{IFEQ-\Q$us\E-\Q$sv\E\}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-\Q$sv\E\}(\n?)/\2/g;
8047                 $rv =~ s/\$\{IFEQ-\Q$us\E-[^\}]+}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-[^\}]+\}(\n?)//g;
8048
8049                 # Replace $IFEQ..$ENDIFEQ block with first value if
8050                 # matching, nothing if not
8051                 $rv =~ s/\$IFEQ-\Q$us\E-\Q$sv\E(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\Q$sv\E(\n?)/\2/g;
8052                 $rv =~ s/\$IFEQ-\Q$us\E-\S+(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\S+(\n?)//g;
8053                 }
8054         else {
8055                 # Replace ${IF}..${ELSE}..${ENDIF} block with second value,
8056                 # and ${IF}..${ENDIF} with nothing
8057                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/\4/g;
8058                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)//g;
8059
8060                 # Replace $IF..$ELSE..$ENDIF block with second value,
8061                 # and $IF..$ENDIF with nothing
8062                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ELSE-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/\4/g;
8063                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)//g;
8064
8065                 # Replace ${IFEQ}..${ENDIFEQ} block with nothing
8066                 $rv =~ s/\$\{IFEQ-\Q$us\E-[^\}]+}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-[^\}]+\}(\n?)//g;
8067                 $rv =~ s/\$IFEQ-\Q$us\E-\S+(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\S+(\n?)//g;
8068                 }
8069         }
8070
8071 # Now assume any $IF blocks whose variables are not present in the hash
8072 # evaluate to false.
8073 # $IF...$ELSE x $ENDIF => x
8074 $rv =~ s/\$\{IF\-([A-Z]+)\}.*?\$\{ELSE\-\1\}(.*?)\$\{ENDIF\-\1\}/$2/gs;
8075 # $IF...x...$ENDIF => (nothing)
8076 $rv =~ s/\$\{IF\-([A-Z]+)\}.*?\$\{ENDIF\-\1\}//gs;
8077 # ${var} => (nothing)
8078 $rv =~ s/\$\{[A-Z]+\}//g;
8079
8080 return $rv;
8081 }
8082
8083 =head2 running_in_zone
8084
8085 Returns 1 if the current Webmin instance is running in a Solaris zone. Used to
8086 disable module and features that are not appropriate, like those that modify
8087 mounted filesystems.
8088
8089 =cut
8090 sub running_in_zone
8091 {
8092 return 0 if ($gconfig{'os_type'} ne 'solaris' ||
8093              $gconfig{'os_version'} < 10);
8094 my $zn = `zonename 2>$null_file`;
8095 chop($zn);
8096 return $zn && $zn ne "global";
8097 }
8098
8099 =head2 running_in_vserver
8100
8101 Returns 1 if the current Webmin instance is running in a Linux VServer.
8102 Used to disable modules and features that are not appropriate.
8103
8104 =cut
8105 sub running_in_vserver
8106 {
8107 return 0 if ($gconfig{'os_type'} !~ /^\*-linux$/);
8108 my $vserver;
8109 local $_;
8110 open(MTAB, "/etc/mtab");
8111 while(<MTAB>) {
8112         my ($dev, $mp) = split(/\s+/, $_);
8113         if ($mp eq "/" && $dev =~ /^\/dev\/hdv/) {
8114                 $vserver = 1;
8115                 last;
8116                 }
8117         }
8118 close(MTAB);
8119 return $vserver;
8120 }
8121
8122 =head2 running_in_xen
8123
8124 Returns 1 if Webmin is running inside a Xen instance, by looking
8125 at /proc/xen/capabilities.
8126
8127 =cut
8128 sub running_in_xen
8129 {
8130 return 0 if (!-r "/proc/xen/capabilities");
8131 my $cap = &read_file_contents("/proc/xen/capabilities");
8132 return $cap =~ /control_d/ ? 0 : 1;
8133 }
8134
8135 =head2 list_categories(&modules, [include-empty])
8136
8137 Returns a hash mapping category codes to names, including any custom-defined
8138 categories. The modules parameter must be an array ref of module hash objects,
8139 as returned by get_all_module_infos.
8140
8141 =cut
8142 sub list_categories
8143 {
8144 my ($mods, $empty) = @_;
8145 my (%cats, %catnames);
8146 &read_file("$config_directory/webmin.catnames", \%catnames);
8147 foreach my $o (@lang_order_list) {
8148         &read_file("$config_directory/webmin.catnames.$o", \%catnames);
8149         }
8150 if ($empty) {
8151         %cats = %catnames;
8152         }
8153 foreach my $m (@$mods) {
8154         my $c = $m->{'category'};
8155         next if ($cats{$c});
8156         if (defined($catnames{$c})) {
8157                 $cats{$c} = $catnames{$c};
8158                 }
8159         elsif ($text{"category_$c"}) {
8160                 $cats{$c} = $text{"category_$c"};
8161                 }
8162         else {
8163                 # try to get category name from module ..
8164                 my %mtext = &load_language($m->{'dir'});
8165                 if ($mtext{"category_$c"}) {
8166                         $cats{$c} = $mtext{"category_$c"};
8167                         }
8168                 else {
8169                         $c = $m->{'category'} = "";
8170                         $cats{$c} = $text{"category_$c"};
8171                         }
8172                 }
8173         }
8174 return %cats;
8175 }
8176
8177 =head2 is_readonly_mode
8178
8179 Returns 1 if the current user is in read-only mode, and thus all writes
8180 to files and command execution should fail.
8181
8182 =cut
8183 sub is_readonly_mode
8184 {
8185 if (!defined($main::readonly_mode_cache)) {
8186         my %gaccess = &get_module_acl(undef, "");
8187         $main::readonly_mode_cache = $gaccess{'readonly'} ? 1 : 0;
8188         }
8189 return $main::readonly_mode_cache;
8190 }
8191
8192 =head2 command_as_user(user, with-env?, command, ...)
8193
8194 Returns a command to execute some command as the given user, using the
8195 su statement. If on Linux, the /bin/sh shell is forced in case the user
8196 does not have a valid shell. If with-env is set to 1, the -s flag is added
8197 to the su command to read the user's .profile or .bashrc file.
8198
8199 =cut
8200 sub command_as_user
8201 {
8202 my ($user, $env, @args) = @_;
8203 my @uinfo = getpwnam($user);
8204 if ($uinfo[8] ne "/bin/sh" && $uinfo[8] !~ /\/bash$/) {
8205         # User shell doesn't appear to be valid
8206         if ($gconfig{'os_type'} =~ /-linux$/) {
8207                 # Use -s /bin/sh to force it
8208                 $shellarg = " -s /bin/sh";
8209                 }
8210         elsif ($gconfig{'os_type'} eq 'freebsd' ||
8211                $gconfig{'os_type'} eq 'solaris' &&
8212                 $gconfig{'os_version'} >= 11 ||
8213                $gconfig{'os_type'} eq 'macos') {
8214                 # Use -m and force /bin/sh
8215                 @args = ( "/bin/sh", "-c", quotemeta(join(" ", @args)) );
8216                 $shellarg = " -m";
8217                 }
8218         }
8219 my $rv = "su".($env ? " -" : "").$shellarg.
8220          " ".quotemeta($user)." -c ".quotemeta(join(" ", @args));
8221 return $rv;
8222 }
8223
8224 =head2 list_osdn_mirrors(project, file)
8225
8226 Given a OSDN project and filename, returns a list of mirror URLs from
8227 which it can be downloaded. Mainly for internal use by the http_download
8228 function.
8229
8230 =cut
8231 sub list_osdn_mirrors
8232 {
8233 my ($project, $file) = @_;
8234
8235 # Convert the sourceforge project name to a group ID
8236 my ($idpage, $iderror);
8237 &http_download($osdn_download_host, $osdn_download_port,
8238                "/$project/", \$idpage, \$iderror,
8239                undef, 0, undef, undef, 0, 0, 1);
8240 my $group_id;
8241 if ($idpage =~ /showfiles.php\?group_id=(\d+)/) {
8242         $group_id = $1;
8243         }
8244
8245 # Query the mirror picker page
8246 my ($page, $error, @rv);
8247 if ($group_id) {
8248         &http_download($osdn_download_host, $osdn_download_port,
8249                        "/project/mirror_picker.php?group_id=".&urlize($group_id).
8250                         "&filename=".&urlize($file),
8251                        \$page, \$error, undef, 0, undef, undef, 0, 0, 1,
8252                        \%headers);
8253         while($page =~ /<input[^>]*name="use_mirror"\s+value="(\S+)"[^>]*>([^,]+),\s*([^<]*)<([\000-\377]*)/i) {
8254                 # Got a country and city
8255                 push(@rv, { 'country' => $3,
8256                             'city' => $2,
8257                             'mirror' => $1,
8258                             'url' => "http://$1.dl.sourceforge.net/sourceforge/$project/$file" });
8259                 $page = $4;
8260                 }
8261         }
8262
8263 if (!@rv) {
8264         # None found! Try some known mirrors
8265         foreach my $m ("superb-east", "superb-west", "osdn", "downloads") {
8266                 my $url = $m eq "downloads" ?
8267                     "http://downloads.sourceforge.net/$project/$file" :
8268                     "http://$m.dl.sourceforge.net/sourceforge/$project/$file";
8269                 $main::download_timed_out = undef;
8270                 local $SIG{ALRM} = \&download_timeout;
8271                 alarm(10);
8272                 my ($host, $port, $page, $ssl) = &parse_http_url($url);
8273                 my $h = &make_http_connection(
8274                         $host, $port, $ssl, "HEAD", $page);
8275                 alarm(0);
8276                 next if (!ref($h) || $main::download_timed_out);
8277
8278                 # Make a HEAD request
8279                 &write_http_connection($h, "Host: $host\r\n");
8280                 &write_http_connection($h, "User-agent: Webmin\r\n");
8281                 &write_http_connection($h, "\r\n");
8282                 $line = &read_http_connection($h);
8283                 $line =~ s/\r|\n//g;
8284                 &close_http_connection($h);
8285                 if ($line =~ /^HTTP\/1\..\s+(200)\s+/) {
8286                         push(@rv, { 'mirror' => $m,
8287                                     'default' => $m eq 'osdn',
8288                                     'url' => $url });
8289                         last;
8290                         }
8291                 }
8292         }
8293 return @rv;
8294 }
8295
8296 =head2 convert_osdn_url(url)
8297
8298 Given a URL like http://osdn.dl.sourceforge.net/sourceforge/project/file.zip
8299 or http://prdownloads.sourceforge.net/project/file.zip , convert it
8300 to a real URL on the best mirror.
8301
8302 =cut
8303 sub convert_osdn_url
8304 {
8305 my ($url) = @_;
8306 if ($url =~ /^http:\/\/[^\.]+.dl.sourceforge.net\/sourceforge\/([^\/]+)\/(.*)$/ ||
8307     $url =~ /^http:\/\/prdownloads.sourceforge.net\/([^\/]+)\/(.*)$/) {
8308         # Find best site
8309         my ($project, $file) = ($1, $2);
8310         my @mirrors = &list_osdn_mirrors($project, $file);
8311         my $pref = $gconfig{'osdn_mirror'};
8312         my $site;
8313         if ($pref) {
8314                 ($site) = grep { $_->{'mirror'} eq $pref } @mirrors;
8315                 }
8316         if (!$site) {
8317                 # Fall back to automatic mirror selection via Sourceforge
8318                 # redirect
8319                 $site = { 'url' => "http://prdownloads.sourceforge.net/sourceforge/$project/$file",
8320                           'default' => 0 };
8321                 }
8322         return wantarray ? ( $site->{'url'}, $site->{'default'} )
8323                          : $site->{'url'};
8324         }
8325 else {
8326         # Some other source .. don't change
8327         return wantarray ? ( $url, 2 ) : $url;
8328         }
8329 }
8330
8331 =head2 get_current_dir
8332
8333 Returns the directory the current process is running in.
8334
8335 =cut
8336 sub get_current_dir
8337 {
8338 my $out;
8339 if ($gconfig{'os_type'} eq 'windows') {
8340         # Use cd command
8341         $out = `cd`;
8342         }
8343 else {
8344         # Use pwd command
8345         $out = `pwd`;
8346         $out =~ s/\\/\//g;
8347         }
8348 $out =~ s/\r|\n//g;
8349 return $out;
8350 }
8351
8352 =head2 supports_users
8353
8354 Returns 1 if the current OS supports Unix user concepts and functions like
8355 su , getpw* and so on. This will be true on Linux and other Unixes, but false
8356 on Windows.
8357
8358 =cut
8359 sub supports_users
8360 {
8361 return $gconfig{'os_type'} ne 'windows';
8362 }
8363
8364 =head2 supports_symlinks
8365
8366 Returns 1 if the current OS supports symbolic and hard links. This will not
8367 be the case on Windows.
8368
8369 =cut
8370 sub supports_symlinks
8371 {
8372 return $gconfig{'os_type'} ne 'windows';
8373 }
8374
8375 =head2 quote_path(path)
8376
8377 Returns a path with safe quoting for the current operating system.
8378
8379 =cut
8380 sub quote_path
8381 {
8382 my ($path) = @_;
8383 if ($gconfig{'os_type'} eq 'windows' || $path =~ /^[a-z]:/i) {
8384         # Windows only supports "" style quoting
8385         return "\"$path\"";
8386         }
8387 else {
8388         return quotemeta($path);
8389         }
8390 }
8391
8392 =head2 get_windows_root
8393
8394 Returns the base windows system directory, like c:/windows.
8395
8396 =cut
8397 sub get_windows_root
8398 {
8399 if ($ENV{'SystemRoot'}) {
8400         my $rv = $ENV{'SystemRoot'};
8401         $rv =~ s/\\/\//g;
8402         return $rv;
8403         }
8404 else {
8405         return -d "c:/windows" ? "c:/windows" : "c:/winnt";
8406         }
8407 }
8408
8409 =head2 read_file_contents(file)
8410
8411 Given a filename, returns its complete contents as a string. Effectively
8412 the same as the Perl construct `cat file`.
8413
8414 =cut
8415 sub read_file_contents
8416 {
8417 &open_readfile(FILE, $_[0]) || return undef;
8418 local $/ = undef;
8419 my $rv = <FILE>;
8420 close(FILE);
8421 return $rv;
8422 }
8423
8424 =head2 unix_crypt(password, salt)
8425
8426 Performs Unix encryption on a password, using the built-in crypt function or
8427 the Crypt::UnixCrypt module if the former does not work. The salt parameter
8428 must be either an already-hashed password, or a two-character alpha-numeric
8429 string.
8430
8431 =cut
8432 sub unix_crypt
8433 {
8434 my ($pass, $salt) = @_;
8435 return "" if ($salt !~ /^[a-zA-Z0-9\.\/]{2}/);   # same as real crypt
8436 my $rv = eval "crypt(\$pass, \$salt)";
8437 my $err = $@;
8438 return $rv if ($rv && !$@);
8439 eval "use Crypt::UnixCrypt";
8440 if (!$@) {
8441         return Crypt::UnixCrypt::crypt($pass, $salt);
8442         }
8443 else {
8444         &error("Failed to encrypt password : $err");
8445         }
8446 }
8447
8448 =head2 split_quoted_string(string)
8449
8450 Given a string like I<foo "bar baz" quux>, returns the array :
8451 foo, bar baz, quux
8452
8453 =cut
8454 sub split_quoted_string
8455 {
8456 my ($str) = @_;
8457 my @rv;
8458 while($str =~ /^"([^"]*)"\s*([\000-\377]*)$/ ||
8459       $str =~ /^'([^']*)'\s*([\000-\377]*)$/ ||
8460       $str =~ /^(\S+)\s*([\000-\377]*)$/) {
8461         push(@rv, $1);
8462         $str = $2;
8463         }
8464 return @rv;
8465 }
8466
8467 =head2 write_to_http_cache(url, file|&data)
8468
8469 Updates the Webmin cache with the contents of the given file, possibly also
8470 clearing out old data. Mainly for internal use by http_download.
8471
8472 =cut
8473 sub write_to_http_cache
8474 {
8475 my ($url, $file) = @_;
8476 return 0 if (!$gconfig{'cache_size'});
8477
8478 # Don't cache downloads that look dynamic
8479 if ($url =~ /cgi-bin/ || $url =~ /\?/) {
8480         return 0;
8481         }
8482
8483 # Check if the current module should do caching
8484 if ($gconfig{'cache_mods'} =~ /^\!(.*)$/) {
8485         # Caching all except some modules
8486         my @mods = split(/\s+/, $1);
8487         return 0 if (&indexof(&get_module_name(), @mods) != -1);
8488         }
8489 elsif ($gconfig{'cache_mods'}) {
8490         # Only caching some modules
8491         my @mods = split(/\s+/, $gconfig{'cache_mods'});
8492         return 0 if (&indexof(&get_module_name(), @mods) == -1);
8493         }
8494
8495 # Work out the size
8496 my $size;
8497 if (ref($file)) {
8498         $size = length($$file);
8499         }
8500 else {
8501         my @st = stat($file);
8502         $size = $st[7];
8503         }
8504
8505 if ($size > $gconfig{'cache_size'}) {
8506         # Bigger than the whole cache - so don't save it
8507         return 0;
8508         }
8509 my $cfile = $url;
8510 $cfile =~ s/\//_/g;
8511 $cfile = "$main::http_cache_directory/$cfile";
8512
8513 # See how much we have cached currently, clearing old files
8514 my $total = 0;
8515 mkdir($main::http_cache_directory, 0700) if (!-d $main::http_cache_directory);
8516 opendir(CACHEDIR, $main::http_cache_directory);
8517 foreach my $f (readdir(CACHEDIR)) {
8518         next if ($f eq "." || $f eq "..");
8519         my $path = "$main::http_cache_directory/$f";
8520         my @st = stat($path);
8521         if ($gconfig{'cache_days'} &&
8522             time()-$st[9] > $gconfig{'cache_days'}*24*60*60) {
8523                 # This file is too old .. trash it
8524                 unlink($path);
8525                 }
8526         else {
8527                 $total += $st[7];
8528                 push(@cached, [ $path, $st[7], $st[9] ]);
8529                 }
8530         }
8531 closedir(CACHEDIR);
8532 @cached = sort { $a->[2] <=> $b->[2] } @cached;
8533 while($total+$size > $gconfig{'cache_size'} && @cached) {
8534         # Cache is too big .. delete some files until the new one will fit
8535         unlink($cached[0]->[0]);
8536         $total -= $cached[0]->[1];
8537         shift(@cached);
8538         }
8539
8540 # Finally, write out the new file
8541 if (ref($file)) {
8542         &open_tempfile(CACHEFILE, ">$cfile");
8543         &print_tempfile(CACHEFILE, $$file);
8544         &close_tempfile(CACHEFILE);
8545         }
8546 else {
8547         my ($ok, $err) = &copy_source_dest($file, $cfile);
8548         }
8549
8550 return 1;
8551 }
8552
8553 =head2 check_in_http_cache(url)
8554
8555 If some URL is in the cache and valid, return the filename for it. Mainly
8556 for internal use by http_download.
8557
8558 =cut
8559 sub check_in_http_cache
8560 {
8561 my ($url) = @_;
8562 return undef if (!$gconfig{'cache_size'});
8563
8564 # Check if the current module should do caching
8565 if ($gconfig{'cache_mods'} =~ /^\!(.*)$/) {
8566         # Caching all except some modules
8567         my @mods = split(/\s+/, $1);
8568         return 0 if (&indexof(&get_module_name(), @mods) != -1);
8569         }
8570 elsif ($gconfig{'cache_mods'}) {
8571         # Only caching some modules
8572         my @mods = split(/\s+/, $gconfig{'cache_mods'});
8573         return 0 if (&indexof(&get_module_name(), @mods) == -1);
8574         }
8575
8576 my $cfile = $url;
8577 $cfile =~ s/\//_/g;
8578 $cfile = "$main::http_cache_directory/$cfile";
8579 my @st = stat($cfile);
8580 return undef if (!@st || !$st[7]);
8581 if ($gconfig{'cache_days'} && time()-$st[9] > $gconfig{'cache_days'}*24*60*60) {
8582         # Too old!
8583         unlink($cfile);
8584         return undef;
8585         }
8586 open(TOUCH, ">>$cfile");        # Update the file time, to keep it in the cache
8587 close(TOUCH);
8588 return $cfile;
8589 }
8590
8591 =head2 supports_javascript
8592
8593 Returns 1 if the current browser is assumed to support javascript.
8594
8595 =cut
8596 sub supports_javascript
8597 {
8598 if (defined(&theme_supports_javascript)) {
8599         return &theme_supports_javascript();
8600         }
8601 return $ENV{'MOBILE_DEVICE'} ? 0 : 1;
8602 }
8603
8604 =head2 get_module_name
8605
8606 Returns the name of the Webmin module that called this function. For internal
8607 use only by other API functions.
8608
8609 =cut
8610 sub get_module_name
8611 {
8612 return &get_module_variable('$module_name');
8613 }
8614
8615 =head2 get_module_variable(name, [ref])
8616
8617 Returns the value of some variable which is set in the caller's context, if
8618 using the new WebminCore package. For internal use only.
8619
8620 =cut
8621 sub get_module_variable
8622 {
8623 my ($v, $wantref) = @_;
8624 my $slash = $wantref ? "\\" : "";
8625 my $thispkg = &web_libs_package();
8626 if ($thispkg eq 'WebminCore') {
8627         my ($vt, $vn) = split('', $v, 2);
8628         my $callpkg;
8629         for(my $i=0; ($callpkg) = caller($i); $i++) {
8630                 last if ($callpkg ne $thispkg);
8631                 }
8632         return eval "${slash}${vt}${callpkg}::${vn}";
8633         }
8634 return eval "${slash}${v}";
8635 }
8636
8637 =head2 clear_time_locale()
8638
8639 Temporarily force the locale to C, until reset_time_locale is called. This is
8640 useful if your code is going to call C<strftime> from the POSIX package, and
8641 you want to ensure that the output is in a consistent format.
8642
8643 =cut
8644 sub clear_time_locale
8645 {
8646 if ($main::clear_time_locale_count == 0) {
8647         eval {
8648                 use POSIX;
8649                 $main::clear_time_locale_old = POSIX::setlocale(POSIX::LC_TIME);
8650                 POSIX::setlocale(POSIX::LC_TIME, "C");
8651                 };
8652         }
8653 $main::clear_time_locale_count++;
8654 }
8655
8656 =head2 reset_time_locale()
8657
8658 Revert the locale to whatever it was before clear_time_locale was called
8659
8660 =cut
8661 sub reset_time_locale
8662 {
8663 if ($main::clear_time_locale_count == 1) {
8664         eval {
8665                 POSIX::setlocale(POSIX::LC_TIME, $main::clear_time_locale_old);
8666                 $main::clear_time_locale_old = undef;
8667                 };
8668         }
8669 $main::clear_time_locale_count--;
8670 }
8671
8672 =head2 callers_package(filehandle)
8673
8674 Convert a non-module filehandle like FOO to one qualified with the
8675 caller's caller's package, like fsdump::FOO. For internal use only.
8676
8677 =cut
8678 sub callers_package
8679 {
8680 my ($fh) = @_;
8681 my $callpkg = (caller(1))[0];
8682 my $thispkg = &web_libs_package();
8683 if (!ref($fh) && $fh !~ /::/ &&
8684     $callpkg ne $thispkg && $thispkg eq 'WebminCore') {
8685         $fh = $callpkg."::".$fh;
8686         }
8687 return $fh;
8688 }
8689
8690 =head2 web_libs_package()
8691
8692 Returns the package this code is in. We can't always trust __PACKAGE__. For
8693 internal use only.
8694
8695 =cut
8696 sub web_libs_package
8697 {
8698 if ($called_from_webmin_core) {
8699         return "WebminCore";
8700         }
8701 return __PACKAGE__;
8702 }
8703
8704 $done_web_lib_funcs = 1;
8705
8706 1;