web-lib-funcs.pl

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