web-lib-funcs.pl

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