web-lib-funcs.pl

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