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