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