web-lib-funcs.pl

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