web-lib-funcs.pl

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