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