web-lib-funcs.pl

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