web-lib-funcs.pl

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