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