web-lib-funcs.pl

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