web-lib-funcs.pl

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