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