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