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