web-lib-funcs.pl

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