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
4441 # Replace references to other strings
4442 if (!$text{'__norefs'}) {
4443         foreach $k (keys %text) {
4444                 $text{$k} =~ s/\$(\{([^\}]+)\}|([A-Za-z0-9\.\-\_]+))/text_subs($2 || $3,\%text)/ge;
4445                 }
4446         }
4447
4448 if (defined(&theme_load_language)) {
4449         &theme_load_language(\%text, $_[0]);
4450         }
4451 return %text;
4452 }
4453
4454 =head2 text_subs(string)
4455
4456 Used internally by load_language to expand $code substitutions in language
4457 files.
4458
4459 =cut
4460 sub text_subs
4461 {
4462 if (substr($_[0], 0, 8) eq "include:") {
4463         local $_;
4464         my $rv;
4465         open(INCLUDE, substr($_[0], 8));
4466         while(<INCLUDE>) {
4467                 $rv .= $_;
4468                 }
4469         close(INCLUDE);
4470         return $rv;
4471         }
4472 else {
4473         my $t = $_[1]->{$_[0]};
4474         return defined($t) ? $t : '$'.$_[0];
4475         }
4476 }
4477
4478 =head2 text(message, [substitute]+)
4479
4480 Returns a translated message from %text, but with $1, $2, etc.. replaced with
4481 the substitute parameters. This makes it easy to use strings with placeholders
4482 that get replaced with programmatically generated text. For example :
4483
4484  print &text('index_hello', $remote_user),"<p>\n";
4485
4486 =cut
4487 sub text
4488 {
4489 my $t = &get_module_variable('%text', 1);
4490 my $rv = exists($t->{$_[0]}) ? $t->{$_[0]} : $text{$_[0]};
4491 for(my $i=1; $i<@_; $i++) {
4492         $rv =~ s/\$$i/$_[$i]/g;
4493         }
4494 return $rv;
4495 }
4496
4497 =head2 encode_base64(string)
4498
4499 Encodes a string into base64 format, for use in MIME email or HTTP
4500 authorization headers.
4501
4502 =cut
4503 sub encode_base64
4504 {
4505 my $res;
4506 pos($_[0]) = 0;                          # ensure start at the beginning
4507 while ($_[0] =~ /(.{1,57})/gs) {
4508         $res .= substr(pack('u57', $1), 1)."\n";
4509         chop($res);
4510         }
4511 $res =~ tr|\` -_|AA-Za-z0-9+/|;
4512 my $padding = (3 - length($_[0]) % 3) % 3;
4513 $res =~ s/.{$padding}$/'=' x $padding/e if ($padding);
4514 return $res;
4515 }
4516
4517 =head2 decode_base64(string)
4518
4519 Converts a base64-encoded string into plain text. The opposite of encode_base64.
4520
4521 =cut
4522 sub decode_base64
4523 {
4524 my ($str) = @_;
4525 my $res;
4526 $str =~ tr|A-Za-z0-9+=/||cd;            # remove non-base64 chars
4527 if (length($str) % 4) {
4528         return undef;
4529 }
4530 $str =~ s/=+$//;                        # remove padding
4531 $str =~ tr|A-Za-z0-9+/| -_|;            # convert to uuencoded format
4532 while ($str =~ /(.{1,60})/gs) {
4533         my $len = chr(32 + length($1)*3/4); # compute length byte
4534         $res .= unpack("u", $len . $1 );    # uudecode
4535         }
4536 return $res;
4537 }
4538
4539 =head2 get_module_info(module, [noclone], [forcache])
4540
4541 Returns a hash containg details of the given module. Some useful keys are :
4542
4543 =item dir - The module directory, like sendmail.
4544
4545 =item desc - Human-readable description, in the current users' language.
4546
4547 =item version - Optional module version number.
4548
4549 =item os_support - List of supported operating systems and versions.
4550
4551 =item category - Category on Webmin's left menu, like net.
4552
4553 =cut
4554 sub get_module_info
4555 {
4556 return () if ($_[0] =~ /^\./);
4557 my (%rv, $clone, $o);
4558 my $mdir = &module_root_directory($_[0]);
4559 &read_file_cached("$mdir/module.info", \%rv) || return ();
4560 if (-l $mdir) {
4561         # A clone is a module that links to another directory under the root
4562         foreach my $r (@root_directories) {
4563                 if (&is_under_directory($r, $mdir)) {
4564                         $clone = 1;
4565                         last;
4566                         }
4567                 }
4568         }
4569 foreach $o (@lang_order_list) {
4570         $rv{"desc"} = $rv{"desc_$o"} if ($rv{"desc_$o"});
4571         $rv{"longdesc"} = $rv{"longdesc_$o"} if ($rv{"longdesc_$o"});
4572         }
4573 if ($clone && !$_[1] && $config_directory) {
4574         $rv{'clone'} = $rv{'desc'};
4575         &read_file("$config_directory/$_[0]/clone", \%rv);
4576         }
4577 $rv{'dir'} = $_[0];
4578 my %module_categories;
4579 &read_file_cached("$config_directory/webmin.cats", \%module_categories);
4580 my $pn = &get_product_name();
4581 if (defined($rv{'category_'.$pn})) {
4582         # Can override category for webmin/usermin
4583         $rv{'category'} = $rv{'category_'.$pn};
4584         }
4585 $rv{'realcategory'} = $rv{'category'};
4586 $rv{'category'} = $module_categories{$_[0]}
4587         if (defined($module_categories{$_[0]}));
4588
4589 # Apply description overrides
4590 $rv{'realdesc'} = $rv{'desc'};
4591 my %descs;
4592 &read_file_cached("$config_directory/webmin.descs", \%descs);
4593 if ($descs{$_[0]." ".$current_lang}) {
4594         $rv{'desc'} = $descs{$_[0]." ".$current_lang};
4595         }
4596 elsif ($descs{$_[0]}) {
4597         $rv{'desc'} = $descs{$_[0]};
4598         }
4599
4600 if (!$_[2]) {
4601         # Apply per-user description overridde
4602         my %gaccess = &get_module_acl(undef, "");
4603         if ($gaccess{'desc_'.$_[0]}) {
4604                 $rv{'desc'} = $gaccess{'desc_'.$_[0]};
4605                 }
4606         }
4607
4608 if ($rv{'longdesc'}) {
4609         # All standard modules have an index.cgi
4610         $rv{'index_link'} = 'index.cgi';
4611         }
4612
4613 # Call theme-specific override function
4614 if (defined(&theme_get_module_info)) {
4615         %rv = &theme_get_module_info(\%rv, $_[0], $_[1], $_[2]);
4616         }
4617
4618 return %rv;
4619 }
4620
4621 =head2 get_all_module_infos(cachemode)
4622
4623 Returns a list contains the information on all modules in this webmin
4624 install, including clones. Uses caching to reduce the number of module.info
4625 files that need to be read. Each element of the array is a hash reference
4626 in the same format as returned by get_module_info. The cache mode flag can be :
4627 0 = read and write, 1 = don't read or write, 2 = read only
4628
4629 =cut
4630 sub get_all_module_infos
4631 {
4632 my (%cache, @rv);
4633
4634 # Is the cache out of date? (ie. have any of the root's changed?)
4635 my $cache_file = "$config_directory/module.infos.cache";
4636 my $changed = 0;
4637 if (&read_file_cached($cache_file, \%cache)) {
4638         foreach my $r (@root_directories) {
4639                 my @st = stat($r);
4640                 if ($st[9] != $cache{'mtime_'.$r}) {
4641                         $changed = 2;
4642                         last;
4643                         }
4644                 }
4645         }
4646 else {
4647         $changed = 1;
4648         }
4649
4650 if ($_[0] != 1 && !$changed && $cache{'lang'} eq $current_lang) {
4651         # Can use existing module.info cache
4652         my %mods;
4653         foreach my $k (keys %cache) {
4654                 if ($k =~ /^(\S+) (\S+)$/) {
4655                         $mods{$1}->{$2} = $cache{$k};
4656                         }
4657                 }
4658         @rv = map { $mods{$_} } (keys %mods) if (%mods);
4659         }
4660 else {
4661         # Need to rebuild cache
4662         %cache = ( );
4663         foreach my $r (@root_directories) {
4664                 opendir(DIR, $r);
4665                 foreach my $m (readdir(DIR)) {
4666                         next if ($m =~ /^(config-|\.)/ || $m =~ /\.(cgi|pl)$/);
4667                         my %minfo = &get_module_info($m, 0, 1);
4668                         next if (!%minfo || !$minfo{'dir'});
4669                         push(@rv, \%minfo);
4670                         foreach $k (keys %minfo) {
4671                                 $cache{"${m} ${k}"} = $minfo{$k};
4672                                 }
4673                         }
4674                 closedir(DIR);
4675                 my @st = stat($r);
4676                 $cache{'mtime_'.$r} = $st[9];
4677                 }
4678         $cache{'lang'} = $current_lang;
4679         &write_file($cache_file, \%cache) if (!$_[0] && $< == 0 && $> == 0);
4680         }
4681
4682 # Override descriptions for modules for current user
4683 my %gaccess = &get_module_acl(undef, "");
4684 foreach my $m (@rv) {
4685         if ($gaccess{"desc_".$m->{'dir'}}) {
4686                 $m->{'desc'} = $gaccess{"desc_".$m->{'dir'}};
4687                 }
4688         }
4689
4690 # Apply installed flags
4691 my %installed;
4692 &read_file_cached("$config_directory/installed.cache", \%installed);
4693 foreach my $m (@rv) {
4694         $m->{'installed'} = $installed{$m->{'dir'}};
4695         }
4696
4697 return @rv;
4698 }
4699
4700 =head2 get_theme_info(theme)
4701
4702 Returns a hash containing a theme's details, taken from it's theme.info file.
4703 Some useful keys are :
4704
4705 =item dir - The theme directory, like blue-theme.
4706
4707 =item desc - Human-readable description, in the current users' language.
4708
4709 =item version - Optional module version number.
4710
4711 =item os_support - List of supported operating systems and versions.
4712
4713 =cut
4714 sub get_theme_info
4715 {
4716 return () if ($_[0] =~ /^\./);
4717 my %rv;
4718 my $tdir = &module_root_directory($_[0]);
4719 &read_file("$tdir/theme.info", \%rv) || return ();
4720 foreach my $o (@lang_order_list) {
4721         $rv{"desc"} = $rv{"desc_$o"} if ($rv{"desc_$o"});
4722         }
4723 $rv{"dir"} = $_[0];
4724 return %rv;
4725 }
4726
4727 =head2 list_languages
4728
4729 Returns an array of supported languages, taken from Webmin's os_list.txt file.
4730 Each is a hash reference with the following keys :
4731
4732 =item lang - The short language code, like es for Spanish.
4733
4734 =item desc - A human-readable description, in English.
4735
4736 =item charset - An optional character set to use when displaying the language.
4737
4738 =item titles - Set to 1 only if Webmin has title images for the language.
4739
4740 =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.
4741
4742 =cut
4743 sub list_languages
4744 {
4745 if (!@main::list_languages_cache) {
4746         my $o;
4747         local $_;
4748         open(LANG, "$root_directory/lang_list.txt");
4749         while(<LANG>) {
4750                 if (/^(\S+)\s+(.*)/) {
4751                         my $l = { 'desc' => $2 };
4752                         foreach $o (split(/,/, $1)) {
4753                                 if ($o =~ /^([^=]+)=(.*)$/) {
4754                                         $l->{$1} = $2;
4755                                         }
4756                                 }
4757                         $l->{'index'} = scalar(@rv);
4758                         push(@main::list_languages_cache, $l);
4759                         }
4760                 }
4761         close(LANG);
4762         @main::list_languages_cache = sort { $a->{'desc'} cmp $b->{'desc'} }
4763                                      @main::list_languages_cache;
4764         }
4765 return @main::list_languages_cache;
4766 }
4767
4768 =head2 read_env_file(file, &hash)
4769
4770 Similar to Webmin's read_file function, but handles files containing shell
4771 environment variables formatted like :
4772
4773   export FOO=bar
4774   SMEG="spod"
4775
4776 The file parameter is the full path to the file to read, and hash a Perl hash
4777 ref to read names and values into.
4778
4779 =cut
4780 sub read_env_file
4781 {
4782 local $_;
4783 &open_readfile(FILE, $_[0]) || return 0;
4784 while(<FILE>) {
4785         s/#.*$//g;
4786         if (/^\s*(export\s*)?([A-Za-z0-9_\.]+)\s*=\s*"(.*)"/i ||
4787             /^\s*(export\s*)?([A-Za-z0-9_\.]+)\s*=\s*'(.*)'/i ||
4788             /^\s*(export\s*)?([A-Za-z0-9_\.]+)\s*=\s*(.*)/i) {
4789                 $_[1]->{$2} = $3;
4790                 }
4791         }
4792 close(FILE);
4793 return 1;
4794 }
4795
4796 =head2 write_env_file(file, &hash, [export])
4797
4798 Writes out a hash to a file in name='value' format, suitable for use in a shell
4799 script. The parameters are :
4800
4801 =item file - Full path for a file to write to
4802
4803 =item hash - Hash reference of names and values to write.
4804
4805 =item export - If set to 1, preceed each variable setting with the word 'export'.
4806
4807 =cut
4808 sub write_env_file
4809 {
4810 my $exp = $_[2] ? "export " : "";
4811 &open_tempfile(FILE, ">$_[0]");
4812 foreach my $k (keys %{$_[1]}) {
4813         my $v = $_[1]->{$k};
4814         if ($v =~ /^\S+$/) {
4815                 &print_tempfile(FILE, "$exp$k=$v\n");
4816                 }
4817         else {
4818                 &print_tempfile(FILE, "$exp$k=\"$v\"\n");
4819                 }
4820         }
4821 &close_tempfile(FILE);
4822 }
4823
4824 =head2 lock_file(filename, [readonly], [forcefile])
4825
4826 Lock a file for exclusive access. If the file is already locked, spin
4827 until it is freed. Uses a .lock file, which is not 100% reliable, but seems
4828 to work OK. The parameters are :
4829
4830 =item filename - File or directory to lock.
4831
4832 =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.
4833
4834 =item forcefile - Force the file to be considered as a real file and not a symlink for Webmin actions logging purposes.
4835
4836 =cut
4837 sub lock_file
4838 {
4839 my $realfile = &translate_filename($_[0]);
4840 return 0 if (!$_[0] || defined($main::locked_file_list{$realfile}));
4841 my $no_lock = !&can_lock_file($realfile);
4842 my $lock_tries_count = 0;
4843 while(1) {
4844         my $pid;
4845         if (!$no_lock && open(LOCKING, "$realfile.lock")) {
4846                 $pid = <LOCKING>;
4847                 $pid = int($pid);
4848                 close(LOCKING);
4849                 }
4850         if ($no_lock || !$pid || !kill(0, $pid) || $pid == $$) {
4851                 # Got the lock!
4852                 if (!$no_lock) {
4853                         # Create the .lock file
4854                         open(LOCKING, ">$realfile.lock") || return 0;
4855                         my $lck = eval "flock(LOCKING, 2+4)";
4856                         if (!$lck && !$@) {
4857                                 # Lock of lock file failed! Wait till later
4858                                 goto tryagain;
4859                                 }
4860                         print LOCKING $$,"\n";
4861                         eval "flock(LOCKING, 8)";
4862                         close(LOCKING);
4863                         }
4864                 $main::locked_file_list{$realfile} = int($_[1]);
4865                 push(@main::temporary_files, "$realfile.lock");
4866                 if (($gconfig{'logfiles'} || $gconfig{'logfullfiles'}) &&
4867                     !&get_module_variable('$no_log_file_changes') &&
4868                     !$_[1]) {
4869                         # Grab a copy of this file for later diffing
4870                         my $lnk;
4871                         $main::locked_file_data{$realfile} = undef;
4872                         if (-d $realfile) {
4873                                 $main::locked_file_type{$realfile} = 1;
4874                                 $main::locked_file_data{$realfile} = '';
4875                                 }
4876                         elsif (!$_[2] && ($lnk = readlink($realfile))) {
4877                                 $main::locked_file_type{$realfile} = 2;
4878                                 $main::locked_file_data{$realfile} = $lnk;
4879                                 }
4880                         elsif (open(ORIGFILE, $realfile)) {
4881                                 $main::locked_file_type{$realfile} = 0;
4882                                 $main::locked_file_data{$realfile} = '';
4883                                 local $_;
4884                                 while(<ORIGFILE>) {
4885                                         $main::locked_file_data{$realfile} .=$_;
4886                                         }
4887                                 close(ORIGFILE);
4888                                 }
4889                         }
4890                 last;
4891                 }
4892 tryagain:
4893         sleep(1);
4894         if ($lock_tries_count++ > 5*60) {
4895                 # Give up after 5 minutes
4896                 &error(&text('elock_tries', "<tt>$realfile</tt>", 5));
4897                 }
4898         }
4899 return 1;
4900 }
4901
4902 =head2 unlock_file(filename)
4903
4904 Release a lock on a file taken out by lock_file. If Webmin actions logging of
4905 file changes is enabled, then at unlock file a diff will be taken between the
4906 old and new contents, and stored under /var/webmin/diffs when webmin_log is
4907 called. This can then be viewed in the Webmin Actions Log module.
4908
4909 =cut
4910 sub unlock_file
4911 {
4912 my $realfile = &translate_filename($_[0]);
4913 return if (!$_[0] || !defined($main::locked_file_list{$realfile}));
4914 unlink("$realfile.lock") if (&can_lock_file($realfile));
4915 delete($main::locked_file_list{$realfile});
4916 if (exists($main::locked_file_data{$realfile})) {
4917         # Diff the new file with the old
4918         stat($realfile);
4919         my $lnk = readlink($realfile);
4920         my $type = -d _ ? 1 : $lnk ? 2 : 0;
4921         my $oldtype = $main::locked_file_type{$realfile};
4922         my $new = !defined($main::locked_file_data{$realfile});
4923         if ($new && !-e _) {
4924                 # file doesn't exist, and never did! do nothing ..
4925                 }
4926         elsif ($new && $type == 1 || !$new && $oldtype == 1) {
4927                 # is (or was) a directory ..
4928                 if (-d _ && !defined($main::locked_file_data{$realfile})) {
4929                         push(@main::locked_file_diff,
4930                              { 'type' => 'mkdir', 'object' => $realfile });
4931                         }
4932                 elsif (!-d _ && defined($main::locked_file_data{$realfile})) {
4933                         push(@main::locked_file_diff,
4934                              { 'type' => 'rmdir', 'object' => $realfile });
4935                         }
4936                 }
4937         elsif ($new && $type == 2 || !$new && $oldtype == 2) {
4938                 # is (or was) a symlink ..
4939                 if ($lnk && !defined($main::locked_file_data{$realfile})) {
4940                         push(@main::locked_file_diff,
4941                              { 'type' => 'symlink', 'object' => $realfile,
4942                                'data' => $lnk });
4943                         }
4944                 elsif (!$lnk && defined($main::locked_file_data{$realfile})) {
4945                         push(@main::locked_file_diff,
4946                              { 'type' => 'unsymlink', 'object' => $realfile,
4947                                'data' => $main::locked_file_data{$realfile} });
4948                         }
4949                 elsif ($lnk ne $main::locked_file_data{$realfile}) {
4950                         push(@main::locked_file_diff,
4951                              { 'type' => 'resymlink', 'object' => $realfile,
4952                                'data' => $lnk });
4953                         }
4954                 }
4955         else {
4956                 # is a file, or has changed type?!
4957                 my ($diff, $delete_file);
4958                 my $type = "modify";
4959                 if (!-r _) {
4960                         open(NEWFILE, ">$realfile");
4961                         close(NEWFILE);
4962                         $delete_file++;
4963                         $type = "delete";
4964                         }
4965                 if (!defined($main::locked_file_data{$realfile})) {
4966                         $type = "create";
4967                         }
4968                 open(ORIGFILE, ">$realfile.webminorig");
4969                 print ORIGFILE $main::locked_file_data{$realfile};
4970                 close(ORIGFILE);
4971                 $diff = &backquote_command(
4972                         "diff ".quotemeta("$realfile.webminorig")." ".
4973                                 quotemeta($realfile)." 2>/dev/null");
4974                 push(@main::locked_file_diff,
4975                      { 'type' => $type, 'object' => $realfile,
4976                        'data' => $diff } ) if ($diff);
4977                 unlink("$realfile.webminorig");
4978                 unlink($realfile) if ($delete_file);
4979                 }
4980
4981         if ($gconfig{'logfullfiles'}) {
4982                 # Add file details to list of those to fully log
4983                 $main::orig_file_data{$realfile} ||=
4984                         $main::locked_file_data{$realfile};
4985                 $main::orig_file_type{$realfile} ||=
4986                         $main::locked_file_type{$realfile};
4987                 }
4988
4989         delete($main::locked_file_data{$realfile});
4990         delete($main::locked_file_type{$realfile});
4991         }
4992 }
4993
4994 =head2 test_lock(file)
4995
4996 Returns 1 if some file is currently locked, 0 if not.
4997
4998 =cut
4999 sub test_lock
5000 {
5001 my $realfile = &translate_filename($_[0]);
5002 return 0 if (!$_[0]);
5003 return 1 if (defined($main::locked_file_list{$realfile}));
5004 return 0 if (!&can_lock_file($realfile));
5005 my $pid;
5006 if (open(LOCKING, "$realfile.lock")) {
5007         $pid = <LOCKING>;
5008         $pid = int($pid);
5009         close(LOCKING);
5010         }
5011 return $pid && kill(0, $pid);
5012 }
5013
5014 =head2 unlock_all_files
5015
5016 Unlocks all files locked by the current script.
5017
5018 =cut
5019 sub unlock_all_files
5020 {
5021 foreach $f (keys %main::locked_file_list) {
5022         &unlock_file($f);
5023         }
5024 }
5025
5026 =head2 can_lock_file(file)
5027
5028 Returns 1 if some file should be locked, based on the settings in the
5029 Webmin Configuration module. For internal use by lock_file only.
5030
5031 =cut
5032 sub can_lock_file
5033 {
5034 if (&is_readonly_mode()) {
5035         return 0;       # never lock in read-only mode
5036         }
5037 elsif ($gconfig{'lockmode'} == 0) {
5038         return 1;       # always
5039         }
5040 elsif ($gconfig{'lockmode'} == 1) {
5041         return 0;       # never
5042         }
5043 else {
5044         # Check if under any of the directories
5045         my $match;
5046         foreach my $d (split(/\t+/, $gconfig{'lockdirs'})) {
5047                 if (&same_file($d, $_[0]) ||
5048                     &is_under_directory($d, $_[0])) {
5049                         $match = 1;
5050                         }
5051                 }
5052         return $gconfig{'lockmode'} == 2 ? $match : !$match;
5053         }
5054 }
5055
5056 =head2 webmin_log(action, type, object, &params, [module], [host, script-on-host, client-ip])
5057
5058 Log some action taken by a user. This is typically called at the end of a
5059 script, once all file changes are complete and all commands run. The
5060 parameters are :
5061
5062 =item action - A short code for the action being performed, like 'create'.
5063
5064 =item type - A code for the type of object the action is performed to, like 'user'.
5065
5066 =item object - A short name for the object, like 'joe' if the Unix user 'joe' was just created.
5067
5068 =item params - A hash ref of additional information about the action.
5069
5070 =item module - Name of the module in which the action was performed, which defaults to the current module.
5071
5072 =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.
5073
5074 =item script-on-host - Script name like create_user.cgi on the host the action was performed on.
5075
5076 =item client-ip - IP address of the browser that performed the action.
5077
5078 =cut
5079 sub webmin_log
5080 {
5081 return if (!$gconfig{'log'} || &is_readonly_mode());
5082 my $m = $_[4] ? $_[4] : &get_module_name();
5083
5084 if ($gconfig{'logclear'}) {
5085         # check if it is time to clear the log
5086         my @st = stat("$webmin_logfile.time");
5087         my $write_logtime = 0;
5088         if (@st) {
5089                 if ($st[9]+$gconfig{'logtime'}*60*60 < time()) {
5090                         # clear logfile and all diff files
5091                         &unlink_file("$ENV{'WEBMIN_VAR'}/diffs");
5092                         &unlink_file("$ENV{'WEBMIN_VAR'}/files");
5093                         &unlink_file("$ENV{'WEBMIN_VAR'}/annotations");
5094                         unlink($webmin_logfile);
5095                         $write_logtime = 1;
5096                         }
5097                 }
5098         else {
5099                 $write_logtime = 1;
5100                 }
5101         if ($write_logtime) {
5102                 open(LOGTIME, ">$webmin_logfile.time");
5103                 print LOGTIME time(),"\n";
5104                 close(LOGTIME);
5105                 }
5106         }
5107
5108 # If an action script directory is defined, call the appropriate scripts
5109 if ($gconfig{'action_script_dir'}) {
5110     my ($action, $type, $object) = ($_[0], $_[1], $_[2]);
5111     my ($basedir) = $gconfig{'action_script_dir'};
5112
5113     for my $dir ($basedir/$type/$action, $basedir/$type, $basedir) {
5114         if (-d $dir) {
5115             my ($file);
5116             opendir(DIR, $dir) or die "Can't open $dir: $!";
5117             while (defined($file = readdir(DIR))) {
5118                 next if ($file =~ /^\.\.?$/); # skip '.' and '..'
5119                 if (-x "$dir/$file") {
5120                     # Call a script notifying it of the action
5121                     my %OLDENV = %ENV;
5122                     $ENV{'ACTION_MODULE'} = &get_module_name();
5123                     $ENV{'ACTION_ACTION'} = $_[0];
5124                     $ENV{'ACTION_TYPE'} = $_[1];
5125                     $ENV{'ACTION_OBJECT'} = $_[2];
5126                     $ENV{'ACTION_SCRIPT'} = $script_name;
5127                     foreach my $p (keys %param) {
5128                             $ENV{'ACTION_PARAM_'.uc($p)} = $param{$p};
5129                             }
5130                     system("$dir/$file", @_,
5131                            "<$null_file", ">$null_file", "2>&1");
5132                     %ENV = %OLDENV;
5133                     }
5134                 }
5135             }
5136         }
5137     }
5138
5139 # should logging be done at all?
5140 return if ($gconfig{'logusers'} && &indexof($base_remote_user,
5141            split(/\s+/, $gconfig{'logusers'})) < 0);
5142 return if ($gconfig{'logmodules'} && &indexof($m,
5143            split(/\s+/, $gconfig{'logmodules'})) < 0);
5144
5145 # log the action
5146 my $now = time();
5147 my @tm = localtime($now);
5148 my $script_name = $0 =~ /([^\/]+)$/ ? $1 : '-';
5149 my $id = sprintf "%d.%d.%d", $now, $$, $main::action_id_count;
5150 $main::action_id_count++;
5151 my $line = sprintf "%s [%2.2d/%s/%4.4d %2.2d:%2.2d:%2.2d] %s %s %s %s %s \"%s\" \"%s\" \"%s\"",
5152         $id, $tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900,
5153         $tm[2], $tm[1], $tm[0],
5154         $remote_user || '-',
5155         $main::session_id || '-',
5156         $_[7] || $ENV{'REMOTE_HOST'} || '-',
5157         $m, $_[5] ? "$_[5]:$_[6]" : $script_name,
5158         $_[0], $_[1] ne '' ? $_[1] : '-', $_[2] ne '' ? $_[2] : '-';
5159 my %param;
5160 foreach my $k (sort { $a cmp $b } keys %{$_[3]}) {
5161         my $v = $_[3]->{$k};
5162         my @pv;
5163         if ($v eq '') {
5164                 $line .= " $k=''";
5165                 @rv = ( "" );
5166                 }
5167         elsif (ref($v) eq 'ARRAY') {
5168                 foreach $vv (@$v) {
5169                         next if (ref($vv));
5170                         push(@pv, $vv);
5171                         $vv =~ s/(['"\\\r\n\t\%])/sprintf("%%%2.2X",ord($1))/ge;
5172                         $line .= " $k='$vv'";
5173                         }
5174                 }
5175         elsif (!ref($v)) {
5176                 foreach $vv (split(/\0/, $v)) {
5177                         push(@pv, $vv);
5178                         $vv =~ s/(['"\\\r\n\t\%])/sprintf("%%%2.2X",ord($1))/ge;
5179                         $line .= " $k='$vv'";
5180                         }
5181                 }
5182         $param{$k} = join(" ", @pv);
5183         }
5184 open(WEBMINLOG, ">>$webmin_logfile");
5185 print WEBMINLOG $line,"\n";
5186 close(WEBMINLOG);
5187 if ($gconfig{'logperms'}) {
5188         chmod(oct($gconfig{'logperms'}), $webmin_logfile);
5189         }
5190 else {
5191         chmod(0600, $webmin_logfile);
5192         }
5193
5194 if ($gconfig{'logfiles'} && !&get_module_variable('$no_log_file_changes')) {
5195         # Find and record the changes made to any locked files, or commands run
5196         my $i = 0;
5197         mkdir("$ENV{'WEBMIN_VAR'}/diffs", 0700);
5198         foreach my $d (@main::locked_file_diff) {
5199                 mkdir("$ENV{'WEBMIN_VAR'}/diffs/$id", 0700);
5200                 open(DIFFLOG, ">$ENV{'WEBMIN_VAR'}/diffs/$id/$i");
5201                 print DIFFLOG "$d->{'type'} $d->{'object'}\n";
5202                 print DIFFLOG $d->{'data'};
5203                 close(DIFFLOG);
5204                 if ($d->{'input'}) {
5205                         open(DIFFLOG, ">$ENV{'WEBMIN_VAR'}/diffs/$id/$i.input");
5206                         print DIFFLOG $d->{'input'};
5207                         close(DIFFLOG);
5208                         }
5209                 if ($gconfig{'logperms'}) {
5210                         chmod(oct($gconfig{'logperms'}),
5211                               "$ENV{'WEBMIN_VAR'}/diffs/$id/$i",
5212                               "$ENV{'WEBMIN_VAR'}/diffs/$id/$i.input");
5213                         }
5214                 $i++;
5215                 }
5216         @main::locked_file_diff = undef;
5217         }
5218
5219 if ($gconfig{'logfullfiles'}) {
5220         # Save the original contents of any modified files
5221         my $i = 0;
5222         mkdir("$ENV{'WEBMIN_VAR'}/files", 0700);
5223         foreach my $f (keys %main::orig_file_data) {
5224                 mkdir("$ENV{'WEBMIN_VAR'}/files/$id", 0700);
5225                 open(ORIGLOG, ">$ENV{'WEBMIN_VAR'}/files/$id/$i");
5226                 if (!defined($main::orig_file_type{$f})) {
5227                         print ORIGLOG -1," ",$f,"\n";
5228                         }
5229                 else {
5230                         print ORIGLOG $main::orig_file_type{$f}," ",$f,"\n";
5231                         }
5232                 print ORIGLOG $main::orig_file_data{$f};
5233                 close(ORIGLOG);
5234                 if ($gconfig{'logperms'}) {
5235                         chmod(oct($gconfig{'logperms'}),
5236                               "$ENV{'WEBMIN_VAR'}/files/$id.$i");
5237                         }
5238                 $i++;
5239                 }
5240         %main::orig_file_data = undef;
5241         %main::orig_file_type = undef;
5242         }
5243
5244 if ($miniserv::page_capture_out) {
5245         # Save the whole page output
5246         mkdir("$ENV{'WEBMIN_VAR'}/output", 0700);
5247         open(PAGEOUT, ">$ENV{'WEBMIN_VAR'}/output/$id");
5248         print PAGEOUT $miniserv::page_capture_out;
5249         close(PAGEOUT);
5250         if ($gconfig{'logperms'}) {
5251                 chmod(oct($gconfig{'logperms'}),
5252                       "$ENV{'WEBMIN_VAR'}/output/$id");
5253                 }
5254         $miniserv::page_capture_out = undef;
5255         }
5256
5257 # Log to syslog too
5258 if ($gconfig{'logsyslog'}) {
5259         eval 'use Sys::Syslog qw(:DEFAULT setlogsock);
5260               openlog(&get_product_name(), "cons,pid,ndelay", "daemon");
5261               setlogsock("inet");';
5262         if (!$@) {
5263                 # Syslog module is installed .. try to convert to a
5264                 # human-readable form
5265                 my $msg;
5266                 my $mod = &get_module_name();
5267                 my $mdir = module_root_directory($mod);
5268                 if (-r "$mdir/log_parser.pl") {
5269                         &foreign_require($mod, "log_parser.pl");
5270                         my %params;
5271                         foreach my $k (keys %{$_[3]}) {
5272                                 my $v = $_[3]->{$k};
5273                                 if (ref($v) eq 'ARRAY') {
5274                                         $params{$k} = join("\0", @$v);
5275                                         }
5276                                 else {
5277                                         $params{$k} = $v;
5278                                         }
5279                                 }
5280                         $msg = &foreign_call($mod, "parse_webmin_log",
5281                                 $remote_user, $script_name,
5282                                 $_[0], $_[1], $_[2], \%params);
5283                         $msg =~ s/<[^>]*>//g;   # Remove tags
5284                         }
5285                 elsif ($_[0] eq "_config_") {
5286                         my %wtext = &load_language("webminlog");
5287                         $msg = $wtext{'search_config'};
5288                         }
5289                 $msg ||= "$_[0] $_[1] $_[2]";
5290                 my %info = &get_module_info($m);
5291                 eval { syslog("info", "%s", "[$info{'desc'}] $msg"); };
5292                 }
5293         }
5294 }
5295
5296 =head2 additional_log(type, object, data, [input])
5297
5298 Records additional log data for an upcoming call to webmin_log, such
5299 as a command that was run or SQL that was executed. Typically you will never
5300 need to call this function directory.
5301
5302 =cut
5303 sub additional_log
5304 {
5305 if ($gconfig{'logfiles'} && !&get_module_variable('$no_log_file_changes')) {
5306         push(@main::locked_file_diff,
5307              { 'type' => $_[0], 'object' => $_[1], 'data' => $_[2],
5308                'input' => $_[3] } );
5309         }
5310 }
5311
5312 =head2 webmin_debug_log(type, message)
5313
5314 Write something to the Webmin debug log. For internal use only.
5315
5316 =cut
5317 sub webmin_debug_log
5318 {
5319 my ($type, $msg) = @_;
5320 return 0 if (!$main::opened_debug_log);
5321 return 0 if ($gconfig{'debug_no'.$main::webmin_script_type});
5322 if ($gconfig{'debug_modules'}) {
5323         my @dmods = split(/\s+/, $gconfig{'debug_modules'});
5324         return 0 if (&indexof($main::initial_module_name, @dmods) < 0);
5325         }
5326 my $now;
5327 eval 'use Time::HiRes qw(gettimeofday); ($now, $ms) = gettimeofday';
5328 $now ||= time();
5329 my @tm = localtime($now);
5330 my $line = sprintf
5331         "%s [%2.2d/%s/%4.4d %2.2d:%2.2d:%2.2d.%6.6d] %s %s %s %s \"%s\"",
5332         $$, $tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900,
5333         $tm[2], $tm[1], $tm[0], $ms,
5334         $remote_user || "-",
5335         $ENV{'REMOTE_HOST'} || "-",
5336         &get_module_name() || "-",
5337         $type,
5338         $msg;
5339 seek(main::DEBUGLOG, 0, 2);
5340 print main::DEBUGLOG $line."\n";
5341 return 1;
5342 }
5343
5344 =head2 system_logged(command)
5345
5346 Just calls the Perl system() function, but also logs the command run.
5347
5348 =cut
5349 sub system_logged
5350 {
5351 if (&is_readonly_mode()) {
5352         print STDERR "Vetoing command $_[0]\n";
5353         return 0;
5354         }
5355 my @realcmd = ( &translate_command($_[0]), @_[1..$#_] );
5356 my $cmd = join(" ", @realcmd);
5357 my $and;
5358 if ($cmd =~ s/(\s*&\s*)$//) {
5359         $and = $1;
5360         }
5361 while($cmd =~ s/(\d*)(<|>)((\/(tmp|dev)\S+)|&\d+)\s*$//) { }
5362 $cmd =~ s/^\((.*)\)\s*$/$1/;
5363 $cmd .= $and;
5364 &additional_log('exec', undef, $cmd);
5365 return system(@realcmd);
5366 }
5367
5368 =head2 backquote_logged(command)
5369
5370 Executes a command and returns the output (like `command`), but also logs it.
5371
5372 =cut
5373 sub backquote_logged
5374 {
5375 if (&is_readonly_mode()) {
5376         $? = 0;
5377         print STDERR "Vetoing command $_[0]\n";
5378         return undef;
5379         }
5380 my $realcmd = &translate_command($_[0]);
5381 my $cmd = $realcmd;
5382 my $and;
5383 if ($cmd =~ s/(\s*&\s*)$//) {
5384         $and = $1;
5385         }
5386 while($cmd =~ s/(\d*)(<|>)((\/(tmp\/.webmin|dev)\S+)|&\d+)\s*$//) { }
5387 $cmd =~ s/^\((.*)\)\s*$/$1/;
5388 $cmd .= $and;
5389 &additional_log('exec', undef, $cmd);
5390 &webmin_debug_log('CMD', "cmd=$cmd") if ($gconfig{'debug_what_cmd'});
5391 return `$realcmd`;
5392 }
5393
5394 =head2 backquote_with_timeout(command, timeout, safe?, [maxlines])
5395
5396 Runs some command, waiting at most the given number of seconds for it to
5397 complete, and returns the output. The maxlines parameter sets the number
5398 of lines of output to capture. The safe parameter should be set to 1 if the
5399 command is safe for read-only mode users to run.
5400
5401 =cut
5402 sub backquote_with_timeout
5403 {
5404 my $realcmd = &translate_command($_[0]);
5405 &webmin_debug_log('CMD', "cmd=$realcmd timeout=$_[1]")
5406         if ($gconfig{'debug_what_cmd'});
5407 my $out;
5408 my $pid = &open_execute_command(OUT, "($realcmd) <$null_file", 1, $_[2]);
5409 my $start = time();
5410 my $timed_out = 0;
5411 my $linecount = 0;
5412 while(1) {
5413         my $elapsed = time() - $start;
5414         last if ($elapsed > $_[1]);
5415         my $rmask;
5416         vec($rmask, fileno(OUT), 1) = 1;
5417         my $sel = select($rmask, undef, undef, $_[1] - $elapsed);
5418         last if (!$sel || $sel < 0);
5419         my $line = <OUT>;
5420         last if (!defined($line));
5421         $out .= $line;
5422         $linecount++;
5423         if ($_[3] && $linecount >= $_[3]) {
5424                 # Got enough lines
5425                 last;
5426                 }
5427         }
5428 if (kill('TERM', $pid) && time() - $start >= $_[1]) {
5429         $timed_out = 1;
5430         }
5431 close(OUT);
5432 return wantarray ? ($out, $timed_out) : $out;
5433 }
5434
5435 =head2 backquote_command(command, safe?)
5436
5437 Executes a command and returns the output (like `command`), subject to
5438 command translation. The safe parameter should be set to 1 if the command
5439 is safe for read-only mode users to run.
5440
5441 =cut
5442 sub backquote_command
5443 {
5444 if (&is_readonly_mode() && !$_[1]) {
5445         print STDERR "Vetoing command $_[0]\n";
5446         $? = 0;
5447         return undef;
5448         }
5449 my $realcmd = &translate_command($_[0]);
5450 &webmin_debug_log('CMD', "cmd=$realcmd") if ($gconfig{'debug_what_cmd'});
5451 return `$realcmd`;
5452 }
5453
5454 =head2 kill_logged(signal, pid, ...)
5455
5456 Like Perl's built-in kill function, but also logs the fact that some process
5457 was killed. On Windows, falls back to calling process.exe to terminate a
5458 process.
5459
5460 =cut
5461 sub kill_logged
5462 {
5463 return scalar(@_)-1 if (&is_readonly_mode());
5464 &webmin_debug_log('KILL', "signal=$_[0] pids=".join(" ", @_[1..@_-1]))
5465         if ($gconfig{'debug_what_procs'});
5466 &additional_log('kill', $_[0], join(" ", @_[1..@_-1])) if (@_ > 1);
5467 if ($gconfig{'os_type'} eq 'windows') {
5468         # Emulate some kills with process.exe
5469         my $arg = $_[0] eq "KILL" ? "-k" :
5470                   $_[0] eq "TERM" ? "-q" :
5471                   $_[0] eq "STOP" ? "-s" :
5472                   $_[0] eq "CONT" ? "-r" : undef;
5473         my $ok = 0;
5474         foreach my $p (@_[1..@_-1]) {
5475                 if ($p < 0) {
5476                         $ok ||= kill($_[0], $p);
5477                         }
5478                 elsif ($arg) {
5479                         &execute_command("process $arg $p");
5480                         $ok = 1;
5481                         }
5482                 }
5483         return $ok;
5484         }
5485 else {
5486         # Normal Unix kill
5487         return kill(@_);
5488         }
5489 }
5490
5491 =head2 rename_logged(old, new)
5492
5493 Re-names a file and logs the rename. If the old and new files are on different
5494 filesystems, calls mv or the Windows rename function to do the job.
5495
5496 =cut
5497 sub rename_logged
5498 {
5499 &additional_log('rename', $_[0], $_[1]) if ($_[0] ne $_[1]);
5500 return &rename_file($_[0], $_[1]);
5501 }
5502
5503 =head2 rename_file(old, new)
5504
5505 Renames a file or directory. If the old and new files are on different
5506 filesystems, calls mv or the Windows rename function to do the job.
5507
5508 =cut
5509 sub rename_file
5510 {
5511 if (&is_readonly_mode()) {
5512         print STDERR "Vetoing rename from $_[0] to $_[1]\n";
5513         return 1;
5514         }
5515 my $src = &translate_filename($_[0]);
5516 my $dst = &translate_filename($_[1]);
5517 &webmin_debug_log('RENAME', "src=$src dst=$dst")
5518         if ($gconfig{'debug_what_ops'});
5519 my $ok = rename($src, $dst);
5520 if (!$ok && $! !~ /permission/i) {
5521         # Try the mv command, in case this is a cross-filesystem rename
5522         if ($gconfig{'os_type'} eq 'windows') {
5523                 # Need to use rename
5524                 my $out = &backquote_command("rename ".quotemeta($_[0]).
5525                                              " ".quotemeta($_[1])." 2>&1");
5526                 $ok = !$?;
5527                 $! = $out if (!$ok);
5528                 }
5529         else {
5530                 # Can use mv
5531                 my $out = &backquote_command("mv ".quotemeta($_[0]).
5532                                              " ".quotemeta($_[1])." 2>&1");
5533                 $ok = !$?;
5534                 $! = $out if (!$ok);
5535                 }
5536         }
5537 return $ok;
5538 }
5539
5540 =head2 symlink_logged(src, dest)
5541
5542 Create a symlink, and logs it. Effectively does the same thing as the Perl
5543 symlink function.
5544
5545 =cut
5546 sub symlink_logged
5547 {
5548 &lock_file($_[1]);
5549 my $rv = &symlink_file($_[0], $_[1]);
5550 &unlock_file($_[1]);
5551 return $rv;
5552 }
5553
5554 =head2 symlink_file(src, dest)
5555
5556 Creates a soft link, unless in read-only mode. Effectively does the same thing
5557 as the Perl symlink function.
5558
5559 =cut
5560 sub symlink_file
5561 {
5562 if (&is_readonly_mode()) {
5563         print STDERR "Vetoing symlink from $_[0] to $_[1]\n";
5564         return 1;
5565         }
5566 my $src = &translate_filename($_[0]);
5567 my $dst = &translate_filename($_[1]);
5568 &webmin_debug_log('SYMLINK', "src=$src dst=$dst")
5569         if ($gconfig{'debug_what_ops'});
5570 return symlink($src, $dst);
5571 }
5572
5573 =head2 link_file(src, dest)
5574
5575 Creates a hard link, unless in read-only mode. The existing new link file
5576 will be deleted if necessary. Effectively the same as Perl's link function.
5577
5578 =cut
5579 sub link_file
5580 {
5581 if (&is_readonly_mode()) {
5582         print STDERR "Vetoing link from $_[0] to $_[1]\n";
5583         return 1;
5584         }
5585 my $src = &translate_filename($_[0]);
5586 my $dst = &translate_filename($_[1]);
5587 &webmin_debug_log('LINK', "src=$src dst=$dst")
5588         if ($gconfig{'debug_what_ops'});
5589 unlink($dst);                   # make sure link works
5590 return link($src, $dst);
5591 }
5592
5593 =head2 make_dir(dir, perms, recursive)
5594
5595 Creates a directory and sets permissions on it, unless in read-only mode.
5596 The perms parameter sets the octal permissions to apply, which unlike Perl's
5597 mkdir will really get set. The recursive flag can be set to 1 to have the
5598 function create parent directories too.
5599
5600 =cut
5601 sub make_dir
5602 {
5603 my ($dir, $perms, $recur) = @_;
5604 if (&is_readonly_mode()) {
5605         print STDERR "Vetoing directory $dir\n";
5606         return 1;
5607         }
5608 $dir = &translate_filename($dir);
5609 my $exists = -d $dir ? 1 : 0;
5610 return 1 if ($exists && $recur);        # already exists
5611 &webmin_debug_log('MKDIR', $dir) if ($gconfig{'debug_what_ops'});
5612 my $rv = mkdir($dir, $perms);
5613 if (!$rv && $recur) {
5614         # Failed .. try mkdir -p
5615         my $param = $gconfig{'os_type'} eq 'windows' ? "" : "-p";
5616         my $ex = &execute_command("mkdir $param ".&quote_path($dir));
5617         if ($ex) {
5618                 return 0;
5619                 }
5620         }
5621 if (!$exists) {
5622         chmod($perms, $dir);
5623         }
5624 return 1;
5625 }
5626
5627 =head2 set_ownership_permissions(user, group, perms, file, ...)
5628
5629 Sets the user, group owner and permissions on some files. The parameters are :
5630
5631 =item user - UID or username to change the file owner to. If undef, then the owner is not changed.
5632
5633 =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.
5634
5635 =item perms - Octal permissions set to set on the file. If undef, they are left alone.
5636
5637 =item file - One or more files or directories to modify.
5638
5639 =cut
5640 sub set_ownership_permissions
5641 {
5642 my ($user, $group, $perms, @files) = @_;
5643 if (&is_readonly_mode()) {
5644         print STDERR "Vetoing permission changes on ",join(" ", @files),"\n";
5645         return 1;
5646         }
5647 @files = map { &translate_filename($_) } @files;
5648 if ($gconfig{'debug_what_ops'}) {
5649         foreach my $f (@files) {
5650                 &webmin_debug_log('PERMS',
5651                         "file=$f user=$user group=$group perms=$perms");
5652                 }
5653         }
5654 my $rv = 1;
5655 if (defined($user)) {
5656         my $uid = $user !~ /^\d+$/ ? getpwnam($user) : $user;
5657         my $gid;
5658         if (defined($group)) {
5659                 $gid = $group !~ /^\d+$/ ? getgrnam($group) : $group;
5660                 }
5661         else {
5662                 my @uinfo = getpwuid($uid);
5663                 $gid = $uinfo[3];
5664                 }
5665         $rv = chown($uid, $gid, @files);
5666         }
5667 if ($rv && defined($perms)) {
5668         $rv = chmod($perms, @files);
5669         }
5670 return $rv;
5671 }
5672
5673 =head2 unlink_logged(file, ...)
5674
5675 Like Perl's unlink function, but locks the files beforehand and un-locks them
5676 after so that the deletion is logged by Webmin.
5677
5678 =cut
5679 sub unlink_logged
5680 {
5681 my %locked;
5682 foreach my $f (@_) {
5683         if (!&test_lock($f)) {
5684                 &lock_file($f);
5685                 $locked{$f} = 1;
5686                 }
5687         }
5688 my @rv = &unlink_file(@_);
5689 foreach my $f (@_) {
5690         if ($locked{$f}) {
5691                 &unlock_file($f);
5692                 }
5693         }
5694 return wantarray ? @rv : $rv[0];
5695 }
5696
5697 =head2 unlink_file(file, ...)
5698
5699 Deletes some files or directories. Like Perl's unlink function, but also
5700 recursively deletes directories with the rm command if needed.
5701
5702 =cut
5703 sub unlink_file
5704 {
5705 return 1 if (&is_readonly_mode());
5706 my $rv = 1;
5707 my $err;
5708 foreach my $f (@_) {
5709         &unflush_file_lines($f);
5710         my $realf = &translate_filename($f);
5711         &webmin_debug_log('UNLINK', $realf) if ($gconfig{'debug_what_ops'});
5712         if (-d $realf) {
5713                 if (!rmdir($realf)) {
5714                         my $out;
5715                         if ($gconfig{'os_type'} eq 'windows') {
5716                                 # Call del and rmdir commands
5717                                 my $qm = $realf;
5718                                 $qm =~ s/\//\\/g;
5719                                 my $out = `del /q "$qm" 2>&1`;
5720                                 if (!$?) {
5721                                         $out = `rmdir "$qm" 2>&1`;
5722                                         }
5723                                 }
5724                         else {
5725                                 # Use rm command
5726                                 my $qm = quotemeta($realf);
5727                                 $out = `rm -rf $qm 2>&1`;
5728                                 }
5729                         if ($?) {
5730                                 $rv = 0;
5731                                 $err = $out;
5732                                 }
5733                         }
5734                 }
5735         else {
5736                 if (!unlink($realf)) {
5737                         $rv = 0;
5738                         $err = $!;
5739                         }
5740                 }
5741         }
5742 return wantarray ? ($rv, $err) : $rv;
5743 }
5744
5745 =head2 copy_source_dest(source, dest)
5746
5747 Copy some file or directory to a new location. Returns 1 on success, or 0
5748 on failure - also sets $! on failure. If the source is a directory, uses
5749 piped tar commands to copy a whole directory structure including permissions
5750 and special files.
5751
5752 =cut
5753 sub copy_source_dest
5754 {
5755 return (1, undef) if (&is_readonly_mode());
5756 my ($src, $dst) = @_;
5757 my $ok = 1;
5758 my ($err, $out);
5759 &webmin_debug_log('COPY', "src=$src dst=$dst")
5760         if ($gconfig{'debug_what_ops'});
5761 if ($gconfig{'os_type'} eq 'windows') {
5762         # No tar or cp on windows, so need to use copy command
5763         $src =~ s/\//\\/g;
5764         $dst =~ s/\//\\/g;
5765         if (-d $src) {
5766                 $out = &backquote_logged("xcopy \"$src\" \"$dst\" /Y /E /I 2>&1");
5767                 }
5768         else {
5769                 $out = &backquote_logged("copy /Y \"$src\" \"$dst\" 2>&1");
5770                 }
5771         if ($?) {
5772                 $ok = 0;
5773                 $err = $out;
5774                 }
5775         }
5776 elsif (-d $src) {
5777         # A directory .. need to copy with tar command
5778         my @st = stat($src);
5779         unlink($dst);
5780         mkdir($dst, 0755);
5781         &set_ownership_permissions($st[4], $st[5], $st[2], $dst);
5782         $out = &backquote_logged("(cd ".quotemeta($src)." ; tar cf - . | (cd ".quotemeta($dst)." ; tar xf -)) 2>&1");
5783         if ($?) {
5784                 $ok = 0;
5785                 $err = $out;
5786                 }
5787         }
5788 else {
5789         # Can just copy with cp
5790         my $out = &backquote_logged("cp -p ".quotemeta($src).
5791                                     " ".quotemeta($dst)." 2>&1");
5792         if ($?) {
5793                 $ok = 0;
5794                 $err = $out;
5795                 }
5796         }
5797 return wantarray ? ($ok, $err) : $ok;
5798 }
5799
5800 =head2 remote_session_name(host|&server)
5801
5802 Generates a session ID for some server. For this server, this will always
5803 be an empty string. For a server object it will include the hostname and
5804 port and PID. For a server name, it will include the hostname and PID. For
5805 internal use only.
5806
5807 =cut
5808 sub remote_session_name
5809 {
5810 return ref($_[0]) && $_[0]->{'host'} && $_[0]->{'port'} ?
5811                 "$_[0]->{'host'}:$_[0]->{'port'}.$$" :
5812        $_[0] eq "" || ref($_[0]) && $_[0]->{'id'} == 0 ? "" :
5813        ref($_[0]) ? "" : "$_[0].$$";
5814 }
5815
5816 =head2 remote_foreign_require(server, module, file)
5817
5818 Connects to rpc.cgi on a remote webmin server and have it open a session
5819 to a process that will actually do the require and run functions. This is the
5820 equivalent for foreign_require, but for a remote Webmin system. The server
5821 parameter can either be a hostname of a system registered in the Webmin
5822 Servers Index module, or a hash reference for a system from that module.
5823
5824 =cut
5825 sub remote_foreign_require
5826 {
5827 my $call = { 'action' => 'require',
5828              'module' => $_[1],
5829              'file' => $_[2] };
5830 my $sn = &remote_session_name($_[0]);
5831 if ($remote_session{$sn}) {
5832         $call->{'session'} = $remote_session{$sn};
5833         }
5834 else {
5835         $call->{'newsession'} = 1;
5836         }
5837 my $rv = &remote_rpc_call($_[0], $call);
5838 if ($rv->{'session'}) {
5839         $remote_session{$sn} = $rv->{'session'};
5840         $remote_session_server{$sn} = $_[0];
5841         }
5842 }
5843
5844 =head2 remote_foreign_call(server, module, function, [arg]*)
5845
5846 Call a function on a remote server. Must have been setup first with
5847 remote_foreign_require for the same server and module. Equivalent to
5848 foreign_call, but with the extra server parameter to specify the remote
5849 system's hostname.
5850
5851 =cut
5852 sub remote_foreign_call
5853 {
5854 return undef if (&is_readonly_mode());
5855 my $sn = &remote_session_name($_[0]);
5856 return &remote_rpc_call($_[0], { 'action' => 'call',
5857                                  'module' => $_[1],
5858                                  'func' => $_[2],
5859                                  'session' => $remote_session{$sn},
5860                                  'args' => [ @_[3 .. $#_] ] } );
5861 }
5862
5863 =head2 remote_foreign_check(server, module, [api-only])
5864
5865 Checks if some module is installed and supported on a remote server. Equivilant
5866 to foreign_check, but for the remote Webmin system specified by the server
5867 parameter.
5868
5869 =cut
5870 sub remote_foreign_check
5871 {
5872 return &remote_rpc_call($_[0], { 'action' => 'check',
5873                                  'module' => $_[1],
5874                                  'api' => $_[2] });
5875 }
5876
5877 =head2 remote_foreign_config(server, module)
5878
5879 Gets the configuration for some module from a remote server, as a hash.
5880 Equivalent to foreign_config, but for a remote system.
5881
5882 =cut
5883 sub remote_foreign_config
5884 {
5885 return &remote_rpc_call($_[0], { 'action' => 'config',
5886                                  'module' => $_[1] });
5887 }
5888
5889 =head2 remote_eval(server, module, code)
5890
5891 Evaluates some perl code in the context of a module on a remote webmin server.
5892 The server parameter must be the hostname of a remote system, module must
5893 be a module directory name, and code a string of Perl code to run. This can
5894 only be called after remote_foreign_require for the same server and module.
5895
5896 =cut
5897 sub remote_eval
5898 {
5899 return undef if (&is_readonly_mode());
5900 my $sn = &remote_session_name($_[0]);
5901 return &remote_rpc_call($_[0], { 'action' => 'eval',
5902                                  'module' => $_[1],
5903                                  'code' => $_[2],
5904                                  'session' => $remote_session{$sn} });
5905 }
5906
5907 =head2 remote_write(server, localfile, [remotefile], [remotebasename])
5908
5909 Transfers some local file to another server via Webmin's RPC protocol, and
5910 returns the resulting remote filename. If the remotefile parameter is given,
5911 that is the destination filename which will be used. Otherwise a randomly
5912 selected temporary filename will be used, and returned by the function.
5913
5914 =cut
5915 sub remote_write
5916 {
5917 return undef if (&is_readonly_mode());
5918 my ($data, $got);
5919 my $sn = &remote_session_name($_[0]);
5920 if (!$_[0] || $remote_server_version{$sn} >= 0.966) {
5921         # Copy data over TCP connection
5922         my $rv = &remote_rpc_call($_[0], { 'action' => 'tcpwrite',
5923                                            'file' => $_[2],
5924                                            'name' => $_[3] } );
5925         my $error;
5926         my $serv = ref($_[0]) ? $_[0]->{'host'} : $_[0];
5927         &open_socket($serv || "localhost", $rv->[1], TWRITE, \$error);
5928         return &$main::remote_error_handler("Failed to transfer file : $error")
5929                 if ($error);
5930         open(FILE, $_[1]);
5931         while(read(FILE, $got, 1024) > 0) {
5932                 print TWRITE $got;
5933                 }
5934         close(FILE);
5935         shutdown(TWRITE, 1);
5936         $error = <TWRITE>;
5937         if ($error && $error !~ /^OK/) {
5938                 # Got back an error!
5939                 return &$main::remote_error_handler("Failed to transfer file : $error");
5940                 }
5941         close(TWRITE);
5942         return $rv->[0];
5943         }
5944 else {
5945         # Just pass file contents as parameters
5946         open(FILE, $_[1]);
5947         while(read(FILE, $got, 1024) > 0) {
5948                 $data .= $got;
5949                 }
5950         close(FILE);
5951         return &remote_rpc_call($_[0], { 'action' => 'write',
5952                                          'data' => $data,
5953                                          'file' => $_[2],
5954                                          'session' => $remote_session{$sn} });
5955         }
5956 }
5957
5958 =head2 remote_read(server, localfile, remotefile)
5959
5960 Transfers a file from a remote server to this system, using Webmin's RPC
5961 protocol. The server parameter must be the hostname of a system registered
5962 in the Webmin Servers Index module, localfile is the destination path on this
5963 system, and remotefile is the file to fetch from the remote server.
5964
5965 =cut
5966 sub remote_read
5967 {
5968 my $sn = &remote_session_name($_[0]);
5969 if (!$_[0] || $remote_server_version{$sn} >= 0.966) {
5970         # Copy data over TCP connection
5971         my $rv = &remote_rpc_call($_[0], { 'action' => 'tcpread',
5972                                            'file' => $_[2] } );
5973         if (!$rv->[0]) {
5974                 return &$main::remote_error_handler("Failed to transfer file : $rv->[1]");
5975                 }
5976         my $error;
5977         my $serv = ref($_[0]) ? $_[0]->{'host'} : $_[0];
5978         &open_socket($serv || "localhost", $rv->[1], TREAD, \$error);
5979         return &$main::remote_error_handler("Failed to transfer file : $error")
5980                 if ($error);
5981         my $got;
5982         open(FILE, ">$_[1]");
5983         while(read(TREAD, $got, 1024) > 0) {
5984                 print FILE $got;
5985                 }
5986         close(FILE);
5987         close(TREAD);
5988         }
5989 else {
5990         # Just get data as return value
5991         my $d = &remote_rpc_call($_[0], { 'action' => 'read',
5992                                           'file' => $_[2],
5993                                           'session' => $remote_session{$sn} });
5994         open(FILE, ">$_[1]");
5995         print FILE $d;
5996         close(FILE);
5997         }
5998 }
5999
6000 =head2 remote_finished
6001
6002 Close all remote sessions. This happens automatically after a while
6003 anyway, but this function should be called to clean things up faster.
6004
6005 =cut
6006 sub remote_finished
6007 {
6008 foreach my $sn (keys %remote_session) {
6009         my $server = $remote_session_server{$sn};
6010         &remote_rpc_call($server, { 'action' => 'quit',
6011                                     'session' => $remote_session{$sn} } );
6012         delete($remote_session{$sn});
6013         delete($remote_session_server{$sn});
6014         }
6015 foreach my $fh (keys %fast_fh_cache) {
6016         close($fh);
6017         delete($fast_fh_cache{$fh});
6018         }
6019 }
6020
6021 =head2 remote_error_setup(&function)
6022
6023 Sets a function to be called instead of &error when a remote RPC operation
6024 fails. Useful if you want to have more control over your remote operations.
6025
6026 =cut
6027 sub remote_error_setup
6028 {
6029 $main::remote_error_handler = $_[0] || \&error;
6030 }
6031
6032 =head2 remote_rpc_call(server, &structure)
6033
6034 Calls rpc.cgi on some server and passes it a perl structure (hash,array,etc)
6035 and then reads back a reply structure. This is mainly for internal use only,
6036 and is called by the other remote_* functions.
6037
6038 =cut
6039 sub remote_rpc_call
6040 {
6041 my $serv;
6042 my $sn = &remote_session_name($_[0]);   # Will be undef for local connection
6043 if (ref($_[0])) {
6044         # Server structure was given
6045         $serv = $_[0];
6046         $serv->{'user'} || $serv->{'id'} == 0 ||
6047                 return &$main::remote_error_handler(
6048                         "No Webmin login set for server");
6049         }
6050 elsif ($_[0]) {
6051         # lookup the server in the webmin servers module if needed
6052         if (!%main::remote_servers_cache) {
6053                 &foreign_require("servers", "servers-lib.pl");
6054                 foreach $s (&foreign_call("servers", "list_servers")) {
6055                         $main::remote_servers_cache{$s->{'host'}} = $s;
6056                         $main::remote_servers_cache{$s->{'host'}.":".$s->{'port'}} = $s;
6057                         }
6058                 }
6059         $serv = $main::remote_servers_cache{$_[0]};
6060         $serv || return &$main::remote_error_handler(
6061                                 "No Webmin Servers entry for $_[0]");
6062         $serv->{'user'} || return &$main::remote_error_handler(
6063                                 "No login set for server $_[0]");
6064         }
6065 my $ip = $serv->{'ip'} || $serv->{'host'};
6066
6067 # Work out the username and password
6068 my ($user, $pass);
6069 if ($serv->{'sameuser'}) {
6070         $user = $remote_user;
6071         defined($main::remote_pass) || return &$main::remote_error_handler(
6072                                    "Password for this server is not available");
6073         $pass = $main::remote_pass;
6074         }
6075 else {
6076         $user = $serv->{'user'};
6077         $pass = $serv->{'pass'};
6078         }
6079
6080 if ($serv->{'fast'} || !$sn) {
6081         # Make TCP connection call to fastrpc.cgi
6082         if (!$fast_fh_cache{$sn} && $sn) {
6083                 # Need to open the connection
6084                 my $con = &make_http_connection(
6085                         $ip, $serv->{'port'}, $serv->{'ssl'},
6086                         "POST", "/fastrpc.cgi");
6087                 return &$main::remote_error_handler(
6088                     "Failed to connect to $serv->{'host'} : $con")
6089                         if (!ref($con));
6090                 &write_http_connection($con, "Host: $serv->{'host'}\r\n");
6091                 &write_http_connection($con, "User-agent: Webmin\r\n");
6092                 my $auth = &encode_base64("$user:$pass");
6093                 $auth =~ tr/\n//d;
6094                 &write_http_connection($con, "Authorization: basic $auth\r\n");
6095                 &write_http_connection($con, "Content-length: ",
6096                                              length($tostr),"\r\n");
6097                 &write_http_connection($con, "\r\n");
6098                 &write_http_connection($con, $tostr);
6099
6100                 # read back the response
6101                 my $line = &read_http_connection($con);
6102                 $line =~ tr/\r\n//d;
6103                 if ($line =~ /^HTTP\/1\..\s+401\s+/) {
6104                         return &$main::remote_error_handler("Login to RPC server as $user rejected");
6105                         }
6106                 $line =~ /^HTTP\/1\..\s+200\s+/ ||
6107                         return &$main::remote_error_handler("HTTP error : $line");
6108                 do {
6109                         $line = &read_http_connection($con);
6110                         $line =~ tr/\r\n//d;
6111                         } while($line);
6112                 $line = &read_http_connection($con);
6113                 if ($line =~ /^0\s+(.*)/) {
6114                         return &$main::remote_error_handler("RPC error : $1");
6115                         }
6116                 elsif ($line =~ /^1\s+(\S+)\s+(\S+)\s+(\S+)/ ||
6117                        $line =~ /^1\s+(\S+)\s+(\S+)/) {
6118                         # Started ok .. connect and save SID
6119                         &close_http_connection($con);
6120                         my ($port, $sid, $version, $error) = ($1, $2, $3);
6121                         &open_socket($ip, $port, $sid, \$error);
6122                         return &$main::remote_error_handler("Failed to connect to fastrpc.cgi : $error")
6123                                 if ($error);
6124                         $fast_fh_cache{$sn} = $sid;
6125                         $remote_server_version{$sn} = $version;
6126                         }
6127                 else {
6128                         while($stuff = &read_http_connection($con)) {
6129                                 $line .= $stuff;
6130                                 }
6131                         return &$main::remote_error_handler("Bad response from fastrpc.cgi : $line");
6132                         }
6133                 }
6134         elsif (!$fast_fh_cache{$sn}) {
6135                 # Open the connection by running fastrpc.cgi locally
6136                 pipe(RPCOUTr, RPCOUTw);
6137                 if (!fork()) {
6138                         untie(*STDIN);
6139                         untie(*STDOUT);
6140                         open(STDOUT, ">&RPCOUTw");
6141                         close(STDIN);
6142                         close(RPCOUTr);
6143                         $| = 1;
6144                         $ENV{'REQUEST_METHOD'} = 'GET';
6145                         $ENV{'SCRIPT_NAME'} = '/fastrpc.cgi';
6146                         $ENV{'SERVER_ROOT'} ||= $root_directory;
6147                         my %acl;
6148                         if ($base_remote_user ne 'root' &&
6149                             $base_remote_user ne 'admin') {
6150                                 # Need to fake up a login for the CGI!
6151                                 &read_acl(undef, \%acl, [ 'root' ]);
6152                                 $ENV{'BASE_REMOTE_USER'} =
6153                                         $ENV{'REMOTE_USER'} =
6154                                                 $acl{'root'} ? 'root' : 'admin';
6155                                 }
6156                         delete($ENV{'FOREIGN_MODULE_NAME'});
6157                         delete($ENV{'FOREIGN_ROOT_DIRECTORY'});
6158                         chdir($root_directory);
6159                         if (!exec("$root_directory/fastrpc.cgi")) {
6160                                 print "exec failed : $!\n";
6161                                 exit 1;
6162                                 }
6163                         }
6164                 close(RPCOUTw);
6165                 my $line;
6166                 do {
6167                         ($line = <RPCOUTr>) =~ tr/\r\n//d;
6168                         } while($line);
6169                 $line = <RPCOUTr>;
6170                 #close(RPCOUTr);
6171                 if ($line =~ /^0\s+(.*)/) {
6172                         return &$main::remote_error_handler("RPC error : $2");
6173                         }
6174                 elsif ($line =~ /^1\s+(\S+)\s+(\S+)/) {
6175                         # Started ok .. connect and save SID
6176                         close(SOCK);
6177                         my ($port, $sid, $error) = ($1, $2, undef);
6178                         &open_socket("localhost", $port, $sid, \$error);
6179                         return &$main::remote_error_handler("Failed to connect to fastrpc.cgi : $error") if ($error);
6180                         $fast_fh_cache{$sn} = $sid;
6181                         }
6182                 else {
6183                         local $_;
6184                         while(<RPCOUTr>) {
6185                                 $line .= $_;
6186                                 }
6187                         &error("Bad response from fastrpc.cgi : $line");
6188                         }
6189                 }
6190         # Got a connection .. send off the request
6191         my $fh = $fast_fh_cache{$sn};
6192         my $tostr = &serialise_variable($_[1]);
6193         print $fh length($tostr)," $fh\n";
6194         print $fh $tostr;
6195         my $rlen = int(<$fh>);
6196         my ($fromstr, $got);
6197         while(length($fromstr) < $rlen) {
6198                 return &$main::remote_error_handler("Failed to read from fastrpc.cgi")
6199                         if (read($fh, $got, $rlen - length($fromstr)) <= 0);
6200                 $fromstr .= $got;
6201                 }
6202         my $from = &unserialise_variable($fromstr);
6203         if (!$from) {
6204                 # No response at all
6205                 return &$main::remote_error_handler("Remote Webmin error");
6206                 }
6207         elsif (ref($from) ne 'HASH') {
6208                 # Not a hash?!
6209                 return &$main::remote_error_handler(
6210                         "Invalid remote Webmin response : $from");
6211                 }
6212         elsif (!$from->{'status'}) {
6213                 # Call failed
6214                 $from->{'rv'} =~ s/\s+at\s+(\S+)\s+line\s+(\d+)(,\s+<\S+>\s+line\s+(\d+))?//;
6215                 return &$main::remote_error_handler($from->{'rv'});
6216                 }
6217         if (defined($from->{'arv'})) {
6218                 return @{$from->{'arv'}};
6219                 }
6220         else {
6221                 return $from->{'rv'};
6222                 }
6223         }
6224 else {
6225         # Call rpc.cgi on remote server
6226         my $tostr = &serialise_variable($_[1]);
6227         my $error = 0;
6228         my $con = &make_http_connection($ip, $serv->{'port'},
6229                                         $serv->{'ssl'}, "POST", "/rpc.cgi");
6230         return &$main::remote_error_handler("Failed to connect to $serv->{'host'} : $con") if (!ref($con));
6231
6232         &write_http_connection($con, "Host: $serv->{'host'}\r\n");
6233         &write_http_connection($con, "User-agent: Webmin\r\n");
6234         my $auth = &encode_base64("$user:$pass");
6235         $auth =~ tr/\n//d;
6236         &write_http_connection($con, "Authorization: basic $auth\r\n");
6237         &write_http_connection($con, "Content-length: ",length($tostr),"\r\n");
6238         &write_http_connection($con, "\r\n");
6239         &write_http_connection($con, $tostr);
6240
6241         # read back the response
6242         my $line = &read_http_connection($con);
6243         $line =~ tr/\r\n//d;
6244         if ($line =~ /^HTTP\/1\..\s+401\s+/) {
6245                 return &$main::remote_error_handler("Login to RPC server as $user rejected");
6246                 }
6247         $line =~ /^HTTP\/1\..\s+200\s+/ || return &$main::remote_error_handler("RPC HTTP error : $line");
6248         do {
6249                 $line = &read_http_connection($con);
6250                 $line =~ tr/\r\n//d;
6251                 } while($line);
6252         my $fromstr;
6253         while($line = &read_http_connection($con)) {
6254                 $fromstr .= $line;
6255                 }
6256         close(SOCK);
6257         my $from = &unserialise_variable($fromstr);
6258         return &$main::remote_error_handler("Invalid RPC login to $serv->{'host'}") if (!$from->{'status'});
6259         if (defined($from->{'arv'})) {
6260                 return @{$from->{'arv'}};
6261                 }
6262         else {
6263                 return $from->{'rv'};
6264                 }
6265         }
6266 }
6267
6268 =head2 remote_multi_callback(&servers, parallel, &function, arg|&args, &returns, &errors, [module, library])
6269
6270 Executes some function in parallel on multiple servers at once. Fills in
6271 the returns and errors arrays respectively. If the module and library
6272 parameters are given, that module is remotely required on the server first,
6273 to check if it is connectable. The parameters are :
6274
6275 =item servers - A list of Webmin system hash references.
6276
6277 =item parallel - Number of parallel operations to perform.
6278
6279 =item function - Reference to function to call for each system.
6280
6281 =item args - Additional parameters to the function.
6282
6283 =item returns - Array ref to place return values into, in same order as servers.
6284
6285 =item errors - Array ref to place error messages into.
6286
6287 =item module - Optional module to require on the remote system first.
6288
6289 =item library - Optional library to require in the module.
6290
6291 =cut
6292 sub remote_multi_callback
6293 {
6294 my ($servs, $parallel, $func, $args, $rets, $errs, $mod, $lib) = @_;
6295 &remote_error_setup(\&remote_multi_callback_error);
6296
6297 # Call the functions
6298 my $p = 0;
6299 foreach my $g (@$servs) {
6300         my $rh = "READ$p";
6301         my $wh = "WRITE$p";
6302         pipe($rh, $wh);
6303         if (!fork()) {
6304                 close($rh);
6305                 $remote_multi_callback_err = undef;
6306                 if ($mod) {
6307                         # Require the remote lib
6308                         &remote_foreign_require($g->{'host'}, $mod, $lib);
6309                         if ($remote_multi_callback_err) {
6310                                 # Failed .. return error
6311                                 print $wh &serialise_variable(
6312                                         [ undef, $remote_multi_callback_err ]);
6313                                 exit(0);
6314                                 }
6315                         }
6316
6317                 # Call the function
6318                 my $a = ref($args) ? $args->[$p] : $args;
6319                 my $rv = &$func($g, $a);
6320
6321                 # Return the result
6322                 print $wh &serialise_variable(
6323                         [ $rv, $remote_multi_callback_err ]);
6324                 close($wh);
6325                 exit(0);
6326                 }
6327         close($wh);
6328         $p++;
6329         }
6330
6331 # Read back the results
6332 $p = 0;
6333 foreach my $g (@$servs) {
6334         my $rh = "READ$p";
6335         my $line = <$rh>;
6336         if (!$line) {
6337                 $errs->[$p] = "Failed to read response from $g->{'host'}";
6338                 }
6339         else {
6340                 my $rv = &unserialise_variable($line);
6341                 close($rh);
6342                 $rets->[$p] = $rv->[0];
6343                 $errs->[$p] = $rv->[1];
6344                 }
6345         $p++;
6346         }
6347
6348 &remote_error_setup(undef);
6349 }
6350
6351 sub remote_multi_callback_error
6352 {
6353 $remote_multi_callback_err = $_[0];
6354 }
6355
6356 =head2 serialise_variable(variable)
6357
6358 Converts some variable (maybe a scalar, hash ref, array ref or scalar ref)
6359 into a url-encoded string. In the cases of arrays and hashes, it is recursively
6360 called on each member to serialize the entire object.
6361
6362 =cut
6363 sub serialise_variable
6364 {
6365 if (!defined($_[0])) {
6366         return 'UNDEF';
6367         }
6368 my $r = ref($_[0]);
6369 my $rv;
6370 if (!$r) {
6371         $rv = &urlize($_[0]);
6372         }
6373 elsif ($r eq 'SCALAR') {
6374         $rv = &urlize(${$_[0]});
6375         }
6376 elsif ($r eq 'ARRAY') {
6377         $rv = join(",", map { &urlize(&serialise_variable($_)) } @{$_[0]});
6378         }
6379 elsif ($r eq 'HASH') {
6380         $rv = join(",", map { &urlize(&serialise_variable($_)).",".
6381                               &urlize(&serialise_variable($_[0]->{$_})) }
6382                             keys %{$_[0]});
6383         }
6384 elsif ($r eq 'REF') {
6385         $rv = &serialise_variable(${$_[0]});
6386         }
6387 elsif ($r eq 'CODE') {
6388         # Code not handled
6389         $rv = undef;
6390         }
6391 elsif ($r) {
6392         # An object - treat as a hash
6393         $r = "OBJECT ".&urlize($r);
6394         $rv = join(",", map { &urlize(&serialise_variable($_)).",".
6395                               &urlize(&serialise_variable($_[0]->{$_})) }
6396                             keys %{$_[0]});
6397         }
6398 return ($r ? $r : 'VAL').",".$rv;
6399 }
6400
6401 =head2 unserialise_variable(string)
6402
6403 Converts a string created by serialise_variable() back into the original
6404 scalar, hash ref, array ref or scalar ref. If the original variable was a Perl
6405 object, the same class is used on this system, if available.
6406
6407 =cut
6408 sub unserialise_variable
6409 {
6410 my @v = split(/,/, $_[0]);
6411 my $rv;
6412 if ($v[0] eq 'VAL') {
6413         @v = split(/,/, $_[0], -1);
6414         $rv = &un_urlize($v[1]);
6415         }
6416 elsif ($v[0] eq 'SCALAR') {
6417         local $r = &un_urlize($v[1]);
6418         $rv = \$r;
6419         }
6420 elsif ($v[0] eq 'ARRAY') {
6421         $rv = [ ];
6422         for(my $i=1; $i<@v; $i++) {
6423                 push(@$rv, &unserialise_variable(&un_urlize($v[$i])));
6424                 }
6425         }
6426 elsif ($v[0] eq 'HASH') {
6427         $rv = { };
6428         for(my $i=1; $i<@v; $i+=2) {
6429                 $rv->{&unserialise_variable(&un_urlize($v[$i]))} =
6430                         &unserialise_variable(&un_urlize($v[$i+1]));
6431                 }
6432         }
6433 elsif ($v[0] eq 'REF') {
6434         local $r = &unserialise_variable($v[1]);
6435         $rv = \$r;
6436         }
6437 elsif ($v[0] eq 'UNDEF') {
6438         $rv = undef;
6439         }
6440 elsif ($v[0] =~ /^OBJECT\s+(.*)$/) {
6441         # An object hash that we have to re-bless
6442         my $cls = $1;
6443         $rv = { };
6444         for(my $i=1; $i<@v; $i+=2) {
6445                 $rv->{&unserialise_variable(&un_urlize($v[$i]))} =
6446                         &unserialise_variable(&un_urlize($v[$i+1]));
6447                 }
6448         eval "use $cls";
6449         bless $rv, $cls;
6450         }
6451 return $rv;
6452 }
6453
6454 =head2 other_groups(user)
6455
6456 Returns a list of secondary groups a user is a member of, as a list of
6457 group names.
6458
6459 =cut
6460 sub other_groups
6461 {
6462 my ($user) = @_;
6463 my @rv;
6464 setgrent();
6465 while(my @g = getgrent()) {
6466         my @m = split(/\s+/, $g[3]);
6467         push(@rv, $g[2]) if (&indexof($user, @m) >= 0);
6468         }
6469 endgrent() if ($gconfig{'os_type'} ne 'hpux');
6470 return @rv;
6471 }
6472
6473 =head2 date_chooser_button(dayfield, monthfield, yearfield)
6474
6475 Returns HTML for a button that pops up a data chooser window. The parameters
6476 are :
6477
6478 =item dayfield - Name of the text field to place the day of the month into.
6479
6480 =item monthfield - Name of the select field to select the month of the year in, indexed from 1.
6481
6482 =item yearfield - Name of the text field to place the year into.
6483
6484 =cut
6485 sub date_chooser_button
6486 {
6487 return &theme_date_chooser_button(@_)
6488         if (defined(&theme_date_chooser_button));
6489 my ($w, $h) = (250, 225);
6490 if ($gconfig{'db_sizedate'}) {
6491         ($w, $h) = split(/x/, $gconfig{'db_sizedate'});
6492         }
6493 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";
6494 }
6495
6496 =head2 help_file(module, file)
6497
6498 Returns the path to a module's help file of some name, typically under the
6499 help directory with a .html extension.
6500
6501 =cut
6502 sub help_file
6503 {
6504 my $mdir = &module_root_directory($_[0]);
6505 my $dir = "$mdir/help";
6506 foreach my $o (@lang_order_list) {
6507         my $lang = "$dir/$_[1].$o.html";
6508         return $lang if (-r $lang);
6509         }
6510 return "$dir/$_[1].html";
6511 }
6512
6513 =head2 seed_random
6514
6515 Seeds the random number generator, if not already done in this script. On Linux
6516 this makes use of the current time, process ID and a read from /dev/urandom.
6517 On other systems, only the current time and process ID are used.
6518
6519 =cut
6520 sub seed_random
6521 {
6522 if (!$main::done_seed_random) {
6523         if (open(RANDOM, "/dev/urandom")) {
6524                 my $buf;
6525                 read(RANDOM, $buf, 4);
6526                 close(RANDOM);
6527                 srand(time() ^ $$ ^ $buf);
6528                 }
6529         else {
6530                 srand(time() ^ $$);
6531                 }
6532         $main::done_seed_random = 1;
6533         }
6534 }
6535
6536 =head2 disk_usage_kb(directory)
6537
6538 Returns the number of kB used by some directory and all subdirs. Implemented
6539 by calling the C<du -k> command.
6540
6541 =cut
6542 sub disk_usage_kb
6543 {
6544 my $dir = &translate_filename($_[0]);
6545 my $out;
6546 my $ex = &execute_command("du -sk ".quotemeta($dir), undef, \$out, undef, 0, 1);
6547 if ($ex) {
6548         &execute_command("du -s ".quotemeta($dir), undef, \$out, undef, 0, 1);
6549         }
6550 return $out =~ /^([0-9]+)/ ? $1 : "???";
6551 }
6552
6553 =head2 recursive_disk_usage(directory, [skip-regexp], [only-regexp])
6554
6555 Returns the number of bytes taken up by all files in some directory and all
6556 sub-directories, by summing up their lengths. The disk_usage_kb is more
6557 reflective of reality, as the filesystem typically pads file sizes to 1k or
6558 4k blocks.
6559
6560 =cut
6561 sub recursive_disk_usage
6562 {
6563 my $dir = &translate_filename($_[0]);
6564 my $skip = $_[1];
6565 my $only = $_[2];
6566 if (-l $dir) {
6567         return 0;
6568         }
6569 elsif (!-d $dir) {
6570         my @st = stat($dir);
6571         return $st[7];
6572         }
6573 else {
6574         my $rv = 0;
6575         opendir(DIR, $dir);
6576         my @files = readdir(DIR);
6577         closedir(DIR);
6578         foreach my $f (@files) {
6579                 next if ($f eq "." || $f eq "..");
6580                 next if ($skip && $f =~ /$skip/);
6581                 next if ($only && $f !~ /$only/);
6582                 $rv += &recursive_disk_usage("$dir/$f", $skip, $only);
6583                 }
6584         return $rv;
6585         }
6586 }
6587
6588 =head2 help_search_link(term, [ section, ... ] )
6589
6590 Returns HTML for a link to the man module for searching local and online
6591 docs for various search terms. The term parameter can either be a single
6592 word like 'bind', or a space-separated list of words. This function is typically
6593 used by modules that want to refer users to additional documentation in man
6594 pages or local system doc files.
6595
6596 =cut
6597 sub help_search_link
6598 {
6599 if (&foreign_available("man") && !$tconfig{'nosearch'}) {
6600         my $for = &urlize(shift(@_));
6601         return "<a href='$gconfig{'webprefix'}/man/search.cgi?".
6602                join("&", map { "section=$_" } @_)."&".
6603                "for=$for&exact=1&check=".&get_module_name()."'>".
6604                $text{'helpsearch'}."</a>\n";
6605         }
6606 else {
6607         return "";
6608         }
6609 }
6610
6611 =head2 make_http_connection(host, port, ssl, method, page, [&headers])
6612
6613 Opens a connection to some HTTP server, maybe through a proxy, and returns
6614 a handle object. The handle can then be used to send additional headers
6615 and read back a response. If anything goes wrong, returns an error string.
6616 The parameters are :
6617
6618 =item host - Hostname or IP address of the webserver to connect to.
6619
6620 =item port - HTTP port number to connect to.
6621
6622 =item ssl - Set to 1 to connect in SSL mode.
6623
6624 =item method - HTTP method, like GET or POST.
6625
6626 =item page - Page to request on the webserver, like /foo/index.html
6627
6628 =item headers - Array ref of additional HTTP headers, each of which is a 2-element array ref.
6629
6630 =cut
6631 sub make_http_connection
6632 {
6633 my ($host, $port, $ssl, $method, $page, $headers) = @_;
6634 my $htxt;
6635 if ($headers) {
6636         foreach my $h (@$headers) {
6637                 $htxt .= $h->[0].": ".$h->[1]."\r\n";
6638                 }
6639         $htxt .= "\r\n";
6640         }
6641 if (&is_readonly_mode()) {
6642         return "HTTP connections not allowed in readonly mode";
6643         }
6644 my $rv = { 'fh' => time().$$ };
6645 if ($ssl) {
6646         # Connect using SSL
6647         eval "use Net::SSLeay";
6648         $@ && return $text{'link_essl'};
6649         eval "Net::SSLeay::SSLeay_add_ssl_algorithms()";
6650         eval "Net::SSLeay::load_error_strings()";
6651         $rv->{'ssl_ctx'} = Net::SSLeay::CTX_new() ||
6652                 return "Failed to create SSL context";
6653         $rv->{'ssl_con'} = Net::SSLeay::new($rv->{'ssl_ctx'}) ||
6654                 return "Failed to create SSL connection";
6655         my $connected;
6656         if ($gconfig{'http_proxy'} =~ /^http:\/\/(\S+):(\d+)/ &&
6657             !&no_proxy($host)) {
6658                 # Via proxy
6659                 my $error;
6660                 &open_socket($1, $2, $rv->{'fh'}, \$error);
6661                 if (!$error) {
6662                         # Connected OK
6663                         my $fh = $rv->{'fh'};
6664                         print $fh "CONNECT $host:$port HTTP/1.0\r\n";
6665                         if ($gconfig{'proxy_user'}) {
6666                                 my $auth = &encode_base64(
6667                                    "$gconfig{'proxy_user'}:".
6668                                    "$gconfig{'proxy_pass'}");
6669                                 $auth =~ tr/\r\n//d;
6670                                 print $fh "Proxy-Authorization: Basic $auth\r\n";
6671                                 }
6672                         print $fh "\r\n";
6673                         my $line = <$fh>;
6674                         if ($line =~ /^HTTP(\S+)\s+(\d+)\s+(.*)/) {
6675                                 return "Proxy error : $3" if ($2 != 200);
6676                                 }
6677                         else {
6678                                 return "Proxy error : $line";
6679                                 }
6680                         $line = <$fh>;
6681                         $connected = 1;
6682                         }
6683                 elsif (!$gconfig{'proxy_fallback'}) {
6684                         # Connection to proxy failed - give up
6685                         return $error;
6686                         }
6687                 }
6688         if (!$connected) {
6689                 # Direct connection
6690                 my $error;
6691                 &open_socket($host, $port, $rv->{'fh'}, \$error);
6692                 return $error if ($error);
6693                 }
6694         Net::SSLeay::set_fd($rv->{'ssl_con'}, fileno($rv->{'fh'}));
6695         Net::SSLeay::connect($rv->{'ssl_con'}) ||
6696                 return "SSL connect() failed";
6697         my $rtxt = "$method $page HTTP/1.0\r\n".$htxt;
6698         Net::SSLeay::write($rv->{'ssl_con'}, $rtxt);
6699         }
6700 else {
6701         # Plain HTTP request
6702         my $connected;
6703         if ($gconfig{'http_proxy'} =~ /^http:\/\/(\S+):(\d+)/ &&
6704             !&no_proxy($host)) {
6705                 # Via a proxy
6706                 my $error;
6707                 &open_socket($1, $2, $rv->{'fh'}, \$error);
6708                 if (!$error) {
6709                         # Connected OK
6710                         $connected = 1;
6711                         my $fh = $rv->{'fh'};
6712                         my $rtxt = $method." ".
6713                                    "http://$host:$port$page HTTP/1.0\r\n";
6714                         if ($gconfig{'proxy_user'}) {
6715                                 my $auth = &encode_base64(
6716                                    "$gconfig{'proxy_user'}:".
6717                                    "$gconfig{'proxy_pass'}");
6718                                 $auth =~ tr/\r\n//d;
6719                                 $rtxt .= "Proxy-Authorization: Basic $auth\r\n";
6720                                 }
6721                         $rtxt .= $htxt;
6722                         print $fh $rtxt;
6723                         }
6724                 elsif (!$gconfig{'proxy_fallback'}) {
6725                         return $error;
6726                         }
6727                 }
6728         if (!$connected) {
6729                 # Connecting directly
6730                 my $error;
6731                 &open_socket($host, $port, $rv->{'fh'}, \$error);
6732                 return $error if ($error);
6733                 my $fh = $rv->{'fh'};
6734                 my $rtxt = "$method $page HTTP/1.0\r\n".$htxt;
6735                 print $fh $rtxt;
6736                 }
6737         }
6738 return $rv;
6739 }
6740
6741 =head2 read_http_connection(&handle, [bytes])
6742
6743 Reads either one line or up to the specified number of bytes from the handle,
6744 originally supplied by make_http_connection.
6745
6746 =cut
6747 sub read_http_connection
6748 {
6749 my ($h) = @_;
6750 my $rv;
6751 if ($h->{'ssl_con'}) {
6752         if (!$_[1]) {
6753                 my ($idx, $more);
6754                 while(($idx = index($h->{'buffer'}, "\n")) < 0) {
6755                         # need to read more..
6756                         if (!($more = Net::SSLeay::read($h->{'ssl_con'}))) {
6757                                 # end of the data
6758                                 $rv = $h->{'buffer'};
6759                                 delete($h->{'buffer'});
6760                                 return $rv;
6761                                 }
6762                         $h->{'buffer'} .= $more;
6763                         }
6764                 $rv = substr($h->{'buffer'}, 0, $idx+1);
6765                 $h->{'buffer'} = substr($h->{'buffer'}, $idx+1);
6766                 }
6767         else {
6768                 if (length($h->{'buffer'})) {
6769                         $rv = $h->{'buffer'};
6770                         delete($h->{'buffer'});
6771                         }
6772                 else {
6773                         $rv = Net::SSLeay::read($h->{'ssl_con'}, $_[1]);
6774                         }
6775                 }
6776         }
6777 else {
6778         if ($_[1]) {
6779                 read($h->{'fh'}, $rv, $_[1]) > 0 || return undef;
6780                 }
6781         else {
6782                 my $fh = $h->{'fh'};
6783                 $rv = <$fh>;
6784                 }
6785         }
6786 $rv = undef if ($rv eq "");
6787 return $rv;
6788 }
6789
6790 =head2 write_http_connection(&handle, [data+])
6791
6792 Writes the given data to the given HTTP connection handle.
6793
6794 =cut
6795 sub write_http_connection
6796 {
6797 my $h = shift(@_);
6798 my $fh = $h->{'fh'};
6799 my $allok = 1;
6800 if ($h->{'ssl_ctx'}) {
6801         foreach my $s (@_) {
6802                 my $ok = Net::SSLeay::write($h->{'ssl_con'}, $s);
6803                 $allok = 0 if (!$ok);
6804                 }
6805         }
6806 else {
6807         my $ok = (print $fh @_);
6808         $allok = 0 if (!$ok);
6809         }
6810 return $allok;
6811 }
6812
6813 =head2 close_http_connection(&handle)
6814
6815 Closes a connection to an HTTP server, identified by the given handle.
6816
6817 =cut
6818 sub close_http_connection
6819 {
6820 my ($h) = @_;
6821 close($h->{'fh'});
6822 }
6823
6824 =head2 clean_environment
6825
6826 Deletes any environment variables inherited from miniserv so that they
6827 won't be passed to programs started by webmin. This is useful when calling
6828 programs that check for CGI-related environment variables and modify their
6829 behaviour, and to avoid passing sensitive variables to un-trusted programs.
6830
6831 =cut
6832 sub clean_environment
6833 {
6834 %UNCLEAN_ENV = %ENV;
6835 foreach my $k (keys %ENV) {
6836         if ($k =~ /^(HTTP|VIRTUALSERVER|QUOTA|USERADMIN)_/) {
6837                 delete($ENV{$k});
6838                 }
6839         }
6840 foreach my $e ('WEBMIN_CONFIG', 'SERVER_NAME', 'CONTENT_TYPE', 'REQUEST_URI',
6841             'PATH_INFO', 'WEBMIN_VAR', 'REQUEST_METHOD', 'GATEWAY_INTERFACE',
6842             'QUERY_STRING', 'REMOTE_USER', 'SERVER_SOFTWARE', 'SERVER_PROTOCOL',
6843             'REMOTE_HOST', 'SERVER_PORT', 'DOCUMENT_ROOT', 'SERVER_ROOT',
6844             'MINISERV_CONFIG', 'SCRIPT_NAME', 'SERVER_ADMIN', 'CONTENT_LENGTH',
6845             'HTTPS', 'FOREIGN_MODULE_NAME', 'FOREIGN_ROOT_DIRECTORY',
6846             'SCRIPT_FILENAME', 'PATH_TRANSLATED', 'BASE_REMOTE_USER',
6847             'DOCUMENT_REALROOT', 'MINISERV_CONFIG', 'MYSQL_PWD',
6848             'MINISERV_PID') {
6849         delete($ENV{$e});
6850         }
6851 }
6852
6853 =head2 reset_environment
6854
6855 Puts the environment back how it was before clean_environment was callled.
6856
6857 =cut
6858 sub reset_environment
6859 {
6860 if (%UNCLEAN_ENV) {
6861         foreach my $k (keys %UNCLEAN_ENV) {
6862                 $ENV{$k} = $UNCLEAN_ENV{$k};
6863                 }
6864         undef(%UNCLEAN_ENV);
6865         }
6866 }
6867
6868 =head2 progress_callback
6869
6870 Never called directly, but useful for passing to &http_download to print
6871 out progress of an HTTP request.
6872
6873 =cut
6874 sub progress_callback
6875 {
6876 if (defined(&theme_progress_callback)) {
6877         # Call the theme override
6878         return &theme_progress_callback(@_);
6879         }
6880 if ($_[0] == 2) {
6881         # Got size
6882         print $progress_callback_prefix;
6883         if ($_[1]) {
6884                 $progress_size = $_[1];
6885                 $progress_step = int($_[1] / 10);
6886                 print &text('progress_size2', $progress_callback_url,
6887                             &nice_size($progress_size)),"<br>\n";
6888                 }
6889         else {
6890                 print &text('progress_nosize', $progress_callback_url),"<br>\n";
6891                 }
6892         $last_progress_time = $last_progress_size = undef;
6893         }
6894 elsif ($_[0] == 3) {
6895         # Got data update
6896         my $sp = $progress_callback_prefix.("&nbsp;" x 5);
6897         if ($progress_size) {
6898                 # And we have a size to compare against
6899                 my $st = int(($_[1] * 10) / $progress_size);
6900                 my $time_now = time();
6901                 if ($st != $progress_step ||
6902                     $time_now - $last_progress_time > 60) {
6903                         # Show progress every 10% or 60 seconds
6904                         print $sp,&text('progress_datan', &nice_size($_[1]),
6905                                         int($_[1]*100/$progress_size)),"<br>\n";
6906                         $last_progress_time = $time_now;
6907                         }
6908                 $progress_step = $st;
6909                 }
6910         else {
6911                 # No total size .. so only show in 100k jumps
6912                 if ($_[1] > $last_progress_size+100*1024) {
6913                         print $sp,&text('progress_data2n',
6914                                         &nice_size($_[1])),"<br>\n";
6915                         $last_progress_size = $_[1];
6916                         }
6917                 }
6918         }
6919 elsif ($_[0] == 4) {
6920         # All done downloading
6921         print $progress_callback_prefix,&text('progress_done'),"<br>\n";
6922         }
6923 elsif ($_[0] == 5) {
6924         # Got new location after redirect
6925         $progress_callback_url = $_[1];
6926         }
6927 elsif ($_[0] == 6) {
6928         # URL is in cache
6929         $progress_callback_url = $_[1];
6930         print &text('progress_incache', $progress_callback_url),"<br>\n";
6931         }
6932 }
6933
6934 =head2 switch_to_remote_user
6935
6936 Changes the user and group of the current process to that of the unix user
6937 with the same name as the current webmin login, or fails if there is none.
6938 This should be called by Usermin module scripts that only need to run with
6939 limited permissions.
6940
6941 =cut
6942 sub switch_to_remote_user
6943 {
6944 @remote_user_info = $remote_user ? getpwnam($remote_user) :
6945                                    getpwuid($<);
6946 @remote_user_info || &error(&text('switch_remote_euser', $remote_user));
6947 &create_missing_homedir(\@remote_user_info);
6948 if ($< == 0) {
6949         &switch_to_unix_user(\@remote_user_info);
6950         $ENV{'USER'} = $ENV{'LOGNAME'} = $remote_user;
6951         $ENV{'HOME'} = $remote_user_info[7];
6952         }
6953 # Export global variables to caller
6954 if ($main::export_to_caller) {
6955         my ($callpkg) = caller();
6956         eval "\@${callpkg}::remote_user_info = \@remote_user_info";
6957         }
6958 }
6959
6960 =head2 switch_to_unix_user(&user-details)
6961
6962 Switches the current process to the UID and group ID from the given list
6963 of user details, which must be in the format returned by getpwnam.
6964
6965 =cut
6966 sub switch_to_unix_user
6967 {
6968 my ($uinfo) = @_;
6969 if (!defined($uinfo->[0])) {
6970         # No username given, so just use given GID
6971         ($(, $)) = ( $uinfo->[3], "$uinfo->[3] $uinfo->[3]" );
6972         }
6973 else {
6974         # Use all groups from user
6975         ($(, $)) = ( $uinfo->[3],
6976                      "$uinfo->[3] ".join(" ", $uinfo->[3],
6977                                          &other_groups($uinfo->[0])) );
6978         }
6979 eval {
6980         POSIX::setuid($uinfo->[2]);
6981         };
6982 if ($< != $uinfo->[2] || $> != $uinfo->[2]) {
6983         ($>, $<) = ( $uinfo->[2], $uinfo->[2] );
6984         }
6985 }
6986
6987 =head2 eval_as_unix_user(username, &code)
6988
6989 Runs some code fragment with the effective UID and GID switch to that
6990 of the given Unix user, so that file IO takes place with his permissions.
6991
6992 =cut
6993
6994 sub eval_as_unix_user
6995 {
6996 my ($user, $code) = @_;
6997 my @uinfo = getpwnam($user);
6998 if (!scalar(@uinfo)) {
6999         &error("eval_as_unix_user called with invalid user $user");
7000         }
7001 $) = $uinfo[3]." ".join(" ", $uinfo[3], &other_groups($user));
7002 $> = $uinfo[2];
7003 my @rv;
7004 eval {
7005         local $main::error_must_die = 1;
7006         @rv = &$code();
7007         };
7008 my $err = $@;
7009 $) = 0;
7010 $> = 0;
7011 if ($err) {
7012         $err =~ s/\s+at\s+(\/\S+)\s+line\s+(\d+)\.?//;
7013         &error($err);
7014         }
7015 return wantarray ? @rv : $rv[0];
7016 }
7017
7018 =head2 create_user_config_dirs
7019
7020 Creates per-user config directories and sets $user_config_directory and
7021 $user_module_config_directory to them. Also reads per-user module configs
7022 into %userconfig. This should be called by Usermin module scripts that need
7023 to store per-user preferences or other settings.
7024
7025 =cut
7026 sub create_user_config_dirs
7027 {
7028 return if (!$gconfig{'userconfig'});
7029 my @uinfo = @remote_user_info ? @remote_user_info : getpwnam($remote_user);
7030 return if (!@uinfo || !$uinfo[7]);
7031 &create_missing_homedir(\@uinfo);
7032 $user_config_directory = "$uinfo[7]/$gconfig{'userconfig'}";
7033 if (!-d $user_config_directory) {
7034         mkdir($user_config_directory, 0700) ||
7035                 &error("Failed to create $user_config_directory : $!");
7036         if ($< == 0 && $uinfo[2]) {
7037                 chown($uinfo[2], $uinfo[3], $user_config_directory);
7038                 }
7039         }
7040 if (&get_module_name()) {
7041         $user_module_config_directory = $user_config_directory."/".
7042                                         &get_module_name();
7043         if (!-d $user_module_config_directory) {
7044                 mkdir($user_module_config_directory, 0700) ||
7045                         &error("Failed to create $user_module_config_directory : $!");
7046                 if ($< == 0 && $uinfo[2]) {
7047                         chown($uinfo[2], $uinfo[3], $user_config_directory);
7048                         }
7049                 }
7050         undef(%userconfig);
7051         &read_file_cached("$module_root_directory/defaultuconfig",
7052                           \%userconfig);
7053         &read_file_cached("$module_config_directory/uconfig", \%userconfig);
7054         &read_file_cached("$user_module_config_directory/config",
7055                           \%userconfig);
7056         }
7057
7058 # Export global variables to caller
7059 if ($main::export_to_caller) {
7060         my ($callpkg) = caller();
7061         foreach my $v ('$user_config_directory',
7062                        '$user_module_config_directory', '%userconfig') {
7063                 my ($vt, $vn) = split('', $v, 2);
7064                 eval "${vt}${callpkg}::${vn} = ${vt}${vn}";
7065                 }
7066         }
7067 }
7068
7069 =head2 create_missing_homedir(&uinfo)
7070
7071 If auto homedir creation is enabled, create one for this user if needed.
7072 For internal use only.
7073
7074 =cut
7075 sub create_missing_homedir
7076 {
7077 my ($uinfo) = @_;
7078 if (!-e $uinfo->[7] && $gconfig{'create_homedir'}) {
7079         # Use has no home dir .. make one
7080         system("mkdir -p ".quotemeta($uinfo->[7]));
7081         chown($uinfo->[2], $uinfo->[3], $uinfo->[7]);
7082         if ($gconfig{'create_homedir_perms'} ne '') {
7083                 chmod(oct($gconfig{'create_homedir_perms'}), $uinfo->[7]);
7084                 }
7085         }
7086 }
7087
7088 =head2 filter_javascript(text)
7089
7090 Disables all javascript <script>, onClick= and so on tags in the given HTML,
7091 and returns the new HTML. Useful for displaying HTML from an un-trusted source.
7092
7093 =cut
7094 sub filter_javascript
7095 {
7096 my ($rv) = @_;
7097 $rv =~ s/<\s*script[^>]*>([\000-\377]*?)<\s*\/script\s*>//gi;
7098 $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;
7099 $rv =~ s/(javascript:)/x$1/gi;
7100 $rv =~ s/(vbscript:)/x$1/gi;
7101 return $rv;
7102 }
7103
7104 =head2 resolve_links(path)
7105
7106 Given a path that may contain symbolic links, returns the real path.
7107
7108 =cut
7109 sub resolve_links
7110 {
7111 my ($path) = @_;
7112 $path =~ s/\/+/\//g;
7113 $path =~ s/\/$// if ($path ne "/");
7114 my @p = split(/\/+/, $path);
7115 shift(@p);
7116 for(my $i=0; $i<@p; $i++) {
7117         my $sofar = "/".join("/", @p[0..$i]);
7118         my $lnk = readlink($sofar);
7119         if ($lnk eq $sofar) {
7120                 # Link to itself! Cannot do anything more really ..
7121                 last;
7122                 }
7123         elsif ($lnk =~ /^\//) {
7124                 # Link is absolute..
7125                 return &resolve_links($lnk."/".join("/", @p[$i+1 .. $#p]));
7126                 }
7127         elsif ($lnk) {
7128                 # Link is relative
7129                 return &resolve_links("/".join("/", @p[0..$i-1])."/".$lnk."/".join("/", @p[$i+1 .. $#p]));
7130                 }
7131         }
7132 return $path;
7133 }
7134
7135 =head2 simplify_path(path, bogus)
7136
7137 Given a path, maybe containing elements ".." and "." , convert it to a
7138 clean, absolute form. Returns undef if this is not possible.
7139
7140 =cut
7141 sub simplify_path
7142 {
7143 my ($dir) = @_;
7144 $dir =~ s/^\/+//g;
7145 $dir =~ s/\/+$//g;
7146 my @bits = split(/\/+/, $dir);
7147 my @fixedbits = ();
7148 $_[1] = 0;
7149 foreach my $b (@bits) {
7150         if ($b eq ".") {
7151                 # Do nothing..
7152                 }
7153         elsif ($b eq "..") {
7154                 # Remove last dir
7155                 if (scalar(@fixedbits) == 0) {
7156                         # Cannot! Already at root!
7157                         return undef;
7158                         }
7159                 pop(@fixedbits);
7160                 }
7161         else {
7162                 # Add dir to list
7163                 push(@fixedbits, $b);
7164                 }
7165         }
7166 return "/".join('/', @fixedbits);
7167 }
7168
7169 =head2 same_file(file1, file2)
7170
7171 Returns 1 if two files are actually the same
7172
7173 =cut
7174 sub same_file
7175 {
7176 return 1 if ($_[0] eq $_[1]);
7177 return 0 if ($_[0] !~ /^\// || $_[1] !~ /^\//);
7178 my @stat1 = $stat_cache{$_[0]} ? @{$stat_cache{$_[0]}}
7179                                : (@{$stat_cache{$_[0]}} = stat($_[0]));
7180 my @stat2 = $stat_cache{$_[1]} ? @{$stat_cache{$_[1]}}
7181                                : (@{$stat_cache{$_[1]}} = stat($_[1]));
7182 return 0 if (!@stat1 || !@stat2);
7183 return $stat1[0] == $stat2[0] && $stat1[1] == $stat2[1];
7184 }
7185
7186 =head2 flush_webmin_caches
7187
7188 Clears all in-memory and on-disk caches used by Webmin.
7189
7190 =cut
7191 sub flush_webmin_caches
7192 {
7193 undef(%main::read_file_cache);
7194 undef(%main::acl_hash_cache);
7195 undef(%main::acl_array_cache);
7196 undef(%main::has_command_cache);
7197 undef(@main::list_languages_cache);
7198 undef($main::got_list_usermods_cache);
7199 undef(@main::list_usermods_cache);
7200 undef(%main::foreign_installed_cache);
7201 unlink("$config_directory/module.infos.cache");
7202 &get_all_module_infos();
7203 }
7204
7205 =head2 list_usermods
7206
7207 Returns a list of additional module restrictions. For internal use in
7208 Usermin only.
7209
7210 =cut
7211 sub list_usermods
7212 {
7213 if (!$main::got_list_usermods_cache) {
7214         @main::list_usermods_cache = ( );
7215         local $_;
7216         open(USERMODS, "$config_directory/usermin.mods");
7217         while(<USERMODS>) {
7218                 if (/^([^:]+):(\+|-|):(.*)/) {
7219                         push(@main::list_usermods_cache,
7220                              [ $1, $2, [ split(/\s+/, $3) ] ]);
7221                         }
7222                 }
7223         close(USERMODS);
7224         $main::got_list_usermods_cache = 1;
7225         }
7226 return @main::list_usermods_cache;
7227 }
7228
7229 =head2 available_usermods(&allmods, &usermods)
7230
7231 Returns a list of modules that are available to the given user, based
7232 on usermod additional/subtractions. For internal use by Usermin only.
7233
7234 =cut
7235 sub available_usermods
7236 {
7237 return @{$_[0]} if (!@{$_[1]});
7238
7239 my %mods = map { $_->{'dir'}, 1 } @{$_[0]};
7240 my @uinfo = @remote_user_info;
7241 @uinfo = getpwnam($remote_user) if (!@uinfo);
7242 foreach my $u (@{$_[1]}) {
7243         my $applies;
7244         if ($u->[0] eq "*" || $u->[0] eq $remote_user) {
7245                 $applies++;
7246                 }
7247         elsif ($u->[0] =~ /^\@(.*)$/) {
7248                 # Check for group membership
7249                 my @ginfo = getgrnam($1);
7250                 $applies++ if (@ginfo && ($ginfo[2] == $uinfo[3] ||
7251                         &indexof($remote_user, split(/\s+/, $ginfo[3])) >= 0));
7252                 }
7253         elsif ($u->[0] =~ /^\//) {
7254                 # Check users and groups in file
7255                 local $_;
7256                 open(USERFILE, $u->[0]);
7257                 while(<USERFILE>) {
7258                         tr/\r\n//d;
7259                         if ($_ eq $remote_user) {
7260                                 $applies++;
7261                                 }
7262                         elsif (/^\@(.*)$/) {
7263                                 my @ginfo = getgrnam($1);
7264                                 $applies++
7265                                   if (@ginfo && ($ginfo[2] == $uinfo[3] ||
7266                                       &indexof($remote_user,
7267                                                split(/\s+/, $ginfo[3])) >= 0));
7268                                 }
7269                         last if ($applies);
7270                         }
7271                 close(USERFILE);
7272                 }
7273         if ($applies) {
7274                 if ($u->[1] eq "+") {
7275                         map { $mods{$_}++ } @{$u->[2]};
7276                         }
7277                 elsif ($u->[1] eq "-") {
7278                         map { delete($mods{$_}) } @{$u->[2]};
7279                         }
7280                 else {
7281                         undef(%mods);
7282                         map { $mods{$_}++ } @{$u->[2]};
7283                         }
7284                 }
7285         }
7286 return grep { $mods{$_->{'dir'}} } @{$_[0]};
7287 }
7288
7289 =head2 get_available_module_infos(nocache)
7290
7291 Returns a list of modules available to the current user, based on
7292 operating system support, access control and usermod restrictions. Useful
7293 in themes that need to display a list of modules the user can use.
7294 Each element of the returned array is a hash reference in the same format as
7295 returned by get_module_info.
7296
7297 =cut
7298 sub get_available_module_infos
7299 {
7300 my (%acl, %uacl);
7301 &read_acl(\%acl, \%uacl, [ $base_remote_user ]);
7302 my $risk = $gconfig{'risk_'.$base_remote_user};
7303 my @rv;
7304 foreach my $minfo (&get_all_module_infos($_[0])) {
7305         next if (!&check_os_support($minfo));
7306         if ($risk) {
7307                 # Check module risk level
7308                 next if ($risk ne 'high' && $minfo->{'risk'} &&
7309                          $minfo->{'risk'} !~ /$risk/);
7310                 }
7311         else {
7312                 # Check user's ACL
7313                 next if (!$acl{$base_remote_user,$minfo->{'dir'}} &&
7314                          !$acl{$base_remote_user,"*"});
7315                 }
7316         next if (&is_readonly_mode() && !$minfo->{'readonly'});
7317         push(@rv, $minfo);
7318         }
7319
7320 # Check usermod restrictions
7321 my @usermods = &list_usermods();
7322 @rv = sort { $a->{'desc'} cmp $b->{'desc'} }
7323             &available_usermods(\@rv, \@usermods);
7324
7325 # Check RBAC restrictions
7326 my @rbacrv;
7327 foreach my $m (@rv) {
7328         if (&supports_rbac($m->{'dir'}) &&
7329             &use_rbac_module_acl(undef, $m->{'dir'})) {
7330                 local $rbacs = &get_rbac_module_acl($remote_user,
7331                                                     $m->{'dir'});
7332                 if ($rbacs) {
7333                         # RBAC allows
7334                         push(@rbacrv, $m);
7335                         }
7336                 }
7337         else {
7338                 # Module or system doesn't support RBAC
7339                 push(@rbacrv, $m) if (!$gconfig{'rbacdeny_'.$base_remote_user});
7340                 }
7341         }
7342
7343 # Check theme vetos
7344 my @themerv;
7345 if (defined(&theme_foreign_available)) {
7346         foreach my $m (@rbacrv) {
7347                 if (&theme_foreign_available($m->{'dir'})) {
7348                         push(@themerv, $m);
7349                         }
7350                 }
7351         }
7352 else {
7353         @themerv = @rbacrv;
7354         }
7355
7356 # Check licence module vetos
7357 my @licrv;
7358 if ($main::licence_module) {
7359         foreach my $m (@themerv) {
7360                 if (&foreign_call($main::licence_module,
7361                                   "check_module_licence", $m->{'dir'})) {
7362                         push(@licrv, $m);
7363                         }
7364                 }
7365         }
7366 else {
7367         @licrv = @themerv;
7368         }
7369
7370 return @licrv;
7371 }
7372
7373 =head2 get_visible_module_infos(nocache)
7374
7375 Like get_available_module_infos, but excludes hidden modules from the list.
7376 Each element of the returned array is a hash reference in the same format as
7377 returned by get_module_info.
7378
7379 =cut
7380 sub get_visible_module_infos
7381 {
7382 my ($nocache) = @_;
7383 my $pn = &get_product_name();
7384 return grep { !$_->{'hidden'} &&
7385               !$_->{$pn.'_hidden'} } &get_available_module_infos($nocache);
7386 }
7387
7388 =head2 get_visible_modules_categories(nocache)
7389
7390 Returns a list of Webmin module categories, each of which is a hash ref
7391 with 'code', 'desc' and 'modules' keys. The modules value is an array ref
7392 of modules in the category, in the format returned by get_module_info.
7393 Un-used modules are automatically assigned to the 'unused' category, and
7394 those with no category are put into 'others'.
7395
7396 =cut
7397 sub get_visible_modules_categories
7398 {
7399 my ($nocache) = @_;
7400 my @mods = &get_visible_module_infos($nocache);
7401 my @unmods;
7402 if (&get_product_name() eq 'webmin') {
7403         @unmods = grep { $_->{'installed'} eq '0' } @mods;
7404         @mods = grep { $_->{'installed'} ne '0' } @mods;
7405         }
7406 my %cats = &list_categories(\@mods);
7407 my @rv;
7408 foreach my $c (keys %cats) {
7409         my $cat = { 'code' => $c || 'other',
7410                     'desc' => $cats{$c} };
7411         $cat->{'modules'} = [ grep { $_->{'category'} eq $c } @mods ];
7412         push(@rv, $cat);
7413         }
7414 @rv = sort { ($b->{'code'} eq "others" ? "" : $b->{'code'}) cmp
7415              ($a->{'code'} eq "others" ? "" : $a->{'code'}) } @rv;
7416 if (@unmods) {
7417         # Add un-installed modules in magic category
7418         my $cat = { 'code' => 'unused',
7419                     'desc' => $text{'main_unused'},
7420                     'unused' => 1,
7421                     'modules' => \@unmods };
7422         push(@rv, $cat);
7423         }
7424 return @rv;
7425 }
7426
7427 =head2 is_under_directory(directory, file)
7428
7429 Returns 1 if the given file is under the specified directory, 0 if not.
7430 Symlinks are taken into account in the file to find it's 'real' location.
7431
7432 =cut
7433 sub is_under_directory
7434 {
7435 my ($dir, $file) = @_;
7436 return 1 if ($dir eq "/");
7437 return 0 if ($file =~ /\.\./);
7438 my $ld = &resolve_links($dir);
7439 if ($ld ne $dir) {
7440         return &is_under_directory($ld, $file);
7441         }
7442 my $lp = &resolve_links($file);
7443 if ($lp ne $file) {
7444         return &is_under_directory($dir, $lp);
7445         }
7446 return 0 if (length($file) < length($dir));
7447 return 1 if ($dir eq $file);
7448 $dir =~ s/\/*$/\//;
7449 return substr($file, 0, length($dir)) eq $dir;
7450 }
7451
7452 =head2 parse_http_url(url, [basehost, baseport, basepage, basessl])
7453
7454 Given an absolute URL, returns the host, port, page and ssl flag components.
7455 If a username and password are given before the hostname, return those too.
7456 Relative URLs can also be parsed, if the base information is provided.
7457
7458 =cut
7459 sub parse_http_url
7460 {
7461 if ($_[0] =~ /^(http|https):\/\/([^\@]+\@)?\[([^\]]+)\](:(\d+))?(\/\S*)?$/ ||
7462     $_[0] =~ /^(http|https):\/\/([^\@]+\@)?([^:\/]+)(:(\d+))?(\/\S*)?$/) {
7463         # An absolute URL
7464         my $ssl = $1 eq 'https';
7465         my @rv = ($3, $4 ? $5 : $ssl ? 443 : 80, $6 || "/", $ssl);
7466         if ($2 =~ /^([^:]+):(\S+)\@/) {
7467                 push(@rv, $1, $2);
7468                 }
7469         return @rv;
7470         }
7471 elsif (!$_[1]) {
7472         # Could not parse
7473         return undef;
7474         }
7475 elsif ($_[0] =~ /^\/\S*$/) {
7476         # A relative to the server URL
7477         return ($_[1], $_[2], $_[0], $_[4], $_[5], $_[6]);
7478         }
7479 else {
7480         # A relative to the directory URL
7481         my $page = $_[3];
7482         $page =~ s/[^\/]+$//;
7483         return ($_[1], $_[2], $page.$_[0], $_[4], $_[5], $_[6]);
7484         }
7485 }
7486
7487 =head2 check_clicks_function
7488
7489 Returns HTML for a JavaScript function called check_clicks that returns
7490 true when first called, but false subsequently. Useful on onClick for
7491 critical buttons. Deprecated, as this method of preventing duplicate actions
7492 is un-reliable.
7493
7494 =cut
7495 sub check_clicks_function
7496 {
7497 return <<EOF;
7498 <script>
7499 clicks = 0;
7500 function check_clicks(form)
7501 {
7502 clicks++;
7503 if (clicks == 1)
7504         return true;
7505 else {
7506         if (form != null) {
7507                 for(i=0; i<form.length; i++)
7508                         form.elements[i].disabled = true;
7509                 }
7510         return false;
7511         }
7512 }
7513 </script>
7514 EOF
7515 }
7516
7517 =head2 load_entities_map
7518
7519 Returns a hash ref containing mappings between HTML entities (like ouml) and
7520 ascii values (like 246). Mainly for internal use.
7521
7522 =cut
7523 sub load_entities_map
7524 {
7525 if (!%entities_map_cache) {
7526         local $_;
7527         open(EMAP, "$root_directory/entities_map.txt");
7528         while(<EMAP>) {
7529                 if (/^(\d+)\s+(\S+)/) {
7530                         $entities_map_cache{$2} = $1;
7531                         }
7532                 }
7533         close(EMAP);
7534         }
7535 return \%entities_map_cache;
7536 }
7537
7538 =head2 entities_to_ascii(string)
7539
7540 Given a string containing HTML entities like &ouml; and &#55;, replace them
7541 with their ASCII equivalents.
7542
7543 =cut
7544 sub entities_to_ascii
7545 {
7546 my ($str) = @_;
7547 my $emap = &load_entities_map();
7548 $str =~ s/&([a-z]+);/chr($emap->{$1})/ge;
7549 $str =~ s/&#(\d+);/chr($1)/ge;
7550 return $str;
7551 }
7552
7553 =head2 get_product_name
7554
7555 Returns either 'webmin' or 'usermin', depending on which program the current
7556 module is in. Useful for modules that can be installed into either.
7557
7558 =cut
7559 sub get_product_name
7560 {
7561 return $gconfig{'product'} if (defined($gconfig{'product'}));
7562 return defined($gconfig{'userconfig'}) ? 'usermin' : 'webmin';
7563 }
7564
7565 =head2 get_charset
7566
7567 Returns the character set for the current language, such as iso-8859-1.
7568
7569 =cut
7570 sub get_charset
7571 {
7572 my $charset = defined($gconfig{'charset'}) ? $gconfig{'charset'} :
7573                  $current_lang_info->{'charset'} ?
7574                  $current_lang_info->{'charset'} : $default_charset;
7575 return $charset;
7576 }
7577
7578 =head2 get_display_hostname
7579
7580 Returns the system's hostname for UI display purposes. This may be different
7581 from the actual hostname if you administrator has configured it so in the
7582 Webmin Configuration module.
7583
7584 =cut
7585 sub get_display_hostname
7586 {
7587 if ($gconfig{'hostnamemode'} == 0) {
7588         return &get_system_hostname();
7589         }
7590 elsif ($gconfig{'hostnamemode'} == 3) {
7591         return $gconfig{'hostnamedisplay'};
7592         }
7593 else {
7594         my $h = $ENV{'HTTP_HOST'};
7595         $h =~ s/:\d+//g;
7596         if ($gconfig{'hostnamemode'} == 2) {
7597                 $h =~ s/^(www|ftp|mail)\.//i;
7598                 }
7599         return $h;
7600         }
7601 }
7602
7603 =head2 save_module_config([&config], [modulename])
7604
7605 Saves the configuration for some module. The config parameter is an optional
7606 hash reference of names and values to save, which defaults to the global
7607 %config hash. The modulename parameter is the module to update the config
7608 file, which defaults to the current module.
7609
7610 =cut
7611 sub save_module_config
7612 {
7613 my $c = $_[0] || { &get_module_variable('%config') };
7614 my $m = defined($_[1]) ? $_[1] : &get_module_name();
7615 &write_file("$config_directory/$m/config", $c);
7616 }
7617
7618 =head2 save_user_module_config([&config], [modulename])
7619
7620 Saves the user's Usermin preferences for some module. The config parameter is
7621 an optional hash reference of names and values to save, which defaults to the
7622 global %userconfig hash. The modulename parameter is the module to update the
7623 config file, which defaults to the current module.
7624
7625 =cut
7626 sub save_user_module_config
7627 {
7628 my $c = $_[0] || { &get_module_variable('%userconfig') };
7629 my $m = $_[1] || &get_module_name();
7630 my $ucd = $user_config_directory;
7631 if (!$ucd) {
7632         my @uinfo = @remote_user_info ? @remote_user_info
7633                                       : getpwnam($remote_user);
7634         return if (!@uinfo || !$uinfo[7]);
7635         $ucd = "$uinfo[7]/$gconfig{'userconfig'}";
7636         }
7637 &write_file("$ucd/$m/config", $c);
7638 }
7639
7640 =head2 nice_size(bytes, [min])
7641
7642 Converts a number of bytes into a number followed by a suffix like GB, MB
7643 or kB. Rounding is to two decimal digits. The optional min parameter sets the
7644 smallest units to use - so you could pass 1024*1024 to never show bytes or kB.
7645
7646 =cut
7647 sub nice_size
7648 {
7649 my ($units, $uname);
7650 if (abs($_[0]) > 1024*1024*1024*1024 || $_[1] >= 1024*1024*1024*1024) {
7651         $units = 1024*1024*1024*1024;
7652         $uname = "TB";
7653         }
7654 elsif (abs($_[0]) > 1024*1024*1024 || $_[1] >= 1024*1024*1024) {
7655         $units = 1024*1024*1024;
7656         $uname = "GB";
7657         }
7658 elsif (abs($_[0]) > 1024*1024 || $_[1] >= 1024*1024) {
7659         $units = 1024*1024;
7660         $uname = "MB";
7661         }
7662 elsif (abs($_[0]) > 1024 || $_[1] >= 1024) {
7663         $units = 1024;
7664         $uname = "kB";
7665         }
7666 else {
7667         $units = 1;
7668         $uname = "bytes";
7669         }
7670 my $sz = sprintf("%.2f", ($_[0]*1.0 / $units));
7671 $sz =~ s/\.00$//;
7672 return $sz." ".$uname;
7673 }
7674
7675 =head2 get_perl_path
7676
7677 Returns the path to Perl currently in use, such as /usr/bin/perl.
7678
7679 =cut
7680 sub get_perl_path
7681 {
7682 if (open(PERL, "$config_directory/perl-path")) {
7683         my $rv;
7684         chop($rv = <PERL>);
7685         close(PERL);
7686         return $rv;
7687         }
7688 return $^X if (-x $^X);
7689 return &has_command("perl");
7690 }
7691
7692 =head2 get_goto_module([&mods])
7693
7694 Returns the details of a module that the current user should be re-directed
7695 to after logging in, or undef if none. Useful for themes.
7696
7697 =cut
7698 sub get_goto_module
7699 {
7700 my @mods = $_[0] ? @{$_[0]} : &get_visible_module_infos();
7701 if ($gconfig{'gotomodule'}) {
7702         my ($goto) = grep { $_->{'dir'} eq $gconfig{'gotomodule'} } @mods;
7703         return $goto if ($goto);
7704         }
7705 if (@mods == 1 && $gconfig{'gotoone'}) {
7706         return $mods[0];
7707         }
7708 return undef;
7709 }
7710
7711 =head2 select_all_link(field, form, [text])
7712
7713 Returns HTML for a 'Select all' link that uses Javascript to select
7714 multiple checkboxes with the same name. The parameters are :
7715
7716 =item field - Name of the checkbox inputs.
7717
7718 =item form - Index of the form on the page.
7719
7720 =item text - Message for the link, defaulting to 'Select all'.
7721
7722 =cut
7723 sub select_all_link
7724 {
7725 return &theme_select_all_link(@_) if (defined(&theme_select_all_link));
7726 my ($field, $form, $text) = @_;
7727 $form = int($form);
7728 $text ||= $text{'ui_selall'};
7729 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>";
7730 }
7731
7732 =head2 select_invert_link(field, form, text)
7733
7734 Returns HTML for an 'Invert selection' link that uses Javascript to invert the
7735 selection on multiple checkboxes with the same name. The parameters are :
7736
7737 =item field - Name of the checkbox inputs.
7738
7739 =item form - Index of the form on the page.
7740
7741 =item text - Message for the link, defaulting to 'Invert selection'.
7742
7743 =cut
7744 sub select_invert_link
7745 {
7746 return &theme_select_invert_link(@_) if (defined(&theme_select_invert_link));
7747 my ($field, $form, $text) = @_;
7748 $form = int($form);
7749 $text ||= $text{'ui_selinv'};
7750 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>";
7751 }
7752
7753 =head2 select_rows_link(field, form, text, &rows)
7754
7755 Returns HTML for a link that uses Javascript to select rows with particular
7756 values for their checkboxes. The parameters are :
7757
7758 =item field - Name of the checkbox inputs.
7759
7760 =item form - Index of the form on the page.
7761
7762 =item text - Message for the link, de
7763
7764 =item rows - Reference to an array of 1 or 0 values, indicating which rows to check.
7765
7766 =cut
7767 sub select_rows_link
7768 {
7769 return &theme_select_rows_link(@_) if (defined(&theme_select_rows_link));
7770 my ($field, $form, $text, $rows) = @_;
7771 $form = int($form);
7772 my $js = "var sel = { ".join(",", map { "\"".&quote_escape($_)."\":1" } @$rows)." }; ";
7773 $js .= "for(var i=0; i<document.forms[$form].${field}.length; i++) { var r = document.forms[$form].${field}[i]; r.checked = sel[r.value]; } ";
7774 $js .= "return false;";
7775 return "<a href='#' onClick='$js'>$text</a>";
7776 }
7777
7778 =head2 check_pid_file(file)
7779
7780 Given a pid file, returns the PID it contains if the process is running.
7781
7782 =cut
7783 sub check_pid_file
7784 {
7785 open(PIDFILE, $_[0]) || return undef;
7786 my $pid = <PIDFILE>;
7787 close(PIDFILE);
7788 $pid =~ /^\s*(\d+)/ || return undef;
7789 kill(0, $1) || return undef;
7790 return $1;
7791 }
7792
7793 =head2 get_mod_lib
7794
7795 Return the local os-specific library name to this module. For internal use only.
7796
7797 =cut
7798 sub get_mod_lib
7799 {
7800 my $mn = &get_module_name();
7801 my $md = &module_root_directory($mn);
7802 if (-r "$md/$mn-$gconfig{'os_type'}-$gconfig{'os_version'}-lib.pl") {
7803         return "$mn-$gconfig{'os_type'}-$gconfig{'os_version'}-lib.pl";
7804         }
7805 elsif (-r "$md/$mn-$gconfig{'os_type'}-lib.pl") {
7806         return "$mn-$gconfig{'os_type'}-lib.pl";
7807         }
7808 elsif (-r "$md/$mn-generic-lib.pl") {
7809         return "$mn-generic-lib.pl";
7810         }
7811 else {
7812         return "";
7813         }
7814 }
7815
7816 =head2 module_root_directory(module)
7817
7818 Given a module name, returns its root directory. On a typical Webmin install,
7819 all modules are under the same directory - but it is theoretically possible to
7820 have more than one.
7821
7822 =cut
7823 sub module_root_directory
7824 {
7825 my $d = ref($_[0]) ? $_[0]->{'dir'} : $_[0];
7826 if (@root_directories > 1) {
7827         foreach my $r (@root_directories) {
7828                 if (-d "$r/$d") {
7829                         return "$r/$d";
7830                         }
7831                 }
7832         }
7833 return "$root_directories[0]/$d";
7834 }
7835
7836 =head2 list_mime_types
7837
7838 Returns a list of all known MIME types and their extensions, as a list of hash
7839 references with keys :
7840
7841 =item type - The MIME type, like text/plain.
7842
7843 =item exts - A list of extensions, like .doc and .avi.
7844
7845 =item desc - A human-readable description for the MIME type.
7846
7847 =cut
7848 sub list_mime_types
7849 {
7850 if (!@list_mime_types_cache) {
7851         local $_;
7852         open(MIME, "$root_directory/mime.types");
7853         while(<MIME>) {
7854                 my $cmt;
7855                 s/\r|\n//g;
7856                 if (s/#\s*(.*)$//g) {
7857                         $cmt = $1;
7858                         }
7859                 my ($type, @exts) = split(/\s+/);
7860                 if ($type) {
7861                         push(@list_mime_types_cache, { 'type' => $type,
7862                                                        'exts' => \@exts,
7863                                                        'desc' => $cmt });
7864                         }
7865                 }
7866         close(MIME);
7867         }
7868 return @list_mime_types_cache;
7869 }
7870
7871 =head2 guess_mime_type(filename, [default])
7872
7873 Given a file name like xxx.gif or foo.html, returns a guessed MIME type.
7874 The optional default parameter sets a default type of use if none is found,
7875 which defaults to application/octet-stream.
7876
7877 =cut
7878 sub guess_mime_type
7879 {
7880 if ($_[0] =~ /\.([A-Za-z0-9\-]+)$/) {
7881         my $ext = $1;
7882         foreach my $t (&list_mime_types()) {
7883                 foreach my $e (@{$t->{'exts'}}) {
7884                         return $t->{'type'} if (lc($e) eq lc($ext));
7885                         }
7886                 }
7887         }
7888 return @_ > 1 ? $_[1] : "application/octet-stream";
7889 }
7890
7891 =head2 open_tempfile([handle], file, [no-error], [no-tempfile], [safe?])
7892
7893 Opens a file handle for writing to a temporary file, which will only be
7894 renamed over the real file when the handle is closed. This allows critical
7895 files like /etc/shadow to be updated safely, even if writing fails part way
7896 through due to lack of disk space. The parameters are :
7897
7898 =item handle - File handle to open, as you would use in Perl's open function.
7899
7900 =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.
7901
7902 =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.
7903
7904 =item no-tempfile - If set to 1, writing will be direct to the file instead of using a temporary file.
7905
7906 =item safe - Indicates to users in read-only mode that this write is safe and non-destructive.
7907
7908 =cut
7909 sub open_tempfile
7910 {
7911 if (@_ == 1) {
7912         # Just getting a temp file
7913         if (!defined($main::open_tempfiles{$_[0]})) {
7914                 $_[0] =~ /^(.*)\/(.*)$/ || return $_[0];
7915                 my $dir = $1 || "/";
7916                 my $tmp = "$dir/$2.webmintmp.$$";
7917                 $main::open_tempfiles{$_[0]} = $tmp;
7918                 push(@main::temporary_files, $tmp);
7919                 }
7920         return $main::open_tempfiles{$_[0]};
7921         }
7922 else {
7923         # Actually opening
7924         my ($fh, $file, $noerror, $notemp, $safe) = @_;
7925         $fh = &callers_package($fh);
7926
7927         my %gaccess = &get_module_acl(undef, "");
7928         my $db = $gconfig{'debug_what_write'};
7929         if ($file =~ /\r|\n|\0/) {
7930                 if ($noerror) { return 0; }
7931                 else { &error("Filename contains invalid characters"); }
7932                 }
7933         if (&is_readonly_mode() && $file =~ />/ && !$safe) {
7934                 # Read-only mode .. veto all writes
7935                 print STDERR "vetoing write to $file\n";
7936                 return open($fh, ">$null_file");
7937                 }
7938         elsif ($file =~ /^(>|>>|)nul$/i) {
7939                 # Write to Windows null device
7940                 &webmin_debug_log($1 eq ">" ? "WRITE" :
7941                           $1 eq ">>" ? "APPEND" : "READ", "nul") if ($db);
7942                 }
7943         elsif ($file =~ /^(>|>>)(\/dev\/.*)/ || lc($file) eq "nul") {
7944                 # Writes to /dev/null or TTYs don't need to be handled
7945                 &webmin_debug_log($1 eq ">" ? "WRITE" : "APPEND", $2) if ($db);
7946                 return open($fh, $file);
7947                 }
7948         elsif ($file =~ /^>\s*(([a-zA-Z]:)?\/.*)$/ && !$notemp) {
7949                 &webmin_debug_log("WRITE", $1) if ($db);
7950                 # Over-writing a file, via a temp file
7951                 $file = $1;
7952                 $file = &translate_filename($file);
7953                 while(-l $file) {
7954                         # Open the link target instead
7955                         $file = &resolve_links($file);
7956                         }
7957                 if (-d $file) {
7958                         # Cannot open a directory!
7959                         if ($noerror) { return 0; }
7960                         else { &error("Cannot write to directory $file"); }
7961                         }
7962                 my $tmp = &open_tempfile($file);
7963                 my $ex = open($fh, ">$tmp");
7964                 if (!$ex && $! =~ /permission/i) {
7965                         # Could not open temp file .. try opening actual file
7966                         # instead directly
7967                         $ex = open($fh, ">$file");
7968                         delete($main::open_tempfiles{$file});
7969                         }
7970                 else {
7971                         $main::open_temphandles{$fh} = $file;
7972                         }
7973                 binmode($fh);
7974                 if (!$ex && !$noerror) {
7975                         &error(&text("efileopen", $file, $!));
7976                         }
7977                 return $ex;
7978                 }
7979         elsif ($file =~ /^>\s*(([a-zA-Z]:)?\/.*)$/ && $notemp) {
7980                 # Just writing direct to a file
7981                 &webmin_debug_log("WRITE", $1) if ($db);
7982                 $file = $1;
7983                 $file = &translate_filename($file);
7984                 my @old_attributes = &get_clear_file_attributes($file);
7985                 my $ex = open($fh, ">$file");
7986                 &reset_file_attributes($file, \@old_attributes);
7987                 $main::open_temphandles{$fh} = $file;
7988                 if (!$ex && !$noerror) {
7989                         &error(&text("efileopen", $file, $!));
7990                         }
7991                 binmode($fh);
7992                 return $ex;
7993                 }
7994         elsif ($file =~ /^>>\s*(([a-zA-Z]:)?\/.*)$/) {
7995                 # Appending to a file .. nothing special to do
7996                 &webmin_debug_log("APPEND", $1) if ($db);
7997                 $file = $1;
7998                 $file = &translate_filename($file);
7999                 my @old_attributes = &get_clear_file_attributes($file);
8000                 my $ex = open($fh, ">>$file");
8001                 &reset_file_attributes($file, \@old_attributes);
8002                 $main::open_temphandles{$fh} = $file;
8003                 if (!$ex && !$noerror) {
8004                         &error(&text("efileopen", $file, $!));
8005                         }
8006                 binmode($fh);
8007                 return $ex;
8008                 }
8009         elsif ($file =~ /^([a-zA-Z]:)?\//) {
8010                 # Read mode .. nothing to do here
8011                 &webmin_debug_log("READ", $file) if ($db);
8012                 $file = &translate_filename($file);
8013                 return open($fh, $file);
8014                 }
8015         elsif ($file eq ">" || $file eq ">>") {
8016                 my ($package, $filename, $line) = caller;
8017                 if ($noerror) { return 0; }
8018                 else { &error("Missing file to open at ${package}::${filename} line $line"); }
8019                 }
8020         else {
8021                 my ($package, $filename, $line) = caller;
8022                 &error("Unsupported file or mode $file at ${package}::${filename} line $line");
8023                 }
8024         }
8025 }
8026
8027 =head2 close_tempfile(file|handle)
8028
8029 Copies a temp file to the actual file, assuming that all writes were
8030 successful. The handle must have been one passed to open_tempfile.
8031
8032 =cut
8033 sub close_tempfile
8034 {
8035 my $file;
8036 my $fh = &callers_package($_[0]);
8037
8038 if (defined($file = $main::open_temphandles{$fh})) {
8039         # Closing a handle
8040         close($fh) || &error(&text("efileclose", $file, $!));
8041         delete($main::open_temphandles{$fh});
8042         return &close_tempfile($file);
8043         }
8044 elsif (defined($main::open_tempfiles{$_[0]})) {
8045         # Closing a file
8046         &webmin_debug_log("CLOSE", $_[0]) if ($gconfig{'debug_what_write'});
8047         my @st = stat($_[0]);
8048         if (&is_selinux_enabled() && &has_command("chcon")) {
8049                 # Set original security context
8050                 system("chcon --reference=".quotemeta($_[0]).
8051                        " ".quotemeta($main::open_tempfiles{$_[0]}).
8052                        " >/dev/null 2>&1");
8053                 }
8054         my @old_attributes = &get_clear_file_attributes($_[0]);
8055         rename($main::open_tempfiles{$_[0]}, $_[0]) || &error("Failed to replace $_[0] with $main::open_tempfiles{$_[0]} : $!");
8056         if (@st) {
8057                 # Set original permissions and ownership
8058                 chmod($st[2], $_[0]);
8059                 chown($st[4], $st[5], $_[0]);
8060                 }
8061         &reset_file_attributes($_[0], \@old_attributes);
8062         delete($main::open_tempfiles{$_[0]});
8063         @main::temporary_files = grep { $_ ne $main::open_tempfiles{$_[0]} } @main::temporary_files;
8064         if ($main::open_templocks{$_[0]}) {
8065                 &unlock_file($_[0]);
8066                 delete($main::open_templocks{$_[0]});
8067                 }
8068         return 1;
8069         }
8070 else {
8071         # Must be closing a handle not associated with a file
8072         close($_[0]);
8073         return 1;
8074         }
8075 }
8076
8077 =head2 print_tempfile(handle, text, ...)
8078
8079 Like the normal print function, but calls &error on failure. Useful when
8080 combined with open_tempfile, to ensure that a criticial file is never
8081 only partially written.
8082
8083 =cut
8084 sub print_tempfile
8085 {
8086 my ($fh, @args) = @_;
8087 $fh = &callers_package($fh);
8088 (print $fh @args) || &error(&text("efilewrite",
8089                             $main::open_temphandles{$fh} || $fh, $!));
8090 }
8091
8092 =head2 is_selinux_enabled
8093
8094 Returns 1 if SElinux is supported on this system and enabled, 0 if not.
8095
8096 =cut
8097 sub is_selinux_enabled
8098 {
8099 if (!defined($main::selinux_enabled_cache)) {
8100         my %seconfig;
8101         if ($gconfig{'os_type'} !~ /-linux$/) {
8102                 # Not on linux, so no way
8103                 $main::selinux_enabled_cache = 0;
8104                 }
8105         elsif (&read_env_file("/etc/selinux/config", \%seconfig)) {
8106                 # Use global config file
8107                 $main::selinux_enabled_cache =
8108                         $seconfig{'SELINUX'} eq 'disabled' ||
8109                         !$seconfig{'SELINUX'} ? 0 : 1;
8110                 }
8111         else {
8112                 # Use selinuxenabled command
8113                 #$selinux_enabled_cache =
8114                 #       system("selinuxenabled >/dev/null 2>&1") ? 0 : 1;
8115                 $main::selinux_enabled_cache = 0;
8116                 }
8117         }
8118 return $main::selinux_enabled_cache;
8119 }
8120
8121 =head2 get_clear_file_attributes(file)
8122
8123 Finds file attributes that may prevent writing, clears them and returns them
8124 as a list. May call error. Mainly for internal use by open_tempfile and
8125 close_tempfile.
8126
8127 =cut
8128 sub get_clear_file_attributes
8129 {
8130 my ($file) = @_;
8131 my @old_attributes;
8132 if ($gconfig{'chattr'}) {
8133         # Get original immutable bit
8134         my $out = &backquote_command(
8135                 "lsattr ".quotemeta($file)." 2>/dev/null");
8136         if (!$?) {
8137                 $out =~ s/\s\S+\n//;
8138                 @old_attributes = grep { $_ ne '-' } split(//, $out);
8139                 }
8140         if (&indexof("i", @old_attributes) >= 0) {
8141                 my $err = &backquote_logged(
8142                         "chattr -i ".quotemeta($file)." 2>&1");
8143                 if ($?) {
8144                         &error("Failed to remove immutable bit on ".
8145                                "$file : $err");
8146                         }
8147                 }
8148         }
8149 return @old_attributes;
8150 }
8151
8152 =head2 reset_file_attributes(file, &attributes)
8153
8154 Put back cleared attributes on some file. May call error. Mainly for internal
8155 use by close_tempfile.
8156
8157 =cut
8158 sub reset_file_attributes
8159 {
8160 my ($file, $old_attributes) = @_;
8161 if (&indexof("i", @$old_attributes) >= 0) {
8162         my $err = &backquote_logged(
8163                 "chattr +i ".quotemeta($file)." 2>&1");
8164         if ($?) {
8165                 &error("Failed to restore immutable bit on ".
8166                        "$file : $err");
8167                 }
8168         }
8169 }
8170
8171 =head2 cleanup_tempnames
8172
8173 Remove all temporary files generated using transname. Typically only called
8174 internally when a Webmin script exits.
8175
8176 =cut
8177 sub cleanup_tempnames
8178 {
8179 foreach my $t (@main::temporary_files) {
8180         &unlink_file($t);
8181         }
8182 @main::temporary_files = ( );
8183 }
8184
8185 =head2 open_lock_tempfile([handle], file, [no-error])
8186
8187 Returns a temporary file for writing to some actual file, and also locks it.
8188 Effectively the same as calling lock_file and open_tempfile on the same file,
8189 but calls the unlock for you automatically when it is closed.
8190
8191 =cut
8192 sub open_lock_tempfile
8193 {
8194 my ($fh, $file, $noerror, $notemp, $safe) = @_;
8195 $fh = &callers_package($fh);
8196 my $lockfile = $file;
8197 $lockfile =~ s/^[^\/]*//;
8198 if ($lockfile =~ /^\//) {
8199         $main::open_templocks{$lockfile} = &lock_file($lockfile);
8200         }
8201 return &open_tempfile($fh, $file, $noerror, $notemp, $safe);
8202 }
8203
8204 sub END
8205 {
8206 $main::end_exit_status ||= $?;
8207 if ($$ == $main::initial_process_id) {
8208         # Exiting from initial process
8209         &cleanup_tempnames();
8210         if ($gconfig{'debug_what_start'} && $main::debug_log_start_time &&
8211             $main::debug_log_start_module eq &get_module_name()) {
8212                 my $len = time() - $main::debug_log_start_time;
8213                 &webmin_debug_log("STOP", "runtime=$len");
8214                 $main::debug_log_start_time = 0;
8215                 }
8216         if (!$ENV{'SCRIPT_NAME'} &&
8217             $main::initial_module_name eq &get_module_name()) {
8218                 # In a command-line script - call the real exit, so that the
8219                 # exit status gets properly propogated. In some cases this
8220                 # was not happening.
8221                 exit($main::end_exit_status);
8222                 }
8223         }
8224 }
8225
8226 =head2 month_to_number(month)
8227
8228 Converts a month name like feb to a number like 1.
8229
8230 =cut
8231 sub month_to_number
8232 {
8233 return $month_to_number_map{lc(substr($_[0], 0, 3))};
8234 }
8235
8236 =head2 number_to_month(number)
8237
8238 Converts a number like 1 to a month name like Feb.
8239
8240 =cut
8241 sub number_to_month
8242 {
8243 return ucfirst($number_to_month_map{$_[0]});
8244 }
8245
8246 =head2 get_rbac_module_acl(user, module)
8247
8248 Returns a hash reference of RBAC overrides ACLs for some user and module.
8249 May return undef if none exist (indicating access denied), or the string *
8250 if full access is granted.
8251
8252 =cut
8253 sub get_rbac_module_acl
8254 {
8255 my ($user, $mod) = @_;
8256 eval "use Authen::SolarisRBAC";
8257 return undef if ($@);
8258 my %rv;
8259 my $foundany = 0;
8260 if (Authen::SolarisRBAC::chkauth("webmin.$mod.admin", $user)) {
8261         # Automagic webmin.modulename.admin authorization exists .. allow access
8262         $foundany = 1;
8263         if (!Authen::SolarisRBAC::chkauth("webmin.$mod.config", $user)) {
8264                 %rv = ( 'noconfig' => 1 );
8265                 }
8266         else {
8267                 %rv = ( );
8268                 }
8269         }
8270 local $_;
8271 open(RBAC, &module_root_directory($mod)."/rbac-mapping");
8272 while(<RBAC>) {
8273         s/\r|\n//g;
8274         s/#.*$//;
8275         my ($auths, $acls) = split(/\s+/, $_);
8276         my @auths = split(/,/, $auths);
8277         next if (!$auths);
8278         my ($merge) = ($acls =~ s/^\+//);
8279         my $gotall = 1;
8280         if ($auths eq "*") {
8281                 # These ACLs apply to all RBAC users.
8282                 # Only if there is some that match a specific authorization
8283                 # later will they be used though.
8284                 }
8285         else {
8286                 # Check each of the RBAC authorizations
8287                 foreach my $a (@auths) {
8288                         if (!Authen::SolarisRBAC::chkauth($a, $user)) {
8289                                 $gotall = 0;
8290                                 last;
8291                                 }
8292                         }
8293                 $foundany++ if ($gotall);
8294                 }
8295         if ($gotall) {
8296                 # Found an RBAC authorization - return the ACLs
8297                 return "*" if ($acls eq "*");
8298                 my %acl = map { split(/=/, $_, 2) } split(/,/, $acls);
8299                 if ($merge) {
8300                         # Just add to current set
8301                         foreach my $a (keys %acl) {
8302                                 $rv{$a} = $acl{$a};
8303                                 }
8304                         }
8305                 else {
8306                         # Found final ACLs
8307                         return \%acl;
8308                         }
8309                 }
8310         }
8311 close(RBAC);
8312 return !$foundany ? undef : %rv ? \%rv : undef;
8313 }
8314
8315 =head2 supports_rbac([module])
8316
8317 Returns 1 if RBAC client support is available, such as on Solaris.
8318
8319 =cut
8320 sub supports_rbac
8321 {
8322 return 0 if ($gconfig{'os_type'} ne 'solaris');
8323 eval "use Authen::SolarisRBAC";
8324 return 0 if ($@);
8325 if ($_[0]) {
8326         #return 0 if (!-r &module_root_directory($_[0])."/rbac-mapping");
8327         }
8328 return 1;
8329 }
8330
8331 =head2 supports_ipv6()
8332
8333 Returns 1 if outgoing IPv6 connections can be made
8334
8335 =cut
8336 sub supports_ipv6
8337 {
8338 return $ipv6_module_error ? 0 : 1;
8339 }
8340
8341 =head2 use_rbac_module_acl(user, module)
8342
8343 Returns 1 if some user should use RBAC to get permissions for a module
8344
8345 =cut
8346 sub use_rbac_module_acl
8347 {
8348 my $u = defined($_[0]) ? $_[0] : $base_remote_user;
8349 my $m = defined($_[1]) ? $_[1] : &get_module_name();
8350 return 1 if ($gconfig{'rbacdeny_'.$u});         # RBAC forced for user
8351 my %access = &get_module_acl($u, $m, 1);
8352 return $access{'rbac'} ? 1 : 0;
8353 }
8354
8355 =head2 execute_command(command, stdin, stdout, stderr, translate-files?, safe?)
8356
8357 Runs some command, possibly feeding it input and capturing output to the
8358 give files or scalar references. The parameters are :
8359
8360 =item command - Full command to run, possibly including shell meta-characters.
8361
8362 =item stdin - File to read input from, or a scalar ref containing input, or undef if no input should be given.
8363
8364 =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.
8365
8366 =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.
8367
8368 =item translate-files - Set to 1 to apply filename translation to any filenames. Usually has no effect.
8369
8370 =item safe - Set to 1 if this command is safe and does not modify the state of the system.
8371
8372 =cut
8373 sub execute_command
8374 {
8375 my ($cmd, $stdin, $stdout, $stderr, $trans, $safe) = @_;
8376 if (&is_readonly_mode() && !$safe) {
8377         print STDERR "Vetoing command $_[0]\n";
8378         $? = 0;
8379         return 0;
8380         }
8381 $cmd = &translate_command($cmd);
8382
8383 # Use ` operator where possible
8384 &webmin_debug_log('CMD', "cmd=$cmd") if ($gconfig{'debug_what_cmd'});
8385 if (!$stdin && ref($stdout) && !$stderr) {
8386         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
8387         $$stdout = `$cmd 2>$null_file`;
8388         return $?;
8389         }
8390 elsif (!$stdin && ref($stdout) && $stdout eq $stderr) {
8391         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
8392         $$stdout = `$cmd 2>&1`;
8393         return $?;
8394         }
8395 elsif (!$stdin && !$stdout && !$stderr) {
8396         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
8397         return system("$cmd >$null_file 2>$null_file <$null_file");
8398         }
8399
8400 # Setup pipes
8401 $| = 1;         # needed on some systems to flush before forking
8402 pipe(EXECSTDINr, EXECSTDINw);
8403 pipe(EXECSTDOUTr, EXECSTDOUTw);
8404 pipe(EXECSTDERRr, EXECSTDERRw);
8405 my $pid;
8406 if (!($pid = fork())) {
8407         untie(*STDIN);
8408         untie(*STDOUT);
8409         untie(*STDERR);
8410         open(STDIN, "<&EXECSTDINr");
8411         open(STDOUT, ">&EXECSTDOUTw");
8412         if (ref($stderr) && $stderr eq $stdout) {
8413                 open(STDERR, ">&EXECSTDOUTw");
8414                 }
8415         else {
8416                 open(STDERR, ">&EXECSTDERRw");
8417                 }
8418         $| = 1;
8419         close(EXECSTDINw);
8420         close(EXECSTDOUTr);
8421         close(EXECSTDERRr);
8422
8423         my $fullcmd = "($cmd)";
8424         if ($stdin && !ref($stdin)) {
8425                 $fullcmd .= " <$stdin";
8426                 }
8427         if ($stdout && !ref($stdout)) {
8428                 $fullcmd .= " >$stdout";
8429                 }
8430         if ($stderr && !ref($stderr)) {
8431                 if ($stderr eq $stdout) {
8432                         $fullcmd .= " 2>&1";
8433                         }
8434                 else {
8435                         $fullcmd .= " 2>$stderr";
8436                         }
8437                 }
8438         if ($gconfig{'os_type'} eq 'windows') {
8439                 exec($fullcmd);
8440                 }
8441         else {
8442                 exec("/bin/sh", "-c", $fullcmd);
8443                 }
8444         print "Exec failed : $!\n";
8445         exit(1);
8446         }
8447 close(EXECSTDINr);
8448 close(EXECSTDOUTw);
8449 close(EXECSTDERRw);
8450
8451 # Feed input and capture output
8452 local $_;
8453 if ($stdin && ref($stdin)) {
8454         print EXECSTDINw $$stdin;
8455         close(EXECSTDINw);
8456         }
8457 if ($stdout && ref($stdout)) {
8458         $$stdout = undef;
8459         while(<EXECSTDOUTr>) {
8460                 $$stdout .= $_;
8461                 }
8462         close(EXECSTDOUTr);
8463         }
8464 if ($stderr && ref($stderr) && $stderr ne $stdout) {
8465         $$stderr = undef;
8466         while(<EXECSTDERRr>) {
8467                 $$stderr .= $_;
8468                 }
8469         close(EXECSTDERRr);
8470         }
8471
8472 # Get exit status
8473 waitpid($pid, 0);
8474 return $?;
8475 }
8476
8477 =head2 open_readfile(handle, file)
8478
8479 Opens some file for reading. Returns 1 on success, 0 on failure. Pretty much
8480 exactly the same as Perl's open function.
8481
8482 =cut
8483 sub open_readfile
8484 {
8485 my ($fh, $file) = @_;
8486 $fh = &callers_package($fh);
8487 my $realfile = &translate_filename($file);
8488 &webmin_debug_log('READ', $file) if ($gconfig{'debug_what_read'});
8489 return open($fh, "<".$realfile);
8490 }
8491
8492 =head2 open_execute_command(handle, command, output?, safe?)
8493
8494 Runs some command, with the specified file handle set to either write to it if
8495 in-or-out is set to 0, or read to it if output is set to 1. The safe flag
8496 indicates if the command modifies the state of the system or not.
8497
8498 =cut
8499 sub open_execute_command
8500 {
8501 my ($fh, $cmd, $mode, $safe) = @_;
8502 $fh = &callers_package($fh);
8503 my $realcmd = &translate_command($cmd);
8504 if (&is_readonly_mode() && !$safe) {
8505         # Don't actually run it
8506         print STDERR "vetoing command $cmd\n";
8507         $? = 0;
8508         if ($mode == 0) {
8509                 return open($fh, ">$null_file");
8510                 }
8511         else {
8512                 return open($fh, $null_file);
8513                 }
8514         }
8515 # Really run it
8516 &webmin_debug_log('CMD', "cmd=$realcmd mode=$mode")
8517         if ($gconfig{'debug_what_cmd'});
8518 if ($mode == 0) {
8519         return open($fh, "| $cmd");
8520         }
8521 elsif ($mode == 1) {
8522         return open($fh, "$cmd 2>$null_file |");
8523         }
8524 elsif ($mode == 2) {
8525         return open($fh, "$cmd 2>&1 |");
8526         }
8527 }
8528
8529 =head2 translate_filename(filename)
8530
8531 Applies all relevant registered translation functions to a filename. Mostly
8532 for internal use, and typically does nothing.
8533
8534 =cut
8535 sub translate_filename
8536 {
8537 my ($realfile) = @_;
8538 my @funcs = grep { $_->[0] eq &get_module_name() ||
8539                    !defined($_->[0]) } @main::filename_callbacks;
8540 foreach my $f (@funcs) {
8541         my $func = $f->[1];
8542         $realfile = &$func($realfile, @{$f->[2]});
8543         }
8544 return $realfile;
8545 }
8546
8547 =head2 translate_command(filename)
8548
8549 Applies all relevant registered translation functions to a command. Mostly
8550 for internal use, and typically does nothing.
8551
8552 =cut
8553 sub translate_command
8554 {
8555 my ($realcmd) = @_;
8556 my @funcs = grep { $_->[0] eq &get_module_name() ||
8557                    !defined($_->[0]) } @main::command_callbacks;
8558 foreach my $f (@funcs) {
8559         my $func = $f->[1];
8560         $realcmd = &$func($realcmd, @{$f->[2]});
8561         }
8562 return $realcmd;
8563 }
8564
8565 =head2 register_filename_callback(module|undef, &function, &args)
8566
8567 Registers some function to be called when the specified module (or all
8568 modules) tries to open a file for reading and writing. The function must
8569 return the actual file to open. This allows you to override which files
8570 other code actually operates on, via the translate_filename function.
8571
8572 =cut
8573 sub register_filename_callback
8574 {
8575 my ($mod, $func, $args) = @_;
8576 push(@main::filename_callbacks, [ $mod, $func, $args ]);
8577 }
8578
8579 =head2 register_command_callback(module|undef, &function, &args)
8580
8581 Registers some function to be called when the specified module (or all
8582 modules) tries to execute a command. The function must return the actual
8583 command to run. This allows you to override which commands other other code
8584 actually runs, via the translate_command function.
8585
8586 =cut
8587 sub register_command_callback
8588 {
8589 my ($mod, $func, $args) = @_;
8590 push(@main::command_callbacks, [ $mod, $func, $args ]);
8591 }
8592
8593 =head2 capture_function_output(&function, arg, ...)
8594
8595 Captures output that some function prints to STDOUT, and returns it. Useful
8596 for functions outside your control that print data when you really want to
8597 manipulate it before output.
8598
8599 =cut
8600 sub capture_function_output
8601 {
8602 my ($func, @args) = @_;
8603 socketpair(SOCKET2, SOCKET1, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
8604 my $old = select(SOCKET1);
8605 my @rv = &$func(@args);
8606 select($old);
8607 close(SOCKET1);
8608 my $out;
8609 local $_;
8610 while(<SOCKET2>) {
8611         $out .= $_;
8612         }
8613 close(SOCKET2);
8614 return wantarray ? ($out, \@rv) : $out;
8615 }
8616
8617 =head2 capture_function_output_tempfile(&function, arg, ...)
8618
8619 Behaves the same as capture_function_output, but uses a temporary file
8620 to avoid buffer full problems.
8621
8622 =cut
8623 sub capture_function_output_tempfile
8624 {
8625 my ($func, @args) = @_;
8626 my $temp = &transname();
8627 open(BUFFER, ">$temp");
8628 my $old = select(BUFFER);
8629 my @rv = &$func(@args);
8630 select($old);
8631 close(BUFFER);
8632 my $out = &read_file_contents($temp);
8633 &unlink_file($temp);
8634 return wantarray ? ($out, \@rv) : $out;
8635 }
8636
8637 =head2 modules_chooser_button(field, multiple, [form])
8638
8639 Returns HTML for a button for selecting one or many Webmin modules.
8640 field - Name of the HTML field to place the module names into.
8641 multiple - Set to 1 if multiple modules can be selected.
8642 form - Index of the form on the page.
8643
8644 =cut
8645 sub modules_chooser_button
8646 {
8647 return &theme_modules_chooser_button(@_)
8648         if (defined(&theme_modules_chooser_button));
8649 my $form = defined($_[2]) ? $_[2] : 0;
8650 my $w = $_[1] ? 700 : 500;
8651 my $h = 200;
8652 if ($_[1] && $gconfig{'db_sizemodules'}) {
8653         ($w, $h) = split(/x/, $gconfig{'db_sizemodules'});
8654         }
8655 elsif (!$_[1] && $gconfig{'db_sizemodule'}) {
8656         ($w, $h) = split(/x/, $gconfig{'db_sizemodule'});
8657         }
8658 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";
8659 }
8660
8661 =head2 substitute_template(text, &hash)
8662
8663 Given some text and a hash reference, for each ocurrance of $FOO or ${FOO} in
8664 the text replaces it with the value of the hash key foo. Also supports blocks
8665 like ${IF-FOO} ... ${ENDIF-FOO}, whose contents are only included if foo is
8666 non-zero, and ${IF-FOO} ... ${ELSE-FOO} ... ${ENDIF-FOO}.
8667
8668 =cut
8669 sub substitute_template
8670 {
8671 # Add some extra fixed parameters to the hash
8672 my %hash = %{$_[1]};
8673 $hash{'hostname'} = &get_system_hostname();
8674 $hash{'webmin_config'} = $config_directory;
8675 $hash{'webmin_etc'} = $config_directory;
8676 $hash{'module_config'} = &get_module_variable('$module_config_directory');
8677 $hash{'webmin_var'} = $var_directory;
8678
8679 # Add time-based parameters, for use in DNS
8680 $hash{'current_time'} = time();
8681 my @tm = localtime($hash{'current_time'});
8682 $hash{'current_year'} = $tm[5]+1900;
8683 $hash{'current_month'} = sprintf("%2.2d", $tm[4]+1);
8684 $hash{'current_day'} = sprintf("%2.2d", $tm[3]);
8685 $hash{'current_hour'} = sprintf("%2.2d", $tm[2]);
8686 $hash{'current_minute'} = sprintf("%2.2d", $tm[1]);
8687 $hash{'current_second'} = sprintf("%2.2d", $tm[0]);
8688
8689 # Actually do the substition
8690 my $rv = $_[0];
8691 foreach my $s (keys %hash) {
8692         next if ($s eq '');     # Prevent just $ from being subbed
8693         my $us = uc($s);
8694         my $sv = $hash{$s};
8695         $rv =~ s/\$\{\Q$us\E\}/$sv/g;
8696         $rv =~ s/\$\Q$us\E/$sv/g;
8697         if ($sv) {
8698                 # Replace ${IF}..${ELSE}..${ENDIF} block with first value,
8699                 # and ${IF}..${ENDIF} with value
8700                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/$2/g;
8701                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/$2/g;
8702
8703                 # Replace $IF..$ELSE..$ENDIF block with first value,
8704                 # and $IF..$ENDIF with value
8705                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ELSE-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/$2/g;
8706                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/$2/g;
8707
8708                 # Replace ${IFEQ}..${ENDIFEQ} block with first value if
8709                 # matching, nothing if not
8710                 $rv =~ s/\$\{IFEQ-\Q$us\E-\Q$sv\E\}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-\Q$sv\E\}(\n?)/$2/g;
8711                 $rv =~ s/\$\{IFEQ-\Q$us\E-[^\}]+}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-[^\}]+\}(\n?)//g;
8712
8713                 # Replace $IFEQ..$ENDIFEQ block with first value if
8714                 # matching, nothing if not
8715                 $rv =~ s/\$IFEQ-\Q$us\E-\Q$sv\E(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\Q$sv\E(\n?)/$2/g;
8716                 $rv =~ s/\$IFEQ-\Q$us\E-\S+(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\S+(\n?)//g;
8717                 }
8718         else {
8719                 # Replace ${IF}..${ELSE}..${ENDIF} block with second value,
8720                 # and ${IF}..${ENDIF} with nothing
8721                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/$4/g;
8722                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)//g;
8723
8724                 # Replace $IF..$ELSE..$ENDIF block with second value,
8725                 # and $IF..$ENDIF with nothing
8726                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ELSE-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/$4/g;
8727                 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)//g;
8728
8729                 # Replace ${IFEQ}..${ENDIFEQ} block with nothing
8730                 $rv =~ s/\$\{IFEQ-\Q$us\E-[^\}]+}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-[^\}]+\}(\n?)//g;
8731                 $rv =~ s/\$IFEQ-\Q$us\E-\S+(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\S+(\n?)//g;
8732                 }
8733         }
8734
8735 # Now assume any $IF blocks whose variables are not present in the hash
8736 # evaluate to false.
8737 # $IF...$ELSE x $ENDIF => x
8738 $rv =~ s/\$\{IF\-([A-Z]+)\}.*?\$\{ELSE\-\1\}(.*?)\$\{ENDIF\-\1\}/$2/gs;
8739 # $IF...x...$ENDIF => (nothing)
8740 $rv =~ s/\$\{IF\-([A-Z]+)\}.*?\$\{ENDIF\-\1\}//gs;
8741 # ${var} => (nothing)
8742 $rv =~ s/\$\{[A-Z]+\}//g;
8743
8744 return $rv;
8745 }
8746
8747 =head2 running_in_zone
8748
8749 Returns 1 if the current Webmin instance is running in a Solaris zone. Used to
8750 disable module and features that are not appropriate, like those that modify
8751 mounted filesystems.
8752
8753 =cut
8754 sub running_in_zone
8755 {
8756 return 0 if ($gconfig{'os_type'} ne 'solaris' ||
8757              $gconfig{'os_version'} < 10);
8758 my $zn = `zonename 2>$null_file`;
8759 chop($zn);
8760 return $zn && $zn ne "global";
8761 }
8762
8763 =head2 running_in_vserver
8764
8765 Returns 1 if the current Webmin instance is running in a Linux VServer.
8766 Used to disable modules and features that are not appropriate.
8767
8768 =cut
8769 sub running_in_vserver
8770 {
8771 return 0 if ($gconfig{'os_type'} !~ /^\*-linux$/);
8772 my $vserver;
8773 local $_;
8774 open(MTAB, "/etc/mtab");
8775 while(<MTAB>) {
8776         my ($dev, $mp) = split(/\s+/, $_);
8777         if ($mp eq "/" && $dev =~ /^\/dev\/hdv/) {
8778                 $vserver = 1;
8779                 last;
8780                 }
8781         }
8782 close(MTAB);
8783 return $vserver;
8784 }
8785
8786 =head2 running_in_xen
8787
8788 Returns 1 if Webmin is running inside a Xen instance, by looking
8789 at /proc/xen/capabilities.
8790
8791 =cut
8792 sub running_in_xen
8793 {
8794 return 0 if (!-r "/proc/xen/capabilities");
8795 my $cap = &read_file_contents("/proc/xen/capabilities");
8796 return $cap =~ /control_d/ ? 0 : 1;
8797 }
8798
8799 =head2 running_in_openvz
8800
8801 Returns 1 if Webmin is running inside an OpenVZ container, by looking
8802 at /proc/vz/veinfo for a non-zero line.
8803
8804 =cut
8805 sub running_in_openvz
8806 {
8807 return 0 if (!-r "/proc/vz/veinfo");
8808 my $lref = &read_file_lines("/proc/vz/veinfo", 1);
8809 return 0 if (!$lref || !@$lref);
8810 foreach my $l (@$lref) {
8811         $l =~ s/^\s+//;
8812         my @ll = split(/\s+/, $l);
8813         return 0 if ($ll[0] eq '0');
8814         }
8815 return 1;
8816 }
8817
8818 =head2 list_categories(&modules, [include-empty])
8819
8820 Returns a hash mapping category codes to names, including any custom-defined
8821 categories. The modules parameter must be an array ref of module hash objects,
8822 as returned by get_all_module_infos.
8823
8824 =cut
8825 sub list_categories
8826 {
8827 my ($mods, $empty) = @_;
8828 my (%cats, %catnames);
8829 &read_file("$config_directory/webmin.catnames", \%catnames);
8830 foreach my $o (@lang_order_list) {
8831         &read_file("$config_directory/webmin.catnames.$o", \%catnames);
8832         }
8833 if ($empty) {
8834         %cats = %catnames;
8835         }
8836 foreach my $m (@$mods) {
8837         my $c = $m->{'category'};
8838         next if ($cats{$c});
8839         if (defined($catnames{$c})) {
8840                 $cats{$c} = $catnames{$c};
8841                 }
8842         elsif ($text{"category_$c"}) {
8843                 $cats{$c} = $text{"category_$c"};
8844                 }
8845         else {
8846                 # try to get category name from module ..
8847                 my %mtext = &load_language($m->{'dir'});
8848                 if ($mtext{"category_$c"}) {
8849                         $cats{$c} = $mtext{"category_$c"};
8850                         }
8851                 else {
8852                         $c = $m->{'category'} = "";
8853                         $cats{$c} = $text{"category_$c"};
8854                         }
8855                 }
8856         }
8857 return %cats;
8858 }
8859
8860 =head2 is_readonly_mode
8861
8862 Returns 1 if the current user is in read-only mode, and thus all writes
8863 to files and command execution should fail.
8864
8865 =cut
8866 sub is_readonly_mode
8867 {
8868 if (!defined($main::readonly_mode_cache)) {
8869         my %gaccess = &get_module_acl(undef, "");
8870         $main::readonly_mode_cache = $gaccess{'readonly'} ? 1 : 0;
8871         }
8872 return $main::readonly_mode_cache;
8873 }
8874
8875 =head2 command_as_user(user, with-env?, command, ...)
8876
8877 Returns a command to execute some command as the given user, using the
8878 su statement. If on Linux, the /bin/sh shell is forced in case the user
8879 does not have a valid shell. If with-env is set to 1, the -s flag is added
8880 to the su command to read the user's .profile or .bashrc file.
8881
8882 =cut
8883 sub command_as_user
8884 {
8885 my ($user, $env, @args) = @_;
8886 my @uinfo = getpwnam($user);
8887 if ($uinfo[8] ne "/bin/sh" && $uinfo[8] !~ /\/bash$/) {
8888         # User shell doesn't appear to be valid
8889         if ($gconfig{'os_type'} =~ /-linux$/) {
8890                 # Use -s /bin/sh to force it
8891                 $shellarg = " -s /bin/sh";
8892                 }
8893         elsif ($gconfig{'os_type'} eq 'freebsd' ||
8894                $gconfig{'os_type'} eq 'solaris' &&
8895                 $gconfig{'os_version'} >= 11 ||
8896                $gconfig{'os_type'} eq 'macos') {
8897                 # Use -m and force /bin/sh
8898                 @args = ( "/bin/sh", "-c", quotemeta(join(" ", @args)) );
8899                 $shellarg = " -m";
8900                 }
8901         }
8902 my $rv = "su".($env ? " -" : "").$shellarg.
8903          " ".quotemeta($user)." -c ".quotemeta(join(" ", @args));
8904 return $rv;
8905 }
8906
8907 =head2 list_osdn_mirrors(project, file)
8908
8909 This function is now deprecated in favor of letting sourceforge just
8910 redirect to the best mirror, and now just returns their primary download URL.
8911
8912 =cut
8913 sub list_osdn_mirrors
8914 {
8915 my ($project, $file) = @_;
8916 return ( { 'url' => "http://downloads.sourceforge.net/$project/$file",
8917            'default' => 0,
8918            'mirror' => 'downloads' } );
8919 }
8920
8921 =head2 convert_osdn_url(url)
8922
8923 Given a URL like http://osdn.dl.sourceforge.net/sourceforge/project/file.zip
8924 or http://prdownloads.sourceforge.net/project/file.zip , convert it
8925 to a real URL on the sourceforge download redirector.
8926
8927 =cut
8928 sub convert_osdn_url
8929 {
8930 my ($url) = @_;
8931 if ($url =~ /^http:\/\/[^\.]+.dl.sourceforge.net\/sourceforge\/([^\/]+)\/(.*)$/ ||
8932     $url =~ /^http:\/\/prdownloads.sourceforge.net\/([^\/]+)\/(.*)$/) {
8933         # Always use the Sourceforge mail download URL, which does
8934         # a location-based redirect for us
8935         my ($project, $file) = ($1, $2);
8936         $url = "http://prdownloads.sourceforge.net/sourceforge/".
8937                "$project/$file";
8938         return wantarray ? ( $url, 0 ) : $url;
8939         }
8940 else {
8941         # Some other source .. don't change
8942         return wantarray ? ( $url, 2 ) : $url;
8943         }
8944 }
8945
8946 =head2 get_current_dir
8947
8948 Returns the directory the current process is running in.
8949
8950 =cut
8951 sub get_current_dir
8952 {
8953 my $out;
8954 if ($gconfig{'os_type'} eq 'windows') {
8955         # Use cd command
8956         $out = `cd`;
8957         }
8958 else {
8959         # Use pwd command
8960         $out = `pwd`;
8961         $out =~ s/\\/\//g;
8962         }
8963 $out =~ s/\r|\n//g;
8964 return $out;
8965 }
8966
8967 =head2 supports_users
8968
8969 Returns 1 if the current OS supports Unix user concepts and functions like
8970 su , getpw* and so on. This will be true on Linux and other Unixes, but false
8971 on Windows.
8972
8973 =cut
8974 sub supports_users
8975 {
8976 return $gconfig{'os_type'} ne 'windows';
8977 }
8978
8979 =head2 supports_symlinks
8980
8981 Returns 1 if the current OS supports symbolic and hard links. This will not
8982 be the case on Windows.
8983
8984 =cut
8985 sub supports_symlinks
8986 {
8987 return $gconfig{'os_type'} ne 'windows';
8988 }
8989
8990 =head2 quote_path(path)
8991
8992 Returns a path with safe quoting for the current operating system.
8993
8994 =cut
8995 sub quote_path
8996 {
8997 my ($path) = @_;
8998 if ($gconfig{'os_type'} eq 'windows' || $path =~ /^[a-z]:/i) {
8999         # Windows only supports "" style quoting
9000         return "\"$path\"";
9001         }
9002 else {
9003         return quotemeta($path);
9004         }
9005 }
9006
9007 =head2 get_windows_root
9008
9009 Returns the base windows system directory, like c:/windows.
9010
9011 =cut
9012 sub get_windows_root
9013 {
9014 if ($ENV{'SystemRoot'}) {
9015         my $rv = $ENV{'SystemRoot'};
9016         $rv =~ s/\\/\//g;
9017         return $rv;
9018         }
9019 else {
9020         return -d "c:/windows" ? "c:/windows" : "c:/winnt";
9021         }
9022 }
9023
9024 =head2 read_file_contents(file)
9025
9026 Given a filename, returns its complete contents as a string. Effectively
9027 the same as the Perl construct `cat file`.
9028
9029 =cut
9030 sub read_file_contents
9031 {
9032 &open_readfile(FILE, $_[0]) || return undef;
9033 local $/ = undef;
9034 my $rv = <FILE>;
9035 close(FILE);
9036 return $rv;
9037 }
9038
9039 =head2 unix_crypt(password, salt)
9040
9041 Performs Unix encryption on a password, using the built-in crypt function or
9042 the Crypt::UnixCrypt module if the former does not work. The salt parameter
9043 must be either an already-hashed password, or a two-character alpha-numeric
9044 string.
9045
9046 =cut
9047 sub unix_crypt
9048 {
9049 my ($pass, $salt) = @_;
9050 return "" if ($salt !~ /^[a-zA-Z0-9\.\/]{2}/);   # same as real crypt
9051 my $rv = eval "crypt(\$pass, \$salt)";
9052 my $err = $@;
9053 return $rv if ($rv && !$@);
9054 eval "use Crypt::UnixCrypt";
9055 if (!$@) {
9056         return Crypt::UnixCrypt::crypt($pass, $salt);
9057         }
9058 else {
9059         &error("Failed to encrypt password : $err");
9060         }
9061 }
9062
9063 =head2 split_quoted_string(string)
9064
9065 Given a string like I<foo "bar baz" quux>, returns the array :
9066 foo, bar baz, quux
9067
9068 =cut
9069 sub split_quoted_string
9070 {
9071 my ($str) = @_;
9072 my @rv;
9073 while($str =~ /^"([^"]*)"\s*([\000-\377]*)$/ ||
9074       $str =~ /^'([^']*)'\s*([\000-\377]*)$/ ||
9075       $str =~ /^(\S+)\s*([\000-\377]*)$/) {
9076         push(@rv, $1);
9077         $str = $2;
9078         }
9079 return @rv;
9080 }
9081
9082 =head2 write_to_http_cache(url, file|&data)
9083
9084 Updates the Webmin cache with the contents of the given file, possibly also
9085 clearing out old data. Mainly for internal use by http_download.
9086
9087 =cut
9088 sub write_to_http_cache
9089 {
9090 my ($url, $file) = @_;
9091 return 0 if (!$gconfig{'cache_size'});
9092
9093 # Don't cache downloads that look dynamic
9094 if ($url =~ /cgi-bin/ || $url =~ /\?/) {
9095         return 0;
9096         }
9097
9098 # Check if the current module should do caching
9099 if ($gconfig{'cache_mods'} =~ /^\!(.*)$/) {
9100         # Caching all except some modules
9101         my @mods = split(/\s+/, $1);
9102         return 0 if (&indexof(&get_module_name(), @mods) != -1);
9103         }
9104 elsif ($gconfig{'cache_mods'}) {
9105         # Only caching some modules
9106         my @mods = split(/\s+/, $gconfig{'cache_mods'});
9107         return 0 if (&indexof(&get_module_name(), @mods) == -1);
9108         }
9109
9110 # Work out the size
9111 my $size;
9112 if (ref($file)) {
9113         $size = length($$file);
9114         }
9115 else {
9116         my @st = stat($file);
9117         $size = $st[7];
9118         }
9119
9120 if ($size > $gconfig{'cache_size'}) {
9121         # Bigger than the whole cache - so don't save it
9122         return 0;
9123         }
9124 my $cfile = $url;
9125 $cfile =~ s/\//_/g;
9126 $cfile = "$main::http_cache_directory/$cfile";
9127
9128 # See how much we have cached currently, clearing old files
9129 my $total = 0;
9130 mkdir($main::http_cache_directory, 0700) if (!-d $main::http_cache_directory);
9131 opendir(CACHEDIR, $main::http_cache_directory);
9132 foreach my $f (readdir(CACHEDIR)) {
9133         next if ($f eq "." || $f eq "..");
9134         my $path = "$main::http_cache_directory/$f";
9135         my @st = stat($path);
9136         if ($gconfig{'cache_days'} &&
9137             time()-$st[9] > $gconfig{'cache_days'}*24*60*60) {
9138                 # This file is too old .. trash it
9139                 unlink($path);
9140                 }
9141         else {
9142                 $total += $st[7];
9143                 push(@cached, [ $path, $st[7], $st[9] ]);
9144                 }
9145         }
9146 closedir(CACHEDIR);
9147 @cached = sort { $a->[2] <=> $b->[2] } @cached;
9148 while($total+$size > $gconfig{'cache_size'} && @cached) {
9149         # Cache is too big .. delete some files until the new one will fit
9150         unlink($cached[0]->[0]);
9151         $total -= $cached[0]->[1];
9152         shift(@cached);
9153         }
9154
9155 # Finally, write out the new file
9156 if (ref($file)) {
9157         &open_tempfile(CACHEFILE, ">$cfile");
9158         &print_tempfile(CACHEFILE, $$file);
9159         &close_tempfile(CACHEFILE);
9160         }
9161 else {
9162         my ($ok, $err) = &copy_source_dest($file, $cfile);
9163         }
9164
9165 return 1;
9166 }
9167
9168 =head2 check_in_http_cache(url)
9169
9170 If some URL is in the cache and valid, return the filename for it. Mainly
9171 for internal use by http_download.
9172
9173 =cut
9174 sub check_in_http_cache
9175 {
9176 my ($url) = @_;
9177 return undef if (!$gconfig{'cache_size'});
9178
9179 # Check if the current module should do caching
9180 if ($gconfig{'cache_mods'} =~ /^\!(.*)$/) {
9181         # Caching all except some modules
9182         my @mods = split(/\s+/, $1);
9183         return 0 if (&indexof(&get_module_name(), @mods) != -1);
9184         }
9185 elsif ($gconfig{'cache_mods'}) {
9186         # Only caching some modules
9187         my @mods = split(/\s+/, $gconfig{'cache_mods'});
9188         return 0 if (&indexof(&get_module_name(), @mods) == -1);
9189         }
9190
9191 my $cfile = $url;
9192 $cfile =~ s/\//_/g;
9193 $cfile = "$main::http_cache_directory/$cfile";
9194 my @st = stat($cfile);
9195 return undef if (!@st || !$st[7]);
9196 if ($gconfig{'cache_days'} && time()-$st[9] > $gconfig{'cache_days'}*24*60*60) {
9197         # Too old!
9198         unlink($cfile);
9199         return undef;
9200         }
9201 open(TOUCH, ">>$cfile");        # Update the file time, to keep it in the cache
9202 close(TOUCH);
9203 return $cfile;
9204 }
9205
9206 =head2 supports_javascript
9207
9208 Returns 1 if the current browser is assumed to support javascript.
9209
9210 =cut
9211 sub supports_javascript
9212 {
9213 if (defined(&theme_supports_javascript)) {
9214         return &theme_supports_javascript();
9215         }
9216 return $ENV{'MOBILE_DEVICE'} ? 0 : 1;
9217 }
9218
9219 =head2 get_module_name
9220
9221 Returns the name of the Webmin module that called this function. For internal
9222 use only by other API functions.
9223
9224 =cut
9225 sub get_module_name
9226 {
9227 return &get_module_variable('$module_name');
9228 }
9229
9230 =head2 get_module_variable(name, [ref])
9231
9232 Returns the value of some variable which is set in the caller's context, if
9233 using the new WebminCore package. For internal use only.
9234
9235 =cut
9236 sub get_module_variable
9237 {
9238 my ($v, $wantref) = @_;
9239 my $slash = $wantref ? "\\" : "";
9240 my $thispkg = &web_libs_package();
9241 if ($thispkg eq 'WebminCore') {
9242         my ($vt, $vn) = split('', $v, 2);
9243         my $callpkg;
9244         for(my $i=0; ($callpkg) = caller($i); $i++) {
9245                 last if ($callpkg ne $thispkg);
9246                 }
9247         return eval "${slash}${vt}${callpkg}::${vn}";
9248         }
9249 return eval "${slash}${v}";
9250 }
9251
9252 =head2 clear_time_locale()
9253
9254 Temporarily force the locale to C, until reset_time_locale is called. This is
9255 useful if your code is going to call C<strftime> from the POSIX package, and
9256 you want to ensure that the output is in a consistent format.
9257
9258 =cut
9259 sub clear_time_locale
9260 {
9261 if ($main::clear_time_locale_count == 0) {
9262         eval {
9263                 use POSIX;
9264                 $main::clear_time_locale_old = POSIX::setlocale(POSIX::LC_TIME);
9265                 POSIX::setlocale(POSIX::LC_TIME, "C");
9266                 };
9267         }
9268 $main::clear_time_locale_count++;
9269 }
9270
9271 =head2 reset_time_locale()
9272
9273 Revert the locale to whatever it was before clear_time_locale was called
9274
9275 =cut
9276 sub reset_time_locale
9277 {
9278 if ($main::clear_time_locale_count == 1) {
9279         eval {
9280                 POSIX::setlocale(POSIX::LC_TIME, $main::clear_time_locale_old);
9281                 $main::clear_time_locale_old = undef;
9282                 };
9283         }
9284 $main::clear_time_locale_count--;
9285 }
9286
9287 =head2 callers_package(filehandle)
9288
9289 Convert a non-module filehandle like FOO to one qualified with the
9290 caller's caller's package, like fsdump::FOO. For internal use only.
9291
9292 =cut
9293 sub callers_package
9294 {
9295 my ($fh) = @_;
9296 my $callpkg = (caller(1))[0];
9297 my $thispkg = &web_libs_package();
9298 if (!ref($fh) && $fh !~ /::/ &&
9299     $callpkg ne $thispkg && $thispkg eq 'WebminCore') {
9300         $fh = $callpkg."::".$fh;
9301         }
9302 return $fh;
9303 }
9304
9305 =head2 web_libs_package()
9306
9307 Returns the package this code is in. We can't always trust __PACKAGE__. For
9308 internal use only.
9309
9310 =cut
9311 sub web_libs_package
9312 {
9313 if ($called_from_webmin_core) {
9314         return "WebminCore";
9315         }
9316 return __PACKAGE__;
9317 }
9318
9319 =head2 get_userdb_string
9320
9321 Returns the URL-style string for connecting to the users and groups database
9322
9323 =cut
9324 sub get_userdb_string
9325 {
9326 return undef if ($main::no_miniserv_userdb);
9327 my %miniserv;
9328 &get_miniserv_config(\%miniserv);
9329 return $miniserv{'userdb'};
9330 }
9331
9332 =head2 connect_userdb(string)
9333
9334 Returns a handle for talking to a user database - may be a DBI or LDAP handle.
9335 On failure returns an error message string. In an array context, returns the
9336 protocol type too.
9337
9338 =cut
9339 sub connect_userdb
9340 {
9341 my ($str) = @_;
9342 my ($proto, $user, $pass, $host, $prefix, $args) = &split_userdb_string($str);
9343 if ($proto eq "mysql") {
9344         # Connect to MySQL with DBI
9345         my $drh = eval "use DBI; DBI->install_driver('mysql');";
9346         $drh || return $text{'sql_emysqldriver'};
9347         my ($host, $port) = split(/:/, $host);
9348         my $cstr = "database=$prefix;host=$host";
9349         $cstr .= ";port=$port" if ($port);
9350         my $dbh = $drh->connect($cstr, $user, $pass, { });
9351         $dbh || return &text('sql_emysqlconnect', $drh->errstr);
9352         return wantarray ? ($dbh, $proto, $prefix, $args) : $dbh;
9353         }
9354 elsif ($proto eq "postgresql") {
9355         # Connect to PostgreSQL with DBI
9356         my $drh = eval "use DBI; DBI->install_driver('Pg');";
9357         $drh || return $text{'sql_epostgresqldriver'};
9358         my ($host, $port) = split(/:/, $host);
9359         my $cstr = "dbname=$prefix;host=$host";
9360         $cstr .= ";port=$port" if ($port);
9361         my $dbh = $drh->connect($cstr, $user, $pass);
9362         $dbh || return &text('sql_epostgresqlconnect', $drh->errstr);
9363         return wantarray ? ($dbh, $proto, $prefix, $args) : $dbh;
9364         }
9365 elsif ($proto eq "ldap") {
9366         # Connect with perl LDAP module
9367         eval "use Net::LDAP";
9368         $@ && return $text{'sql_eldapdriver'};
9369         my ($host, $port) = split(/:/, $host);
9370         my $scheme = $args->{'scheme'} || 'ldap';
9371         if (!$port) {
9372                 $port = $scheme eq 'ldaps' ? 636 : 389;
9373                 }
9374         my $ldap = Net::LDAP->new($host,
9375                                   port => $port,
9376                                   'scheme' => $scheme);
9377         $ldap || return &text('sql_eldapconnect', $host);
9378         my $mesg;
9379         if ($args->{'tls'}) {
9380                 # Switch to TLS mode
9381                 eval { $mesg = $ldap->start_tls(); };
9382                 if ($@ || !$mesg || $mesg->code) {
9383                         return &text('sql_eldaptls',
9384                             $@ ? $@ : $mesg ? $mesg->error : "Unknown error");
9385                         }
9386                 }
9387         # Login to the server
9388         if ($pass) {
9389                 $mesg = $ldap->bind(dn => $user, password => $pass);
9390                 }
9391         else {
9392                 $mesg = $ldap->bind(dn => $user, anonymous => 1);
9393                 }
9394         if (!$mesg || $mesg->code) {
9395                 return &text('sql_eldaplogin', $user,
9396                              $mesg ? $mesg->error : "Unknown error");
9397                 }
9398         return wantarray ? ($ldap, $proto, $prefix, $args) : $ldap;
9399         }
9400 else {
9401         return "Unknown protocol $proto";
9402         }
9403 }
9404
9405 =head2 disconnect_userdb(string, &handle)
9406
9407 Closes a handle opened by connect_userdb
9408
9409 =cut
9410 sub disconnect_userdb
9411 {
9412 my ($str, $h) = @_;
9413 if ($str =~ /^(mysql|postgresql):/) {
9414         # DBI disconnnect
9415         if (!$h->{'AutoCommit'}) {
9416                 $h->commit();
9417                 }
9418         $h->disconnect();
9419         }
9420 elsif ($str =~ /^ldap:/) {
9421         # LDAP disconnect
9422         $h->unbind();
9423         $h->disconnect();
9424         }
9425 }
9426
9427 =head2 split_userdb_string(string)
9428
9429 Converts a string like mysql://user:pass@host/db into separate parts
9430
9431 =cut
9432 sub split_userdb_string
9433 {
9434 my ($str) = @_;
9435 if ($str =~ /^([a-z]+):\/\/([^:]*):([^\@]*)\@([a-z0-9\.\-\_]+)\/([^\?]+)(\?(.*))?$/) {
9436         my ($proto, $user, $pass, $host, $prefix, $argstr) =
9437                 ($1, $2, $3, $4, $5, $7);
9438         my %args = map { split(/=/, $_, 2) } split(/\&/, $argstr);
9439         return ($proto, $user, $pass, $host, $prefix, \%args);
9440         }
9441 return ( );
9442 }
9443
9444 $done_web_lib_funcs = 1;
9445
9446 1;