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