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         my %miniserv;
3292         &get_miniserv_config(\%miniserv);
3293         if ($miniserv{'userdb'}) {
3294                 # Look for this user in the user/group DB
3295                 # XXX
3296                 }
3297         &read_file_cached("$config_directory/$m/$u.acl", \%rv);
3298         if ($remote_user ne $base_remote_user && !defined($_[0])) {
3299                 &read_file_cached("$config_directory/$m/$remote_user.acl",\%rv);
3300                 }
3301         }
3302 if ($tconfig{'preload_functions'}) {
3303         &load_theme_library();
3304         }
3305 if (defined(&theme_get_module_acl)) {
3306         %rv = &theme_get_module_acl($u, $m, \%rv);
3307         }
3308 return %rv;
3309 }
3310
3311 =head2 get_group_module_acl(group, [module])
3312
3313 Returns the ACL for a Webmin group, in an optional module (which defaults to
3314 the current module).
3315
3316 =cut
3317 sub get_group_module_acl
3318 {
3319 my $g = $_[0];
3320 my $m = defined($_[1]) ? $_[1] : &get_module_name();
3321 my $mdir = &module_root_directory($m);
3322 my %rv;
3323 &read_file_cached("$mdir/defaultacl", \%rv);
3324 &read_file_cached("$config_directory/$m/$g.gacl", \%rv);
3325 if (defined(&theme_get_module_acl)) {
3326         %rv = &theme_get_module_acl($g, $m, \%rv);
3327         }
3328 return %rv;
3329 }
3330
3331 =head2 save_module_acl(&acl, [user], [module])
3332
3333 Updates the acl hash for some user and module. The parameters are :
3334
3335 =item acl - Hash reference for the new access control options.
3336
3337 =item user - User to update, defaulting to the current user.
3338
3339 =item module - Module to update, defaulting to the caller.
3340
3341 =cut
3342 sub save_module_acl
3343 {
3344 my $u = defined($_[1]) ? $_[1] : $base_remote_user;
3345 my $m = defined($_[2]) ? $_[2] : &get_module_name();
3346 if (&foreign_check("acl")) {
3347         # Check if this user is a member of a group, and if he gets the
3348         # module from a group. If so, update its ACL as well
3349         &foreign_require("acl", "acl-lib.pl");
3350         my $group;
3351         foreach my $g (&acl::list_groups()) {
3352                 if (&indexof($u, @{$g->{'members'}}) >= 0 &&
3353                     &indexof($m, @{$g->{'modules'}}) >= 0) {
3354                         $group = $g;
3355                         last;
3356                         }
3357                 }
3358         if ($group) {
3359                 &save_group_module_acl($_[0], $group->{'name'}, $m);
3360                 }
3361         }
3362 if (!-d "$config_directory/$m") {
3363         mkdir("$config_directory/$m", 0755);
3364         }
3365 &write_file("$config_directory/$m/$u.acl", $_[0]);
3366 }
3367
3368 =head2 save_group_module_acl(&acl, group, [module])
3369
3370 Updates the acl hash for some group and module. The parameters are :
3371
3372 =item acl - Hash reference for the new access control options.
3373
3374 =item group - Group name to update.
3375
3376 =item module - Module to update, defaulting to the caller.
3377
3378 =cut
3379 sub save_group_module_acl
3380 {
3381 my $g = $_[1];
3382 my $m = defined($_[2]) ? $_[2] : &get_module_name();
3383 if (&foreign_check("acl")) {
3384         # Check if this group is a member of a group, and if it gets the
3385         # module from a group. If so, update the parent ACL as well
3386         &foreign_require("acl", "acl-lib.pl");
3387         my $group;
3388         foreach my $pg (&acl::list_groups()) {
3389                 if (&indexof('@'.$g, @{$pg->{'members'}}) >= 0 &&
3390                     &indexof($m, @{$pg->{'modules'}}) >= 0) {
3391                         $group = $g;
3392                         last;
3393                         }
3394                 }
3395         if ($group) {
3396                 &save_group_module_acl($_[0], $group->{'name'}, $m);
3397                 }
3398         }
3399 if (!-d "$config_directory/$m") {
3400         mkdir("$config_directory/$m", 0755);
3401         }
3402 &write_file("$config_directory/$m/$g.gacl", $_[0]);
3403 }
3404
3405 =head2 init_config
3406
3407 This function must be called by all Webmin CGI scripts, either directly or
3408 indirectly via a per-module lib.pl file. It performs a number of initialization
3409 and housekeeping tasks, such as working out the module name, checking that the
3410 current user has access to the module, and populating global variables. Some
3411 of the variables set include :
3412
3413 =item $config_directory - Base Webmin config directory, typically /etc/webmin
3414
3415 =item $var_directory - Base logs directory, typically /var/webmin
3416
3417 =item %config - Per-module configuration.
3418
3419 =item %gconfig - Global configuration.
3420
3421 =item $scriptname - Base name of the current perl script.
3422
3423 =item $module_name - The name of the current module.
3424
3425 =item $module_config_directory - The config directory for this module.
3426
3427 =item $module_config_file - The config file for this module.
3428
3429 =item $module_root_directory - This module's code directory.
3430
3431 =item $webmin_logfile - The detailed logfile for webmin.
3432
3433 =item $remote_user - The actual username used to login to webmin.
3434
3435 =item $base_remote_user - The username whose permissions are in effect.
3436
3437 =item $current_theme - The theme currently in use.
3438
3439 =item $root_directory - The first root directory of this webmin install.
3440
3441 =item @root_directories - All root directories for this webmin install.
3442
3443 =cut
3444 sub init_config
3445 {
3446 # Record first process ID that called this, so we know when it exited to clean
3447 # up temp files
3448 $main::initial_process_id ||= $$;
3449
3450 # Configuration and spool directories
3451 if (!defined($ENV{'WEBMIN_CONFIG'})) {
3452         die "WEBMIN_CONFIG not set";
3453         }
3454 $config_directory = $ENV{'WEBMIN_CONFIG'};
3455 if (!defined($ENV{'WEBMIN_VAR'})) {
3456         open(VARPATH, "$config_directory/var-path");
3457         chop($var_directory = <VARPATH>);
3458         close(VARPATH);
3459         }
3460 else {
3461         $var_directory = $ENV{'WEBMIN_VAR'};
3462         }
3463 $main::http_cache_directory = $ENV{'WEBMIN_VAR'}."/cache";
3464 $main::default_debug_log_file = $ENV{'WEBMIN_VAR'}."/webmin.debug";
3465
3466 if ($ENV{'SESSION_ID'}) {
3467         # Hide this variable from called programs, but keep it for internal use
3468         $main::session_id = $ENV{'SESSION_ID'};
3469         delete($ENV{'SESSION_ID'});
3470         }
3471 if ($ENV{'REMOTE_PASS'}) {
3472         # Hide the password too
3473         $main::remote_pass = $ENV{'REMOTE_PASS'};
3474         delete($ENV{'REMOTE_PASS'});
3475         }
3476
3477 if ($> == 0 && $< != 0 && !$ENV{'FOREIGN_MODULE_NAME'}) {
3478         # Looks like we are running setuid, but the real UID hasn't been set.
3479         # Do so now, so that executed programs don't get confused
3480         $( = $);
3481         $< = $>;
3482         }
3483
3484 # Read the webmin global config file. This contains the OS type and version,
3485 # OS specific configuration and global options such as proxy servers
3486 $config_file = "$config_directory/config";
3487 %gconfig = ( );
3488 &read_file_cached($config_file, \%gconfig);
3489 $null_file = $gconfig{'os_type'} eq 'windows' ? "NUL" : "/dev/null";
3490 $path_separator = $gconfig{'os_type'} eq 'windows' ? ';' : ':';
3491
3492 # If debugging is enabled, open the debug log
3493 if ($gconfig{'debug_enabled'} && !$main::opened_debug_log++) {
3494         my $dlog = $gconfig{'debug_file'} || $main::default_debug_log_file;
3495         if ($gconfig{'debug_size'}) {
3496                 my @st = stat($dlog);
3497                 if ($st[7] > $gconfig{'debug_size'}) {
3498                         rename($dlog, $dlog.".0");
3499                         }
3500                 }
3501         open(main::DEBUGLOG, ">>$dlog");
3502         $main::opened_debug_log = 1;
3503
3504         if ($gconfig{'debug_what_start'}) {
3505                 my $script_name = $0 =~ /([^\/]+)$/ ? $1 : '-';
3506                 $main::debug_log_start_time = time();
3507                 &webmin_debug_log("START", "script=$script_name");
3508                 $main::debug_log_start_module = $module_name;
3509                 }
3510         }
3511
3512 # Set PATH and LD_LIBRARY_PATH
3513 if ($gconfig{'path'}) {
3514         if ($gconfig{'syspath'}) {
3515                 # Webmin only
3516                 $ENV{'PATH'} = $gconfig{'path'};
3517                 }
3518         else {
3519                 # Include OS too
3520                 $ENV{'PATH'} = $gconfig{'path'}.$path_separator.$ENV{'PATH'};
3521                 }
3522         }
3523 $ENV{$gconfig{'ld_env'}} = $gconfig{'ld_path'} if ($gconfig{'ld_env'});
3524
3525 # Set http_proxy and ftp_proxy environment variables, based on Webmin settings
3526 if ($gconfig{'http_proxy'}) {
3527         $ENV{'http_proxy'} = $gconfig{'http_proxy'};
3528         }
3529 if ($gconfig{'ftp_proxy'}) {
3530         $ENV{'ftp_proxy'} = $gconfig{'ftp_proxy'};
3531         }
3532 if ($gconfig{'noproxy'}) {
3533         $ENV{'no_proxy'} = $gconfig{'noproxy'};
3534         }
3535
3536 # Find all root directories
3537 my %miniserv;
3538 if (&get_miniserv_config(\%miniserv)) {
3539         @root_directories = ( $miniserv{'root'} );
3540         for($i=0; defined($miniserv{"extraroot_$i"}); $i++) {
3541                 push(@root_directories, $miniserv{"extraroot_$i"});
3542                 }
3543         }
3544
3545 # Work out which module we are in, and read the per-module config file
3546 $0 =~ s/\\/\//g;        # Force consistent path on Windows
3547 if (defined($ENV{'FOREIGN_MODULE_NAME'})) {
3548         # In a foreign call - use the module name given
3549         $root_directory = $ENV{'FOREIGN_ROOT_DIRECTORY'};
3550         $module_name = $ENV{'FOREIGN_MODULE_NAME'};
3551         @root_directories = ( $root_directory ) if (!@root_directories);
3552         }
3553 elsif ($ENV{'SCRIPT_NAME'}) {
3554         my $sn = $ENV{'SCRIPT_NAME'};
3555         $sn =~ s/^$gconfig{'webprefix'}//
3556                 if (!$gconfig{'webprefixnoredir'});
3557         if ($sn =~ /^\/([^\/]+)\//) {
3558                 # Get module name from CGI path
3559                 $module_name = $1;
3560                 }
3561         if ($ENV{'SERVER_ROOT'}) {
3562                 $root_directory = $ENV{'SERVER_ROOT'};
3563                 }
3564         elsif ($ENV{'SCRIPT_FILENAME'}) {
3565                 $root_directory = $ENV{'SCRIPT_FILENAME'};
3566                 $root_directory =~ s/$sn$//;
3567                 }
3568         @root_directories = ( $root_directory ) if (!@root_directories);
3569         }
3570 else {
3571         # Get root directory from miniserv.conf, and deduce module name from $0
3572         $root_directory = $root_directories[0];
3573         my $rok = 0;
3574         foreach my $r (@root_directories) {
3575                 if ($0 =~ /^$r\/([^\/]+)\/[^\/]+$/i) {
3576                         # Under a module directory
3577                         $module_name = $1;
3578                         $rok = 1;
3579                         last;
3580                         }
3581                 elsif ($0 =~ /^$root_directory\/[^\/]+$/i) {
3582                         # At the top level
3583                         $rok = 1;
3584                         last;
3585                         }
3586                 }
3587         &error("Script was not run with full path (failed to find $0 under $root_directory)") if (!$rok);
3588         }
3589
3590 # Work out of this is a web, command line or cron job
3591 if (!$main::webmin_script_type) {
3592         if ($ENV{'SCRIPT_NAME'}) {
3593                 # Run via a CGI
3594                 $main::webmin_script_type = 'web';
3595                 }
3596         else {
3597                 # Cron jobs have no TTY
3598                 if ($gconfig{'os_type'} eq 'windows' ||
3599                     open(DEVTTY, ">/dev/tty")) {
3600                         $main::webmin_script_type = 'cmd';
3601                         close(DEVTTY);
3602                         }
3603                 else {
3604                         $main::webmin_script_type = 'cron';
3605                         }
3606                 }
3607         }
3608
3609 # Set the umask based on config
3610 if ($gconfig{'umask'} && !$main::umask_already++) {
3611         umask(oct($gconfig{'umask'}));
3612         }
3613
3614 # If this is a cron job or other background task, set the nice level
3615 if (!$main::nice_already && $main::webmin_script_type eq 'cron') {
3616         # Set nice level
3617         if ($gconfig{'nice'}) {
3618                 eval 'POSIX::nice($gconfig{\'nice\'});';
3619                 }
3620
3621         # Set IO scheduling class and priority
3622         if ($gconfig{'sclass'} ne '' || $gconfig{'sprio'} ne '') {
3623                 my $cmd = "ionice";
3624                 $cmd .= " -c ".quotemeta($gconfig{'sclass'})
3625                         if ($gconfig{'sclass'} ne '');
3626                 $cmd .= " -n ".quotemeta($gconfig{'sprio'})
3627                         if ($gconfig{'sprio'} ne '');
3628                 $cmd .= " -p $$";
3629                 &execute_command("$cmd >/dev/null 2>&1");
3630                 }
3631         }
3632 $main::nice_already++;
3633
3634 # Get the username
3635 my $u = $ENV{'BASE_REMOTE_USER'} || $ENV{'REMOTE_USER'};
3636 $base_remote_user = $u;
3637 $remote_user = $ENV{'REMOTE_USER'};
3638
3639 if ($module_name) {
3640         # Find and load the configuration file for this module
3641         my (@ruinfo, $rgroup);
3642         $module_config_directory = "$config_directory/$module_name";
3643         if (&get_product_name() eq "usermin" &&
3644             -r "$module_config_directory/config.$remote_user") {
3645                 # Based on username
3646                 $module_config_file = "$module_config_directory/config.$remote_user";
3647                 }
3648         elsif (&get_product_name() eq "usermin" &&
3649             (@ruinfo = getpwnam($remote_user)) &&
3650             ($rgroup = getgrgid($ruinfo[3])) &&
3651             -r "$module_config_directory/config.\@$rgroup") {
3652                 # Based on group name
3653                 $module_config_file = "$module_config_directory/config.\@$rgroup";
3654                 }
3655         else {
3656                 # Global config
3657                 $module_config_file = "$module_config_directory/config";
3658                 }
3659         %config = ( );
3660         &read_file_cached($module_config_file, \%config);
3661
3662         # Fix up windows-specific substitutions in values
3663         foreach my $k (keys %config) {
3664                 if ($config{$k} =~ /\$\{systemroot\}/) {
3665                         my $root = &get_windows_root();
3666                         $config{$k} =~ s/\$\{systemroot\}/$root/g;
3667                         }
3668                 }
3669         }
3670
3671 # Record the initial module
3672 $main::initial_module_name ||= $module_name;
3673
3674 # Set some useful variables
3675 my $current_themes;
3676 $current_themes = $ENV{'MOBILE_DEVICE'} && defined($gconfig{'mobile_theme'}) ?
3677                     $gconfig{'mobile_theme'} :
3678                   defined($gconfig{'theme_'.$remote_user}) ?
3679                     $gconfig{'theme_'.$remote_user} :
3680                   defined($gconfig{'theme_'.$base_remote_user}) ?
3681                     $gconfig{'theme_'.$base_remote_user} :
3682                     $gconfig{'theme'};
3683 @current_themes = split(/\s+/, $current_themes);
3684 $current_theme = $current_themes[0];
3685 @theme_root_directories = map { "$root_directory/$_" } @current_themes;
3686 $theme_root_directory = $theme_root_directories[0];
3687 @theme_configs = ( );
3688 foreach my $troot (@theme_root_directories) {
3689         my %onetconfig;
3690         &read_file_cached("$troot/config", \%onetconfig);
3691         &read_file_cached("$troot/config", \%tconfig);
3692         push(@theme_configs, \%onetconfig);
3693         }
3694 $tb = defined($tconfig{'cs_header'}) ? "bgcolor=#$tconfig{'cs_header'}" :
3695       defined($gconfig{'cs_header'}) ? "bgcolor=#$gconfig{'cs_header'}" :
3696                                        "bgcolor=#9999ff";
3697 $cb = defined($tconfig{'cs_table'}) ? "bgcolor=#$tconfig{'cs_table'}" :
3698       defined($gconfig{'cs_table'}) ? "bgcolor=#$gconfig{'cs_table'}" :
3699                                       "bgcolor=#cccccc";
3700 $tb .= ' '.$tconfig{'tb'} if ($tconfig{'tb'});
3701 $cb .= ' '.$tconfig{'cb'} if ($tconfig{'cb'});
3702 if ($tconfig{'preload_functions'}) {
3703         # Force load of theme functions right now, if requested
3704         &load_theme_library();
3705         }
3706 if ($tconfig{'oofunctions'} && !$main::loaded_theme_oo_library++) {
3707         # Load the theme's Webmin:: package classes
3708         do "$theme_root_directory/$tconfig{'oofunctions'}";
3709         }
3710
3711 $0 =~ /([^\/]+)$/;
3712 $scriptname = $1;
3713 $webmin_logfile = $gconfig{'webmin_log'} ? $gconfig{'webmin_log'}
3714                                          : "$var_directory/webmin.log";
3715
3716 # Load language strings into %text
3717 my @langs = &list_languages();
3718 my $accepted_lang;
3719 if ($gconfig{'acceptlang'}) {
3720         foreach my $a (split(/,/, $ENV{'HTTP_ACCEPT_LANGUAGE'})) {
3721                 my ($al) = grep { $_->{'lang'} eq $a } @langs;
3722                 if ($al) {
3723                         $accepted_lang = $al->{'lang'};
3724                         last;
3725                         }
3726                 }
3727         }
3728 $current_lang = $force_lang ? $force_lang :
3729     $accepted_lang ? $accepted_lang :
3730     $gconfig{"lang_$remote_user"} ? $gconfig{"lang_$remote_user"} :
3731     $gconfig{"lang_$base_remote_user"} ? $gconfig{"lang_$base_remote_user"} :
3732     $gconfig{"lang"} ? $gconfig{"lang"} : $default_lang;
3733 foreach my $l (@langs) {
3734         $current_lang_info = $l if ($l->{'lang'} eq $current_lang);
3735         }
3736 @lang_order_list = &unique($default_lang,
3737                            split(/:/, $current_lang_info->{'fallback'}),
3738                            $current_lang);
3739 %text = &load_language($module_name);
3740 %text || &error("Failed to determine Webmin root from SERVER_ROOT, SCRIPT_FILENAME or the full command line");
3741
3742 # Get the %module_info for this module
3743 if ($module_name) {
3744         my ($mi) = grep { $_->{'dir'} eq $module_name }
3745                          &get_all_module_infos(2);
3746         %module_info = %$mi;
3747         $module_root_directory = &module_root_directory($module_name);
3748         }
3749
3750 if ($module_name && !$main::no_acl_check &&
3751     !defined($ENV{'FOREIGN_MODULE_NAME'})) {
3752         # Check if the HTTP user can access this module
3753         if (!&foreign_available($module_name)) {
3754                 if (!&foreign_check($module_name)) {
3755                         &error(&text('emodulecheck',
3756                                      "<i>$module_info{'desc'}</i>"));
3757                         }
3758                 else {
3759                         &error(&text('emodule', "<i>$u</i>",
3760                                      "<i>$module_info{'desc'}</i>"));
3761                         }
3762                 }
3763         $main::no_acl_check++;
3764         }
3765
3766 # Check the Referer: header for nasty redirects
3767 my @referers = split(/\s+/, $gconfig{'referers'});
3768 my $referer_site;
3769 if ($ENV{'HTTP_REFERER'} =~/^(http|https|ftp):\/\/([^:\/]+:[^@\/]+@)?([^\/:@]+)/) {
3770         $referer_site = $3;
3771         }
3772 my $http_host = $ENV{'HTTP_HOST'};
3773 $http_host =~ s/:\d+$//;
3774 my $unsafe_index = $unsafe_index_cgi ||
3775                    &get_module_variable('$unsafe_index_cgi');
3776 if ($0 &&
3777     ($ENV{'SCRIPT_NAME'} !~ /^\/(index.cgi)?$/ || $unsafe_index) &&
3778     ($ENV{'SCRIPT_NAME'} !~ /^\/([a-z0-9\_\-]+)\/(index.cgi)?$/i ||
3779      $unsafe_index) &&
3780     $0 !~ /(session_login|pam_login)\.cgi$/ && !$gconfig{'referer'} &&
3781     $ENV{'MINISERV_CONFIG'} && !$main::no_referers_check &&
3782     $ENV{'HTTP_USER_AGENT'} !~ /^Webmin/i &&
3783     ($referer_site && $referer_site ne $http_host &&
3784      &indexof($referer_site, @referers) < 0 ||
3785     !$referer_site && $gconfig{'referers_none'}) &&
3786     !$trust_unknown_referers &&
3787     !&get_module_variable('$trust_unknown_referers')) {
3788         # Looks like a link from elsewhere .. show an error
3789         &header($text{'referer_title'}, "", undef, 0, 1, 1);
3790
3791         $prot = lc($ENV{'HTTPS'}) eq 'on' ? "https" : "http";
3792         my $url = "<tt>".&html_escape("$prot://$ENV{'HTTP_HOST'}$ENV{'REQUEST_URI'}")."</tt>";
3793         if ($referer_site) {
3794                 # From a known host
3795                 print &text('referer_warn',
3796                      "<tt>".&html_escape($ENV{'HTTP_REFERER'})."</tt>", $url);
3797                 print "<p>\n";
3798                 print &text('referer_fix1', &html_escape($http_host)),"<p>\n";
3799                 print &text('referer_fix2', &html_escape($http_host)),"<p>\n";
3800                 }
3801         else {
3802                 # No referer info given
3803                 print &text('referer_warn_unknown', $url),"<p>\n";
3804                 print &text('referer_fix1u'),"<p>\n";
3805                 print &text('referer_fix2u'),"<p>\n";
3806                 }
3807         print "<p>\n";
3808
3809         &footer("/", $text{'index'});
3810         exit;
3811         }
3812 $main::no_referers_check++;
3813 $main::completed_referers_check++;
3814
3815 # Call theme post-init
3816 if (defined(&theme_post_init_config)) {
3817         &theme_post_init_config(@_);
3818         }
3819
3820 # Record that we have done the calling library in this package
3821 my ($callpkg, $lib) = caller();
3822 $lib =~ s/^.*\///;
3823 $main::done_foreign_require{$callpkg,$lib} = 1;
3824
3825 # If a licence checking is enabled, do it now
3826 if ($gconfig{'licence_module'} && !$main::done_licence_module_check &&
3827     &foreign_check($gconfig{'licence_module'}) &&
3828     -r "$root_directory/$gconfig{'licence_module'}/licence_check.pl") {
3829         my $oldpwd = &get_current_dir();
3830         $main::done_licence_module_check++;
3831         $main::licence_module = $gconfig{'licence_module'};
3832         &foreign_require($main::licence_module, "licence_check.pl");
3833         ($main::licence_status, $main::licence_message) =
3834                 &foreign_call($main::licence_module, "check_licence");
3835         chdir($oldpwd);
3836         }
3837
3838 # Export global variables to caller
3839 if ($main::export_to_caller) {
3840         foreach my $v ('$config_file', '%gconfig', '$null_file',
3841                        '$path_separator', '@root_directories',
3842                        '$root_directory', '$module_name',
3843                        '$base_remote_user', '$remote_user',
3844                        '$module_config_directory', '$module_config_file',
3845                        '%config', '@current_themes', '$current_theme',
3846                        '@theme_root_directories', '$theme_root_directory',
3847                        '%tconfig','@theme_configs', '$tb', '$cb', '$scriptname',
3848                        '$webmin_logfile', '$current_lang',
3849                        '$current_lang_info', '@lang_order_list', '%text',
3850                        '%module_info', '$module_root_directory') {
3851                 my ($vt, $vn) = split('', $v, 2);
3852                 eval "${vt}${callpkg}::${vn} = ${vt}${vn}";
3853                 }
3854         }
3855
3856 return 1;
3857 }
3858
3859 =head2 load_language([module], [directory])
3860
3861 Returns a hashtable mapping text codes to strings in the appropriate language,
3862 based on the $current_lang global variable, which is in turn set based on
3863 the Webmin user's selection. The optional module parameter tells the function
3864 which module to load strings for, and defaults to the calling module. The
3865 optional directory parameter can be used to load strings from a directory
3866 other than lang.
3867
3868 In regular module development you will never need to call this function
3869 directly, as init_config calls it for you, and places the module's strings
3870 into the %text hash.
3871
3872 =cut
3873 sub load_language
3874 {
3875 my %text;
3876 my $root = $root_directory;
3877 my $ol = $gconfig{'overlang'};
3878 my ($dir) = ($_[1] || "lang");
3879
3880 # Read global lang files
3881 foreach my $o (@lang_order_list) {
3882         my $ok = &read_file_cached("$root/$dir/$o", \%text);
3883         return () if (!$ok && $o eq $default_lang);
3884         }
3885 if ($ol) {
3886         foreach my $o (@lang_order_list) {
3887                 &read_file_cached("$root/$ol/$o", \%text);
3888                 }
3889         }
3890 &read_file_cached("$config_directory/custom-lang", \%text);
3891
3892 if ($_[0]) {
3893         # Read module's lang files
3894         my $mdir = &module_root_directory($_[0]);
3895         foreach my $o (@lang_order_list) {
3896                 &read_file_cached("$mdir/$dir/$o", \%text);
3897                 }
3898         if ($ol) {
3899                 foreach $o (@lang_order_list) {
3900                         &read_file_cached("$mdir/$ol/$o", \%text);
3901                         }
3902                 }
3903         &read_file_cached("$config_directory/$_[0]/custom-lang", \%text);
3904         }
3905 foreach $k (keys %text) {
3906         $text{$k} =~ s/\$(\{([^\}]+)\}|([A-Za-z0-9\.\-\_]+))/text_subs($2 || $3,\%text)/ge;
3907         }
3908
3909 if (defined(&theme_load_language)) {
3910         &theme_load_language(\%text, $_[0]);
3911         }
3912 return %text;
3913 }
3914
3915 =head2 text_subs(string)
3916
3917 Used internally by load_language to expand $code substitutions in language
3918 files.
3919
3920 =cut
3921 sub text_subs
3922 {
3923 if (substr($_[0], 0, 8) eq "include:") {
3924         local $_;
3925         my $rv;
3926         open(INCLUDE, substr($_[0], 8));
3927         while(<INCLUDE>) {
3928                 $rv .= $_;
3929                 }
3930         close(INCLUDE);
3931         return $rv;
3932         }
3933 else {
3934         my $t = $_[1]->{$_[0]};
3935         return defined($t) ? $t : '$'.$_[0];
3936         }
3937 }
3938
3939 =head2 text(message, [substitute]+)
3940
3941 Returns a translated message from %text, but with $1, $2, etc.. replaced with
3942 the substitute parameters. This makes it easy to use strings with placeholders
3943 that get replaced with programmatically generated text. For example :
3944
3945  print &text('index_hello', $remote_user),"<p>\n";
3946
3947 =cut
3948 sub text
3949 {
3950 my $t = &get_module_variable('%text', 1);
3951 my $rv = exists($t->{$_[0]}) ? $t->{$_[0]} : $text{$_[0]};
3952 for(my $i=1; $i<@_; $i++) {
3953         $rv =~ s/\$$i/$_[$i]/g;
3954         }
3955 return $rv;
3956 }
3957
3958 =head2 encode_base64(string)
3959
3960 Encodes a string into base64 format, for use in MIME email or HTTP
3961 authorization headers.
3962
3963 =cut
3964 sub encode_base64
3965 {
3966 my $res;
3967 pos($_[0]) = 0;                          # ensure start at the beginning
3968 while ($_[0] =~ /(.{1,57})/gs) {
3969         $res .= substr(pack('u57', $1), 1)."\n";
3970         chop($res);
3971         }
3972 $res =~ tr|\` -_|AA-Za-z0-9+/|;
3973 my $padding = (3 - length($_[0]) % 3) % 3;
3974 $res =~ s/.{$padding}$/'=' x $padding/e if ($padding);
3975 return $res;
3976 }
3977
3978 =head2 decode_base64(string)
3979
3980 Converts a base64-encoded string into plain text. The opposite of encode_base64.
3981
3982 =cut
3983 sub decode_base64
3984 {
3985 my ($str) = @_;
3986 my $res;
3987 $str =~ tr|A-Za-z0-9+=/||cd;            # remove non-base64 chars
3988 if (length($str) % 4) {
3989         return undef;
3990 }
3991 $str =~ s/=+$//;                        # remove padding
3992 $str =~ tr|A-Za-z0-9+/| -_|;            # convert to uuencoded format
3993 while ($str =~ /(.{1,60})/gs) {
3994         my $len = chr(32 + length($1)*3/4); # compute length byte
3995         $res .= unpack("u", $len . $1 );    # uudecode
3996         }
3997 return $res;
3998 }
3999
4000 =head2 get_module_info(module, [noclone], [forcache])
4001
4002 Returns a hash containg details of the given module. Some useful keys are :
4003
4004 =item dir - The module directory, like sendmail.
4005
4006 =item desc - Human-readable description, in the current users' language.
4007
4008 =item version - Optional module version number.
4009
4010 =item os_support - List of supported operating systems and versions.
4011
4012 =item category - Category on Webmin's left menu, like net.
4013
4014 =cut
4015 sub get_module_info
4016 {
4017 return () if ($_[0] =~ /^\./);
4018 my (%rv, $clone, $o);
4019 my $mdir = &module_root_directory($_[0]);
4020 &read_file_cached("$mdir/module.info", \%rv) || return ();
4021 $clone = -l $mdir;
4022 foreach $o (@lang_order_list) {
4023         $rv{"desc"} = $rv{"desc_$o"} if ($rv{"desc_$o"});
4024         $rv{"longdesc"} = $rv{"longdesc_$o"} if ($rv{"longdesc_$o"});
4025         }
4026 if ($clone && !$_[1] && $config_directory) {
4027         $rv{'clone'} = $rv{'desc'};
4028         &read_file("$config_directory/$_[0]/clone", \%rv);
4029         }
4030 $rv{'dir'} = $_[0];
4031 my %module_categories;
4032 &read_file_cached("$config_directory/webmin.cats", \%module_categories);
4033 my $pn = &get_product_name();
4034 if (defined($rv{'category_'.$pn})) {
4035         # Can override category for webmin/usermin
4036         $rv{'category'} = $rv{'category_'.$pn};
4037         }
4038 $rv{'realcategory'} = $rv{'category'};
4039 $rv{'category'} = $module_categories{$_[0]}
4040         if (defined($module_categories{$_[0]}));
4041
4042 # Apply description overrides
4043 $rv{'realdesc'} = $rv{'desc'};
4044 my %descs;
4045 &read_file_cached("$config_directory/webmin.descs", \%descs);
4046 if ($descs{$_[0]." ".$current_lang}) {
4047         $rv{'desc'} = $descs{$_[0]." ".$current_lang};
4048         }
4049 elsif ($descs{$_[0]}) {
4050         $rv{'desc'} = $descs{$_[0]};
4051         }
4052
4053 if (!$_[2]) {
4054         # Apply per-user description overridde
4055         my %gaccess = &get_module_acl(undef, "");
4056         if ($gaccess{'desc_'.$_[0]}) {
4057                 $rv{'desc'} = $gaccess{'desc_'.$_[0]};
4058                 }
4059         }
4060
4061 if ($rv{'longdesc'}) {
4062         # All standard modules have an index.cgi
4063         $rv{'index_link'} = 'index.cgi';
4064         }
4065
4066 # Call theme-specific override function
4067 if (defined(&theme_get_module_info)) {
4068         %rv = &theme_get_module_info(\%rv, $_[0], $_[1], $_[2]);
4069         }
4070
4071 return %rv;
4072 }
4073
4074 =head2 get_all_module_infos(cachemode)
4075
4076 Returns a list contains the information on all modules in this webmin
4077 install, including clones. Uses caching to reduce the number of module.info
4078 files that need to be read. Each element of the array is a hash reference
4079 in the same format as returned by get_module_info. The cache mode flag can be :
4080 0 = read and write, 1 = don't read or write, 2 = read only
4081
4082 =cut
4083 sub get_all_module_infos
4084 {
4085 my (%cache, @rv);
4086
4087 # Is the cache out of date? (ie. have any of the root's changed?)
4088 my $cache_file = "$config_directory/module.infos.cache";
4089 my $changed = 0;
4090 if (&read_file_cached($cache_file, \%cache)) {
4091         foreach my $r (@root_directories) {
4092                 my @st = stat($r);
4093                 if ($st[9] != $cache{'mtime_'.$r}) {
4094                         $changed = 2;
4095                         last;
4096                         }
4097                 }
4098         }
4099 else {
4100         $changed = 1;
4101         }
4102
4103 if ($_[0] != 1 && !$changed && $cache{'lang'} eq $current_lang) {
4104         # Can use existing module.info cache
4105         my %mods;
4106         foreach my $k (keys %cache) {
4107                 if ($k =~ /^(\S+) (\S+)$/) {
4108                         $mods{$1}->{$2} = $cache{$k};
4109                         }
4110                 }
4111         @rv = map { $mods{$_} } (keys %mods) if (%mods);
4112         }
4113 else {
4114         # Need to rebuild cache
4115         %cache = ( );
4116         foreach my $r (@root_directories) {
4117                 opendir(DIR, $r);
4118                 foreach my $m (readdir(DIR)) {
4119                         next if ($m =~ /^(config-|\.)/ || $m =~ /\.(cgi|pl)$/);
4120                         my %minfo = &get_module_info($m, 0, 1);
4121                         next if (!%minfo || !$minfo{'dir'});
4122                         push(@rv, \%minfo);
4123                         foreach $k (keys %minfo) {
4124                                 $cache{"${m} ${k}"} = $minfo{$k};
4125                                 }
4126                         }
4127                 closedir(DIR);
4128                 my @st = stat($r);
4129                 $cache{'mtime_'.$r} = $st[9];
4130                 }
4131         $cache{'lang'} = $current_lang;
4132         &write_file($cache_file, \%cache) if (!$_[0] && $< == 0 && $> == 0);
4133         }
4134
4135 # Override descriptions for modules for current user
4136 my %gaccess = &get_module_acl(undef, "");
4137 foreach my $m (@rv) {
4138         if ($gaccess{"desc_".$m->{'dir'}}) {
4139                 $m->{'desc'} = $gaccess{"desc_".$m->{'dir'}};
4140                 }
4141         }
4142
4143 # Apply installed flags
4144 my %installed;
4145 &read_file_cached("$config_directory/installed.cache", \%installed);
4146 foreach my $m (@rv) {
4147         $m->{'installed'} = $installed{$m->{'dir'}};
4148         }
4149
4150 return @rv;
4151 }
4152
4153 =head2 get_theme_info(theme)
4154
4155 Returns a hash containing a theme's details, taken from it's theme.info file.
4156 Some useful keys are :
4157
4158 =item dir - The theme directory, like blue-theme.
4159
4160 =item desc - Human-readable description, in the current users' language.
4161
4162 =item version - Optional module version number.
4163
4164 =item os_support - List of supported operating systems and versions.
4165
4166 =cut
4167 sub get_theme_info
4168 {
4169 return () if ($_[0] =~ /^\./);
4170 my %rv;
4171 my $tdir = &module_root_directory($_[0]);
4172 &read_file("$tdir/theme.info", \%rv) || return ();
4173 foreach my $o (@lang_order_list) {
4174         $rv{"desc"} = $rv{"desc_$o"} if ($rv{"desc_$o"});
4175         }
4176 $rv{"dir"} = $_[0];
4177 return %rv;
4178 }
4179
4180 =head2 list_languages
4181
4182 Returns an array of supported languages, taken from Webmin's os_list.txt file.
4183 Each is a hash reference with the following keys :
4184
4185 =item lang - The short language code, like es for Spanish.
4186
4187 =item desc - A human-readable description, in English.
4188
4189 =item charset - An optional character set to use when displaying the language.
4190
4191 =item titles - Set to 1 only if Webmin has title images for the language.
4192
4193 =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.
4194
4195 =cut
4196 sub list_languages
4197 {
4198 if (!@main::list_languages_cache) {
4199         my $o;
4200         local $_;
4201         open(LANG, "$root_directory/lang_list.txt");
4202         while(<LANG>) {
4203                 if (/^(\S+)\s+(.*)/) {
4204                         my $l = { 'desc' => $2 };
4205                         foreach $o (split(/,/, $1)) {
4206                                 if ($o =~ /^([^=]+)=(.*)$/) {
4207                                         $l->{$1} = $2;
4208                                         }
4209                                 }
4210                         $l->{'index'} = scalar(@rv);
4211                         push(@main::list_languages_cache, $l);
4212                         }
4213                 }
4214         close(LANG);
4215         @main::list_languages_cache = sort { $a->{'desc'} cmp $b->{'desc'} }
4216                                      @main::list_languages_cache;
4217         }
4218 return @main::list_languages_cache;
4219 }
4220
4221 =head2 read_env_file(file, &hash)
4222
4223 Similar to Webmin's read_file function, but handles files containing shell
4224 environment variables formatted like :
4225
4226   export FOO=bar
4227   SMEG="spod"
4228
4229 The file parameter is the full path to the file to read, and hash a Perl hash
4230 ref to read names and values into.
4231
4232 =cut
4233 sub read_env_file
4234 {
4235 local $_;
4236 &open_readfile(FILE, $_[0]) || return 0;
4237 while(<FILE>) {
4238         s/#.*$//g;
4239         if (/^\s*(export\s*)?([A-Za-z0-9_\.]+)\s*=\s*"(.*)"/i ||
4240             /^\s*(export\s*)?([A-Za-z0-9_\.]+)\s*=\s*'(.*)'/i ||
4241             /^\s*(export\s*)?([A-Za-z0-9_\.]+)\s*=\s*(.*)/i) {
4242                 $_[1]->{$2} = $3;
4243                 }
4244         }
4245 close(FILE);
4246 return 1;
4247 }
4248
4249 =head2 write_env_file(file, &hash, [export])
4250
4251 Writes out a hash to a file in name='value' format, suitable for use in a shell
4252 script. The parameters are :
4253
4254 =item file - Full path for a file to write to
4255
4256 =item hash - Hash reference of names and values to write.
4257
4258 =item export - If set to 1, preceed each variable setting with the word 'export'.
4259
4260 =cut
4261 sub write_env_file
4262 {
4263 my $exp = $_[2] ? "export " : "";
4264 &open_tempfile(FILE, ">$_[0]");
4265 foreach my $k (keys %{$_[1]}) {
4266         my $v = $_[1]->{$k};
4267         if ($v =~ /^\S+$/) {
4268                 &print_tempfile(FILE, "$exp$k=$v\n");
4269                 }
4270         else {
4271                 &print_tempfile(FILE, "$exp$k=\"$v\"\n");
4272                 }
4273         }
4274 &close_tempfile(FILE);
4275 }
4276
4277 =head2 lock_file(filename, [readonly], [forcefile])
4278
4279 Lock a file for exclusive access. If the file is already locked, spin
4280 until it is freed. Uses a .lock file, which is not 100% reliable, but seems
4281 to work OK. The parameters are :
4282
4283 =item filename - File or directory to lock.
4284
4285 =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.
4286
4287 =item forcefile - Force the file to be considered as a real file and not a symlink for Webmin actions logging purposes.
4288
4289 =cut
4290 sub lock_file
4291 {
4292 my $realfile = &translate_filename($_[0]);
4293 return 0 if (!$_[0] || defined($main::locked_file_list{$realfile}));
4294 my $no_lock = !&can_lock_file($realfile);
4295 my $lock_tries_count = 0;
4296 while(1) {
4297         my $pid;
4298         if (!$no_lock && open(LOCKING, "$realfile.lock")) {
4299                 $pid = <LOCKING>;
4300                 $pid = int($pid);
4301                 close(LOCKING);
4302                 }
4303         if ($no_lock || !$pid || !kill(0, $pid) || $pid == $$) {
4304                 # Got the lock!
4305                 if (!$no_lock) {
4306                         # Create the .lock file
4307                         open(LOCKING, ">$realfile.lock") || return 0;
4308                         my $lck = eval "flock(LOCKING, 2+4)";
4309                         if (!$lck && !$@) {
4310                                 # Lock of lock file failed! Wait till later
4311                                 goto tryagain;
4312                                 }
4313                         print LOCKING $$,"\n";
4314                         eval "flock(LOCKING, 8)";
4315                         close(LOCKING);
4316                         }
4317                 $main::locked_file_list{$realfile} = int($_[1]);
4318                 push(@main::temporary_files, "$realfile.lock");
4319                 if (($gconfig{'logfiles'} || $gconfig{'logfullfiles'}) &&
4320                     !&get_module_variable('$no_log_file_changes') &&
4321                     !$_[1]) {
4322                         # Grab a copy of this file for later diffing
4323                         my $lnk;
4324                         $main::locked_file_data{$realfile} = undef;
4325                         if (-d $realfile) {
4326                                 $main::locked_file_type{$realfile} = 1;
4327                                 $main::locked_file_data{$realfile} = '';
4328                                 }
4329                         elsif (!$_[2] && ($lnk = readlink($realfile))) {
4330                                 $main::locked_file_type{$realfile} = 2;
4331                                 $main::locked_file_data{$realfile} = $lnk;
4332                                 }
4333                         elsif (open(ORIGFILE, $realfile)) {
4334                                 $main::locked_file_type{$realfile} = 0;
4335                                 $main::locked_file_data{$realfile} = '';
4336                                 local $_;
4337                                 while(<ORIGFILE>) {
4338                                         $main::locked_file_data{$realfile} .=$_;
4339                                         }
4340                                 close(ORIGFILE);
4341                                 }
4342                         }
4343                 last;
4344                 }
4345 tryagain:
4346         sleep(1);
4347         if ($lock_tries_count++ > 5*60) {
4348                 # Give up after 5 minutes
4349                 &error(&text('elock_tries', "<tt>$realfile</tt>", 5));
4350                 }
4351         }
4352 return 1;
4353 }
4354
4355 =head2 unlock_file(filename)
4356
4357 Release a lock on a file taken out by lock_file. If Webmin actions logging of
4358 file changes is enabled, then at unlock file a diff will be taken between the
4359 old and new contents, and stored under /var/webmin/diffs when webmin_log is
4360 called. This can then be viewed in the Webmin Actions Log module.
4361
4362 =cut
4363 sub unlock_file
4364 {
4365 my $realfile = &translate_filename($_[0]);
4366 return if (!$_[0] || !defined($main::locked_file_list{$realfile}));
4367 unlink("$realfile.lock") if (&can_lock_file($realfile));
4368 delete($main::locked_file_list{$realfile});
4369 if (exists($main::locked_file_data{$realfile})) {
4370         # Diff the new file with the old
4371         stat($realfile);
4372         my $lnk = readlink($realfile);
4373         my $type = -d _ ? 1 : $lnk ? 2 : 0;
4374         my $oldtype = $main::locked_file_type{$realfile};
4375         my $new = !defined($main::locked_file_data{$realfile});
4376         if ($new && !-e _) {
4377                 # file doesn't exist, and never did! do nothing ..
4378                 }
4379         elsif ($new && $type == 1 || !$new && $oldtype == 1) {
4380                 # is (or was) a directory ..
4381                 if (-d _ && !defined($main::locked_file_data{$realfile})) {
4382                         push(@main::locked_file_diff,
4383                              { 'type' => 'mkdir', 'object' => $realfile });
4384                         }
4385                 elsif (!-d _ && defined($main::locked_file_data{$realfile})) {
4386                         push(@main::locked_file_diff,
4387                              { 'type' => 'rmdir', 'object' => $realfile });
4388                         }
4389                 }
4390         elsif ($new && $type == 2 || !$new && $oldtype == 2) {
4391                 # is (or was) a symlink ..
4392                 if ($lnk && !defined($main::locked_file_data{$realfile})) {
4393                         push(@main::locked_file_diff,
4394                              { 'type' => 'symlink', 'object' => $realfile,
4395                                'data' => $lnk });
4396                         }
4397                 elsif (!$lnk && defined($main::locked_file_data{$realfile})) {
4398                         push(@main::locked_file_diff,
4399                              { 'type' => 'unsymlink', 'object' => $realfile,
4400                                'data' => $main::locked_file_data{$realfile} });
4401                         }
4402                 elsif ($lnk ne $main::locked_file_data{$realfile}) {
4403                         push(@main::locked_file_diff,
4404                              { 'type' => 'resymlink', 'object' => $realfile,
4405                                'data' => $lnk });
4406                         }
4407                 }
4408         else {
4409                 # is a file, or has changed type?!
4410                 my ($diff, $delete_file);
4411                 my $type = "modify";
4412                 if (!-r _) {
4413                         open(NEWFILE, ">$realfile");
4414                         close(NEWFILE);
4415                         $delete_file++;
4416                         $type = "delete";
4417                         }
4418                 if (!defined($main::locked_file_data{$realfile})) {
4419                         $type = "create";
4420                         }
4421                 open(ORIGFILE, ">$realfile.webminorig");
4422                 print ORIGFILE $main::locked_file_data{$realfile};
4423                 close(ORIGFILE);
4424                 $diff = &backquote_command(
4425                         "diff ".quotemeta("$realfile.webminorig")." ".
4426                                 quotemeta($realfile)." 2>/dev/null");
4427                 push(@main::locked_file_diff,
4428                      { 'type' => $type, 'object' => $realfile,
4429                        'data' => $diff } ) if ($diff);
4430                 unlink("$realfile.webminorig");
4431                 unlink($realfile) if ($delete_file);
4432                 }
4433
4434         if ($gconfig{'logfullfiles'}) {
4435                 # Add file details to list of those to fully log
4436                 $main::orig_file_data{$realfile} ||=
4437                         $main::locked_file_data{$realfile};
4438                 $main::orig_file_type{$realfile} ||=
4439                         $main::locked_file_type{$realfile};
4440                 }
4441
4442         delete($main::locked_file_data{$realfile});
4443         delete($main::locked_file_type{$realfile});
4444         }
4445 }
4446
4447 =head2 test_lock(file)
4448
4449 Returns 1 if some file is currently locked, 0 if not.
4450
4451 =cut
4452 sub test_lock
4453 {
4454 my $realfile = &translate_filename($_[0]);
4455 return 0 if (!$_[0]);
4456 return 1 if (defined($main::locked_file_list{$realfile}));
4457 return 0 if (!&can_lock_file($realfile));
4458 my $pid;
4459 if (open(LOCKING, "$realfile.lock")) {
4460         $pid = <LOCKING>;
4461         $pid = int($pid);
4462         close(LOCKING);
4463         }
4464 return $pid && kill(0, $pid);
4465 }
4466
4467 =head2 unlock_all_files
4468
4469 Unlocks all files locked by the current script.
4470
4471 =cut
4472 sub unlock_all_files
4473 {
4474 foreach $f (keys %main::locked_file_list) {
4475         &unlock_file($f);
4476         }
4477 }
4478
4479 =head2 can_lock_file(file)
4480
4481 Returns 1 if some file should be locked, based on the settings in the
4482 Webmin Configuration module. For internal use by lock_file only.
4483
4484 =cut
4485 sub can_lock_file
4486 {
4487 if (&is_readonly_mode()) {
4488         return 0;       # never lock in read-only mode
4489         }
4490 elsif ($gconfig{'lockmode'} == 0) {
4491         return 1;       # always
4492         }
4493 elsif ($gconfig{'lockmode'} == 1) {
4494         return 0;       # never
4495         }
4496 else {
4497         # Check if under any of the directories
4498         my $match;
4499         foreach my $d (split(/\t+/, $gconfig{'lockdirs'})) {
4500                 if (&same_file($d, $_[0]) ||
4501                     &is_under_directory($d, $_[0])) {
4502                         $match = 1;
4503                         }
4504                 }
4505         return $gconfig{'lockmode'} == 2 ? $match : !$match;
4506         }
4507 }
4508
4509 =head2 webmin_log(action, type, object, &params, [module], [host, script-on-host, client-ip])
4510
4511 Log some action taken by a user. This is typically called at the end of a
4512 script, once all file changes are complete and all commands run. The
4513 parameters are :
4514
4515 =item action - A short code for the action being performed, like 'create'.
4516
4517 =item type - A code for the type of object the action is performed to, like 'user'.
4518
4519 =item object - A short name for the object, like 'joe' if the Unix user 'joe' was just created.
4520
4521 =item params - A hash ref of additional information about the action.
4522
4523 =item module - Name of the module in which the action was performed, which defaults to the current module.
4524
4525 =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.
4526
4527 =item script-on-host - Script name like create_user.cgi on the host the action was performed on.
4528
4529 =item client-ip - IP address of the browser that performed the action.
4530
4531 =cut
4532 sub webmin_log
4533 {
4534 return if (!$gconfig{'log'} || &is_readonly_mode());
4535 my $m = $_[4] ? $_[4] : &get_module_name();
4536
4537 if ($gconfig{'logclear'}) {
4538         # check if it is time to clear the log
4539         my @st = stat("$webmin_logfile.time");
4540         my $write_logtime = 0;
4541         if (@st) {
4542                 if ($st[9]+$gconfig{'logtime'}*60*60 < time()) {
4543                         # clear logfile and all diff files
4544                         &unlink_file("$ENV{'WEBMIN_VAR'}/diffs");
4545                         &unlink_file("$ENV{'WEBMIN_VAR'}/files");
4546                         &unlink_file("$ENV{'WEBMIN_VAR'}/annotations");
4547                         unlink($webmin_logfile);
4548                         $write_logtime = 1;
4549                         }
4550                 }
4551         else {
4552                 $write_logtime = 1;
4553                 }
4554         if ($write_logtime) {
4555                 open(LOGTIME, ">$webmin_logfile.time");
4556                 print LOGTIME time(),"\n";
4557                 close(LOGTIME);
4558                 }
4559         }
4560
4561 # If an action script directory is defined, call the appropriate scripts
4562 if ($gconfig{'action_script_dir'}) {
4563     my ($action, $type, $object) = ($_[0], $_[1], $_[2]);
4564     my ($basedir) = $gconfig{'action_script_dir'};
4565
4566     for my $dir ($basedir/$type/$action, $basedir/$type, $basedir) {
4567         if (-d $dir) {
4568             my ($file);
4569             opendir(DIR, $dir) or die "Can't open $dir: $!";
4570             while (defined($file = readdir(DIR))) {
4571                 next if ($file =~ /^\.\.?$/); # skip '.' and '..'
4572                 if (-x "$dir/$file") {
4573                     # Call a script notifying it of the action
4574                     my %OLDENV = %ENV;
4575                     $ENV{'ACTION_MODULE'} = &get_module_name();
4576                     $ENV{'ACTION_ACTION'} = $_[0];
4577                     $ENV{'ACTION_TYPE'} = $_[1];
4578                     $ENV{'ACTION_OBJECT'} = $_[2];
4579                     $ENV{'ACTION_SCRIPT'} = $script_name;
4580                     foreach my $p (keys %param) {
4581                             $ENV{'ACTION_PARAM_'.uc($p)} = $param{$p};
4582                             }
4583                     system("$dir/$file", @_,
4584                            "<$null_file", ">$null_file", "2>&1");
4585                     %ENV = %OLDENV;
4586                     }
4587                 }
4588             }
4589         }
4590     }
4591
4592 # should logging be done at all?
4593 return if ($gconfig{'logusers'} && &indexof($base_remote_user,
4594            split(/\s+/, $gconfig{'logusers'})) < 0);
4595 return if ($gconfig{'logmodules'} && &indexof($m,
4596            split(/\s+/, $gconfig{'logmodules'})) < 0);
4597
4598 # log the action
4599 my $now = time();
4600 my @tm = localtime($now);
4601 my $script_name = $0 =~ /([^\/]+)$/ ? $1 : '-';
4602 my $id = sprintf "%d.%d.%d", $now, $$, $main::action_id_count;
4603 $main::action_id_count++;
4604 my $line = sprintf "%s [%2.2d/%s/%4.4d %2.2d:%2.2d:%2.2d] %s %s %s %s %s \"%s\" \"%s\" \"%s\"",
4605         $id, $tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900,
4606         $tm[2], $tm[1], $tm[0],
4607         $remote_user || '-',
4608         $main::session_id || '-',
4609         $_[7] || $ENV{'REMOTE_HOST'} || '-',
4610         $m, $_[5] ? "$_[5]:$_[6]" : $script_name,
4611         $_[0], $_[1] ne '' ? $_[1] : '-', $_[2] ne '' ? $_[2] : '-';
4612 my %param;
4613 foreach my $k (sort { $a cmp $b } keys %{$_[3]}) {
4614         my $v = $_[3]->{$k};
4615         my @pv;
4616         if ($v eq '') {
4617                 $line .= " $k=''";
4618                 @rv = ( "" );
4619                 }
4620         elsif (ref($v) eq 'ARRAY') {
4621                 foreach $vv (@$v) {
4622                         next if (ref($vv));
4623                         push(@pv, $vv);
4624                         $vv =~ s/(['"\\\r\n\t\%])/sprintf("%%%2.2X",ord($1))/ge;
4625                         $line .= " $k='$vv'";
4626                         }
4627                 }
4628         elsif (!ref($v)) {
4629                 foreach $vv (split(/\0/, $v)) {
4630                         push(@pv, $vv);
4631                         $vv =~ s/(['"\\\r\n\t\%])/sprintf("%%%2.2X",ord($1))/ge;
4632                         $line .= " $k='$vv'";
4633                         }
4634                 }
4635         $param{$k} = join(" ", @pv);
4636         }
4637 open(WEBMINLOG, ">>$webmin_logfile");
4638 print WEBMINLOG $line,"\n";
4639 close(WEBMINLOG);
4640 if ($gconfig{'logperms'}) {
4641         chmod(oct($gconfig{'logperms'}), $webmin_logfile);
4642         }
4643 else {
4644         chmod(0600, $webmin_logfile);
4645         }
4646
4647 if ($gconfig{'logfiles'} && !&get_module_variable('$no_log_file_changes')) {
4648         # Find and record the changes made to any locked files, or commands run
4649         my $i = 0;
4650         mkdir("$ENV{'WEBMIN_VAR'}/diffs", 0700);
4651         foreach my $d (@main::locked_file_diff) {
4652                 mkdir("$ENV{'WEBMIN_VAR'}/diffs/$id", 0700);
4653                 open(DIFFLOG, ">$ENV{'WEBMIN_VAR'}/diffs/$id/$i");
4654                 print DIFFLOG "$d->{'type'} $d->{'object'}\n";
4655                 print DIFFLOG $d->{'data'};
4656                 close(DIFFLOG);
4657                 if ($d->{'input'}) {
4658                         open(DIFFLOG, ">$ENV{'WEBMIN_VAR'}/diffs/$id/$i.input");
4659                         print DIFFLOG $d->{'input'};
4660                         close(DIFFLOG);
4661                         }
4662                 if ($gconfig{'logperms'}) {
4663                         chmod(oct($gconfig{'logperms'}),
4664                               "$ENV{'WEBMIN_VAR'}/diffs/$id/$i",
4665                               "$ENV{'WEBMIN_VAR'}/diffs/$id/$i.input");
4666                         }
4667                 $i++;
4668                 }
4669         @main::locked_file_diff = undef;
4670         }
4671 if ($gconfig{'logfullfiles'}) {
4672         # Save the original contents of any modified files
4673         my $i = 0;
4674         mkdir("$ENV{'WEBMIN_VAR'}/files", 0700);
4675         foreach my $f (keys %main::orig_file_data) {
4676                 mkdir("$ENV{'WEBMIN_VAR'}/files/$id", 0700);
4677                 open(ORIGLOG, ">$ENV{'WEBMIN_VAR'}/files/$id/$i");
4678                 if (!defined($main::orig_file_type{$f})) {
4679                         print ORIGLOG -1," ",$f,"\n";
4680                         }
4681                 else {
4682                         print ORIGLOG $main::orig_file_type{$f}," ",$f,"\n";
4683                         }
4684                 print ORIGLOG $main::orig_file_data{$f};
4685                 close(ORIGLOG);
4686                 if ($gconfig{'logperms'}) {
4687                         chmod(oct($gconfig{'logperms'}),
4688                               "$ENV{'WEBMIN_VAR'}/files/$id.$i");
4689                         }
4690                 $i++;
4691                 }
4692         %main::orig_file_data = undef;
4693         %main::orig_file_type = undef;
4694         }
4695
4696 # Log to syslog too
4697 if ($gconfig{'logsyslog'}) {
4698         eval 'use Sys::Syslog qw(:DEFAULT setlogsock);
4699               openlog(&get_product_name(), "cons,pid,ndelay", "daemon");
4700               setlogsock("inet");';
4701         if (!$@) {
4702                 # Syslog module is installed .. try to convert to a
4703                 # human-readable form
4704                 my $msg;
4705                 my $mod = &get_module_name();
4706                 my $mdir = module_root_directory($mod);
4707                 if (-r "$mdir/log_parser.pl") {
4708                         &foreign_require($mod, "log_parser.pl");
4709                         my %params;
4710                         foreach my $k (keys %{$_[3]}) {
4711                                 my $v = $_[3]->{$k};
4712                                 if (ref($v) eq 'ARRAY') {
4713                                         $params{$k} = join("\0", @$v);
4714                                         }
4715                                 else {
4716                                         $params{$k} = $v;
4717                                         }
4718                                 }
4719                         $msg = &foreign_call($mod, "parse_webmin_log",
4720                                 $remote_user, $script_name,
4721                                 $_[0], $_[1], $_[2], \%params);
4722                         $msg =~ s/<[^>]*>//g;   # Remove tags
4723                         }
4724                 elsif ($_[0] eq "_config_") {
4725                         my %wtext = &load_language("webminlog");
4726                         $msg = $wtext{'search_config'};
4727                         }
4728                 $msg ||= "$_[0] $_[1] $_[2]";
4729                 my %info = &get_module_info($m);
4730                 eval { syslog("info", "%s", "[$info{'desc'}] $msg"); };
4731                 }
4732         }
4733 }
4734
4735 =head2 additional_log(type, object, data, [input])
4736
4737 Records additional log data for an upcoming call to webmin_log, such
4738 as a command that was run or SQL that was executed. Typically you will never
4739 need to call this function directory.
4740
4741 =cut
4742 sub additional_log
4743 {
4744 if ($gconfig{'logfiles'} && !&get_module_variable('$no_log_file_changes')) {
4745         push(@main::locked_file_diff,
4746              { 'type' => $_[0], 'object' => $_[1], 'data' => $_[2],
4747                'input' => $_[3] } );
4748         }
4749 }
4750
4751 =head2 webmin_debug_log(type, message)
4752
4753 Write something to the Webmin debug log. For internal use only.
4754
4755 =cut
4756 sub webmin_debug_log
4757 {
4758 my ($type, $msg) = @_;
4759 return 0 if (!$main::opened_debug_log);
4760 return 0 if ($gconfig{'debug_no'.$main::webmin_script_type});
4761 if ($gconfig{'debug_modules'}) {
4762         my @dmods = split(/\s+/, $gconfig{'debug_modules'});
4763         return 0 if (&indexof($main::initial_module_name, @dmods) < 0);
4764         }
4765 my $now = time();
4766 my @tm = localtime($now);
4767 my $line = sprintf
4768         "%s [%2.2d/%s/%4.4d %2.2d:%2.2d:%2.2d] %s %s %s %s \"%s\"",
4769         $$, $tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900,
4770         $tm[2], $tm[1], $tm[0],
4771         $remote_user || "-",
4772         $ENV{'REMOTE_HOST'} || "-",
4773         &get_module_name() || "-",
4774         $type,
4775         $msg;
4776 seek(main::DEBUGLOG, 0, 2);
4777 print main::DEBUGLOG $line."\n";
4778 return 1;
4779 }
4780
4781 =head2 system_logged(command)
4782
4783 Just calls the Perl system() function, but also logs the command run.
4784
4785 =cut
4786 sub system_logged
4787 {
4788 if (&is_readonly_mode()) {
4789         print STDERR "Vetoing command $_[0]\n";
4790         return 0;
4791         }
4792 my @realcmd = ( &translate_command($_[0]), @_[1..$#_] );
4793 my $cmd = join(" ", @realcmd);
4794 my $and;
4795 if ($cmd =~ s/(\s*&\s*)$//) {
4796         $and = $1;
4797         }
4798 while($cmd =~ s/(\d*)(<|>)((\/(tmp|dev)\S+)|&\d+)\s*$//) { }
4799 $cmd =~ s/^\((.*)\)\s*$/$1/;
4800 $cmd .= $and;
4801 &additional_log('exec', undef, $cmd);
4802 return system(@realcmd);
4803 }
4804
4805 =head2 backquote_logged(command)
4806
4807 Executes a command and returns the output (like `command`), but also logs it.
4808
4809 =cut
4810 sub backquote_logged
4811 {
4812 if (&is_readonly_mode()) {
4813         $? = 0;
4814         print STDERR "Vetoing command $_[0]\n";
4815         return undef;
4816         }
4817 my $realcmd = &translate_command($_[0]);
4818 my $cmd = $realcmd;
4819 my $and;
4820 if ($cmd =~ s/(\s*&\s*)$//) {
4821         $and = $1;
4822         }
4823 while($cmd =~ s/(\d*)(<|>)((\/(tmp\/.webmin|dev)\S+)|&\d+)\s*$//) { }
4824 $cmd =~ s/^\((.*)\)\s*$/$1/;
4825 $cmd .= $and;
4826 &additional_log('exec', undef, $cmd);
4827 &webmin_debug_log('CMD', "cmd=$cmd") if ($gconfig{'debug_what_cmd'});
4828 return `$realcmd`;
4829 }
4830
4831 =head2 backquote_with_timeout(command, timeout, safe?, [maxlines])
4832
4833 Runs some command, waiting at most the given number of seconds for it to
4834 complete, and returns the output. The maxlines parameter sets the number
4835 of lines of output to capture. The safe parameter should be set to 1 if the
4836 command is safe for read-only mode users to run.
4837
4838 =cut
4839 sub backquote_with_timeout
4840 {
4841 my $realcmd = &translate_command($_[0]);
4842 &webmin_debug_log('CMD', "cmd=$realcmd timeout=$_[1]")
4843         if ($gconfig{'debug_what_cmd'});
4844 my $out;
4845 my $pid = &open_execute_command(OUT, "($realcmd) <$null_file", 1, $_[2]);
4846 my $start = time();
4847 my $timed_out = 0;
4848 my $linecount = 0;
4849 while(1) {
4850         my $elapsed = time() - $start;
4851         last if ($elapsed > $_[1]);
4852         my $rmask;
4853         vec($rmask, fileno(OUT), 1) = 1;
4854         my $sel = select($rmask, undef, undef, $_[1] - $elapsed);
4855         last if (!$sel || $sel < 0);
4856         my $line = <OUT>;
4857         last if (!defined($line));
4858         $out .= $line;
4859         $linecount++;
4860         if ($_[3] && $linecount >= $_[3]) {
4861                 # Got enough lines
4862                 last;
4863                 }
4864         }
4865 if (kill('TERM', $pid) && time() - $start >= $_[1]) {
4866         $timed_out = 1;
4867         }
4868 close(OUT);
4869 return wantarray ? ($out, $timed_out) : $out;
4870 }
4871
4872 =head2 backquote_command(command, safe?)
4873
4874 Executes a command and returns the output (like `command`), subject to
4875 command translation. The safe parameter should be set to 1 if the command
4876 is safe for read-only mode users to run.
4877
4878 =cut
4879 sub backquote_command
4880 {
4881 if (&is_readonly_mode() && !$_[1]) {
4882         print STDERR "Vetoing command $_[0]\n";
4883         $? = 0;
4884         return undef;
4885         }
4886 my $realcmd = &translate_command($_[0]);
4887 &webmin_debug_log('CMD', "cmd=$realcmd") if ($gconfig{'debug_what_cmd'});
4888 return `$realcmd`;
4889 }
4890
4891 =head2 kill_logged(signal, pid, ...)
4892
4893 Like Perl's built-in kill function, but also logs the fact that some process
4894 was killed. On Windows, falls back to calling process.exe to terminate a
4895 process.
4896
4897 =cut
4898 sub kill_logged
4899 {
4900 return scalar(@_)-1 if (&is_readonly_mode());
4901 &webmin_debug_log('KILL', "signal=$_[0] pids=".join(" ", @_[1..@_-1]))
4902         if ($gconfig{'debug_what_procs'});
4903 &additional_log('kill', $_[0], join(" ", @_[1..@_-1])) if (@_ > 1);
4904 if ($gconfig{'os_type'} eq 'windows') {
4905         # Emulate some kills with process.exe
4906         my $arg = $_[0] eq "KILL" ? "-k" :
4907                   $_[0] eq "TERM" ? "-q" :
4908                   $_[0] eq "STOP" ? "-s" :
4909                   $_[0] eq "CONT" ? "-r" : undef;
4910         my $ok = 0;
4911         foreach my $p (@_[1..@_-1]) {
4912                 if ($p < 0) {
4913                         $ok ||= kill($_[0], $p);
4914                         }
4915                 elsif ($arg) {
4916                         &execute_command("process $arg $p");
4917                         $ok = 1;
4918                         }
4919                 }
4920         return $ok;
4921         }
4922 else {
4923         # Normal Unix kill
4924         return kill(@_);
4925         }
4926 }
4927
4928 =head2 rename_logged(old, new)
4929
4930 Re-names a file and logs the rename. If the old and new files are on different
4931 filesystems, calls mv or the Windows rename function to do the job.
4932
4933 =cut
4934 sub rename_logged
4935 {
4936 &additional_log('rename', $_[0], $_[1]) if ($_[0] ne $_[1]);
4937 return &rename_file($_[0], $_[1]);
4938 }
4939
4940 =head2 rename_file(old, new)
4941
4942 Renames a file or directory. If the old and new files are on different
4943 filesystems, calls mv or the Windows rename function to do the job.
4944
4945 =cut
4946 sub rename_file
4947 {
4948 if (&is_readonly_mode()) {
4949         print STDERR "Vetoing rename from $_[0] to $_[1]\n";
4950         return 1;
4951         }
4952 my $src = &translate_filename($_[0]);
4953 my $dst = &translate_filename($_[1]);
4954 &webmin_debug_log('RENAME', "src=$src dst=$dst")
4955         if ($gconfig{'debug_what_ops'});
4956 my $ok = rename($src, $dst);
4957 if (!$ok && $! !~ /permission/i) {
4958         # Try the mv command, in case this is a cross-filesystem rename
4959         if ($gconfig{'os_type'} eq 'windows') {
4960                 # Need to use rename
4961                 my $out = &backquote_command("rename ".quotemeta($_[0]).
4962                                              " ".quotemeta($_[1])." 2>&1");
4963                 $ok = !$?;
4964                 $! = $out if (!$ok);
4965                 }
4966         else {
4967                 # Can use mv
4968                 my $out = &backquote_command("mv ".quotemeta($_[0]).
4969                                              " ".quotemeta($_[1])." 2>&1");
4970                 $ok = !$?;
4971                 $! = $out if (!$ok);
4972                 }
4973         }
4974 return $ok;
4975 }
4976
4977 =head2 symlink_logged(src, dest)
4978
4979 Create a symlink, and logs it. Effectively does the same thing as the Perl
4980 symlink function.
4981
4982 =cut
4983 sub symlink_logged
4984 {
4985 &lock_file($_[1]);
4986 my $rv = &symlink_file($_[0], $_[1]);
4987 &unlock_file($_[1]);
4988 return $rv;
4989 }
4990
4991 =head2 symlink_file(src, dest)
4992
4993 Creates a soft link, unless in read-only mode. Effectively does the same thing
4994 as the Perl symlink function.
4995
4996 =cut
4997 sub symlink_file
4998 {
4999 if (&is_readonly_mode()) {
5000         print STDERR "Vetoing symlink from $_[0] to $_[1]\n";
5001         return 1;
5002         }
5003 my $src = &translate_filename($_[0]);
5004 my $dst = &translate_filename($_[1]);
5005 &webmin_debug_log('SYMLINK', "src=$src dst=$dst")
5006         if ($gconfig{'debug_what_ops'});
5007 return symlink($src, $dst);
5008 }
5009
5010 =head2 link_file(src, dest)
5011
5012 Creates a hard link, unless in read-only mode. The existing new link file
5013 will be deleted if necessary. Effectively the same as Perl's link function.
5014
5015 =cut
5016 sub link_file
5017 {
5018 if (&is_readonly_mode()) {
5019         print STDERR "Vetoing link from $_[0] to $_[1]\n";
5020         return 1;
5021         }
5022 my $src = &translate_filename($_[0]);
5023 my $dst = &translate_filename($_[1]);
5024 &webmin_debug_log('LINK', "src=$src dst=$dst")
5025         if ($gconfig{'debug_what_ops'});
5026 unlink($dst);                   # make sure link works
5027 return link($src, $dst);
5028 }
5029
5030 =head2 make_dir(dir, perms, recursive)
5031
5032 Creates a directory and sets permissions on it, unless in read-only mode.
5033 The perms parameter sets the octal permissions to apply, which unlike Perl's
5034 mkdir will really get set. The recursive flag can be set to 1 to have the
5035 function create parent directories too.
5036
5037 =cut
5038 sub make_dir
5039 {
5040 my ($dir, $perms, $recur) = @_;
5041 if (&is_readonly_mode()) {
5042         print STDERR "Vetoing directory $dir\n";
5043         return 1;
5044         }
5045 $dir = &translate_filename($dir);
5046 my $exists = -d $dir ? 1 : 0;
5047 return 1 if ($exists && $recur);        # already exists
5048 &webmin_debug_log('MKDIR', $dir) if ($gconfig{'debug_what_ops'});
5049 my $rv = mkdir($dir, $perms);
5050 if (!$rv && $recur) {
5051         # Failed .. try mkdir -p
5052         my $param = $gconfig{'os_type'} eq 'windows' ? "" : "-p";
5053         my $ex = &execute_command("mkdir $param ".&quote_path($dir));
5054         if ($ex) {
5055                 return 0;
5056                 }
5057         }
5058 if (!$exists) {
5059         chmod($perms, $dir);
5060         }
5061 return 1;
5062 }
5063
5064 =head2 set_ownership_permissions(user, group, perms, file, ...)
5065
5066 Sets the user, group owner and permissions on some files. The parameters are :
5067
5068 =item user - UID or username to change the file owner to. If undef, then the owner is not changed.
5069
5070 =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.
5071
5072 =item perms - Octal permissions set to set on the file. If undef, they are left alone.
5073
5074 =item file - One or more files or directories to modify.
5075
5076 =cut
5077 sub set_ownership_permissions
5078 {
5079 my ($user, $group, $perms, @files) = @_;
5080 if (&is_readonly_mode()) {
5081         print STDERR "Vetoing permission changes on ",join(" ", @files),"\n";
5082         return 1;
5083         }
5084 @files = map { &translate_filename($_) } @files;
5085 if ($gconfig{'debug_what_ops'}) {
5086         foreach my $f (@files) {
5087                 &webmin_debug_log('PERMS',
5088                         "file=$f user=$user group=$group perms=$perms");
5089                 }
5090         }
5091 my $rv = 1;
5092 if (defined($user)) {
5093         my $uid = $user !~ /^\d+$/ ? getpwnam($user) : $user;
5094         my $gid;
5095         if (defined($group)) {
5096                 $gid = $group !~ /^\d+$/ ? getgrnam($group) : $group;
5097                 }
5098         else {
5099                 my @uinfo = getpwuid($uid);
5100                 $gid = $uinfo[3];
5101                 }
5102         $rv = chown($uid, $gid, @files);
5103         }
5104 if ($rv && defined($perms)) {
5105         $rv = chmod($perms, @files);
5106         }
5107 return $rv;
5108 }
5109
5110 =head2 unlink_logged(file, ...)
5111
5112 Like Perl's unlink function, but locks the files beforehand and un-locks them
5113 after so that the deletion is logged by Webmin.
5114
5115 =cut
5116 sub unlink_logged
5117 {
5118 my %locked;
5119 foreach my $f (@_) {
5120         if (!&test_lock($f)) {
5121                 &lock_file($f);
5122                 $locked{$f} = 1;
5123                 }
5124         }
5125 my @rv = &unlink_file(@_);
5126 foreach my $f (@_) {
5127         if ($locked{$f}) {
5128                 &unlock_file($f);
5129                 }
5130         }
5131 return wantarray ? @rv : $rv[0];
5132 }
5133
5134 =head2 unlink_file(file, ...)
5135
5136 Deletes some files or directories. Like Perl's unlink function, but also
5137 recursively deletes directories with the rm command if needed.
5138
5139 =cut
5140 sub unlink_file
5141 {
5142 return 1 if (&is_readonly_mode());
5143 my $rv = 1;
5144 my $err;
5145 foreach my $f (@_) {
5146         &unflush_file_lines($f);
5147         my $realf = &translate_filename($f);
5148         &webmin_debug_log('UNLINK', $realf) if ($gconfig{'debug_what_ops'});
5149         if (-d $realf) {
5150                 if (!rmdir($realf)) {
5151                         my $out;
5152                         if ($gconfig{'os_type'} eq 'windows') {
5153                                 # Call del and rmdir commands
5154                                 my $qm = $realf;
5155                                 $qm =~ s/\//\\/g;
5156                                 my $out = `del /q "$qm" 2>&1`;
5157                                 if (!$?) {
5158                                         $out = `rmdir "$qm" 2>&1`;
5159                                         }
5160                                 }
5161                         else {
5162                                 # Use rm command
5163                                 my $qm = quotemeta($realf);
5164                                 $out = `rm -rf $qm 2>&1`;
5165                                 }
5166                         if ($?) {
5167                                 $rv = 0;
5168                                 $err = $out;
5169                                 }
5170                         }
5171                 }
5172         else {
5173                 if (!unlink($realf)) {
5174                         $rv = 0;
5175                         $err = $!;
5176                         }
5177                 }
5178         }
5179 return wantarray ? ($rv, $err) : $rv;
5180 }
5181
5182 =head2 copy_source_dest(source, dest)
5183
5184 Copy some file or directory to a new location. Returns 1 on success, or 0
5185 on failure - also sets $! on failure. If the source is a directory, uses
5186 piped tar commands to copy a whole directory structure including permissions
5187 and special files.
5188
5189 =cut
5190 sub copy_source_dest
5191 {
5192 return (1, undef) if (&is_readonly_mode());
5193 my ($src, $dst) = @_;
5194 my $ok = 1;
5195 my ($err, $out);
5196 &webmin_debug_log('COPY', "src=$src dst=$dst")
5197         if ($gconfig{'debug_what_ops'});
5198 if ($gconfig{'os_type'} eq 'windows') {
5199         # No tar or cp on windows, so need to use copy command
5200         $src =~ s/\//\\/g;
5201         $dst =~ s/\//\\/g;
5202         if (-d $src) {
5203                 $out = &backquote_logged("xcopy \"$src\" \"$dst\" /Y /E /I 2>&1");
5204                 }
5205         else {
5206                 $out = &backquote_logged("copy /Y \"$src\" \"$dst\" 2>&1");
5207                 }
5208         if ($?) {
5209                 $ok = 0;
5210                 $err = $out;
5211                 }
5212         }
5213 elsif (-d $src) {
5214         # A directory .. need to copy with tar command
5215         my @st = stat($src);
5216         unlink($dst);
5217         mkdir($dst, 0755);
5218         &set_ownership_permissions($st[4], $st[5], $st[2], $dst);
5219         $out = &backquote_logged("(cd ".quotemeta($src)." ; tar cf - . | (cd ".quotemeta($dst)." ; tar xf -)) 2>&1");
5220         if ($?) {
5221                 $ok = 0;
5222                 $err = $out;
5223                 }
5224         }
5225 else {
5226         # Can just copy with cp
5227         my $out = &backquote_logged("cp -p ".quotemeta($src).
5228                                     " ".quotemeta($dst)." 2>&1");
5229         if ($?) {
5230                 $ok = 0;
5231                 $err = $out;
5232                 }
5233         }
5234 return wantarray ? ($ok, $err) : $ok;
5235 }
5236
5237 =head2 remote_session_name(host|&server)
5238
5239 Generates a session ID for some server. For this server, this will always
5240 be an empty string. For a server object it will include the hostname and
5241 port and PID. For a server name, it will include the hostname and PID. For
5242 internal use only.
5243
5244 =cut
5245 sub remote_session_name
5246 {
5247 return ref($_[0]) && $_[0]->{'host'} && $_[0]->{'port'} ?
5248                 "$_[0]->{'host'}:$_[0]->{'port'}.$$" :
5249        $_[0] eq "" || ref($_[0]) && $_[0]->{'id'} == 0 ? "" :
5250        ref($_[0]) ? "" : "$_[0].$$";
5251 }
5252
5253 =head2 remote_foreign_require(server, module, file)
5254
5255 Connects to rpc.cgi on a remote webmin server and have it open a session
5256 to a process that will actually do the require and run functions. This is the
5257 equivalent for foreign_require, but for a remote Webmin system. The server
5258 parameter can either be a hostname of a system registered in the Webmin
5259 Servers Index module, or a hash reference for a system from that module.
5260
5261 =cut
5262 sub remote_foreign_require
5263 {
5264 my $call = { 'action' => 'require',
5265              'module' => $_[1],
5266              'file' => $_[2] };
5267 my $sn = &remote_session_name($_[0]);
5268 if ($remote_session{$sn}) {
5269         $call->{'session'} = $remote_session{$sn};
5270         }
5271 else {
5272         $call->{'newsession'} = 1;
5273         }
5274 my $rv = &remote_rpc_call($_[0], $call);
5275 if ($rv->{'session'}) {
5276         $remote_session{$sn} = $rv->{'session'};
5277         $remote_session_server{$sn} = $_[0];
5278         }
5279 }
5280
5281 =head2 remote_foreign_call(server, module, function, [arg]*)
5282
5283 Call a function on a remote server. Must have been setup first with
5284 remote_foreign_require for the same server and module. Equivalent to
5285 foreign_call, but with the extra server parameter to specify the remote
5286 system's hostname.
5287
5288 =cut
5289 sub remote_foreign_call
5290 {
5291 return undef if (&is_readonly_mode());
5292 my $sn = &remote_session_name($_[0]);
5293 return &remote_rpc_call($_[0], { 'action' => 'call',
5294                                  'module' => $_[1],
5295                                  'func' => $_[2],
5296                                  'session' => $remote_session{$sn},
5297                                  'args' => [ @_[3 .. $#_] ] } );
5298 }
5299
5300 =head2 remote_foreign_check(server, module, [api-only])
5301
5302 Checks if some module is installed and supported on a remote server. Equivilant
5303 to foreign_check, but for the remote Webmin system specified by the server
5304 parameter.
5305
5306 =cut
5307 sub remote_foreign_check
5308 {
5309 return &remote_rpc_call($_[0], { 'action' => 'check',
5310                                  'module' => $_[1],
5311                                  'api' => $_[2] });
5312 }
5313
5314 =head2 remote_foreign_config(server, module)
5315
5316 Gets the configuration for some module from a remote server, as a hash.
5317 Equivalent to foreign_config, but for a remote system.
5318
5319 =cut
5320 sub remote_foreign_config
5321 {
5322 return &remote_rpc_call($_[0], { 'action' => 'config',
5323                                  'module' => $_[1] });
5324 }
5325
5326 =head2 remote_eval(server, module, code)
5327
5328 Evaluates some perl code in the context of a module on a remote webmin server.
5329 The server parameter must be the hostname of a remote system, module must
5330 be a module directory name, and code a string of Perl code to run. This can
5331 only be called after remote_foreign_require for the same server and module.
5332
5333 =cut
5334 sub remote_eval
5335 {
5336 return undef if (&is_readonly_mode());
5337 my $sn = &remote_session_name($_[0]);
5338 return &remote_rpc_call($_[0], { 'action' => 'eval',
5339                                  'module' => $_[1],
5340                                  'code' => $_[2],
5341                                  'session' => $remote_session{$sn} });
5342 }
5343
5344 =head2 remote_write(server, localfile, [remotefile], [remotebasename])
5345
5346 Transfers some local file to another server via Webmin's RPC protocol, and
5347 returns the resulting remote filename. If the remotefile parameter is given,
5348 that is the destination filename which will be used. Otherwise a randomly
5349 selected temporary filename will be used, and returned by the function.
5350
5351 =cut
5352 sub remote_write
5353 {
5354 return undef if (&is_readonly_mode());
5355 my ($data, $got);
5356 my $sn = &remote_session_name($_[0]);
5357 if (!$_[0] || $remote_server_version{$sn} >= 0.966) {
5358         # Copy data over TCP connection
5359         my $rv = &remote_rpc_call($_[0], { 'action' => 'tcpwrite',
5360                                            'file' => $_[2],
5361                                            'name' => $_[3] } );
5362         my $error;
5363         my $serv = ref($_[0]) ? $_[0]->{'host'} : $_[0];
5364         &open_socket($serv || "localhost", $rv->[1], TWRITE, \$error);
5365         return &$main::remote_error_handler("Failed to transfer file : $error")
5366                 if ($error);
5367         open(FILE, $_[1]);
5368         while(read(FILE, $got, 1024) > 0) {
5369                 print TWRITE $got;
5370                 }
5371         close(FILE);
5372         shutdown(TWRITE, 1);
5373         $error = <TWRITE>;
5374         if ($error && $error !~ /^OK/) {
5375                 # Got back an error!
5376                 return &$main::remote_error_handler("Failed to transfer file : $error");
5377                 }
5378         close(TWRITE);
5379         return $rv->[0];
5380         }
5381 else {
5382         # Just pass file contents as parameters
5383         open(FILE, $_[1]);
5384         while(read(FILE, $got, 1024) > 0) {
5385                 $data .= $got;
5386                 }
5387         close(FILE);
5388         return &remote_rpc_call($_[0], { 'action' => 'write',
5389                                          'data' => $data,
5390                                          'file' => $_[2],
5391                                          'session' => $remote_session{$sn} });
5392         }
5393 }
5394
5395 =head2 remote_read(server, localfile, remotefile)
5396
5397 Transfers a file from a remote server to this system, using Webmin's RPC
5398 protocol. The server parameter must be the hostname of a system registered
5399 in the Webmin Servers Index module, localfile is the destination path on this
5400 system, and remotefile is the file to fetch from the remote server.
5401
5402 =cut
5403 sub remote_read
5404 {
5405 my $sn = &remote_session_name($_[0]);
5406 if (!$_[0] || $remote_server_version{$sn} >= 0.966) {
5407         # Copy data over TCP connection
5408         my $rv = &remote_rpc_call($_[0], { 'action' => 'tcpread',
5409                                            'file' => $_[2] } );
5410         if (!$rv->[0]) {
5411                 return &$main::remote_error_handler("Failed to transfer file : $rv->[1]");
5412                 }
5413         my $error;
5414         my $serv = ref($_[0]) ? $_[0]->{'host'} : $_[0];
5415         &open_socket($serv || "localhost", $rv->[1], TREAD, \$error);
5416         return &$main::remote_error_handler("Failed to transfer file : $error")
5417                 if ($error);
5418         my $got;
5419         open(FILE, ">$_[1]");
5420         while(read(TREAD, $got, 1024) > 0) {
5421                 print FILE $got;
5422                 }
5423         close(FILE);
5424         close(TREAD);
5425         }
5426 else {
5427         # Just get data as return value
5428         my $d = &remote_rpc_call($_[0], { 'action' => 'read',
5429                                           'file' => $_[2],
5430                                           'session' => $remote_session{$sn} });
5431         open(FILE, ">$_[1]");
5432         print FILE $d;
5433         close(FILE);
5434         }
5435 }
5436
5437 =head2 remote_finished
5438
5439 Close all remote sessions. This happens automatically after a while
5440 anyway, but this function should be called to clean things up faster.
5441
5442 =cut
5443 sub remote_finished
5444 {
5445 foreach my $sn (keys %remote_session) {
5446         my $server = $remote_session_server{$sn};
5447         &remote_rpc_call($server, { 'action' => 'quit',
5448                                     'session' => $remote_session{$sn} } );
5449         delete($remote_session{$sn});
5450         delete($remote_session_server{$sn});
5451         }
5452 foreach $fh (keys %fast_fh_cache) {
5453         close($fh);
5454         delete($fast_fh_cache{$fh});
5455         }
5456 }
5457
5458 =head2 remote_error_setup(&function)
5459
5460 Sets a function to be called instead of &error when a remote RPC operation
5461 fails. Useful if you want to have more control over your remote operations.
5462
5463 =cut
5464 sub remote_error_setup
5465 {
5466 $main::remote_error_handler = $_[0] || \&error;
5467 }
5468
5469 =head2 remote_rpc_call(server, structure)
5470
5471 Calls rpc.cgi on some server and passes it a perl structure (hash,array,etc)
5472 and then reads back a reply structure. This is mainly for internal use only,
5473 and is called by the other remote_* functions.
5474
5475 =cut
5476 sub remote_rpc_call
5477 {
5478 my $serv;
5479 my $sn = &remote_session_name($_[0]);   # Will be undef for local connection
5480 if (ref($_[0])) {
5481         # Server structure was given
5482         $serv = $_[0];
5483         $serv->{'user'} || $serv->{'id'} == 0 ||
5484                 return &$main::remote_error_handler(
5485                         "No Webmin login set for server");
5486         }
5487 elsif ($_[0]) {
5488         # lookup the server in the webmin servers module if needed
5489         if (!%main::remote_servers_cache) {
5490                 &foreign_require("servers", "servers-lib.pl");
5491                 foreach $s (&foreign_call("servers", "list_servers")) {
5492                         $main::remote_servers_cache{$s->{'host'}} = $s;
5493                         $main::remote_servers_cache{$s->{'host'}.":".$s->{'port'}} = $s;
5494                         }
5495                 }
5496         $serv = $main::remote_servers_cache{$_[0]};
5497         $serv || return &$main::remote_error_handler(
5498                                 "No Webmin Servers entry for $_[0]");
5499         $serv->{'user'} || return &$main::remote_error_handler(
5500                                 "No login set for server $_[0]");
5501         }
5502 my $ip = $serv->{'ip'} || $serv->{'host'};
5503
5504 # Work out the username and password
5505 my ($user, $pass);
5506 if ($serv->{'sameuser'}) {
5507         $user = $remote_user;
5508         defined($main::remote_pass) || return &$main::remote_error_handler(
5509                                    "Password for this server is not available");
5510         $pass = $main::remote_pass;
5511         }
5512 else {
5513         $user = $serv->{'user'};
5514         $pass = $serv->{'pass'};
5515         }
5516
5517 if ($serv->{'fast'} || !$sn) {
5518         # Make TCP connection call to fastrpc.cgi
5519         if (!$fast_fh_cache{$sn} && $sn) {
5520                 # Need to open the connection
5521                 my $con = &make_http_connection(
5522                         $ip, $serv->{'port'}, $serv->{'ssl'},
5523                         "POST", "/fastrpc.cgi");
5524                 return &$main::remote_error_handler(
5525                     "Failed to connect to $serv->{'host'} : $con")
5526                         if (!ref($con));
5527                 &write_http_connection($con, "Host: $serv->{'host'}\r\n");
5528                 &write_http_connection($con, "User-agent: Webmin\r\n");
5529                 my $auth = &encode_base64("$user:$pass");
5530                 $auth =~ tr/\n//d;
5531                 &write_http_connection($con, "Authorization: basic $auth\r\n");
5532                 &write_http_connection($con, "Content-length: ",
5533                                              length($tostr),"\r\n");
5534                 &write_http_connection($con, "\r\n");
5535                 &write_http_connection($con, $tostr);
5536
5537                 # read back the response
5538                 my $line = &read_http_connection($con);
5539                 $line =~ tr/\r\n//d;
5540                 if ($line =~ /^HTTP\/1\..\s+401\s+/) {
5541                         return &$main::remote_error_handler("Login to RPC server as $user rejected");
5542                         }
5543                 $line =~ /^HTTP\/1\..\s+200\s+/ ||
5544                         return &$main::remote_error_handler("HTTP error : $line");
5545                 do {
5546                         $line = &read_http_connection($con);
5547                         $line =~ tr/\r\n//d;
5548                         } while($line);
5549                 $line = &read_http_connection($con);
5550                 if ($line =~ /^0\s+(.*)/) {
5551                         return &$main::remote_error_handler("RPC error : $1");
5552                         }
5553                 elsif ($line =~ /^1\s+(\S+)\s+(\S+)\s+(\S+)/ ||
5554                        $line =~ /^1\s+(\S+)\s+(\S+)/) {
5555                         # Started ok .. connect and save SID
5556                         &close_http_connection($con);
5557                         my ($port, $sid, $version, $error) = ($1, $2, $3);
5558                         &open_socket($ip, $port, $sid, \$error);
5559                         return &$main::remote_error_handler("Failed to connect to fastrpc.cgi : $error")
5560                                 if ($error);
5561                         $fast_fh_cache{$sn} = $sid;
5562                         $remote_server_version{$sn} = $version;
5563                         }
5564                 else {
5565                         while($stuff = &read_http_connection($con)) {
5566                                 $line .= $stuff;
5567                                 }
5568                         return &$main::remote_error_handler("Bad response from fastrpc.cgi : $line");
5569                         }
5570                 }
5571         elsif (!$fast_fh_cache{$sn}) {
5572                 # Open the connection by running fastrpc.cgi locally
5573                 pipe(RPCOUTr, RPCOUTw);
5574                 if (!fork()) {
5575                         untie(*STDIN);
5576                         untie(*STDOUT);
5577                         open(STDOUT, ">&RPCOUTw");
5578                         close(STDIN);
5579                         close(RPCOUTr);
5580                         $| = 1;
5581                         $ENV{'REQUEST_METHOD'} = 'GET';
5582                         $ENV{'SCRIPT_NAME'} = '/fastrpc.cgi';
5583                         $ENV{'SERVER_ROOT'} ||= $root_directory;
5584                         my %acl;
5585                         if ($base_remote_user ne 'root' &&
5586                             $base_remote_user ne 'admin') {
5587                                 # Need to fake up a login for the CGI!
5588                                 &read_acl(undef, \%acl);
5589                                 $ENV{'BASE_REMOTE_USER'} =
5590                                         $ENV{'REMOTE_USER'} =
5591                                                 $acl{'root'} ? 'root' : 'admin';
5592                                 }
5593                         delete($ENV{'FOREIGN_MODULE_NAME'});
5594                         delete($ENV{'FOREIGN_ROOT_DIRECTORY'});
5595                         chdir($root_directory);
5596                         if (!exec("$root_directory/fastrpc.cgi")) {
5597                                 print "exec failed : $!\n";
5598                                 exit 1;
5599                                 }
5600                         }
5601                 close(RPCOUTw);
5602                 my $line;
5603                 do {
5604                         ($line = <RPCOUTr>) =~ tr/\r\n//d;
5605                         } while($line);
5606                 $line = <RPCOUTr>;
5607                 #close(RPCOUTr);
5608                 if ($line =~ /^0\s+(.*)/) {
5609                         return &$main::remote_error_handler("RPC error : $2");
5610                         }
5611                 elsif ($line =~ /^1\s+(\S+)\s+(\S+)/) {
5612                         # Started ok .. connect and save SID
5613                         close(SOCK);
5614                         my ($port, $sid, $error) = ($1, $2, undef);
5615                         &open_socket("localhost", $port, $sid, \$error);
5616                         return &$main::remote_error_handler("Failed to connect to fastrpc.cgi : $error") if ($error);
5617                         $fast_fh_cache{$sn} = $sid;
5618                         }
5619                 else {
5620                         local $_;
5621                         while(<RPCOUTr>) {
5622                                 $line .= $_;
5623                                 }
5624                         &error("Bad response from fastrpc.cgi : $line");
5625                         }
5626                 }
5627         # Got a connection .. send off the request
5628         my $fh = $fast_fh_cache{$sn};
5629         my $tostr = &serialise_variable($_[1]);
5630         print $fh length($tostr)," $fh\n";
5631         print $fh $tostr;
5632         my $rlen = int(<$fh>);
5633         my ($fromstr, $got);
5634         while(length($fromstr) < $rlen) {
5635                 return &$main::remote_error_handler("Failed to read from fastrpc.cgi")
5636                         if (read($fh, $got, $rlen - length($fromstr)) <= 0);
5637                 $fromstr .= $got;
5638                 }
5639         my $from = &unserialise_variable($fromstr);
5640         if (!$from) {
5641                 return &$main::remote_error_handler("Remote Webmin error");
5642                 }
5643         if (defined($from->{'arv'})) {
5644                 return @{$from->{'arv'}};
5645                 }
5646         else {
5647                 return $from->{'rv'};
5648                 }
5649         }
5650 else {
5651         # Call rpc.cgi on remote server
5652         my $tostr = &serialise_variable($_[1]);
5653         my $error = 0;
5654         my $con = &make_http_connection($ip, $serv->{'port'},
5655                                         $serv->{'ssl'}, "POST", "/rpc.cgi");
5656         return &$main::remote_error_handler("Failed to connect to $serv->{'host'} : $con") if (!ref($con));
5657
5658         &write_http_connection($con, "Host: $serv->{'host'}\r\n");
5659         &write_http_connection($con, "User-agent: Webmin\r\n");
5660         my $auth = &encode_base64("$user:$pass");
5661         $auth =~ tr/\n//d;
5662         &write_http_connection($con, "Authorization: basic $auth\r\n");
5663         &write_http_connection($con, "Content-length: ",length($tostr),"\r\n");
5664         &write_http_connection($con, "\r\n");
5665         &write_http_connection($con, $tostr);
5666
5667         # read back the response
5668         my $line = &read_http_connection($con);
5669         $line =~ tr/\r\n//d;
5670         if ($line =~ /^HTTP\/1\..\s+401\s+/) {
5671                 return &$main::remote_error_handler("Login to RPC server as $user rejected");
5672                 }
5673         $line =~ /^HTTP\/1\..\s+200\s+/ || return &$main::remote_error_handler("RPC HTTP error : $line");
5674         do {
5675                 $line = &read_http_connection($con);
5676                 $line =~ tr/\r\n//d;
5677                 } while($line);
5678         my $fromstr;
5679         while($line = &read_http_connection($con)) {
5680                 $fromstr .= $line;
5681                 }
5682         close(SOCK);
5683         my $from = &unserialise_variable($fromstr);
5684         return &$main::remote_error_handler("Invalid RPC login to $serv->{'host'}") if (!$from->{'status'});
5685         if (defined($from->{'arv'})) {
5686                 return @{$from->{'arv'}};
5687                 }
5688         else {
5689                 return $from->{'rv'};
5690                 }
5691         }
5692 }
5693
5694 =head2 remote_multi_callback(&servers, parallel, &function, arg|&args, &returns, &errors, [module, library])
5695
5696 Executes some function in parallel on multiple servers at once. Fills in
5697 the returns and errors arrays respectively. If the module and library
5698 parameters are given, that module is remotely required on the server first,
5699 to check if it is connectable. The parameters are :
5700
5701 =item servers - A list of Webmin system hash references.
5702
5703 =item parallel - Number of parallel operations to perform.
5704
5705 =item function - Reference to function to call for each system.
5706
5707 =item args - Additional parameters to the function.
5708
5709 =item returns - Array ref to place return values into, in same order as servers.
5710
5711 =item errors - Array ref to place error messages into.
5712
5713 =item module - Optional module to require on the remote system first.
5714
5715 =item library - Optional library to require in the module.
5716
5717 =cut
5718 sub remote_multi_callback
5719 {
5720 my ($servs, $parallel, $func, $args, $rets, $errs, $mod, $lib) = @_;
5721 &remote_error_setup(\&remote_multi_callback_error);
5722
5723 # Call the functions
5724 my $p = 0;
5725 foreach my $g (@$servs) {
5726         my $rh = "READ$p";
5727         my $wh = "WRITE$p";
5728         pipe($rh, $wh);
5729         if (!fork()) {
5730                 close($rh);
5731                 $remote_multi_callback_err = undef;
5732                 if ($mod) {
5733                         # Require the remote lib
5734                         &remote_foreign_require($g->{'host'}, $mod, $lib);
5735                         if ($remote_multi_callback_err) {
5736                                 # Failed .. return error
5737                                 print $wh &serialise_variable(
5738                                         [ undef, $remote_multi_callback_err ]);
5739                                 exit(0);
5740                                 }
5741                         }
5742
5743                 # Call the function
5744                 my $a = ref($args) ? $args->[$p] : $args;
5745                 my $rv = &$func($g, $a);
5746
5747                 # Return the result
5748                 print $wh &serialise_variable(
5749                         [ $rv, $remote_multi_callback_err ]);
5750                 close($wh);
5751                 exit(0);
5752                 }
5753         close($wh);
5754         $p++;
5755         }
5756
5757 # Read back the results
5758 $p = 0;
5759 foreach my $g (@$servs) {
5760         my $rh = "READ$p";
5761         my $line = <$rh>;
5762         if (!$line) {
5763                 $errs->[$p] = "Failed to read response from $g->{'host'}";
5764                 }
5765         else {
5766                 my $rv = &unserialise_variable($line);
5767                 close($rh);
5768                 $rets->[$p] = $rv->[0];
5769                 $errs->[$p] = $rv->[1];
5770                 }
5771         $p++;
5772         }
5773
5774 &remote_error_setup(undef);
5775 }
5776
5777 sub remote_multi_callback_error
5778 {
5779 $remote_multi_callback_err = $_[0];
5780 }
5781
5782 =head2 serialise_variable(variable)
5783
5784 Converts some variable (maybe a scalar, hash ref, array ref or scalar ref)
5785 into a url-encoded string. In the cases of arrays and hashes, it is recursively
5786 called on each member to serialize the entire object.
5787
5788 =cut
5789 sub serialise_variable
5790 {
5791 if (!defined($_[0])) {
5792         return 'UNDEF';
5793         }
5794 my $r = ref($_[0]);
5795 my $rv;
5796 if (!$r) {
5797         $rv = &urlize($_[0]);
5798         }
5799 elsif ($r eq 'SCALAR') {
5800         $rv = &urlize(${$_[0]});
5801         }
5802 elsif ($r eq 'ARRAY') {
5803         $rv = join(",", map { &urlize(&serialise_variable($_)) } @{$_[0]});
5804         }
5805 elsif ($r eq 'HASH') {
5806         $rv = join(",", map { &urlize(&serialise_variable($_)).",".
5807                               &urlize(&serialise_variable($_[0]->{$_})) }
5808                             keys %{$_[0]});
5809         }
5810 elsif ($r eq 'REF') {
5811         $rv = &serialise_variable(${$_[0]});
5812         }
5813 elsif ($r eq 'CODE') {
5814         # Code not handled
5815         $rv = undef;
5816         }
5817 elsif ($r) {
5818         # An object - treat as a hash
5819         $r = "OBJECT ".&urlize($r);
5820         $rv = join(",", map { &urlize(&serialise_variable($_)).",".
5821                               &urlize(&serialise_variable($_[0]->{$_})) }
5822                             keys %{$_[0]});
5823         }
5824 return ($r ? $r : 'VAL').",".$rv;
5825 }
5826
5827 =head2 unserialise_variable(string)
5828
5829 Converts a string created by serialise_variable() back into the original
5830 scalar, hash ref, array ref or scalar ref. If the original variable was a Perl
5831 object, the same class is used on this system, if available.
5832
5833 =cut
5834 sub unserialise_variable
5835 {
5836 my @v = split(/,/, $_[0]);
5837 my $rv;
5838 if ($v[0] eq 'VAL') {
5839         @v = split(/,/, $_[0], -1);
5840         $rv = &un_urlize($v[1]);
5841         }
5842 elsif ($v[0] eq 'SCALAR') {
5843         local $r = &un_urlize($v[1]);
5844         $rv = \$r;
5845         }
5846 elsif ($v[0] eq 'ARRAY') {
5847         $rv = [ ];
5848         for(my $i=1; $i<@v; $i++) {
5849                 push(@$rv, &unserialise_variable(&un_urlize($v[$i])));
5850                 }
5851         }
5852 elsif ($v[0] eq 'HASH') {
5853         $rv = { };
5854         for(my $i=1; $i<@v; $i+=2) {
5855                 $rv->{&unserialise_variable(&un_urlize($v[$i]))} =
5856                         &unserialise_variable(&un_urlize($v[$i+1]));
5857                 }
5858         }
5859 elsif ($v[0] eq 'REF') {
5860         local $r = &unserialise_variable($v[1]);
5861         $rv = \$r;
5862         }
5863 elsif ($v[0] eq 'UNDEF') {
5864         $rv = undef;
5865         }
5866 elsif ($v[0] =~ /^OBJECT\s+(.*)$/) {
5867         # An object hash that we have to re-bless
5868         my $cls = $1;
5869         $rv = { };
5870         for(my $i=1; $i<@v; $i+=2) {
5871                 $rv->{&unserialise_variable(&un_urlize($v[$i]))} =
5872                         &unserialise_variable(&un_urlize($v[$i+1]));
5873                 }
5874         eval "use $cls";
5875         bless $rv, $cls;
5876         }
5877 return $rv;
5878 }
5879
5880 =head2 other_groups(user)
5881
5882 Returns a list of secondary groups a user is a member of, as a list of
5883 group names.
5884
5885 =cut
5886 sub other_groups
5887 {
5888 my ($user) = @_;
5889 my @rv;
5890 setgrent();
5891 while(my @g = getgrent()) {
5892         my @m = split(/\s+/, $g[3]);
5893         push(@rv, $g[2]) if (&indexof($user, @m) >= 0);
5894         }
5895 endgrent() if ($gconfig{'os_type'} ne 'hpux');
5896 return @rv;
5897 }
5898
5899 =head2 date_chooser_button(dayfield, monthfield, yearfield)
5900
5901 Returns HTML for a button that pops up a data chooser window. The parameters
5902 are :
5903
5904 =item dayfield - Name of the text field to place the day of the month into.
5905
5906 =item monthfield - Name of the select field to select the month of the year in, indexed from 1.
5907
5908 =item yearfield - Name of the text field to place the year into.
5909
5910 =cut
5911 sub date_chooser_button
5912 {
5913 return &theme_date_chooser_button(@_)
5914         if (defined(&theme_date_chooser_button));
5915 my ($w, $h) = (250, 225);
5916 if ($gconfig{'db_sizedate'}) {
5917         ($w, $h) = split(/x/, $gconfig{'db_sizedate'});
5918         }
5919 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";
5920 }
5921
5922 =head2 help_file(module, file)
5923
5924 Returns the path to a module's help file of some name, typically under the
5925 help directory with a .html extension.
5926
5927 =cut
5928 sub help_file
5929 {
5930 my $mdir = &module_root_directory($_[0]);
5931 my $dir = "$mdir/help";
5932 foreach my $o (@lang_order_list) {
5933         my $lang = "$dir/$_[1].$o.html";
5934         return $lang if (-r $lang);
5935         }
5936 return "$dir/$_[1].html";
5937 }
5938
5939 =head2 seed_random
5940
5941 Seeds the random number generator, if not already done in this script. On Linux
5942 this makes use of the current time, process ID and a read from /dev/urandom.
5943 On other systems, only the current time and process ID are used.
5944
5945 =cut
5946 sub seed_random
5947 {
5948 if (!$main::done_seed_random) {
5949         if (open(RANDOM, "/dev/urandom")) {
5950                 my $buf;
5951                 read(RANDOM, $buf, 4);
5952                 close(RANDOM);
5953                 srand(time() ^ $$ ^ $buf);
5954                 }
5955         else {
5956                 srand(time() ^ $$);
5957                 }
5958         $main::done_seed_random = 1;
5959         }
5960 }
5961
5962 =head2 disk_usage_kb(directory)
5963
5964 Returns the number of kB used by some directory and all subdirs. Implemented
5965 by calling the C<du -k> command.
5966
5967 =cut
5968 sub disk_usage_kb
5969 {
5970 my $dir = &translate_filename($_[0]);
5971 my $out;
5972 my $ex = &execute_command("du -sk ".quotemeta($dir), undef, \$out, undef, 0, 1);
5973 if ($ex) {
5974         &execute_command("du -s ".quotemeta($dir), undef, \$out, undef, 0, 1);
5975         }
5976 return $out =~ /^([0-9]+)/ ? $1 : "???";
5977 }
5978
5979 =head2 recursive_disk_usage(directory, [skip-regexp], [only-regexp])
5980
5981 Returns the number of bytes taken up by all files in some directory and all
5982 sub-directories, by summing up their lengths. The disk_usage_kb is more
5983 reflective of reality, as the filesystem typically pads file sizes to 1k or
5984 4k blocks.
5985
5986 =cut
5987 sub recursive_disk_usage
5988 {
5989 my $dir = &translate_filename($_[0]);
5990 my $skip = $_[1];
5991 my $only = $_[2];
5992 if (-l $dir) {
5993         return 0;
5994         }
5995 elsif (!-d $dir) {
5996         my @st = stat($dir);
5997         return $st[7];
5998         }
5999 else {
6000         my $rv = 0;
6001         opendir(DIR, $dir);
6002         my @files = readdir(DIR);
6003         closedir(DIR);
6004         foreach my $f (@files) {
6005                 next if ($f eq "." || $f eq "..");
6006                 next if ($skip && $f =~ /$skip/);
6007                 next if ($only && $f !~ /$only/);
6008                 $rv += &recursive_disk_usage("$dir/$f", $skip, $only);
6009                 }
6010         return $rv;
6011         }
6012 }
6013
6014 =head2 help_search_link(term, [ section, ... ] )
6015
6016 Returns HTML for a link to the man module for searching local and online
6017 docs for various search terms. The term parameter can either be a single
6018 word like 'bind', or a space-separated list of words. This function is typically
6019 used by modules that want to refer users to additional documentation in man
6020 pages or local system doc files.
6021
6022 =cut
6023 sub help_search_link
6024 {
6025 if (&foreign_available("man") && !$tconfig{'nosearch'}) {
6026         my $for = &urlize(shift(@_));
6027         return "<a href='$gconfig{'webprefix'}/man/search.cgi?".
6028                join("&", map { "section=$_" } @_)."&".
6029                "for=$for&exact=1&check=".&get_module_name()."'>".
6030                $text{'helpsearch'}."</a>\n";
6031         }
6032 else {
6033         return "";
6034         }
6035 }
6036
6037 =head2 make_http_connection(host, port, ssl, method, page, [&headers])
6038
6039 Opens a connection to some HTTP server, maybe through a proxy, and returns
6040 a handle object. The handle can then be used to send additional headers
6041 and read back a response. If anything goes wrong, returns an error string.
6042 The parameters are :
6043
6044 =item host - Hostname or IP address of the webserver to connect to.
6045
6046 =item port - HTTP port number to connect to.
6047
6048 =item ssl - Set to 1 to connect in SSL mode.
6049
6050 =item method - HTTP method, like GET or POST.
6051
6052 =item page - Page to request on the webserver, like /foo/index.html
6053
6054 =item headers - Array ref of additional HTTP headers, each of which is a 2-element array ref.
6055
6056 =cut
6057 sub make_http_connection
6058 {
6059 my ($host, $port, $ssl, $method, $page, $headers) = @_;
6060 my $htxt;
6061 if ($headers) {
6062         foreach my $h (@$headers) {
6063                 $htxt .= $h->[0].": ".$h->[1]."\r\n";
6064                 }
6065         $htxt .= "\r\n";
6066         }
6067 if (&is_readonly_mode()) {
6068         return "HTTP connections not allowed in readonly mode";
6069         }
6070 my $rv = { 'fh' => time().$$ };
6071 if ($ssl) {
6072         # Connect using SSL
6073         eval "use Net::SSLeay";
6074         $@ && return $text{'link_essl'};
6075         eval "Net::SSLeay::SSLeay_add_ssl_algorithms()";
6076         eval "Net::SSLeay::load_error_strings()";
6077         $rv->{'ssl_ctx'} = Net::SSLeay::CTX_new() ||
6078                 return "Failed to create SSL context";
6079         $rv->{'ssl_con'} = Net::SSLeay::new($rv->{'ssl_ctx'}) ||
6080                 return "Failed to create SSL connection";
6081         my $connected;
6082         if ($gconfig{'http_proxy'} =~ /^http:\/\/(\S+):(\d+)/ &&
6083             !&no_proxy($host)) {
6084                 # Via proxy
6085                 my $error;
6086                 &open_socket($1, $2, $rv->{'fh'}, \$error);
6087                 if (!$error) {
6088                         # Connected OK
6089                         my $fh = $rv->{'fh'};
6090                         print $fh "CONNECT $host:$port HTTP/1.0\r\n";
6091                         if ($gconfig{'proxy_user'}) {
6092                                 my $auth = &encode_base64(
6093                                    "$gconfig{'proxy_user'}:".
6094                                    "$gconfig{'proxy_pass'}");
6095                                 $auth =~ tr/\r\n//d;
6096                                 print $fh "Proxy-Authorization: Basic $auth\r\n";
6097                                 }
6098                         print $fh "\r\n";
6099                         my $line = <$fh>;
6100                         if ($line =~ /^HTTP(\S+)\s+(\d+)\s+(.*)/) {
6101                                 return "Proxy error : $3" if ($2 != 200);
6102                                 }
6103                         else {
6104                                 return "Proxy error : $line";
6105                                 }
6106                         $line = <$fh>;
6107                         $connected = 1;
6108                         }
6109                 elsif (!$gconfig{'proxy_fallback'}) {
6110                         # Connection to proxy failed - give up
6111                         return $error;
6112                         }
6113                 }
6114         if (!$connected) {
6115                 # Direct connection
6116                 my $error;
6117                 &open_socket($host, $port, $rv->{'fh'}, \$error);
6118                 return $error if ($error);
6119                 }
6120         Net::SSLeay::set_fd($rv->{'ssl_con'}, fileno($rv->{'fh'}));
6121         Net::SSLeay::connect($rv->{'ssl_con'}) ||
6122                 return "SSL connect() failed";
6123         my $rtxt = "$method $page HTTP/1.0\r\n".$htxt;
6124         Net::SSLeay::write($rv->{'ssl_con'}, $rtxt);
6125         }
6126 else {
6127         # Plain HTTP request
6128         my $connected;
6129         if ($gconfig{'http_proxy'} =~ /^http:\/\/(\S+):(\d+)/ &&
6130             !&no_proxy($host)) {
6131                 # Via a proxy
6132                 my $error;
6133                 &open_socket($1, $2, $rv->{'fh'}, \$error);
6134                 if (!$error) {
6135                         # Connected OK
6136                         $connected = 1;
6137                         my $fh = $rv->{'fh'};
6138                         my $rtxt = $method." ".
6139                                    "http://$host:$port$page HTTP/1.0\r\n";
6140                         if ($gconfig{'proxy_user'}) {
6141                                 my $auth = &encode_base64(
6142                                    "$gconfig{'proxy_user'}:".
6143                                    "$gconfig{'proxy_pass'}");
6144                                 $auth =~ tr/\r\n//d;
6145                                 $rtxt .= "Proxy-Authorization: Basic $auth\r\n";
6146                                 }
6147                         $rtxt .= $htxt;
6148                         print $fh $rtxt;
6149                         }
6150                 elsif (!$gconfig{'proxy_fallback'}) {
6151                         return $error;
6152                         }
6153                 }
6154         if (!$connected) {
6155                 # Connecting directly
6156                 my $error;
6157                 &open_socket($host, $port, $rv->{'fh'}, \$error);
6158                 return $error if ($error);
6159                 my $fh = $rv->{'fh'};
6160                 my $rtxt = "$method $page HTTP/1.0\r\n".$htxt;
6161                 print $fh $rtxt;
6162                 }
6163         }
6164 return $rv;
6165 }
6166
6167 =head2 read_http_connection(&handle, [bytes])
6168
6169 Reads either one line or up to the specified number of bytes from the handle,
6170 originally supplied by make_http_connection.
6171
6172 =cut
6173 sub read_http_connection
6174 {
6175 my ($h) = @_;
6176 my $rv;
6177 if ($h->{'ssl_con'}) {
6178         if (!$_[1]) {
6179                 my ($idx, $more);
6180                 while(($idx = index($h->{'buffer'}, "\n")) < 0) {
6181                         # need to read more..
6182                         if (!($more = Net::SSLeay::read($h->{'ssl_con'}))) {
6183                                 # end of the data
6184                                 $rv = $h->{'buffer'};
6185                                 delete($h->{'buffer'});
6186                                 return $rv;
6187                                 }
6188                         $h->{'buffer'} .= $more;
6189                         }
6190                 $rv = substr($h->{'buffer'}, 0, $idx+1);
6191                 $h->{'buffer'} = substr($h->{'buffer'}, $idx+1);
6192                 }
6193         else {
6194                 if (length($h->{'buffer'})) {
6195                         $rv = $h->{'buffer'};
6196                         delete($h->{'buffer'});
6197                         }
6198                 else {
6199                         $rv = Net::SSLeay::read($h->{'ssl_con'}, $_[1]);
6200                         }
6201                 }
6202         }
6203 else {
6204         if ($_[1]) {
6205                 read($h->{'fh'}, $rv, $_[1]) > 0 || return undef;
6206                 }
6207         else {
6208                 my $fh = $h->{'fh'};
6209                 $rv = <$fh>;
6210                 }
6211         }
6212 $rv = undef if ($rv eq "");
6213 return $rv;
6214 }
6215
6216 =head2 write_http_connection(&handle, [data+])
6217
6218 Writes the given data to the given HTTP connection handle.
6219
6220 =cut
6221 sub write_http_connection
6222 {
6223 my $h = shift(@_);
6224 my $fh = $h->{'fh'};
6225 my $allok = 1;
6226 if ($h->{'ssl_ctx'}) {
6227         foreach my $s (@_) {
6228                 my $ok = Net::SSLeay::write($h->{'ssl_con'}, $s);
6229                 $allok = 0 if (!$ok);
6230                 }
6231         }
6232 else {
6233         my $ok = (print $fh @_);
6234         $allok = 0 if (!$ok);
6235         }
6236 return $allok;
6237 }
6238
6239 =head2 close_http_connection(&handle)
6240
6241 Closes a connection to an HTTP server, identified by the given handle.
6242
6243 =cut
6244 sub close_http_connection
6245 {
6246 my ($h) = @_;
6247 close($h->{'fh'});
6248 }
6249
6250 =head2 clean_environment
6251
6252 Deletes any environment variables inherited from miniserv so that they
6253 won't be passed to programs started by webmin. This is useful when calling
6254 programs that check for CGI-related environment variables and modify their
6255 behaviour, and to avoid passing sensitive variables to un-trusted programs.
6256
6257 =cut
6258 sub clean_environment
6259 {
6260 %UNCLEAN_ENV = %ENV;
6261 foreach my $k (keys %ENV) {
6262         if ($k =~ /^(HTTP|VIRTUALSERVER|QUOTA|USERADMIN)_/) {
6263                 delete($ENV{$k});
6264                 }
6265         }
6266 foreach my $e ('WEBMIN_CONFIG', 'SERVER_NAME', 'CONTENT_TYPE', 'REQUEST_URI',
6267             'PATH_INFO', 'WEBMIN_VAR', 'REQUEST_METHOD', 'GATEWAY_INTERFACE',
6268             'QUERY_STRING', 'REMOTE_USER', 'SERVER_SOFTWARE', 'SERVER_PROTOCOL',
6269             'REMOTE_HOST', 'SERVER_PORT', 'DOCUMENT_ROOT', 'SERVER_ROOT',
6270             'MINISERV_CONFIG', 'SCRIPT_NAME', 'SERVER_ADMIN', 'CONTENT_LENGTH',
6271             'HTTPS', 'FOREIGN_MODULE_NAME', 'FOREIGN_ROOT_DIRECTORY',
6272             'SCRIPT_FILENAME', 'PATH_TRANSLATED', 'BASE_REMOTE_USER',
6273             'DOCUMENT_REALROOT', 'MINISERV_CONFIG', 'MYSQL_PWD',
6274             'MINISERV_PID') {
6275         delete($ENV{$e});
6276         }
6277 }
6278
6279 =head2 reset_environment
6280
6281 Puts the environment back how it was before clean_environment was callled.
6282
6283 =cut
6284 sub reset_environment
6285 {
6286 if (%UNCLEAN_ENV) {
6287         foreach my $k (keys %UNCLEAN_ENV) {
6288                 $ENV{$k} = $UNCLEAN_ENV{$k};
6289                 }
6290         undef(%UNCLEAN_ENV);
6291         }
6292 }
6293
6294 =head2 progress_callback
6295
6296 Never called directly, but useful for passing to &http_download to print
6297 out progress of an HTTP request.
6298
6299 =cut
6300 sub progress_callback
6301 {
6302 if (defined(&theme_progress_callback)) {
6303         # Call the theme override
6304         return &theme_progress_callback(@_);
6305         }
6306 if ($_[0] == 2) {
6307         # Got size
6308         print $progress_callback_prefix;
6309         if ($_[1]) {
6310                 $progress_size = $_[1];
6311                 $progress_step = int($_[1] / 10);
6312                 print &text('progress_size2', $progress_callback_url,
6313                             &nice_size($progress_size)),"<br>\n";
6314                 }
6315         else {
6316                 print &text('progress_nosize', $progress_callback_url),"<br>\n";
6317                 }
6318         $last_progress_time = $last_progress_size = undef;
6319         }
6320 elsif ($_[0] == 3) {
6321         # Got data update
6322         my $sp = $progress_callback_prefix.("&nbsp;" x 5);
6323         if ($progress_size) {
6324                 # And we have a size to compare against
6325                 my $st = int(($_[1] * 10) / $progress_size);
6326                 my $time_now = time();
6327                 if ($st != $progress_step ||
6328                     $time_now - $last_progress_time > 60) {
6329                         # Show progress every 10% or 60 seconds
6330                         print $sp,&text('progress_datan', &nice_size($_[1]),
6331                                         int($_[1]*100/$progress_size)),"<br>\n";
6332                         $last_progress_time = $time_now;
6333                         }
6334                 $progress_step = $st;
6335                 }
6336         else {
6337                 # No total size .. so only show in 100k jumps
6338                 if ($_[1] > $last_progress_size+100*1024) {
6339                         print $sp,&text('progress_data2n',
6340                                         &nice_size($_[1])),"<br>\n";
6341                         $last_progress_size = $_[1];
6342                         }
6343                 }
6344         }
6345 elsif ($_[0] == 4) {
6346         # All done downloading
6347         print $progress_callback_prefix,&text('progress_done'),"<br>\n";
6348         }
6349 elsif ($_[0] == 5) {
6350         # Got new location after redirect
6351         $progress_callback_url = $_[1];
6352         }
6353 elsif ($_[0] == 6) {
6354         # URL is in cache
6355         $progress_callback_url = $_[1];
6356         print &text('progress_incache', $progress_callback_url),"<br>\n";
6357         }
6358 }
6359
6360 =head2 switch_to_remote_user
6361
6362 Changes the user and group of the current process to that of the unix user
6363 with the same name as the current webmin login, or fails if there is none.
6364 This should be called by Usermin module scripts that only need to run with
6365 limited permissions.
6366
6367 =cut
6368 sub switch_to_remote_user
6369 {
6370 @remote_user_info = $remote_user ? getpwnam($remote_user) :
6371                                    getpwuid($<);
6372 @remote_user_info || &error(&text('switch_remote_euser', $remote_user));
6373 &create_missing_homedir(\@remote_user_info);
6374 if ($< == 0) {
6375         &switch_to_unix_user(\@remote_user_info);
6376         $ENV{'USER'} = $ENV{'LOGNAME'} = $remote_user;
6377         $ENV{'HOME'} = $remote_user_info[7];
6378         }
6379 # Export global variables to caller
6380 if ($main::export_to_caller) {
6381         my ($callpkg) = caller();
6382         eval "\@${callpkg}::remote_user_info = \@remote_user_info";
6383         }
6384 }
6385
6386 =head2 switch_to_unix_user(&user-details)
6387
6388 Switches the current process to the UID and group ID from the given list
6389 of user details, which must be in the format returned by getpwnam.
6390
6391 =cut
6392 sub switch_to_unix_user
6393 {
6394 my ($uinfo) = @_;
6395 if (!defined($uinfo->[0])) {
6396         # No username given, so just use given GID
6397         ($(, $)) = ( $uinfo->[3], "$uinfo->[3] $uinfo->[3]" );
6398         }
6399 else {
6400         # Use all groups from user
6401         ($(, $)) = ( $uinfo->[3],
6402                      "$uinfo->[3] ".join(" ", $uinfo->[3],
6403                                          &other_groups($uinfo->[0])) );
6404         }
6405 eval {
6406         POSIX::setuid($uinfo->[2]);
6407         };
6408 if ($< != $uinfo->[2] || $> != $uinfo->[2]) {
6409         ($>, $<) = ( $uinfo->[2], $uinfo->[2] );
6410         }
6411 }
6412
6413 =head2 eval_as_unix_user(username, &code)
6414
6415 Runs some code fragment with the effective UID and GID switch to that
6416 of the given Unix user, so that file IO takes place with his permissions.
6417
6418 =cut
6419
6420 sub eval_as_unix_user
6421 {
6422 my ($user, $code) = @_;
6423 my @uinfo = getpwnam($user);
6424 if (!scalar(@uinfo)) {
6425         &error("eval_as_unix_user called with invalid user $user");
6426         }
6427 $) = $uinfo[3]." ".join(" ", $uinfo[3], &other_groups($user));
6428 $> = $uinfo[2];
6429 my @rv;
6430 eval {
6431         local $main::error_must_die = 1;
6432         @rv = &$code();
6433         };
6434 my $err = $@;
6435 $) = 0;
6436 $> = 0;
6437 if ($err) {
6438         $err =~ s/\s+at\s+(\/\S+)\s+line\s+(\d+)\.?//;
6439         &error($err);
6440         }
6441 return wantarray ? @rv : $rv[0];
6442 }
6443
6444 =head2 create_user_config_dirs
6445
6446 Creates per-user config directories and sets $user_config_directory and
6447 $user_module_config_directory to them. Also reads per-user module configs
6448 into %userconfig. This should be called by Usermin module scripts that need
6449 to store per-user preferences or other settings.
6450
6451 =cut
6452 sub create_user_config_dirs
6453 {
6454 return if (!$gconfig{'userconfig'});
6455 my @uinfo = @remote_user_info ? @remote_user_info : getpwnam($remote_user);
6456 return if (!@uinfo || !$uinfo[7]);
6457 &create_missing_homedir(\@uinfo);
6458 $user_config_directory = "$uinfo[7]/$gconfig{'userconfig'}";
6459 if (!-d $user_config_directory) {
6460         mkdir($user_config_directory, 0700) ||
6461                 &error("Failed to create $user_config_directory : $!");
6462         if ($< == 0 && $uinfo[2]) {
6463                 chown($uinfo[2], $uinfo[3], $user_config_directory);
6464                 }
6465         }
6466 if (&get_module_name()) {
6467         $user_module_config_directory = $user_config_directory."/".
6468                                         &get_module_name();
6469         if (!-d $user_module_config_directory) {
6470                 mkdir($user_module_config_directory, 0700) ||
6471                         &error("Failed to create $user_module_config_directory : $!");
6472                 if ($< == 0 && $uinfo[2]) {
6473                         chown($uinfo[2], $uinfo[3], $user_config_directory);
6474                         }
6475                 }
6476         undef(%userconfig);
6477         &read_file_cached("$module_root_directory/defaultuconfig",
6478                           \%userconfig);
6479         &read_file_cached("$module_config_directory/uconfig", \%userconfig);
6480         &read_file_cached("$user_module_config_directory/config",
6481                           \%userconfig);
6482         }
6483
6484 # Export global variables to caller
6485 if ($main::export_to_caller) {
6486         my ($callpkg) = caller();
6487         foreach my $v ('$user_config_directory',
6488                        '$user_module_config_directory', '%userconfig') {
6489                 my ($vt, $vn) = split('', $v, 2);
6490                 eval "${vt}${callpkg}::${vn} = ${vt}${vn}";
6491                 }
6492         }
6493 }
6494
6495 =head2 create_missing_homedir(&uinfo)
6496
6497 If auto homedir creation is enabled, create one for this user if needed.
6498 For internal use only.
6499
6500 =cut
6501 sub create_missing_homedir
6502 {
6503 my ($uinfo) = @_;
6504 if (!-e $uinfo->[7] && $gconfig{'create_homedir'}) {
6505         # Use has no home dir .. make one
6506         system("mkdir -p ".quotemeta($uinfo->[7]));
6507         chown($uinfo->[2], $uinfo->[3], $uinfo->[7]);
6508         if ($gconfig{'create_homedir_perms'} ne '') {
6509                 chmod(oct($gconfig{'create_homedir_perms'}), $uinfo->[7]);
6510                 }
6511         }
6512 }
6513
6514 =head2 filter_javascript(text)
6515
6516 Disables all javascript <script>, onClick= and so on tags in the given HTML,
6517 and returns the new HTML. Useful for displaying HTML from an un-trusted source.
6518
6519 =cut
6520 sub filter_javascript
6521 {
6522 my ($rv) = @_;
6523 $rv =~ s/<\s*script[^>]*>([\000-\377]*?)<\s*\/script\s*>//gi;
6524 $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;
6525 $rv =~ s/(javascript:)/x$1/gi;
6526 $rv =~ s/(vbscript:)/x$1/gi;
6527 return $rv;
6528 }
6529
6530 =head2 resolve_links(path)
6531
6532 Given a path that may contain symbolic links, returns the real path.
6533
6534 =cut
6535 sub resolve_links
6536 {
6537 my ($path) = @_;
6538 $path =~ s/\/+/\//g;
6539 $path =~ s/\/$// if ($path ne "/");
6540 my @p = split(/\/+/, $path);
6541 shift(@p);
6542 for(my $i=0; $i<@p; $i++) {
6543         my $sofar = "/".join("/", @p[0..$i]);
6544         my $lnk = readlink($sofar);
6545         if ($lnk eq $sofar) {
6546                 # Link to itself! Cannot do anything more really ..
6547                 last;
6548                 }
6549         elsif ($lnk =~ /^\//) {
6550                 # Link is absolute..
6551                 return &resolve_links($lnk."/".join("/", @p[$i+1 .. $#p]));
6552                 }
6553         elsif ($lnk) {
6554                 # Link is relative
6555                 return &resolve_links("/".join("/", @p[0..$i-1])."/".$lnk."/".join("/", @p[$i+1 .. $#p]));
6556                 }
6557         }
6558 return $path;
6559 }
6560
6561 =head2 simplify_path(path, bogus)
6562
6563 Given a path, maybe containing elements ".." and "." , convert it to a
6564 clean, absolute form. Returns undef if this is not possible.
6565
6566 =cut
6567 sub simplify_path
6568 {
6569 my ($dir) = @_;
6570 $dir =~ s/^\/+//g;
6571 $dir =~ s/\/+$//g;
6572 my @bits = split(/\/+/, $dir);
6573 my @fixedbits = ();
6574 $_[1] = 0;
6575 foreach my $b (@bits) {
6576         if ($b eq ".") {
6577                 # Do nothing..
6578                 }
6579         elsif ($b eq "..") {
6580                 # Remove last dir
6581                 if (scalar(@fixedbits) == 0) {
6582                         # Cannot! Already at root!
6583                         return undef;
6584                         }
6585                 pop(@fixedbits);
6586                 }
6587         else {
6588                 # Add dir to list
6589                 push(@fixedbits, $b);
6590                 }
6591         }
6592 return "/".join('/', @fixedbits);
6593 }
6594
6595 =head2 same_file(file1, file2)
6596
6597 Returns 1 if two files are actually the same
6598
6599 =cut
6600 sub same_file
6601 {
6602 return 1 if ($_[0] eq $_[1]);
6603 return 0 if ($_[0] !~ /^\// || $_[1] !~ /^\//);
6604 my @stat1 = $stat_cache{$_[0]} ? @{$stat_cache{$_[0]}}
6605                                : (@{$stat_cache{$_[0]}} = stat($_[0]));
6606 my @stat2 = $stat_cache{$_[1]} ? @{$stat_cache{$_[1]}}
6607                                : (@{$stat_cache{$_[1]}} = stat($_[1]));
6608 return 0 if (!@stat1 || !@stat2);
6609 return $stat1[0] == $stat2[0] && $stat1[1] == $stat2[1];
6610 }
6611
6612 =head2 flush_webmin_caches
6613
6614 Clears all in-memory and on-disk caches used by Webmin.
6615
6616 =cut
6617 sub flush_webmin_caches
6618 {
6619 undef(%main::read_file_cache);
6620 undef(%main::acl_hash_cache);
6621 undef(%main::acl_array_cache);
6622 undef(%main::has_command_cache);
6623 undef(@main::list_languages_cache);
6624 undef($main::got_list_usermods_cache);
6625 undef(@main::list_usermods_cache);
6626 undef(%main::foreign_installed_cache);
6627 unlink("$config_directory/module.infos.cache");
6628 &get_all_module_infos();
6629 }
6630
6631 =head2 list_usermods
6632
6633 Returns a list of additional module restrictions. For internal use in
6634 Usermin only.
6635
6636 =cut
6637 sub list_usermods
6638 {
6639 if (!$main::got_list_usermods_cache) {
6640         @main::list_usermods_cache = ( );
6641         local $_;
6642         open(USERMODS, "$config_directory/usermin.mods");
6643         while(<USERMODS>) {
6644                 if (/^([^:]+):(\+|-|):(.*)/) {
6645                         push(@main::list_usermods_cache,
6646                              [ $1, $2, [ split(/\s+/, $3) ] ]);
6647                         }
6648                 }
6649         close(USERMODS);
6650         $main::got_list_usermods_cache = 1;
6651         }
6652 return @main::list_usermods_cache;
6653 }
6654
6655 =head2 available_usermods(&allmods, &usermods)
6656
6657 Returns a list of modules that are available to the given user, based
6658 on usermod additional/subtractions. For internal use by Usermin only.
6659
6660 =cut
6661 sub available_usermods
6662 {
6663 return @{$_[0]} if (!@{$_[1]});
6664
6665 my %mods = map { $_->{'dir'}, 1 } @{$_[0]};
6666 my @uinfo = @remote_user_info;
6667 @uinfo = getpwnam($remote_user) if (!@uinfo);
6668 foreach my $u (@{$_[1]}) {
6669         my $applies;
6670         if ($u->[0] eq "*" || $u->[0] eq $remote_user) {
6671                 $applies++;
6672                 }
6673         elsif ($u->[0] =~ /^\@(.*)$/) {
6674                 # Check for group membership
6675                 my @ginfo = getgrnam($1);
6676                 $applies++ if (@ginfo && ($ginfo[2] == $uinfo[3] ||
6677                         &indexof($remote_user, split(/\s+/, $ginfo[3])) >= 0));
6678                 }
6679         elsif ($u->[0] =~ /^\//) {
6680                 # Check users and groups in file
6681                 local $_;
6682                 open(USERFILE, $u->[0]);
6683                 while(<USERFILE>) {
6684                         tr/\r\n//d;
6685                         if ($_ eq $remote_user) {
6686                                 $applies++;
6687                                 }
6688                         elsif (/^\@(.*)$/) {
6689                                 my @ginfo = getgrnam($1);
6690                                 $applies++
6691                                   if (@ginfo && ($ginfo[2] == $uinfo[3] ||
6692                                       &indexof($remote_user,
6693                                                split(/\s+/, $ginfo[3])) >= 0));
6694                                 }
6695                         last if ($applies);
6696                         }
6697                 close(USERFILE);
6698                 }
6699         if ($applies) {
6700                 if ($u->[1] eq "+") {
6701                         map { $mods{$_}++ } @{$u->[2]};
6702                         }
6703                 elsif ($u->[1] eq "-") {
6704                         map { delete($mods{$_}) } @{$u->[2]};
6705                         }
6706                 else {
6707                         undef(%mods);
6708                         map { $mods{$_}++ } @{$u->[2]};
6709                         }
6710                 }
6711         }
6712 return grep { $mods{$_->{'dir'}} } @{$_[0]};
6713 }
6714
6715 =head2 get_available_module_infos(nocache)
6716
6717 Returns a list of modules available to the current user, based on
6718 operating system support, access control and usermod restrictions. Useful
6719 in themes that need to display a list of modules the user can use.
6720 Each element of the returned array is a hash reference in the same format as
6721 returned by get_module_info.
6722
6723 =cut
6724 sub get_available_module_infos
6725 {
6726 my (%acl, %uacl);
6727 &read_acl(\%acl, \%uacl);
6728 my $risk = $gconfig{'risk_'.$base_remote_user};
6729 my @rv;
6730 foreach my $minfo (&get_all_module_infos($_[0])) {
6731         next if (!&check_os_support($minfo));
6732         if ($risk) {
6733                 # Check module risk level
6734                 next if ($risk ne 'high' && $minfo->{'risk'} &&
6735                          $minfo->{'risk'} !~ /$risk/);
6736                 }
6737         else {
6738                 # Check user's ACL
6739                 next if (!$acl{$base_remote_user,$minfo->{'dir'}} &&
6740                          !$acl{$base_remote_user,"*"});
6741                 }
6742         next if (&is_readonly_mode() && !$minfo->{'readonly'});
6743         push(@rv, $minfo);
6744         }
6745
6746 # Check usermod restrictions
6747 my @usermods = &list_usermods();
6748 @rv = sort { $a->{'desc'} cmp $b->{'desc'} }
6749             &available_usermods(\@rv, \@usermods);
6750
6751 # Check RBAC restrictions
6752 my @rbacrv;
6753 foreach my $m (@rv) {
6754         if (&supports_rbac($m->{'dir'}) &&
6755             &use_rbac_module_acl(undef, $m->{'dir'})) {
6756                 local $rbacs = &get_rbac_module_acl($remote_user,
6757                                                     $m->{'dir'});
6758                 if ($rbacs) {
6759                         # RBAC allows
6760                         push(@rbacrv, $m);
6761                         }
6762                 }
6763         else {
6764                 # Module or system doesn't support RBAC
6765                 push(@rbacrv, $m) if (!$gconfig{'rbacdeny_'.$base_remote_user});
6766                 }
6767         }
6768
6769 # Check theme vetos
6770 my @themerv;
6771 if (defined(&theme_foreign_available)) {
6772         foreach my $m (@rbacrv) {
6773                 if (&theme_foreign_available($m->{'dir'})) {
6774                         push(@themerv, $m);
6775                         }
6776                 }
6777         }
6778 else {
6779         @themerv = @rbacrv;
6780         }
6781
6782 # Check licence module vetos
6783 my @licrv;
6784 if ($main::licence_module) {
6785         foreach my $m (@themerv) {
6786                 if (&foreign_call($main::licence_module,
6787                                   "check_module_licence", $m->{'dir'})) {
6788                         push(@licrv, $m);
6789                         }
6790                 }
6791         }
6792 else {
6793         @licrv = @themerv;
6794         }
6795
6796 return @licrv;
6797 }
6798
6799 =head2 get_visible_module_infos(nocache)
6800
6801 Like get_available_module_infos, but excludes hidden modules from the list.
6802 Each element of the returned array is a hash reference in the same format as
6803 returned by get_module_info.
6804
6805 =cut
6806 sub get_visible_module_infos
6807 {
6808 my ($nocache) = @_;
6809 my $pn = &get_product_name();
6810 return grep { !$_->{'hidden'} &&
6811               !$_->{$pn.'_hidden'} } &get_available_module_infos($nocache);
6812 }
6813
6814 =head2 get_visible_modules_categories(nocache)
6815
6816 Returns a list of Webmin module categories, each of which is a hash ref
6817 with 'code', 'desc' and 'modules' keys. The modules value is an array ref
6818 of modules in the category, in the format returned by get_module_info.
6819 Un-used modules are automatically assigned to the 'unused' category, and
6820 those with no category are put into 'others'.
6821
6822 =cut
6823 sub get_visible_modules_categories
6824 {
6825 my ($nocache) = @_;
6826 my @mods = &get_visible_module_infos($nocache);
6827 my @unmods;
6828 if (&get_product_name() eq 'webmin') {
6829         @unmods = grep { $_->{'installed'} eq '0' } @mods;
6830         @mods = grep { $_->{'installed'} ne '0' } @mods;
6831         }
6832 my %cats = &list_categories(\@mods);
6833 my @rv;
6834 foreach my $c (keys %cats) {
6835         my $cat = { 'code' => $c || 'other',
6836                     'desc' => $cats{$c} };
6837         $cat->{'modules'} = [ grep { $_->{'category'} eq $c } @mods ];
6838         push(@rv, $cat);
6839         }
6840 @rv = sort { ($b->{'code'} eq "others" ? "" : $b->{'code'}) cmp
6841              ($a->{'code'} eq "others" ? "" : $a->{'code'}) } @rv;
6842 if (@unmods) {
6843         # Add un-installed modules in magic category
6844         my $cat = { 'code' => 'unused',
6845                     'desc' => $text{'main_unused'},
6846                     'unused' => 1,
6847                     'modules' => \@unmods };
6848         push(@rv, $cat);
6849         }
6850 return @rv;
6851 }
6852
6853 =head2 is_under_directory(directory, file)
6854
6855 Returns 1 if the given file is under the specified directory, 0 if not.
6856 Symlinks are taken into account in the file to find it's 'real' location.
6857
6858 =cut
6859 sub is_under_directory
6860 {
6861 my ($dir, $file) = @_;
6862 return 1 if ($dir eq "/");
6863 return 0 if ($file =~ /\.\./);
6864 my $ld = &resolve_links($dir);
6865 if ($ld ne $dir) {
6866         return &is_under_directory($ld, $file);
6867         }
6868 my $lp = &resolve_links($file);
6869 if ($lp ne $file) {
6870         return &is_under_directory($dir, $lp);
6871         }
6872 return 0 if (length($file) < length($dir));
6873 return 1 if ($dir eq $file);
6874 $dir =~ s/\/*$/\//;
6875 return substr($file, 0, length($dir)) eq $dir;
6876 }
6877
6878 =head2 parse_http_url(url, [basehost, baseport, basepage, basessl])
6879
6880 Given an absolute URL, returns the host, port, page and ssl flag components.
6881 Relative URLs can also be parsed, if the base information is provided.
6882
6883 =cut
6884 sub parse_http_url
6885 {
6886 if ($_[0] =~ /^(http|https):\/\/([^:\/]+)(:(\d+))?(\/\S*)?$/) {
6887         # An absolute URL
6888         my $ssl = $1 eq 'https';
6889         return ($2, $3 ? $4 : $ssl ? 443 : 80, $5 || "/", $ssl);
6890         }
6891 elsif (!$_[1]) {
6892         # Could not parse
6893         return undef;
6894         }
6895 elsif ($_[0] =~ /^\/\S*$/) {
6896         # A relative to the server URL
6897         return ($_[1], $_[2], $_[0], $_[4]);
6898         }
6899 else {
6900         # A relative to the directory URL
6901         my $page = $_[3];
6902         $page =~ s/[^\/]+$//;
6903         return ($_[1], $_[2], $page.$_[0], $_[4]);
6904         }
6905 }
6906
6907 =head2 check_clicks_function
6908
6909 Returns HTML for a JavaScript function called check_clicks that returns
6910 true when first called, but false subsequently. Useful on onClick for
6911 critical buttons. Deprecated, as this method of preventing duplicate actions
6912 is un-reliable.
6913
6914 =cut
6915 sub check_clicks_function
6916 {
6917 return <<EOF;
6918 <script>
6919 clicks = 0;
6920 function check_clicks(form)
6921 {
6922 clicks++;
6923 if (clicks == 1)
6924         return true;
6925 else {
6926         if (form != null) {
6927                 for(i=0; i<form.length; i++)
6928                         form.elements[i].disabled = true;
6929                 }
6930         return false;
6931         }
6932 }
6933 </script>
6934 EOF
6935 }
6936
6937 =head2 load_entities_map
6938
6939 Returns a hash ref containing mappings between HTML entities (like ouml) and
6940 ascii values (like 246). Mainly for internal use.
6941
6942 =cut
6943 sub load_entities_map
6944 {
6945 if (!%entities_map_cache) {
6946         local $_;
6947         open(EMAP, "$root_directory/entities_map.txt");
6948         while(<EMAP>) {
6949                 if (/^(\d+)\s+(\S+)/) {
6950                         $entities_map_cache{$2} = $1;
6951                         }
6952                 }
6953         close(EMAP);
6954         }
6955 return \%entities_map_cache;
6956 }
6957
6958 =head2 entities_to_ascii(string)
6959
6960 Given a string containing HTML entities like &ouml; and &#55;, replace them
6961 with their ASCII equivalents.
6962
6963 =cut
6964 sub entities_to_ascii
6965 {
6966 my ($str) = @_;
6967 my $emap = &load_entities_map();
6968 $str =~ s/&([a-z]+);/chr($emap->{$1})/ge;
6969 $str =~ s/&#(\d+);/chr($1)/ge;
6970 return $str;
6971 }
6972
6973 =head2 get_product_name
6974
6975 Returns either 'webmin' or 'usermin', depending on which program the current
6976 module is in. Useful for modules that can be installed into either.
6977
6978 =cut
6979 sub get_product_name
6980 {
6981 return $gconfig{'product'} if (defined($gconfig{'product'}));
6982 return defined($gconfig{'userconfig'}) ? 'usermin' : 'webmin';
6983 }
6984
6985 =head2 get_charset
6986
6987 Returns the character set for the current language, such as iso-8859-1.
6988
6989 =cut
6990 sub get_charset
6991 {
6992 my $charset = defined($gconfig{'charset'}) ? $gconfig{'charset'} :
6993                  $current_lang_info->{'charset'} ?
6994                  $current_lang_info->{'charset'} : $default_charset;
6995 return $charset;
6996 }
6997
6998 =head2 get_display_hostname
6999
7000 Returns the system's hostname for UI display purposes. This may be different
7001 from the actual hostname if you administrator has configured it so in the
7002 Webmin Configuration module.
7003
7004 =cut
7005 sub get_display_hostname
7006 {
7007 if ($gconfig{'hostnamemode'} == 0) {
7008         return &get_system_hostname();
7009         }
7010 elsif ($gconfig{'hostnamemode'} == 3) {
7011         return $gconfig{'hostnamedisplay'};
7012         }
7013 else {
7014         my $h = $ENV{'HTTP_HOST'};
7015         $h =~ s/:\d+//g;
7016         if ($gconfig{'hostnamemode'} == 2) {
7017                 $h =~ s/^(www|ftp|mail)\.//i;
7018                 }
7019         return $h;
7020         }
7021 }
7022
7023 =head2 save_module_config([&config], [modulename])
7024
7025 Saves the configuration for some module. The config parameter is an optional
7026 hash reference of names and values to save, which defaults to the global
7027 %config hash. The modulename parameter is the module to update the config
7028 file, which defaults to the current module.
7029
7030 =cut
7031 sub save_module_config
7032 {
7033 my $c = $_[0] || { &get_module_variable('%config') };
7034 my $m = defined($_[1]) ? $_[1] : &get_module_name();
7035 &write_file("$config_directory/$m/config", $c);
7036 }
7037
7038 =head2 save_user_module_config([&config], [modulename])
7039
7040 Saves the user's Usermin preferences for some module. The config parameter is
7041 an optional hash reference of names and values to save, which defaults to the
7042 global %userconfig hash. The modulename parameter is the module to update the
7043 config file, which defaults to the current module.
7044
7045 =cut
7046 sub save_user_module_config
7047 {
7048 my $c = $_[0] || { &get_module_variable('%userconfig') };
7049 my $m = $_[1] || &get_module_name();
7050 my $ucd = $user_config_directory;
7051 if (!$ucd) {
7052         my @uinfo = @remote_user_info ? @remote_user_info
7053                                       : getpwnam($remote_user);
7054         return if (!@uinfo || !$uinfo[7]);
7055         $ucd = "$uinfo[7]/$gconfig{'userconfig'}";
7056         }
7057 &write_file("$ucd/$m/config", $c);
7058 }
7059
7060 =head2 nice_size(bytes, [min])
7061
7062 Converts a number of bytes into a number followed by a suffix like GB, MB
7063 or kB. Rounding is to two decimal digits. The optional min parameter sets the
7064 smallest units to use - so you could pass 1024*1024 to never show bytes or kB.
7065
7066 =cut
7067 sub nice_size
7068 {
7069 my ($units, $uname);
7070 if (abs($_[0]) > 1024*1024*1024*1024 || $_[1] >= 1024*1024*1024*1024) {
7071         $units = 1024*1024*1024*1024;
7072         $uname = "TB";
7073         }
7074 elsif (abs($_[0]) > 1024*1024*1024 || $_[1] >= 1024*1024*1024) {
7075         $units = 1024*1024*1024;
7076         $uname = "GB";
7077         }
7078 elsif (abs($_[0]) > 1024*1024 || $_[1] >= 1024*1024) {
7079         $units = 1024*1024;
7080         $uname = "MB";
7081         }
7082 elsif (abs($_[0]) > 1024 || $_[1] >= 1024) {
7083         $units = 1024;
7084         $uname = "kB";
7085         }
7086 else {
7087         $units = 1;
7088         $uname = "bytes";
7089         }
7090 my $sz = sprintf("%.2f", ($_[0]*1.0 / $units));
7091 $sz =~ s/\.00$//;
7092 return $sz." ".$uname;
7093 }
7094
7095 =head2 get_perl_path
7096
7097 Returns the path to Perl currently in use, such as /usr/bin/perl.
7098
7099 =cut
7100 sub get_perl_path
7101 {
7102 if (open(PERL, "$config_directory/perl-path")) {
7103         my $rv;
7104         chop($rv = <PERL>);
7105         close(PERL);
7106         return $rv;
7107         }
7108 return $^X if (-x $^X);
7109 return &has_command("perl");
7110 }
7111
7112 =head2 get_goto_module([&mods])
7113
7114 Returns the details of a module that the current user should be re-directed
7115 to after logging in, or undef if none. Useful for themes.
7116
7117 =cut
7118 sub get_goto_module
7119 {
7120 my @mods = $_[0] ? @{$_[0]} : &get_visible_module_infos();
7121 if ($gconfig{'gotomodule'}) {
7122         my ($goto) = grep { $_->{'dir'} eq $gconfig{'gotomodule'} } @mods;
7123         return $goto if ($goto);
7124         }
7125 if (@mods == 1 && $gconfig{'gotoone'}) {
7126         return $mods[0];
7127         }
7128 return undef;
7129 }
7130
7131 =head2 select_all_link(field, form, [text])
7132
7133 Returns HTML for a 'Select all' link that uses Javascript to select
7134 multiple checkboxes with the same name. The parameters are :
7135
7136 =item field - Name of the checkbox inputs.
7137
7138 =item form - Index of the form on the page.
7139
7140 =item text - Message for the link, defaulting to 'Select all'.
7141
7142 =cut
7143 sub select_all_link
7144 {
7145 return &theme_select_all_link(@_) if (defined(&theme_select_all_link));
7146 my ($field, $form, $text) = @_;
7147 $form = int($form);
7148 $text ||= $text{'ui_selall'};
7149 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>";
7150 }
7151
7152 =head2 select_invert_link(field, form, text)
7153
7154 Returns HTML for an 'Invert selection' link that uses Javascript to invert the
7155 selection on multiple checkboxes with the same name. The parameters are :
7156
7157 =item field - Name of the checkbox inputs.
7158
7159 =item form - Index of the form on the page.
7160
7161 =item text - Message for the link, defaulting to 'Invert selection'.
7162
7163 =cut
7164 sub select_invert_link
7165 {
7166 return &theme_select_invert_link(@_) if (defined(&theme_select_invert_link));
7167 my ($field, $form, $text) = @_;
7168 $form = int($form);
7169 $text ||= $text{'ui_selinv'};
7170 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>";
7171 }
7172
7173 =head2 select_rows_link(field, form, text, &rows)
7174
7175 Returns HTML for a link that uses Javascript to select rows with particular
7176 values for their checkboxes. The parameters are :
7177
7178 =item field - Name of the checkbox inputs.
7179
7180 =item form - Index of the form on the page.
7181
7182 =item text - Message for the link, de
7183
7184 =item rows - Reference to an array of 1 or 0 values, indicating which rows to check.
7185
7186 =cut
7187 sub select_rows_link
7188 {
7189 return &theme_select_rows_link(@_) if (defined(&theme_select_rows_link));
7190 my ($field, $form, $text, $rows) = @_;
7191 $form = int($form);
7192 my $js = "var sel = { ".join(",", map { "\"".&quote_escape($_)."\":1" } @$rows)." }; ";
7193 $js .= "for(var i=0; i<document.forms[$form].${field}.length; i++) { var r = document.forms[$form].${field}[i]; r.checked = sel[r.value]; } ";
7194 $js .= "return false;";
7195 return "<a href='#' onClick='$js'>$text</a>";
7196 }
7197
7198 =head2 check_pid_file(file)
7199
7200 Given a pid file, returns the PID it contains if the process is running.
7201
7202 =cut
7203 sub check_pid_file
7204 {
7205 open(PIDFILE, $_[0]) || return undef;
7206 my $pid = <PIDFILE>;
7207 close(PIDFILE);
7208 $pid =~ /^\s*(\d+)/ || return undef;
7209 kill(0, $1) || return undef;
7210 return $1;
7211 }
7212
7213 =head2 get_mod_lib
7214
7215 Return the local os-specific library name to this module. For internal use only.
7216
7217 =cut
7218 sub get_mod_lib
7219 {
7220 my $mn = &get_module_name();
7221 my $md = &module_root_directory($mn);
7222 if (-r "$md/$mn-$gconfig{'os_type'}-$gconfig{'os_version'}-lib.pl") {
7223         return "$mn-$gconfig{'os_type'}-$gconfig{'os_version'}-lib.pl";
7224         }
7225 elsif (-r "$md/$mn-$gconfig{'os_type'}-lib.pl") {
7226         return "$mn-$gconfig{'os_type'}-lib.pl";
7227         }
7228 elsif (-r "$md/$mn-generic-lib.pl") {
7229         return "$mn-generic-lib.pl";
7230         }
7231 else {
7232         return "";
7233         }
7234 }
7235
7236 =head2 module_root_directory(module)
7237
7238 Given a module name, returns its root directory. On a typical Webmin install,
7239 all modules are under the same directory - but it is theoretically possible to
7240 have more than one.
7241
7242 =cut
7243 sub module_root_directory
7244 {
7245 my $d = ref($_[0]) ? $_[0]->{'dir'} : $_[0];
7246 if (@root_directories > 1) {
7247         foreach my $r (@root_directories) {
7248                 if (-d "$r/$d") {
7249                         return "$r/$d";
7250                         }
7251                 }
7252         }
7253 return "$root_directories[0]/$d";
7254 }
7255
7256 =head2 list_mime_types
7257
7258 Returns a list of all known MIME types and their extensions, as a list of hash
7259 references with keys :
7260
7261 =item type - The MIME type, like text/plain.
7262
7263 =item exts - A list of extensions, like .doc and .avi.
7264
7265 =item desc - A human-readable description for the MIME type.
7266
7267 =cut
7268 sub list_mime_types
7269 {
7270 if (!@list_mime_types_cache) {
7271         local $_;
7272         open(MIME, "$root_directory/mime.types");
7273         while(<MIME>) {
7274                 my $cmt;
7275                 s/\r|\n//g;
7276                 if (s/#\s*(.*)$//g) {
7277                         $cmt = $1;
7278                         }
7279                 my ($type, @exts) = split(/\s+/);
7280                 if ($type) {
7281                         push(@list_mime_types_cache, { 'type' => $type,
7282                                                        'exts' => \@exts,
7283                                                        'desc' => $cmt });
7284                         }
7285                 }
7286         close(MIME);
7287         }
7288 return @list_mime_types_cache;
7289 }
7290
7291 =head2 guess_mime_type(filename, [default])
7292
7293 Given a file name like xxx.gif or foo.html, returns a guessed MIME type.
7294 The optional default parameter sets a default type of use if none is found,
7295 which defaults to application/octet-stream.
7296
7297 =cut
7298 sub guess_mime_type
7299 {
7300 if ($_[0] =~ /\.([A-Za-z0-9\-]+)$/) {
7301         my $ext = $1;
7302         foreach my $t (&list_mime_types()) {
7303                 foreach my $e (@{$t->{'exts'}}) {
7304                         return $t->{'type'} if (lc($e) eq lc($ext));
7305                         }
7306                 }
7307         }
7308 return @_ > 1 ? $_[1] : "application/octet-stream";
7309 }
7310
7311 =head2 open_tempfile([handle], file, [no-error], [no-tempfile], [safe?])
7312
7313 Opens a file handle for writing to a temporary file, which will only be
7314 renamed over the real file when the handle is closed. This allows critical
7315 files like /etc/shadow to be updated safely, even if writing fails part way
7316 through due to lack of disk space. The parameters are :
7317
7318 =item handle - File handle to open, as you would use in Perl's open function.
7319
7320 =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.
7321
7322 =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.
7323
7324 =item no-tempfile - If set to 1, writing will be direct to the file instead of using a temporary file.
7325
7326 =item safe - Indicates to users in read-only mode that this write is safe and non-destructive.
7327
7328 =cut
7329 sub open_tempfile
7330 {
7331 if (@_ == 1) {
7332         # Just getting a temp file
7333         if (!defined($main::open_tempfiles{$_[0]})) {
7334                 $_[0] =~ /^(.*)\/(.*)$/ || return $_[0];
7335                 my $dir = $1 || "/";
7336                 my $tmp = "$dir/$2.webmintmp.$$";
7337                 $main::open_tempfiles{$_[0]} = $tmp;
7338                 push(@main::temporary_files, $tmp);
7339                 }
7340         return $main::open_tempfiles{$_[0]};
7341         }
7342 else {
7343         # Actually opening
7344         my ($fh, $file, $noerror, $notemp, $safe) = @_;
7345         $fh = &callers_package($fh);
7346
7347         my %gaccess = &get_module_acl(undef, "");
7348         my $db = $gconfig{'debug_what_write'};
7349         if ($file =~ /\r|\n|\0/) {
7350                 if ($noerror) { return 0; }
7351                 else { &error("Filename contains invalid characters"); }
7352                 }
7353         if (&is_readonly_mode() && $file =~ />/ && !$safe) {
7354                 # Read-only mode .. veto all writes
7355                 print STDERR "vetoing write to $file\n";
7356                 return open($fh, ">$null_file");
7357                 }
7358         elsif ($file =~ /^(>|>>|)nul$/i) {
7359                 # Write to Windows null device
7360                 &webmin_debug_log($1 eq ">" ? "WRITE" :
7361                           $1 eq ">>" ? "APPEND" : "READ", "nul") if ($db);
7362                 }
7363         elsif ($file =~ /^(>|>>)(\/dev\/.*)/ || lc($file) eq "nul") {
7364                 # Writes to /dev/null or TTYs don't need to be handled
7365                 &webmin_debug_log($1 eq ">" ? "WRITE" : "APPEND", $2) if ($db);
7366                 return open($fh, $file);
7367                 }
7368         elsif ($file =~ /^>\s*(([a-zA-Z]:)?\/.*)$/ && !$notemp) {
7369                 &webmin_debug_log("WRITE", $1) if ($db);
7370                 # Over-writing a file, via a temp file
7371                 $file = $1;
7372                 $file = &translate_filename($file);
7373                 while(-l $file) {
7374                         # Open the link target instead
7375                         $file = &resolve_links($file);
7376                         }
7377                 if (-d $file) {
7378                         # Cannot open a directory!
7379                         if ($noerror) { return 0; }
7380                         else { &error("Cannot write to directory $file"); }
7381                         }
7382                 my $tmp = &open_tempfile($file);
7383                 my $ex = open($fh, ">$tmp");
7384                 if (!$ex && $! =~ /permission/i) {
7385                         # Could not open temp file .. try opening actual file
7386                         # instead directly
7387                         $ex = open($fh, ">$file");
7388                         delete($main::open_tempfiles{$file});
7389                         }
7390                 else {
7391                         $main::open_temphandles{$fh} = $file;
7392                         }
7393                 binmode($fh);
7394                 if (!$ex && !$noerror) {
7395                         &error(&text("efileopen", $file, $!));
7396                         }
7397                 return $ex;
7398                 }
7399         elsif ($file =~ /^>\s*(([a-zA-Z]:)?\/.*)$/ && $notemp) {
7400                 # Just writing direct to a file
7401                 &webmin_debug_log("WRITE", $1) if ($db);
7402                 $file = $1;
7403                 $file = &translate_filename($file);
7404                 my @old_attributes = &get_clear_file_attributes($file);
7405                 my $ex = open($fh, ">$file");
7406                 &reset_file_attributes($file, \@old_attributes);
7407                 $main::open_temphandles{$fh} = $file;
7408                 if (!$ex && !$noerror) {
7409                         &error(&text("efileopen", $file, $!));
7410                         }
7411                 binmode($fh);
7412                 return $ex;
7413                 }
7414         elsif ($file =~ /^>>\s*(([a-zA-Z]:)?\/.*)$/) {
7415                 # Appending to a file .. nothing special to do
7416                 &webmin_debug_log("APPEND", $1) if ($db);
7417                 $file = $1;
7418                 $file = &translate_filename($file);
7419                 my @old_attributes = &get_clear_file_attributes($file);
7420                 my $ex = open($fh, ">>$file");
7421                 &reset_file_attributes($file, \@old_attributes);
7422                 $main::open_temphandles{$fh} = $file;
7423                 if (!$ex && !$noerror) {
7424                         &error(&text("efileopen", $file, $!));
7425                         }
7426                 binmode($fh);
7427                 return $ex;
7428                 }
7429         elsif ($file =~ /^([a-zA-Z]:)?\//) {
7430                 # Read mode .. nothing to do here
7431                 &webmin_debug_log("READ", $file) if ($db);
7432                 $file = &translate_filename($file);
7433                 return open($fh, $file);
7434                 }
7435         elsif ($file eq ">" || $file eq ">>") {
7436                 my ($package, $filename, $line) = caller;
7437                 if ($noerror) { return 0; }
7438                 else { &error("Missing file to open at ${package}::${filename} line $line"); }
7439                 }
7440         else {
7441                 my ($package, $filename, $line) = caller;
7442                 &error("Unsupported file or mode $file at ${package}::${filename} line $line");
7443                 }
7444         }
7445 }
7446
7447 =head2 close_tempfile(file|handle)
7448
7449 Copies a temp file to the actual file, assuming that all writes were
7450 successful. The handle must have been one passed to open_tempfile.
7451
7452 =cut
7453 sub close_tempfile
7454 {
7455 my $file;
7456 my $fh = &callers_package($_[0]);
7457
7458 if (defined($file = $main::open_temphandles{$fh})) {
7459         # Closing a handle
7460         close($fh) || &error(&text("efileclose", $file, $!));
7461         delete($main::open_temphandles{$fh});
7462         return &close_tempfile($file);
7463         }
7464 elsif (defined($main::open_tempfiles{$_[0]})) {
7465         # Closing a file
7466         &webmin_debug_log("CLOSE", $_[0]) if ($gconfig{'debug_what_write'});
7467         my @st = stat($_[0]);
7468         if (&is_selinux_enabled() && &has_command("chcon")) {
7469                 # Set original security context
7470                 system("chcon --reference=".quotemeta($_[0]).
7471                        " ".quotemeta($main::open_tempfiles{$_[0]}).
7472                        " >/dev/null 2>&1");
7473                 }
7474         my @old_attributes = &get_clear_file_attributes($_[0]);
7475         rename($main::open_tempfiles{$_[0]}, $_[0]) || &error("Failed to replace $_[0] with $main::open_tempfiles{$_[0]} : $!");
7476         if (@st) {
7477                 # Set original permissions and ownership
7478                 chmod($st[2], $_[0]);
7479                 chown($st[4], $st[5], $_[0]);
7480                 }
7481         &reset_file_attributes($_[0], \@old_attributes);
7482         delete($main::open_tempfiles{$_[0]});
7483         @main::temporary_files = grep { $_ ne $main::open_tempfiles{$_[0]} } @main::temporary_files;
7484         if ($main::open_templocks{$_[0]}) {
7485                 &unlock_file($_[0]);
7486                 delete($main::open_templocks{$_[0]});
7487                 }
7488         return 1;
7489         }
7490 else {
7491         # Must be closing a handle not associated with a file
7492         close($_[0]);
7493         return 1;
7494         }
7495 }
7496
7497 =head2 print_tempfile(handle, text, ...)
7498
7499 Like the normal print function, but calls &error on failure. Useful when
7500 combined with open_tempfile, to ensure that a criticial file is never
7501 only partially written.
7502
7503 =cut
7504 sub print_tempfile
7505 {
7506 my ($fh, @args) = @_;
7507 $fh = &callers_package($fh);
7508 (print $fh @args) || &error(&text("efilewrite",
7509                             $main::open_temphandles{$fh} || $fh, $!));
7510 }
7511
7512 =head2 is_selinux_enabled
7513
7514 Returns 1 if SElinux is supported on this system and enabled, 0 if not.
7515
7516 =cut
7517 sub is_selinux_enabled
7518 {
7519 if (!defined($main::selinux_enabled_cache)) {
7520         my %seconfig;
7521         if ($gconfig{'os_type'} !~ /-linux$/) {
7522                 # Not on linux, so no way
7523                 $main::selinux_enabled_cache = 0;
7524                 }
7525         elsif (&read_env_file("/etc/selinux/config", \%seconfig)) {
7526                 # Use global config file
7527                 $main::selinux_enabled_cache =
7528                         $seconfig{'SELINUX'} eq 'disabled' ||
7529                         !$seconfig{'SELINUX'} ? 0 : 1;
7530                 }
7531         else {
7532                 # Use selinuxenabled command
7533                 #$selinux_enabled_cache =
7534                 #       system("selinuxenabled >/dev/null 2>&1") ? 0 : 1;
7535                 $main::selinux_enabled_cache = 0;
7536                 }
7537         }
7538 return $main::selinux_enabled_cache;
7539 }
7540
7541 =head2 get_clear_file_attributes(file)
7542
7543 Finds file attributes that may prevent writing, clears them and returns them
7544 as a list. May call error. Mainly for internal use by open_tempfile and
7545 close_tempfile.
7546
7547 =cut
7548 sub get_clear_file_attributes
7549 {
7550 my ($file) = @_;
7551 my @old_attributes;
7552 if ($gconfig{'chattr'}) {
7553         # Get original immutable bit
7554         my $out = &backquote_command(
7555                 "lsattr ".quotemeta($file)." 2>/dev/null");
7556         if (!$?) {
7557                 $out =~ s/\s\S+\n//;
7558                 @old_attributes = grep { $_ ne '-' } split(//, $out);
7559                 }
7560         if (&indexof("i", @old_attributes) >= 0) {
7561                 my $err = &backquote_logged(
7562                         "chattr -i ".quotemeta($file)." 2>&1");
7563                 if ($?) {
7564                         &error("Failed to remove immutable bit on ".
7565                                "$file : $err");
7566                         }
7567                 }
7568         }
7569 return @old_attributes;
7570 }
7571
7572 =head2 reset_file_attributes(file, &attributes)
7573
7574 Put back cleared attributes on some file. May call error. Mainly for internal
7575 use by close_tempfile.
7576
7577 =cut
7578 sub reset_file_attributes
7579 {
7580 my ($file, $old_attributes) = @_;
7581 if (&indexof("i", @$old_attributes) >= 0) {
7582         my $err = &backquote_logged(
7583                 "chattr +i ".quotemeta($file)." 2>&1");
7584         if ($?) {
7585                 &error("Failed to restore immutable bit on ".
7586                        "$file : $err");
7587                 }
7588         }
7589 }
7590
7591 =head2 cleanup_tempnames
7592
7593 Remove all temporary files generated using transname. Typically only called
7594 internally when a Webmin script exits.
7595
7596 =cut
7597 sub cleanup_tempnames
7598 {
7599 foreach my $t (@main::temporary_files) {
7600         &unlink_file($t);
7601         }
7602 @main::temporary_files = ( );
7603 }
7604
7605 =head2 open_lock_tempfile([handle], file, [no-error])
7606
7607 Returns a temporary file for writing to some actual file, and also locks it.
7608 Effectively the same as calling lock_file and open_tempfile on the same file,
7609 but calls the unlock for you automatically when it is closed.
7610
7611 =cut
7612 sub open_lock_tempfile
7613 {
7614 my ($fh, $file, $noerror, $notemp, $safe) = @_;
7615 $fh = &callers_package($fh);
7616 my $lockfile = $file;
7617 $lockfile =~ s/^[^\/]*//;
7618 if ($lockfile =~ /^\//) {
7619         $main::open_templocks{$lockfile} = &lock_file($lockfile);
7620         }
7621 return &open_tempfile($fh, $file, $noerror, $notemp, $safe);
7622 }
7623
7624 sub END
7625 {
7626 $main::end_exit_status ||= $?;
7627 if ($$ == $main::initial_process_id) {
7628         # Exiting from initial process
7629         &cleanup_tempnames();
7630         if ($gconfig{'debug_what_start'} && $main::debug_log_start_time &&
7631             $main::debug_log_start_module eq &get_module_name()) {
7632                 my $len = time() - $main::debug_log_start_time;
7633                 &webmin_debug_log("STOP", "runtime=$len");
7634                 $main::debug_log_start_time = 0;
7635                 }
7636         if (!$ENV{'SCRIPT_NAME'} &&
7637             $main::initial_module_name eq &get_module_name()) {
7638                 # In a command-line script - call the real exit, so that the
7639                 # exit status gets properly propogated. In some cases this
7640                 # was not happening.
7641                 exit($main::end_exit_status);
7642                 }
7643         }
7644 }
7645
7646 =head2 month_to_number(month)
7647
7648 Converts a month name like feb to a number like 1.
7649
7650 =cut
7651 sub month_to_number
7652 {
7653 return $month_to_number_map{lc(substr($_[0], 0, 3))};
7654 }
7655
7656 =head2 number_to_month(number)
7657
7658 Converts a number like 1 to a month name like Feb.
7659
7660 =cut
7661 sub number_to_month
7662 {
7663 return ucfirst($number_to_month_map{$_[0]});
7664 }
7665
7666 =head2 get_rbac_module_acl(user, module)
7667
7668 Returns a hash reference of RBAC overrides ACLs for some user and module.
7669 May return undef if none exist (indicating access denied), or the string *
7670 if full access is granted.
7671
7672 =cut
7673 sub get_rbac_module_acl
7674 {
7675 my ($user, $mod) = @_;
7676 eval "use Authen::SolarisRBAC";
7677 return undef if ($@);
7678 my %rv;
7679 my $foundany = 0;
7680 if (Authen::SolarisRBAC::chkauth("webmin.$mod.admin", $user)) {
7681         # Automagic webmin.modulename.admin authorization exists .. allow access
7682         $foundany = 1;
7683         if (!Authen::SolarisRBAC::chkauth("webmin.$mod.config", $user)) {
7684                 %rv = ( 'noconfig' => 1 );
7685                 }
7686         else {
7687                 %rv = ( );
7688                 }
7689         }
7690 local $_;
7691 open(RBAC, &module_root_directory($mod)."/rbac-mapping");
7692 while(<RBAC>) {
7693         s/\r|\n//g;
7694         s/#.*$//;
7695         my ($auths, $acls) = split(/\s+/, $_);
7696         my @auths = split(/,/, $auths);
7697         next if (!$auths);
7698         my ($merge) = ($acls =~ s/^\+//);
7699         my $gotall = 1;
7700         if ($auths eq "*") {
7701                 # These ACLs apply to all RBAC users.
7702                 # Only if there is some that match a specific authorization
7703                 # later will they be used though.
7704                 }
7705         else {
7706                 # Check each of the RBAC authorizations
7707                 foreach my $a (@auths) {
7708                         if (!Authen::SolarisRBAC::chkauth($a, $user)) {
7709                                 $gotall = 0;
7710                                 last;
7711                                 }
7712                         }
7713                 $foundany++ if ($gotall);
7714                 }
7715         if ($gotall) {
7716                 # Found an RBAC authorization - return the ACLs
7717                 return "*" if ($acls eq "*");
7718                 my %acl = map { split(/=/, $_, 2) } split(/,/, $acls);
7719                 if ($merge) {
7720                         # Just add to current set
7721                         foreach my $a (keys %acl) {
7722                                 $rv{$a} = $acl{$a};
7723                                 }
7724                         }
7725                 else {
7726                         # Found final ACLs
7727                         return \%acl;
7728                         }
7729                 }
7730         }
7731 close(RBAC);
7732 return !$foundany ? undef : %rv ? \%rv : undef;
7733 }
7734
7735 =head2 supports_rbac([module])
7736
7737 Returns 1 if RBAC client support is available, such as on Solaris.
7738
7739 =cut
7740 sub supports_rbac
7741 {
7742 return 0 if ($gconfig{'os_type'} ne 'solaris');
7743 eval "use Authen::SolarisRBAC";
7744 return 0 if ($@);
7745 if ($_[0]) {
7746         #return 0 if (!-r &module_root_directory($_[0])."/rbac-mapping");
7747         }
7748 return 1;
7749 }
7750
7751 =head2 use_rbac_module_acl(user, module)
7752
7753 Returns 1 if some user should use RBAC to get permissions for a module
7754
7755 =cut
7756 sub use_rbac_module_acl
7757 {
7758 my $u = defined($_[0]) ? $_[0] : $base_remote_user;
7759 my $m = defined($_[1]) ? $_[1] : &get_module_name();
7760 return 1 if ($gconfig{'rbacdeny_'.$u});         # RBAC forced for user
7761 my %access = &get_module_acl($u, $m, 1);
7762 return $access{'rbac'} ? 1 : 0;
7763 }
7764
7765 =head2 execute_command(command, stdin, stdout, stderr, translate-files?, safe?)
7766
7767 Runs some command, possibly feeding it input and capturing output to the
7768 give files or scalar references. The parameters are :
7769
7770 =item command - Full command to run, possibly including shell meta-characters.
7771
7772 =item stdin - File to read input from, or a scalar ref containing input, or undef if no input should be given.
7773
7774 =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.
7775
7776 =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.
7777
7778 =item translate-files - Set to 1 to apply filename translation to any filenames. Usually has no effect.
7779
7780 =item safe - Set to 1 if this command is safe and does not modify the state of the system.
7781
7782 =cut
7783 sub execute_command
7784 {
7785 my ($cmd, $stdin, $stdout, $stderr, $trans, $safe) = @_;
7786 if (&is_readonly_mode() && !$safe) {
7787         print STDERR "Vetoing command $_[0]\n";
7788         $? = 0;
7789         return 0;
7790         }
7791 $cmd = &translate_command($cmd);
7792
7793 # Use ` operator where possible
7794 &webmin_debug_log('CMD', "cmd=$cmd") if ($gconfig{'debug_what_cmd'});
7795 if (!$stdin && ref($stdout) && !$stderr) {
7796         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
7797         $$stdout = `$cmd 2>$null_file`;
7798         return $?;
7799         }
7800 elsif (!$stdin && ref($stdout) && $stdout eq $stderr) {
7801         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
7802         $$stdout = `$cmd 2>&1`;
7803         return $?;
7804         }
7805 elsif (!$stdin && !$stdout && !$stderr) {
7806         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
7807         return system("$cmd >$null_file 2>$null_file <$null_file");
7808         }
7809
7810 # Setup pipes
7811 $| = 1;         # needed on some systems to flush before forking
7812 pipe(EXECSTDINr, EXECSTDINw);
7813 pipe(EXECSTDOUTr, EXECSTDOUTw);
7814 pipe(EXECSTDERRr, EXECSTDERRw);
7815 my $pid;
7816 if (!($pid = fork())) {
7817         untie(*STDIN);
7818         untie(*STDOUT);
7819         untie(*STDERR);
7820         open(STDIN, "<&EXECSTDINr");
7821         open(STDOUT, ">&EXECSTDOUTw");
7822         if (ref($stderr) && $stderr eq $stdout) {
7823                 open(STDERR, ">&EXECSTDOUTw");
7824                 }
7825         else {
7826                 open(STDERR, ">&EXECSTDERRw");
7827                 }
7828         $| = 1;
7829         close(EXECSTDINw);
7830         close(EXECSTDOUTr);
7831         close(EXECSTDERRr);
7832
7833         my $fullcmd = "($cmd)";
7834         if ($stdin && !ref($stdin)) {
7835                 $fullcmd .= " <$stdin";
7836                 }
7837         if ($stdout && !ref($stdout)) {
7838                 $fullcmd .= " >$stdout";
7839                 }
7840         if ($stderr && !ref($stderr)) {
7841                 if ($stderr eq $stdout) {
7842                         $fullcmd .= " 2>&1";
7843                         }
7844                 else {
7845                         $fullcmd .= " 2>$stderr";
7846                         }
7847                 }
7848         if ($gconfig{'os_type'} eq 'windows') {
7849                 exec($fullcmd);
7850                 }
7851         else {
7852                 exec("/bin/sh", "-c", $fullcmd);
7853                 }
7854         print "Exec failed : $!\n";
7855         exit(1);
7856         }
7857 close(EXECSTDINr);
7858 close(EXECSTDOUTw);
7859 close(EXECSTDERRw);
7860
7861 # Feed input and capture output
7862 local $_;
7863 if ($stdin && ref($stdin)) {
7864         print EXECSTDINw $$stdin;
7865         close(EXECSTDINw);
7866         }
7867 if ($stdout && ref($stdout)) {
7868         $$stdout = undef;
7869         while(<EXECSTDOUTr>) {
7870                 $$stdout .= $_;
7871                 }
7872         close(EXECSTDOUTr);
7873         }
7874 if ($stderr && ref($stderr) && $stderr ne $stdout) {
7875         $$stderr = undef;
7876         while(<EXECSTDERRr>) {
7877                 $$stderr .= $_;
7878                 }
7879         close(EXECSTDERRr);
7880         }
7881
7882 # Get exit status
7883 waitpid($pid, 0);
7884 return $?;
7885 }
7886
7887 =head2 open_readfile(handle, file)
7888
7889 Opens some file for reading. Returns 1 on success, 0 on failure. Pretty much
7890 exactly the same as Perl's open function.
7891
7892 =cut
7893 sub open_readfile
7894 {
7895 my ($fh, $file) = @_;
7896 $fh = &callers_package($fh);
7897 my $realfile = &translate_filename($file);
7898 &webmin_debug_log('READ', $file) if ($gconfig{'debug_what_read'});
7899 return open($fh, "<".$realfile);
7900 }
7901
7902 =head2 open_execute_command(handle, command, output?, safe?)
7903
7904 Runs some command, with the specified file handle set to either write to it if
7905 in-or-out is set to 0, or read to it if output is set to 1. The safe flag
7906 indicates if the command modifies the state of the system or not.
7907
7908 =cut
7909 sub open_execute_command
7910 {
7911 my ($fh, $cmd, $mode, $safe) = @_;
7912 $fh = &callers_package($fh);
7913 my $realcmd = &translate_command($cmd);
7914 if (&is_readonly_mode() && !$safe) {
7915         # Don't actually run it
7916         print STDERR "vetoing command $cmd\n";
7917         $? = 0;
7918         if ($mode == 0) {
7919                 return open($fh, ">$null_file");
7920                 }
7921         else {
7922                 return open($fh, $null_file);
7923                 }
7924         }
7925 # Really run it
7926 &webmin_debug_log('CMD', "cmd=$realcmd mode=$mode")
7927         if ($gconfig{'debug_what_cmd'});
7928 if ($mode == 0) {
7929         return open($fh, "| $cmd");
7930         }
7931 elsif ($mode == 1) {
7932         return open($fh, "$cmd 2>$null_file |");
7933         }
7934 elsif ($mode == 2) {
7935         return open($fh, "$cmd 2>&1 |");
7936         }
7937 }
7938
7939 =head2 translate_filename(filename)
7940
7941 Applies all relevant registered translation functions to a filename. Mostly
7942 for internal use, and typically does nothing.
7943
7944 =cut
7945 sub translate_filename
7946 {
7947 my ($realfile) = @_;
7948 my @funcs = grep { $_->[0] eq &get_module_name() ||
7949                    !defined($_->[0]) } @main::filename_callbacks;
7950 foreach my $f (@funcs) {
7951         my $func = $f->[1];
7952         $realfile = &$func($realfile, @{$f->[2]});
7953         }
7954 return $realfile;
7955 }
7956
7957 =head2 translate_command(filename)
7958
7959 Applies all relevant registered translation functions to a command. Mostly
7960 for internal use, and typically does nothing.
7961
7962 =cut
7963 sub translate_command
7964 {
7965 my ($realcmd) = @_;
7966 my @funcs = grep { $_->[0] eq &get_module_name() ||
7967                    !defined($_->[0]) } @main::command_callbacks;
7968 foreach my $f (@funcs) {
7969         my $func = $f->[1];
7970         $realcmd = &$func($realcmd, @{$f->[2]});
7971         }
7972 return $realcmd;
7973 }
7974
7975 =head2 register_filename_callback(module|undef, &function, &args)
7976
7977 Registers some function to be called when the specified module (or all
7978 modules) tries to open a file for reading and writing. The function must
7979 return the actual file to open. This allows you to override which files
7980 other code actually operates on, via the translate_filename function.
7981
7982 =cut
7983 sub register_filename_callback
7984 {
7985 my ($mod, $func, $args) = @_;
7986 push(@main::filename_callbacks, [ $mod, $func, $args ]);
7987 }
7988
7989 =head2 register_command_callback(module|undef, &function, &args)
7990
7991 Registers some function to be called when the specified module (or all
7992 modules) tries to execute a command. The function must return the actual
7993 command to run. This allows you to override which commands other other code
7994 actually runs, via the translate_command function.
7995
7996 =cut
7997 sub register_command_callback
7998 {
7999 my ($mod, $func, $args) = @_;
8000 push(@main::command_callbacks, [ $mod, $func, $args ]);
8001 }
8002
8003 =head2 capture_function_output(&function, arg, ...)
8004
8005 Captures output that some function prints to STDOUT, and returns it. Useful
8006 for functions outside your control that print data when you really want to
8007 manipulate it before output.
8008
8009 =cut
8010 sub capture_function_output
8011 {
8012 my ($func, @args) = @_;
8013 socketpair(SOCKET2, SOCKET1, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
8014 my $old = select(SOCKET1);
8015 my @rv = &$func(@args);
8016 select($old);
8017 close(SOCKET1);
8018 my $out;
8019 local $_;
8020 while(<SOCKET2>) {
8021         $out .= $_;
8022         }
8023 close(SOCKET2);
8024 return wantarray ? ($out, \@rv) : $out;
8025 }
8026
8027 =head2 capture_function_output_tempfile(&function, arg, ...)
8028
8029 Behaves the same as capture_function_output, but uses a temporary file
8030 to avoid buffer full problems.
8031
8032 =cut
8033 sub capture_function_output_tempfile
8034 {
8035 my ($func, @args) = @_;
8036 my $temp = &transname();
8037 open(BUFFER, ">$temp");
8038 my $old = select(BUFFER);
8039 my @rv = &$func(@args);
8040 select($old);
8041 close(BUFFER);
8042 my $out = &read_file_contents($temp);
8043 &unlink_file($temp);
8044 return wantarray ? ($out, \@rv) : $out;
8045 }
8046
8047 =head2 modules_chooser_button(field, multiple, [form])
8048
8049 Returns HTML for a button for selecting one or many Webmin modules.
8050 field - Name of the HTML field to place the module names into.
8051 multiple - Set to 1 if multiple modules can be selected.
8052 form - Index of the form on the page.
8053
8054 =cut
8055 sub modules_chooser_button
8056 {
8057 return &theme_modules_chooser_button(@_)
8058         if (defined(&theme_modules_chooser_button));
8059 my $form = defined($_[2]) ? $_[2] : 0;
8060 my $w = $_[1] ? 700 : 500;
8061 my $h = 200;
8062 if ($_[1] && $gconfig{'db_sizemodules'}) {
8063         ($w, $h) = split(/x/, $gconfig{'db_sizemodules'});
8064         }
8065 elsif (!$_[1] && $gconfig{'db_sizemodule'}) {
8066         ($w, $h) = split(/x/, $gconfig{'db_sizemodule'});
8067         }
8068 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";
8069 }
8070
8071 =head2 substitute_template(text, &hash)
8072
8073 Given some text and a hash reference, for each ocurrance of $FOO or ${FOO} in
8074 the text replaces it with the value of the hash key foo. Also supports blocks
8075 like ${IF-FOO} ... ${ENDIF-FOO}, whose contents are only included if foo is
8076 non-zero, and ${IF-FOO} ... ${ELSE-FOO} ... ${ENDIF-FOO}.
8077
8078 =cut
8079 sub substitute_template
8080 {
8081 # Add some extra fixed parameters to the hash
8082 my %hash = %{$_[1]};
8083 $hash{'hostname'} = &get_system_hostname();
8084 $hash{'webmin_config'} = $config_directory;
8085 $hash{'webmin_etc'} = $config_directory;
8086 $hash{'module_config'} = &get_module_variable('$module_config_directory');
8087 $hash{'webmin_var'} = $var_directory;
8088
8089 # Add time-based parameters, for use in DNS
8090 $hash{'current_time'} = time();
8091 my @tm = localtime($hash{'current_time'});
8092 $hash{'current_year'} = $tm[5]+1900;
8093 $hash{'current_month'} = sprintf("%2.2d", $tm[4]+1);
8094 $hash{'current_day'} = sprintf("%2.2d", $tm[3]);
8095 $hash{'current_hour'} = sprintf("%2.2d", $tm[2]);
8096 $hash{'current_minute'} = sprintf("%2.2d", $tm[1]);
8097 $hash{'current_second'} = sprintf("%2.2d", $tm[0]);
8098
8099 # Actually do the substition
8100 my $rv = $_[0];
8101 foreach my $s (keys %hash) {
8102         next if ($s eq '');     # Prevent just $ from being subbed
8103         my $us = uc($s);
8104         my $sv = $hash{$s};
8105         $rv =~ s/\$\{\Q$us\E\}/$sv/g;
8106         $rv =~ s/\$\Q$us\E/$sv/g;
8107         if ($sv) {
8108                 # Replace ${IF}..${ELSE}..${ENDIF} block with first value,
8109                 # and ${IF}..${ENDIF} with value
8110                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/$2/g;
8111                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/$2/g;
8112
8113                 # Replace $IF..$ELSE..$ENDIF block with first value,
8114                 # and $IF..$ENDIF with value
8115                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ELSE-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/$2/g;
8116                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/$2/g;
8117
8118                 # Replace ${IFEQ}..${ENDIFEQ} block with first value if
8119                 # matching, nothing if not
8120                 $rv =~ s/\$\{IFEQ-\Q$us\E-\Q$sv\E\}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-\Q$sv\E\}(\n?)/$2/g;
8121                 $rv =~ s/\$\{IFEQ-\Q$us\E-[^\}]+}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-[^\}]+\}(\n?)//g;
8122
8123                 # Replace $IFEQ..$ENDIFEQ block with first value if
8124                 # matching, nothing if not
8125                 $rv =~ s/\$IFEQ-\Q$us\E-\Q$sv\E(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\Q$sv\E(\n?)/$2/g;
8126                 $rv =~ s/\$IFEQ-\Q$us\E-\S+(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\S+(\n?)//g;
8127                 }
8128         else {
8129                 # Replace ${IF}..${ELSE}..${ENDIF} block with second value,
8130                 # and ${IF}..${ENDIF} with nothing
8131                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/$4/g;
8132                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)//g;
8133
8134                 # Replace $IF..$ELSE..$ENDIF block with second value,
8135                 # and $IF..$ENDIF with nothing
8136                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ELSE-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/$4/g;
8137                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)//g;
8138
8139                 # Replace ${IFEQ}..${ENDIFEQ} block with nothing
8140                 $rv =~ s/\$\{IFEQ-\Q$us\E-[^\}]+}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-[^\}]+\}(\n?)//g;
8141                 $rv =~ s/\$IFEQ-\Q$us\E-\S+(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\S+(\n?)//g;
8142                 }
8143         }
8144
8145 # Now assume any $IF blocks whose variables are not present in the hash
8146 # evaluate to false.
8147 # $IF...$ELSE x $ENDIF => x
8148 $rv =~ s/\$\{IF\-([A-Z]+)\}.*?\$\{ELSE\-\1\}(.*?)\$\{ENDIF\-\1\}/$2/gs;
8149 # $IF...x...$ENDIF => (nothing)
8150 $rv =~ s/\$\{IF\-([A-Z]+)\}.*?\$\{ENDIF\-\1\}//gs;
8151 # ${var} => (nothing)
8152 $rv =~ s/\$\{[A-Z]+\}//g;
8153
8154 return $rv;
8155 }
8156
8157 =head2 running_in_zone
8158
8159 Returns 1 if the current Webmin instance is running in a Solaris zone. Used to
8160 disable module and features that are not appropriate, like those that modify
8161 mounted filesystems.
8162
8163 =cut
8164 sub running_in_zone
8165 {
8166 return 0 if ($gconfig{'os_type'} ne 'solaris' ||
8167              $gconfig{'os_version'} < 10);
8168 my $zn = `zonename 2>$null_file`;
8169 chop($zn);
8170 return $zn && $zn ne "global";
8171 }
8172
8173 =head2 running_in_vserver
8174
8175 Returns 1 if the current Webmin instance is running in a Linux VServer.
8176 Used to disable modules and features that are not appropriate.
8177
8178 =cut
8179 sub running_in_vserver
8180 {
8181 return 0 if ($gconfig{'os_type'} !~ /^\*-linux$/);
8182 my $vserver;
8183 local $_;
8184 open(MTAB, "/etc/mtab");
8185 while(<MTAB>) {
8186         my ($dev, $mp) = split(/\s+/, $_);
8187         if ($mp eq "/" && $dev =~ /^\/dev\/hdv/) {
8188                 $vserver = 1;
8189                 last;
8190                 }
8191         }
8192 close(MTAB);
8193 return $vserver;
8194 }
8195
8196 =head2 running_in_xen
8197
8198 Returns 1 if Webmin is running inside a Xen instance, by looking
8199 at /proc/xen/capabilities.
8200
8201 =cut
8202 sub running_in_xen
8203 {
8204 return 0 if (!-r "/proc/xen/capabilities");
8205 my $cap = &read_file_contents("/proc/xen/capabilities");
8206 return $cap =~ /control_d/ ? 0 : 1;
8207 }
8208
8209 =head2 running_in_openvz
8210
8211 Returns 1 if Webmin is running inside an OpenVZ container, by looking
8212 at /proc/vz/veinfo for a non-zero line.
8213
8214 =cut
8215 sub running_in_openvz
8216 {
8217 return 0 if (!-r "/proc/vz/veinfo");
8218 my $lref = &read_file_lines("/proc/vz/veinfo", 1);
8219 return 0 if (!$lref || !@$lref);
8220 foreach my $l (@$lref) {
8221         $l =~ s/^\s+//;
8222         my @ll = split(/\s+/, $l);
8223         return 0 if ($ll[0] eq '0');
8224         }
8225 return 1;
8226 }
8227
8228 =head2 list_categories(&modules, [include-empty])
8229
8230 Returns a hash mapping category codes to names, including any custom-defined
8231 categories. The modules parameter must be an array ref of module hash objects,
8232 as returned by get_all_module_infos.
8233
8234 =cut
8235 sub list_categories
8236 {
8237 my ($mods, $empty) = @_;
8238 my (%cats, %catnames);
8239 &read_file("$config_directory/webmin.catnames", \%catnames);
8240 foreach my $o (@lang_order_list) {
8241         &read_file("$config_directory/webmin.catnames.$o", \%catnames);
8242         }
8243 if ($empty) {
8244         %cats = %catnames;
8245         }
8246 foreach my $m (@$mods) {
8247         my $c = $m->{'category'};
8248         next if ($cats{$c});
8249         if (defined($catnames{$c})) {
8250                 $cats{$c} = $catnames{$c};
8251                 }
8252         elsif ($text{"category_$c"}) {
8253                 $cats{$c} = $text{"category_$c"};
8254                 }
8255         else {
8256                 # try to get category name from module ..
8257                 my %mtext = &load_language($m->{'dir'});
8258                 if ($mtext{"category_$c"}) {
8259                         $cats{$c} = $mtext{"category_$c"};
8260                         }
8261                 else {
8262                         $c = $m->{'category'} = "";
8263                         $cats{$c} = $text{"category_$c"};
8264                         }
8265                 }
8266         }
8267 return %cats;
8268 }
8269
8270 =head2 is_readonly_mode
8271
8272 Returns 1 if the current user is in read-only mode, and thus all writes
8273 to files and command execution should fail.
8274
8275 =cut
8276 sub is_readonly_mode
8277 {
8278 if (!defined($main::readonly_mode_cache)) {
8279         my %gaccess = &get_module_acl(undef, "");
8280         $main::readonly_mode_cache = $gaccess{'readonly'} ? 1 : 0;
8281         }
8282 return $main::readonly_mode_cache;
8283 }
8284
8285 =head2 command_as_user(user, with-env?, command, ...)
8286
8287 Returns a command to execute some command as the given user, using the
8288 su statement. If on Linux, the /bin/sh shell is forced in case the user
8289 does not have a valid shell. If with-env is set to 1, the -s flag is added
8290 to the su command to read the user's .profile or .bashrc file.
8291
8292 =cut
8293 sub command_as_user
8294 {
8295 my ($user, $env, @args) = @_;
8296 my @uinfo = getpwnam($user);
8297 if ($uinfo[8] ne "/bin/sh" && $uinfo[8] !~ /\/bash$/) {
8298         # User shell doesn't appear to be valid
8299         if ($gconfig{'os_type'} =~ /-linux$/) {
8300                 # Use -s /bin/sh to force it
8301                 $shellarg = " -s /bin/sh";
8302                 }
8303         elsif ($gconfig{'os_type'} eq 'freebsd' ||
8304                $gconfig{'os_type'} eq 'solaris' &&
8305                 $gconfig{'os_version'} >= 11 ||
8306                $gconfig{'os_type'} eq 'macos') {
8307                 # Use -m and force /bin/sh
8308                 @args = ( "/bin/sh", "-c", quotemeta(join(" ", @args)) );
8309                 $shellarg = " -m";
8310                 }
8311         }
8312 my $rv = "su".($env ? " -" : "").$shellarg.
8313          " ".quotemeta($user)." -c ".quotemeta(join(" ", @args));
8314 return $rv;
8315 }
8316
8317 =head2 list_osdn_mirrors(project, file)
8318
8319 This function is now deprecated in favor of letting sourceforge just
8320 redirect to the best mirror, and now just returns their primary download URL.
8321
8322 =cut
8323 sub list_osdn_mirrors
8324 {
8325 my ($project, $file) = @_;
8326 return ( { 'url' => "http://downloads.sourceforge.net/$project/$file",
8327            'default' => 0,
8328            'mirror' => 'downloads' } );
8329 }
8330
8331 =head2 convert_osdn_url(url)
8332
8333 Given a URL like http://osdn.dl.sourceforge.net/sourceforge/project/file.zip
8334 or http://prdownloads.sourceforge.net/project/file.zip , convert it
8335 to a real URL on the sourceforge download redirector.
8336
8337 =cut
8338 sub convert_osdn_url
8339 {
8340 my ($url) = @_;
8341 if ($url =~ /^http:\/\/[^\.]+.dl.sourceforge.net\/sourceforge\/([^\/]+)\/(.*)$/ ||
8342     $url =~ /^http:\/\/prdownloads.sourceforge.net\/([^\/]+)\/(.*)$/) {
8343         # Always use the Sourceforge mail download URL, which does
8344         # a location-based redirect for us
8345         my ($project, $file) = ($1, $2);
8346         $url = "http://prdownloads.sourceforge.net/sourceforge/".
8347                "$project/$file";
8348         return wantarray ? ( $url, 0 ) : $url;
8349         }
8350 else {
8351         # Some other source .. don't change
8352         return wantarray ? ( $url, 2 ) : $url;
8353         }
8354 }
8355
8356 =head2 get_current_dir
8357
8358 Returns the directory the current process is running in.
8359
8360 =cut
8361 sub get_current_dir
8362 {
8363 my $out;
8364 if ($gconfig{'os_type'} eq 'windows') {
8365         # Use cd command
8366         $out = `cd`;
8367         }
8368 else {
8369         # Use pwd command
8370         $out = `pwd`;
8371         $out =~ s/\\/\//g;
8372         }
8373 $out =~ s/\r|\n//g;
8374 return $out;
8375 }
8376
8377 =head2 supports_users
8378
8379 Returns 1 if the current OS supports Unix user concepts and functions like
8380 su , getpw* and so on. This will be true on Linux and other Unixes, but false
8381 on Windows.
8382
8383 =cut
8384 sub supports_users
8385 {
8386 return $gconfig{'os_type'} ne 'windows';
8387 }
8388
8389 =head2 supports_symlinks
8390
8391 Returns 1 if the current OS supports symbolic and hard links. This will not
8392 be the case on Windows.
8393
8394 =cut
8395 sub supports_symlinks
8396 {
8397 return $gconfig{'os_type'} ne 'windows';
8398 }
8399
8400 =head2 quote_path(path)
8401
8402 Returns a path with safe quoting for the current operating system.
8403
8404 =cut
8405 sub quote_path
8406 {
8407 my ($path) = @_;
8408 if ($gconfig{'os_type'} eq 'windows' || $path =~ /^[a-z]:/i) {
8409         # Windows only supports "" style quoting
8410         return "\"$path\"";
8411         }
8412 else {
8413         return quotemeta($path);
8414         }
8415 }
8416
8417 =head2 get_windows_root
8418
8419 Returns the base windows system directory, like c:/windows.
8420
8421 =cut
8422 sub get_windows_root
8423 {
8424 if ($ENV{'SystemRoot'}) {
8425         my $rv = $ENV{'SystemRoot'};
8426         $rv =~ s/\\/\//g;
8427         return $rv;
8428         }
8429 else {
8430         return -d "c:/windows" ? "c:/windows" : "c:/winnt";
8431         }
8432 }
8433
8434 =head2 read_file_contents(file)
8435
8436 Given a filename, returns its complete contents as a string. Effectively
8437 the same as the Perl construct `cat file`.
8438
8439 =cut
8440 sub read_file_contents
8441 {
8442 &open_readfile(FILE, $_[0]) || return undef;
8443 local $/ = undef;
8444 my $rv = <FILE>;
8445 close(FILE);
8446 return $rv;
8447 }
8448
8449 =head2 unix_crypt(password, salt)
8450
8451 Performs Unix encryption on a password, using the built-in crypt function or
8452 the Crypt::UnixCrypt module if the former does not work. The salt parameter
8453 must be either an already-hashed password, or a two-character alpha-numeric
8454 string.
8455
8456 =cut
8457 sub unix_crypt
8458 {
8459 my ($pass, $salt) = @_;
8460 return "" if ($salt !~ /^[a-zA-Z0-9\.\/]{2}/);   # same as real crypt
8461 my $rv = eval "crypt(\$pass, \$salt)";
8462 my $err = $@;
8463 return $rv if ($rv && !$@);
8464 eval "use Crypt::UnixCrypt";
8465 if (!$@) {
8466         return Crypt::UnixCrypt::crypt($pass, $salt);
8467         }
8468 else {
8469         &error("Failed to encrypt password : $err");
8470         }
8471 }
8472
8473 =head2 split_quoted_string(string)
8474
8475 Given a string like I<foo "bar baz" quux>, returns the array :
8476 foo, bar baz, quux
8477
8478 =cut
8479 sub split_quoted_string
8480 {
8481 my ($str) = @_;
8482 my @rv;
8483 while($str =~ /^"([^"]*)"\s*([\000-\377]*)$/ ||
8484       $str =~ /^'([^']*)'\s*([\000-\377]*)$/ ||
8485       $str =~ /^(\S+)\s*([\000-\377]*)$/) {
8486         push(@rv, $1);
8487         $str = $2;
8488         }
8489 return @rv;
8490 }
8491
8492 =head2 write_to_http_cache(url, file|&data)
8493
8494 Updates the Webmin cache with the contents of the given file, possibly also
8495 clearing out old data. Mainly for internal use by http_download.
8496
8497 =cut
8498 sub write_to_http_cache
8499 {
8500 my ($url, $file) = @_;
8501 return 0 if (!$gconfig{'cache_size'});
8502
8503 # Don't cache downloads that look dynamic
8504 if ($url =~ /cgi-bin/ || $url =~ /\?/) {
8505         return 0;
8506         }
8507
8508 # Check if the current module should do caching
8509 if ($gconfig{'cache_mods'} =~ /^\!(.*)$/) {
8510         # Caching all except some modules
8511         my @mods = split(/\s+/, $1);
8512         return 0 if (&indexof(&get_module_name(), @mods) != -1);
8513         }
8514 elsif ($gconfig{'cache_mods'}) {
8515         # Only caching some modules
8516         my @mods = split(/\s+/, $gconfig{'cache_mods'});
8517         return 0 if (&indexof(&get_module_name(), @mods) == -1);
8518         }
8519
8520 # Work out the size
8521 my $size;
8522 if (ref($file)) {
8523         $size = length($$file);
8524         }
8525 else {
8526         my @st = stat($file);
8527         $size = $st[7];
8528         }
8529
8530 if ($size > $gconfig{'cache_size'}) {
8531         # Bigger than the whole cache - so don't save it
8532         return 0;
8533         }
8534 my $cfile = $url;
8535 $cfile =~ s/\//_/g;
8536 $cfile = "$main::http_cache_directory/$cfile";
8537
8538 # See how much we have cached currently, clearing old files
8539 my $total = 0;
8540 mkdir($main::http_cache_directory, 0700) if (!-d $main::http_cache_directory);
8541 opendir(CACHEDIR, $main::http_cache_directory);
8542 foreach my $f (readdir(CACHEDIR)) {
8543         next if ($f eq "." || $f eq "..");
8544         my $path = "$main::http_cache_directory/$f";
8545         my @st = stat($path);
8546         if ($gconfig{'cache_days'} &&
8547             time()-$st[9] > $gconfig{'cache_days'}*24*60*60) {
8548                 # This file is too old .. trash it
8549                 unlink($path);
8550                 }
8551         else {
8552                 $total += $st[7];
8553                 push(@cached, [ $path, $st[7], $st[9] ]);
8554                 }
8555         }
8556 closedir(CACHEDIR);
8557 @cached = sort { $a->[2] <=> $b->[2] } @cached;
8558 while($total+$size > $gconfig{'cache_size'} && @cached) {
8559         # Cache is too big .. delete some files until the new one will fit
8560         unlink($cached[0]->[0]);
8561         $total -= $cached[0]->[1];
8562         shift(@cached);
8563         }
8564
8565 # Finally, write out the new file
8566 if (ref($file)) {
8567         &open_tempfile(CACHEFILE, ">$cfile");
8568         &print_tempfile(CACHEFILE, $$file);
8569         &close_tempfile(CACHEFILE);
8570         }
8571 else {
8572         my ($ok, $err) = &copy_source_dest($file, $cfile);
8573         }
8574
8575 return 1;
8576 }
8577
8578 =head2 check_in_http_cache(url)
8579
8580 If some URL is in the cache and valid, return the filename for it. Mainly
8581 for internal use by http_download.
8582
8583 =cut
8584 sub check_in_http_cache
8585 {
8586 my ($url) = @_;
8587 return undef if (!$gconfig{'cache_size'});
8588
8589 # Check if the current module should do caching
8590 if ($gconfig{'cache_mods'} =~ /^\!(.*)$/) {
8591         # Caching all except some modules
8592         my @mods = split(/\s+/, $1);
8593         return 0 if (&indexof(&get_module_name(), @mods) != -1);
8594         }
8595 elsif ($gconfig{'cache_mods'}) {
8596         # Only caching some modules
8597         my @mods = split(/\s+/, $gconfig{'cache_mods'});
8598         return 0 if (&indexof(&get_module_name(), @mods) == -1);
8599         }
8600
8601 my $cfile = $url;
8602 $cfile =~ s/\//_/g;
8603 $cfile = "$main::http_cache_directory/$cfile";
8604 my @st = stat($cfile);
8605 return undef if (!@st || !$st[7]);
8606 if ($gconfig{'cache_days'} && time()-$st[9] > $gconfig{'cache_days'}*24*60*60) {
8607         # Too old!
8608         unlink($cfile);
8609         return undef;
8610         }
8611 open(TOUCH, ">>$cfile");        # Update the file time, to keep it in the cache
8612 close(TOUCH);
8613 return $cfile;
8614 }
8615
8616 =head2 supports_javascript
8617
8618 Returns 1 if the current browser is assumed to support javascript.
8619
8620 =cut
8621 sub supports_javascript
8622 {
8623 if (defined(&theme_supports_javascript)) {
8624         return &theme_supports_javascript();
8625         }
8626 return $ENV{'MOBILE_DEVICE'} ? 0 : 1;
8627 }
8628
8629 =head2 get_module_name
8630
8631 Returns the name of the Webmin module that called this function. For internal
8632 use only by other API functions.
8633
8634 =cut
8635 sub get_module_name
8636 {
8637 return &get_module_variable('$module_name');
8638 }
8639
8640 =head2 get_module_variable(name, [ref])
8641
8642 Returns the value of some variable which is set in the caller's context, if
8643 using the new WebminCore package. For internal use only.
8644
8645 =cut
8646 sub get_module_variable
8647 {
8648 my ($v, $wantref) = @_;
8649 my $slash = $wantref ? "\\" : "";
8650 my $thispkg = &web_libs_package();
8651 if ($thispkg eq 'WebminCore') {
8652         my ($vt, $vn) = split('', $v, 2);
8653         my $callpkg;
8654         for(my $i=0; ($callpkg) = caller($i); $i++) {
8655                 last if ($callpkg ne $thispkg);
8656                 }
8657         return eval "${slash}${vt}${callpkg}::${vn}";
8658         }
8659 return eval "${slash}${v}";
8660 }
8661
8662 =head2 clear_time_locale()
8663
8664 Temporarily force the locale to C, until reset_time_locale is called. This is
8665 useful if your code is going to call C<strftime> from the POSIX package, and
8666 you want to ensure that the output is in a consistent format.
8667
8668 =cut
8669 sub clear_time_locale
8670 {
8671 if ($main::clear_time_locale_count == 0) {
8672         eval {
8673                 use POSIX;
8674                 $main::clear_time_locale_old = POSIX::setlocale(POSIX::LC_TIME);
8675                 POSIX::setlocale(POSIX::LC_TIME, "C");
8676                 };
8677         }
8678 $main::clear_time_locale_count++;
8679 }
8680
8681 =head2 reset_time_locale()
8682
8683 Revert the locale to whatever it was before clear_time_locale was called
8684
8685 =cut
8686 sub reset_time_locale
8687 {
8688 if ($main::clear_time_locale_count == 1) {
8689         eval {
8690                 POSIX::setlocale(POSIX::LC_TIME, $main::clear_time_locale_old);
8691                 $main::clear_time_locale_old = undef;
8692                 };
8693         }
8694 $main::clear_time_locale_count--;
8695 }
8696
8697 =head2 callers_package(filehandle)
8698
8699 Convert a non-module filehandle like FOO to one qualified with the
8700 caller's caller's package, like fsdump::FOO. For internal use only.
8701
8702 =cut
8703 sub callers_package
8704 {
8705 my ($fh) = @_;
8706 my $callpkg = (caller(1))[0];
8707 my $thispkg = &web_libs_package();
8708 if (!ref($fh) && $fh !~ /::/ &&
8709     $callpkg ne $thispkg && $thispkg eq 'WebminCore') {
8710         $fh = $callpkg."::".$fh;
8711         }
8712 return $fh;
8713 }
8714
8715 =head2 web_libs_package()
8716
8717 Returns the package this code is in. We can't always trust __PACKAGE__. For
8718 internal use only.
8719
8720 =cut
8721 sub web_libs_package
8722 {
8723 if ($called_from_webmin_core) {
8724         return "WebminCore";
8725         }
8726 return __PACKAGE__;
8727 }
8728
8729 =head2 get_userdb_string
8730
8731 Returns the URL-style string for connecting to the users and groups database
8732
8733 =cut
8734 sub get_userdb_string
8735 {
8736 my %miniserv;
8737 &get_miniserv_config(\%miniserv);
8738 return $miniserv{'userdb'};
8739 }
8740
8741 =head2 connect_userdb(string)
8742
8743 Returns a handle for talking to a user database - may be a DBI or LDAP handle.
8744 On failure returns an error message string.
8745
8746 =cut
8747 sub connect_userdb
8748 {
8749 my ($str) = @_;
8750 my ($proto, $user, $pass, $host, $prefix, $args) = &split_userdb_string($str);
8751 if ($proto eq "mysql") {
8752         # Connect to MySQL with DBI
8753         my $drh = eval "use DBI; DBI->install_driver('mysql');";
8754         $drh || return $text{'sql_emysqldriver'};
8755         my ($host, $port) = split(/:/, $host);
8756         my $cstr = "database=$prefix;host=$host";
8757         $cstr .= ";port=$port" if ($port);
8758         my $dbh = $drh->connect($cstr, $user, $pass, { });
8759         $dbh || return &text('sql_emysqlconnect', $drh->errstr);
8760         return $dbh;
8761         }
8762 elsif ($proto eq "postgresql") {
8763         # Connect to PostgreSQL with DBI
8764         my $drh = eval "use DBI; DBI->install_driver('Pg');";
8765         $drh || return $text{'sql_epostgresqldriver'};
8766         my ($host, $port) = split(/:/, $host);
8767         my $cstr = "dbname=$prefix;host=$host";
8768         $cstr .= ";port=$port" if ($port);
8769         my $dbh = $drh->connect($cstr, $user, $pass);
8770         $dbh || return &text('sql_epostgresqlconnect', $drh->errstr);
8771         return $dbh;
8772         }
8773 elsif ($proto eq "ldap") {
8774         # XXX
8775         return "LDAP not done yet";
8776         }
8777 else {
8778         return "Unknown protocol $proto";
8779         }
8780 }
8781
8782 =head2 disconnect_userdb(string, &handle)
8783
8784 Closes a handle opened by connect_userdb
8785
8786 =cut
8787 sub disconnect_userdb
8788 {
8789 my ($str, $h) = @_;
8790 if ($str =~ /^(mysql|postgresql):/) {
8791         # DBI disconnnect
8792         $h->disconnect();
8793         }
8794 elsif ($str =~ /^ldap:/) {
8795         # LDAP disconnect
8796         $h->disconnect();
8797         }
8798 }
8799
8800 =head2 split_userdb_string(string)
8801
8802 Converts a string like mysql://user:pass@host/db into separate parts
8803
8804 =cut
8805 sub split_userdb_string
8806 {
8807 my ($str) = @_;
8808 if ($str =~ /^([a-z]+):\/\/([^:]*):([^\@]*)\@([a-z0-9\.\-\_]+)\/([^\?]+)(\?(.*))?$/) {
8809         my ($proto, $user, $pass, $host, $prefix, $argstr) =
8810                 ($1, $2, $3, $4, $5, $7);
8811         my %args = map { split(/=/, $_, 2) } split(/\&/, $argstr);
8812         return ($proto, $user, $pass, $host, $prefix, \%args);
8813         }
8814 return ( );
8815 }
8816
8817 $done_web_lib_funcs = 1;
8818
8819 1;