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