web-lib-funcs.pl

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