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 close($h->{'fh'});
6189 }
6190
6191 =head2 clean_environment
6192
6193 Deletes any environment variables inherited from miniserv so that they
6194 won't be passed to programs started by webmin. This is useful when calling
6195 programs that check for CGI-related environment variables and modify their
6196 behaviour, and to avoid passing sensitive variables to un-trusted programs.
6197
6198 =cut
6199 sub clean_environment
6200 {
6201 %UNCLEAN_ENV = %ENV;
6202 foreach my $k (keys %ENV) {
6203         if ($k =~ /^(HTTP|VIRTUALSERVER|QUOTA|USERADMIN)_/) {
6204                 delete($ENV{$k});
6205                 }
6206         }
6207 foreach my $e ('WEBMIN_CONFIG', 'SERVER_NAME', 'CONTENT_TYPE', 'REQUEST_URI',
6208             'PATH_INFO', 'WEBMIN_VAR', 'REQUEST_METHOD', 'GATEWAY_INTERFACE',
6209             'QUERY_STRING', 'REMOTE_USER', 'SERVER_SOFTWARE', 'SERVER_PROTOCOL',
6210             'REMOTE_HOST', 'SERVER_PORT', 'DOCUMENT_ROOT', 'SERVER_ROOT',
6211             'MINISERV_CONFIG', 'SCRIPT_NAME', 'SERVER_ADMIN', 'CONTENT_LENGTH',
6212             'HTTPS', 'FOREIGN_MODULE_NAME', 'FOREIGN_ROOT_DIRECTORY',
6213             'SCRIPT_FILENAME', 'PATH_TRANSLATED', 'BASE_REMOTE_USER',
6214             'DOCUMENT_REALROOT', 'MINISERV_CONFIG', 'MYSQL_PWD') {
6215         delete($ENV{$e});
6216         }
6217 }
6218
6219 =head2 reset_environment
6220
6221 Puts the environment back how it was before clean_environment was callled.
6222
6223 =cut
6224 sub reset_environment
6225 {
6226 if (defined(%UNCLEAN_ENV)) {
6227         foreach my $k (keys %UNCLEAN_ENV) {
6228                 $ENV{$k} = $UNCLEAN_ENV{$k};
6229                 }
6230         undef(%UNCLEAN_ENV);
6231         }
6232 }
6233
6234 =head2 progress_callback
6235
6236 Never called directly, but useful for passing to &http_download to print
6237 out progress of an HTTP request.
6238
6239 =cut
6240 sub progress_callback
6241 {
6242 if (defined(&theme_progress_callback)) {
6243         # Call the theme override
6244         return &theme_progress_callback(@_);
6245         }
6246 if ($_[0] == 2) {
6247         # Got size
6248         print $progress_callback_prefix;
6249         if ($_[1]) {
6250                 $progress_size = $_[1];
6251                 $progress_step = int($_[1] / 10);
6252                 print &text('progress_size', $progress_callback_url,
6253                             $progress_size),"<br>\n";
6254                 }
6255         else {
6256                 print &text('progress_nosize', $progress_callback_url),"<br>\n";
6257                 }
6258         $last_progress_time = $last_progress_size = undef;
6259         }
6260 elsif ($_[0] == 3) {
6261         # Got data update
6262         my $sp = $progress_callback_prefix.("&nbsp;" x 5);
6263         if ($progress_size) {
6264                 # And we have a size to compare against
6265                 my $st = int(($_[1] * 10) / $progress_size);
6266                 my $time_now = time();
6267                 if ($st != $progress_step ||
6268                     $time_now - $last_progress_time > 60) {
6269                         # Show progress every 10% or 60 seconds
6270                         print $sp,&text('progress_data', $_[1], int($_[1]*100/$progress_size)),"<br>\n";
6271                         $last_progress_time = $time_now;
6272                         }
6273                 $progress_step = $st;
6274                 }
6275         else {
6276                 # No total size .. so only show in 100k jumps
6277                 if ($_[1] > $last_progress_size+100*1024) {
6278                         print $sp,&text('progress_data2', $_[1]),"<br>\n";
6279                         $last_progress_size = $_[1];
6280                         }
6281                 }
6282         }
6283 elsif ($_[0] == 4) {
6284         # All done downloading
6285         print $progress_callback_prefix,&text('progress_done'),"<br>\n";
6286         }
6287 elsif ($_[0] == 5) {
6288         # Got new location after redirect
6289         $progress_callback_url = $_[1];
6290         }
6291 elsif ($_[0] == 6) {
6292         # URL is in cache
6293         $progress_callback_url = $_[1];
6294         print &text('progress_incache', $progress_callback_url),"<br>\n";
6295         }
6296 }
6297
6298 =head2 switch_to_remote_user
6299
6300 Changes the user and group of the current process to that of the unix user
6301 with the same name as the current webmin login, or fails if there is none.
6302 This should be called by Usermin module scripts that only need to run with
6303 limited permissions.
6304
6305 =cut
6306 sub switch_to_remote_user
6307 {
6308 @remote_user_info = $remote_user ? getpwnam($remote_user) :
6309                                    getpwuid($<);
6310 @remote_user_info || &error(&text('switch_remote_euser', $remote_user));
6311 &create_missing_homedir(\@remote_user_info);
6312 if ($< == 0) {
6313         &switch_to_unix_user(\@remote_user_info);
6314         $ENV{'USER'} = $ENV{'LOGNAME'} = $remote_user;
6315         $ENV{'HOME'} = $remote_user_info[7];
6316         }
6317 # Export global variables to caller
6318 if ($main::export_to_caller) {
6319         my ($callpkg) = caller();
6320         eval "\@${callpkg}::remote_user_info = \@remote_user_info";
6321         }
6322 }
6323
6324 =head2 switch_to_unix_user(&user-details)
6325
6326 Switches the current process to the UID and group ID from the given list
6327 of user details, which must be in the format returned by getpwnam.
6328
6329 =cut
6330 sub switch_to_unix_user
6331 {
6332 my ($uinfo) = @_;
6333 if (!defined($uinfo->[0])) {
6334         # No username given, so just use given GID
6335         ($(, $)) = ( $uinfo->[3], "$uinfo->[3] $uinfo->[3]" );
6336         }
6337 else {
6338         # Use all groups from user
6339         ($(, $)) = ( $uinfo->[3],
6340                      "$uinfo->[3] ".join(" ", $uinfo->[3],
6341                                          &other_groups($uinfo->[0])) );
6342         }
6343 eval {
6344         POSIX::setuid($uinfo->[2]);
6345         };
6346 if ($< != $uinfo->[2] || $> != $uinfo->[2]) {
6347         ($>, $<) = ( $uinfo->[2], $uinfo->[2] );
6348         }
6349 }
6350
6351 =head2 eval_as_unix_user(username, &code)
6352
6353 Runs some code fragment with the effective UID and GID switch to that
6354 of the given Unix user, so that file IO takes place with his permissions.
6355
6356 =cut
6357
6358 sub eval_as_unix_user
6359 {
6360 my ($user, $code) = @_;
6361 my @uinfo = getpwnam($user);
6362 defined(@uinfo) || &error("eval_as_unix_user called with invalid user $user");
6363 $) = $uinfo[3]." ".join(" ", $uinfo[3], &other_groups($user));
6364 $> = $uinfo[2];
6365 my @rv;
6366 eval {
6367         local $main::error_must_die = 1;
6368         @rv = &$code();
6369         };
6370 my $err = $@;
6371 $) = 0;
6372 $> = 0;
6373 if ($err) {
6374         $err =~ s/\s+at\s+(\/\S+)\s+line\s+(\d+)\.?//;
6375         &error($err);
6376         }
6377 return wantarray ? @rv : $rv[0];
6378 }
6379
6380 =head2 create_user_config_dirs
6381
6382 Creates per-user config directories and sets $user_config_directory and
6383 $user_module_config_directory to them. Also reads per-user module configs
6384 into %userconfig. This should be called by Usermin module scripts that need
6385 to store per-user preferences or other settings.
6386
6387 =cut
6388 sub create_user_config_dirs
6389 {
6390 return if (!$gconfig{'userconfig'});
6391 my @uinfo = @remote_user_info ? @remote_user_info : getpwnam($remote_user);
6392 return if (!@uinfo || !$uinfo[7]);
6393 &create_missing_homedir(\@uinfo);
6394 $user_config_directory = "$uinfo[7]/$gconfig{'userconfig'}";
6395 if (!-d $user_config_directory) {
6396         mkdir($user_config_directory, 0700) ||
6397                 &error("Failed to create $user_config_directory : $!");
6398         if ($< == 0 && $uinfo[2]) {
6399                 chown($uinfo[2], $uinfo[3], $user_config_directory);
6400                 }
6401         }
6402 if (&get_module_name()) {
6403         $user_module_config_directory = $user_config_directory."/".
6404                                         &get_module_name();
6405         if (!-d $user_module_config_directory) {
6406                 mkdir($user_module_config_directory, 0700) ||
6407                         &error("Failed to create $user_module_config_directory : $!");
6408                 if ($< == 0 && $uinfo[2]) {
6409                         chown($uinfo[2], $uinfo[3], $user_config_directory);
6410                         }
6411                 }
6412         undef(%userconfig);
6413         &read_file_cached("$module_root_directory/defaultuconfig",
6414                           \%userconfig);
6415         &read_file_cached("$module_config_directory/uconfig", \%userconfig);
6416         &read_file_cached("$user_module_config_directory/config",
6417                           \%userconfig);
6418         }
6419
6420 # Export global variables to caller
6421 if ($main::export_to_caller) {
6422         my ($callpkg) = caller();
6423         foreach my $v ('$user_config_directory',
6424                        '$user_module_config_directory', '%userconfig') {
6425                 my ($vt, $vn) = split('', $v, 2);
6426                 eval "${vt}${callpkg}::${vn} = ${vt}${vn}";
6427                 }
6428         }
6429 }
6430
6431 =head2 create_missing_homedir(&uinfo)
6432
6433 If auto homedir creation is enabled, create one for this user if needed.
6434 For internal use only.
6435
6436 =cut
6437 sub create_missing_homedir
6438 {
6439 my ($uinfo) = @_;
6440 if (!-e $uinfo->[7] && $gconfig{'create_homedir'}) {
6441         # Use has no home dir .. make one
6442         system("mkdir -p ".quotemeta($uinfo->[7]));
6443         chown($uinfo->[2], $uinfo->[3], $uinfo->[7]);
6444         if ($gconfig{'create_homedir_perms'} ne '') {
6445                 chmod(oct($gconfig{'create_homedir_perms'}), $uinfo->[7]);
6446                 }
6447         }
6448 }
6449
6450 =head2 filter_javascript(text)
6451
6452 Disables all javascript <script>, onClick= and so on tags in the given HTML,
6453 and returns the new HTML. Useful for displaying HTML from an un-trusted source.
6454
6455 =cut
6456 sub filter_javascript
6457 {
6458 my ($rv) = @_;
6459 $rv =~ s/<\s*script[^>]*>([\000-\377]*?)<\s*\/script\s*>//gi;
6460 $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;
6461 $rv =~ s/(javascript:)/x$1/gi;
6462 $rv =~ s/(vbscript:)/x$1/gi;
6463 return $rv;
6464 }
6465
6466 =head2 resolve_links(path)
6467
6468 Given a path that may contain symbolic links, returns the real path.
6469
6470 =cut
6471 sub resolve_links
6472 {
6473 my ($path) = @_;
6474 $path =~ s/\/+/\//g;
6475 $path =~ s/\/$// if ($path ne "/");
6476 my @p = split(/\/+/, $path);
6477 shift(@p);
6478 for(my $i=0; $i<@p; $i++) {
6479         my $sofar = "/".join("/", @p[0..$i]);
6480         my $lnk = readlink($sofar);
6481         if ($lnk =~ /^\//) {
6482                 # Link is absolute..
6483                 return &resolve_links($lnk."/".join("/", @p[$i+1 .. $#p]));
6484                 }
6485         elsif ($lnk) {
6486                 # Link is relative
6487                 return &resolve_links("/".join("/", @p[0..$i-1])."/".$lnk."/".join("/", @p[$i+1 .. $#p]));
6488                 }
6489         }
6490 return $path;
6491 }
6492
6493 =head2 simplify_path(path, bogus)
6494
6495 Given a path, maybe containing elements ".." and "." , convert it to a
6496 clean, absolute form. Returns undef if this is not possible.
6497
6498 =cut
6499 sub simplify_path
6500 {
6501 my ($dir) = @_;
6502 $dir =~ s/^\/+//g;
6503 $dir =~ s/\/+$//g;
6504 my @bits = split(/\/+/, $dir);
6505 my @fixedbits = ();
6506 $_[1] = 0;
6507 foreach my $b (@bits) {
6508         if ($b eq ".") {
6509                 # Do nothing..
6510                 }
6511         elsif ($b eq "..") {
6512                 # Remove last dir
6513                 if (scalar(@fixedbits) == 0) {
6514                         # Cannot! Already at root!
6515                         return undef;
6516                         }
6517                 pop(@fixedbits);
6518                 }
6519         else {
6520                 # Add dir to list
6521                 push(@fixedbits, $b);
6522                 }
6523         }
6524 return "/".join('/', @fixedbits);
6525 }
6526
6527 =head2 same_file(file1, file2)
6528
6529 Returns 1 if two files are actually the same
6530
6531 =cut
6532 sub same_file
6533 {
6534 return 1 if ($_[0] eq $_[1]);
6535 return 0 if ($_[0] !~ /^\// || $_[1] !~ /^\//);
6536 my @stat1 = $stat_cache{$_[0]} ? @{$stat_cache{$_[0]}}
6537                                : (@{$stat_cache{$_[0]}} = stat($_[0]));
6538 my @stat2 = $stat_cache{$_[1]} ? @{$stat_cache{$_[1]}}
6539                                : (@{$stat_cache{$_[1]}} = stat($_[1]));
6540 return 0 if (!@stat1 || !@stat2);
6541 return $stat1[0] == $stat2[0] && $stat1[1] == $stat2[1];
6542 }
6543
6544 =head2 flush_webmin_caches
6545
6546 Clears all in-memory and on-disk caches used by Webmin.
6547
6548 =cut
6549 sub flush_webmin_caches
6550 {
6551 undef(%main::read_file_cache);
6552 undef(%main::acl_hash_cache);
6553 undef(%main::acl_array_cache);
6554 undef(%main::has_command_cache);
6555 undef(@main::list_languages_cache);
6556 undef($main::got_list_usermods_cache);
6557 undef(@main::list_usermods_cache);
6558 undef(%main::foreign_installed_cache);
6559 unlink("$config_directory/module.infos.cache");
6560 &get_all_module_infos();
6561 }
6562
6563 =head2 list_usermods
6564
6565 Returns a list of additional module restrictions. For internal use in
6566 Usermin only.
6567
6568 =cut
6569 sub list_usermods
6570 {
6571 if (!$main::got_list_usermods_cache) {
6572         @main::list_usermods_cache = ( );
6573         local $_;
6574         open(USERMODS, "$config_directory/usermin.mods");
6575         while(<USERMODS>) {
6576                 if (/^([^:]+):(\+|-|):(.*)/) {
6577                         push(@main::list_usermods_cache,
6578                              [ $1, $2, [ split(/\s+/, $3) ] ]);
6579                         }
6580                 }
6581         close(USERMODS);
6582         $main::got_list_usermods_cache = 1;
6583         }
6584 return @main::list_usermods_cache;
6585 }
6586
6587 =head2 available_usermods(&allmods, &usermods)
6588
6589 Returns a list of modules that are available to the given user, based
6590 on usermod additional/subtractions. For internal use by Usermin only.
6591
6592 =cut
6593 sub available_usermods
6594 {
6595 return @{$_[0]} if (!@{$_[1]});
6596
6597 my %mods = map { $_->{'dir'}, 1 } @{$_[0]};
6598 my @uinfo = @remote_user_info;
6599 @uinfo = getpwnam($remote_user) if (!@uinfo);
6600 foreach my $u (@{$_[1]}) {
6601         my $applies;
6602         if ($u->[0] eq "*" || $u->[0] eq $remote_user) {
6603                 $applies++;
6604                 }
6605         elsif ($u->[0] =~ /^\@(.*)$/) {
6606                 # Check for group membership
6607                 my @ginfo = getgrnam($1);
6608                 $applies++ if (@ginfo && ($ginfo[2] == $uinfo[3] ||
6609                         &indexof($remote_user, split(/\s+/, $ginfo[3])) >= 0));
6610                 }
6611         elsif ($u->[0] =~ /^\//) {
6612                 # Check users and groups in file
6613                 local $_;
6614                 open(USERFILE, $u->[0]);
6615                 while(<USERFILE>) {
6616                         tr/\r\n//d;
6617                         if ($_ eq $remote_user) {
6618                                 $applies++;
6619                                 }
6620                         elsif (/^\@(.*)$/) {
6621                                 my @ginfo = getgrnam($1);
6622                                 $applies++
6623                                   if (@ginfo && ($ginfo[2] == $uinfo[3] ||
6624                                       &indexof($remote_user,
6625                                                split(/\s+/, $ginfo[3])) >= 0));
6626                                 }
6627                         last if ($applies);
6628                         }
6629                 close(USERFILE);
6630                 }
6631         if ($applies) {
6632                 if ($u->[1] eq "+") {
6633                         map { $mods{$_}++ } @{$u->[2]};
6634                         }
6635                 elsif ($u->[1] eq "-") {
6636                         map { delete($mods{$_}) } @{$u->[2]};
6637                         }
6638                 else {
6639                         undef(%mods);
6640                         map { $mods{$_}++ } @{$u->[2]};
6641                         }
6642                 }
6643         }
6644 return grep { $mods{$_->{'dir'}} } @{$_[0]};
6645 }
6646
6647 =head2 get_available_module_infos(nocache)
6648
6649 Returns a list of modules available to the current user, based on
6650 operating system support, access control and usermod restrictions. Useful
6651 in themes that need to display a list of modules the user can use.
6652 Each element of the returned array is a hash reference in the same format as
6653 returned by get_module_info.
6654
6655 =cut
6656 sub get_available_module_infos
6657 {
6658 my (%acl, %uacl);
6659 &read_acl(\%acl, \%uacl);
6660 my $risk = $gconfig{'risk_'.$base_remote_user};
6661 my @rv;
6662 foreach my $minfo (&get_all_module_infos($_[0])) {
6663         next if (!&check_os_support($minfo));
6664         if ($risk) {
6665                 # Check module risk level
6666                 next if ($risk ne 'high' && $minfo->{'risk'} &&
6667                          $minfo->{'risk'} !~ /$risk/);
6668                 }
6669         else {
6670                 # Check user's ACL
6671                 next if (!$acl{$base_remote_user,$minfo->{'dir'}} &&
6672                          !$acl{$base_remote_user,"*"});
6673                 }
6674         next if (&is_readonly_mode() && !$minfo->{'readonly'});
6675         push(@rv, $minfo);
6676         }
6677
6678 # Check usermod restrictions
6679 my @usermods = &list_usermods();
6680 @rv = sort { $a->{'desc'} cmp $b->{'desc'} }
6681             &available_usermods(\@rv, \@usermods);
6682
6683 # Check RBAC restrictions
6684 my @rbacrv;
6685 foreach my $m (@rv) {
6686         if (&supports_rbac($m->{'dir'}) &&
6687             &use_rbac_module_acl(undef, $m->{'dir'})) {
6688                 local $rbacs = &get_rbac_module_acl($remote_user,
6689                                                     $m->{'dir'});
6690                 if ($rbacs) {
6691                         # RBAC allows
6692                         push(@rbacrv, $m);
6693                         }
6694                 }
6695         else {
6696                 # Module or system doesn't support RBAC
6697                 push(@rbacrv, $m) if (!$gconfig{'rbacdeny_'.$base_remote_user});
6698                 }
6699         }
6700
6701 # Check theme vetos
6702 my @themerv;
6703 if (defined(&theme_foreign_available)) {
6704         foreach my $m (@rbacrv) {
6705                 if (&theme_foreign_available($m->{'dir'})) {
6706                         push(@themerv, $m);
6707                         }
6708                 }
6709         }
6710 else {
6711         @themerv = @rbacrv;
6712         }
6713
6714 # Check licence module vetos
6715 my @licrv;
6716 if ($main::licence_module) {
6717         foreach my $m (@themerv) {
6718                 if (&foreign_call($main::licence_module,
6719                                   "check_module_licence", $m->{'dir'})) {
6720                         push(@licrv, $m);
6721                         }
6722                 }
6723         }
6724 else {
6725         @licrv = @themerv;
6726         }
6727
6728 return @licrv;
6729 }
6730
6731 =head2 get_visible_module_infos(nocache)
6732
6733 Like get_available_module_infos, but excludes hidden modules from the list.
6734 Each element of the returned array is a hash reference in the same format as
6735 returned by get_module_info.
6736
6737 =cut
6738 sub get_visible_module_infos
6739 {
6740 my ($nocache) = @_;
6741 my $pn = &get_product_name();
6742 return grep { !$_->{'hidden'} &&
6743               !$_->{$pn.'_hidden'} } &get_available_module_infos($nocache);
6744 }
6745
6746 =head2 get_visible_modules_categories(nocache)
6747
6748 Returns a list of Webmin module categories, each of which is a hash ref
6749 with 'code', 'desc' and 'modules' keys. The modules value is an array ref
6750 of modules in the category, in the format returned by get_module_info.
6751 Un-used modules are automatically assigned to the 'unused' category, and
6752 those with no category are put into 'others'.
6753
6754 =cut
6755 sub get_visible_modules_categories
6756 {
6757 my ($nocache) = @_;
6758 my @mods = &get_visible_module_infos($nocache);
6759 my @unmods;
6760 if (&get_product_name() eq 'webmin') {
6761         @unmods = grep { $_->{'installed'} eq '0' } @mods;
6762         @mods = grep { $_->{'installed'} ne '0' } @mods;
6763         }
6764 my %cats = &list_categories(\@mods);
6765 my @rv;
6766 foreach my $c (keys %cats) {
6767         my $cat = { 'code' => $c || 'other',
6768                     'desc' => $cats{$c} };
6769         $cat->{'modules'} = [ grep { $_->{'category'} eq $c } @mods ];
6770         push(@rv, $cat);
6771         }
6772 @rv = sort { ($b->{'code'} eq "others" ? "" : $b->{'code'}) cmp
6773              ($a->{'code'} eq "others" ? "" : $a->{'code'}) } @rv;
6774 if (@unmods) {
6775         # Add un-installed modules in magic category
6776         my $cat = { 'code' => 'unused',
6777                     'desc' => $text{'main_unused'},
6778                     'unused' => 1,
6779                     'modules' => \@unmods };
6780         push(@rv, $cat);
6781         }
6782 return @rv;
6783 }
6784
6785 =head2 is_under_directory(directory, file)
6786
6787 Returns 1 if the given file is under the specified directory, 0 if not.
6788 Symlinks are taken into account in the file to find it's 'real' location.
6789
6790 =cut
6791 sub is_under_directory
6792 {
6793 my ($dir, $file) = @_;
6794 return 1 if ($dir eq "/");
6795 return 0 if ($file =~ /\.\./);
6796 my $ld = &resolve_links($dir);
6797 if ($ld ne $dir) {
6798         return &is_under_directory($ld, $file);
6799         }
6800 my $lp = &resolve_links($file);
6801 if ($lp ne $file) {
6802         return &is_under_directory($dir, $lp);
6803         }
6804 return 0 if (length($file) < length($dir));
6805 return 1 if ($dir eq $file);
6806 $dir =~ s/\/*$/\//;
6807 return substr($file, 0, length($dir)) eq $dir;
6808 }
6809
6810 =head2 parse_http_url(url, [basehost, baseport, basepage, basessl])
6811
6812 Given an absolute URL, returns the host, port, page and ssl flag components.
6813 Relative URLs can also be parsed, if the base information is provided.
6814
6815 =cut
6816 sub parse_http_url
6817 {
6818 if ($_[0] =~ /^(http|https):\/\/([^:\/]+)(:(\d+))?(\/\S*)?$/) {
6819         # An absolute URL
6820         my $ssl = $1 eq 'https';
6821         return ($2, $3 ? $4 : $ssl ? 443 : 80, $5 || "/", $ssl);
6822         }
6823 elsif (!$_[1]) {
6824         # Could not parse
6825         return undef;
6826         }
6827 elsif ($_[0] =~ /^\/\S*$/) {
6828         # A relative to the server URL
6829         return ($_[1], $_[2], $_[0], $_[4]);
6830         }
6831 else {
6832         # A relative to the directory URL
6833         my $page = $_[3];
6834         $page =~ s/[^\/]+$//;
6835         return ($_[1], $_[2], $page.$_[0], $_[4]);
6836         }
6837 }
6838
6839 =head2 check_clicks_function
6840
6841 Returns HTML for a JavaScript function called check_clicks that returns
6842 true when first called, but false subsequently. Useful on onClick for
6843 critical buttons. Deprecated, as this method of preventing duplicate actions
6844 is un-reliable.
6845
6846 =cut
6847 sub check_clicks_function
6848 {
6849 return <<EOF;
6850 <script>
6851 clicks = 0;
6852 function check_clicks(form)
6853 {
6854 clicks++;
6855 if (clicks == 1)
6856         return true;
6857 else {
6858         if (form != null) {
6859                 for(i=0; i<form.length; i++)
6860                         form.elements[i].disabled = true;
6861                 }
6862         return false;
6863         }
6864 }
6865 </script>
6866 EOF
6867 }
6868
6869 =head2 load_entities_map
6870
6871 Returns a hash ref containing mappings between HTML entities (like ouml) and
6872 ascii values (like 246). Mainly for internal use.
6873
6874 =cut
6875 sub load_entities_map
6876 {
6877 if (!defined(%entities_map_cache)) {
6878         local $_;
6879         open(EMAP, "$root_directory/entities_map.txt");
6880         while(<EMAP>) {
6881                 if (/^(\d+)\s+(\S+)/) {
6882                         $entities_map_cache{$2} = $1;
6883                         }
6884                 }
6885         close(EMAP);
6886         }
6887 return \%entities_map_cache;
6888 }
6889
6890 =head2 entities_to_ascii(string)
6891
6892 Given a string containing HTML entities like &ouml; and &#55;, replace them
6893 with their ASCII equivalents.
6894
6895 =cut
6896 sub entities_to_ascii
6897 {
6898 my ($str) = @_;
6899 my $emap = &load_entities_map();
6900 $str =~ s/&([a-z]+);/chr($emap->{$1})/ge;
6901 $str =~ s/&#(\d+);/chr($1)/ge;
6902 return $str;
6903 }
6904
6905 =head2 get_product_name
6906
6907 Returns either 'webmin' or 'usermin', depending on which program the current
6908 module is in. Useful for modules that can be installed into either.
6909
6910 =cut
6911 sub get_product_name
6912 {
6913 return $gconfig{'product'} if (defined($gconfig{'product'}));
6914 return defined($gconfig{'userconfig'}) ? 'usermin' : 'webmin';
6915 }
6916
6917 =head2 get_charset
6918
6919 Returns the character set for the current language, such as iso-8859-1.
6920
6921 =cut
6922 sub get_charset
6923 {
6924 my $charset = defined($gconfig{'charset'}) ? $gconfig{'charset'} :
6925                  $current_lang_info->{'charset'} ?
6926                  $current_lang_info->{'charset'} : $default_charset;
6927 return $charset;
6928 }
6929
6930 =head2 get_display_hostname
6931
6932 Returns the system's hostname for UI display purposes. This may be different
6933 from the actual hostname if you administrator has configured it so in the
6934 Webmin Configuration module.
6935
6936 =cut
6937 sub get_display_hostname
6938 {
6939 if ($gconfig{'hostnamemode'} == 0) {
6940         return &get_system_hostname();
6941         }
6942 elsif ($gconfig{'hostnamemode'} == 3) {
6943         return $gconfig{'hostnamedisplay'};
6944         }
6945 else {
6946         my $h = $ENV{'HTTP_HOST'};
6947         $h =~ s/:\d+//g;
6948         if ($gconfig{'hostnamemode'} == 2) {
6949                 $h =~ s/^(www|ftp|mail)\.//i;
6950                 }
6951         return $h;
6952         }
6953 }
6954
6955 =head2 save_module_config([&config], [modulename])
6956
6957 Saves the configuration for some module. The config parameter is an optional
6958 hash reference of names and values to save, which defaults to the global
6959 %config hash. The modulename parameter is the module to update the config
6960 file, which defaults to the current module.
6961
6962 =cut
6963 sub save_module_config
6964 {
6965 my $c = $_[0] || { &get_module_variable('%config') };
6966 my $m = defined($_[1]) ? $_[1] : &get_module_name();
6967 &write_file("$config_directory/$m/config", $c);
6968 }
6969
6970 =head2 save_user_module_config([&config], [modulename])
6971
6972 Saves the user's Usermin preferences for some module. The config parameter is
6973 an optional hash reference of names and values to save, which defaults to the
6974 global %userconfig hash. The modulename parameter is the module to update the
6975 config file, which defaults to the current module.
6976
6977 =cut
6978 sub save_user_module_config
6979 {
6980 my $c = $_[0] || { &get_module_variable('%userconfig') };
6981 my $m = $_[1] || &get_module_name();
6982 my $ucd = $user_config_directory;
6983 if (!$ucd) {
6984         my @uinfo = @remote_user_info ? @remote_user_info
6985                                       : getpwnam($remote_user);
6986         return if (!@uinfo || !$uinfo[7]);
6987         $ucd = "$uinfo[7]/$gconfig{'userconfig'}";
6988         }
6989 &write_file("$ucd/$m/config", $c);
6990 }
6991
6992 =head2 nice_size(bytes, [min])
6993
6994 Converts a number of bytes into a number followed by a suffix like GB, MB
6995 or kB. Rounding is to two decimal digits. The optional min parameter sets the
6996 smallest units to use - so you could pass 1024*1024 to never show bytes or kB.
6997
6998 =cut
6999 sub nice_size
7000 {
7001 my ($units, $uname);
7002 if (abs($_[0]) > 1024*1024*1024*1024 || $_[1] >= 1024*1024*1024*1024) {
7003         $units = 1024*1024*1024*1024;
7004         $uname = "TB";
7005         }
7006 elsif (abs($_[0]) > 1024*1024*1024 || $_[1] >= 1024*1024*1024) {
7007         $units = 1024*1024*1024;
7008         $uname = "GB";
7009         }
7010 elsif (abs($_[0]) > 1024*1024 || $_[1] >= 1024*1024) {
7011         $units = 1024*1024;
7012         $uname = "MB";
7013         }
7014 elsif (abs($_[0]) > 1024 || $_[1] >= 1024) {
7015         $units = 1024;
7016         $uname = "kB";
7017         }
7018 else {
7019         $units = 1;
7020         $uname = "bytes";
7021         }
7022 my $sz = sprintf("%.2f", ($_[0]*1.0 / $units));
7023 $sz =~ s/\.00$//;
7024 return $sz." ".$uname;
7025 }
7026
7027 =head2 get_perl_path
7028
7029 Returns the path to Perl currently in use, such as /usr/bin/perl.
7030
7031 =cut
7032 sub get_perl_path
7033 {
7034 if (open(PERL, "$config_directory/perl-path")) {
7035         my $rv;
7036         chop($rv = <PERL>);
7037         close(PERL);
7038         return $rv;
7039         }
7040 return $^X if (-x $^X);
7041 return &has_command("perl");
7042 }
7043
7044 =head2 get_goto_module([&mods])
7045
7046 Returns the details of a module that the current user should be re-directed
7047 to after logging in, or undef if none. Useful for themes.
7048
7049 =cut
7050 sub get_goto_module
7051 {
7052 my @mods = $_[0] ? @{$_[0]} : &get_visible_module_infos();
7053 if ($gconfig{'gotomodule'}) {
7054         my ($goto) = grep { $_->{'dir'} eq $gconfig{'gotomodule'} } @mods;
7055         return $goto if ($goto);
7056         }
7057 if (@mods == 1 && $gconfig{'gotoone'}) {
7058         return $mods[0];
7059         }
7060 return undef;
7061 }
7062
7063 =head2 select_all_link(field, form, [text])
7064
7065 Returns HTML for a 'Select all' link that uses Javascript to select
7066 multiple checkboxes with the same name. The parameters are :
7067
7068 =item field - Name of the checkbox inputs.
7069
7070 =item form - Index of the form on the page.
7071
7072 =item text - Message for the link, defaulting to 'Select all'.
7073
7074 =cut
7075 sub select_all_link
7076 {
7077 return &theme_select_all_link(@_) if (defined(&theme_select_all_link));
7078 my ($field, $form, $text) = @_;
7079 $form = int($form);
7080 $text ||= $text{'ui_selall'};
7081 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>";
7082 }
7083
7084 =head2 select_invert_link(field, form, text)
7085
7086 Returns HTML for an 'Invert selection' link that uses Javascript to invert the
7087 selection on multiple checkboxes with the same name. The parameters are :
7088
7089 =item field - Name of the checkbox inputs.
7090
7091 =item form - Index of the form on the page.
7092
7093 =item text - Message for the link, defaulting to 'Invert selection'.
7094
7095 =cut
7096 sub select_invert_link
7097 {
7098 return &theme_select_invert_link(@_) if (defined(&theme_select_invert_link));
7099 my ($field, $form, $text) = @_;
7100 $form = int($form);
7101 $text ||= $text{'ui_selinv'};
7102 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>";
7103 }
7104
7105 =head2 select_rows_link(field, form, text, &rows)
7106
7107 Returns HTML for a link that uses Javascript to select rows with particular
7108 values for their checkboxes. The parameters are :
7109
7110 =item field - Name of the checkbox inputs.
7111
7112 =item form - Index of the form on the page.
7113
7114 =item text - Message for the link, de
7115
7116 =item rows - Reference to an array of 1 or 0 values, indicating which rows to check.
7117
7118 =cut
7119 sub select_rows_link
7120 {
7121 return &theme_select_rows_link(@_) if (defined(&theme_select_rows_link));
7122 my ($field, $form, $text, $rows) = @_;
7123 $form = int($form);
7124 my $js = "var sel = { ".join(",", map { "\"".&quote_escape($_)."\":1" } @$rows)." }; ";
7125 $js .= "for(var i=0; i<document.forms[$form].${field}.length; i++) { var r = document.forms[$form].${field}[i]; r.checked = sel[r.value]; } ";
7126 $js .= "return false;";
7127 return "<a href='#' onClick='$js'>$text</a>";
7128 }
7129
7130 =head2 check_pid_file(file)
7131
7132 Given a pid file, returns the PID it contains if the process is running.
7133
7134 =cut
7135 sub check_pid_file
7136 {
7137 open(PIDFILE, $_[0]) || return undef;
7138 my $pid = <PIDFILE>;
7139 close(PIDFILE);
7140 $pid =~ /^\s*(\d+)/ || return undef;
7141 kill(0, $1) || return undef;
7142 return $1;
7143 }
7144
7145 =head2 get_mod_lib
7146
7147 Return the local os-specific library name to this module. For internal use only.
7148
7149 =cut
7150 sub get_mod_lib
7151 {
7152 my $mn = &get_module_name();
7153 my $md = &module_root_directory($mn);
7154 if (-r "$md/$mn-$gconfig{'os_type'}-$gconfig{'os_version'}-lib.pl") {
7155         return "$mn-$gconfig{'os_type'}-$gconfig{'os_version'}-lib.pl";
7156         }
7157 elsif (-r "$md/$mn-$gconfig{'os_type'}-lib.pl") {
7158         return "$mn-$gconfig{'os_type'}-lib.pl";
7159         }
7160 elsif (-r "$md/$mn-generic-lib.pl") {
7161         return "$mn-generic-lib.pl";
7162         }
7163 else {
7164         return "";
7165         }
7166 }
7167
7168 =head2 module_root_directory(module)
7169
7170 Given a module name, returns its root directory. On a typical Webmin install,
7171 all modules are under the same directory - but it is theoretically possible to
7172 have more than one.
7173
7174 =cut
7175 sub module_root_directory
7176 {
7177 my $d = ref($_[0]) ? $_[0]->{'dir'} : $_[0];
7178 if (@root_directories > 1) {
7179         foreach my $r (@root_directories) {
7180                 if (-d "$r/$d") {
7181                         return "$r/$d";
7182                         }
7183                 }
7184         }
7185 return "$root_directories[0]/$d";
7186 }
7187
7188 =head2 list_mime_types
7189
7190 Returns a list of all known MIME types and their extensions, as a list of hash
7191 references with keys :
7192
7193 =item type - The MIME type, like text/plain.
7194
7195 =item exts - A list of extensions, like .doc and .avi.
7196
7197 =item desc - A human-readable description for the MIME type.
7198
7199 =cut
7200 sub list_mime_types
7201 {
7202 if (!@list_mime_types_cache) {
7203         local $_;
7204         open(MIME, "$root_directory/mime.types");
7205         while(<MIME>) {
7206                 my $cmt;
7207                 s/\r|\n//g;
7208                 if (s/#\s*(.*)$//g) {
7209                         $cmt = $1;
7210                         }
7211                 my ($type, @exts) = split(/\s+/);
7212                 if ($type) {
7213                         push(@list_mime_types_cache, { 'type' => $type,
7214                                                        'exts' => \@exts,
7215                                                        'desc' => $cmt });
7216                         }
7217                 }
7218         close(MIME);
7219         }
7220 return @list_mime_types_cache;
7221 }
7222
7223 =head2 guess_mime_type(filename, [default])
7224
7225 Given a file name like xxx.gif or foo.html, returns a guessed MIME type.
7226 The optional default parameter sets a default type of use if none is found,
7227 which defaults to application/octet-stream.
7228
7229 =cut
7230 sub guess_mime_type
7231 {
7232 if ($_[0] =~ /\.([A-Za-z0-9\-]+)$/) {
7233         my $ext = $1;
7234         foreach my $t (&list_mime_types()) {
7235                 foreach my $e (@{$t->{'exts'}}) {
7236                         return $t->{'type'} if (lc($e) eq lc($ext));
7237                         }
7238                 }
7239         }
7240 return @_ > 1 ? $_[1] : "application/octet-stream";
7241 }
7242
7243 =head2 open_tempfile([handle], file, [no-error], [no-tempfile], [safe?])
7244
7245 Opens a file handle for writing to a temporary file, which will only be
7246 renamed over the real file when the handle is closed. This allows critical
7247 files like /etc/shadow to be updated safely, even if writing fails part way
7248 through due to lack of disk space. The parameters are :
7249
7250 =item handle - File handle to open, as you would use in Perl's open function.
7251
7252 =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.
7253
7254 =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.
7255
7256 =item no-tempfile - If set to 1, writing will be direct to the file instead of using a temporary file.
7257
7258 =item safe - Indicates to users in read-only mode that this write is safe and non-destructive.
7259
7260 =cut
7261 sub open_tempfile
7262 {
7263 if (@_ == 1) {
7264         # Just getting a temp file
7265         if (!defined($main::open_tempfiles{$_[0]})) {
7266                 $_[0] =~ /^(.*)\/(.*)$/ || return $_[0];
7267                 my $dir = $1 || "/";
7268                 my $tmp = "$dir/$2.webmintmp.$$";
7269                 $main::open_tempfiles{$_[0]} = $tmp;
7270                 push(@main::temporary_files, $tmp);
7271                 }
7272         return $main::open_tempfiles{$_[0]};
7273         }
7274 else {
7275         # Actually opening
7276         my ($fh, $file, $noerror, $notemp, $safe) = @_;
7277         $fh = &callers_package($fh);
7278
7279         my %gaccess = &get_module_acl(undef, "");
7280         my $db = $gconfig{'debug_what_write'};
7281         if ($file =~ /\r|\n|\0/) {
7282                 if ($noerror) { return 0; }
7283                 else { &error("Filename contains invalid characters"); }
7284                 }
7285         if (&is_readonly_mode() && $file =~ />/ && !$safe) {
7286                 # Read-only mode .. veto all writes
7287                 print STDERR "vetoing write to $file\n";
7288                 return open($fh, ">$null_file");
7289                 }
7290         elsif ($file =~ /^(>|>>|)nul$/i) {
7291                 # Write to Windows null device
7292                 &webmin_debug_log($1 eq ">" ? "WRITE" :
7293                           $l eq ">>" ? "APPEND" : "READ", "nul") if ($db);
7294                 }
7295         elsif ($file =~ /^(>|>>)(\/dev\/.*)/ || lc($file) eq "nul") {
7296                 # Writes to /dev/null or TTYs don't need to be handled
7297                 &webmin_debug_log($1 eq ">" ? "WRITE" : "APPEND", $2) if ($db);
7298                 return open($fh, $file);
7299                 }
7300         elsif ($file =~ /^>\s*(([a-zA-Z]:)?\/.*)$/ && !$notemp) {
7301                 &webmin_debug_log("WRITE", $1) if ($db);
7302                 # Over-writing a file, via a temp file
7303                 $file = $1;
7304                 $file = &translate_filename($file);
7305                 while(-l $file) {
7306                         # Open the link target instead
7307                         $file = &resolve_links($file);
7308                         }
7309                 if (-d $file) {
7310                         # Cannot open a directory!
7311                         if ($noerror) { return 0; }
7312                         else { &error("Cannot write to directory $file"); }
7313                         }
7314                 my $tmp = &open_tempfile($file);
7315                 my $ex = open($fh, ">$tmp");
7316                 if (!$ex && $! =~ /permission/i) {
7317                         # Could not open temp file .. try opening actual file
7318                         # instead directly
7319                         $ex = open($fh, ">$file");
7320                         delete($main::open_tempfiles{$file});
7321                         }
7322                 else {
7323                         $main::open_temphandles{$fh} = $file;
7324                         }
7325                 binmode($fh);
7326                 if (!$ex && !$noerror) {
7327                         &error(&text("efileopen", $file, $!));
7328                         }
7329                 return $ex;
7330                 }
7331         elsif ($file =~ /^>\s*(([a-zA-Z]:)?\/.*)$/ && $notemp) {
7332                 # Just writing direct to a file
7333                 &webmin_debug_log("WRITE", $1) if ($db);
7334                 $file = $1;
7335                 $file = &translate_filename($file);
7336                 my @old_attributes = &get_clear_file_attributes($file);
7337                 my $ex = open($fh, ">$file");
7338                 &reset_file_attributes($file, \@old_attributes);
7339                 $main::open_temphandles{$fh} = $file;
7340                 if (!$ex && !$noerror) {
7341                         &error(&text("efileopen", $file, $!));
7342                         }
7343                 binmode($fh);
7344                 return $ex;
7345                 }
7346         elsif ($file =~ /^>>\s*(([a-zA-Z]:)?\/.*)$/) {
7347                 # Appending to a file .. nothing special to do
7348                 &webmin_debug_log("APPEND", $1) if ($db);
7349                 $file = $1;
7350                 $file = &translate_filename($file);
7351                 my @old_attributes = &get_clear_file_attributes($file);
7352                 my $ex = open($fh, ">>$file");
7353                 &reset_file_attributes($file, \@old_attributes);
7354                 $main::open_temphandles{$fh} = $file;
7355                 if (!$ex && !$noerror) {
7356                         &error(&text("efileopen", $file, $!));
7357                         }
7358                 binmode($fh);
7359                 return $ex;
7360                 }
7361         elsif ($file =~ /^([a-zA-Z]:)?\//) {
7362                 # Read mode .. nothing to do here
7363                 &webmin_debug_log("READ", $file) if ($db);
7364                 $file = &translate_filename($file);
7365                 return open($fh, $file);
7366                 }
7367         elsif ($file eq ">" || $file eq ">>") {
7368                 my ($package, $filename, $line) = caller;
7369                 if ($noerror) { return 0; }
7370                 else { &error("Missing file to open at ${package}::${filename} line $line"); }
7371                 }
7372         else {
7373                 my ($package, $filename, $line) = caller;
7374                 &error("Unsupported file or mode $file at ${package}::${filename} line $line");
7375                 }
7376         }
7377 }
7378
7379 =head2 close_tempfile(file|handle)
7380
7381 Copies a temp file to the actual file, assuming that all writes were
7382 successful. The handle must have been one passed to open_tempfile.
7383
7384 =cut
7385 sub close_tempfile
7386 {
7387 my $file;
7388 my $fh = &callers_package($_[0]);
7389
7390 if (defined($file = $main::open_temphandles{$fh})) {
7391         # Closing a handle
7392         close($fh) || &error(&text("efileclose", $file, $!));
7393         delete($main::open_temphandles{$fh});
7394         return &close_tempfile($file);
7395         }
7396 elsif (defined($main::open_tempfiles{$_[0]})) {
7397         # Closing a file
7398         &webmin_debug_log("CLOSE", $_[0]) if ($gconfig{'debug_what_write'});
7399         my @st = stat($_[0]);
7400         if (&is_selinux_enabled() && &has_command("chcon")) {
7401                 # Set original security context
7402                 system("chcon --reference=".quotemeta($_[0]).
7403                        " ".quotemeta($main::open_tempfiles{$_[0]}).
7404                        " >/dev/null 2>&1");
7405                 }
7406         my @old_attributes = &get_clear_file_attributes($_[0]);
7407         rename($main::open_tempfiles{$_[0]}, $_[0]) || &error("Failed to replace $_[0] with $main::open_tempfiles{$_[0]} : $!");
7408         if (@st) {
7409                 # Set original permissions and ownership
7410                 chmod($st[2], $_[0]);
7411                 chown($st[4], $st[5], $_[0]);
7412                 }
7413         &reset_file_attributes($_[0], \@old_attributes);
7414         delete($main::open_tempfiles{$_[0]});
7415         @main::temporary_files = grep { $_ ne $main::open_tempfiles{$_[0]} } @main::temporary_files;
7416         if ($main::open_templocks{$_[0]}) {
7417                 &unlock_file($_[0]);
7418                 delete($main::open_templocks{$_[0]});
7419                 }
7420         return 1;
7421         }
7422 else {
7423         # Must be closing a handle not associated with a file
7424         close($_[0]);
7425         return 1;
7426         }
7427 }
7428
7429 =head2 print_tempfile(handle, text, ...)
7430
7431 Like the normal print function, but calls &error on failure. Useful when
7432 combined with open_tempfile, to ensure that a criticial file is never
7433 only partially written.
7434
7435 =cut
7436 sub print_tempfile
7437 {
7438 my ($fh, @args) = @_;
7439 $fh = &callers_package($fh);
7440 (print $fh @args) || &error(&text("efilewrite",
7441                             $main::open_temphandles{$fh} || $fh, $!));
7442 }
7443
7444 =head2 is_selinux_enabled
7445
7446 Returns 1 if SElinux is supported on this system and enabled, 0 if not.
7447
7448 =cut
7449 sub is_selinux_enabled
7450 {
7451 if (!defined($main::selinux_enabled_cache)) {
7452         my %seconfig;
7453         if ($gconfig{'os_type'} !~ /-linux$/) {
7454                 # Not on linux, so no way
7455                 $main::selinux_enabled_cache = 0;
7456                 }
7457         elsif (&read_env_file("/etc/selinux/config", \%seconfig)) {
7458                 # Use global config file
7459                 $main::selinux_enabled_cache =
7460                         $seconfig{'SELINUX'} eq 'disabled' ||
7461                         !$seconfig{'SELINUX'} ? 0 : 1;
7462                 }
7463         else {
7464                 # Use selinuxenabled command
7465                 #$selinux_enabled_cache =
7466                 #       system("selinuxenabled >/dev/null 2>&1") ? 0 : 1;
7467                 $main::selinux_enabled_cache = 0;
7468                 }
7469         }
7470 return $main::selinux_enabled_cache;
7471 }
7472
7473 =head2 get_clear_file_attributes(file)
7474
7475 Finds file attributes that may prevent writing, clears them and returns them
7476 as a list. May call error. Mainly for internal use by open_tempfile and
7477 close_tempfile.
7478
7479 =cut
7480 sub get_clear_file_attributes
7481 {
7482 my ($file) = @_;
7483 my @old_attributes;
7484 if ($gconfig{'chattr'}) {
7485         # Get original immutable bit
7486         my $out = &backquote_command(
7487                 "lsattr ".quotemeta($file)." 2>/dev/null");
7488         if (!$?) {
7489                 $out =~ s/\s\S+\n//;
7490                 @old_attributes = grep { $_ ne '-' } split(//, $out);
7491                 }
7492         if (&indexof("i", @old_attributes) >= 0) {
7493                 my $err = &backquote_logged(
7494                         "chattr -i ".quotemeta($file)." 2>&1");
7495                 if ($?) {
7496                         &error("Failed to remove immutable bit on ".
7497                                "$file : $err");
7498                         }
7499                 }
7500         }
7501 return @old_attributes;
7502 }
7503
7504 =head2 reset_file_attributes(file, &attributes)
7505
7506 Put back cleared attributes on some file. May call error. Mainly for internal
7507 use by close_tempfile.
7508
7509 =cut
7510 sub reset_file_attributes
7511 {
7512 my ($file, $old_attributes) = @_;
7513 if (&indexof("i", @$old_attributes) >= 0) {
7514         my $err = &backquote_logged(
7515                 "chattr +i ".quotemeta($file)." 2>&1");
7516         if ($?) {
7517                 &error("Failed to restore immutable bit on ".
7518                        "$file : $err");
7519                 }
7520         }
7521 }
7522
7523 =head2 cleanup_tempnames
7524
7525 Remove all temporary files generated using transname. Typically only called
7526 internally when a Webmin script exits.
7527
7528 =cut
7529 sub cleanup_tempnames
7530 {
7531 foreach my $t (@main::temporary_files) {
7532         &unlink_file($t);
7533         }
7534 @main::temporary_files = ( );
7535 }
7536
7537 =head2 open_lock_tempfile([handle], file, [no-error])
7538
7539 Returns a temporary file for writing to some actual file, and also locks it.
7540 Effectively the same as calling lock_file and open_tempfile on the same file,
7541 but calls the unlock for you automatically when it is closed.
7542
7543 =cut
7544 sub open_lock_tempfile
7545 {
7546 my ($fh, $file, $noerror, $notemp, $safe) = @_;
7547 $fh = &callers_package($fh);
7548 my $lockfile = $file;
7549 $lockfile =~ s/^[^\/]*//;
7550 if ($lockfile =~ /^\//) {
7551         $main::open_templocks{$lockfile} = &lock_file($lockfile);
7552         }
7553 return &open_tempfile($fh, $file, $noerror, $notemp, $safe);
7554 }
7555
7556 sub END
7557 {
7558 $main::end_exit_status ||= $?;
7559 if ($$ == $main::initial_process_id) {
7560         # Exiting from initial process
7561         &cleanup_tempnames();
7562         if ($gconfig{'debug_what_start'} && $main::debug_log_start_time &&
7563             $main::debug_log_start_module eq &get_module_name()) {
7564                 my $len = time() - $main::debug_log_start_time;
7565                 &webmin_debug_log("STOP", "runtime=$len");
7566                 $main::debug_log_start_time = 0;
7567                 }
7568         if (!$ENV{'SCRIPT_NAME'} &&
7569             $main::initial_module_name eq &get_module_name()) {
7570                 # In a command-line script - call the real exit, so that the
7571                 # exit status gets properly propogated. In some cases this
7572                 # was not happening.
7573                 exit($main::end_exit_status);
7574                 }
7575         }
7576 }
7577
7578 =head2 month_to_number(month)
7579
7580 Converts a month name like feb to a number like 1.
7581
7582 =cut
7583 sub month_to_number
7584 {
7585 return $month_to_number_map{lc(substr($_[0], 0, 3))};
7586 }
7587
7588 =head2 number_to_month(number)
7589
7590 Converts a number like 1 to a month name like Feb.
7591
7592 =cut
7593 sub number_to_month
7594 {
7595 return ucfirst($number_to_month_map{$_[0]});
7596 }
7597
7598 =head2 get_rbac_module_acl(user, module)
7599
7600 Returns a hash reference of RBAC overrides ACLs for some user and module.
7601 May return undef if none exist (indicating access denied), or the string *
7602 if full access is granted.
7603
7604 =cut
7605 sub get_rbac_module_acl
7606 {
7607 my ($user, $mod) = @_;
7608 eval "use Authen::SolarisRBAC";
7609 return undef if ($@);
7610 my %rv;
7611 my $foundany = 0;
7612 if (Authen::SolarisRBAC::chkauth("webmin.$mod.admin", $user)) {
7613         # Automagic webmin.modulename.admin authorization exists .. allow access
7614         $foundany = 1;
7615         if (!Authen::SolarisRBAC::chkauth("webmin.$mod.config", $user)) {
7616                 %rv = ( 'noconfig' => 1 );
7617                 }
7618         else {
7619                 %rv = ( );
7620                 }
7621         }
7622 local $_;
7623 open(RBAC, &module_root_directory($mod)."/rbac-mapping");
7624 while(<RBAC>) {
7625         s/\r|\n//g;
7626         s/#.*$//;
7627         my ($auths, $acls) = split(/\s+/, $_);
7628         my @auths = split(/,/, $auths);
7629         next if (!$auths);
7630         my ($merge) = ($acls =~ s/^\+//);
7631         my $gotall = 1;
7632         if ($auths eq "*") {
7633                 # These ACLs apply to all RBAC users.
7634                 # Only if there is some that match a specific authorization
7635                 # later will they be used though.
7636                 }
7637         else {
7638                 # Check each of the RBAC authorizations
7639                 foreach my $a (@auths) {
7640                         if (!Authen::SolarisRBAC::chkauth($a, $user)) {
7641                                 $gotall = 0;
7642                                 last;
7643                                 }
7644                         }
7645                 $foundany++ if ($gotall);
7646                 }
7647         if ($gotall) {
7648                 # Found an RBAC authorization - return the ACLs
7649                 return "*" if ($acls eq "*");
7650                 my %acl = map { split(/=/, $_, 2) } split(/,/, $acls);
7651                 if ($merge) {
7652                         # Just add to current set
7653                         foreach my $a (keys %acl) {
7654                                 $rv{$a} = $acl{$a};
7655                                 }
7656                         }
7657                 else {
7658                         # Found final ACLs
7659                         return \%acl;
7660                         }
7661                 }
7662         }
7663 close(RBAC);
7664 return !$foundany ? undef : defined(%rv) ? \%rv : undef;
7665 }
7666
7667 =head2 supports_rbac([module])
7668
7669 Returns 1 if RBAC client support is available, such as on Solaris.
7670
7671 =cut
7672 sub supports_rbac
7673 {
7674 return 0 if ($gconfig{'os_type'} ne 'solaris');
7675 eval "use Authen::SolarisRBAC";
7676 return 0 if ($@);
7677 if ($_[0]) {
7678         #return 0 if (!-r &module_root_directory($_[0])."/rbac-mapping");
7679         }
7680 return 1;
7681 }
7682
7683 =head2 use_rbac_module_acl(user, module)
7684
7685 Returns 1 if some user should use RBAC to get permissions for a module
7686
7687 =cut
7688 sub use_rbac_module_acl
7689 {
7690 my $u = defined($_[0]) ? $_[0] : $base_remote_user;
7691 my $m = defined($_[1]) ? $_[1] : &get_module_name();
7692 return 1 if ($gconfig{'rbacdeny_'.$u});         # RBAC forced for user
7693 my %access = &get_module_acl($u, $m, 1);
7694 return $access{'rbac'} ? 1 : 0;
7695 }
7696
7697 =head2 execute_command(command, stdin, stdout, stderr, translate-files?, safe?)
7698
7699 Runs some command, possibly feeding it input and capturing output to the
7700 give files or scalar references. The parameters are :
7701
7702 =item command - Full command to run, possibly including shell meta-characters.
7703
7704 =item stdin - File to read input from, or a scalar ref containing input, or undef if no input should be given.
7705
7706 =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.
7707
7708 =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.
7709
7710 =item translate-files - Set to 1 to apply filename translation to any filenames. Usually has no effect.
7711
7712 =item safe - Set to 1 if this command is safe and does not modify the state of the system.
7713
7714 =cut
7715 sub execute_command
7716 {
7717 my ($cmd, $stdin, $stdout, $stderr, $trans, $safe) = @_;
7718 if (&is_readonly_mode() && !$safe) {
7719         print STDERR "Vetoing command $_[0]\n";
7720         $? = 0;
7721         return 0;
7722         }
7723 my $cmd = &translate_command($cmd);
7724
7725 # Use ` operator where possible
7726 if (!$stdin && ref($stdout) && !$stderr) {
7727         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
7728         $$stdout = `$cmd 2>$null_file`;
7729         return $?;
7730         }
7731 elsif (!$stdin && ref($stdout) && $stdout eq $stderr) {
7732         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
7733         $$stdout = `$cmd 2>&1`;
7734         return $?;
7735         }
7736 elsif (!$stdin && !$stdout && !$stderr) {
7737         $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
7738         return system("$cmd >$null_file 2>$null_file <$null_file");
7739         }
7740 &webmin_debug_log('CMD', "cmd=$cmd") if ($gconfig{'debug_what_cmd'});
7741
7742 # Setup pipes
7743 $| = 1;         # needed on some systems to flush before forking
7744 pipe(EXECSTDINr, EXECSTDINw);
7745 pipe(EXECSTDOUTr, EXECSTDOUTw);
7746 pipe(EXECSTDERRr, EXECSTDERRw);
7747 my $pid;
7748 if (!($pid = fork())) {
7749         untie(*STDIN);
7750         untie(*STDOUT);
7751         untie(*STDERR);
7752         open(STDIN, "<&EXECSTDINr");
7753         open(STDOUT, ">&EXECSTDOUTw");
7754         if (ref($stderr) && $stderr eq $stdout) {
7755                 open(STDERR, ">&EXECSTDOUTw");
7756                 }
7757         else {
7758                 open(STDERR, ">&EXECSTDERRw");
7759                 }
7760         $| = 1;
7761         close(EXECSTDINw);
7762         close(EXECSTDOUTr);
7763         close(EXECSTDERRr);
7764
7765         my $fullcmd = "($cmd)";
7766         if ($stdin && !ref($stdin)) {
7767                 $fullcmd .= " <$stdin";
7768                 }
7769         if ($stdout && !ref($stdout)) {
7770                 $fullcmd .= " >$stdout";
7771                 }
7772         if ($stderr && !ref($stderr)) {
7773                 if ($stderr eq $stdout) {
7774                         $fullcmd .= " 2>&1";
7775                         }
7776                 else {
7777                         $fullcmd .= " 2>$stderr";
7778                         }
7779                 }
7780         if ($gconfig{'os_type'} eq 'windows') {
7781                 exec($fullcmd);
7782                 }
7783         else {
7784                 exec("/bin/sh", "-c", $fullcmd);
7785                 }
7786         print "Exec failed : $!\n";
7787         exit(1);
7788         }
7789 close(EXECSTDINr);
7790 close(EXECSTDOUTw);
7791 close(EXECSTDERRw);
7792
7793 # Feed input and capture output
7794 local $_;
7795 if ($stdin && ref($stdin)) {
7796         print EXECSTDINw $$stdin;
7797         close(EXECSTDINw);
7798         }
7799 if ($stdout && ref($stdout)) {
7800         $$stdout = undef;
7801         while(<EXECSTDOUTr>) {
7802                 $$stdout .= $_;
7803                 }
7804         close(EXECSTDOUTr);
7805         }
7806 if ($stderr && ref($stderr) && $stderr ne $stdout) {
7807         $$stderr = undef;
7808         while(<EXECSTDERRr>) {
7809                 $$stderr .= $_;
7810                 }
7811         close(EXECSTDERRr);
7812         }
7813
7814 # Get exit status
7815 waitpid($pid, 0);
7816 return $?;
7817 }
7818
7819 =head2 open_readfile(handle, file)
7820
7821 Opens some file for reading. Returns 1 on success, 0 on failure. Pretty much
7822 exactly the same as Perl's open function.
7823
7824 =cut
7825 sub open_readfile
7826 {
7827 my ($fh, $file) = @_;
7828 $fh = &callers_package($fh);
7829 my $realfile = &translate_filename($file);
7830 &webmin_debug_log('READ', $file) if ($gconfig{'debug_what_read'});
7831 return open($fh, "<".$realfile);
7832 }
7833
7834 =head2 open_execute_command(handle, command, output?, safe?)
7835
7836 Runs some command, with the specified file handle set to either write to it if
7837 in-or-out is set to 0, or read to it if output is set to 1. The safe flag
7838 indicates if the command modifies the state of the system or not.
7839
7840 =cut
7841 sub open_execute_command
7842 {
7843 my ($fh, $cmd, $mode, $safe) = @_;
7844 $fh = &callers_package($fh);
7845 my $realcmd = &translate_command($cmd);
7846 if (&is_readonly_mode() && !$safe) {
7847         # Don't actually run it
7848         print STDERR "vetoing command $cmd\n";
7849         $? = 0;
7850         if ($mode == 0) {
7851                 return open($fh, ">$null_file");
7852                 }
7853         else {
7854                 return open($fh, $null_file);
7855                 }
7856         }
7857 # Really run it
7858 &webmin_debug_log('CMD', "cmd=$realcmd mode=$mode")
7859         if ($gconfig{'debug_what_cmd'});
7860 if ($mode == 0) {
7861         return open($fh, "| $cmd");
7862         }
7863 elsif ($mode == 1) {
7864         return open($fh, "$cmd 2>$null_file |");
7865         }
7866 elsif ($mode == 2) {
7867         return open($fh, "$cmd 2>&1 |");
7868         }
7869 }
7870
7871 =head2 translate_filename(filename)
7872
7873 Applies all relevant registered translation functions to a filename. Mostly
7874 for internal use, and typically does nothing.
7875
7876 =cut
7877 sub translate_filename
7878 {
7879 my ($realfile) = @_;
7880 my @funcs = grep { $_->[0] eq &get_module_name() ||
7881                    !defined($_->[0]) } @main::filename_callbacks;
7882 foreach my $f (@funcs) {
7883         my $func = $f->[1];
7884         $realfile = &$func($realfile, @{$f->[2]});
7885         }
7886 return $realfile;
7887 }
7888
7889 =head2 translate_command(filename)
7890
7891 Applies all relevant registered translation functions to a command. Mostly
7892 for internal use, and typically does nothing.
7893
7894 =cut
7895 sub translate_command
7896 {
7897 my ($realcmd) = @_;
7898 my @funcs = grep { $_->[0] eq &get_module_name() ||
7899                    !defined($_->[0]) } @main::command_callbacks;
7900 foreach my $f (@funcs) {
7901         my $func = $f->[1];
7902         $realcmd = &$func($realcmd, @{$f->[2]});
7903         }
7904 return $realcmd;
7905 }
7906
7907 =head2 register_filename_callback(module|undef, &function, &args)
7908
7909 Registers some function to be called when the specified module (or all
7910 modules) tries to open a file for reading and writing. The function must
7911 return the actual file to open. This allows you to override which files
7912 other code actually operates on, via the translate_filename function.
7913
7914 =cut
7915 sub register_filename_callback
7916 {
7917 my ($mod, $func, $args) = @_;
7918 push(@main::filename_callbacks, [ $mod, $func, $args ]);
7919 }
7920
7921 =head2 register_command_callback(module|undef, &function, &args)
7922
7923 Registers some function to be called when the specified module (or all
7924 modules) tries to execute a command. The function must return the actual
7925 command to run. This allows you to override which commands other other code
7926 actually runs, via the translate_command function.
7927
7928 =cut
7929 sub register_command_callback
7930 {
7931 my ($mod, $func, $args) = @_;
7932 push(@main::command_callbacks, [ $mod, $func, $args ]);
7933 }
7934
7935 =head2 capture_function_output(&function, arg, ...)
7936
7937 Captures output that some function prints to STDOUT, and returns it. Useful
7938 for functions outside your control that print data when you really want to
7939 manipulate it before output.
7940
7941 =cut
7942 sub capture_function_output
7943 {
7944 my ($func, @args) = @_;
7945 socketpair(SOCKET2, SOCKET1, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
7946 my $old = select(SOCKET1);
7947 my @rv = &$func(@args);
7948 select($old);
7949 close(SOCKET1);
7950 my $out;
7951 local $_;
7952 while(<SOCKET2>) {
7953         $out .= $_;
7954         }
7955 close(SOCKET2);
7956 return wantarray ? ($out, \@rv) : $out;
7957 }
7958
7959 =head2 capture_function_output_tempfile(&function, arg, ...)
7960
7961 Behaves the same as capture_function_output, but uses a temporary file
7962 to avoid buffer full problems.
7963
7964 =cut
7965 sub capture_function_output_tempfile
7966 {
7967 my ($func, @args) = @_;
7968 my $temp = &transname();
7969 open(BUFFER, ">$temp");
7970 my $old = select(BUFFER);
7971 my @rv = &$func(@args);
7972 select($old);
7973 close(BUFFER);
7974 my $out = &read_file_contents($temp);
7975 &unlink_file($temp);
7976 return wantarray ? ($out, \@rv) : $out;
7977 }
7978
7979 =head2 modules_chooser_button(field, multiple, [form])
7980
7981 Returns HTML for a button for selecting one or many Webmin modules.
7982 field - Name of the HTML field to place the module names into.
7983 multiple - Set to 1 if multiple modules can be selected.
7984 form - Index of the form on the page.
7985
7986 =cut
7987 sub modules_chooser_button
7988 {
7989 return &theme_modules_chooser_button(@_)
7990         if (defined(&theme_modules_chooser_button));
7991 my $form = defined($_[2]) ? $_[2] : 0;
7992 my $w = $_[1] ? 700 : 500;
7993 my $h = 200;
7994 if ($_[1] && $gconfig{'db_sizemodules'}) {
7995         ($w, $h) = split(/x/, $gconfig{'db_sizemodules'});
7996         }
7997 elsif (!$_[1] && $gconfig{'db_sizemodule'}) {
7998         ($w, $h) = split(/x/, $gconfig{'db_sizemodule'});
7999         }
8000 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";
8001 }
8002
8003 =head2 substitute_template(text, &hash)
8004
8005 Given some text and a hash reference, for each ocurrance of $FOO or ${FOO} in
8006 the text replaces it with the value of the hash key foo. Also supports blocks
8007 like ${IF-FOO} ... ${ENDIF-FOO}, whose contents are only included if foo is
8008 non-zero, and ${IF-FOO} ... ${ELSE-FOO} ... ${ENDIF-FOO}.
8009
8010 =cut
8011 sub substitute_template
8012 {
8013 # Add some extra fixed parameters to the hash
8014 my %hash = %{$_[1]};
8015 $hash{'hostname'} = &get_system_hostname();
8016 $hash{'webmin_config'} = $config_directory;
8017 $hash{'webmin_etc'} = $config_directory;
8018 $hash{'module_config'} = &get_module_variable('$module_config_directory');
8019 $hash{'webmin_var'} = $var_directory;
8020
8021 # Add time-based parameters, for use in DNS
8022 $hash{'current_time'} = time();
8023 my @tm = localtime($hash{'current_time'});
8024 $hash{'current_year'} = $tm[5]+1900;
8025 $hash{'current_month'} = sprintf("%2.2d", $tm[4]+1);
8026 $hash{'current_day'} = sprintf("%2.2d", $tm[3]);
8027 $hash{'current_hour'} = sprintf("%2.2d", $tm[2]);
8028 $hash{'current_minute'} = sprintf("%2.2d", $tm[1]);
8029 $hash{'current_second'} = sprintf("%2.2d", $tm[0]);
8030
8031 # Actually do the substition
8032 my $rv = $_[0];
8033 foreach my $s (keys %hash) {
8034         next if ($s eq '');     # Prevent just $ from being subbed
8035         my $us = uc($s);
8036         my $sv = $hash{$s};
8037         $rv =~ s/\$\{\Q$us\E\}/$sv/g;
8038         $rv =~ s/\$\Q$us\E/$sv/g;
8039         if ($sv) {
8040                 # Replace ${IF}..${ELSE}..${ENDIF} block with first value,
8041                 # and ${IF}..${ENDIF} with value
8042                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/\2/g;
8043                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/\2/g;
8044
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 ${IFEQ}..${ENDIFEQ} block with first value if
8051                 # matching, nothing if not
8052                 $rv =~ s/\$\{IFEQ-\Q$us\E-\Q$sv\E\}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-\Q$sv\E\}(\n?)/\2/g;
8053                 $rv =~ s/\$\{IFEQ-\Q$us\E-[^\}]+}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-[^\}]+\}(\n?)//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-\S+(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\S+(\n?)//g;
8059                 }
8060         else {
8061                 # Replace ${IF}..${ELSE}..${ENDIF} block with second value,
8062                 # and ${IF}..${ENDIF} with nothing
8063                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/\4/g;
8064                 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)//g;
8065
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 ${IFEQ}..${ENDIFEQ} block with nothing
8072                 $rv =~ s/\$\{IFEQ-\Q$us\E-[^\}]+}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-[^\}]+\}(\n?)//g;
8073                 $rv =~ s/\$IFEQ-\Q$us\E-\S+(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\S+(\n?)//g;
8074                 }
8075         }
8076
8077 # Now assume any $IF blocks whose variables are not present in the hash
8078 # evaluate to false.
8079 # $IF...$ELSE x $ENDIF => x
8080 $rv =~ s/\$\{IF\-([A-Z]+)\}.*?\$\{ELSE\-\1\}(.*?)\$\{ENDIF\-\1\}/$2/gs;
8081 # $IF...x...$ENDIF => (nothing)
8082 $rv =~ s/\$\{IF\-([A-Z]+)\}.*?\$\{ENDIF\-\1\}//gs;
8083 # ${var} => (nothing)
8084 $rv =~ s/\$\{[A-Z]+\}//g;
8085
8086 return $rv;
8087 }
8088
8089 =head2 running_in_zone
8090
8091 Returns 1 if the current Webmin instance is running in a Solaris zone. Used to
8092 disable module and features that are not appropriate, like those that modify
8093 mounted filesystems.
8094
8095 =cut
8096 sub running_in_zone
8097 {
8098 return 0 if ($gconfig{'os_type'} ne 'solaris' ||
8099              $gconfig{'os_version'} < 10);
8100 my $zn = `zonename 2>$null_file`;
8101 chop($zn);
8102 return $zn && $zn ne "global";
8103 }
8104
8105 =head2 running_in_vserver
8106
8107 Returns 1 if the current Webmin instance is running in a Linux VServer.
8108 Used to disable modules and features that are not appropriate.
8109
8110 =cut
8111 sub running_in_vserver
8112 {
8113 return 0 if ($gconfig{'os_type'} !~ /^\*-linux$/);
8114 my $vserver;
8115 local $_;
8116 open(MTAB, "/etc/mtab");
8117 while(<MTAB>) {
8118         my ($dev, $mp) = split(/\s+/, $_);
8119         if ($mp eq "/" && $dev =~ /^\/dev\/hdv/) {
8120                 $vserver = 1;
8121                 last;
8122                 }
8123         }
8124 close(MTAB);
8125 return $vserver;
8126 }
8127
8128 =head2 running_in_xen
8129
8130 Returns 1 if Webmin is running inside a Xen instance, by looking
8131 at /proc/xen/capabilities.
8132
8133 =cut
8134 sub running_in_xen
8135 {
8136 return 0 if (!-r "/proc/xen/capabilities");
8137 my $cap = &read_file_contents("/proc/xen/capabilities");
8138 return $cap =~ /control_d/ ? 0 : 1;
8139 }
8140
8141 =head2 list_categories(&modules, [include-empty])
8142
8143 Returns a hash mapping category codes to names, including any custom-defined
8144 categories. The modules parameter must be an array ref of module hash objects,
8145 as returned by get_all_module_infos.
8146
8147 =cut
8148 sub list_categories
8149 {
8150 my ($mods, $empty) = @_;
8151 my (%cats, %catnames);
8152 &read_file("$config_directory/webmin.catnames", \%catnames);
8153 foreach my $o (@lang_order_list) {
8154         &read_file("$config_directory/webmin.catnames.$o", \%catnames);
8155         }
8156 if ($empty) {
8157         %cats = %catnames;
8158         }
8159 foreach my $m (@$mods) {
8160         my $c = $m->{'category'};
8161         next if ($cats{$c});
8162         if (defined($catnames{$c})) {
8163                 $cats{$c} = $catnames{$c};
8164                 }
8165         elsif ($text{"category_$c"}) {
8166                 $cats{$c} = $text{"category_$c"};
8167                 }
8168         else {
8169                 # try to get category name from module ..
8170                 my %mtext = &load_language($m->{'dir'});
8171                 if ($mtext{"category_$c"}) {
8172                         $cats{$c} = $mtext{"category_$c"};
8173                         }
8174                 else {
8175                         $c = $m->{'category'} = "";
8176                         $cats{$c} = $text{"category_$c"};
8177                         }
8178                 }
8179         }
8180 return %cats;
8181 }
8182
8183 =head2 is_readonly_mode
8184
8185 Returns 1 if the current user is in read-only mode, and thus all writes
8186 to files and command execution should fail.
8187
8188 =cut
8189 sub is_readonly_mode
8190 {
8191 if (!defined($main::readonly_mode_cache)) {
8192         my %gaccess = &get_module_acl(undef, "");
8193         $main::readonly_mode_cache = $gaccess{'readonly'} ? 1 : 0;
8194         }
8195 return $main::readonly_mode_cache;
8196 }
8197
8198 =head2 command_as_user(user, with-env?, command, ...)
8199
8200 Returns a command to execute some command as the given user, using the
8201 su statement. If on Linux, the /bin/sh shell is forced in case the user
8202 does not have a valid shell. If with-env is set to 1, the -s flag is added
8203 to the su command to read the user's .profile or .bashrc file.
8204
8205 =cut
8206 sub command_as_user
8207 {
8208 my ($user, $env, @args) = @_;
8209 my @uinfo = getpwnam($user);
8210 if ($uinfo[8] ne "/bin/sh" && $uinfo[8] !~ /\/bash$/) {
8211         # User shell doesn't appear to be valid
8212         if ($gconfig{'os_type'} =~ /-linux$/) {
8213                 # Use -s /bin/sh to force it
8214                 $shellarg = " -s /bin/sh";
8215                 }
8216         elsif ($gconfig{'os_type'} eq 'freebsd' ||
8217                $gconfig{'os_type'} eq 'solaris' &&
8218                 $gconfig{'os_version'} >= 11 ||
8219                $gconfig{'os_type'} eq 'macos') {
8220                 # Use -m and force /bin/sh
8221                 @args = ( "/bin/sh", "-c", quotemeta(join(" ", @args)) );
8222                 $shellarg = " -m";
8223                 }
8224         }
8225 my $rv = "su".($env ? " -" : "").$shellarg.
8226          " ".quotemeta($user)." -c ".quotemeta(join(" ", @args));
8227 return $rv;
8228 }
8229
8230 =head2 list_osdn_mirrors(project, file)
8231
8232 Given a OSDN project and filename, returns a list of mirror URLs from
8233 which it can be downloaded. Mainly for internal use by the http_download
8234 function.
8235
8236 =cut
8237 sub list_osdn_mirrors
8238 {
8239 my ($project, $file) = @_;
8240
8241 # Convert the sourceforge project name to a group ID
8242 my ($idpage, $iderror);
8243 &http_download($osdn_download_host, $osdn_download_port,
8244                "/$project/", \$idpage, \$iderror,
8245                undef, 0, undef, undef, 0, 0, 1);
8246 my $group_id;
8247 if ($idpage =~ /showfiles.php\?group_id=(\d+)/) {
8248         $group_id = $1;
8249         }
8250
8251 # Query the mirror picker page
8252 my ($page, $error, @rv);
8253 if ($group_id) {
8254         &http_download($osdn_download_host, $osdn_download_port,
8255                        "/project/mirror_picker.php?group_id=".&urlize($group_id).
8256                         "&filename=".&urlize($file),
8257                        \$page, \$error, undef, 0, undef, undef, 0, 0, 1,
8258                        \%headers);
8259         while($page =~ /<input[^>]*name="use_mirror"\s+value="(\S+)"[^>]*>([^,]+),\s*([^<]*)<([\000-\377]*)/i) {
8260                 # Got a country and city
8261                 push(@rv, { 'country' => $3,
8262                             'city' => $2,
8263                             'mirror' => $1,
8264                             'url' => "http://$1.dl.sourceforge.net/sourceforge/$project/$file" });
8265                 $page = $4;
8266                 }
8267         }
8268
8269 if (!@rv) {
8270         # None found! Try some known mirrors
8271         foreach my $m ("superb-east", "superb-west", "osdn", "downloads") {
8272                 my $url = $m eq "downloads" ?
8273                     "http://downloads.sourceforge.net/$project/$file" :
8274                     "http://$m.dl.sourceforge.net/sourceforge/$project/$file";
8275                 $main::download_timed_out = undef;
8276                 local $SIG{ALRM} = \&download_timeout;
8277                 alarm(10);
8278                 my ($host, $port, $page, $ssl) = &parse_http_url($url);
8279                 my $h = &make_http_connection(
8280                         $host, $port, $ssl, "HEAD", $page);
8281                 alarm(0);
8282                 next if (!ref($h) || $main::download_timed_out);
8283
8284                 # Make a HEAD request
8285                 &write_http_connection($h, "Host: $host\r\n");
8286                 &write_http_connection($h, "User-agent: Webmin\r\n");
8287                 &write_http_connection($h, "\r\n");
8288                 $line = &read_http_connection($h);
8289                 $line =~ s/\r|\n//g;
8290                 &close_http_connection($h);
8291                 if ($line =~ /^HTTP\/1\..\s+(200)\s+/) {
8292                         push(@rv, { 'mirror' => $m,
8293                                     'default' => $m eq 'osdn',
8294                                     'url' => $url });
8295                         last;
8296                         }
8297                 }
8298         }
8299 return @rv;
8300 }
8301
8302 =head2 convert_osdn_url(url)
8303
8304 Given a URL like http://osdn.dl.sourceforge.net/sourceforge/project/file.zip
8305 or http://prdownloads.sourceforge.net/project/file.zip , convert it
8306 to a real URL on the sourceforge download redirector.
8307
8308 =cut
8309 sub convert_osdn_url
8310 {
8311 my ($url) = @_;
8312 if ($url =~ /^http:\/\/[^\.]+.dl.sourceforge.net\/sourceforge\/([^\/]+)\/(.*)$/ ||
8313     $url =~ /^http:\/\/prdownloads.sourceforge.net\/([^\/]+)\/(.*)$/) {
8314         # Always use the Sourceforge mail download URL, which does
8315         # a location-based redirect for us
8316         my ($project, $file) = ($1, $2);
8317         local $url = "http://prdownloads.sourceforge.net/sourceforge/".
8318                      "$project/$file";
8319         return wantarray ? ( $url, 0 ) : $url;
8320         }
8321 else {
8322         # Some other source .. don't change
8323         return wantarray ? ( $url, 2 ) : $url;
8324         }
8325 }
8326
8327 =head2 get_current_dir
8328
8329 Returns the directory the current process is running in.
8330
8331 =cut
8332 sub get_current_dir
8333 {
8334 my $out;
8335 if ($gconfig{'os_type'} eq 'windows') {
8336         # Use cd command
8337         $out = `cd`;
8338         }
8339 else {
8340         # Use pwd command
8341         $out = `pwd`;
8342         $out =~ s/\\/\//g;
8343         }
8344 $out =~ s/\r|\n//g;
8345 return $out;
8346 }
8347
8348 =head2 supports_users
8349
8350 Returns 1 if the current OS supports Unix user concepts and functions like
8351 su , getpw* and so on. This will be true on Linux and other Unixes, but false
8352 on Windows.
8353
8354 =cut
8355 sub supports_users
8356 {
8357 return $gconfig{'os_type'} ne 'windows';
8358 }
8359
8360 =head2 supports_symlinks
8361
8362 Returns 1 if the current OS supports symbolic and hard links. This will not
8363 be the case on Windows.
8364
8365 =cut
8366 sub supports_symlinks
8367 {
8368 return $gconfig{'os_type'} ne 'windows';
8369 }
8370
8371 =head2 quote_path(path)
8372
8373 Returns a path with safe quoting for the current operating system.
8374
8375 =cut
8376 sub quote_path
8377 {
8378 my ($path) = @_;
8379 if ($gconfig{'os_type'} eq 'windows' || $path =~ /^[a-z]:/i) {
8380         # Windows only supports "" style quoting
8381         return "\"$path\"";
8382         }
8383 else {
8384         return quotemeta($path);
8385         }
8386 }
8387
8388 =head2 get_windows_root
8389
8390 Returns the base windows system directory, like c:/windows.
8391
8392 =cut
8393 sub get_windows_root
8394 {
8395 if ($ENV{'SystemRoot'}) {
8396         my $rv = $ENV{'SystemRoot'};
8397         $rv =~ s/\\/\//g;
8398         return $rv;
8399         }
8400 else {
8401         return -d "c:/windows" ? "c:/windows" : "c:/winnt";
8402         }
8403 }
8404
8405 =head2 read_file_contents(file)
8406
8407 Given a filename, returns its complete contents as a string. Effectively
8408 the same as the Perl construct `cat file`.
8409
8410 =cut
8411 sub read_file_contents
8412 {
8413 &open_readfile(FILE, $_[0]) || return undef;
8414 local $/ = undef;
8415 my $rv = <FILE>;
8416 close(FILE);
8417 return $rv;
8418 }
8419
8420 =head2 unix_crypt(password, salt)
8421
8422 Performs Unix encryption on a password, using the built-in crypt function or
8423 the Crypt::UnixCrypt module if the former does not work. The salt parameter
8424 must be either an already-hashed password, or a two-character alpha-numeric
8425 string.
8426
8427 =cut
8428 sub unix_crypt
8429 {
8430 my ($pass, $salt) = @_;
8431 return "" if ($salt !~ /^[a-zA-Z0-9\.\/]{2}/);   # same as real crypt
8432 my $rv = eval "crypt(\$pass, \$salt)";
8433 my $err = $@;
8434 return $rv if ($rv && !$@);
8435 eval "use Crypt::UnixCrypt";
8436 if (!$@) {
8437         return Crypt::UnixCrypt::crypt($pass, $salt);
8438         }
8439 else {
8440         &error("Failed to encrypt password : $err");
8441         }
8442 }
8443
8444 =head2 split_quoted_string(string)
8445
8446 Given a string like I<foo "bar baz" quux>, returns the array :
8447 foo, bar baz, quux
8448
8449 =cut
8450 sub split_quoted_string
8451 {
8452 my ($str) = @_;
8453 my @rv;
8454 while($str =~ /^"([^"]*)"\s*([\000-\377]*)$/ ||
8455       $str =~ /^'([^']*)'\s*([\000-\377]*)$/ ||
8456       $str =~ /^(\S+)\s*([\000-\377]*)$/) {
8457         push(@rv, $1);
8458         $str = $2;
8459         }
8460 return @rv;
8461 }
8462
8463 =head2 write_to_http_cache(url, file|&data)
8464
8465 Updates the Webmin cache with the contents of the given file, possibly also
8466 clearing out old data. Mainly for internal use by http_download.
8467
8468 =cut
8469 sub write_to_http_cache
8470 {
8471 my ($url, $file) = @_;
8472 return 0 if (!$gconfig{'cache_size'});
8473
8474 # Don't cache downloads that look dynamic
8475 if ($url =~ /cgi-bin/ || $url =~ /\?/) {
8476         return 0;
8477         }
8478
8479 # Check if the current module should do caching
8480 if ($gconfig{'cache_mods'} =~ /^\!(.*)$/) {
8481         # Caching all except some modules
8482         my @mods = split(/\s+/, $1);
8483         return 0 if (&indexof(&get_module_name(), @mods) != -1);
8484         }
8485 elsif ($gconfig{'cache_mods'}) {
8486         # Only caching some modules
8487         my @mods = split(/\s+/, $gconfig{'cache_mods'});
8488         return 0 if (&indexof(&get_module_name(), @mods) == -1);
8489         }
8490
8491 # Work out the size
8492 my $size;
8493 if (ref($file)) {
8494         $size = length($$file);
8495         }
8496 else {
8497         my @st = stat($file);
8498         $size = $st[7];
8499         }
8500
8501 if ($size > $gconfig{'cache_size'}) {
8502         # Bigger than the whole cache - so don't save it
8503         return 0;
8504         }
8505 my $cfile = $url;
8506 $cfile =~ s/\//_/g;
8507 $cfile = "$main::http_cache_directory/$cfile";
8508
8509 # See how much we have cached currently, clearing old files
8510 my $total = 0;
8511 mkdir($main::http_cache_directory, 0700) if (!-d $main::http_cache_directory);
8512 opendir(CACHEDIR, $main::http_cache_directory);
8513 foreach my $f (readdir(CACHEDIR)) {
8514         next if ($f eq "." || $f eq "..");
8515         my $path = "$main::http_cache_directory/$f";
8516         my @st = stat($path);
8517         if ($gconfig{'cache_days'} &&
8518             time()-$st[9] > $gconfig{'cache_days'}*24*60*60) {
8519                 # This file is too old .. trash it
8520                 unlink($path);
8521                 }
8522         else {
8523                 $total += $st[7];
8524                 push(@cached, [ $path, $st[7], $st[9] ]);
8525                 }
8526         }
8527 closedir(CACHEDIR);
8528 @cached = sort { $a->[2] <=> $b->[2] } @cached;
8529 while($total+$size > $gconfig{'cache_size'} && @cached) {
8530         # Cache is too big .. delete some files until the new one will fit
8531         unlink($cached[0]->[0]);
8532         $total -= $cached[0]->[1];
8533         shift(@cached);
8534         }
8535
8536 # Finally, write out the new file
8537 if (ref($file)) {
8538         &open_tempfile(CACHEFILE, ">$cfile");
8539         &print_tempfile(CACHEFILE, $$file);
8540         &close_tempfile(CACHEFILE);
8541         }
8542 else {
8543         my ($ok, $err) = &copy_source_dest($file, $cfile);
8544         }
8545
8546 return 1;
8547 }
8548
8549 =head2 check_in_http_cache(url)
8550
8551 If some URL is in the cache and valid, return the filename for it. Mainly
8552 for internal use by http_download.
8553
8554 =cut
8555 sub check_in_http_cache
8556 {
8557 my ($url) = @_;
8558 return undef if (!$gconfig{'cache_size'});
8559
8560 # Check if the current module should do caching
8561 if ($gconfig{'cache_mods'} =~ /^\!(.*)$/) {
8562         # Caching all except some modules
8563         my @mods = split(/\s+/, $1);
8564         return 0 if (&indexof(&get_module_name(), @mods) != -1);
8565         }
8566 elsif ($gconfig{'cache_mods'}) {
8567         # Only caching some modules
8568         my @mods = split(/\s+/, $gconfig{'cache_mods'});
8569         return 0 if (&indexof(&get_module_name(), @mods) == -1);
8570         }
8571
8572 my $cfile = $url;
8573 $cfile =~ s/\//_/g;
8574 $cfile = "$main::http_cache_directory/$cfile";
8575 my @st = stat($cfile);
8576 return undef if (!@st || !$st[7]);
8577 if ($gconfig{'cache_days'} && time()-$st[9] > $gconfig{'cache_days'}*24*60*60) {
8578         # Too old!
8579         unlink($cfile);
8580         return undef;
8581         }
8582 open(TOUCH, ">>$cfile");        # Update the file time, to keep it in the cache
8583 close(TOUCH);
8584 return $cfile;
8585 }
8586
8587 =head2 supports_javascript
8588
8589 Returns 1 if the current browser is assumed to support javascript.
8590
8591 =cut
8592 sub supports_javascript
8593 {
8594 if (defined(&theme_supports_javascript)) {
8595         return &theme_supports_javascript();
8596         }
8597 return $ENV{'MOBILE_DEVICE'} ? 0 : 1;
8598 }
8599
8600 =head2 get_module_name
8601
8602 Returns the name of the Webmin module that called this function. For internal
8603 use only by other API functions.
8604
8605 =cut
8606 sub get_module_name
8607 {
8608 return &get_module_variable('$module_name');
8609 }
8610
8611 =head2 get_module_variable(name, [ref])
8612
8613 Returns the value of some variable which is set in the caller's context, if
8614 using the new WebminCore package. For internal use only.
8615
8616 =cut
8617 sub get_module_variable
8618 {
8619 my ($v, $wantref) = @_;
8620 my $slash = $wantref ? "\\" : "";
8621 my $thispkg = &web_libs_package();
8622 if ($thispkg eq 'WebminCore') {
8623         my ($vt, $vn) = split('', $v, 2);
8624         my $callpkg;
8625         for(my $i=0; ($callpkg) = caller($i); $i++) {
8626                 last if ($callpkg ne $thispkg);
8627                 }
8628         return eval "${slash}${vt}${callpkg}::${vn}";
8629         }
8630 return eval "${slash}${v}";
8631 }
8632
8633 =head2 clear_time_locale()
8634
8635 Temporarily force the locale to C, until reset_time_locale is called. This is
8636 useful if your code is going to call C<strftime> from the POSIX package, and
8637 you want to ensure that the output is in a consistent format.
8638
8639 =cut
8640 sub clear_time_locale
8641 {
8642 if ($main::clear_time_locale_count == 0) {
8643         eval {
8644                 use POSIX;
8645                 $main::clear_time_locale_old = POSIX::setlocale(POSIX::LC_TIME);
8646                 POSIX::setlocale(POSIX::LC_TIME, "C");
8647                 };
8648         }
8649 $main::clear_time_locale_count++;
8650 }
8651
8652 =head2 reset_time_locale()
8653
8654 Revert the locale to whatever it was before clear_time_locale was called
8655
8656 =cut
8657 sub reset_time_locale
8658 {
8659 if ($main::clear_time_locale_count == 1) {
8660         eval {
8661                 POSIX::setlocale(POSIX::LC_TIME, $main::clear_time_locale_old);
8662                 $main::clear_time_locale_old = undef;
8663                 };
8664         }
8665 $main::clear_time_locale_count--;
8666 }
8667
8668 =head2 callers_package(filehandle)
8669
8670 Convert a non-module filehandle like FOO to one qualified with the
8671 caller's caller's package, like fsdump::FOO. For internal use only.
8672
8673 =cut
8674 sub callers_package
8675 {
8676 my ($fh) = @_;
8677 my $callpkg = (caller(1))[0];
8678 my $thispkg = &web_libs_package();
8679 if (!ref($fh) && $fh !~ /::/ &&
8680     $callpkg ne $thispkg && $thispkg eq 'WebminCore') {
8681         $fh = $callpkg."::".$fh;
8682         }
8683 return $fh;
8684 }
8685
8686 =head2 web_libs_package()
8687
8688 Returns the package this code is in. We can't always trust __PACKAGE__. For
8689 internal use only.
8690
8691 =cut
8692 sub web_libs_package
8693 {
8694 if ($called_from_webmin_core) {
8695         return "WebminCore";
8696         }
8697 return __PACKAGE__;
8698 }
8699
8700 $done_web_lib_funcs = 1;
8701
8702 1;