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