1 =head1 web-lib-funcs.pl
3 Common functions for Webmin CGI scripts. This file gets in-directly included
4 by all scripts that use web-lib.pl.
9 ui_print_header(undef, 'My Module', '');
10 print 'This is Webmin version ',get_webmin_version(),'<p>\n';
19 use vars qw($user_risk_level $loaded_theme_library $wait_for_input
20 $done_webmin_header $trust_unknown_referers $unsafe_index_cgi
21 %done_foreign_require $webmin_feedback_address
22 $user_skill_level $pragma_no_cache $foreign_args);
24 use vars qw($module_index_name $number_to_month_map $month_to_number_map
25 $umask_already $default_charset $licence_status $os_type
26 $licence_message $script_name $loaded_theme_oo_library
27 $done_web_lib_funcs $os_version $module_index_link
28 $called_from_webmin_core);
30 =head2 read_file(file, &hash, [&order], [lowercase], [split-char])
32 Fill the given hash reference with name=value pairs from a file. The required
35 =item file - The file to head, which must be text with each line like name=value
37 =item hash - The hash reference to add values read from the file to.
39 =item order - If given, an array reference to add names to in the order they were read
41 =item lowercase - If set to 1, names are converted to lower case
43 =item split-char - If set, names and values are split on this character instead of =
49 my $split = defined($_[4]) ? $_[4] : "=";
50 my $realfile = &translate_filename($_[0]);
51 &open_readfile(ARFILE, $_[0]) || return 0;
54 my $hash = index($_, "#");
55 my $eq = index($_, $split);
56 if ($hash != 0 && $eq >= 0) {
57 my $n = substr($_, 0, $eq);
58 my $v = substr($_, $eq+1);
60 $_[1]->{$_[3] ? lc($n) : $n} = $v;
61 push(@{$_[2]}, $n) if ($_[2]);
65 $main::read_file_missing{$realfile} = 0; # It exists now
66 if (defined($main::read_file_cache{$realfile})) {
67 %{$main::read_file_cache{$realfile}} = %{$_[1]};
72 =head2 read_file_cached(file, &hash, [&order], [lowercase], [split-char])
74 Like read_file, but reads from an in-memory cache if the file has already been
75 read in this Webmin script. Recommended, as it behaves exactly the same as
76 read_file, but can be much faster.
81 my $realfile = &translate_filename($_[0]);
82 if (defined($main::read_file_cache{$realfile})) {
84 %{$_[1]} = ( %{$_[1]}, %{$main::read_file_cache{$realfile}} );
87 elsif ($main::read_file_missing{$realfile}) {
88 # Doesn't exist, so don't re-try read
92 # Actually read the file
94 if (&read_file($_[0], \%d, $_[2], $_[3], $_[4])) {
95 %{$main::read_file_cache{$realfile}} = %d;
96 %{$_[1]} = ( %{$_[1]}, %d );
100 # Flag as non-existant
101 $main::read_file_missing{$realfile} = 1;
107 =head2 write_file(file, &hash, [join-char])
109 Write out the contents of a hash as name=value lines. The parameters are :
111 =item file - Full path to write to
113 =item hash - A hash reference containing names and values to output
115 =item join-char - If given, names and values are separated by this instead of =
121 my $join = defined($_[2]) ? $_[2] : "=";
122 my $realfile = &translate_filename($_[0]);
123 &read_file($_[0], \%old, \@order);
124 &open_tempfile(ARFILE, ">$_[0]");
125 foreach $k (@order) {
126 if (exists($_[1]->{$k})) {
127 (print ARFILE $k,$join,$_[1]->{$k},"\n") ||
128 &error(&text("efilewrite", $realfile, $!));
131 foreach $k (keys %{$_[1]}) {
132 if (!exists($old{$k})) {
133 (print ARFILE $k,$join,$_[1]->{$k},"\n") ||
134 &error(&text("efilewrite", $realfile, $!));
137 &close_tempfile(ARFILE);
138 if (defined($main::read_file_cache{$realfile})) {
139 %{$main::read_file_cache{$realfile}} = %{$_[1]};
141 if (defined($main::read_file_missing{$realfile})) {
142 $main::read_file_missing{$realfile} = 0;
146 =head2 html_escape(string)
148 Converts &, < and > codes in text to HTML entities, and returns the new string.
149 This should be used when including data read from other sources in HTML pages.
158 $tmp =~ s/\"/"/g;
159 $tmp =~ s/\'/'/g;
164 =head2 quote_escape(string, [only-quote])
166 Converts ' and " characters in a string into HTML entities, and returns it.
167 Useful for outputing HTML tag values.
172 my ($tmp, $only) = @_;
173 if ($tmp !~ /\&[a-zA-Z]+;/ && $tmp !~ /\&#/) {
174 # convert &, unless it is part of &#nnn; or &foo;
175 $tmp =~ s/&([^#])/&$1/g;
177 $tmp =~ s/&$/&/g;
178 $tmp =~ s/\"/"/g if ($only eq '' || $only eq '"');
179 $tmp =~ s/\'/'/g if ($only eq '' || $only eq "'");
183 =head2 tempname([filename])
185 Returns a mostly random temporary file name, typically under the /tmp/.webmin
186 directory. If filename is given, this will be the base name used. Otherwise
187 a unique name is selected randomly.
192 my $tmp_base = $gconfig{'tempdir_'.&get_module_name()} ?
193 $gconfig{'tempdir_'.&get_module_name()} :
194 $gconfig{'tempdir'} ? $gconfig{'tempdir'} :
195 $ENV{'TEMP'} ? $ENV{'TEMP'} :
196 $ENV{'TMP'} ? $ENV{'TMP'} :
197 -d "c:/temp" ? "c:/temp" : "/tmp/.webmin";
198 my $tmp_dir = -d $remote_user_info[7] && !$gconfig{'nohometemp'} ?
199 "$remote_user_info[7]/.tmp" :
200 @remote_user_info ? $tmp_base."-".$remote_user :
201 $< != 0 ? $tmp_base."-".getpwuid($<) :
203 if ($gconfig{'os_type'} eq 'windows' || $tmp_dir =~ /^[a-z]:/i) {
204 # On Windows system, just create temp dir if missing
206 mkdir($tmp_dir, 0755) ||
207 &error("Failed to create temp directory $tmp_dir : $!");
211 # On Unix systems, need to make sure temp dir is valid
213 while($tries++ < 10) {
214 my @st = lstat($tmp_dir);
215 last if ($st[4] == $< && (-d _) && ($st[2] & 0777) == 0755);
217 unlink($tmp_dir) || rmdir($tmp_dir) ||
218 system("/bin/rm -rf ".quotemeta($tmp_dir));
220 mkdir($tmp_dir, 0755) || next;
221 chown($<, $(, $tmp_dir);
222 chmod(0755, $tmp_dir);
225 my @st = lstat($tmp_dir);
226 &error("Failed to create temp directory $tmp_dir : uid=$st[4] mode=$st[2]");
230 if (defined($_[0]) && $_[0] !~ /\.\./) {
231 $rv = "$tmp_dir/$_[0]";
234 $main::tempfilecount++;
236 $rv = $tmp_dir."/".int(rand(1000000))."_".
237 $main::tempfilecount."_".$scriptname;
242 =head2 transname([filename])
244 Behaves exactly like tempname, but records the temp file for deletion when the
245 current Webmin script process exits.
250 my $rv = &tempname(@_);
251 push(@main::temporary_files, $rv);
255 =head2 trunc(string, maxlen)
257 Truncates a string to the shortest whole word less than or equal to the
258 given width. Useful for word wrapping.
263 if (length($_[0]) <= $_[1]) {
266 my $str = substr($_[0],0,$_[1]);
275 =head2 indexof(string, value, ...)
277 Returns the index of some value in an array of values, or -1 if it was not
283 for(my $i=1; $i <= $#_; $i++) {
284 if ($_[$i] eq $_[0]) { return $i - 1; }
289 =head2 indexoflc(string, value, ...)
291 Like indexof, but does a case-insensitive match
296 my $str = lc(shift(@_));
297 my @arr = map { lc($_) } @_;
298 return &indexof($str, @arr);
301 =head2 sysprint(handle, [string]+)
303 Outputs some strings to a file handle, but bypassing IO buffering. Can be used
304 as a replacement for print when writing to pipes or sockets.
309 my $fh = &callers_package($_[0]);
310 my $str = join('', @_[1..$#_]);
311 syswrite $fh, $str, length($str);
314 =head2 check_ipaddress(ip)
316 Check if some IPv4 address is properly formatted, returning 1 if so or 0 if not.
321 return $_[0] =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/ &&
322 $1 >= 0 && $1 <= 255 &&
323 $2 >= 0 && $2 <= 255 &&
324 $3 >= 0 && $3 <= 255 &&
325 $4 >= 0 && $4 <= 255;
328 =head2 check_ip6address(ip)
330 Check if some IPv6 address is properly formatted, and returns 1 if so.
335 my @blocks = split(/:/, $_[0]);
336 return 0 if (@blocks == 0 || @blocks > 8);
338 # The address/netmask format is accepted. So we're looking for a "/" to isolate a possible netmask.
339 # After that, we delete the netmask to control the address only format, but we verify whether the netmask
340 # value is in [0;128].
342 my $where = index($blocks[$ib],"/");
345 my $b = substr($blocks[$ib],0,$where);
346 $m = substr($blocks[$ib],$where+1,length($blocks[$ib])-($where+1));
350 # The netmask must take its value in [0;128]
351 return 0 if ($m <0 || $m >128);
353 # Check the different blocks of the address : 16 bits block in hexa notation.
354 # Possibility of 1 empty block or 2 if the address begins with "::".
357 foreach $b (@blocks) {
358 return 0 if ($b ne "" && $b !~ /^[0-9a-f]{1,4}$/i);
359 $empty++ if ($b eq "");
361 return 0 if ($empty > 1 && !($_[0] =~ /^::/ && $empty == 2));
367 =head2 generate_icon(image, title, link, [href], [width], [height], [before-title], [after-title])
369 Prints HTML for an icon image. The parameters are :
371 =item image - URL for the image, like images/foo.gif
373 =item title - Text to appear under the icon
375 =item link - Optional destination for the icon's link
377 =item href - Other HTML attributes to be added to the <a href> for the link
379 =item width - Optional width of the icon
381 =item height - Optional height of the icon
383 =item before-title - HTML to appear before the title link, but which is not actually in the link
385 =item after-title - HTML to appear after the title link, but which is not actually in the link
390 &load_theme_library();
391 if (defined(&theme_generate_icon)) {
392 &theme_generate_icon(@_);
395 my $w = !defined($_[4]) ? "width=48" : $_[4] ? "width=$_[4]" : "";
396 my $h = !defined($_[5]) ? "height=48" : $_[5] ? "height=$_[5]" : "";
397 if ($tconfig{'noicons'}) {
399 print "$_[6]<a href=\"$_[2]\" $_[3]>$_[1]</a>$_[7]\n";
402 print "$_[6]$_[1]$_[7]\n";
406 print "<table border><tr><td width=48 height=48>\n",
407 "<a href=\"$_[2]\" $_[3]><img src=\"$_[0]\" alt=\"\" border=0 ",
408 "$w $h></a></td></tr></table>\n";
409 print "$_[6]<a href=\"$_[2]\" $_[3]>$_[1]</a>$_[7]\n";
412 print "<table border><tr><td width=48 height=48>\n",
413 "<img src=\"$_[0]\" alt=\"\" border=0 $w $h>",
414 "</td></tr></table>\n$_[6]$_[1]$_[7]\n";
420 Converts a string to a form ok for putting in a URL, using % escaping.
426 $rv =~ s/([^A-Za-z0-9])/sprintf("%%%2.2X", ord($1))/ge;
430 =head2 un_urlize(string)
432 Converts a URL-encoded string to it's original contents - the reverse of the
440 $rv =~ s/%(..)/pack("c",hex($1))/ge;
444 =head2 include(filename)
446 Read and output the contents of the given file.
452 open(INCLUDE, &translate_filename($_[0])) || return 0;
460 =head2 copydata(in-handle, out-handle)
462 Read from one file handle and write to another, until there is no more to read.
468 $in = &callers_package($in);
469 $out = &callers_package($out);
471 while(read($in, $buf, 1024) > 0) {
472 (print $out $buf) || return 0;
477 =head2 ReadParseMime([maximum], [&cbfunc, &cbargs])
479 Read data submitted via a POST request using the multipart/form-data coding,
480 and store it in the global %in hash. The optional parameters are :
482 =item maximum - If the number of bytes of input exceeds this number, stop reading and call error.
484 =item cbfunc - A function reference to call after reading each block of data.
486 =item cbargs - Additional parameters to the callback function.
491 my ($max, $cbfunc, $cbargs) = @_;
492 my ($boundary, $line, $foo, $name, $got, $file);
493 my $err = &text('readparse_max', $max);
494 $ENV{'CONTENT_TYPE'} =~ /boundary=(.*)$/ || &error($text{'readparse_enc'});
495 if ($ENV{'CONTENT_LENGTH'} && $max && $ENV{'CONTENT_LENGTH'} > $max) {
498 &$cbfunc(0, $ENV{'CONTENT_LENGTH'}, $file, @$cbargs) if ($cbfunc);
500 <STDIN>; # skip first boundary
503 # Read section headers
507 $got += length($line);
508 &$cbfunc($got, $ENV{'CONTENT_LENGTH'}, @$cbargs) if ($cbfunc);
509 if ($max && $got > $max) {
514 if ($line =~ /^(\S+):\s*(.*)$/) {
515 $header{$lastheader = lc($1)} = $2;
517 elsif ($line =~ /^\s+(.*)$/) {
518 $header{$lastheader} .= $line;
522 # Parse out filename and type
523 if ($header{'content-disposition'} =~ /^form-data(.*)/) {
525 while ($rest =~ /([a-zA-Z]*)=\"([^\"]*)\"(.*)/) {
530 $foo = $name . "_$1";
537 &error($text{'readparse_cdheader'});
539 if ($header{'content-type'} =~ /^([^\s;]+)/) {
540 $foo = $name . "_content_type";
543 $file = $in{$name."_filename"};
546 $in{$name} .= "\0" if (defined($in{$name}));
549 $got += length($line);
550 &$cbfunc($got, $ENV{'CONTENT_LENGTH'}, $file, @$cbargs)
552 if ($max && $got > $max) {
553 #print STDERR "over limit of $max\n";
558 &$cbfunc(-1, $ENV{'CONTENT_LENGTH'}, $file, @$cbargs)
563 $ptline =~ s/[^a-zA-Z0-9\-]/\./g;
564 if (index($line, $boundary) != -1) { last; }
567 chop($in{$name}); chop($in{$name});
568 if (index($line,"$boundary--") != -1) { last; }
570 &$cbfunc(-1, $ENV{'CONTENT_LENGTH'}, $file, @$cbargs) if ($cbfunc);
573 =head2 ReadParse([&hash], [method], [noplus])
575 Fills the given hash reference with CGI parameters, or uses the global hash
576 %in if none is given. Also sets the global variables $in and @in. The other
579 =item method - For use of this HTTP method, such as GET
581 =item noplus - Don't convert + in parameters to spaces.
586 my $a = $_[0] || \%in;
588 my $meth = $_[1] ? $_[1] : $ENV{'REQUEST_METHOD'};
590 if ($meth eq 'POST') {
591 my $clen = $ENV{'CONTENT_LENGTH'};
592 &read_fully(STDIN, \$in, $clen) == $clen ||
593 &error("Failed to read POST input : $!");
595 if ($ENV{'QUERY_STRING'}) {
596 if ($in) { $in .= "&".$ENV{'QUERY_STRING'}; }
597 else { $in = $ENV{'QUERY_STRING'}; }
599 @in = split(/\&/, $in);
600 foreach my $i (@in) {
601 my ($k, $v) = split(/=/, $i, 2);
606 $k =~ s/%(..)/pack("c",hex($1))/ge;
607 $v =~ s/%(..)/pack("c",hex($1))/ge;
608 $a->{$k} = defined($a->{$k}) ? $a->{$k}."\0".$v : $v;
612 =head2 read_fully(fh, &buffer, length)
614 Read data from some file handle up to the given length, even in the face
615 of partial reads. Reads the number of bytes read. Stores received data in the
616 string pointed to be the buffer reference.
621 my ($fh, $buf, $len) = @_;
622 $fh = &callers_package($fh);
625 my $r = read(STDIN, $$buf, $len-$got, $got);
632 =head2 read_parse_mime_callback(size, totalsize, upload-id)
634 Called by ReadParseMime as new data arrives from a form-data POST. Only updates
635 the file on every 1% change though. For internal use by the upload progress
639 sub read_parse_mime_callback
641 my ($size, $totalsize, $filename, $id) = @_;
642 return if ($gconfig{'no_upload_tracker'});
645 # Create the upload tracking directory - if running as non-root, this has to
646 # be under the user's home
649 my @uinfo = @remote_user_info ? @remote_user_info : getpwuid($<);
650 $vardir = "$uinfo[7]/.tmp";
653 $vardir = $ENV{'WEBMIN_VAR'};
656 &make_dir($vardir, 0755);
659 # Remove any upload.* files more than 1 hour old
660 if (!$main::read_parse_mime_callback_flushed) {
662 opendir(UPDIR, $vardir);
663 foreach my $f (readdir(UPDIR)) {
664 next if ($f !~ /^upload\./);
665 my @st = stat("$vardir/$f");
666 if ($st[9] < $now-3600) {
667 unlink("$vardir/$f");
671 $main::read_parse_mime_callback_flushed++;
674 # Only update file once per percent
675 my $upfile = "$vardir/upload.$id";
676 if ($totalsize && $size >= 0) {
677 my $pc = int(100 * $size / $totalsize);
678 if ($pc <= $main::read_parse_mime_callback_pc{$upfile}) {
681 $main::read_parse_mime_callback_pc{$upfile} = $pc;
685 &open_tempfile(UPFILE, ">$upfile");
686 print UPFILE $size,"\n";
687 print UPFILE $totalsize,"\n";
688 print UPFILE $filename,"\n";
689 &close_tempfile(UPFILE);
692 =head2 read_parse_mime_javascript(upload-id, [&fields])
694 Returns an onSubmit= Javascript statement to popup a window for tracking
695 an upload with the given ID. For internal use by the upload progress tracker.
698 sub read_parse_mime_javascript
700 my ($id, $fields) = @_;
701 return "" if ($gconfig{'no_upload_tracker'});
702 my $opener = "window.open(\"$gconfig{'webprefix'}/uptracker.cgi?id=$id&uid=$<\", \"uptracker\", \"toolbar=no,menubar=no,scrollbars=no,width=500,height=100\");";
704 my $if = join(" || ", map { "typeof($_) != \"undefined\" && $_.value != \"\"" } @$fields);
705 return "onSubmit='if ($if) { $opener }'";
708 return "onSubmit='$opener'";
712 =head2 PrintHeader(charset)
714 Outputs the HTTP headers for an HTML page. The optional charset parameter
715 can be used to set a character set. Normally this function is not called
716 directly, but is rather called by ui_print_header or header.
721 if ($pragma_no_cache || $gconfig{'pragma_no_cache'}) {
722 print "pragma: no-cache\n";
723 print "Expires: Thu, 1 Jan 1970 00:00:00 GMT\n";
724 print "Cache-Control: no-store, no-cache, must-revalidate\n";
725 print "Cache-Control: post-check=0, pre-check=0\n";
727 if (defined($_[0])) {
728 print "Content-type: text/html; Charset=$_[0]\n\n";
731 print "Content-type: text/html\n\n";
735 =head2 header(title, image, [help], [config], [nomodule], [nowebmin], [rightside], [head-stuff], [body-stuff], [below])
737 Outputs a Webmin HTML page header with a title, including HTTP headers. The
740 =item title - The text to show at the top of the page
742 =item image - An image to show instead of the title text. This is typically left blank.
744 =item help - If set, this is the name of a help page that will be linked to in the title.
746 =item config - If set to 1, the title will contain a link to the module's config page.
748 =item nomodule - If set to 1, there will be no link in the title section to the module's index.
750 =item nowebmin - If set to 1, there will be no link in the title section to the Webmin index.
752 =item rightside - HTML to be shown on the right-hand side of the title. Can contain multiple lines, separated by <br>. Typically this is used for links to stop, start or restart servers.
754 =item head-stuff - HTML to be included in the <head> section of the page.
756 =item body-stuff - HTML attributes to be include in the <body> tag.
758 =item below - HTML to be displayed below the title. Typically this is used for application or server version information.
763 return if ($main::done_webmin_header++);
765 my $charset = defined($main::force_charset) ? $main::force_charset
767 &PrintHeader($charset);
768 &load_theme_library();
769 if (defined(&theme_header)) {
770 $module_name = &get_module_name();
774 print "<!doctype html public \"-//W3C//DTD HTML 3.2 Final//EN\">\n";
777 if (defined(&theme_prehead)) {
781 print "<meta http-equiv=\"Content-Type\" ",
782 "content=\"text/html; Charset="."e_escape($charset)."\">\n";
785 my $title = &get_html_title($_[0]);
786 print "<title>$title</title>\n";
787 print $_[7] if ($_[7]);
788 print &get_html_status_line(0);
790 print "$tconfig{'headhtml'}\n" if ($tconfig{'headhtml'});
791 if ($tconfig{'headinclude'}) {
792 print &read_file_contents(
793 "$theme_root_directory/$tconfig{'headinclude'}");
796 my $bgcolor = defined($tconfig{'cs_page'}) ? $tconfig{'cs_page'} :
797 defined($gconfig{'cs_page'}) ? $gconfig{'cs_page'} : "ffffff";
798 my $link = defined($tconfig{'cs_link'}) ? $tconfig{'cs_link'} :
799 defined($gconfig{'cs_link'}) ? $gconfig{'cs_link'} : "0000ee";
800 my $text = defined($tconfig{'cs_text'}) ? $tconfig{'cs_text'} :
801 defined($gconfig{'cs_text'}) ? $gconfig{'cs_text'} : "000000";
802 my $bgimage = defined($tconfig{'bgimage'}) ? "background=$tconfig{'bgimage'}"
804 my $dir = $current_lang_info->{'dir'} ? "dir=\"$current_lang_info->{'dir'}\""
806 print "<body bgcolor=#$bgcolor link=#$link vlink=#$link text=#$text ",
807 "$bgimage $tconfig{'inbody'} $dir $_[8]>\n";
808 if (defined(&theme_prebody)) {
811 my $hostname = &get_display_hostname();
812 my $version = &get_webmin_version();
813 my $prebody = $tconfig{'prebody'};
815 $prebody =~ s/%HOSTNAME%/$hostname/g;
816 $prebody =~ s/%VERSION%/$version/g;
817 $prebody =~ s/%USER%/$remote_user/g;
818 $prebody =~ s/%OS%/$os_type $os_version/g;
821 if ($tconfig{'prebodyinclude'}) {
823 open(INC, "$theme_root_directory/$tconfig{'prebodyinclude'}");
830 print $tconfig{'preheader'};
831 my %this_module_info = &get_module_info(&get_module_name());
832 print "<table class='header' width=100%><tr>\n";
833 if ($gconfig{'sysinfo'} == 2 && $remote_user) {
834 print "<td id='headln1' colspan=3 align=center>\n";
835 print &get_html_status_line(1);
836 print "</td></tr> <tr>\n";
838 print "<td id='headln2l' width=15% valign=top align=left>";
839 if ($ENV{'HTTP_WEBMIN_SERVERS'} && !$tconfig{'framed'}) {
840 print "<a href='$ENV{'HTTP_WEBMIN_SERVERS'}'>",
841 "$text{'header_servers'}</a><br>\n";
843 if (!$_[5] && !$tconfig{'noindex'}) {
844 my @avail = &get_available_module_infos(1);
845 my $nolo = $ENV{'ANONYMOUS_USER'} ||
846 $ENV{'SSL_USER'} || $ENV{'LOCAL_USER'} ||
847 $ENV{'HTTP_USER_AGENT'} =~ /webmin/i;
848 if ($gconfig{'gotoone'} && $main::session_id && @avail == 1 &&
850 print "<a href='$gconfig{'webprefix'}/session_login.cgi?logout=1'>",
851 "$text{'main_logout'}</a><br>";
853 elsif ($gconfig{'gotoone'} && @avail == 1 && !$nolo) {
854 print "<a href=$gconfig{'webprefix'}/switch_user.cgi>",
855 "$text{'main_switch'}</a><br>";
857 elsif (!$gconfig{'gotoone'} || @avail > 1) {
858 print "<a href='$gconfig{'webprefix'}/?cat=",
859 $this_module_info{'category'},
860 "'>$text{'header_webmin'}</a><br>\n";
863 if (!$_[4] && !$tconfig{'nomoduleindex'}) {
864 my $idx = $this_module_info{'index_link'};
865 my $mi = $module_index_link || "/".&get_module_name()."/$idx";
866 my $mt = $module_index_name || $text{'header_module'};
867 print "<a href=\"$gconfig{'webprefix'}$mi\">$mt</a><br>\n";
869 if (ref($_[2]) eq "ARRAY" && !$ENV{'ANONYMOUS_USER'} &&
870 !$tconfig{'nohelp'}) {
871 print &hlink($text{'header_help'}, $_[2]->[0], $_[2]->[1]),
874 elsif (defined($_[2]) && !$ENV{'ANONYMOUS_USER'} &&
875 !$tconfig{'nohelp'}) {
876 print &hlink($text{'header_help'}, $_[2]),"<br>\n";
879 my %access = &get_module_acl();
880 if (!$access{'noconfig'} && !$config{'noprefs'}) {
881 my $cprog = $user_module_config_directory ?
882 "uconfig.cgi" : "config.cgi";
883 print "<a href=\"$gconfig{'webprefix'}/$cprog?",
884 &get_module_name()."\">",
885 $text{'header_config'},"</a><br>\n";
890 # Title is a single image
891 print "<td id='headln2c' align=center width=70%>",
892 "<img alt=\"$_[0]\" src=\"$_[1]\"></td>\n";
896 my $ts = defined($tconfig{'titlesize'}) ?
897 $tconfig{'titlesize'} : "+2";
898 print "<td id='headln2c' align=center width=70%>",
899 ($ts ? "<font size=$ts>" : ""),$_[0],
900 ($ts ? "</font>" : "");
901 print "<br>$_[9]\n" if ($_[9]);
904 print "<td id='headln2r' width=15% valign=top align=right>";
906 print "</td></tr></table>\n";
907 print $tconfig{'postheader'};
911 =head2 get_html_title(title)
913 Returns the full string to appear in the HTML <title> block.
920 my $os_type = $gconfig{'real_os_type'} || $gconfig{'os_type'};
921 my $os_version = $gconfig{'real_os_version'} || $gconfig{'os_version'};
922 my $host = &get_display_hostname();
923 if ($gconfig{'sysinfo'} == 1 && $remote_user) {
924 $title = sprintf "%s : %s on %s (%s %s)\n",
925 $msg, $remote_user, $host,
926 $os_type, $os_version;
928 elsif ($gconfig{'sysinfo'} == 4 && $remote_user) {
929 $title = sprintf "%s on %s (%s %s)\n",
931 $os_type, $os_version;
936 if ($gconfig{'showlogin'} && $remote_user) {
937 $title = $remote_user.($title ? " : ".$title : "");
939 if ($gconfig{'showhost'}) {
940 $title = $host.($title ? " : ".$title : "");
945 =head2 get_html_framed_title
947 Returns the title text for a framed theme main page.
950 sub get_html_framed_title
953 my $os_type = $gconfig{'real_os_type'} || $gconfig{'os_type'};
954 my $os_version = $gconfig{'real_os_version'} || $gconfig{'os_version'};
956 if (($gconfig{'sysinfo'} == 4 || $gconfig{'sysinfo'} == 1) && $remote_user) {
957 # Alternate title mode requested
958 $title = sprintf "%s on %s (%s %s)\n",
959 $remote_user, &get_display_hostname(),
960 $os_type, $os_version;
963 # Title like 'Webmin x.yy on hostname (Linux 6)'
964 if ($os_version eq "*") {
968 $ostr = "$os_type $os_version";
970 my $host = &get_display_hostname();
971 my $ver = &get_webmin_version();
972 $title = $gconfig{'nohostname'} ? $text{'main_title2'} :
973 $gconfig{'showhost'} ? &text('main_title3', $ver, $ostr) :
974 &text('main_title', $ver, $host, $ostr);
975 if ($gconfig{'showlogin'}) {
976 $title = $remote_user.($title ? " : ".$title : "");
978 if ($gconfig{'showhost'}) {
979 $title = $host.($title ? " : ".$title : "");
985 =head2 get_html_status_line(text-only)
987 Returns HTML for a script block that sets the status line, or if text-only
988 is set to 1, just return the status line text.
991 sub get_html_status_line
994 if (($gconfig{'sysinfo'} != 0 || !$remote_user) && !$textonly) {
995 # Disabled in this mode
998 my $os_type = $gconfig{'real_os_type'} || $gconfig{'os_type'};
999 my $os_version = $gconfig{'real_os_version'} || $gconfig{'os_version'};
1000 my $line = &text('header_statusmsg',
1001 ($ENV{'ANONYMOUS_USER'} ? "Anonymous user"
1003 ($ENV{'SSL_USER'} ? " (SSL certified)" :
1004 $ENV{'LOCAL_USER'} ? " (Local user)" : ""),
1005 $text{'programname'},
1006 &get_webmin_version(),
1007 &get_display_hostname(),
1008 $os_type.($os_version eq "*" ? "" :" $os_version"));
1013 $line =~ s/\r|\n//g;
1014 return "<script language=JavaScript type=text/javascript>\n".
1015 "defaultStatus=\""."e_escape($line)."\";\n".
1020 =head2 popup_header([title], [head-stuff], [body-stuff], [no-body])
1022 Outputs a page header, suitable for a popup window. If no title is given,
1023 absolutely no decorations are output. Also useful in framesets. The parameters
1026 =item title - Title text for the popup window.
1028 =item head-stuff - HTML to appear in the <head> section.
1030 =item body-stuff - HTML attributes to be include in the <body> tag.
1032 =item no-body - If set to 1, don't generate a body tag
1037 return if ($main::done_webmin_header++);
1039 my $charset = defined($main::force_charset) ? $main::force_charset
1041 &PrintHeader($charset);
1042 &load_theme_library();
1043 if (defined(&theme_popup_header)) {
1044 &theme_popup_header(@_);
1047 print "<!doctype html public \"-//W3C//DTD HTML 3.2 Final//EN\">\n";
1050 if (defined(&theme_popup_prehead)) {
1051 &theme_popup_prehead(@_);
1053 print "<title>$_[0]</title>\n";
1055 print "$tconfig{'headhtml'}\n" if ($tconfig{'headhtml'});
1056 if ($tconfig{'headinclude'}) {
1057 print &read_file_contents(
1058 "$theme_root_directory/$tconfig{'headinclude'}");
1061 my $bgcolor = defined($tconfig{'cs_page'}) ? $tconfig{'cs_page'} :
1062 defined($gconfig{'cs_page'}) ? $gconfig{'cs_page'} : "ffffff";
1063 my $link = defined($tconfig{'cs_link'}) ? $tconfig{'cs_link'} :
1064 defined($gconfig{'cs_link'}) ? $gconfig{'cs_link'} : "0000ee";
1065 my $text = defined($tconfig{'cs_text'}) ? $tconfig{'cs_text'} :
1066 defined($gconfig{'cs_text'}) ? $gconfig{'cs_text'} : "000000";
1067 my $bgimage = defined($tconfig{'bgimage'}) ? "background=$tconfig{'bgimage'}"
1070 print "<body id='popup' bgcolor=#$bgcolor link=#$link vlink=#$link ",
1071 "text=#$text $bgimage $tconfig{'inbody'} $_[2]>\n";
1072 if (defined(&theme_popup_prebody)) {
1073 &theme_popup_prebody(@_);
1078 =head2 footer([page, name]+, [noendbody])
1080 Outputs the footer for a Webmin HTML page, possibly with links back to other
1081 pages. The links are specified by pairs of parameters, the first of which is
1082 a link destination, and the second the link text. For example :
1084 footer('/', 'Webmin index', '', 'Module menu');
1089 &load_theme_library();
1090 my %this_module_info = &get_module_info(&get_module_name());
1091 if (defined(&theme_footer)) {
1092 $module_name = &get_module_name(); # Old themes use these
1093 %module_info = %this_module_info;
1097 for(my $i=0; $i+1<@_; $i+=2) {
1099 if ($url ne '/' || !$tconfig{'noindex'}) {
1101 $url = "/?cat=$this_module_info{'category'}";
1103 elsif ($url eq '' && &get_module_name()) {
1104 $url = "/".&get_module_name()."/".
1105 $this_module_info{'index_link'};
1107 elsif ($url =~ /^\?/ && &get_module_name()) {
1108 $url = "/".&get_module_name()."/$url";
1110 $url = "$gconfig{'webprefix'}$url" if ($url =~ /^\//);
1112 print "<a href=\"$url\"><img alt=\"<-\" align=middle border=0 src=$gconfig{'webprefix'}/images/left.gif></a>\n";
1117 print " <a href=\"$url\">",&text('main_return', $_[$i+1]),"</a>\n";
1122 my $postbody = $tconfig{'postbody'};
1124 my $hostname = &get_display_hostname();
1125 my $version = &get_webmin_version();
1126 my $os_type = $gconfig{'real_os_type'} ||
1127 $gconfig{'os_type'};
1128 my $os_version = $gconfig{'real_os_version'} ||
1129 $gconfig{'os_version'};
1130 $postbody =~ s/%HOSTNAME%/$hostname/g;
1131 $postbody =~ s/%VERSION%/$version/g;
1132 $postbody =~ s/%USER%/$remote_user/g;
1133 $postbody =~ s/%OS%/$os_type $os_version/g;
1134 print "$postbody\n";
1136 if ($tconfig{'postbodyinclude'}) {
1138 open(INC, "$theme_root_directory/$tconfig{'postbodyinclude'}");
1144 if (defined(&theme_postbody)) {
1145 &theme_postbody(@_);
1147 print "</body></html>\n";
1151 =head2 popup_footer([no-body])
1153 Outputs html for a footer for a popup window, started by popup_header.
1158 &load_theme_library();
1159 if (defined(&theme_popup_footer)) {
1160 &theme_popup_footer(@_);
1169 =head2 load_theme_library
1171 Immediately loads the current theme's theme.pl file. Not generally useful for
1172 most module developers, as this is called automatically by the header function.
1175 sub load_theme_library
1177 return if (!$current_theme || $loaded_theme_library++);
1178 for(my $i=0; $i<@theme_root_directories; $i++) {
1179 if ($theme_configs[$i]->{'functions'}) {
1180 do $theme_root_directories[$i]."/".
1181 $theme_configs[$i]->{'functions'};
1186 =head2 redirect(url)
1188 Output HTTP headers to redirect the browser to some page. The url parameter is
1189 typically a relative URL like index.cgi or list_users.cgi.
1194 my $port = $ENV{'SERVER_PORT'} == 443 && uc($ENV{'HTTPS'}) eq "ON" ? "" :
1195 $ENV{'SERVER_PORT'} == 80 && uc($ENV{'HTTPS'}) ne "ON" ? "" :
1196 ":$ENV{'SERVER_PORT'}";
1197 my $prot = uc($ENV{'HTTPS'}) eq "ON" ? "https" : "http";
1198 my $wp = $gconfig{'webprefixnoredir'} ? undef : $gconfig{'webprefix'};
1200 if ($_[0] =~ /^(http|https|ftp|gopher):/) {
1201 # Absolute URL (like http://...)
1204 elsif ($_[0] =~ /^\//) {
1205 # Absolute path (like /foo/bar.cgi)
1206 $url = "$prot://$ENV{'SERVER_NAME'}$port$wp$_[0]";
1208 elsif ($ENV{'SCRIPT_NAME'} =~ /^(.*)\/[^\/]*$/) {
1209 # Relative URL (like foo.cgi)
1210 $url = "$prot://$ENV{'SERVER_NAME'}$port$wp$1/$_[0]";
1213 $url = "$prot://$ENV{'SERVER_NAME'}$port/$wp$_[0]";
1215 &load_theme_library();
1216 if (defined(&theme_redirect)) {
1217 $module_name = &get_module_name(); # Old themes use these
1218 %module_info = &get_module_info($module_name);
1219 &theme_redirect($_[0], $url);
1222 print "Location: $url\n\n";
1226 =head2 kill_byname(name, signal)
1228 Finds a process whose command line contains the given name (such as httpd), and
1229 sends some signal to it. The signal can be numeric (like 9) or named
1235 my @pids = &find_byname($_[0]);
1236 return scalar(@pids) if (&is_readonly_mode());
1237 &webmin_debug_log('KILL', "signal=$_[1] name=$_[0]")
1238 if ($gconfig{'debug_what_procs'});
1239 if (@pids) { kill($_[1], @pids); return scalar(@pids); }
1243 =head2 kill_byname_logged(name, signal)
1245 Like kill_byname, but also logs the killing.
1248 sub kill_byname_logged
1250 my @pids = &find_byname($_[0]);
1251 return scalar(@pids) if (&is_readonly_mode());
1252 if (@pids) { &kill_logged($_[1], @pids); return scalar(@pids); }
1256 =head2 find_byname(name)
1258 Finds processes searching for the given name in their command lines, and
1259 returns a list of matching PIDs.
1264 if ($gconfig{'os_type'} =~ /-linux$/ && -r "/proc/$$/cmdline") {
1265 # Linux with /proc filesystem .. use cmdline files, as this is
1266 # faster than forking
1268 opendir(PROCDIR, "/proc");
1269 foreach my $f (readdir(PROCDIR)) {
1270 if ($f eq int($f) && $f != $$) {
1271 my $line = &read_file_contents("/proc/$f/cmdline");
1272 if ($line =~ /$_[0]/) {
1281 if (&foreign_check("proc")) {
1282 # Call the proc module
1283 &foreign_require("proc", "proc-lib.pl");
1284 if (defined(&proc::list_processes)) {
1285 my @procs = &proc::list_processes();
1287 foreach my $p (@procs) {
1288 if ($p->{'args'} =~ /$_[0]/) {
1289 push(@pids, $p->{'pid'});
1292 @pids = grep { $_ != $$ } @pids;
1297 # Fall back to running a command
1299 $cmd = $gconfig{'find_pid_command'};
1300 $cmd =~ s/NAME/"$_[0]"/g;
1301 $cmd = &translate_command($cmd);
1302 @pids = split(/\n/, `($cmd) <$null_file 2>$null_file`);
1303 @pids = grep { $_ != $$ } @pids;
1307 =head2 error([message]+)
1309 Display an error message and exit. This should be used by CGI scripts that
1310 encounter a fatal error or invalid user input to notify users of the problem.
1311 If error_setup has been called, the displayed error message will be prefixed
1312 by the message setup using that function.
1317 $main::no_miniserv_userdb = 1;
1318 my $msg = join("", @_);
1319 $msg =~ s/<[^>]*>//g;
1320 if (!$main::error_must_die) {
1321 print STDERR "Error: ",$msg,"\n";
1323 &load_theme_library();
1324 if ($main::error_must_die) {
1325 if ($gconfig{'error_stack'}) {
1326 print STDERR "Error: ",$msg,"\n";
1327 for(my $i=0; my @stack = caller($i); $i++) {
1328 print STDERR "File: $stack[1] Line: $stack[2] ",
1329 "Function: $stack[3]\n";
1334 elsif (!$ENV{'REQUEST_METHOD'}) {
1335 # Show text-only error
1336 print STDERR "$text{'error'}\n";
1337 print STDERR "-----\n";
1338 print STDERR ($main::whatfailed ? "$main::whatfailed : " : ""),
1340 print STDERR "-----\n";
1341 if ($gconfig{'error_stack'}) {
1343 print STDERR $text{'error_stack'},"\n";
1344 for(my $i=0; my @stack = caller($i); $i++) {
1345 print STDERR &text('error_stackline',
1346 $stack[1], $stack[2], $stack[3]),"\n";
1351 elsif (defined(&theme_error)) {
1355 &header($text{'error'}, "");
1357 print "<h3>",($main::whatfailed ? "$main::whatfailed : " : ""),
1359 if ($gconfig{'error_stack'}) {
1361 print "<h3>$text{'error_stack'}</h3>\n";
1363 print "<tr> <td><b>$text{'error_file'}</b></td> ",
1364 "<td><b>$text{'error_line'}</b></td> ",
1365 "<td><b>$text{'error_sub'}</b></td> </tr>\n";
1366 for($i=0; my @stack = caller($i); $i++) {
1368 print "<td>$stack[1]</td>\n";
1369 print "<td>$stack[2]</td>\n";
1370 print "<td>$stack[3]</td>\n";
1376 if ($ENV{'HTTP_REFERER'} && $main::completed_referers_check) {
1377 &footer($ENV{'HTTP_REFERER'}, $text{'error_previous'});
1383 &unlock_all_files();
1384 &cleanup_tempnames();
1388 =head2 popup_error([message]+)
1390 This function is almost identical to error, but displays the message with HTML
1391 headers suitable for a popup window.
1396 $main::no_miniserv_userdb = 1;
1397 &load_theme_library();
1398 if ($main::error_must_die) {
1401 elsif (defined(&theme_popup_error)) {
1402 &theme_popup_error(@_);
1405 &popup_header($text{'error'}, "");
1406 print "<h3>",($main::whatfailed ? "$main::whatfailed : " : ""),@_,"</h3>\n";
1409 &unlock_all_files();
1410 &cleanup_tempnames();
1414 =head2 error_setup(message)
1416 Registers a message to be prepended to all error messages displayed by the
1422 $main::whatfailed = $_[0];
1425 =head2 wait_for(handle, regexp, regexp, ...)
1427 Reads from the input stream until one of the regexps matches, and returns the
1428 index of the matching regexp, or -1 if input ended before any matched. This is
1429 very useful for parsing the output of interactive programs, and can be used with
1430 a two-way pipe to feed input to a program in response to output matched by
1433 If the matching regexp contains bracketed sub-expressions, their values will
1434 be placed in the global array @matches, indexed starting from 1. You cannot
1435 use the Perl variables $1, $2 and so on to capture matches.
1439 $rv = wait_for($loginfh, "username:");
1441 error("Didn't get username prompt");
1443 print $loginfh "joe\n";
1444 $rv = wait_for($loginfh, "password:");
1446 error("Didn't get password prompt");
1448 print $loginfh "smeg\n";
1453 my ($c, $i, $sw, $rv, $ha);
1454 undef($wait_for_input);
1455 if ($wait_for_debug) {
1456 print STDERR "wait_for(",join(",", @_),")\n";
1458 $ha = &callers_package($_[0]);
1459 if ($wait_for_debug) {
1460 print STDERR "File handle=$ha fd=",fileno($ha),"\n";
1465 " if ((\$c = getc(\$ha)) eq \"\") { return -1; }\n".
1466 " \$wait_for_input .= \$c;\n";
1467 if ($wait_for_debug) {
1468 $codes .= "print STDERR \$wait_for_input,\"\\n\";";
1470 for($i=1; $i<@_; $i++) {
1471 $sw = $i>1 ? "elsif" : "if";
1472 $codes .= " $sw (\$wait_for_input =~ /$_[$i]/i) { \$hit = $i-1; }\n";
1475 " if (defined(\$hit)) {\n".
1476 " \@matches = (-1, \$1, \$2, \$3, \$4, \$5, \$6, \$7, \$8, \$9);\n".
1482 &error("wait_for error : $@\n");
1487 =head2 fast_wait_for(handle, string, string, ...)
1489 This function behaves very similar to wait_for (documented above), but instead
1490 of taking regular expressions as parameters, it takes strings. As soon as the
1491 input contains one of them, it will return the index of the matching string.
1492 If the input ends before any match, it returns -1.
1497 my ($inp, $maxlen, $ha, $i, $c, $inpl);
1498 for($i=1; $i<@_; $i++) {
1499 $maxlen = length($_[$i]) > $maxlen ? length($_[$i]) : $maxlen;
1503 if (($c = getc($ha)) eq "") {
1504 &error("fast_wait_for read error : $!");
1507 if (length($inp) > $maxlen) {
1508 $inp = substr($inp, length($inp)-$maxlen);
1510 $inpl = length($inp);
1511 for($i=1; $i<@_; $i++) {
1512 if ($_[$i] eq substr($inp, $inpl-length($_[$i]))) {
1519 =head2 has_command(command)
1521 Returns the full path to the executable if some command is in the path, or
1522 undef if not found. If the given command is already an absolute path and
1523 exists, then the same path will be returned.
1528 if (!$_[0]) { return undef; }
1529 if (exists($main::has_command_cache{$_[0]})) {
1530 return $main::has_command_cache{$_[0]};
1533 my $slash = $gconfig{'os_type'} eq 'windows' ? '\\' : '/';
1534 if ($_[0] =~ /^\// || $_[0] =~ /^[a-z]:[\\\/]/i) {
1535 # Absolute path given - just use it
1536 my $t = &translate_filename($_[0]);
1537 $rv = (-x $t && !-d _) ? $_[0] : undef;
1540 # Check each directory in the path
1542 foreach my $d (split($path_separator, $ENV{'PATH'})) {
1543 next if ($donedir{$d}++);
1544 $d =~ s/$slash$// if ($d ne $slash);
1545 my $t = &translate_filename("$d/$_[0]");
1546 if (-x $t && !-d _) {
1547 $rv = $d.$slash.$_[0];
1550 if ($gconfig{'os_type'} eq 'windows') {
1551 foreach my $sfx (".exe", ".com", ".bat") {
1552 my $t = &translate_filename("$d/$_[0]").$sfx;
1553 if (-r $t && !-d _) {
1554 $rv = $d.$slash.$_[0].$sfx;
1561 $main::has_command_cache{$_[0]} = $rv;
1565 =head2 make_date(seconds, [date-only], [fmt])
1567 Converts a Unix date/time in seconds to a human-readable form, by default
1568 formatted like dd/mmm/yyyy hh:mm:ss. Parameters are :
1570 =item seconds - Unix time is seconds to convert.
1572 =item date-only - If set to 1, exclude the time from the returned string.
1574 =item fmt - Optional, one of dd/mon/yyyy, dd/mm/yyyy, mm/dd/yyyy or yyyy/mm/dd
1579 my ($secs, $only, $fmt) = @_;
1580 my @tm = localtime($secs);
1583 $fmt = $gconfig{'dateformat'} || 'dd/mon/yyyy';
1585 if ($fmt eq 'dd/mon/yyyy') {
1586 $date = sprintf "%2.2d/%s/%4.4d",
1587 $tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900;
1589 elsif ($fmt eq 'dd/mm/yyyy') {
1590 $date = sprintf "%2.2d/%2.2d/%4.4d", $tm[3], $tm[4]+1, $tm[5]+1900;
1592 elsif ($fmt eq 'mm/dd/yyyy') {
1593 $date = sprintf "%2.2d/%2.2d/%4.4d", $tm[4]+1, $tm[3], $tm[5]+1900;
1595 elsif ($fmt eq 'yyyy/mm/dd') {
1596 $date = sprintf "%4.4d/%2.2d/%2.2d", $tm[5]+1900, $tm[4]+1, $tm[3];
1598 elsif ($fmt eq 'd. mon yyyy') {
1599 $date = sprintf "%d. %s %4.4d",
1600 $tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900;
1602 elsif ($fmt eq 'dd.mm.yyyy') {
1603 $date = sprintf "%2.2d.%2.2d.%4.4d", $tm[3], $tm[4]+1, $tm[5]+1900;
1605 elsif ($fmt eq 'yyyy-mm-dd') {
1606 $date = sprintf "%4.4d-%2.2d-%2.2d", $tm[5]+1900, $tm[4]+1, $tm[3];
1609 $date .= sprintf " %2.2d:%2.2d", $tm[2], $tm[1];
1614 =head2 file_chooser_button(input, type, [form], [chroot], [addmode])
1616 Return HTML for a button that pops up a file chooser when clicked, and places
1617 the selected filename into another HTML field. The parameters are :
1619 =item input - Name of the form field to store the filename in.
1621 =item type - 0 for file or directory chooser, or 1 for directory only.
1623 =item form - Index of the form containing the button.
1625 =item chroot - If set to 1, the chooser will be limited to this directory.
1627 =item addmode - If set to 1, the selected filename will be appended to the text box instead of replacing it's contents.
1630 sub file_chooser_button
1632 return &theme_file_chooser_button(@_)
1633 if (defined(&theme_file_chooser_button));
1634 my $form = defined($_[2]) ? $_[2] : 0;
1635 my $chroot = defined($_[3]) ? $_[3] : "/";
1636 my $add = int($_[4]);
1637 my ($w, $h) = (400, 300);
1638 if ($gconfig{'db_sizefile'}) {
1639 ($w, $h) = split(/x/, $gconfig{'db_sizefile'});
1641 return "<input type=button onClick='ifield = form.$_[0]; chooser = window.open(\"$gconfig{'webprefix'}/chooser.cgi?add=$add&type=$_[1]&chroot=$chroot&file=\"+escape(ifield.value), \"chooser\", \"toolbar=no,menubar=no,scrollbars=no,resizable=yes,width=$w,height=$h\"); chooser.ifield = ifield; window.ifield = ifield' value=\"...\">\n";
1644 =head2 popup_window_button(url, width, height, scrollbars?, &field-mappings)
1646 Returns HTML for a button that will popup a chooser window of some kind. The
1649 =item url - Base URL of the popup window's contents
1651 =item width - Width of the window in pixels
1653 =item height - Height in pixels
1655 =item scrollbars - Set to 1 if the window should have scrollbars
1657 The field-mappings parameter is an array ref of array refs containing
1659 =item - Attribute to assign field to in the popup window
1661 =item - Form field name
1663 =item - CGI parameter to URL for value, if any
1666 sub popup_window_button
1668 return &theme_popup_window_button(@_) if (defined(&theme_popup_window_button));
1669 my ($url, $w, $h, $scroll, $fields) = @_;
1670 my $scrollyn = $scroll ? "yes" : "no";
1671 my $rv = "<input type=button onClick='";
1672 foreach my $m (@$fields) {
1673 $rv .= "$m->[0] = form.$m->[1]; ";
1675 my $sep = $url =~ /\?/ ? "&" : "?";
1676 $rv .= "chooser = window.open(\"$url\"";
1677 foreach my $m (@$fields) {
1679 $rv .= "+\"$sep$m->[2]=\"+escape($m->[0].value)";
1683 $rv .= ", \"chooser\", \"toolbar=no,menubar=no,scrollbars=$scrollyn,resizable=yes,width=$w,height=$h\"); ";
1684 foreach my $m (@$fields) {
1685 $rv .= "chooser.$m->[0] = $m->[0]; ";
1686 $rv .= "window.$m->[0] = $m->[0]; ";
1688 $rv .= "' value=\"...\">";
1692 =head2 read_acl(&user-module-hash, &user-list-hash, [&only-users])
1694 Reads the Webmin acl file into the given hash references. The first is indexed
1695 by a combined key of username,module , with the value being set to 1 when
1696 the user has access to that module. The second is indexed by username, with
1697 the value being an array ref of allowed modules.
1699 This function is deprecated in favour of foreign_available, which performs a
1700 more comprehensive check of module availability.
1702 If the only-users array ref parameter is given, the results may be limited to
1703 users in that list of names.
1708 my ($usermod, $userlist, $only) = @_;
1709 if (!%main::acl_hash_cache) {
1710 # Read from local files
1712 open(ACL, &acl_filename());
1714 if (/^([^:]+):\s*(.*)/) {
1716 my @mods = split(/\s+/, $2);
1717 foreach my $m (@mods) {
1718 $main::acl_hash_cache{$user,$m}++;
1720 $main::acl_array_cache{$user} = \@mods;
1725 %$usermod = %main::acl_hash_cache if ($usermod);
1726 %$userlist = %main::acl_array_cache if ($userlist);
1729 my $userdb = &get_userdb_string();
1730 my ($dbh, $proto, $prefix, $args) =
1731 $userdb ? &connect_userdb($userdb) : ( );
1733 if ($proto eq "mysql" || $proto eq "postgresql") {
1734 # Select usernames and modules from SQL DB
1735 my $cmd = $dbh->prepare(
1736 "select webmin_user.name,webmin_user_attr.value ".
1737 "from webmin_user,webmin_user_attr ".
1738 "where webmin_user.id = webmin_user_attr.id ".
1739 "and webmin_user_attr.attr = 'modules' ".
1740 ($only ? " and webmin_user.name in (".
1741 join(",", map { "'$_'" } @$only).")" : ""));
1742 if ($cmd && $cmd->execute()) {
1743 while(my ($user, $mods) = $cmd->fetchrow()) {
1744 my @mods = split(/\s+/, $mods);
1745 foreach my $m (@mods) {
1746 $usermod->{$user,$m}++ if ($usermod);
1748 $userlist->{$user} = \@mods if ($userlist);
1751 $cmd->finish() if ($cmd);
1753 elsif ($proto eq "ldap") {
1754 # Find users in LDAP
1755 my $filter = '(objectClass='.$args->{'userclass'}.')';
1758 "(|".join("", map { "(cn=$_)" } @$only).")";
1759 $filter = "(&".$filter.$ufilter.")";
1761 my $rv = $dbh->search(
1765 attrs => [ 'cn', 'webminModule' ]);
1766 if ($rv && !$rv->code) {
1767 foreach my $u ($rv->all_entries) {
1768 my $user = $u->get_value('cn');
1769 my @mods =$u->get_value('webminModule');
1770 foreach my $m (@mods) {
1771 $usermod->{$user,$m}++ if ($usermod);
1773 $userlist->{$user} = \@mods if ($userlist);
1777 &disconnect_userdb($userdb, $dbh);
1783 Returns the file containing the webmin ACL, which is usually
1784 /etc/webmin/webmin.acl.
1789 return "$config_directory/webmin.acl";
1794 Does nothing, but kept around for compatability.
1801 =head2 get_miniserv_config(&hash)
1803 Reads the Webmin webserver's (miniserv.pl) configuration file, usually located
1804 at /etc/webmin/miniserv.conf, and stores its names and values in the given
1808 sub get_miniserv_config
1810 return &read_file_cached(
1811 $ENV{'MINISERV_CONFIG'} || "$config_directory/miniserv.conf", $_[0]);
1814 =head2 put_miniserv_config(&hash)
1816 Writes out the Webmin webserver configuration file from the contents of
1817 the given hash ref. This should be initially populated by get_miniserv_config,
1820 get_miniserv_config(\%miniserv);
1821 $miniserv{'port'} = 10005;
1822 put_miniserv_config(\%miniserv);
1826 sub put_miniserv_config
1828 &write_file($ENV{'MINISERV_CONFIG'} || "$config_directory/miniserv.conf",
1832 =head2 restart_miniserv([nowait])
1834 Kill the old miniserv process and re-start it, then optionally waits for
1835 it to restart. This will apply all configuration settings.
1838 sub restart_miniserv
1841 return undef if (&is_readonly_mode());
1843 &get_miniserv_config(\%miniserv) || return;
1846 if ($gconfig{'os_type'} ne 'windows') {
1847 # On Unix systems, we can restart with a signal
1848 my ($pid, $addr, $i);
1849 $miniserv{'inetd'} && return;
1850 my @oldst = stat($miniserv{'pidfile'});
1851 $pid = $ENV{'MINISERV_PID'};
1853 open(PID, $miniserv{'pidfile'}) ||
1854 &error("Failed to open PID file $miniserv{'pidfile'}");
1857 $pid || &error("Invalid PID file $miniserv{'pidfile'}");
1860 # Just signal miniserv to restart
1861 &kill_logged('HUP', $pid) || &error("Incorrect Webmin PID $pid");
1863 # Wait till new PID is written, indicating a restart
1864 for($i=0; $i<60; $i++) {
1866 my @newst = stat($miniserv{'pidfile'});
1867 last if ($newst[9] != $oldst[9]);
1869 $i < 60 || &error("Webmin server did not write new PID file");
1871 ## Totally kill the process and re-run it
1872 #$SIG{'TERM'} = 'IGNORE';
1873 #&kill_logged('TERM', $pid);
1874 #&system_logged("$config_directory/start >/dev/null 2>&1 </dev/null");
1877 # On Windows, we need to use the flag file
1878 open(TOUCH, ">$miniserv{'restartflag'}");
1883 # wait for miniserv to come back up
1884 $addr = inet_aton($miniserv{'bind'} ? $miniserv{'bind'} : "127.0.0.1");
1886 for($i=0; $i<20; $i++) {
1888 socket(STEST, PF_INET, SOCK_STREAM, getprotobyname("tcp"));
1889 my $rv = connect(STEST,
1890 pack_sockaddr_in($miniserv{'port'}, $addr));
1892 last if ($rv && ++$ok >= 2);
1894 $i < 20 || &error("Failed to restart Webmin server!");
1898 =head2 reload_miniserv
1900 Sends a USR1 signal to the miniserv process, telling it to read-read it's
1901 configuration files. Not all changes will be applied though, such as the
1902 IP addresses and ports to accept connections on.
1907 return undef if (&is_readonly_mode());
1909 &get_miniserv_config(\%miniserv) || return;
1911 if ($gconfig{'os_type'} ne 'windows') {
1912 # Send a USR1 signal to re-read the config
1913 my ($pid, $addr, $i);
1914 $miniserv{'inetd'} && return;
1915 $pid = $ENV{'MINISERV_PID'};
1917 open(PID, $miniserv{'pidfile'}) ||
1918 &error("Failed to open PID file $miniserv{'pidfile'}");
1921 $pid || &error("Invalid PID file $miniserv{'pidfile'}");
1923 &kill_logged('USR1', $pid) || &error("Incorrect Webmin PID $pid");
1925 # Make sure this didn't kill Webmin!
1927 if (!kill(0, $pid)) {
1928 print STDERR "USR1 signal killed Webmin - restarting\n";
1929 &system_logged("$config_directory/start >/dev/null 2>&1 </dev/null");
1933 # On Windows, we need to use the flag file
1934 open(TOUCH, ">$miniserv{'reloadflag'}");
1939 =head2 check_os_support(&minfo, [os-type, os-version], [api-only])
1941 Returns 1 if some module is supported on the current operating system, or the
1942 OS supplies as parameters. The parameters are :
1944 =item minfo - A hash ref of module information, as returned by get_module_info
1946 =item os-type - The Webmin OS code to use instead of the system's real OS, such as redhat-linux
1948 =item os-version - The Webmin OS version to use, such as 13.0
1950 =item api-only - If set to 1, considers a module supported if it provides an API to other modules on this OS, even if the majority of its functionality is not supported.
1953 sub check_os_support
1955 my $oss = $_[0]->{'os_support'};
1956 if ($_[3] && $oss && $_[0]->{'api_os_support'}) {
1957 # May provide usable API
1958 $oss .= " ".$_[0]->{'api_os_support'};
1960 if ($_[0]->{'nozone'} && &running_in_zone()) {
1961 # Not supported in a Solaris Zone
1964 if ($_[0]->{'novserver'} && &running_in_vserver()) {
1965 # Not supported in a Linux Vserver
1968 if ($_[0]->{'noopenvz'} && &running_in_openvz()) {
1969 # Not supported in an OpenVZ container
1972 return 1 if (!$oss || $oss eq '*');
1973 my $osver = $_[2] || $gconfig{'os_version'};
1974 my $ostype = $_[1] || $gconfig{'os_type'};
1977 my ($os, $ver, $codes);
1978 my ($neg) = ($oss =~ s/^!//); # starts with !
1979 $anyneg++ if ($neg);
1980 if ($oss =~ /^([^\/\s]+)\/([^\{\s]+)\{([^\}]*)\}\s*(.*)$/) {
1982 $os = $1; $ver = $2; $codes = $3; $oss = $4;
1984 elsif ($oss =~ /^([^\/\s]+)\/([^\/\s]+)\s*(.*)$/) {
1986 $os = $1; $ver = $2; $oss = $3;
1988 elsif ($oss =~ /^([^\{\s]+)\{([^\}]*)\}\s*(.*)$/) {
1990 $os = $1; $codes = $2; $oss = $3;
1992 elsif ($oss =~ /^\{([^\}]*)\}\s*(.*)$/) {
1994 $codes = $1; $oss = $2;
1996 elsif ($oss =~ /^(\S+)\s*(.*)$/) {
1998 $os = $1; $oss = $2;
2001 next if ($os && !($os eq $ostype ||
2002 $ostype =~ /^(\S+)-(\S+)$/ && $os eq "*-$2"));
2003 if ($ver =~ /^([0-9\.]+)\-([0-9\.]+)$/) {
2004 next if ($osver < $1 || $osver > $2);
2006 elsif ($ver =~ /^([0-9\.]+)\-\*$/) {
2007 next if ($osver < $1);
2009 elsif ($ver =~ /^\*\-([0-9\.]+)$/) {
2010 next if ($osver > $1);
2013 next if ($ver ne $osver);
2015 next if ($codes && !eval $codes);
2021 =head2 http_download(host, port, page, destfile, [&error], [&callback], [sslmode], [user, pass], [timeout], [osdn-convert], [no-cache], [&headers])
2023 Downloads data from a HTTP url to a local file or string. The parameters are :
2025 =item host - The hostname part of the URL, such as www.google.com
2027 =item port - The HTTP port number, such as 80
2029 =item page - The filename part of the URL, like /index.html
2031 =item destfile - The local file to save the URL data to, like /tmp/index.html. This can also be a scalar reference, in which case the data will be appended to that scalar.
2033 =item error - If set to a scalar ref, the function will store any error message in this scalar and return 0 on failure, or 1 on success. If not set, it will simply call the error function if the download fails.
2035 =item callback - If set to a function ref, it will be called after each block of data is received. This is typically set to \&progress_callback, for printing download progress.
2037 =item sslmode - If set to 1, an HTTPS connection is used instead of HTTP.
2039 =item user - If set, HTTP authentication is done with this username.
2041 =item pass - The HTTP password to use with the username above.
2043 =item timeout - A timeout in seconds to wait for the TCP connection to be established before failing.
2045 =item osdn-convert - If set to 1, URL for downloads from sourceforge are converted to use an appropriate mirror site.
2047 =item no-cache - If set to 1, Webmin's internal caching for this URL is disabled.
2049 =item headers - If set to a hash ref of additional HTTP headers, they will be added to the request.
2054 my ($host, $port, $page, $dest, $error, $cbfunc, $ssl, $user, $pass,
2055 $timeout, $osdn, $nocache, $headers) = @_;
2056 if ($gconfig{'debug_what_net'}) {
2057 &webmin_debug_log('HTTP', "host=$host port=$port page=$page ssl=$ssl".
2058 ($user ? " user=$user pass=$pass" : "").
2059 (ref($dest) ? "" : " dest=$dest"));
2062 # Convert OSDN URL first
2063 my $prot = $ssl ? "https://" : "http://";
2064 my $portstr = $ssl && $port == 443 ||
2065 !$ssl && $port == 80 ? "" : ":$port";
2066 ($host, $port, $page, $ssl) = &parse_http_url(
2067 &convert_osdn_url($prot.$host.$portstr.$page));
2070 # Check if we already have cached the URL
2071 my $url = ($ssl ? "https://" : "http://").$host.":".$port.$page;
2072 my $cfile = &check_in_http_cache($url);
2073 if ($cfile && !$nocache) {
2074 # Yes! Copy to dest file or variable
2075 &$cbfunc(6, $url) if ($cbfunc);
2077 &open_readfile(CACHEFILE, $cfile);
2079 $$dest = <CACHEFILE>;
2083 ©_source_dest($cfile, $dest);
2090 push(@headers, [ "Host", $host ]);
2091 push(@headers, [ "User-agent", "Webmin" ]);
2092 push(@headers, [ "Accept-language", "en" ]);
2094 my $auth = &encode_base64("$user:$pass");
2095 $auth =~ tr/\r\n//d;
2096 push(@headers, [ "Authorization", "Basic $auth" ]);
2098 foreach my $hname (keys %$headers) {
2099 push(@headers, [ $hname, $headers->{$hname} ]);
2102 # Actually download it
2103 $main::download_timed_out = undef;
2104 local $SIG{ALRM} = \&download_timeout;
2105 alarm($timeout || 60);
2106 my $h = &make_http_connection($host, $port, $ssl, "GET", $page, \@headers);
2108 $h = $main::download_timed_out if ($main::download_timed_out);
2110 if ($error) { $$error = $h; return; }
2111 else { &error($h); }
2113 &complete_http_download($h, $dest, $error, $cbfunc, $osdn, $host, $port,
2114 $headers, $ssl, $nocache);
2115 if ((!$error || !$$error) && !$nocache) {
2116 &write_to_http_cache($url, $dest);
2120 =head2 complete_http_download(handle, destfile, [&error], [&callback], [osdn], [oldhost], [oldport], [&send-headers], [old-ssl], [no-cache])
2122 Do a HTTP download, after the headers have been sent. For internal use only,
2123 typically called by http_download.
2126 sub complete_http_download
2128 local ($line, %header, @headers, $s); # Kept local so that callback funcs
2134 ($line = &read_http_connection($_[0])) =~ tr/\r\n//d;
2135 if ($line !~ /^HTTP\/1\..\s+(200|30[0-9])(\s+|$)/) {
2137 if ($_[2]) { ${$_[2]} = $line; return; }
2138 else { &error("Download failed : $line"); }
2141 &$cbfunc(1, $rcode >= 300 && $rcode < 400 ? 1 : 0)
2144 $line = &read_http_connection($_[0]);
2145 $line =~ tr/\r\n//d;
2146 $line =~ /^(\S+):\s+(.*)$/ || last;
2147 $header{lc($1)} = $2;
2148 push(@headers, [ lc($1), $2 ]);
2151 if ($main::download_timed_out) {
2152 if ($_[2]) { ${$_[2]} = $main::download_timed_out; return 0; }
2153 else { &error($main::download_timed_out); }
2155 &$cbfunc(2, $header{'content-length'}) if ($cbfunc);
2156 if ($rcode >= 300 && $rcode < 400) {
2157 # follow the redirect
2158 &$cbfunc(5, $header{'location'}) if ($cbfunc);
2159 my ($host, $port, $page, $ssl);
2160 if ($header{'location'} =~ /^(http|https):\/\/([^:]+):(\d+)(\/.*)?$/) {
2161 $ssl = $1 eq 'https' ? 1 : 0;
2162 $host = $2; $port = $3; $page = $4 || "/";
2164 elsif ($header{'location'} =~ /^(http|https):\/\/([^:\/]+)(\/.*)?$/) {
2165 $ssl = $1 eq 'https' ? 1 : 0;
2166 $host = $2; $port = 80; $page = $3 || "/";
2168 elsif ($header{'location'} =~ /^\// && $_[5]) {
2169 # Relative to same server
2173 $page = $header{'location'};
2175 elsif ($header{'location'}) {
2176 # Assume relative to same dir .. not handled
2177 if ($_[2]) { ${$_[2]} = "Invalid Location header $header{'location'}"; return; }
2178 else { &error("Invalid Location header $header{'location'}"); }
2181 if ($_[2]) { ${$_[2]} = "Missing Location header"; return; }
2182 else { &error("Missing Location header"); }
2185 ($page, $params) = split(/\?/, $page);
2187 $page .= "?".$params if (defined($params));
2188 &http_download($host, $port, $page, $_[1], $_[2], $cbfunc, $ssl,
2189 undef, undef, undef, $_[4], $_[9], $_[7]);
2194 # Append to a variable
2195 while(defined($buf = &read_http_connection($_[0], 1024))) {
2197 &$cbfunc(3, length(${$_[1]})) if ($cbfunc);
2203 if (!&open_tempfile(PFILE, ">$_[1]", 1)) {
2204 if ($_[2]) { ${$_[2]} = "Failed to write to $_[1] : $!"; return; }
2205 else { &error("Failed to write to $_[1] : $!"); }
2207 binmode(PFILE); # For windows
2208 while(defined($buf = &read_http_connection($_[0], 1024))) {
2209 &print_tempfile(PFILE, $buf);
2210 $got += length($buf);
2211 &$cbfunc(3, $got) if ($cbfunc);
2213 &close_tempfile(PFILE);
2214 if ($header{'content-length'} &&
2215 $got != $header{'content-length'}) {
2216 if ($_[2]) { ${$_[2]} = "Download incomplete"; return; }
2217 else { &error("Download incomplete"); }
2220 &$cbfunc(4) if ($cbfunc);
2222 &close_http_connection($_[0]);
2226 =head2 ftp_download(host, file, destfile, [&error], [&callback], [user, pass], [port])
2228 Download data from an FTP site to a local file. The parameters are :
2230 =item host - FTP server hostname
2232 =item file - File on the FTP server to download
2234 =item destfile - File on the Webmin system to download data to
2236 =item error - If set to a string ref, any error message is written into this string and the function returns 0 on failure, 1 on success. Otherwise, error is called on failure.
2238 =item callback - If set to a function ref, it will be called after each block of data is received. This is typically set to \&progress_callback, for printing download progress.
2240 =item user - Username to login to the FTP server as. If missing, Webmin will login as anonymous.
2242 =item pass - Password for the username above.
2244 =item port - FTP server port number, which defaults to 21 if not set.
2249 my ($host, $file, $dest, $error, $cbfunc, $user, $pass, $port) = @_;
2251 if ($gconfig{'debug_what_net'}) {
2252 &webmin_debug_log('FTP', "host=$host port=$port file=$file".
2253 ($user ? " user=$user pass=$pass" : "").
2254 (ref($dest) ? "" : " dest=$dest"));
2258 if (&is_readonly_mode()) {
2259 if ($_[3]) { ${$_[3]} = "FTP connections not allowed in readonly mode";
2261 else { &error("FTP connections not allowed in readonly mode"); }
2264 # Check if we already have cached the URL
2265 my $url = "ftp://".$host.$file;
2266 my $cfile = &check_in_http_cache($url);
2268 # Yes! Copy to dest file or variable
2269 &$cbfunc(6, $url) if ($cbfunc);
2271 &open_readfile(CACHEFILE, $cfile);
2273 $$dest = <CACHEFILE>;
2277 ©_source_dest($cfile, $dest);
2282 # Actually download it
2283 $main::download_timed_out = undef;
2284 local $SIG{ALRM} = \&download_timeout;
2287 if ($gconfig{'ftp_proxy'} =~ /^http:\/\/(\S+):(\d+)/ && !&no_proxy($_[0])) {
2288 # download through http-style proxy
2290 if (&open_socket($1, $2, "SOCK", \$error)) {
2292 if ($main::download_timed_out) {
2294 if ($_[3]) { ${$_[3]} = $main::download_timed_out; return 0; }
2295 else { &error($main::download_timed_out); }
2297 my $esc = $_[1]; $esc =~ s/ /%20/g;
2298 my $up = "$_[5]:$_[6]\@" if ($_[5]);
2299 my $portstr = $port == 21 ? "" : ":$port";
2300 print SOCK "GET ftp://$up$_[0]$portstr$esc HTTP/1.0\r\n";
2301 print SOCK "User-agent: Webmin\r\n";
2302 if ($gconfig{'proxy_user'}) {
2303 my $auth = &encode_base64(
2304 "$gconfig{'proxy_user'}:$gconfig{'proxy_pass'}");
2305 $auth =~ tr/\r\n//d;
2306 print SOCK "Proxy-Authorization: Basic $auth\r\n";
2309 &complete_http_download({ 'fh' => "SOCK" }, $_[2], $_[3], $_[4]);
2312 elsif (!$gconfig{'proxy_fallback'}) {
2314 if ($error) { $$error = $main::download_timed_out; return 0; }
2315 else { &error($main::download_timed_out); }
2320 # connect to host and login with real FTP protocol
2321 &open_socket($_[0], $port, "SOCK", $_[3]) || return 0;
2323 if ($main::download_timed_out) {
2324 if ($_[3]) { ${$_[3]} = $main::download_timed_out; return 0; }
2325 else { &error($main::download_timed_out); }
2327 &ftp_command("", 2, $_[3]) || return 0;
2329 # Login as supplied user
2330 my @urv = &ftp_command("USER $_[5]", [ 2, 3 ], $_[3]);
2332 if (int($urv[1]/100) == 3) {
2333 &ftp_command("PASS $_[6]", 2, $_[3]) || return 0;
2337 # Login as anonymous
2338 my @urv = &ftp_command("USER anonymous", [ 2, 3 ], $_[3]);
2340 if (int($urv[1]/100) == 3) {
2341 &ftp_command("PASS root\@".&get_system_hostname(), 2,
2345 &$cbfunc(1, 0) if ($cbfunc);
2348 # get the file size and tell the callback
2349 &ftp_command("TYPE I", 2, $_[3]) || return 0;
2350 my $size = &ftp_command("SIZE $_[1]", 2, $_[3]);
2351 defined($size) || return 0;
2353 &$cbfunc(2, int($size));
2357 my $pasv = &ftp_command("PASV", 2, $_[3]);
2358 defined($pasv) || return 0;
2359 $pasv =~ /\(([0-9,]+)\)/;
2360 @n = split(/,/ , $1);
2361 &open_socket("$n[0].$n[1].$n[2].$n[3]",
2362 $n[4]*256 + $n[5], "CON", $_[3]) || return 0;
2363 &ftp_command("RETR $_[1]", 1, $_[3]) || return 0;
2367 &open_tempfile(PFILE, ">$_[2]", 1);
2368 while(read(CON, $buf, 1024) > 0) {
2369 &print_tempfile(PFILE, $buf);
2370 $got += length($buf);
2371 &$cbfunc(3, $got) if ($cbfunc);
2373 &close_tempfile(PFILE);
2375 if ($got != $size) {
2376 if ($_[3]) { ${$_[3]} = "Download incomplete"; return 0; }
2377 else { &error("Download incomplete"); }
2379 &$cbfunc(4) if ($cbfunc);
2381 &ftp_command("", 2, $_[3]) || return 0;
2385 &ftp_command("QUIT", 2, $_[3]) || return 0;
2389 &write_to_http_cache($url, $dest);
2393 =head2 ftp_upload(host, file, srcfile, [&error], [&callback], [user, pass], [port])
2395 Upload data from a local file to an FTP site. The parameters are :
2397 =item host - FTP server hostname
2399 =item file - File on the FTP server to write to
2401 =item srcfile - File on the Webmin system to upload data from
2403 =item error - If set to a string ref, any error message is written into this string and the function returns 0 on failure, 1 on success. Otherwise, error is called on failure.
2405 =item callback - If set to a function ref, it will be called after each block of data is received. This is typically set to \&progress_callback, for printing upload progress.
2407 =item user - Username to login to the FTP server as. If missing, Webmin will login as anonymous.
2409 =item pass - Password for the username above.
2411 =item port - FTP server port number, which defaults to 21 if not set.
2418 if (&is_readonly_mode()) {
2419 if ($_[3]) { ${$_[3]} = "FTP connections not allowed in readonly mode";
2421 else { &error("FTP connections not allowed in readonly mode"); }
2424 $main::download_timed_out = undef;
2425 local $SIG{ALRM} = \&download_timeout;
2428 # connect to host and login
2429 &open_socket($_[0], $_[7] || 21, "SOCK", $_[3]) || return 0;
2431 if ($main::download_timed_out) {
2432 if ($_[3]) { ${$_[3]} = $main::download_timed_out; return 0; }
2433 else { &error($main::download_timed_out); }
2435 &ftp_command("", 2, $_[3]) || return 0;
2437 # Login as supplied user
2438 my @urv = &ftp_command("USER $_[5]", [ 2, 3 ], $_[3]);
2440 if (int($urv[1]/100) == 3) {
2441 &ftp_command("PASS $_[6]", 2, $_[3]) || return 0;
2445 # Login as anonymous
2446 my @urv = &ftp_command("USER anonymous", [ 2, 3 ], $_[3]);
2448 if (int($urv[1]/100) == 3) {
2449 &ftp_command("PASS root\@".&get_system_hostname(), 2,
2453 &$cbfunc(1, 0) if ($cbfunc);
2455 &ftp_command("TYPE I", 2, $_[3]) || return 0;
2457 # get the file size and tell the callback
2458 my @st = stat($_[2]);
2460 &$cbfunc(2, $st[7]);
2464 my $pasv = &ftp_command("PASV", 2, $_[3]);
2465 defined($pasv) || return 0;
2466 $pasv =~ /\(([0-9,]+)\)/;
2467 @n = split(/,/ , $1);
2468 &open_socket("$n[0].$n[1].$n[2].$n[3]", $n[4]*256 + $n[5], "CON", $_[3]) || return 0;
2469 &ftp_command("STOR $_[1]", 1, $_[3]) || return 0;
2474 while(read(PFILE, $buf, 1024) > 0) {
2476 $got += length($buf);
2477 &$cbfunc(3, $got) if ($cbfunc);
2481 if ($got != $st[7]) {
2482 if ($_[3]) { ${$_[3]} = "Upload incomplete"; return 0; }
2483 else { &error("Upload incomplete"); }
2485 &$cbfunc(4) if ($cbfunc);
2488 &ftp_command("", 2, $_[3]) || return 0;
2489 &ftp_command("QUIT", 2, $_[3]) || return 0;
2495 =head2 no_proxy(host)
2497 Checks if some host is on the no proxy list. For internal use by the
2498 http_download and ftp_download functions.
2503 my $ip = &to_ipaddress($_[0]);
2504 foreach my $n (split(/\s+/, $gconfig{'noproxy'})) {
2505 return 1 if ($_[0] =~ /\Q$n\E/ ||
2511 =head2 open_socket(host, port, handle, [&error])
2513 Open a TCP connection to some host and port, using a file handle. The
2516 =item host - Hostname or IP address to connect to.
2518 =item port - TCP port number.
2520 =item handle - A file handle name to use for the connection.
2522 =item error - A string reference to write any error message into. If not set, the error function is called on failure.
2527 my ($host, $port, $fh, $err) = @_;
2528 $fh = &callers_package($fh);
2530 if ($gconfig{'debug_what_net'}) {
2531 &webmin_debug_log('TCP', "host=$host port=$port");
2533 if (!socket($fh, PF_INET, SOCK_STREAM, getprotobyname("tcp"))) {
2534 if ($err) { $$err = "Failed to create socket : $!"; return 0; }
2535 else { &error("Failed to create socket : $!"); }
2538 if (!($addr = inet_aton($host))) {
2539 if ($err) { $$err = "Failed to lookup IP address for $host"; return 0; }
2540 else { &error("Failed to lookup IP address for $host"); }
2542 if ($gconfig{'bind_proxy'}) {
2543 if (!bind($fh,pack_sockaddr_in(0, inet_aton($gconfig{'bind_proxy'})))) {
2544 if ($err) { $$err = "Failed to bind to source address : $!"; return 0; }
2545 else { &error("Failed to bind to source address : $!"); }
2548 if (!connect($fh, pack_sockaddr_in($port, $addr))) {
2549 if ($err) { $$err = "Failed to connect to $host:$port : $!"; return 0; }
2550 else { &error("Failed to connect to $host:$port : $!"); }
2552 my $old = select($fh); $| =1; select($old);
2556 =head2 download_timeout
2558 Called when a download times out. For internal use only.
2561 sub download_timeout
2563 $main::download_timed_out = "Download timed out";
2566 =head2 ftp_command(command, expected, [&error], [filehandle])
2568 Send an FTP command, and die if the reply is not what was expected. Mainly
2569 for internal use by the ftp_download and ftp_upload functions.
2574 my ($cmd, $expect, $err, $fh) = @_;
2576 $fh = &callers_package($fh);
2579 my $what = $cmd ne "" ? "<i>$cmd</i>" : "initial connection";
2581 print $fh "$cmd\r\n";
2584 if (!($line = <$fh>)) {
2586 if ($err) { $$err = "Failed to read reply to $what"; return undef; }
2587 else { &error("Failed to read reply to $what"); }
2589 $line =~ /^(...)(.)(.*)$/;
2592 foreach my $c (@$expect) {
2593 $found++ if (int($1/100) == $c);
2597 $found++ if (int($1/100) == $_[1]);
2601 if ($err) { $$err = "$what failed : $3"; return undef; }
2602 else { &error("$what failed : $3"); }
2607 # Need to skip extra stuff..
2609 if (!($line = <$fh>)) {
2611 if ($$err) { $$err = "Failed to read reply to $what";
2613 else { &error("Failed to read reply to $what"); }
2615 $line =~ /^(....)(.*)$/; $reply .= $2;
2616 if ($1 eq "$rcode ") { last; }
2620 return wantarray ? ($reply, $rcode) : $reply;
2623 =head2 to_ipaddress(hostname)
2625 Converts a hostname to an a.b.c.d format IP address, or returns undef if
2626 it cannot be resolved.
2631 if (&check_ipaddress($_[0])) {
2635 my $hn = gethostbyname($_[0]);
2636 return undef if (!$hn);
2637 local @ip = unpack("CCCC", $hn);
2638 return join("." , @ip);
2642 =head2 icons_table(&links, &titles, &icons, [columns], [href], [width], [height], &befores, &afters)
2644 Renders a 4-column table of icons. The useful parameters are :
2646 =item links - An array ref of link destination URLs for the icons.
2648 =item titles - An array ref of titles to appear under the icons.
2650 =item icons - An array ref of URLs for icon images.
2652 =item columns - Number of columns to layout the icons with. Defaults to 4.
2657 &load_theme_library();
2658 if (defined(&theme_icons_table)) {
2659 &theme_icons_table(@_);
2663 my $cols = $_[3] ? $_[3] : 4;
2664 my $per = int(100.0 / $cols);
2665 print "<table class='icons_table' width=100% cellpadding=5>\n";
2666 for(my $i=0; $i<@{$_[0]}; $i++) {
2667 if ($i%$cols == 0) { print "<tr>\n"; }
2668 print "<td width=$per% align=center valign=top>\n";
2669 &generate_icon($_[2]->[$i], $_[1]->[$i], $_[0]->[$i],
2670 ref($_[4]) ? $_[4]->[$i] : $_[4], $_[5], $_[6],
2671 $_[7]->[$i], $_[8]->[$i]);
2673 if ($i%$cols == $cols-1) { print "</tr>\n"; }
2675 while($i++%$cols) { print "<td width=$per%></td>\n"; $need_tr++; }
2676 print "</tr>\n" if ($need_tr);
2680 =head2 replace_file_line(file, line, [newline]*)
2682 Replaces one line in some file with 0 or more new lines. The parameters are :
2684 =item file - Full path to some file, like /etc/hosts.
2686 =item line - Line number to replace, starting from 0.
2688 =item newline - Zero or more lines to put into the file at the given line number. These must be newline-terminated strings.
2691 sub replace_file_line
2694 my $realfile = &translate_filename($_[0]);
2695 open(FILE, $realfile);
2698 if (@_ > 2) { splice(@lines, $_[1], 1, @_[2..$#_]); }
2699 else { splice(@lines, $_[1], 1); }
2700 &open_tempfile(FILE, ">$realfile");
2701 &print_tempfile(FILE, @lines);
2702 &close_tempfile(FILE);
2705 =head2 read_file_lines(file, [readonly])
2707 Returns a reference to an array containing the lines from some file. This
2708 array can be modified, and will be written out when flush_file_lines()
2709 is called. The parameters are :
2711 =item file - Full path to the file to read.
2713 =item readonly - Should be set 1 if the caller is only going to read the lines, and never write it out.
2717 $lref = read_file_lines("/etc/hosts");
2718 push(@$lref, "127.0.0.1 localhost");
2719 flush_file_lines("/etc/hosts");
2725 my ($package, $filename, $line) = caller;
2726 print STDERR "Missing file to read at ${package}::${filename} line $line\n";
2728 my $realfile = &translate_filename($_[0]);
2729 if (!$main::file_cache{$realfile}) {
2732 &webmin_debug_log('READ', $_[0]) if ($gconfig{'debug_what_read'});
2733 open(READFILE, $realfile);
2736 $eol = /\r\n$/ ? "\r\n" : "\n";
2742 $main::file_cache{$realfile} = \@lines;
2743 $main::file_cache_noflush{$realfile} = $_[1];
2744 $main::file_cache_eol{$realfile} = $eol || "\n";
2747 # Make read-write if currently readonly
2749 $main::file_cache_noflush{$realfile} = 0;
2752 return $main::file_cache{$realfile};
2755 =head2 flush_file_lines([file], [eol])
2757 Write out to a file previously read by read_file_lines to disk (except
2758 for those marked readonly). The parameters are :
2760 =item file - The file to flush out.
2762 =item eof - End-of-line character for each line. Defaults to \n.
2765 sub flush_file_lines
2769 local $trans = &translate_filename($_[0]);
2770 $main::file_cache{$trans} ||
2771 &error("flush_file_lines called on non-loaded file $trans");
2772 push(@files, $trans);
2775 @files = ( keys %main::file_cache );
2777 foreach my $f (@files) {
2778 my $eol = $_[1] || $main::file_cache_eol{$f} || "\n";
2779 if (!$main::file_cache_noflush{$f}) {
2780 no warnings; # XXX Bareword file handles should go away
2781 &open_tempfile(FLUSHFILE, ">$f");
2782 foreach my $line (@{$main::file_cache{$f}}) {
2783 (print FLUSHFILE $line,$eol) ||
2784 &error(&text("efilewrite", $f, $!));
2786 &close_tempfile(FLUSHFILE);
2788 delete($main::file_cache{$f});
2789 delete($main::file_cache_noflush{$f});
2793 =head2 unflush_file_lines(file)
2795 Clear the internal cache of some given file, previously read by read_file_lines.
2798 sub unflush_file_lines
2800 my $realfile = &translate_filename($_[0]);
2801 delete($main::file_cache{$realfile});
2802 delete($main::file_cache_noflush{$realfile});
2805 =head2 unix_user_input(fieldname, user, [form])
2807 Returns HTML for an input to select a Unix user. By default this is a text
2808 box with a user popup button next to it.
2813 if (defined(&theme_unix_user_input)) {
2814 return &theme_unix_user_input(@_);
2816 return "<input name=$_[0] size=13 value=\"$_[1]\"> ".
2817 &user_chooser_button($_[0], 0, $_[2] || 0)."\n";
2820 =head2 unix_group_input(fieldname, user, [form])
2822 Returns HTML for an input to select a Unix group. By default this is a text
2823 box with a group popup button next to it.
2826 sub unix_group_input
2828 if (defined(&theme_unix_group_input)) {
2829 return &theme_unix_group_input(@_);
2831 return "<input name=$_[0] size=13 value=\"$_[1]\"> ".
2832 &group_chooser_button($_[0], 0, $_[2] || 0)."\n";
2835 =head2 hlink(text, page, [module], [width], [height])
2837 Returns HTML for a link that when clicked on pops up a window for a Webmin
2838 help page. The parameters are :
2840 =item text - Text for the link.
2842 =item page - Help page code, such as 'intro'.
2844 =item module - Module the help page is in. Defaults to the current module.
2846 =item width - Width of the help popup window. Defaults to 600 pixels.
2848 =item height - Height of the help popup window. Defaults to 400 pixels.
2850 The actual help pages are in each module's help sub-directory, in files with
2856 if (defined(&theme_hlink)) {
2857 return &theme_hlink(@_);
2859 my $mod = $_[2] ? $_[2] : &get_module_name();
2860 my $width = $_[3] || $tconfig{'help_width'} || $gconfig{'help_width'} || 600;
2861 my $height = $_[4] || $tconfig{'help_height'} || $gconfig{'help_height'} || 400;
2862 return "<a onClick='window.open(\"$gconfig{'webprefix'}/help.cgi/$mod/$_[1]\", \"help\", \"toolbar=no,menubar=no,scrollbars=yes,width=$width,height=$height,resizable=yes\"); return false' href=\"$gconfig{'webprefix'}/help.cgi/$mod/$_[1]\">$_[0]</a>";
2865 =head2 user_chooser_button(field, multiple, [form])
2867 Returns HTML for a javascript button for choosing a Unix user or users.
2868 The parameters are :
2870 =item field - Name of the HTML field to place the username into.
2872 =item multiple - Set to 1 if multiple users can be selected.
2874 =item form - Index of the form on the page.
2877 sub user_chooser_button
2879 return undef if (!&supports_users());
2880 return &theme_user_chooser_button(@_)
2881 if (defined(&theme_user_chooser_button));
2882 my $form = defined($_[2]) ? $_[2] : 0;
2883 my $w = $_[1] ? 500 : 300;
2885 if ($_[1] && $gconfig{'db_sizeusers'}) {
2886 ($w, $h) = split(/x/, $gconfig{'db_sizeusers'});
2888 elsif (!$_[1] && $gconfig{'db_sizeuser'}) {
2889 ($w, $h) = split(/x/, $gconfig{'db_sizeuser'});
2891 return "<input type=button onClick='ifield = form.$_[0]; chooser = window.open(\"$gconfig{'webprefix'}/user_chooser.cgi?multi=$_[1]&user=\"+escape(ifield.value), \"chooser\", \"toolbar=no,menubar=no,scrollbars=yes,resizable=yes,width=$w,height=$h\"); chooser.ifield = ifield; window.ifield = ifield' value=\"...\">\n";
2894 =head2 group_chooser_button(field, multiple, [form])
2896 Returns HTML for a javascript button for choosing a Unix group or groups
2897 The parameters are :
2899 =item field - Name of the HTML field to place the group name into.
2901 =item multiple - Set to 1 if multiple groups can be selected.
2903 =item form - Index of the form on the page.
2906 sub group_chooser_button
2908 return undef if (!&supports_users());
2909 return &theme_group_chooser_button(@_)
2910 if (defined(&theme_group_chooser_button));
2911 my $form = defined($_[2]) ? $_[2] : 0;
2912 my $w = $_[1] ? 500 : 300;
2914 if ($_[1] && $gconfig{'db_sizeusers'}) {
2915 ($w, $h) = split(/x/, $gconfig{'db_sizeusers'});
2917 elsif (!$_[1] && $gconfig{'db_sizeuser'}) {
2918 ($w, $h) = split(/x/, $gconfig{'db_sizeuser'});
2920 return "<input type=button onClick='ifield = form.$_[0]; chooser = window.open(\"$gconfig{'webprefix'}/group_chooser.cgi?multi=$_[1]&group=\"+escape(ifield.value), \"chooser\", \"toolbar=no,menubar=no,scrollbars=yes,resizable=yes,width=$w,height=$h\"); chooser.ifield = ifield; window.ifield = ifield' value=\"...\">\n";
2923 =head2 foreign_check(module, [api-only])
2925 Checks if some other module exists and is supported on this OS. The parameters
2928 =item module - Name of the module to check.
2930 =item api-only - Set to 1 if you just want to check if the module provides an API that others can call, instead of the full web UI.
2935 my ($mod, $api) = @_;
2937 my $mdir = &module_root_directory($mod);
2938 &read_file_cached("$mdir/module.info", \%minfo) || return 0;
2939 return &check_os_support(\%minfo, undef, undef, $api);
2942 =head2 foreign_exists(module)
2944 Checks if some other module exists. The module parameter is the short module
2950 my $mdir = &module_root_directory($_[0]);
2951 return -r "$mdir/module.info";
2954 =head2 foreign_available(module)
2956 Returns 1 if some module is installed, and acessible to the current user. The
2957 module parameter is the module directory name.
2960 sub foreign_available
2962 return 0 if (!&foreign_check($_[0]) &&
2963 !$gconfig{'available_even_if_no_support'});
2964 my %foreign_module_info = &get_module_info($_[0]);
2966 # Check list of allowed modules
2968 &read_acl(\%acl, undef, [ $base_remote_user ]);
2969 return 0 if (!$acl{$base_remote_user,$_[0]} &&
2970 !$acl{$base_remote_user,'*'});
2972 # Check for usermod restrictions
2973 my @usermods = &list_usermods();
2974 return 0 if (!&available_usermods( [ \%foreign_module_info ], \@usermods));
2976 if (&get_product_name() eq "webmin") {
2977 # Check if the user has any RBAC privileges in this module
2978 if (&supports_rbac($_[0]) &&
2979 &use_rbac_module_acl(undef, $_[0])) {
2980 # RBAC is enabled for this user and module - check if he
2982 my $rbacs = &get_rbac_module_acl($remote_user, $_[0]);
2983 return 0 if (!$rbacs);
2985 elsif ($gconfig{'rbacdeny_'.$base_remote_user}) {
2986 # If denying access to modules not specifically allowed by
2987 # RBAC, then prevent access
2992 # Check readonly support
2993 if (&is_readonly_mode()) {
2994 return 0 if (!$foreign_module_info{'readonly'});
2997 # Check if theme vetos
2998 if (defined(&theme_foreign_available)) {
2999 return 0 if (!&theme_foreign_available($_[0]));
3002 # Check if licence module vetos
3003 if ($main::licence_module) {
3004 return 0 if (!&foreign_call($main::licence_module,
3005 "check_module_licence", $_[0]));
3011 =head2 foreign_require(module, [file], [package])
3013 Brings in functions from another module, and places them in the Perl namespace
3014 with the same name as the module. The parameters are :
3016 =item module - The source module's directory name, like sendmail.
3018 =item file - The API file in that module, like sendmail-lib.pl. If missing, all API files are loaded.
3020 =item package - Perl package to place the module's functions and global variables in.
3022 If the original module name contains dashes, they will be replaced with _ in
3028 my ($mod, $file, $pkg) = @_;
3029 $pkg ||= $mod || "global";
3030 $pkg =~ s/[^A-Za-z0-9]/_/g;
3033 push(@files, $file);
3037 my %minfo = &get_module_info($mod);
3038 if ($minfo{'library'}) {
3039 @files = split(/\s+/, $minfo{'library'});
3042 @files = ( $mod."-lib.pl" );
3045 @files = grep { !$main::done_foreign_require{$pkg,$_} } @files;
3046 return 1 if (!@files);
3047 foreach my $f (@files) {
3048 $main::done_foreign_require{$pkg,$f}++;
3051 my $mdir = &module_root_directory($mod);
3052 @INC = &unique($mdir, @INC);
3053 -d $mdir || &error("Module $mod does not exist");
3054 if (!&get_module_name() && $mod) {
3057 my $old_fmn = $ENV{'FOREIGN_MODULE_NAME'};
3058 my $old_frd = $ENV{'FOREIGN_ROOT_DIRECTORY'};
3059 my $code = "package $pkg; ".
3060 "\$ENV{'FOREIGN_MODULE_NAME'} = '$mod'; ".
3061 "\$ENV{'FOREIGN_ROOT_DIRECTORY'} = '$root_directory'; ";
3062 foreach my $f (@files) {
3063 $code .= "do '$mdir/$f' || die \$@; ";
3066 if (defined($old_fmn)) {
3067 $ENV{'FOREIGN_MODULE_NAME'} = $old_fmn;
3070 delete($ENV{'FOREIGN_MODULE_NAME'});
3072 if (defined($old_frd)) {
3073 $ENV{'FOREIGN_ROOT_DIRECTORY'} = $old_frd;
3076 delete($ENV{'FOREIGN_ROOT_DIRECTORY'});
3079 if ($@) { &error("Require $mod/$files[0] failed : <pre>$@</pre>"); }
3083 =head2 foreign_call(module, function, [arg]*)
3085 Call a function in another module. The module parameter is the target module
3086 directory name, function is the perl sub to call, and the remaining parameters
3087 are the arguments. However, unless you need to call a function whose name
3088 is dynamic, it is better to use Perl's cross-module function call syntax
3089 like module::function(args).
3094 my $pkg = $_[0] || "global";
3095 $pkg =~ s/[^A-Za-z0-9]/_/g;
3096 my @args = @_[2 .. @_-1];
3097 $main::foreign_args = \@args;
3098 my @rv = eval <<EOF;
3100 &$_[1](\@{\$main::foreign_args});
3102 if ($@) { &error("$_[0]::$_[1] failed : $@"); }
3103 return wantarray ? @rv : $rv[0];
3106 =head2 foreign_config(module, [user-config])
3108 Get the configuration from another module, and return it as a hash. If the
3109 user-config parameter is set to 1, returns the Usermin user-level preferences
3110 for the current user instead.
3115 my ($mod, $uc) = @_;
3118 &read_file_cached("$root_directory/$mod/defaultuconfig", \%fconfig);
3119 &read_file_cached("$config_directory/$mod/uconfig", \%fconfig);
3120 &read_file_cached("$user_config_directory/$mod/config", \%fconfig);
3123 &read_file_cached("$config_directory/$mod/config", \%fconfig);
3128 =head2 foreign_installed(module, mode)
3130 Checks if the server for some module is installed, and possibly also checks
3131 if the module has been configured by Webmin.
3132 For mode 1, returns 2 if the server is installed and configured for use by
3133 Webmin, 1 if installed but not configured, or 0 otherwise.
3134 For mode 0, returns 1 if installed, 0 if not.
3135 If the module does not provide an install_check.pl script, assumes that
3136 the server is installed.
3139 sub foreign_installed
3141 my ($mod, $configured) = @_;
3142 if (defined($main::foreign_installed_cache{$mod,$configured})) {
3144 return $main::foreign_installed_cache{$mod,$configured};
3148 if (!&foreign_check($mod)) {
3153 my $mdir = &module_root_directory($mod);
3154 if (!-r "$mdir/install_check.pl") {
3155 # Not known, assume OK
3156 $rv = $configured ? 2 : 1;
3159 # Call function to check
3160 &foreign_require($mod, "install_check.pl");
3161 $rv = &foreign_call($mod, "is_installed", $configured);
3164 $main::foreign_installed_cache{$mod,$configured} = $rv;
3169 =head2 foreign_defined(module, function)
3171 Returns 1 if some function is defined in another module. In general, it is
3172 simpler to use the syntax &defined(module::function) instead.
3178 $pkg =~ s/[^A-Za-z0-9]/_/g;
3179 my $func = "${pkg}::$_[1]";
3180 return defined(&$func);
3183 =head2 get_system_hostname([short])
3185 Returns the hostname of this system. If the short parameter is set to 1,
3186 then the domain name is not prepended - otherwise, Webmin will attempt to get
3187 the fully qualified hostname, like foo.example.com.
3190 sub get_system_hostname
3193 if (!$main::get_system_hostname[$m]) {
3194 if ($gconfig{'os_type'} ne 'windows') {
3195 # Try some common Linux hostname files first
3197 if ($gconfig{'os_type'} eq 'redhat-linux') {
3199 &read_env_file("/etc/sysconfig/network", \%nc);
3200 if ($nc{'HOSTNAME'}) {
3201 $fromfile = $nc{'HOSTNAME'};
3204 elsif ($gconfig{'os_type'} eq 'debian-linux') {
3205 my $hn = &read_file_contents("/etc/hostname");
3211 elsif ($gconfig{'os_type'} eq 'open-linux') {
3212 my $hn = &read_file_contents("/etc/HOSTNAME");
3218 elsif ($gconfig{'os_type'} eq 'solaris') {
3219 my $hn = &read_file_contents("/etc/nodename");
3226 # If we found a hostname, use it if value
3227 if ($fromfile && ($m || $fromfile =~ /\./)) {
3229 $fromfile =~ s/\..*$//;
3231 $main::get_system_hostname[$m] = $fromfile;
3235 # Can use hostname command on Unix
3236 &execute_command("hostname", undef,
3237 \$main::get_system_hostname[$m], undef, 0, 1);
3238 chop($main::get_system_hostname[$m]);
3240 eval "use Sys::Hostname";
3242 $main::get_system_hostname[$m] = eval "hostname()";
3244 if ($@ || !$main::get_system_hostname[$m]) {
3245 $main::get_system_hostname[$m] = "UNKNOWN";
3248 elsif ($main::get_system_hostname[$m] !~ /\./ &&
3249 $gconfig{'os_type'} =~ /linux$/ &&
3250 !$gconfig{'no_hostname_f'} && !$_[0]) {
3251 # Try with -f flag to get fully qualified name
3253 my $ex = &execute_command("hostname -f", undef, \$flag,
3256 if ($ex || $flag eq "") {
3257 # -f not supported! We have probably set the
3258 # hostname to just '-f'. Fix the problem
3261 &execute_command("hostname ".
3262 quotemeta($main::get_system_hostname[$m]),
3263 undef, undef, undef, 0, 1);
3267 $main::get_system_hostname[$m] = $flag;
3272 # On Windows, try computername environment variable
3273 return $ENV{'computername'} if ($ENV{'computername'});
3274 return $ENV{'COMPUTERNAME'} if ($ENV{'COMPUTERNAME'});
3276 # Fall back to net name command
3277 my $out = `net name 2>&1`;
3278 if ($out =~ /\-+\r?\n(\S+)/) {
3279 $main::get_system_hostname[$m] = $1;
3282 $main::get_system_hostname[$m] = "windows";
3286 return $main::get_system_hostname[$m];
3289 =head2 get_webmin_version
3291 Returns the version of Webmin currently being run, such as 1.450.
3294 sub get_webmin_version
3296 if (!$get_webmin_version) {
3297 open(VERSION, "$root_directory/version") || return 0;
3298 ($get_webmin_version = <VERSION>) =~ tr/\r|\n//d;
3301 return $get_webmin_version;
3304 =head2 get_module_acl([user], [module], [no-rbac], [no-default])
3306 Returns a hash containing access control options for the given user and module.
3307 By default the current username and module name are used. If the no-rbac flag
3308 is given, the permissions will not be updated based on the user's RBAC role
3309 (as seen on Solaris). If the no-default flag is given, default permissions for
3310 the module will not be included.
3315 my $u = defined($_[0]) ? $_[0] : $base_remote_user;
3316 my $m = defined($_[1]) ? $_[1] : &get_module_name();
3317 my $mdir = &module_root_directory($m);
3320 # Read default ACL first, to be overridden by per-user settings
3321 &read_file_cached("$mdir/defaultacl", \%rv);
3323 # If this isn't a master admin user, apply the negative permissions
3324 # so that he doesn't un-expectedly gain access to new features
3326 &read_file_cached("$config_directory/$u.acl", \%gaccess);
3327 if ($gaccess{'negative'}) {
3328 &read_file_cached("$mdir/negativeacl", \%rv);
3332 if (!$_[2] && &supports_rbac($m) && &use_rbac_module_acl($u, $m)) {
3333 # RBAC overrides exist for this user in this module
3334 my $rbac = &get_rbac_module_acl(
3335 defined($_[0]) ? $_[0] : $remote_user, $m);
3336 foreach my $r (keys %$rbac) {
3337 $rv{$r} = $rbac->{$r};
3340 elsif ($gconfig{"risk_$u"} && $m) {
3341 # ACL is defined by user's risk level
3342 my $rf = $gconfig{"risk_$u"}.'.risk';
3343 &read_file_cached("$mdir/$rf", \%rv);
3345 my $sf = $gconfig{"skill_$u"}.'.skill';
3346 &read_file_cached("$mdir/$sf", \%rv);
3349 # Use normal Webmin ACL, if a user is set
3350 my $userdb = &get_userdb_string();
3352 if ($userdb && ($u ne $base_remote_user || $remote_user_proto)) {
3353 # Look for this user in the user/group DB, if one is defined
3354 # and if the user might be in the DB
3355 my ($dbh, $proto, $prefix, $args) = &connect_userdb($userdb);
3356 ref($dbh) || &error(&text('euserdbacl', $dbh));
3357 if ($proto eq "mysql" || $proto eq "postgresql") {
3358 # Find the user in the SQL DB
3359 my $cmd = $dbh->prepare(
3360 "select id from webmin_user where name = ?");
3361 $cmd && $cmd->execute($u) ||
3362 &error(&text('euserdbacl', $dbh->errstr));
3363 my ($id) = $cmd->fetchrow();
3364 $foundindb = 1 if (defined($id));
3367 # Fetch ACLs with SQL
3369 my $cmd = $dbh->prepare(
3370 "select attr,value from webmin_user_acl ".
3371 "where id = ? and module = ?");
3372 $cmd && $cmd->execute($id, $m) ||
3373 &error(&text('euserdbacl', $dbh->errstr));
3374 while(my ($a, $v) = $cmd->fetchrow()) {
3380 elsif ($proto eq "ldap") {
3382 my $rv = $dbh->search(
3384 filter => '(&(cn='.$u.')(objectClass='.
3385 $args->{'userclass'}.'))',
3387 if (!$rv || $rv->code) {
3388 &error(&text('euserdbacl',
3389 $rv ? $rv->error : "Unknown error"));
3391 my ($user) = $rv->all_entries;
3393 # Find ACL sub-object for the module
3394 my $ldapm = $m || "global";
3396 my $rv = $dbh->search(
3397 base => $user->dn(),
3398 filter => '(cn='.$ldapm.')',
3400 if (!$rv || $rv->code) {
3401 &error(&text('euserdbacl',
3402 $rv ? $rv->error : "Unknown error"));
3404 my ($acl) = $rv->all_entries;
3406 foreach my $av ($acl->get_value(
3407 'webminAclEntry')) {
3408 my ($a, $v) = split(/=/, $av,2);
3414 &disconnect_userdb($userdb, $dbh);
3418 # Read from local files
3419 &read_file_cached("$config_directory/$m/$u.acl", \%rv);
3420 if ($remote_user ne $base_remote_user && !defined($_[0])) {
3422 "$config_directory/$m/$remote_user.acl",\%rv);
3426 if ($tconfig{'preload_functions'}) {
3427 &load_theme_library();
3429 if (defined(&theme_get_module_acl)) {
3430 %rv = &theme_get_module_acl($u, $m, \%rv);
3435 =head2 get_group_module_acl(group, [module], [no-default])
3437 Returns the ACL for a Webmin group, in an optional module (which defaults to
3438 the current module).
3441 sub get_group_module_acl
3444 my $m = defined($_[1]) ? $_[1] : &get_module_name();
3445 my $mdir = &module_root_directory($m);
3448 &read_file_cached("$mdir/defaultacl", \%rv);
3451 my $userdb = &get_userdb_string();
3454 # Look for this group in the user/group DB
3455 my ($dbh, $proto, $prefix, $args) = &connect_userdb($userdb);
3456 ref($dbh) || &error(&text('egroupdbacl', $dbh));
3457 if ($proto eq "mysql" || $proto eq "postgresql") {
3458 # Find the group in the SQL DB
3459 my $cmd = $dbh->prepare(
3460 "select id from webmin_group where name = ?");
3461 $cmd && $cmd->execute($g) ||
3462 &error(&text('egroupdbacl', $dbh->errstr));
3463 my ($id) = $cmd->fetchrow();
3464 $foundindb = 1 if (defined($id));
3467 # Fetch ACLs with SQL
3469 my $cmd = $dbh->prepare(
3470 "select attr,value from webmin_group_acl ".
3471 "where id = ? and module = ?");
3472 $cmd && $cmd->execute($id, $m) ||
3473 &error(&text('egroupdbacl', $dbh->errstr));
3474 while(my ($a, $v) = $cmd->fetchrow()) {
3480 elsif ($proto eq "ldap") {
3481 # Find group in LDAP
3482 my $rv = $dbh->search(
3484 filter => '(&(cn='.$g.')(objectClass='.
3485 $args->{'groupclass'}.'))',
3487 if (!$rv || $rv->code) {
3488 &error(&text('egroupdbacl',
3489 $rv ? $rv->error : "Unknown error"));
3491 my ($group) = $rv->all_entries;
3493 # Find ACL sub-object for the module
3494 my $ldapm = $m || "global";
3496 my $rv = $dbh->search(
3497 base => $group->dn(),
3498 filter => '(cn='.$ldapm.')',
3500 if (!$rv || $rv->code) {
3501 &error(&text('egroupdbacl',
3502 $rv ? $rv->error : "Unknown error"));
3504 my ($acl) = $rv->all_entries;
3506 foreach my $av ($acl->get_value(
3507 'webminAclEntry')) {
3508 my ($a, $v) = split(/=/, $av, 2);
3514 &disconnect_userdb($userdb, $dbh);
3517 # Read from local files
3518 &read_file_cached("$config_directory/$m/$g.gacl", \%rv);
3520 if (defined(&theme_get_module_acl)) {
3521 %rv = &theme_get_module_acl($g, $m, \%rv);
3526 =head2 save_module_acl(&acl, [user], [module], [never-update-group])
3528 Updates the acl hash for some user and module. The parameters are :
3530 =item acl - Hash reference for the new access control options, or undef to clear
3532 =item user - User to update, defaulting to the current user.
3534 =item module - Module to update, defaulting to the caller.
3536 =item never-update-group - Never update the user's group's ACL
3541 my $u = defined($_[1]) ? $_[1] : $base_remote_user;
3542 my $m = defined($_[2]) ? $_[2] : &get_module_name();
3543 if (!$_[3] && &foreign_check("acl")) {
3544 # Check if this user is a member of a group, and if he gets the
3545 # module from a group. If so, update its ACL as well
3546 &foreign_require("acl", "acl-lib.pl");
3548 foreach my $g (&acl::list_groups()) {
3549 if (&indexof($u, @{$g->{'members'}}) >= 0 &&
3550 &indexof($m, @{$g->{'modules'}}) >= 0) {
3556 &save_group_module_acl($_[0], $group->{'name'}, $m);
3560 my $userdb = &get_userdb_string();
3562 if ($userdb && ($u ne $base_remote_user || $remote_user_proto)) {
3563 # Look for this user in the user/group DB
3564 my ($dbh, $proto, $prefix, $args) = &connect_userdb($userdb);
3565 ref($dbh) || &error(&text('euserdbacl', $dbh));
3566 if ($proto eq "mysql" || $proto eq "postgresql") {
3567 # Find the user in the SQL DB
3568 my $cmd = $dbh->prepare(
3569 "select id from webmin_user where name = ?");
3570 $cmd && $cmd->execute($u) ||
3571 &error(&text('euserdbacl2', $dbh->errstr));
3572 my ($id) = $cmd->fetchrow();
3573 $foundindb = 1 if (defined($id));
3576 # Replace ACLs for user
3578 my $cmd = $dbh->prepare("delete from webmin_user_acl ".
3579 "where id = ? and module = ?");
3580 $cmd && $cmd->execute($id, $m) ||
3581 &error(&text('euserdbacl', $dbh->errstr));
3584 my $cmd = $dbh->prepare(
3585 "insert into webmin_user_acl ".
3586 "(id,module,attr,value) values (?,?,?,?)");
3587 $cmd || &error(&text('euserdbacl2',
3589 foreach my $a (keys %{$_[0]}) {
3590 $cmd->execute($id,$m,$a,$_[0]->{$a}) ||
3591 &error(&text('euserdbacl2',
3598 elsif ($proto eq "ldap") {
3599 # Find the user in LDAP
3600 my $rv = $dbh->search(
3602 filter => '(&(cn='.$u.')(objectClass='.
3603 $args->{'userclass'}.'))',
3605 if (!$rv || $rv->code) {
3606 &error(&text('euserdbacl',
3607 $rv ? $rv->error : "Unknown error"));
3609 my ($user) = $rv->all_entries;
3612 # Find the ACL sub-object for the module
3614 my $ldapm = $m || "global";
3615 my $rv = $dbh->search(
3616 base => $user->dn(),
3617 filter => '(cn='.$ldapm.')',
3619 if (!$rv || $rv->code) {
3620 &error(&text('euserdbacl',
3621 $rv ? $rv->error : "Unknown error"));
3623 my ($acl) = $rv->all_entries;
3626 foreach my $a (keys %{$_[0]}) {
3627 push(@al, $a."=".$_[0]->{$a});
3631 $rv = $dbh->modify($acl->dn(),
3632 replace => { "webminAclEntry", \@al });
3636 my @attrs = ( "cn", $ldapm,
3637 "objectClass", "webminAcl",
3638 "webminAclEntry", \@al );
3639 $rv = $dbh->add("cn=".$ldapm.",".$user->dn(),
3642 if (!$rv || $rv->code) {
3643 &error(&text('euserdbacl2',
3644 $rv ? $rv->error : "Unknown error"));
3648 &disconnect_userdb($userdb, $dbh);
3652 # Save ACL to local file
3653 if (!-d "$config_directory/$m") {
3654 mkdir("$config_directory/$m", 0755);
3657 &write_file("$config_directory/$m/$u.acl", $_[0]);
3660 &unlink_file("$config_directory/$m/$u.acl");
3665 =head2 save_group_module_acl(&acl, group, [module], [never-update-group])
3667 Updates the acl hash for some group and module. The parameters are :
3669 =item acl - Hash reference for the new access control options.
3671 =item group - Group name to update.
3673 =item module - Module to update, defaulting to the caller.
3675 =item never-update-group - Never update the parent group's ACL
3678 sub save_group_module_acl
3681 my $m = defined($_[2]) ? $_[2] : &get_module_name();
3682 if (!$_[3] && &foreign_check("acl")) {
3683 # Check if this group is a member of a group, and if it gets the
3684 # module from a group. If so, update the parent ACL as well
3685 &foreign_require("acl", "acl-lib.pl");
3687 foreach my $pg (&acl::list_groups()) {
3688 if (&indexof('@'.$g, @{$pg->{'members'}}) >= 0 &&
3689 &indexof($m, @{$pg->{'modules'}}) >= 0) {
3695 &save_group_module_acl($_[0], $group->{'name'}, $m);
3699 my $userdb = &get_userdb_string();
3702 # Look for this group in the user/group DB
3703 my ($dbh, $proto, $prefix, $args) = &connect_userdb($userdb);
3704 ref($dbh) || &error(&text('egroupdbacl', $dbh));
3705 if ($proto eq "mysql" || $proto eq "postgresql") {
3706 # Find the group in the SQL DB
3707 my $cmd = $dbh->prepare(
3708 "select id from webmin_group where name = ?");
3709 $cmd && $cmd->execute($g) ||
3710 &error(&text('egroupdbacl2', $dbh->errstr));
3711 my ($id) = $cmd->fetchrow();
3712 $foundindb = 1 if (defined($id));
3715 # Replace ACLs for group
3717 my $cmd = $dbh->prepare("delete from webmin_group_acl ".
3718 "where id = ? and module = ?");
3719 $cmd && $cmd->execute($id, $m) ||
3720 &error(&text('egroupdbacl', $dbh->errstr));
3723 my $cmd = $dbh->prepare(
3724 "insert into webmin_group_acl ".
3725 "(id,module,attr,value) values (?,?,?,?)");
3726 $cmd || &error(&text('egroupdbacl2',
3728 foreach my $a (keys %{$_[0]}) {
3729 $cmd->execute($id,$m,$a,$_[0]->{$a}) ||
3730 &error(&text('egroupdbacl2',
3737 elsif ($proto eq "ldap") {
3738 # Find the group in LDAP
3739 my $rv = $dbh->search(
3741 filter => '(&(cn='.$g.')(objectClass='.
3742 $args->{'groupclass'}.'))',
3744 if (!$rv || $rv->code) {
3745 &error(&text('egroupdbacl',
3746 $rv ? $rv->error : "Unknown error"));
3748 my ($group) = $rv->all_entries;
3750 my $ldapm = $m || "global";
3752 # Find the ACL sub-object for the module
3754 my $rv = $dbh->search(
3755 base => $group->dn(),
3756 filter => '(cn='.$ldapm.')',
3758 if (!$rv || $rv->code) {
3759 &error(&text('egroupdbacl',
3760 $rv ? $rv->error : "Unknown error"));
3762 my ($acl) = $rv->all_entries;
3765 foreach my $a (keys %{$_[0]}) {
3766 push(@al, $a."=".$_[0]->{$a});
3770 $rv = $dbh->modify($acl->dn(),
3771 replace => { "webminAclEntry", \@al });
3775 my @attrs = ( "cn", $ldapm,
3776 "objectClass", "webminAcl",
3777 "webminAclEntry", \@al );
3778 $rv = $dbh->add("cn=".$ldapm.",".$group->dn(),
3781 if (!$rv || $rv->code) {
3782 &error(&text('egroupdbacl2',
3783 $rv ? $rv->error : "Unknown error"));
3787 &disconnect_userdb($userdb, $dbh);
3791 # Save ACL to local file
3792 if (!-d "$config_directory/$m") {
3793 mkdir("$config_directory/$m", 0755);
3796 &write_file("$config_directory/$m/$g.gacl", $_[0]);
3799 &unlink_file("$config_directory/$m/$g.gacl");
3806 This function must be called by all Webmin CGI scripts, either directly or
3807 indirectly via a per-module lib.pl file. It performs a number of initialization
3808 and housekeeping tasks, such as working out the module name, checking that the
3809 current user has access to the module, and populating global variables. Some
3810 of the variables set include :
3812 =item $config_directory - Base Webmin config directory, typically /etc/webmin
3814 =item $var_directory - Base logs directory, typically /var/webmin
3816 =item %config - Per-module configuration.
3818 =item %gconfig - Global configuration.
3820 =item $scriptname - Base name of the current perl script.
3822 =item $module_name - The name of the current module.
3824 =item $module_config_directory - The config directory for this module.
3826 =item $module_config_file - The config file for this module.
3828 =item $module_root_directory - This module's code directory.
3830 =item $webmin_logfile - The detailed logfile for webmin.
3832 =item $remote_user - The actual username used to login to webmin.
3834 =item $base_remote_user - The username whose permissions are in effect.
3836 =item $current_theme - The theme currently in use.
3838 =item $root_directory - The first root directory of this webmin install.
3840 =item @root_directories - All root directories for this webmin install.
3845 # Record first process ID that called this, so we know when it exited to clean
3847 $main::initial_process_id ||= $$;
3849 # Configuration and spool directories
3850 if (!defined($ENV{'WEBMIN_CONFIG'})) {
3851 die "WEBMIN_CONFIG not set";
3853 $config_directory = $ENV{'WEBMIN_CONFIG'};
3854 if (!defined($ENV{'WEBMIN_VAR'})) {
3855 open(VARPATH, "$config_directory/var-path");
3856 chop($var_directory = <VARPATH>);
3860 $var_directory = $ENV{'WEBMIN_VAR'};
3862 $main::http_cache_directory = $ENV{'WEBMIN_VAR'}."/cache";
3863 $main::default_debug_log_file = $ENV{'WEBMIN_VAR'}."/webmin.debug";
3865 if ($ENV{'SESSION_ID'}) {
3866 # Hide this variable from called programs, but keep it for internal use
3867 $main::session_id = $ENV{'SESSION_ID'};
3868 delete($ENV{'SESSION_ID'});
3870 if ($ENV{'REMOTE_PASS'}) {
3871 # Hide the password too
3872 $main::remote_pass = $ENV{'REMOTE_PASS'};
3873 delete($ENV{'REMOTE_PASS'});
3876 if ($> == 0 && $< != 0 && !$ENV{'FOREIGN_MODULE_NAME'}) {
3877 # Looks like we are running setuid, but the real UID hasn't been set.
3878 # Do so now, so that executed programs don't get confused
3883 # Read the webmin global config file. This contains the OS type and version,
3884 # OS specific configuration and global options such as proxy servers
3885 $config_file = "$config_directory/config";
3887 &read_file_cached($config_file, \%gconfig);
3888 $null_file = $gconfig{'os_type'} eq 'windows' ? "NUL" : "/dev/null";
3889 $path_separator = $gconfig{'os_type'} eq 'windows' ? ';' : ':';
3891 # If debugging is enabled, open the debug log
3892 if ($gconfig{'debug_enabled'} && !$main::opened_debug_log++) {
3893 my $dlog = $gconfig{'debug_file'} || $main::default_debug_log_file;
3894 if ($gconfig{'debug_size'}) {
3895 my @st = stat($dlog);
3896 if ($st[7] > $gconfig{'debug_size'}) {
3897 rename($dlog, $dlog.".0");
3900 open(main::DEBUGLOG, ">>$dlog");
3901 $main::opened_debug_log = 1;
3903 if ($gconfig{'debug_what_start'}) {
3904 my $script_name = $0 =~ /([^\/]+)$/ ? $1 : '-';
3905 $main::debug_log_start_time = time();
3906 &webmin_debug_log("START", "script=$script_name");
3907 $main::debug_log_start_module = $module_name;
3911 # Set PATH and LD_LIBRARY_PATH
3912 if ($gconfig{'path'}) {
3913 if ($gconfig{'syspath'}) {
3915 $ENV{'PATH'} = $gconfig{'path'};
3919 $ENV{'PATH'} = $gconfig{'path'}.$path_separator.$ENV{'PATH'};
3922 $ENV{$gconfig{'ld_env'}} = $gconfig{'ld_path'} if ($gconfig{'ld_env'});
3924 # Set http_proxy and ftp_proxy environment variables, based on Webmin settings
3925 if ($gconfig{'http_proxy'}) {
3926 $ENV{'http_proxy'} = $gconfig{'http_proxy'};
3928 if ($gconfig{'ftp_proxy'}) {
3929 $ENV{'ftp_proxy'} = $gconfig{'ftp_proxy'};
3931 if ($gconfig{'noproxy'}) {
3932 $ENV{'no_proxy'} = $gconfig{'noproxy'};
3935 # Find all root directories
3937 if (&get_miniserv_config(\%miniserv)) {
3938 @root_directories = ( $miniserv{'root'} );
3939 for($i=0; defined($miniserv{"extraroot_$i"}); $i++) {
3940 push(@root_directories, $miniserv{"extraroot_$i"});
3944 # Work out which module we are in, and read the per-module config file
3945 $0 =~ s/\\/\//g; # Force consistent path on Windows
3946 if (defined($ENV{'FOREIGN_MODULE_NAME'})) {
3947 # In a foreign call - use the module name given
3948 $root_directory = $ENV{'FOREIGN_ROOT_DIRECTORY'};
3949 $module_name = $ENV{'FOREIGN_MODULE_NAME'};
3950 @root_directories = ( $root_directory ) if (!@root_directories);
3952 elsif ($ENV{'SCRIPT_NAME'}) {
3953 my $sn = $ENV{'SCRIPT_NAME'};
3954 $sn =~ s/^$gconfig{'webprefix'}//
3955 if (!$gconfig{'webprefixnoredir'});
3956 if ($sn =~ /^\/([^\/]+)\//) {
3957 # Get module name from CGI path
3960 if ($ENV{'SERVER_ROOT'}) {
3961 $root_directory = $ENV{'SERVER_ROOT'};
3963 elsif ($ENV{'SCRIPT_FILENAME'}) {
3964 $root_directory = $ENV{'SCRIPT_FILENAME'};
3965 $root_directory =~ s/$sn$//;
3967 @root_directories = ( $root_directory ) if (!@root_directories);
3970 # Get root directory from miniserv.conf, and deduce module name from $0
3971 $root_directory = $root_directories[0];
3973 foreach my $r (@root_directories) {
3974 if ($0 =~ /^$r\/([^\/]+)\/[^\/]+$/i) {
3975 # Under a module directory
3980 elsif ($0 =~ /^$root_directory\/[^\/]+$/i) {
3986 &error("Script was not run with full path (failed to find $0 under $root_directory)") if (!$rok);
3989 # Work out of this is a web, command line or cron job
3990 if (!$main::webmin_script_type) {
3991 if ($ENV{'SCRIPT_NAME'}) {
3993 $main::webmin_script_type = 'web';
3996 # Cron jobs have no TTY
3997 if ($gconfig{'os_type'} eq 'windows' ||
3998 open(DEVTTY, ">/dev/tty")) {
3999 $main::webmin_script_type = 'cmd';
4003 $main::webmin_script_type = 'cron';
4008 # Set the umask based on config
4009 if ($gconfig{'umask'} && !$main::umask_already++) {
4010 umask(oct($gconfig{'umask'}));
4013 # If this is a cron job or other background task, set the nice level
4014 if (!$main::nice_already && $main::webmin_script_type eq 'cron') {
4016 if ($gconfig{'nice'}) {
4017 eval 'POSIX::nice($gconfig{\'nice\'});';
4020 # Set IO scheduling class and priority
4021 if ($gconfig{'sclass'} ne '' || $gconfig{'sprio'} ne '') {
4023 $cmd .= " -c ".quotemeta($gconfig{'sclass'})
4024 if ($gconfig{'sclass'} ne '');
4025 $cmd .= " -n ".quotemeta($gconfig{'sprio'})
4026 if ($gconfig{'sprio'} ne '');
4028 &execute_command("$cmd >/dev/null 2>&1");
4031 $main::nice_already++;
4034 my $u = $ENV{'BASE_REMOTE_USER'} || $ENV{'REMOTE_USER'};
4035 $base_remote_user = $u;
4036 $remote_user = $ENV{'REMOTE_USER'};
4038 # Work out if user is definitely in the DB, and if so get his attrs
4039 $remote_user_proto = $ENV{"REMOTE_USER_PROTO"};
4040 %remote_user_attrs = ( );
4041 if ($remote_user_proto) {
4042 my $userdb = &get_userdb_string();
4043 my ($dbh, $proto, $prefix, $args) =
4044 $userdb ? &connect_userdb($userdb) : ( );
4046 if ($proto eq "mysql" || $proto eq "postgresql") {
4047 # Read attrs from SQL
4048 my $cmd = $dbh->prepare("select webmin_user_attr.attr,webmin_user_attr.value from webmin_user_attr,webmin_user where webmin_user_attr.id = webmin_user.id and webmin_user.name = ?");
4049 if ($cmd && $cmd->execute($base_remote_user)) {
4050 while(my ($attr, $value) = $cmd->fetchrow()) {
4051 $remote_user_attrs{$attr} = $value;
4056 elsif ($proto eq "ldap") {
4057 # Read attrs from LDAP
4058 my $rv = $dbh->search(
4060 filter => '(&(cn='.$base_remote_user.')'.
4062 $args->{'userclass'}.'))',
4064 my ($u) = $rv && !$rv->code ? $rv->all_entries : ( );
4066 foreach $la ($u->get_value('webminAttr')) {
4067 my ($attr, $value) = split(/=/, $la, 2);
4068 $remote_user_attrs{$attr} = $value;
4072 &disconnect_userdb($userdb, $dbh);
4077 # Find and load the configuration file for this module
4078 my (@ruinfo, $rgroup);
4079 $module_config_directory = "$config_directory/$module_name";
4080 if (&get_product_name() eq "usermin" &&
4081 -r "$module_config_directory/config.$remote_user") {
4083 $module_config_file = "$module_config_directory/config.$remote_user";
4085 elsif (&get_product_name() eq "usermin" &&
4086 (@ruinfo = getpwnam($remote_user)) &&
4087 ($rgroup = getgrgid($ruinfo[3])) &&
4088 -r "$module_config_directory/config.\@$rgroup") {
4089 # Based on group name
4090 $module_config_file = "$module_config_directory/config.\@$rgroup";
4094 $module_config_file = "$module_config_directory/config";
4097 &read_file_cached($module_config_file, \%config);
4099 # Fix up windows-specific substitutions in values
4100 foreach my $k (keys %config) {
4101 if ($config{$k} =~ /\$\{systemroot\}/) {
4102 my $root = &get_windows_root();
4103 $config{$k} =~ s/\$\{systemroot\}/$root/g;
4108 # Record the initial module
4109 $main::initial_module_name ||= $module_name;
4111 # Set some useful variables
4113 $current_themes = $ENV{'MOBILE_DEVICE'} && defined($gconfig{'mobile_theme'}) ?
4114 $gconfig{'mobile_theme'} :
4115 defined($remote_user_attrs{'theme'}) ?
4116 $remote_user_attrs{'theme'} :
4117 defined($gconfig{'theme_'.$remote_user}) ?
4118 $gconfig{'theme_'.$remote_user} :
4119 defined($gconfig{'theme_'.$base_remote_user}) ?
4120 $gconfig{'theme_'.$base_remote_user} :
4122 @current_themes = split(/\s+/, $current_themes);
4123 $current_theme = $current_themes[0];
4124 @theme_root_directories = map { "$root_directory/$_" } @current_themes;
4125 $theme_root_directory = $theme_root_directories[0];
4126 @theme_configs = ( );
4127 foreach my $troot (@theme_root_directories) {
4129 &read_file_cached("$troot/config", \%onetconfig);
4130 &read_file_cached("$troot/config", \%tconfig);
4131 push(@theme_configs, \%onetconfig);
4133 $tb = defined($tconfig{'cs_header'}) ? "bgcolor=#$tconfig{'cs_header'}" :
4134 defined($gconfig{'cs_header'}) ? "bgcolor=#$gconfig{'cs_header'}" :
4136 $cb = defined($tconfig{'cs_table'}) ? "bgcolor=#$tconfig{'cs_table'}" :
4137 defined($gconfig{'cs_table'}) ? "bgcolor=#$gconfig{'cs_table'}" :
4139 $tb .= ' '.$tconfig{'tb'} if ($tconfig{'tb'});
4140 $cb .= ' '.$tconfig{'cb'} if ($tconfig{'cb'});
4141 if ($tconfig{'preload_functions'}) {
4142 # Force load of theme functions right now, if requested
4143 &load_theme_library();
4145 if ($tconfig{'oofunctions'} && !$main::loaded_theme_oo_library++) {
4146 # Load the theme's Webmin:: package classes
4147 do "$theme_root_directory/$tconfig{'oofunctions'}";
4152 $webmin_logfile = $gconfig{'webmin_log'} ? $gconfig{'webmin_log'}
4153 : "$var_directory/webmin.log";
4155 # Load language strings into %text
4156 my @langs = &list_languages();
4158 if ($gconfig{'acceptlang'}) {
4159 foreach my $a (split(/,/, $ENV{'HTTP_ACCEPT_LANGUAGE'})) {
4160 my ($al) = grep { $_->{'lang'} eq $a } @langs;
4162 $accepted_lang = $al->{'lang'};
4167 $current_lang = $force_lang ? $force_lang :
4168 $accepted_lang ? $accepted_lang :
4169 $remote_user_attrs{'lang'} ? $remote_user_attrs{'lang'} :
4170 $gconfig{"lang_$remote_user"} ? $gconfig{"lang_$remote_user"} :
4171 $gconfig{"lang_$base_remote_user"} ? $gconfig{"lang_$base_remote_user"} :
4172 $gconfig{"lang"} ? $gconfig{"lang"} : $default_lang;
4173 foreach my $l (@langs) {
4174 $current_lang_info = $l if ($l->{'lang'} eq $current_lang);
4176 @lang_order_list = &unique($default_lang,
4177 split(/:/, $current_lang_info->{'fallback'}),
4179 %text = &load_language($module_name);
4180 %text || &error("Failed to determine Webmin root from SERVER_ROOT, SCRIPT_FILENAME or the full command line");
4182 # Get the %module_info for this module
4184 my ($mi) = grep { $_->{'dir'} eq $module_name }
4185 &get_all_module_infos(2);
4186 %module_info = %$mi;
4187 $module_root_directory = &module_root_directory($module_name);
4190 if ($module_name && !$main::no_acl_check &&
4191 !defined($ENV{'FOREIGN_MODULE_NAME'})) {
4192 # Check if the HTTP user can access this module
4193 if (!&foreign_available($module_name)) {
4194 if (!&foreign_check($module_name)) {
4195 &error(&text('emodulecheck',
4196 "<i>$module_info{'desc'}</i>"));
4199 &error(&text('emodule', "<i>$u</i>",
4200 "<i>$module_info{'desc'}</i>"));
4203 $main::no_acl_check++;
4206 # Check the Referer: header for nasty redirects
4207 my @referers = split(/\s+/, $gconfig{'referers'});
4209 if ($ENV{'HTTP_REFERER'} =~/^(http|https|ftp):\/\/([^:\/]+:[^@\/]+@)?([^\/:@]+)/) {
4212 my $http_host = $ENV{'HTTP_HOST'};
4213 $http_host =~ s/:\d+$//;
4214 my $unsafe_index = $unsafe_index_cgi ||
4215 &get_module_variable('$unsafe_index_cgi');
4217 ($ENV{'SCRIPT_NAME'} !~ /^\/(index.cgi)?$/ || $unsafe_index) &&
4218 ($ENV{'SCRIPT_NAME'} !~ /^\/([a-z0-9\_\-]+)\/(index.cgi)?$/i ||
4220 $0 !~ /(session_login|pam_login)\.cgi$/ && !$gconfig{'referer'} &&
4221 $ENV{'MINISERV_CONFIG'} && !$main::no_referers_check &&
4222 $ENV{'HTTP_USER_AGENT'} !~ /^Webmin/i &&
4223 ($referer_site && $referer_site ne $http_host &&
4224 &indexof($referer_site, @referers) < 0 ||
4225 !$referer_site && $gconfig{'referers_none'}) &&
4226 !$trust_unknown_referers &&
4227 !&get_module_variable('$trust_unknown_referers')) {
4228 # Looks like a link from elsewhere .. show an error
4229 &header($text{'referer_title'}, "", undef, 0, 1, 1);
4231 $prot = lc($ENV{'HTTPS'}) eq 'on' ? "https" : "http";
4232 my $url = "<tt>".&html_escape("$prot://$ENV{'HTTP_HOST'}$ENV{'REQUEST_URI'}")."</tt>";
4233 if ($referer_site) {
4235 print &text('referer_warn',
4236 "<tt>".&html_escape($ENV{'HTTP_REFERER'})."</tt>", $url);
4238 print &text('referer_fix1', &html_escape($http_host)),"<p>\n";
4239 print &text('referer_fix2', &html_escape($http_host)),"<p>\n";
4242 # No referer info given
4243 print &text('referer_warn_unknown', $url),"<p>\n";
4244 print &text('referer_fix1u'),"<p>\n";
4245 print &text('referer_fix2u'),"<p>\n";
4249 &footer("/", $text{'index'});
4252 $main::no_referers_check++;
4253 $main::completed_referers_check++;
4255 # Call theme post-init
4256 if (defined(&theme_post_init_config)) {
4257 &theme_post_init_config(@_);
4260 # Record that we have done the calling library in this package
4261 my ($callpkg, $lib) = caller();
4263 $main::done_foreign_require{$callpkg,$lib} = 1;
4265 # If a licence checking is enabled, do it now
4266 if ($gconfig{'licence_module'} && !$main::done_licence_module_check &&
4267 &foreign_check($gconfig{'licence_module'}) &&
4268 -r "$root_directory/$gconfig{'licence_module'}/licence_check.pl") {
4269 my $oldpwd = &get_current_dir();
4270 $main::done_licence_module_check++;
4271 $main::licence_module = $gconfig{'licence_module'};
4272 &foreign_require($main::licence_module, "licence_check.pl");
4273 ($main::licence_status, $main::licence_message) =
4274 &foreign_call($main::licence_module, "check_licence");
4278 # Export global variables to caller
4279 if ($main::export_to_caller) {
4280 foreach my $v ('$config_file', '%gconfig', '$null_file',
4281 '$path_separator', '@root_directories',
4282 '$root_directory', '$module_name',
4283 '$base_remote_user', '$remote_user',
4284 '$remote_user_proto', '%remote_user_attrs',
4285 '$module_config_directory', '$module_config_file',
4286 '%config', '@current_themes', '$current_theme',
4287 '@theme_root_directories', '$theme_root_directory',
4288 '%tconfig','@theme_configs', '$tb', '$cb', '$scriptname',
4289 '$webmin_logfile', '$current_lang',
4290 '$current_lang_info', '@lang_order_list', '%text',
4291 '%module_info', '$module_root_directory') {
4292 my ($vt, $vn) = split('', $v, 2);
4293 eval "${vt}${callpkg}::${vn} = ${vt}${vn}";
4300 =head2 load_language([module], [directory])
4302 Returns a hashtable mapping text codes to strings in the appropriate language,
4303 based on the $current_lang global variable, which is in turn set based on
4304 the Webmin user's selection. The optional module parameter tells the function
4305 which module to load strings for, and defaults to the calling module. The
4306 optional directory parameter can be used to load strings from a directory
4309 In regular module development you will never need to call this function
4310 directly, as init_config calls it for you, and places the module's strings
4311 into the %text hash.
4317 my $root = $root_directory;
4318 my $ol = $gconfig{'overlang'};
4319 my ($dir) = ($_[1] || "lang");
4321 # Read global lang files
4322 foreach my $o (@lang_order_list) {
4323 my $ok = &read_file_cached("$root/$dir/$o", \%text);
4324 return () if (!$ok && $o eq $default_lang);
4327 foreach my $o (@lang_order_list) {
4328 &read_file_cached("$root/$ol/$o", \%text);
4331 &read_file_cached("$config_directory/custom-lang", \%text);
4334 # Read module's lang files
4335 my $mdir = &module_root_directory($_[0]);
4336 foreach my $o (@lang_order_list) {
4337 &read_file_cached("$mdir/$dir/$o", \%text);
4340 foreach $o (@lang_order_list) {
4341 &read_file_cached("$mdir/$ol/$o", \%text);
4344 &read_file_cached("$config_directory/$_[0]/custom-lang", \%text);
4346 foreach $k (keys %text) {
4347 $text{$k} =~ s/\$(\{([^\}]+)\}|([A-Za-z0-9\.\-\_]+))/text_subs($2 || $3,\%text)/ge;
4350 if (defined(&theme_load_language)) {
4351 &theme_load_language(\%text, $_[0]);
4356 =head2 text_subs(string)
4358 Used internally by load_language to expand $code substitutions in language
4364 if (substr($_[0], 0, 8) eq "include:") {
4367 open(INCLUDE, substr($_[0], 8));
4375 my $t = $_[1]->{$_[0]};
4376 return defined($t) ? $t : '$'.$_[0];
4380 =head2 text(message, [substitute]+)
4382 Returns a translated message from %text, but with $1, $2, etc.. replaced with
4383 the substitute parameters. This makes it easy to use strings with placeholders
4384 that get replaced with programmatically generated text. For example :
4386 print &text('index_hello', $remote_user),"<p>\n";
4391 my $t = &get_module_variable('%text', 1);
4392 my $rv = exists($t->{$_[0]}) ? $t->{$_[0]} : $text{$_[0]};
4393 for(my $i=1; $i<@_; $i++) {
4394 $rv =~ s/\$$i/$_[$i]/g;
4399 =head2 encode_base64(string)
4401 Encodes a string into base64 format, for use in MIME email or HTTP
4402 authorization headers.
4408 pos($_[0]) = 0; # ensure start at the beginning
4409 while ($_[0] =~ /(.{1,57})/gs) {
4410 $res .= substr(pack('u57', $1), 1)."\n";
4413 $res =~ tr|\` -_|AA-Za-z0-9+/|;
4414 my $padding = (3 - length($_[0]) % 3) % 3;
4415 $res =~ s/.{$padding}$/'=' x $padding/e if ($padding);
4419 =head2 decode_base64(string)
4421 Converts a base64-encoded string into plain text. The opposite of encode_base64.
4428 $str =~ tr|A-Za-z0-9+=/||cd; # remove non-base64 chars
4429 if (length($str) % 4) {
4432 $str =~ s/=+$//; # remove padding
4433 $str =~ tr|A-Za-z0-9+/| -_|; # convert to uuencoded format
4434 while ($str =~ /(.{1,60})/gs) {
4435 my $len = chr(32 + length($1)*3/4); # compute length byte
4436 $res .= unpack("u", $len . $1 ); # uudecode
4441 =head2 get_module_info(module, [noclone], [forcache])
4443 Returns a hash containg details of the given module. Some useful keys are :
4445 =item dir - The module directory, like sendmail.
4447 =item desc - Human-readable description, in the current users' language.
4449 =item version - Optional module version number.
4451 =item os_support - List of supported operating systems and versions.
4453 =item category - Category on Webmin's left menu, like net.
4458 return () if ($_[0] =~ /^\./);
4459 my (%rv, $clone, $o);
4460 my $mdir = &module_root_directory($_[0]);
4461 &read_file_cached("$mdir/module.info", \%rv) || return ();
4463 foreach $o (@lang_order_list) {
4464 $rv{"desc"} = $rv{"desc_$o"} if ($rv{"desc_$o"});
4465 $rv{"longdesc"} = $rv{"longdesc_$o"} if ($rv{"longdesc_$o"});
4467 if ($clone && !$_[1] && $config_directory) {
4468 $rv{'clone'} = $rv{'desc'};
4469 &read_file("$config_directory/$_[0]/clone", \%rv);
4472 my %module_categories;
4473 &read_file_cached("$config_directory/webmin.cats", \%module_categories);
4474 my $pn = &get_product_name();
4475 if (defined($rv{'category_'.$pn})) {
4476 # Can override category for webmin/usermin
4477 $rv{'category'} = $rv{'category_'.$pn};
4479 $rv{'realcategory'} = $rv{'category'};
4480 $rv{'category'} = $module_categories{$_[0]}
4481 if (defined($module_categories{$_[0]}));
4483 # Apply description overrides
4484 $rv{'realdesc'} = $rv{'desc'};
4486 &read_file_cached("$config_directory/webmin.descs", \%descs);
4487 if ($descs{$_[0]." ".$current_lang}) {
4488 $rv{'desc'} = $descs{$_[0]." ".$current_lang};
4490 elsif ($descs{$_[0]}) {
4491 $rv{'desc'} = $descs{$_[0]};
4495 # Apply per-user description overridde
4496 my %gaccess = &get_module_acl(undef, "");
4497 if ($gaccess{'desc_'.$_[0]}) {
4498 $rv{'desc'} = $gaccess{'desc_'.$_[0]};
4502 if ($rv{'longdesc'}) {
4503 # All standard modules have an index.cgi
4504 $rv{'index_link'} = 'index.cgi';
4507 # Call theme-specific override function
4508 if (defined(&theme_get_module_info)) {
4509 %rv = &theme_get_module_info(\%rv, $_[0], $_[1], $_[2]);
4515 =head2 get_all_module_infos(cachemode)
4517 Returns a list contains the information on all modules in this webmin
4518 install, including clones. Uses caching to reduce the number of module.info
4519 files that need to be read. Each element of the array is a hash reference
4520 in the same format as returned by get_module_info. The cache mode flag can be :
4521 0 = read and write, 1 = don't read or write, 2 = read only
4524 sub get_all_module_infos
4528 # Is the cache out of date? (ie. have any of the root's changed?)
4529 my $cache_file = "$config_directory/module.infos.cache";
4531 if (&read_file_cached($cache_file, \%cache)) {
4532 foreach my $r (@root_directories) {
4534 if ($st[9] != $cache{'mtime_'.$r}) {
4544 if ($_[0] != 1 && !$changed && $cache{'lang'} eq $current_lang) {
4545 # Can use existing module.info cache
4547 foreach my $k (keys %cache) {
4548 if ($k =~ /^(\S+) (\S+)$/) {
4549 $mods{$1}->{$2} = $cache{$k};
4552 @rv = map { $mods{$_} } (keys %mods) if (%mods);
4555 # Need to rebuild cache
4557 foreach my $r (@root_directories) {
4559 foreach my $m (readdir(DIR)) {
4560 next if ($m =~ /^(config-|\.)/ || $m =~ /\.(cgi|pl)$/);
4561 my %minfo = &get_module_info($m, 0, 1);
4562 next if (!%minfo || !$minfo{'dir'});
4564 foreach $k (keys %minfo) {
4565 $cache{"${m} ${k}"} = $minfo{$k};
4570 $cache{'mtime_'.$r} = $st[9];
4572 $cache{'lang'} = $current_lang;
4573 &write_file($cache_file, \%cache) if (!$_[0] && $< == 0 && $> == 0);
4576 # Override descriptions for modules for current user
4577 my %gaccess = &get_module_acl(undef, "");
4578 foreach my $m (@rv) {
4579 if ($gaccess{"desc_".$m->{'dir'}}) {
4580 $m->{'desc'} = $gaccess{"desc_".$m->{'dir'}};
4584 # Apply installed flags
4586 &read_file_cached("$config_directory/installed.cache", \%installed);
4587 foreach my $m (@rv) {
4588 $m->{'installed'} = $installed{$m->{'dir'}};
4594 =head2 get_theme_info(theme)
4596 Returns a hash containing a theme's details, taken from it's theme.info file.
4597 Some useful keys are :
4599 =item dir - The theme directory, like blue-theme.
4601 =item desc - Human-readable description, in the current users' language.
4603 =item version - Optional module version number.
4605 =item os_support - List of supported operating systems and versions.
4610 return () if ($_[0] =~ /^\./);
4612 my $tdir = &module_root_directory($_[0]);
4613 &read_file("$tdir/theme.info", \%rv) || return ();
4614 foreach my $o (@lang_order_list) {
4615 $rv{"desc"} = $rv{"desc_$o"} if ($rv{"desc_$o"});
4621 =head2 list_languages
4623 Returns an array of supported languages, taken from Webmin's os_list.txt file.
4624 Each is a hash reference with the following keys :
4626 =item lang - The short language code, like es for Spanish.
4628 =item desc - A human-readable description, in English.
4630 =item charset - An optional character set to use when displaying the language.
4632 =item titles - Set to 1 only if Webmin has title images for the language.
4634 =item fallback - The code for another language to use if a string does not exist in this one. For all languages, English is the ultimate fallback.
4639 if (!@main::list_languages_cache) {
4642 open(LANG, "$root_directory/lang_list.txt");
4644 if (/^(\S+)\s+(.*)/) {
4645 my $l = { 'desc' => $2 };
4646 foreach $o (split(/,/, $1)) {
4647 if ($o =~ /^([^=]+)=(.*)$/) {
4651 $l->{'index'} = scalar(@rv);
4652 push(@main::list_languages_cache, $l);
4656 @main::list_languages_cache = sort { $a->{'desc'} cmp $b->{'desc'} }
4657 @main::list_languages_cache;
4659 return @main::list_languages_cache;
4662 =head2 read_env_file(file, &hash)
4664 Similar to Webmin's read_file function, but handles files containing shell
4665 environment variables formatted like :
4670 The file parameter is the full path to the file to read, and hash a Perl hash
4671 ref to read names and values into.
4677 &open_readfile(FILE, $_[0]) || return 0;
4680 if (/^\s*(export\s*)?([A-Za-z0-9_\.]+)\s*=\s*"(.*)"/i ||
4681 /^\s*(export\s*)?([A-Za-z0-9_\.]+)\s*=\s*'(.*)'/i ||
4682 /^\s*(export\s*)?([A-Za-z0-9_\.]+)\s*=\s*(.*)/i) {
4690 =head2 write_env_file(file, &hash, [export])
4692 Writes out a hash to a file in name='value' format, suitable for use in a shell
4693 script. The parameters are :
4695 =item file - Full path for a file to write to
4697 =item hash - Hash reference of names and values to write.
4699 =item export - If set to 1, preceed each variable setting with the word 'export'.
4704 my $exp = $_[2] ? "export " : "";
4705 &open_tempfile(FILE, ">$_[0]");
4706 foreach my $k (keys %{$_[1]}) {
4707 my $v = $_[1]->{$k};
4708 if ($v =~ /^\S+$/) {
4709 &print_tempfile(FILE, "$exp$k=$v\n");
4712 &print_tempfile(FILE, "$exp$k=\"$v\"\n");
4715 &close_tempfile(FILE);
4718 =head2 lock_file(filename, [readonly], [forcefile])
4720 Lock a file for exclusive access. If the file is already locked, spin
4721 until it is freed. Uses a .lock file, which is not 100% reliable, but seems
4722 to work OK. The parameters are :
4724 =item filename - File or directory to lock.
4726 =item readonly - If set, the lock is for reading the file only. More than one script can have a readonly lock, but only one can hold a write lock.
4728 =item forcefile - Force the file to be considered as a real file and not a symlink for Webmin actions logging purposes.
4733 my $realfile = &translate_filename($_[0]);
4734 return 0 if (!$_[0] || defined($main::locked_file_list{$realfile}));
4735 my $no_lock = !&can_lock_file($realfile);
4736 my $lock_tries_count = 0;
4739 if (!$no_lock && open(LOCKING, "$realfile.lock")) {
4744 if ($no_lock || !$pid || !kill(0, $pid) || $pid == $$) {
4747 # Create the .lock file
4748 open(LOCKING, ">$realfile.lock") || return 0;
4749 my $lck = eval "flock(LOCKING, 2+4)";
4751 # Lock of lock file failed! Wait till later
4754 print LOCKING $$,"\n";
4755 eval "flock(LOCKING, 8)";
4758 $main::locked_file_list{$realfile} = int($_[1]);
4759 push(@main::temporary_files, "$realfile.lock");
4760 if (($gconfig{'logfiles'} || $gconfig{'logfullfiles'}) &&
4761 !&get_module_variable('$no_log_file_changes') &&
4763 # Grab a copy of this file for later diffing
4765 $main::locked_file_data{$realfile} = undef;
4767 $main::locked_file_type{$realfile} = 1;
4768 $main::locked_file_data{$realfile} = '';
4770 elsif (!$_[2] && ($lnk = readlink($realfile))) {
4771 $main::locked_file_type{$realfile} = 2;
4772 $main::locked_file_data{$realfile} = $lnk;
4774 elsif (open(ORIGFILE, $realfile)) {
4775 $main::locked_file_type{$realfile} = 0;
4776 $main::locked_file_data{$realfile} = '';
4779 $main::locked_file_data{$realfile} .=$_;
4788 if ($lock_tries_count++ > 5*60) {
4789 # Give up after 5 minutes
4790 &error(&text('elock_tries', "<tt>$realfile</tt>", 5));
4796 =head2 unlock_file(filename)
4798 Release a lock on a file taken out by lock_file. If Webmin actions logging of
4799 file changes is enabled, then at unlock file a diff will be taken between the
4800 old and new contents, and stored under /var/webmin/diffs when webmin_log is
4801 called. This can then be viewed in the Webmin Actions Log module.
4806 my $realfile = &translate_filename($_[0]);
4807 return if (!$_[0] || !defined($main::locked_file_list{$realfile}));
4808 unlink("$realfile.lock") if (&can_lock_file($realfile));
4809 delete($main::locked_file_list{$realfile});
4810 if (exists($main::locked_file_data{$realfile})) {
4811 # Diff the new file with the old
4813 my $lnk = readlink($realfile);
4814 my $type = -d _ ? 1 : $lnk ? 2 : 0;
4815 my $oldtype = $main::locked_file_type{$realfile};
4816 my $new = !defined($main::locked_file_data{$realfile});
4817 if ($new && !-e _) {
4818 # file doesn't exist, and never did! do nothing ..
4820 elsif ($new && $type == 1 || !$new && $oldtype == 1) {
4821 # is (or was) a directory ..
4822 if (-d _ && !defined($main::locked_file_data{$realfile})) {
4823 push(@main::locked_file_diff,
4824 { 'type' => 'mkdir', 'object' => $realfile });
4826 elsif (!-d _ && defined($main::locked_file_data{$realfile})) {
4827 push(@main::locked_file_diff,
4828 { 'type' => 'rmdir', 'object' => $realfile });
4831 elsif ($new && $type == 2 || !$new && $oldtype == 2) {
4832 # is (or was) a symlink ..
4833 if ($lnk && !defined($main::locked_file_data{$realfile})) {
4834 push(@main::locked_file_diff,
4835 { 'type' => 'symlink', 'object' => $realfile,
4838 elsif (!$lnk && defined($main::locked_file_data{$realfile})) {
4839 push(@main::locked_file_diff,
4840 { 'type' => 'unsymlink', 'object' => $realfile,
4841 'data' => $main::locked_file_data{$realfile} });
4843 elsif ($lnk ne $main::locked_file_data{$realfile}) {
4844 push(@main::locked_file_diff,
4845 { 'type' => 'resymlink', 'object' => $realfile,
4850 # is a file, or has changed type?!
4851 my ($diff, $delete_file);
4852 my $type = "modify";
4854 open(NEWFILE, ">$realfile");
4859 if (!defined($main::locked_file_data{$realfile})) {
4862 open(ORIGFILE, ">$realfile.webminorig");
4863 print ORIGFILE $main::locked_file_data{$realfile};
4865 $diff = &backquote_command(
4866 "diff ".quotemeta("$realfile.webminorig")." ".
4867 quotemeta($realfile)." 2>/dev/null");
4868 push(@main::locked_file_diff,
4869 { 'type' => $type, 'object' => $realfile,
4870 'data' => $diff } ) if ($diff);
4871 unlink("$realfile.webminorig");
4872 unlink($realfile) if ($delete_file);
4875 if ($gconfig{'logfullfiles'}) {
4876 # Add file details to list of those to fully log
4877 $main::orig_file_data{$realfile} ||=
4878 $main::locked_file_data{$realfile};
4879 $main::orig_file_type{$realfile} ||=
4880 $main::locked_file_type{$realfile};
4883 delete($main::locked_file_data{$realfile});
4884 delete($main::locked_file_type{$realfile});
4888 =head2 test_lock(file)
4890 Returns 1 if some file is currently locked, 0 if not.
4895 my $realfile = &translate_filename($_[0]);
4896 return 0 if (!$_[0]);
4897 return 1 if (defined($main::locked_file_list{$realfile}));
4898 return 0 if (!&can_lock_file($realfile));
4900 if (open(LOCKING, "$realfile.lock")) {
4905 return $pid && kill(0, $pid);
4908 =head2 unlock_all_files
4910 Unlocks all files locked by the current script.
4913 sub unlock_all_files
4915 foreach $f (keys %main::locked_file_list) {
4920 =head2 can_lock_file(file)
4922 Returns 1 if some file should be locked, based on the settings in the
4923 Webmin Configuration module. For internal use by lock_file only.
4928 if (&is_readonly_mode()) {
4929 return 0; # never lock in read-only mode
4931 elsif ($gconfig{'lockmode'} == 0) {
4934 elsif ($gconfig{'lockmode'} == 1) {
4938 # Check if under any of the directories
4940 foreach my $d (split(/\t+/, $gconfig{'lockdirs'})) {
4941 if (&same_file($d, $_[0]) ||
4942 &is_under_directory($d, $_[0])) {
4946 return $gconfig{'lockmode'} == 2 ? $match : !$match;
4950 =head2 webmin_log(action, type, object, ¶ms, [module], [host, script-on-host, client-ip])
4952 Log some action taken by a user. This is typically called at the end of a
4953 script, once all file changes are complete and all commands run. The
4956 =item action - A short code for the action being performed, like 'create'.
4958 =item type - A code for the type of object the action is performed to, like 'user'.
4960 =item object - A short name for the object, like 'joe' if the Unix user 'joe' was just created.
4962 =item params - A hash ref of additional information about the action.
4964 =item module - Name of the module in which the action was performed, which defaults to the current module.
4966 =item host - Remote host on which the action was performed. You should never need to set this (or the following two parameters), as they are used only for remote Webmin logging.
4968 =item script-on-host - Script name like create_user.cgi on the host the action was performed on.
4970 =item client-ip - IP address of the browser that performed the action.
4975 return if (!$gconfig{'log'} || &is_readonly_mode());
4976 my $m = $_[4] ? $_[4] : &get_module_name();
4978 if ($gconfig{'logclear'}) {
4979 # check if it is time to clear the log
4980 my @st = stat("$webmin_logfile.time");
4981 my $write_logtime = 0;
4983 if ($st[9]+$gconfig{'logtime'}*60*60 < time()) {
4984 # clear logfile and all diff files
4985 &unlink_file("$ENV{'WEBMIN_VAR'}/diffs");
4986 &unlink_file("$ENV{'WEBMIN_VAR'}/files");
4987 &unlink_file("$ENV{'WEBMIN_VAR'}/annotations");
4988 unlink($webmin_logfile);
4995 if ($write_logtime) {
4996 open(LOGTIME, ">$webmin_logfile.time");
4997 print LOGTIME time(),"\n";
5002 # If an action script directory is defined, call the appropriate scripts
5003 if ($gconfig{'action_script_dir'}) {
5004 my ($action, $type, $object) = ($_[0], $_[1], $_[2]);
5005 my ($basedir) = $gconfig{'action_script_dir'};
5007 for my $dir ($basedir/$type/$action, $basedir/$type, $basedir) {
5010 opendir(DIR, $dir) or die "Can't open $dir: $!";
5011 while (defined($file = readdir(DIR))) {
5012 next if ($file =~ /^\.\.?$/); # skip '.' and '..'
5013 if (-x "$dir/$file") {
5014 # Call a script notifying it of the action
5016 $ENV{'ACTION_MODULE'} = &get_module_name();
5017 $ENV{'ACTION_ACTION'} = $_[0];
5018 $ENV{'ACTION_TYPE'} = $_[1];
5019 $ENV{'ACTION_OBJECT'} = $_[2];
5020 $ENV{'ACTION_SCRIPT'} = $script_name;
5021 foreach my $p (keys %param) {
5022 $ENV{'ACTION_PARAM_'.uc($p)} = $param{$p};
5024 system("$dir/$file", @_,
5025 "<$null_file", ">$null_file", "2>&1");
5033 # should logging be done at all?
5034 return if ($gconfig{'logusers'} && &indexof($base_remote_user,
5035 split(/\s+/, $gconfig{'logusers'})) < 0);
5036 return if ($gconfig{'logmodules'} && &indexof($m,
5037 split(/\s+/, $gconfig{'logmodules'})) < 0);
5041 my @tm = localtime($now);
5042 my $script_name = $0 =~ /([^\/]+)$/ ? $1 : '-';
5043 my $id = sprintf "%d.%d.%d", $now, $$, $main::action_id_count;
5044 $main::action_id_count++;
5045 my $line = sprintf "%s [%2.2d/%s/%4.4d %2.2d:%2.2d:%2.2d] %s %s %s %s %s \"%s\" \"%s\" \"%s\"",
5046 $id, $tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900,
5047 $tm[2], $tm[1], $tm[0],
5048 $remote_user || '-',
5049 $main::session_id || '-',
5050 $_[7] || $ENV{'REMOTE_HOST'} || '-',
5051 $m, $_[5] ? "$_[5]:$_[6]" : $script_name,
5052 $_[0], $_[1] ne '' ? $_[1] : '-', $_[2] ne '' ? $_[2] : '-';
5054 foreach my $k (sort { $a cmp $b } keys %{$_[3]}) {
5055 my $v = $_[3]->{$k};
5061 elsif (ref($v) eq 'ARRAY') {
5065 $vv =~ s/(['"\\\r\n\t\%])/sprintf("%%%2.2X",ord($1))/ge;
5066 $line .= " $k='$vv'";
5070 foreach $vv (split(/\0/, $v)) {
5072 $vv =~ s/(['"\\\r\n\t\%])/sprintf("%%%2.2X",ord($1))/ge;
5073 $line .= " $k='$vv'";
5076 $param{$k} = join(" ", @pv);
5078 open(WEBMINLOG, ">>$webmin_logfile");
5079 print WEBMINLOG $line,"\n";
5081 if ($gconfig{'logperms'}) {
5082 chmod(oct($gconfig{'logperms'}), $webmin_logfile);
5085 chmod(0600, $webmin_logfile);
5088 if ($gconfig{'logfiles'} && !&get_module_variable('$no_log_file_changes')) {
5089 # Find and record the changes made to any locked files, or commands run
5091 mkdir("$ENV{'WEBMIN_VAR'}/diffs", 0700);
5092 foreach my $d (@main::locked_file_diff) {
5093 mkdir("$ENV{'WEBMIN_VAR'}/diffs/$id", 0700);
5094 open(DIFFLOG, ">$ENV{'WEBMIN_VAR'}/diffs/$id/$i");
5095 print DIFFLOG "$d->{'type'} $d->{'object'}\n";
5096 print DIFFLOG $d->{'data'};
5098 if ($d->{'input'}) {
5099 open(DIFFLOG, ">$ENV{'WEBMIN_VAR'}/diffs/$id/$i.input");
5100 print DIFFLOG $d->{'input'};
5103 if ($gconfig{'logperms'}) {
5104 chmod(oct($gconfig{'logperms'}),
5105 "$ENV{'WEBMIN_VAR'}/diffs/$id/$i",
5106 "$ENV{'WEBMIN_VAR'}/diffs/$id/$i.input");
5110 @main::locked_file_diff = undef;
5112 if ($gconfig{'logfullfiles'}) {
5113 # Save the original contents of any modified files
5115 mkdir("$ENV{'WEBMIN_VAR'}/files", 0700);
5116 foreach my $f (keys %main::orig_file_data) {
5117 mkdir("$ENV{'WEBMIN_VAR'}/files/$id", 0700);
5118 open(ORIGLOG, ">$ENV{'WEBMIN_VAR'}/files/$id/$i");
5119 if (!defined($main::orig_file_type{$f})) {
5120 print ORIGLOG -1," ",$f,"\n";
5123 print ORIGLOG $main::orig_file_type{$f}," ",$f,"\n";
5125 print ORIGLOG $main::orig_file_data{$f};
5127 if ($gconfig{'logperms'}) {
5128 chmod(oct($gconfig{'logperms'}),
5129 "$ENV{'WEBMIN_VAR'}/files/$id.$i");
5133 %main::orig_file_data = undef;
5134 %main::orig_file_type = undef;
5138 if ($gconfig{'logsyslog'}) {
5139 eval 'use Sys::Syslog qw(:DEFAULT setlogsock);
5140 openlog(&get_product_name(), "cons,pid,ndelay", "daemon");
5141 setlogsock("inet");';
5143 # Syslog module is installed .. try to convert to a
5144 # human-readable form
5146 my $mod = &get_module_name();
5147 my $mdir = module_root_directory($mod);
5148 if (-r "$mdir/log_parser.pl") {
5149 &foreign_require($mod, "log_parser.pl");
5151 foreach my $k (keys %{$_[3]}) {
5152 my $v = $_[3]->{$k};
5153 if (ref($v) eq 'ARRAY') {
5154 $params{$k} = join("\0", @$v);
5160 $msg = &foreign_call($mod, "parse_webmin_log",
5161 $remote_user, $script_name,
5162 $_[0], $_[1], $_[2], \%params);
5163 $msg =~ s/<[^>]*>//g; # Remove tags
5165 elsif ($_[0] eq "_config_") {
5166 my %wtext = &load_language("webminlog");
5167 $msg = $wtext{'search_config'};
5169 $msg ||= "$_[0] $_[1] $_[2]";
5170 my %info = &get_module_info($m);
5171 eval { syslog("info", "%s", "[$info{'desc'}] $msg"); };
5176 =head2 additional_log(type, object, data, [input])
5178 Records additional log data for an upcoming call to webmin_log, such
5179 as a command that was run or SQL that was executed. Typically you will never
5180 need to call this function directory.
5185 if ($gconfig{'logfiles'} && !&get_module_variable('$no_log_file_changes')) {
5186 push(@main::locked_file_diff,
5187 { 'type' => $_[0], 'object' => $_[1], 'data' => $_[2],
5188 'input' => $_[3] } );
5192 =head2 webmin_debug_log(type, message)
5194 Write something to the Webmin debug log. For internal use only.
5197 sub webmin_debug_log
5199 my ($type, $msg) = @_;
5200 return 0 if (!$main::opened_debug_log);
5201 return 0 if ($gconfig{'debug_no'.$main::webmin_script_type});
5202 if ($gconfig{'debug_modules'}) {
5203 my @dmods = split(/\s+/, $gconfig{'debug_modules'});
5204 return 0 if (&indexof($main::initial_module_name, @dmods) < 0);
5207 my @tm = localtime($now);
5209 "%s [%2.2d/%s/%4.4d %2.2d:%2.2d:%2.2d] %s %s %s %s \"%s\"",
5210 $$, $tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900,
5211 $tm[2], $tm[1], $tm[0],
5212 $remote_user || "-",
5213 $ENV{'REMOTE_HOST'} || "-",
5214 &get_module_name() || "-",
5217 seek(main::DEBUGLOG, 0, 2);
5218 print main::DEBUGLOG $line."\n";
5222 =head2 system_logged(command)
5224 Just calls the Perl system() function, but also logs the command run.
5229 if (&is_readonly_mode()) {
5230 print STDERR "Vetoing command $_[0]\n";
5233 my @realcmd = ( &translate_command($_[0]), @_[1..$#_] );
5234 my $cmd = join(" ", @realcmd);
5236 if ($cmd =~ s/(\s*&\s*)$//) {
5239 while($cmd =~ s/(\d*)(<|>)((\/(tmp|dev)\S+)|&\d+)\s*$//) { }
5240 $cmd =~ s/^\((.*)\)\s*$/$1/;
5242 &additional_log('exec', undef, $cmd);
5243 return system(@realcmd);
5246 =head2 backquote_logged(command)
5248 Executes a command and returns the output (like `command`), but also logs it.
5251 sub backquote_logged
5253 if (&is_readonly_mode()) {
5255 print STDERR "Vetoing command $_[0]\n";
5258 my $realcmd = &translate_command($_[0]);
5261 if ($cmd =~ s/(\s*&\s*)$//) {
5264 while($cmd =~ s/(\d*)(<|>)((\/(tmp\/.webmin|dev)\S+)|&\d+)\s*$//) { }
5265 $cmd =~ s/^\((.*)\)\s*$/$1/;
5267 &additional_log('exec', undef, $cmd);
5268 &webmin_debug_log('CMD', "cmd=$cmd") if ($gconfig{'debug_what_cmd'});
5272 =head2 backquote_with_timeout(command, timeout, safe?, [maxlines])
5274 Runs some command, waiting at most the given number of seconds for it to
5275 complete, and returns the output. The maxlines parameter sets the number
5276 of lines of output to capture. The safe parameter should be set to 1 if the
5277 command is safe for read-only mode users to run.
5280 sub backquote_with_timeout
5282 my $realcmd = &translate_command($_[0]);
5283 &webmin_debug_log('CMD', "cmd=$realcmd timeout=$_[1]")
5284 if ($gconfig{'debug_what_cmd'});
5286 my $pid = &open_execute_command(OUT, "($realcmd) <$null_file", 1, $_[2]);
5291 my $elapsed = time() - $start;
5292 last if ($elapsed > $_[1]);
5294 vec($rmask, fileno(OUT), 1) = 1;
5295 my $sel = select($rmask, undef, undef, $_[1] - $elapsed);
5296 last if (!$sel || $sel < 0);
5298 last if (!defined($line));
5301 if ($_[3] && $linecount >= $_[3]) {
5306 if (kill('TERM', $pid) && time() - $start >= $_[1]) {
5310 return wantarray ? ($out, $timed_out) : $out;
5313 =head2 backquote_command(command, safe?)
5315 Executes a command and returns the output (like `command`), subject to
5316 command translation. The safe parameter should be set to 1 if the command
5317 is safe for read-only mode users to run.
5320 sub backquote_command
5322 if (&is_readonly_mode() && !$_[1]) {
5323 print STDERR "Vetoing command $_[0]\n";
5327 my $realcmd = &translate_command($_[0]);
5328 &webmin_debug_log('CMD', "cmd=$realcmd") if ($gconfig{'debug_what_cmd'});
5332 =head2 kill_logged(signal, pid, ...)
5334 Like Perl's built-in kill function, but also logs the fact that some process
5335 was killed. On Windows, falls back to calling process.exe to terminate a
5341 return scalar(@_)-1 if (&is_readonly_mode());
5342 &webmin_debug_log('KILL', "signal=$_[0] pids=".join(" ", @_[1..@_-1]))
5343 if ($gconfig{'debug_what_procs'});
5344 &additional_log('kill', $_[0], join(" ", @_[1..@_-1])) if (@_ > 1);
5345 if ($gconfig{'os_type'} eq 'windows') {
5346 # Emulate some kills with process.exe
5347 my $arg = $_[0] eq "KILL" ? "-k" :
5348 $_[0] eq "TERM" ? "-q" :
5349 $_[0] eq "STOP" ? "-s" :
5350 $_[0] eq "CONT" ? "-r" : undef;
5352 foreach my $p (@_[1..@_-1]) {
5354 $ok ||= kill($_[0], $p);
5357 &execute_command("process $arg $p");
5369 =head2 rename_logged(old, new)
5371 Re-names a file and logs the rename. If the old and new files are on different
5372 filesystems, calls mv or the Windows rename function to do the job.
5377 &additional_log('rename', $_[0], $_[1]) if ($_[0] ne $_[1]);
5378 return &rename_file($_[0], $_[1]);
5381 =head2 rename_file(old, new)
5383 Renames a file or directory. If the old and new files are on different
5384 filesystems, calls mv or the Windows rename function to do the job.
5389 if (&is_readonly_mode()) {
5390 print STDERR "Vetoing rename from $_[0] to $_[1]\n";
5393 my $src = &translate_filename($_[0]);
5394 my $dst = &translate_filename($_[1]);
5395 &webmin_debug_log('RENAME', "src=$src dst=$dst")
5396 if ($gconfig{'debug_what_ops'});
5397 my $ok = rename($src, $dst);
5398 if (!$ok && $! !~ /permission/i) {
5399 # Try the mv command, in case this is a cross-filesystem rename
5400 if ($gconfig{'os_type'} eq 'windows') {
5401 # Need to use rename
5402 my $out = &backquote_command("rename ".quotemeta($_[0]).
5403 " ".quotemeta($_[1])." 2>&1");
5405 $! = $out if (!$ok);
5409 my $out = &backquote_command("mv ".quotemeta($_[0]).
5410 " ".quotemeta($_[1])." 2>&1");
5412 $! = $out if (!$ok);
5418 =head2 symlink_logged(src, dest)
5420 Create a symlink, and logs it. Effectively does the same thing as the Perl
5427 my $rv = &symlink_file($_[0], $_[1]);
5428 &unlock_file($_[1]);
5432 =head2 symlink_file(src, dest)
5434 Creates a soft link, unless in read-only mode. Effectively does the same thing
5435 as the Perl symlink function.
5440 if (&is_readonly_mode()) {
5441 print STDERR "Vetoing symlink from $_[0] to $_[1]\n";
5444 my $src = &translate_filename($_[0]);
5445 my $dst = &translate_filename($_[1]);
5446 &webmin_debug_log('SYMLINK', "src=$src dst=$dst")
5447 if ($gconfig{'debug_what_ops'});
5448 return symlink($src, $dst);
5451 =head2 link_file(src, dest)
5453 Creates a hard link, unless in read-only mode. The existing new link file
5454 will be deleted if necessary. Effectively the same as Perl's link function.
5459 if (&is_readonly_mode()) {
5460 print STDERR "Vetoing link from $_[0] to $_[1]\n";
5463 my $src = &translate_filename($_[0]);
5464 my $dst = &translate_filename($_[1]);
5465 &webmin_debug_log('LINK', "src=$src dst=$dst")
5466 if ($gconfig{'debug_what_ops'});
5467 unlink($dst); # make sure link works
5468 return link($src, $dst);
5471 =head2 make_dir(dir, perms, recursive)
5473 Creates a directory and sets permissions on it, unless in read-only mode.
5474 The perms parameter sets the octal permissions to apply, which unlike Perl's
5475 mkdir will really get set. The recursive flag can be set to 1 to have the
5476 function create parent directories too.
5481 my ($dir, $perms, $recur) = @_;
5482 if (&is_readonly_mode()) {
5483 print STDERR "Vetoing directory $dir\n";
5486 $dir = &translate_filename($dir);
5487 my $exists = -d $dir ? 1 : 0;
5488 return 1 if ($exists && $recur); # already exists
5489 &webmin_debug_log('MKDIR', $dir) if ($gconfig{'debug_what_ops'});
5490 my $rv = mkdir($dir, $perms);
5491 if (!$rv && $recur) {
5492 # Failed .. try mkdir -p
5493 my $param = $gconfig{'os_type'} eq 'windows' ? "" : "-p";
5494 my $ex = &execute_command("mkdir $param "."e_path($dir));
5500 chmod($perms, $dir);
5505 =head2 set_ownership_permissions(user, group, perms, file, ...)
5507 Sets the user, group owner and permissions on some files. The parameters are :
5509 =item user - UID or username to change the file owner to. If undef, then the owner is not changed.
5511 =item group - GID or group name to change the file group to. If undef, then the group is set to the user's primary group.
5513 =item perms - Octal permissions set to set on the file. If undef, they are left alone.
5515 =item file - One or more files or directories to modify.
5518 sub set_ownership_permissions
5520 my ($user, $group, $perms, @files) = @_;
5521 if (&is_readonly_mode()) {
5522 print STDERR "Vetoing permission changes on ",join(" ", @files),"\n";
5525 @files = map { &translate_filename($_) } @files;
5526 if ($gconfig{'debug_what_ops'}) {
5527 foreach my $f (@files) {
5528 &webmin_debug_log('PERMS',
5529 "file=$f user=$user group=$group perms=$perms");
5533 if (defined($user)) {
5534 my $uid = $user !~ /^\d+$/ ? getpwnam($user) : $user;
5536 if (defined($group)) {
5537 $gid = $group !~ /^\d+$/ ? getgrnam($group) : $group;
5540 my @uinfo = getpwuid($uid);
5543 $rv = chown($uid, $gid, @files);
5545 if ($rv && defined($perms)) {
5546 $rv = chmod($perms, @files);
5551 =head2 unlink_logged(file, ...)
5553 Like Perl's unlink function, but locks the files beforehand and un-locks them
5554 after so that the deletion is logged by Webmin.
5560 foreach my $f (@_) {
5561 if (!&test_lock($f)) {
5566 my @rv = &unlink_file(@_);
5567 foreach my $f (@_) {
5572 return wantarray ? @rv : $rv[0];
5575 =head2 unlink_file(file, ...)
5577 Deletes some files or directories. Like Perl's unlink function, but also
5578 recursively deletes directories with the rm command if needed.
5583 return 1 if (&is_readonly_mode());
5586 foreach my $f (@_) {
5587 &unflush_file_lines($f);
5588 my $realf = &translate_filename($f);
5589 &webmin_debug_log('UNLINK', $realf) if ($gconfig{'debug_what_ops'});
5591 if (!rmdir($realf)) {
5593 if ($gconfig{'os_type'} eq 'windows') {
5594 # Call del and rmdir commands
5597 my $out = `del /q "$qm" 2>&1`;
5599 $out = `rmdir "$qm" 2>&1`;
5604 my $qm = quotemeta($realf);
5605 $out = `rm -rf $qm 2>&1`;
5614 if (!unlink($realf)) {
5620 return wantarray ? ($rv, $err) : $rv;
5623 =head2 copy_source_dest(source, dest)
5625 Copy some file or directory to a new location. Returns 1 on success, or 0
5626 on failure - also sets $! on failure. If the source is a directory, uses
5627 piped tar commands to copy a whole directory structure including permissions
5631 sub copy_source_dest
5633 return (1, undef) if (&is_readonly_mode());
5634 my ($src, $dst) = @_;
5637 &webmin_debug_log('COPY', "src=$src dst=$dst")
5638 if ($gconfig{'debug_what_ops'});
5639 if ($gconfig{'os_type'} eq 'windows') {
5640 # No tar or cp on windows, so need to use copy command
5644 $out = &backquote_logged("xcopy \"$src\" \"$dst\" /Y /E /I 2>&1");
5647 $out = &backquote_logged("copy /Y \"$src\" \"$dst\" 2>&1");
5655 # A directory .. need to copy with tar command
5656 my @st = stat($src);
5659 &set_ownership_permissions($st[4], $st[5], $st[2], $dst);
5660 $out = &backquote_logged("(cd ".quotemeta($src)." ; tar cf - . | (cd ".quotemeta($dst)." ; tar xf -)) 2>&1");
5667 # Can just copy with cp
5668 my $out = &backquote_logged("cp -p ".quotemeta($src).
5669 " ".quotemeta($dst)." 2>&1");
5675 return wantarray ? ($ok, $err) : $ok;
5678 =head2 remote_session_name(host|&server)
5680 Generates a session ID for some server. For this server, this will always
5681 be an empty string. For a server object it will include the hostname and
5682 port and PID. For a server name, it will include the hostname and PID. For
5686 sub remote_session_name
5688 return ref($_[0]) && $_[0]->{'host'} && $_[0]->{'port'} ?
5689 "$_[0]->{'host'}:$_[0]->{'port'}.$$" :
5690 $_[0] eq "" || ref($_[0]) && $_[0]->{'id'} == 0 ? "" :
5691 ref($_[0]) ? "" : "$_[0].$$";
5694 =head2 remote_foreign_require(server, module, file)
5696 Connects to rpc.cgi on a remote webmin server and have it open a session
5697 to a process that will actually do the require and run functions. This is the
5698 equivalent for foreign_require, but for a remote Webmin system. The server
5699 parameter can either be a hostname of a system registered in the Webmin
5700 Servers Index module, or a hash reference for a system from that module.
5703 sub remote_foreign_require
5705 my $call = { 'action' => 'require',
5708 my $sn = &remote_session_name($_[0]);
5709 if ($remote_session{$sn}) {
5710 $call->{'session'} = $remote_session{$sn};
5713 $call->{'newsession'} = 1;
5715 my $rv = &remote_rpc_call($_[0], $call);
5716 if ($rv->{'session'}) {
5717 $remote_session{$sn} = $rv->{'session'};
5718 $remote_session_server{$sn} = $_[0];
5722 =head2 remote_foreign_call(server, module, function, [arg]*)
5724 Call a function on a remote server. Must have been setup first with
5725 remote_foreign_require for the same server and module. Equivalent to
5726 foreign_call, but with the extra server parameter to specify the remote
5730 sub remote_foreign_call
5732 return undef if (&is_readonly_mode());
5733 my $sn = &remote_session_name($_[0]);
5734 return &remote_rpc_call($_[0], { 'action' => 'call',
5737 'session' => $remote_session{$sn},
5738 'args' => [ @_[3 .. $#_] ] } );
5741 =head2 remote_foreign_check(server, module, [api-only])
5743 Checks if some module is installed and supported on a remote server. Equivilant
5744 to foreign_check, but for the remote Webmin system specified by the server
5748 sub remote_foreign_check
5750 return &remote_rpc_call($_[0], { 'action' => 'check',
5755 =head2 remote_foreign_config(server, module)
5757 Gets the configuration for some module from a remote server, as a hash.
5758 Equivalent to foreign_config, but for a remote system.
5761 sub remote_foreign_config
5763 return &remote_rpc_call($_[0], { 'action' => 'config',
5764 'module' => $_[1] });
5767 =head2 remote_eval(server, module, code)
5769 Evaluates some perl code in the context of a module on a remote webmin server.
5770 The server parameter must be the hostname of a remote system, module must
5771 be a module directory name, and code a string of Perl code to run. This can
5772 only be called after remote_foreign_require for the same server and module.
5777 return undef if (&is_readonly_mode());
5778 my $sn = &remote_session_name($_[0]);
5779 return &remote_rpc_call($_[0], { 'action' => 'eval',
5782 'session' => $remote_session{$sn} });
5785 =head2 remote_write(server, localfile, [remotefile], [remotebasename])
5787 Transfers some local file to another server via Webmin's RPC protocol, and
5788 returns the resulting remote filename. If the remotefile parameter is given,
5789 that is the destination filename which will be used. Otherwise a randomly
5790 selected temporary filename will be used, and returned by the function.
5795 return undef if (&is_readonly_mode());
5797 my $sn = &remote_session_name($_[0]);
5798 if (!$_[0] || $remote_server_version{$sn} >= 0.966) {
5799 # Copy data over TCP connection
5800 my $rv = &remote_rpc_call($_[0], { 'action' => 'tcpwrite',
5802 'name' => $_[3] } );
5804 my $serv = ref($_[0]) ? $_[0]->{'host'} : $_[0];
5805 &open_socket($serv || "localhost", $rv->[1], TWRITE, \$error);
5806 return &$main::remote_error_handler("Failed to transfer file : $error")
5809 while(read(FILE, $got, 1024) > 0) {
5813 shutdown(TWRITE, 1);
5815 if ($error && $error !~ /^OK/) {
5816 # Got back an error!
5817 return &$main::remote_error_handler("Failed to transfer file : $error");
5823 # Just pass file contents as parameters
5825 while(read(FILE, $got, 1024) > 0) {
5829 return &remote_rpc_call($_[0], { 'action' => 'write',
5832 'session' => $remote_session{$sn} });
5836 =head2 remote_read(server, localfile, remotefile)
5838 Transfers a file from a remote server to this system, using Webmin's RPC
5839 protocol. The server parameter must be the hostname of a system registered
5840 in the Webmin Servers Index module, localfile is the destination path on this
5841 system, and remotefile is the file to fetch from the remote server.
5846 my $sn = &remote_session_name($_[0]);
5847 if (!$_[0] || $remote_server_version{$sn} >= 0.966) {
5848 # Copy data over TCP connection
5849 my $rv = &remote_rpc_call($_[0], { 'action' => 'tcpread',
5850 'file' => $_[2] } );
5852 return &$main::remote_error_handler("Failed to transfer file : $rv->[1]");
5855 my $serv = ref($_[0]) ? $_[0]->{'host'} : $_[0];
5856 &open_socket($serv || "localhost", $rv->[1], TREAD, \$error);
5857 return &$main::remote_error_handler("Failed to transfer file : $error")
5860 open(FILE, ">$_[1]");
5861 while(read(TREAD, $got, 1024) > 0) {
5868 # Just get data as return value
5869 my $d = &remote_rpc_call($_[0], { 'action' => 'read',
5871 'session' => $remote_session{$sn} });
5872 open(FILE, ">$_[1]");
5878 =head2 remote_finished
5880 Close all remote sessions. This happens automatically after a while
5881 anyway, but this function should be called to clean things up faster.
5886 foreach my $sn (keys %remote_session) {
5887 my $server = $remote_session_server{$sn};
5888 &remote_rpc_call($server, { 'action' => 'quit',
5889 'session' => $remote_session{$sn} } );
5890 delete($remote_session{$sn});
5891 delete($remote_session_server{$sn});
5893 foreach $fh (keys %fast_fh_cache) {
5895 delete($fast_fh_cache{$fh});
5899 =head2 remote_error_setup(&function)
5901 Sets a function to be called instead of &error when a remote RPC operation
5902 fails. Useful if you want to have more control over your remote operations.
5905 sub remote_error_setup
5907 $main::remote_error_handler = $_[0] || \&error;
5910 =head2 remote_rpc_call(server, structure)
5912 Calls rpc.cgi on some server and passes it a perl structure (hash,array,etc)
5913 and then reads back a reply structure. This is mainly for internal use only,
5914 and is called by the other remote_* functions.
5920 my $sn = &remote_session_name($_[0]); # Will be undef for local connection
5922 # Server structure was given
5924 $serv->{'user'} || $serv->{'id'} == 0 ||
5925 return &$main::remote_error_handler(
5926 "No Webmin login set for server");
5929 # lookup the server in the webmin servers module if needed
5930 if (!%main::remote_servers_cache) {
5931 &foreign_require("servers", "servers-lib.pl");
5932 foreach $s (&foreign_call("servers", "list_servers")) {
5933 $main::remote_servers_cache{$s->{'host'}} = $s;
5934 $main::remote_servers_cache{$s->{'host'}.":".$s->{'port'}} = $s;
5937 $serv = $main::remote_servers_cache{$_[0]};
5938 $serv || return &$main::remote_error_handler(
5939 "No Webmin Servers entry for $_[0]");
5940 $serv->{'user'} || return &$main::remote_error_handler(
5941 "No login set for server $_[0]");
5943 my $ip = $serv->{'ip'} || $serv->{'host'};
5945 # Work out the username and password
5947 if ($serv->{'sameuser'}) {
5948 $user = $remote_user;
5949 defined($main::remote_pass) || return &$main::remote_error_handler(
5950 "Password for this server is not available");
5951 $pass = $main::remote_pass;
5954 $user = $serv->{'user'};
5955 $pass = $serv->{'pass'};
5958 if ($serv->{'fast'} || !$sn) {
5959 # Make TCP connection call to fastrpc.cgi
5960 if (!$fast_fh_cache{$sn} && $sn) {
5961 # Need to open the connection
5962 my $con = &make_http_connection(
5963 $ip, $serv->{'port'}, $serv->{'ssl'},
5964 "POST", "/fastrpc.cgi");
5965 return &$main::remote_error_handler(
5966 "Failed to connect to $serv->{'host'} : $con")
5968 &write_http_connection($con, "Host: $serv->{'host'}\r\n");
5969 &write_http_connection($con, "User-agent: Webmin\r\n");
5970 my $auth = &encode_base64("$user:$pass");
5972 &write_http_connection($con, "Authorization: basic $auth\r\n");
5973 &write_http_connection($con, "Content-length: ",
5974 length($tostr),"\r\n");
5975 &write_http_connection($con, "\r\n");
5976 &write_http_connection($con, $tostr);
5978 # read back the response
5979 my $line = &read_http_connection($con);
5980 $line =~ tr/\r\n//d;
5981 if ($line =~ /^HTTP\/1\..\s+401\s+/) {
5982 return &$main::remote_error_handler("Login to RPC server as $user rejected");
5984 $line =~ /^HTTP\/1\..\s+200\s+/ ||
5985 return &$main::remote_error_handler("HTTP error : $line");
5987 $line = &read_http_connection($con);
5988 $line =~ tr/\r\n//d;
5990 $line = &read_http_connection($con);
5991 if ($line =~ /^0\s+(.*)/) {
5992 return &$main::remote_error_handler("RPC error : $1");
5994 elsif ($line =~ /^1\s+(\S+)\s+(\S+)\s+(\S+)/ ||
5995 $line =~ /^1\s+(\S+)\s+(\S+)/) {
5996 # Started ok .. connect and save SID
5997 &close_http_connection($con);
5998 my ($port, $sid, $version, $error) = ($1, $2, $3);
5999 &open_socket($ip, $port, $sid, \$error);
6000 return &$main::remote_error_handler("Failed to connect to fastrpc.cgi : $error")
6002 $fast_fh_cache{$sn} = $sid;
6003 $remote_server_version{$sn} = $version;
6006 while($stuff = &read_http_connection($con)) {
6009 return &$main::remote_error_handler("Bad response from fastrpc.cgi : $line");
6012 elsif (!$fast_fh_cache{$sn}) {
6013 # Open the connection by running fastrpc.cgi locally
6014 pipe(RPCOUTr, RPCOUTw);
6018 open(STDOUT, ">&RPCOUTw");
6022 $ENV{'REQUEST_METHOD'} = 'GET';
6023 $ENV{'SCRIPT_NAME'} = '/fastrpc.cgi';
6024 $ENV{'SERVER_ROOT'} ||= $root_directory;
6026 if ($base_remote_user ne 'root' &&
6027 $base_remote_user ne 'admin') {
6028 # Need to fake up a login for the CGI!
6029 &read_acl(undef, \%acl, [ 'root' ]);
6030 $ENV{'BASE_REMOTE_USER'} =
6031 $ENV{'REMOTE_USER'} =
6032 $acl{'root'} ? 'root' : 'admin';
6034 delete($ENV{'FOREIGN_MODULE_NAME'});
6035 delete($ENV{'FOREIGN_ROOT_DIRECTORY'});
6036 chdir($root_directory);
6037 if (!exec("$root_directory/fastrpc.cgi")) {
6038 print "exec failed : $!\n";
6045 ($line = <RPCOUTr>) =~ tr/\r\n//d;
6049 if ($line =~ /^0\s+(.*)/) {
6050 return &$main::remote_error_handler("RPC error : $2");
6052 elsif ($line =~ /^1\s+(\S+)\s+(\S+)/) {
6053 # Started ok .. connect and save SID
6055 my ($port, $sid, $error) = ($1, $2, undef);
6056 &open_socket("localhost", $port, $sid, \$error);
6057 return &$main::remote_error_handler("Failed to connect to fastrpc.cgi : $error") if ($error);
6058 $fast_fh_cache{$sn} = $sid;
6065 &error("Bad response from fastrpc.cgi : $line");
6068 # Got a connection .. send off the request
6069 my $fh = $fast_fh_cache{$sn};
6070 my $tostr = &serialise_variable($_[1]);
6071 print $fh length($tostr)," $fh\n";
6073 my $rlen = int(<$fh>);
6074 my ($fromstr, $got);
6075 while(length($fromstr) < $rlen) {
6076 return &$main::remote_error_handler("Failed to read from fastrpc.cgi")
6077 if (read($fh, $got, $rlen - length($fromstr)) <= 0);
6080 my $from = &unserialise_variable($fromstr);
6082 return &$main::remote_error_handler("Remote Webmin error");
6084 if (defined($from->{'arv'})) {
6085 return @{$from->{'arv'}};
6088 return $from->{'rv'};
6092 # Call rpc.cgi on remote server
6093 my $tostr = &serialise_variable($_[1]);
6095 my $con = &make_http_connection($ip, $serv->{'port'},
6096 $serv->{'ssl'}, "POST", "/rpc.cgi");
6097 return &$main::remote_error_handler("Failed to connect to $serv->{'host'} : $con") if (!ref($con));
6099 &write_http_connection($con, "Host: $serv->{'host'}\r\n");
6100 &write_http_connection($con, "User-agent: Webmin\r\n");
6101 my $auth = &encode_base64("$user:$pass");
6103 &write_http_connection($con, "Authorization: basic $auth\r\n");
6104 &write_http_connection($con, "Content-length: ",length($tostr),"\r\n");
6105 &write_http_connection($con, "\r\n");
6106 &write_http_connection($con, $tostr);
6108 # read back the response
6109 my $line = &read_http_connection($con);
6110 $line =~ tr/\r\n//d;
6111 if ($line =~ /^HTTP\/1\..\s+401\s+/) {
6112 return &$main::remote_error_handler("Login to RPC server as $user rejected");
6114 $line =~ /^HTTP\/1\..\s+200\s+/ || return &$main::remote_error_handler("RPC HTTP error : $line");
6116 $line = &read_http_connection($con);
6117 $line =~ tr/\r\n//d;
6120 while($line = &read_http_connection($con)) {
6124 my $from = &unserialise_variable($fromstr);
6125 return &$main::remote_error_handler("Invalid RPC login to $serv->{'host'}") if (!$from->{'status'});
6126 if (defined($from->{'arv'})) {
6127 return @{$from->{'arv'}};
6130 return $from->{'rv'};
6135 =head2 remote_multi_callback(&servers, parallel, &function, arg|&args, &returns, &errors, [module, library])
6137 Executes some function in parallel on multiple servers at once. Fills in
6138 the returns and errors arrays respectively. If the module and library
6139 parameters are given, that module is remotely required on the server first,
6140 to check if it is connectable. The parameters are :
6142 =item servers - A list of Webmin system hash references.
6144 =item parallel - Number of parallel operations to perform.
6146 =item function - Reference to function to call for each system.
6148 =item args - Additional parameters to the function.
6150 =item returns - Array ref to place return values into, in same order as servers.
6152 =item errors - Array ref to place error messages into.
6154 =item module - Optional module to require on the remote system first.
6156 =item library - Optional library to require in the module.
6159 sub remote_multi_callback
6161 my ($servs, $parallel, $func, $args, $rets, $errs, $mod, $lib) = @_;
6162 &remote_error_setup(\&remote_multi_callback_error);
6164 # Call the functions
6166 foreach my $g (@$servs) {
6172 $remote_multi_callback_err = undef;
6174 # Require the remote lib
6175 &remote_foreign_require($g->{'host'}, $mod, $lib);
6176 if ($remote_multi_callback_err) {
6177 # Failed .. return error
6178 print $wh &serialise_variable(
6179 [ undef, $remote_multi_callback_err ]);
6185 my $a = ref($args) ? $args->[$p] : $args;
6186 my $rv = &$func($g, $a);
6189 print $wh &serialise_variable(
6190 [ $rv, $remote_multi_callback_err ]);
6198 # Read back the results
6200 foreach my $g (@$servs) {
6204 $errs->[$p] = "Failed to read response from $g->{'host'}";
6207 my $rv = &unserialise_variable($line);
6209 $rets->[$p] = $rv->[0];
6210 $errs->[$p] = $rv->[1];
6215 &remote_error_setup(undef);
6218 sub remote_multi_callback_error
6220 $remote_multi_callback_err = $_[0];
6223 =head2 serialise_variable(variable)
6225 Converts some variable (maybe a scalar, hash ref, array ref or scalar ref)
6226 into a url-encoded string. In the cases of arrays and hashes, it is recursively
6227 called on each member to serialize the entire object.
6230 sub serialise_variable
6232 if (!defined($_[0])) {
6238 $rv = &urlize($_[0]);
6240 elsif ($r eq 'SCALAR') {
6241 $rv = &urlize(${$_[0]});
6243 elsif ($r eq 'ARRAY') {
6244 $rv = join(",", map { &urlize(&serialise_variable($_)) } @{$_[0]});
6246 elsif ($r eq 'HASH') {
6247 $rv = join(",", map { &urlize(&serialise_variable($_)).",".
6248 &urlize(&serialise_variable($_[0]->{$_})) }
6251 elsif ($r eq 'REF') {
6252 $rv = &serialise_variable(${$_[0]});
6254 elsif ($r eq 'CODE') {
6259 # An object - treat as a hash
6260 $r = "OBJECT ".&urlize($r);
6261 $rv = join(",", map { &urlize(&serialise_variable($_)).",".
6262 &urlize(&serialise_variable($_[0]->{$_})) }
6265 return ($r ? $r : 'VAL').",".$rv;
6268 =head2 unserialise_variable(string)
6270 Converts a string created by serialise_variable() back into the original
6271 scalar, hash ref, array ref or scalar ref. If the original variable was a Perl
6272 object, the same class is used on this system, if available.
6275 sub unserialise_variable
6277 my @v = split(/,/, $_[0]);
6279 if ($v[0] eq 'VAL') {
6280 @v = split(/,/, $_[0], -1);
6281 $rv = &un_urlize($v[1]);
6283 elsif ($v[0] eq 'SCALAR') {
6284 local $r = &un_urlize($v[1]);
6287 elsif ($v[0] eq 'ARRAY') {
6289 for(my $i=1; $i<@v; $i++) {
6290 push(@$rv, &unserialise_variable(&un_urlize($v[$i])));
6293 elsif ($v[0] eq 'HASH') {
6295 for(my $i=1; $i<@v; $i+=2) {
6296 $rv->{&unserialise_variable(&un_urlize($v[$i]))} =
6297 &unserialise_variable(&un_urlize($v[$i+1]));
6300 elsif ($v[0] eq 'REF') {
6301 local $r = &unserialise_variable($v[1]);
6304 elsif ($v[0] eq 'UNDEF') {
6307 elsif ($v[0] =~ /^OBJECT\s+(.*)$/) {
6308 # An object hash that we have to re-bless
6311 for(my $i=1; $i<@v; $i+=2) {
6312 $rv->{&unserialise_variable(&un_urlize($v[$i]))} =
6313 &unserialise_variable(&un_urlize($v[$i+1]));
6321 =head2 other_groups(user)
6323 Returns a list of secondary groups a user is a member of, as a list of
6332 while(my @g = getgrent()) {
6333 my @m = split(/\s+/, $g[3]);
6334 push(@rv, $g[2]) if (&indexof($user, @m) >= 0);
6336 endgrent() if ($gconfig{'os_type'} ne 'hpux');
6340 =head2 date_chooser_button(dayfield, monthfield, yearfield)
6342 Returns HTML for a button that pops up a data chooser window. The parameters
6345 =item dayfield - Name of the text field to place the day of the month into.
6347 =item monthfield - Name of the select field to select the month of the year in, indexed from 1.
6349 =item yearfield - Name of the text field to place the year into.
6352 sub date_chooser_button
6354 return &theme_date_chooser_button(@_)
6355 if (defined(&theme_date_chooser_button));
6356 my ($w, $h) = (250, 225);
6357 if ($gconfig{'db_sizedate'}) {
6358 ($w, $h) = split(/x/, $gconfig{'db_sizedate'});
6360 return "<input type=button onClick='window.dfield = form.$_[0]; window.mfield = form.$_[1]; window.yfield = form.$_[2]; window.open(\"$gconfig{'webprefix'}/date_chooser.cgi?day=\"+escape(dfield.value)+\"&month=\"+escape(mfield.selectedIndex)+\"&year=\"+yfield.value, \"chooser\", \"toolbar=no,menubar=no,scrollbars=yes,width=$w,height=$h\")' value=\"...\">\n";
6363 =head2 help_file(module, file)
6365 Returns the path to a module's help file of some name, typically under the
6366 help directory with a .html extension.
6371 my $mdir = &module_root_directory($_[0]);
6372 my $dir = "$mdir/help";
6373 foreach my $o (@lang_order_list) {
6374 my $lang = "$dir/$_[1].$o.html";
6375 return $lang if (-r $lang);
6377 return "$dir/$_[1].html";
6382 Seeds the random number generator, if not already done in this script. On Linux
6383 this makes use of the current time, process ID and a read from /dev/urandom.
6384 On other systems, only the current time and process ID are used.
6389 if (!$main::done_seed_random) {
6390 if (open(RANDOM, "/dev/urandom")) {
6392 read(RANDOM, $buf, 4);
6394 srand(time() ^ $$ ^ $buf);
6399 $main::done_seed_random = 1;
6403 =head2 disk_usage_kb(directory)
6405 Returns the number of kB used by some directory and all subdirs. Implemented
6406 by calling the C<du -k> command.
6411 my $dir = &translate_filename($_[0]);
6413 my $ex = &execute_command("du -sk ".quotemeta($dir), undef, \$out, undef, 0, 1);
6415 &execute_command("du -s ".quotemeta($dir), undef, \$out, undef, 0, 1);
6417 return $out =~ /^([0-9]+)/ ? $1 : "???";
6420 =head2 recursive_disk_usage(directory, [skip-regexp], [only-regexp])
6422 Returns the number of bytes taken up by all files in some directory and all
6423 sub-directories, by summing up their lengths. The disk_usage_kb is more
6424 reflective of reality, as the filesystem typically pads file sizes to 1k or
6428 sub recursive_disk_usage
6430 my $dir = &translate_filename($_[0]);
6437 my @st = stat($dir);
6443 my @files = readdir(DIR);
6445 foreach my $f (@files) {
6446 next if ($f eq "." || $f eq "..");
6447 next if ($skip && $f =~ /$skip/);
6448 next if ($only && $f !~ /$only/);
6449 $rv += &recursive_disk_usage("$dir/$f", $skip, $only);
6455 =head2 help_search_link(term, [ section, ... ] )
6457 Returns HTML for a link to the man module for searching local and online
6458 docs for various search terms. The term parameter can either be a single
6459 word like 'bind', or a space-separated list of words. This function is typically
6460 used by modules that want to refer users to additional documentation in man
6461 pages or local system doc files.
6464 sub help_search_link
6466 if (&foreign_available("man") && !$tconfig{'nosearch'}) {
6467 my $for = &urlize(shift(@_));
6468 return "<a href='$gconfig{'webprefix'}/man/search.cgi?".
6469 join("&", map { "section=$_" } @_)."&".
6470 "for=$for&exact=1&check=".&get_module_name()."'>".
6471 $text{'helpsearch'}."</a>\n";
6478 =head2 make_http_connection(host, port, ssl, method, page, [&headers])
6480 Opens a connection to some HTTP server, maybe through a proxy, and returns
6481 a handle object. The handle can then be used to send additional headers
6482 and read back a response. If anything goes wrong, returns an error string.
6483 The parameters are :
6485 =item host - Hostname or IP address of the webserver to connect to.
6487 =item port - HTTP port number to connect to.
6489 =item ssl - Set to 1 to connect in SSL mode.
6491 =item method - HTTP method, like GET or POST.
6493 =item page - Page to request on the webserver, like /foo/index.html
6495 =item headers - Array ref of additional HTTP headers, each of which is a 2-element array ref.
6498 sub make_http_connection
6500 my ($host, $port, $ssl, $method, $page, $headers) = @_;
6503 foreach my $h (@$headers) {
6504 $htxt .= $h->[0].": ".$h->[1]."\r\n";
6508 if (&is_readonly_mode()) {
6509 return "HTTP connections not allowed in readonly mode";
6511 my $rv = { 'fh' => time().$$ };
6514 eval "use Net::SSLeay";
6515 $@ && return $text{'link_essl'};
6516 eval "Net::SSLeay::SSLeay_add_ssl_algorithms()";
6517 eval "Net::SSLeay::load_error_strings()";
6518 $rv->{'ssl_ctx'} = Net::SSLeay::CTX_new() ||
6519 return "Failed to create SSL context";
6520 $rv->{'ssl_con'} = Net::SSLeay::new($rv->{'ssl_ctx'}) ||
6521 return "Failed to create SSL connection";
6523 if ($gconfig{'http_proxy'} =~ /^http:\/\/(\S+):(\d+)/ &&
6524 !&no_proxy($host)) {
6527 &open_socket($1, $2, $rv->{'fh'}, \$error);
6530 my $fh = $rv->{'fh'};
6531 print $fh "CONNECT $host:$port HTTP/1.0\r\n";
6532 if ($gconfig{'proxy_user'}) {
6533 my $auth = &encode_base64(
6534 "$gconfig{'proxy_user'}:".
6535 "$gconfig{'proxy_pass'}");
6536 $auth =~ tr/\r\n//d;
6537 print $fh "Proxy-Authorization: Basic $auth\r\n";
6541 if ($line =~ /^HTTP(\S+)\s+(\d+)\s+(.*)/) {
6542 return "Proxy error : $3" if ($2 != 200);
6545 return "Proxy error : $line";
6550 elsif (!$gconfig{'proxy_fallback'}) {
6551 # Connection to proxy failed - give up
6558 &open_socket($host, $port, $rv->{'fh'}, \$error);
6559 return $error if ($error);
6561 Net::SSLeay::set_fd($rv->{'ssl_con'}, fileno($rv->{'fh'}));
6562 Net::SSLeay::connect($rv->{'ssl_con'}) ||
6563 return "SSL connect() failed";
6564 my $rtxt = "$method $page HTTP/1.0\r\n".$htxt;
6565 Net::SSLeay::write($rv->{'ssl_con'}, $rtxt);
6568 # Plain HTTP request
6570 if ($gconfig{'http_proxy'} =~ /^http:\/\/(\S+):(\d+)/ &&
6571 !&no_proxy($host)) {
6574 &open_socket($1, $2, $rv->{'fh'}, \$error);
6578 my $fh = $rv->{'fh'};
6579 my $rtxt = $method." ".
6580 "http://$host:$port$page HTTP/1.0\r\n";
6581 if ($gconfig{'proxy_user'}) {
6582 my $auth = &encode_base64(
6583 "$gconfig{'proxy_user'}:".
6584 "$gconfig{'proxy_pass'}");
6585 $auth =~ tr/\r\n//d;
6586 $rtxt .= "Proxy-Authorization: Basic $auth\r\n";
6591 elsif (!$gconfig{'proxy_fallback'}) {
6596 # Connecting directly
6598 &open_socket($host, $port, $rv->{'fh'}, \$error);
6599 return $error if ($error);
6600 my $fh = $rv->{'fh'};
6601 my $rtxt = "$method $page HTTP/1.0\r\n".$htxt;
6608 =head2 read_http_connection(&handle, [bytes])
6610 Reads either one line or up to the specified number of bytes from the handle,
6611 originally supplied by make_http_connection.
6614 sub read_http_connection
6618 if ($h->{'ssl_con'}) {
6621 while(($idx = index($h->{'buffer'}, "\n")) < 0) {
6622 # need to read more..
6623 if (!($more = Net::SSLeay::read($h->{'ssl_con'}))) {
6625 $rv = $h->{'buffer'};
6626 delete($h->{'buffer'});
6629 $h->{'buffer'} .= $more;
6631 $rv = substr($h->{'buffer'}, 0, $idx+1);
6632 $h->{'buffer'} = substr($h->{'buffer'}, $idx+1);
6635 if (length($h->{'buffer'})) {
6636 $rv = $h->{'buffer'};
6637 delete($h->{'buffer'});
6640 $rv = Net::SSLeay::read($h->{'ssl_con'}, $_[1]);
6646 read($h->{'fh'}, $rv, $_[1]) > 0 || return undef;
6649 my $fh = $h->{'fh'};
6653 $rv = undef if ($rv eq "");
6657 =head2 write_http_connection(&handle, [data+])
6659 Writes the given data to the given HTTP connection handle.
6662 sub write_http_connection
6665 my $fh = $h->{'fh'};
6667 if ($h->{'ssl_ctx'}) {
6668 foreach my $s (@_) {
6669 my $ok = Net::SSLeay::write($h->{'ssl_con'}, $s);
6670 $allok = 0 if (!$ok);
6674 my $ok = (print $fh @_);
6675 $allok = 0 if (!$ok);
6680 =head2 close_http_connection(&handle)
6682 Closes a connection to an HTTP server, identified by the given handle.
6685 sub close_http_connection
6691 =head2 clean_environment
6693 Deletes any environment variables inherited from miniserv so that they
6694 won't be passed to programs started by webmin. This is useful when calling
6695 programs that check for CGI-related environment variables and modify their
6696 behaviour, and to avoid passing sensitive variables to un-trusted programs.
6699 sub clean_environment
6701 %UNCLEAN_ENV = %ENV;
6702 foreach my $k (keys %ENV) {
6703 if ($k =~ /^(HTTP|VIRTUALSERVER|QUOTA|USERADMIN)_/) {
6707 foreach my $e ('WEBMIN_CONFIG', 'SERVER_NAME', 'CONTENT_TYPE', 'REQUEST_URI',
6708 'PATH_INFO', 'WEBMIN_VAR', 'REQUEST_METHOD', 'GATEWAY_INTERFACE',
6709 'QUERY_STRING', 'REMOTE_USER', 'SERVER_SOFTWARE', 'SERVER_PROTOCOL',
6710 'REMOTE_HOST', 'SERVER_PORT', 'DOCUMENT_ROOT', 'SERVER_ROOT',
6711 'MINISERV_CONFIG', 'SCRIPT_NAME', 'SERVER_ADMIN', 'CONTENT_LENGTH',
6712 'HTTPS', 'FOREIGN_MODULE_NAME', 'FOREIGN_ROOT_DIRECTORY',
6713 'SCRIPT_FILENAME', 'PATH_TRANSLATED', 'BASE_REMOTE_USER',
6714 'DOCUMENT_REALROOT', 'MINISERV_CONFIG', 'MYSQL_PWD',
6720 =head2 reset_environment
6722 Puts the environment back how it was before clean_environment was callled.
6725 sub reset_environment
6728 foreach my $k (keys %UNCLEAN_ENV) {
6729 $ENV{$k} = $UNCLEAN_ENV{$k};
6731 undef(%UNCLEAN_ENV);
6735 =head2 progress_callback
6737 Never called directly, but useful for passing to &http_download to print
6738 out progress of an HTTP request.
6741 sub progress_callback
6743 if (defined(&theme_progress_callback)) {
6744 # Call the theme override
6745 return &theme_progress_callback(@_);
6749 print $progress_callback_prefix;
6751 $progress_size = $_[1];
6752 $progress_step = int($_[1] / 10);
6753 print &text('progress_size2', $progress_callback_url,
6754 &nice_size($progress_size)),"<br>\n";
6757 print &text('progress_nosize', $progress_callback_url),"<br>\n";
6759 $last_progress_time = $last_progress_size = undef;
6761 elsif ($_[0] == 3) {
6763 my $sp = $progress_callback_prefix.(" " x 5);
6764 if ($progress_size) {
6765 # And we have a size to compare against
6766 my $st = int(($_[1] * 10) / $progress_size);
6767 my $time_now = time();
6768 if ($st != $progress_step ||
6769 $time_now - $last_progress_time > 60) {
6770 # Show progress every 10% or 60 seconds
6771 print $sp,&text('progress_datan', &nice_size($_[1]),
6772 int($_[1]*100/$progress_size)),"<br>\n";
6773 $last_progress_time = $time_now;
6775 $progress_step = $st;
6778 # No total size .. so only show in 100k jumps
6779 if ($_[1] > $last_progress_size+100*1024) {
6780 print $sp,&text('progress_data2n',
6781 &nice_size($_[1])),"<br>\n";
6782 $last_progress_size = $_[1];
6786 elsif ($_[0] == 4) {
6787 # All done downloading
6788 print $progress_callback_prefix,&text('progress_done'),"<br>\n";
6790 elsif ($_[0] == 5) {
6791 # Got new location after redirect
6792 $progress_callback_url = $_[1];
6794 elsif ($_[0] == 6) {
6796 $progress_callback_url = $_[1];
6797 print &text('progress_incache', $progress_callback_url),"<br>\n";
6801 =head2 switch_to_remote_user
6803 Changes the user and group of the current process to that of the unix user
6804 with the same name as the current webmin login, or fails if there is none.
6805 This should be called by Usermin module scripts that only need to run with
6806 limited permissions.
6809 sub switch_to_remote_user
6811 @remote_user_info = $remote_user ? getpwnam($remote_user) :
6813 @remote_user_info || &error(&text('switch_remote_euser', $remote_user));
6814 &create_missing_homedir(\@remote_user_info);
6816 &switch_to_unix_user(\@remote_user_info);
6817 $ENV{'USER'} = $ENV{'LOGNAME'} = $remote_user;
6818 $ENV{'HOME'} = $remote_user_info[7];
6820 # Export global variables to caller
6821 if ($main::export_to_caller) {
6822 my ($callpkg) = caller();
6823 eval "\@${callpkg}::remote_user_info = \@remote_user_info";
6827 =head2 switch_to_unix_user(&user-details)
6829 Switches the current process to the UID and group ID from the given list
6830 of user details, which must be in the format returned by getpwnam.
6833 sub switch_to_unix_user
6836 if (!defined($uinfo->[0])) {
6837 # No username given, so just use given GID
6838 ($(, $)) = ( $uinfo->[3], "$uinfo->[3] $uinfo->[3]" );
6841 # Use all groups from user
6842 ($(, $)) = ( $uinfo->[3],
6843 "$uinfo->[3] ".join(" ", $uinfo->[3],
6844 &other_groups($uinfo->[0])) );
6847 POSIX::setuid($uinfo->[2]);
6849 if ($< != $uinfo->[2] || $> != $uinfo->[2]) {
6850 ($>, $<) = ( $uinfo->[2], $uinfo->[2] );
6854 =head2 eval_as_unix_user(username, &code)
6856 Runs some code fragment with the effective UID and GID switch to that
6857 of the given Unix user, so that file IO takes place with his permissions.
6861 sub eval_as_unix_user
6863 my ($user, $code) = @_;
6864 my @uinfo = getpwnam($user);
6865 if (!scalar(@uinfo)) {
6866 &error("eval_as_unix_user called with invalid user $user");
6868 $) = $uinfo[3]." ".join(" ", $uinfo[3], &other_groups($user));
6872 local $main::error_must_die = 1;
6879 $err =~ s/\s+at\s+(\/\S+)\s+line\s+(\d+)\.?//;
6882 return wantarray ? @rv : $rv[0];
6885 =head2 create_user_config_dirs
6887 Creates per-user config directories and sets $user_config_directory and
6888 $user_module_config_directory to them. Also reads per-user module configs
6889 into %userconfig. This should be called by Usermin module scripts that need
6890 to store per-user preferences or other settings.
6893 sub create_user_config_dirs
6895 return if (!$gconfig{'userconfig'});
6896 my @uinfo = @remote_user_info ? @remote_user_info : getpwnam($remote_user);
6897 return if (!@uinfo || !$uinfo[7]);
6898 &create_missing_homedir(\@uinfo);
6899 $user_config_directory = "$uinfo[7]/$gconfig{'userconfig'}";
6900 if (!-d $user_config_directory) {
6901 mkdir($user_config_directory, 0700) ||
6902 &error("Failed to create $user_config_directory : $!");
6903 if ($< == 0 && $uinfo[2]) {
6904 chown($uinfo[2], $uinfo[3], $user_config_directory);
6907 if (&get_module_name()) {
6908 $user_module_config_directory = $user_config_directory."/".
6910 if (!-d $user_module_config_directory) {
6911 mkdir($user_module_config_directory, 0700) ||
6912 &error("Failed to create $user_module_config_directory : $!");
6913 if ($< == 0 && $uinfo[2]) {
6914 chown($uinfo[2], $uinfo[3], $user_config_directory);
6918 &read_file_cached("$module_root_directory/defaultuconfig",
6920 &read_file_cached("$module_config_directory/uconfig", \%userconfig);
6921 &read_file_cached("$user_module_config_directory/config",
6925 # Export global variables to caller
6926 if ($main::export_to_caller) {
6927 my ($callpkg) = caller();
6928 foreach my $v ('$user_config_directory',
6929 '$user_module_config_directory', '%userconfig') {
6930 my ($vt, $vn) = split('', $v, 2);
6931 eval "${vt}${callpkg}::${vn} = ${vt}${vn}";
6936 =head2 create_missing_homedir(&uinfo)
6938 If auto homedir creation is enabled, create one for this user if needed.
6939 For internal use only.
6942 sub create_missing_homedir
6945 if (!-e $uinfo->[7] && $gconfig{'create_homedir'}) {
6946 # Use has no home dir .. make one
6947 system("mkdir -p ".quotemeta($uinfo->[7]));
6948 chown($uinfo->[2], $uinfo->[3], $uinfo->[7]);
6949 if ($gconfig{'create_homedir_perms'} ne '') {
6950 chmod(oct($gconfig{'create_homedir_perms'}), $uinfo->[7]);
6955 =head2 filter_javascript(text)
6957 Disables all javascript <script>, onClick= and so on tags in the given HTML,
6958 and returns the new HTML. Useful for displaying HTML from an un-trusted source.
6961 sub filter_javascript
6964 $rv =~ s/<\s*script[^>]*>([\000-\377]*?)<\s*\/script\s*>//gi;
6965 $rv =~ s/(on(Abort|Blur|Change|Click|DblClick|DragDrop|Error|Focus|KeyDown|KeyPress|KeyUp|Load|MouseDown|MouseMove|MouseOut|MouseOver|MouseUp|Move|Reset|Resize|Select|Submit|Unload)=)/x$1/gi;
6966 $rv =~ s/(javascript:)/x$1/gi;
6967 $rv =~ s/(vbscript:)/x$1/gi;
6971 =head2 resolve_links(path)
6973 Given a path that may contain symbolic links, returns the real path.
6979 $path =~ s/\/+/\//g;
6980 $path =~ s/\/$// if ($path ne "/");
6981 my @p = split(/\/+/, $path);
6983 for(my $i=0; $i<@p; $i++) {
6984 my $sofar = "/".join("/", @p[0..$i]);
6985 my $lnk = readlink($sofar);
6986 if ($lnk eq $sofar) {
6987 # Link to itself! Cannot do anything more really ..
6990 elsif ($lnk =~ /^\//) {
6991 # Link is absolute..
6992 return &resolve_links($lnk."/".join("/", @p[$i+1 .. $#p]));
6996 return &resolve_links("/".join("/", @p[0..$i-1])."/".$lnk."/".join("/", @p[$i+1 .. $#p]));
7002 =head2 simplify_path(path, bogus)
7004 Given a path, maybe containing elements ".." and "." , convert it to a
7005 clean, absolute form. Returns undef if this is not possible.
7013 my @bits = split(/\/+/, $dir);
7016 foreach my $b (@bits) {
7020 elsif ($b eq "..") {
7022 if (scalar(@fixedbits) == 0) {
7023 # Cannot! Already at root!
7030 push(@fixedbits, $b);
7033 return "/".join('/', @fixedbits);
7036 =head2 same_file(file1, file2)
7038 Returns 1 if two files are actually the same
7043 return 1 if ($_[0] eq $_[1]);
7044 return 0 if ($_[0] !~ /^\// || $_[1] !~ /^\//);
7045 my @stat1 = $stat_cache{$_[0]} ? @{$stat_cache{$_[0]}}
7046 : (@{$stat_cache{$_[0]}} = stat($_[0]));
7047 my @stat2 = $stat_cache{$_[1]} ? @{$stat_cache{$_[1]}}
7048 : (@{$stat_cache{$_[1]}} = stat($_[1]));
7049 return 0 if (!@stat1 || !@stat2);
7050 return $stat1[0] == $stat2[0] && $stat1[1] == $stat2[1];
7053 =head2 flush_webmin_caches
7055 Clears all in-memory and on-disk caches used by Webmin.
7058 sub flush_webmin_caches
7060 undef(%main::read_file_cache);
7061 undef(%main::acl_hash_cache);
7062 undef(%main::acl_array_cache);
7063 undef(%main::has_command_cache);
7064 undef(@main::list_languages_cache);
7065 undef($main::got_list_usermods_cache);
7066 undef(@main::list_usermods_cache);
7067 undef(%main::foreign_installed_cache);
7068 unlink("$config_directory/module.infos.cache");
7069 &get_all_module_infos();
7072 =head2 list_usermods
7074 Returns a list of additional module restrictions. For internal use in
7080 if (!$main::got_list_usermods_cache) {
7081 @main::list_usermods_cache = ( );
7083 open(USERMODS, "$config_directory/usermin.mods");
7085 if (/^([^:]+):(\+|-|):(.*)/) {
7086 push(@main::list_usermods_cache,
7087 [ $1, $2, [ split(/\s+/, $3) ] ]);
7091 $main::got_list_usermods_cache = 1;
7093 return @main::list_usermods_cache;
7096 =head2 available_usermods(&allmods, &usermods)
7098 Returns a list of modules that are available to the given user, based
7099 on usermod additional/subtractions. For internal use by Usermin only.
7102 sub available_usermods
7104 return @{$_[0]} if (!@{$_[1]});
7106 my %mods = map { $_->{'dir'}, 1 } @{$_[0]};
7107 my @uinfo = @remote_user_info;
7108 @uinfo = getpwnam($remote_user) if (!@uinfo);
7109 foreach my $u (@{$_[1]}) {
7111 if ($u->[0] eq "*" || $u->[0] eq $remote_user) {
7114 elsif ($u->[0] =~ /^\@(.*)$/) {
7115 # Check for group membership
7116 my @ginfo = getgrnam($1);
7117 $applies++ if (@ginfo && ($ginfo[2] == $uinfo[3] ||
7118 &indexof($remote_user, split(/\s+/, $ginfo[3])) >= 0));
7120 elsif ($u->[0] =~ /^\//) {
7121 # Check users and groups in file
7123 open(USERFILE, $u->[0]);
7126 if ($_ eq $remote_user) {
7129 elsif (/^\@(.*)$/) {
7130 my @ginfo = getgrnam($1);
7132 if (@ginfo && ($ginfo[2] == $uinfo[3] ||
7133 &indexof($remote_user,
7134 split(/\s+/, $ginfo[3])) >= 0));
7141 if ($u->[1] eq "+") {
7142 map { $mods{$_}++ } @{$u->[2]};
7144 elsif ($u->[1] eq "-") {
7145 map { delete($mods{$_}) } @{$u->[2]};
7149 map { $mods{$_}++ } @{$u->[2]};
7153 return grep { $mods{$_->{'dir'}} } @{$_[0]};
7156 =head2 get_available_module_infos(nocache)
7158 Returns a list of modules available to the current user, based on
7159 operating system support, access control and usermod restrictions. Useful
7160 in themes that need to display a list of modules the user can use.
7161 Each element of the returned array is a hash reference in the same format as
7162 returned by get_module_info.
7165 sub get_available_module_infos
7168 &read_acl(\%acl, \%uacl, [ $base_remote_user ]);
7169 my $risk = $gconfig{'risk_'.$base_remote_user};
7171 foreach my $minfo (&get_all_module_infos($_[0])) {
7172 next if (!&check_os_support($minfo));
7174 # Check module risk level
7175 next if ($risk ne 'high' && $minfo->{'risk'} &&
7176 $minfo->{'risk'} !~ /$risk/);
7180 next if (!$acl{$base_remote_user,$minfo->{'dir'}} &&
7181 !$acl{$base_remote_user,"*"});
7183 next if (&is_readonly_mode() && !$minfo->{'readonly'});
7187 # Check usermod restrictions
7188 my @usermods = &list_usermods();
7189 @rv = sort { $a->{'desc'} cmp $b->{'desc'} }
7190 &available_usermods(\@rv, \@usermods);
7192 # Check RBAC restrictions
7194 foreach my $m (@rv) {
7195 if (&supports_rbac($m->{'dir'}) &&
7196 &use_rbac_module_acl(undef, $m->{'dir'})) {
7197 local $rbacs = &get_rbac_module_acl($remote_user,
7205 # Module or system doesn't support RBAC
7206 push(@rbacrv, $m) if (!$gconfig{'rbacdeny_'.$base_remote_user});
7212 if (defined(&theme_foreign_available)) {
7213 foreach my $m (@rbacrv) {
7214 if (&theme_foreign_available($m->{'dir'})) {
7223 # Check licence module vetos
7225 if ($main::licence_module) {
7226 foreach my $m (@themerv) {
7227 if (&foreign_call($main::licence_module,
7228 "check_module_licence", $m->{'dir'})) {
7240 =head2 get_visible_module_infos(nocache)
7242 Like get_available_module_infos, but excludes hidden modules from the list.
7243 Each element of the returned array is a hash reference in the same format as
7244 returned by get_module_info.
7247 sub get_visible_module_infos
7250 my $pn = &get_product_name();
7251 return grep { !$_->{'hidden'} &&
7252 !$_->{$pn.'_hidden'} } &get_available_module_infos($nocache);
7255 =head2 get_visible_modules_categories(nocache)
7257 Returns a list of Webmin module categories, each of which is a hash ref
7258 with 'code', 'desc' and 'modules' keys. The modules value is an array ref
7259 of modules in the category, in the format returned by get_module_info.
7260 Un-used modules are automatically assigned to the 'unused' category, and
7261 those with no category are put into 'others'.
7264 sub get_visible_modules_categories
7267 my @mods = &get_visible_module_infos($nocache);
7269 if (&get_product_name() eq 'webmin') {
7270 @unmods = grep { $_->{'installed'} eq '0' } @mods;
7271 @mods = grep { $_->{'installed'} ne '0' } @mods;
7273 my %cats = &list_categories(\@mods);
7275 foreach my $c (keys %cats) {
7276 my $cat = { 'code' => $c || 'other',
7277 'desc' => $cats{$c} };
7278 $cat->{'modules'} = [ grep { $_->{'category'} eq $c } @mods ];
7281 @rv = sort { ($b->{'code'} eq "others" ? "" : $b->{'code'}) cmp
7282 ($a->{'code'} eq "others" ? "" : $a->{'code'}) } @rv;
7284 # Add un-installed modules in magic category
7285 my $cat = { 'code' => 'unused',
7286 'desc' => $text{'main_unused'},
7288 'modules' => \@unmods };
7294 =head2 is_under_directory(directory, file)
7296 Returns 1 if the given file is under the specified directory, 0 if not.
7297 Symlinks are taken into account in the file to find it's 'real' location.
7300 sub is_under_directory
7302 my ($dir, $file) = @_;
7303 return 1 if ($dir eq "/");
7304 return 0 if ($file =~ /\.\./);
7305 my $ld = &resolve_links($dir);
7307 return &is_under_directory($ld, $file);
7309 my $lp = &resolve_links($file);
7311 return &is_under_directory($dir, $lp);
7313 return 0 if (length($file) < length($dir));
7314 return 1 if ($dir eq $file);
7316 return substr($file, 0, length($dir)) eq $dir;
7319 =head2 parse_http_url(url, [basehost, baseport, basepage, basessl])
7321 Given an absolute URL, returns the host, port, page and ssl flag components.
7322 Relative URLs can also be parsed, if the base information is provided.
7327 if ($_[0] =~ /^(http|https):\/\/([^:\/]+)(:(\d+))?(\/\S*)?$/) {
7329 my $ssl = $1 eq 'https';
7330 return ($2, $3 ? $4 : $ssl ? 443 : 80, $5 || "/", $ssl);
7336 elsif ($_[0] =~ /^\/\S*$/) {
7337 # A relative to the server URL
7338 return ($_[1], $_[2], $_[0], $_[4]);
7341 # A relative to the directory URL
7343 $page =~ s/[^\/]+$//;
7344 return ($_[1], $_[2], $page.$_[0], $_[4]);
7348 =head2 check_clicks_function
7350 Returns HTML for a JavaScript function called check_clicks that returns
7351 true when first called, but false subsequently. Useful on onClick for
7352 critical buttons. Deprecated, as this method of preventing duplicate actions
7356 sub check_clicks_function
7361 function check_clicks(form)
7368 for(i=0; i<form.length; i++)
7369 form.elements[i].disabled = true;
7378 =head2 load_entities_map
7380 Returns a hash ref containing mappings between HTML entities (like ouml) and
7381 ascii values (like 246). Mainly for internal use.
7384 sub load_entities_map
7386 if (!%entities_map_cache) {
7388 open(EMAP, "$root_directory/entities_map.txt");
7390 if (/^(\d+)\s+(\S+)/) {
7391 $entities_map_cache{$2} = $1;
7396 return \%entities_map_cache;
7399 =head2 entities_to_ascii(string)
7401 Given a string containing HTML entities like ö and 7, replace them
7402 with their ASCII equivalents.
7405 sub entities_to_ascii
7408 my $emap = &load_entities_map();
7409 $str =~ s/&([a-z]+);/chr($emap->{$1})/ge;
7410 $str =~ s/&#(\d+);/chr($1)/ge;
7414 =head2 get_product_name
7416 Returns either 'webmin' or 'usermin', depending on which program the current
7417 module is in. Useful for modules that can be installed into either.
7420 sub get_product_name
7422 return $gconfig{'product'} if (defined($gconfig{'product'}));
7423 return defined($gconfig{'userconfig'}) ? 'usermin' : 'webmin';
7428 Returns the character set for the current language, such as iso-8859-1.
7433 my $charset = defined($gconfig{'charset'}) ? $gconfig{'charset'} :
7434 $current_lang_info->{'charset'} ?
7435 $current_lang_info->{'charset'} : $default_charset;
7439 =head2 get_display_hostname
7441 Returns the system's hostname for UI display purposes. This may be different
7442 from the actual hostname if you administrator has configured it so in the
7443 Webmin Configuration module.
7446 sub get_display_hostname
7448 if ($gconfig{'hostnamemode'} == 0) {
7449 return &get_system_hostname();
7451 elsif ($gconfig{'hostnamemode'} == 3) {
7452 return $gconfig{'hostnamedisplay'};
7455 my $h = $ENV{'HTTP_HOST'};
7457 if ($gconfig{'hostnamemode'} == 2) {
7458 $h =~ s/^(www|ftp|mail)\.//i;
7464 =head2 save_module_config([&config], [modulename])
7466 Saves the configuration for some module. The config parameter is an optional
7467 hash reference of names and values to save, which defaults to the global
7468 %config hash. The modulename parameter is the module to update the config
7469 file, which defaults to the current module.
7472 sub save_module_config
7474 my $c = $_[0] || { &get_module_variable('%config') };
7475 my $m = defined($_[1]) ? $_[1] : &get_module_name();
7476 &write_file("$config_directory/$m/config", $c);
7479 =head2 save_user_module_config([&config], [modulename])
7481 Saves the user's Usermin preferences for some module. The config parameter is
7482 an optional hash reference of names and values to save, which defaults to the
7483 global %userconfig hash. The modulename parameter is the module to update the
7484 config file, which defaults to the current module.
7487 sub save_user_module_config
7489 my $c = $_[0] || { &get_module_variable('%userconfig') };
7490 my $m = $_[1] || &get_module_name();
7491 my $ucd = $user_config_directory;
7493 my @uinfo = @remote_user_info ? @remote_user_info
7494 : getpwnam($remote_user);
7495 return if (!@uinfo || !$uinfo[7]);
7496 $ucd = "$uinfo[7]/$gconfig{'userconfig'}";
7498 &write_file("$ucd/$m/config", $c);
7501 =head2 nice_size(bytes, [min])
7503 Converts a number of bytes into a number followed by a suffix like GB, MB
7504 or kB. Rounding is to two decimal digits. The optional min parameter sets the
7505 smallest units to use - so you could pass 1024*1024 to never show bytes or kB.
7510 my ($units, $uname);
7511 if (abs($_[0]) > 1024*1024*1024*1024 || $_[1] >= 1024*1024*1024*1024) {
7512 $units = 1024*1024*1024*1024;
7515 elsif (abs($_[0]) > 1024*1024*1024 || $_[1] >= 1024*1024*1024) {
7516 $units = 1024*1024*1024;
7519 elsif (abs($_[0]) > 1024*1024 || $_[1] >= 1024*1024) {
7523 elsif (abs($_[0]) > 1024 || $_[1] >= 1024) {
7531 my $sz = sprintf("%.2f", ($_[0]*1.0 / $units));
7533 return $sz." ".$uname;
7536 =head2 get_perl_path
7538 Returns the path to Perl currently in use, such as /usr/bin/perl.
7543 if (open(PERL, "$config_directory/perl-path")) {
7549 return $^X if (-x $^X);
7550 return &has_command("perl");
7553 =head2 get_goto_module([&mods])
7555 Returns the details of a module that the current user should be re-directed
7556 to after logging in, or undef if none. Useful for themes.
7561 my @mods = $_[0] ? @{$_[0]} : &get_visible_module_infos();
7562 if ($gconfig{'gotomodule'}) {
7563 my ($goto) = grep { $_->{'dir'} eq $gconfig{'gotomodule'} } @mods;
7564 return $goto if ($goto);
7566 if (@mods == 1 && $gconfig{'gotoone'}) {
7572 =head2 select_all_link(field, form, [text])
7574 Returns HTML for a 'Select all' link that uses Javascript to select
7575 multiple checkboxes with the same name. The parameters are :
7577 =item field - Name of the checkbox inputs.
7579 =item form - Index of the form on the page.
7581 =item text - Message for the link, defaulting to 'Select all'.
7586 return &theme_select_all_link(@_) if (defined(&theme_select_all_link));
7587 my ($field, $form, $text) = @_;
7589 $text ||= $text{'ui_selall'};
7590 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>";
7593 =head2 select_invert_link(field, form, text)
7595 Returns HTML for an 'Invert selection' link that uses Javascript to invert the
7596 selection on multiple checkboxes with the same name. The parameters are :
7598 =item field - Name of the checkbox inputs.
7600 =item form - Index of the form on the page.
7602 =item text - Message for the link, defaulting to 'Invert selection'.
7605 sub select_invert_link
7607 return &theme_select_invert_link(@_) if (defined(&theme_select_invert_link));
7608 my ($field, $form, $text) = @_;
7610 $text ||= $text{'ui_selinv'};
7611 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>";
7614 =head2 select_rows_link(field, form, text, &rows)
7616 Returns HTML for a link that uses Javascript to select rows with particular
7617 values for their checkboxes. The parameters are :
7619 =item field - Name of the checkbox inputs.
7621 =item form - Index of the form on the page.
7623 =item text - Message for the link, de
7625 =item rows - Reference to an array of 1 or 0 values, indicating which rows to check.
7628 sub select_rows_link
7630 return &theme_select_rows_link(@_) if (defined(&theme_select_rows_link));
7631 my ($field, $form, $text, $rows) = @_;
7633 my $js = "var sel = { ".join(",", map { "\""."e_escape($_)."\":1" } @$rows)." }; ";
7634 $js .= "for(var i=0; i<document.forms[$form].${field}.length; i++) { var r = document.forms[$form].${field}[i]; r.checked = sel[r.value]; } ";
7635 $js .= "return false;";
7636 return "<a href='#' onClick='$js'>$text</a>";
7639 =head2 check_pid_file(file)
7641 Given a pid file, returns the PID it contains if the process is running.
7646 open(PIDFILE, $_[0]) || return undef;
7647 my $pid = <PIDFILE>;
7649 $pid =~ /^\s*(\d+)/ || return undef;
7650 kill(0, $1) || return undef;
7656 Return the local os-specific library name to this module. For internal use only.
7661 my $mn = &get_module_name();
7662 my $md = &module_root_directory($mn);
7663 if (-r "$md/$mn-$gconfig{'os_type'}-$gconfig{'os_version'}-lib.pl") {
7664 return "$mn-$gconfig{'os_type'}-$gconfig{'os_version'}-lib.pl";
7666 elsif (-r "$md/$mn-$gconfig{'os_type'}-lib.pl") {
7667 return "$mn-$gconfig{'os_type'}-lib.pl";
7669 elsif (-r "$md/$mn-generic-lib.pl") {
7670 return "$mn-generic-lib.pl";
7677 =head2 module_root_directory(module)
7679 Given a module name, returns its root directory. On a typical Webmin install,
7680 all modules are under the same directory - but it is theoretically possible to
7684 sub module_root_directory
7686 my $d = ref($_[0]) ? $_[0]->{'dir'} : $_[0];
7687 if (@root_directories > 1) {
7688 foreach my $r (@root_directories) {
7694 return "$root_directories[0]/$d";
7697 =head2 list_mime_types
7699 Returns a list of all known MIME types and their extensions, as a list of hash
7700 references with keys :
7702 =item type - The MIME type, like text/plain.
7704 =item exts - A list of extensions, like .doc and .avi.
7706 =item desc - A human-readable description for the MIME type.
7711 if (!@list_mime_types_cache) {
7713 open(MIME, "$root_directory/mime.types");
7717 if (s/#\s*(.*)$//g) {
7720 my ($type, @exts) = split(/\s+/);
7722 push(@list_mime_types_cache, { 'type' => $type,
7729 return @list_mime_types_cache;
7732 =head2 guess_mime_type(filename, [default])
7734 Given a file name like xxx.gif or foo.html, returns a guessed MIME type.
7735 The optional default parameter sets a default type of use if none is found,
7736 which defaults to application/octet-stream.
7741 if ($_[0] =~ /\.([A-Za-z0-9\-]+)$/) {
7743 foreach my $t (&list_mime_types()) {
7744 foreach my $e (@{$t->{'exts'}}) {
7745 return $t->{'type'} if (lc($e) eq lc($ext));
7749 return @_ > 1 ? $_[1] : "application/octet-stream";
7752 =head2 open_tempfile([handle], file, [no-error], [no-tempfile], [safe?])
7754 Opens a file handle for writing to a temporary file, which will only be
7755 renamed over the real file when the handle is closed. This allows critical
7756 files like /etc/shadow to be updated safely, even if writing fails part way
7757 through due to lack of disk space. The parameters are :
7759 =item handle - File handle to open, as you would use in Perl's open function.
7761 =item file - Full path to the file to write, prefixed by > or >> to indicate over-writing or appending. In append mode, no temp file is used.
7763 =item no-error - By default, this function will call error if the open fails. Setting this parameter to 1 causes it to return 0 on failure, and set $! with the error code.
7765 =item no-tempfile - If set to 1, writing will be direct to the file instead of using a temporary file.
7767 =item safe - Indicates to users in read-only mode that this write is safe and non-destructive.
7773 # Just getting a temp file
7774 if (!defined($main::open_tempfiles{$_[0]})) {
7775 $_[0] =~ /^(.*)\/(.*)$/ || return $_[0];
7776 my $dir = $1 || "/";
7777 my $tmp = "$dir/$2.webmintmp.$$";
7778 $main::open_tempfiles{$_[0]} = $tmp;
7779 push(@main::temporary_files, $tmp);
7781 return $main::open_tempfiles{$_[0]};
7785 my ($fh, $file, $noerror, $notemp, $safe) = @_;
7786 $fh = &callers_package($fh);
7788 my %gaccess = &get_module_acl(undef, "");
7789 my $db = $gconfig{'debug_what_write'};
7790 if ($file =~ /\r|\n|\0/) {
7791 if ($noerror) { return 0; }
7792 else { &error("Filename contains invalid characters"); }
7794 if (&is_readonly_mode() && $file =~ />/ && !$safe) {
7795 # Read-only mode .. veto all writes
7796 print STDERR "vetoing write to $file\n";
7797 return open($fh, ">$null_file");
7799 elsif ($file =~ /^(>|>>|)nul$/i) {
7800 # Write to Windows null device
7801 &webmin_debug_log($1 eq ">" ? "WRITE" :
7802 $1 eq ">>" ? "APPEND" : "READ", "nul") if ($db);
7804 elsif ($file =~ /^(>|>>)(\/dev\/.*)/ || lc($file) eq "nul") {
7805 # Writes to /dev/null or TTYs don't need to be handled
7806 &webmin_debug_log($1 eq ">" ? "WRITE" : "APPEND", $2) if ($db);
7807 return open($fh, $file);
7809 elsif ($file =~ /^>\s*(([a-zA-Z]:)?\/.*)$/ && !$notemp) {
7810 &webmin_debug_log("WRITE", $1) if ($db);
7811 # Over-writing a file, via a temp file
7813 $file = &translate_filename($file);
7815 # Open the link target instead
7816 $file = &resolve_links($file);
7819 # Cannot open a directory!
7820 if ($noerror) { return 0; }
7821 else { &error("Cannot write to directory $file"); }
7823 my $tmp = &open_tempfile($file);
7824 my $ex = open($fh, ">$tmp");
7825 if (!$ex && $! =~ /permission/i) {
7826 # Could not open temp file .. try opening actual file
7828 $ex = open($fh, ">$file");
7829 delete($main::open_tempfiles{$file});
7832 $main::open_temphandles{$fh} = $file;
7835 if (!$ex && !$noerror) {
7836 &error(&text("efileopen", $file, $!));
7840 elsif ($file =~ /^>\s*(([a-zA-Z]:)?\/.*)$/ && $notemp) {
7841 # Just writing direct to a file
7842 &webmin_debug_log("WRITE", $1) if ($db);
7844 $file = &translate_filename($file);
7845 my @old_attributes = &get_clear_file_attributes($file);
7846 my $ex = open($fh, ">$file");
7847 &reset_file_attributes($file, \@old_attributes);
7848 $main::open_temphandles{$fh} = $file;
7849 if (!$ex && !$noerror) {
7850 &error(&text("efileopen", $file, $!));
7855 elsif ($file =~ /^>>\s*(([a-zA-Z]:)?\/.*)$/) {
7856 # Appending to a file .. nothing special to do
7857 &webmin_debug_log("APPEND", $1) if ($db);
7859 $file = &translate_filename($file);
7860 my @old_attributes = &get_clear_file_attributes($file);
7861 my $ex = open($fh, ">>$file");
7862 &reset_file_attributes($file, \@old_attributes);
7863 $main::open_temphandles{$fh} = $file;
7864 if (!$ex && !$noerror) {
7865 &error(&text("efileopen", $file, $!));
7870 elsif ($file =~ /^([a-zA-Z]:)?\//) {
7871 # Read mode .. nothing to do here
7872 &webmin_debug_log("READ", $file) if ($db);
7873 $file = &translate_filename($file);
7874 return open($fh, $file);
7876 elsif ($file eq ">" || $file eq ">>") {
7877 my ($package, $filename, $line) = caller;
7878 if ($noerror) { return 0; }
7879 else { &error("Missing file to open at ${package}::${filename} line $line"); }
7882 my ($package, $filename, $line) = caller;
7883 &error("Unsupported file or mode $file at ${package}::${filename} line $line");
7888 =head2 close_tempfile(file|handle)
7890 Copies a temp file to the actual file, assuming that all writes were
7891 successful. The handle must have been one passed to open_tempfile.
7897 my $fh = &callers_package($_[0]);
7899 if (defined($file = $main::open_temphandles{$fh})) {
7901 close($fh) || &error(&text("efileclose", $file, $!));
7902 delete($main::open_temphandles{$fh});
7903 return &close_tempfile($file);
7905 elsif (defined($main::open_tempfiles{$_[0]})) {
7907 &webmin_debug_log("CLOSE", $_[0]) if ($gconfig{'debug_what_write'});
7908 my @st = stat($_[0]);
7909 if (&is_selinux_enabled() && &has_command("chcon")) {
7910 # Set original security context
7911 system("chcon --reference=".quotemeta($_[0]).
7912 " ".quotemeta($main::open_tempfiles{$_[0]}).
7913 " >/dev/null 2>&1");
7915 my @old_attributes = &get_clear_file_attributes($_[0]);
7916 rename($main::open_tempfiles{$_[0]}, $_[0]) || &error("Failed to replace $_[0] with $main::open_tempfiles{$_[0]} : $!");
7918 # Set original permissions and ownership
7919 chmod($st[2], $_[0]);
7920 chown($st[4], $st[5], $_[0]);
7922 &reset_file_attributes($_[0], \@old_attributes);
7923 delete($main::open_tempfiles{$_[0]});
7924 @main::temporary_files = grep { $_ ne $main::open_tempfiles{$_[0]} } @main::temporary_files;
7925 if ($main::open_templocks{$_[0]}) {
7926 &unlock_file($_[0]);
7927 delete($main::open_templocks{$_[0]});
7932 # Must be closing a handle not associated with a file
7938 =head2 print_tempfile(handle, text, ...)
7940 Like the normal print function, but calls &error on failure. Useful when
7941 combined with open_tempfile, to ensure that a criticial file is never
7942 only partially written.
7947 my ($fh, @args) = @_;
7948 $fh = &callers_package($fh);
7949 (print $fh @args) || &error(&text("efilewrite",
7950 $main::open_temphandles{$fh} || $fh, $!));
7953 =head2 is_selinux_enabled
7955 Returns 1 if SElinux is supported on this system and enabled, 0 if not.
7958 sub is_selinux_enabled
7960 if (!defined($main::selinux_enabled_cache)) {
7962 if ($gconfig{'os_type'} !~ /-linux$/) {
7963 # Not on linux, so no way
7964 $main::selinux_enabled_cache = 0;
7966 elsif (&read_env_file("/etc/selinux/config", \%seconfig)) {
7967 # Use global config file
7968 $main::selinux_enabled_cache =
7969 $seconfig{'SELINUX'} eq 'disabled' ||
7970 !$seconfig{'SELINUX'} ? 0 : 1;
7973 # Use selinuxenabled command
7974 #$selinux_enabled_cache =
7975 # system("selinuxenabled >/dev/null 2>&1") ? 0 : 1;
7976 $main::selinux_enabled_cache = 0;
7979 return $main::selinux_enabled_cache;
7982 =head2 get_clear_file_attributes(file)
7984 Finds file attributes that may prevent writing, clears them and returns them
7985 as a list. May call error. Mainly for internal use by open_tempfile and
7989 sub get_clear_file_attributes
7993 if ($gconfig{'chattr'}) {
7994 # Get original immutable bit
7995 my $out = &backquote_command(
7996 "lsattr ".quotemeta($file)." 2>/dev/null");
7998 $out =~ s/\s\S+\n//;
7999 @old_attributes = grep { $_ ne '-' } split(//, $out);
8001 if (&indexof("i", @old_attributes) >= 0) {
8002 my $err = &backquote_logged(
8003 "chattr -i ".quotemeta($file)." 2>&1");
8005 &error("Failed to remove immutable bit on ".
8010 return @old_attributes;
8013 =head2 reset_file_attributes(file, &attributes)
8015 Put back cleared attributes on some file. May call error. Mainly for internal
8016 use by close_tempfile.
8019 sub reset_file_attributes
8021 my ($file, $old_attributes) = @_;
8022 if (&indexof("i", @$old_attributes) >= 0) {
8023 my $err = &backquote_logged(
8024 "chattr +i ".quotemeta($file)." 2>&1");
8026 &error("Failed to restore immutable bit on ".
8032 =head2 cleanup_tempnames
8034 Remove all temporary files generated using transname. Typically only called
8035 internally when a Webmin script exits.
8038 sub cleanup_tempnames
8040 foreach my $t (@main::temporary_files) {
8043 @main::temporary_files = ( );
8046 =head2 open_lock_tempfile([handle], file, [no-error])
8048 Returns a temporary file for writing to some actual file, and also locks it.
8049 Effectively the same as calling lock_file and open_tempfile on the same file,
8050 but calls the unlock for you automatically when it is closed.
8053 sub open_lock_tempfile
8055 my ($fh, $file, $noerror, $notemp, $safe) = @_;
8056 $fh = &callers_package($fh);
8057 my $lockfile = $file;
8058 $lockfile =~ s/^[^\/]*//;
8059 if ($lockfile =~ /^\//) {
8060 $main::open_templocks{$lockfile} = &lock_file($lockfile);
8062 return &open_tempfile($fh, $file, $noerror, $notemp, $safe);
8067 $main::end_exit_status ||= $?;
8068 if ($$ == $main::initial_process_id) {
8069 # Exiting from initial process
8070 &cleanup_tempnames();
8071 if ($gconfig{'debug_what_start'} && $main::debug_log_start_time &&
8072 $main::debug_log_start_module eq &get_module_name()) {
8073 my $len = time() - $main::debug_log_start_time;
8074 &webmin_debug_log("STOP", "runtime=$len");
8075 $main::debug_log_start_time = 0;
8077 if (!$ENV{'SCRIPT_NAME'} &&
8078 $main::initial_module_name eq &get_module_name()) {
8079 # In a command-line script - call the real exit, so that the
8080 # exit status gets properly propogated. In some cases this
8081 # was not happening.
8082 exit($main::end_exit_status);
8087 =head2 month_to_number(month)
8089 Converts a month name like feb to a number like 1.
8094 return $month_to_number_map{lc(substr($_[0], 0, 3))};
8097 =head2 number_to_month(number)
8099 Converts a number like 1 to a month name like Feb.
8104 return ucfirst($number_to_month_map{$_[0]});
8107 =head2 get_rbac_module_acl(user, module)
8109 Returns a hash reference of RBAC overrides ACLs for some user and module.
8110 May return undef if none exist (indicating access denied), or the string *
8111 if full access is granted.
8114 sub get_rbac_module_acl
8116 my ($user, $mod) = @_;
8117 eval "use Authen::SolarisRBAC";
8118 return undef if ($@);
8121 if (Authen::SolarisRBAC::chkauth("webmin.$mod.admin", $user)) {
8122 # Automagic webmin.modulename.admin authorization exists .. allow access
8124 if (!Authen::SolarisRBAC::chkauth("webmin.$mod.config", $user)) {
8125 %rv = ( 'noconfig' => 1 );
8132 open(RBAC, &module_root_directory($mod)."/rbac-mapping");
8136 my ($auths, $acls) = split(/\s+/, $_);
8137 my @auths = split(/,/, $auths);
8139 my ($merge) = ($acls =~ s/^\+//);
8141 if ($auths eq "*") {
8142 # These ACLs apply to all RBAC users.
8143 # Only if there is some that match a specific authorization
8144 # later will they be used though.
8147 # Check each of the RBAC authorizations
8148 foreach my $a (@auths) {
8149 if (!Authen::SolarisRBAC::chkauth($a, $user)) {
8154 $foundany++ if ($gotall);
8157 # Found an RBAC authorization - return the ACLs
8158 return "*" if ($acls eq "*");
8159 my %acl = map { split(/=/, $_, 2) } split(/,/, $acls);
8161 # Just add to current set
8162 foreach my $a (keys %acl) {
8173 return !$foundany ? undef : %rv ? \%rv : undef;
8176 =head2 supports_rbac([module])
8178 Returns 1 if RBAC client support is available, such as on Solaris.
8183 return 0 if ($gconfig{'os_type'} ne 'solaris');
8184 eval "use Authen::SolarisRBAC";
8187 #return 0 if (!-r &module_root_directory($_[0])."/rbac-mapping");
8192 =head2 use_rbac_module_acl(user, module)
8194 Returns 1 if some user should use RBAC to get permissions for a module
8197 sub use_rbac_module_acl
8199 my $u = defined($_[0]) ? $_[0] : $base_remote_user;
8200 my $m = defined($_[1]) ? $_[1] : &get_module_name();
8201 return 1 if ($gconfig{'rbacdeny_'.$u}); # RBAC forced for user
8202 my %access = &get_module_acl($u, $m, 1);
8203 return $access{'rbac'} ? 1 : 0;
8206 =head2 execute_command(command, stdin, stdout, stderr, translate-files?, safe?)
8208 Runs some command, possibly feeding it input and capturing output to the
8209 give files or scalar references. The parameters are :
8211 =item command - Full command to run, possibly including shell meta-characters.
8213 =item stdin - File to read input from, or a scalar ref containing input, or undef if no input should be given.
8215 =item stdout - File to write output to, or a scalar ref into which output should be placed, or undef if the output is to be discarded.
8217 =item stderr - File to write error output to, or a scalar ref into which error output should be placed, or undef if the error output is to be discarded.
8219 =item translate-files - Set to 1 to apply filename translation to any filenames. Usually has no effect.
8221 =item safe - Set to 1 if this command is safe and does not modify the state of the system.
8226 my ($cmd, $stdin, $stdout, $stderr, $trans, $safe) = @_;
8227 if (&is_readonly_mode() && !$safe) {
8228 print STDERR "Vetoing command $_[0]\n";
8232 $cmd = &translate_command($cmd);
8234 # Use ` operator where possible
8235 &webmin_debug_log('CMD', "cmd=$cmd") if ($gconfig{'debug_what_cmd'});
8236 if (!$stdin && ref($stdout) && !$stderr) {
8237 $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
8238 $$stdout = `$cmd 2>$null_file`;
8241 elsif (!$stdin && ref($stdout) && $stdout eq $stderr) {
8242 $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
8243 $$stdout = `$cmd 2>&1`;
8246 elsif (!$stdin && !$stdout && !$stderr) {
8247 $cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
8248 return system("$cmd >$null_file 2>$null_file <$null_file");
8252 $| = 1; # needed on some systems to flush before forking
8253 pipe(EXECSTDINr, EXECSTDINw);
8254 pipe(EXECSTDOUTr, EXECSTDOUTw);
8255 pipe(EXECSTDERRr, EXECSTDERRw);
8257 if (!($pid = fork())) {
8261 open(STDIN, "<&EXECSTDINr");
8262 open(STDOUT, ">&EXECSTDOUTw");
8263 if (ref($stderr) && $stderr eq $stdout) {
8264 open(STDERR, ">&EXECSTDOUTw");
8267 open(STDERR, ">&EXECSTDERRw");
8274 my $fullcmd = "($cmd)";
8275 if ($stdin && !ref($stdin)) {
8276 $fullcmd .= " <$stdin";
8278 if ($stdout && !ref($stdout)) {
8279 $fullcmd .= " >$stdout";
8281 if ($stderr && !ref($stderr)) {
8282 if ($stderr eq $stdout) {
8283 $fullcmd .= " 2>&1";
8286 $fullcmd .= " 2>$stderr";
8289 if ($gconfig{'os_type'} eq 'windows') {
8293 exec("/bin/sh", "-c", $fullcmd);
8295 print "Exec failed : $!\n";
8302 # Feed input and capture output
8304 if ($stdin && ref($stdin)) {
8305 print EXECSTDINw $$stdin;
8308 if ($stdout && ref($stdout)) {
8310 while(<EXECSTDOUTr>) {
8315 if ($stderr && ref($stderr) && $stderr ne $stdout) {
8317 while(<EXECSTDERRr>) {
8328 =head2 open_readfile(handle, file)
8330 Opens some file for reading. Returns 1 on success, 0 on failure. Pretty much
8331 exactly the same as Perl's open function.
8336 my ($fh, $file) = @_;
8337 $fh = &callers_package($fh);
8338 my $realfile = &translate_filename($file);
8339 &webmin_debug_log('READ', $file) if ($gconfig{'debug_what_read'});
8340 return open($fh, "<".$realfile);
8343 =head2 open_execute_command(handle, command, output?, safe?)
8345 Runs some command, with the specified file handle set to either write to it if
8346 in-or-out is set to 0, or read to it if output is set to 1. The safe flag
8347 indicates if the command modifies the state of the system or not.
8350 sub open_execute_command
8352 my ($fh, $cmd, $mode, $safe) = @_;
8353 $fh = &callers_package($fh);
8354 my $realcmd = &translate_command($cmd);
8355 if (&is_readonly_mode() && !$safe) {
8356 # Don't actually run it
8357 print STDERR "vetoing command $cmd\n";
8360 return open($fh, ">$null_file");
8363 return open($fh, $null_file);
8367 &webmin_debug_log('CMD', "cmd=$realcmd mode=$mode")
8368 if ($gconfig{'debug_what_cmd'});
8370 return open($fh, "| $cmd");
8372 elsif ($mode == 1) {
8373 return open($fh, "$cmd 2>$null_file |");
8375 elsif ($mode == 2) {
8376 return open($fh, "$cmd 2>&1 |");
8380 =head2 translate_filename(filename)
8382 Applies all relevant registered translation functions to a filename. Mostly
8383 for internal use, and typically does nothing.
8386 sub translate_filename
8388 my ($realfile) = @_;
8389 my @funcs = grep { $_->[0] eq &get_module_name() ||
8390 !defined($_->[0]) } @main::filename_callbacks;
8391 foreach my $f (@funcs) {
8393 $realfile = &$func($realfile, @{$f->[2]});
8398 =head2 translate_command(filename)
8400 Applies all relevant registered translation functions to a command. Mostly
8401 for internal use, and typically does nothing.
8404 sub translate_command
8407 my @funcs = grep { $_->[0] eq &get_module_name() ||
8408 !defined($_->[0]) } @main::command_callbacks;
8409 foreach my $f (@funcs) {
8411 $realcmd = &$func($realcmd, @{$f->[2]});
8416 =head2 register_filename_callback(module|undef, &function, &args)
8418 Registers some function to be called when the specified module (or all
8419 modules) tries to open a file for reading and writing. The function must
8420 return the actual file to open. This allows you to override which files
8421 other code actually operates on, via the translate_filename function.
8424 sub register_filename_callback
8426 my ($mod, $func, $args) = @_;
8427 push(@main::filename_callbacks, [ $mod, $func, $args ]);
8430 =head2 register_command_callback(module|undef, &function, &args)
8432 Registers some function to be called when the specified module (or all
8433 modules) tries to execute a command. The function must return the actual
8434 command to run. This allows you to override which commands other other code
8435 actually runs, via the translate_command function.
8438 sub register_command_callback
8440 my ($mod, $func, $args) = @_;
8441 push(@main::command_callbacks, [ $mod, $func, $args ]);
8444 =head2 capture_function_output(&function, arg, ...)
8446 Captures output that some function prints to STDOUT, and returns it. Useful
8447 for functions outside your control that print data when you really want to
8448 manipulate it before output.
8451 sub capture_function_output
8453 my ($func, @args) = @_;
8454 socketpair(SOCKET2, SOCKET1, AF_UNIX, SOCK_STREAM, PF_UNSPEC);
8455 my $old = select(SOCKET1);
8456 my @rv = &$func(@args);
8465 return wantarray ? ($out, \@rv) : $out;
8468 =head2 capture_function_output_tempfile(&function, arg, ...)
8470 Behaves the same as capture_function_output, but uses a temporary file
8471 to avoid buffer full problems.
8474 sub capture_function_output_tempfile
8476 my ($func, @args) = @_;
8477 my $temp = &transname();
8478 open(BUFFER, ">$temp");
8479 my $old = select(BUFFER);
8480 my @rv = &$func(@args);
8483 my $out = &read_file_contents($temp);
8484 &unlink_file($temp);
8485 return wantarray ? ($out, \@rv) : $out;
8488 =head2 modules_chooser_button(field, multiple, [form])
8490 Returns HTML for a button for selecting one or many Webmin modules.
8491 field - Name of the HTML field to place the module names into.
8492 multiple - Set to 1 if multiple modules can be selected.
8493 form - Index of the form on the page.
8496 sub modules_chooser_button
8498 return &theme_modules_chooser_button(@_)
8499 if (defined(&theme_modules_chooser_button));
8500 my $form = defined($_[2]) ? $_[2] : 0;
8501 my $w = $_[1] ? 700 : 500;
8503 if ($_[1] && $gconfig{'db_sizemodules'}) {
8504 ($w, $h) = split(/x/, $gconfig{'db_sizemodules'});
8506 elsif (!$_[1] && $gconfig{'db_sizemodule'}) {
8507 ($w, $h) = split(/x/, $gconfig{'db_sizemodule'});
8509 return "<input type=button onClick='ifield = document.forms[$form].$_[0]; chooser = window.open(\"$gconfig{'webprefix'}/module_chooser.cgi?multi=$_[1]&module=\"+escape(ifield.value), \"chooser\", \"toolbar=no,menubar=no,scrollbars=yes,width=$w,height=$h\"); chooser.ifield = ifield; window.ifield = ifield' value=\"...\">\n";
8512 =head2 substitute_template(text, &hash)
8514 Given some text and a hash reference, for each ocurrance of $FOO or ${FOO} in
8515 the text replaces it with the value of the hash key foo. Also supports blocks
8516 like ${IF-FOO} ... ${ENDIF-FOO}, whose contents are only included if foo is
8517 non-zero, and ${IF-FOO} ... ${ELSE-FOO} ... ${ENDIF-FOO}.
8520 sub substitute_template
8522 # Add some extra fixed parameters to the hash
8523 my %hash = %{$_[1]};
8524 $hash{'hostname'} = &get_system_hostname();
8525 $hash{'webmin_config'} = $config_directory;
8526 $hash{'webmin_etc'} = $config_directory;
8527 $hash{'module_config'} = &get_module_variable('$module_config_directory');
8528 $hash{'webmin_var'} = $var_directory;
8530 # Add time-based parameters, for use in DNS
8531 $hash{'current_time'} = time();
8532 my @tm = localtime($hash{'current_time'});
8533 $hash{'current_year'} = $tm[5]+1900;
8534 $hash{'current_month'} = sprintf("%2.2d", $tm[4]+1);
8535 $hash{'current_day'} = sprintf("%2.2d", $tm[3]);
8536 $hash{'current_hour'} = sprintf("%2.2d", $tm[2]);
8537 $hash{'current_minute'} = sprintf("%2.2d", $tm[1]);
8538 $hash{'current_second'} = sprintf("%2.2d", $tm[0]);
8540 # Actually do the substition
8542 foreach my $s (keys %hash) {
8543 next if ($s eq ''); # Prevent just $ from being subbed
8546 $rv =~ s/\$\{\Q$us\E\}/$sv/g;
8547 $rv =~ s/\$\Q$us\E/$sv/g;
8549 # Replace ${IF}..${ELSE}..${ENDIF} block with first value,
8550 # and ${IF}..${ENDIF} with value
8551 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/$2/g;
8552 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/$2/g;
8554 # Replace $IF..$ELSE..$ENDIF block with first value,
8555 # and $IF..$ENDIF with value
8556 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ELSE-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/$2/g;
8557 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/$2/g;
8559 # Replace ${IFEQ}..${ENDIFEQ} block with first value if
8560 # matching, nothing if not
8561 $rv =~ s/\$\{IFEQ-\Q$us\E-\Q$sv\E\}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-\Q$sv\E\}(\n?)/$2/g;
8562 $rv =~ s/\$\{IFEQ-\Q$us\E-[^\}]+}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-[^\}]+\}(\n?)//g;
8564 # Replace $IFEQ..$ENDIFEQ block with first value if
8565 # matching, nothing if not
8566 $rv =~ s/\$IFEQ-\Q$us\E-\Q$sv\E(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\Q$sv\E(\n?)/$2/g;
8567 $rv =~ s/\$IFEQ-\Q$us\E-\S+(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\S+(\n?)//g;
8570 # Replace ${IF}..${ELSE}..${ENDIF} block with second value,
8571 # and ${IF}..${ENDIF} with nothing
8572 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/$4/g;
8573 $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)//g;
8575 # Replace $IF..$ELSE..$ENDIF block with second value,
8576 # and $IF..$ENDIF with nothing
8577 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ELSE-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/$4/g;
8578 $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)//g;
8580 # Replace ${IFEQ}..${ENDIFEQ} block with nothing
8581 $rv =~ s/\$\{IFEQ-\Q$us\E-[^\}]+}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-[^\}]+\}(\n?)//g;
8582 $rv =~ s/\$IFEQ-\Q$us\E-\S+(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\S+(\n?)//g;
8586 # Now assume any $IF blocks whose variables are not present in the hash
8587 # evaluate to false.
8588 # $IF...$ELSE x $ENDIF => x
8589 $rv =~ s/\$\{IF\-([A-Z]+)\}.*?\$\{ELSE\-\1\}(.*?)\$\{ENDIF\-\1\}/$2/gs;
8590 # $IF...x...$ENDIF => (nothing)
8591 $rv =~ s/\$\{IF\-([A-Z]+)\}.*?\$\{ENDIF\-\1\}//gs;
8592 # ${var} => (nothing)
8593 $rv =~ s/\$\{[A-Z]+\}//g;
8598 =head2 running_in_zone
8600 Returns 1 if the current Webmin instance is running in a Solaris zone. Used to
8601 disable module and features that are not appropriate, like those that modify
8602 mounted filesystems.
8607 return 0 if ($gconfig{'os_type'} ne 'solaris' ||
8608 $gconfig{'os_version'} < 10);
8609 my $zn = `zonename 2>$null_file`;
8611 return $zn && $zn ne "global";
8614 =head2 running_in_vserver
8616 Returns 1 if the current Webmin instance is running in a Linux VServer.
8617 Used to disable modules and features that are not appropriate.
8620 sub running_in_vserver
8622 return 0 if ($gconfig{'os_type'} !~ /^\*-linux$/);
8625 open(MTAB, "/etc/mtab");
8627 my ($dev, $mp) = split(/\s+/, $_);
8628 if ($mp eq "/" && $dev =~ /^\/dev\/hdv/) {
8637 =head2 running_in_xen
8639 Returns 1 if Webmin is running inside a Xen instance, by looking
8640 at /proc/xen/capabilities.
8645 return 0 if (!-r "/proc/xen/capabilities");
8646 my $cap = &read_file_contents("/proc/xen/capabilities");
8647 return $cap =~ /control_d/ ? 0 : 1;
8650 =head2 running_in_openvz
8652 Returns 1 if Webmin is running inside an OpenVZ container, by looking
8653 at /proc/vz/veinfo for a non-zero line.
8656 sub running_in_openvz
8658 return 0 if (!-r "/proc/vz/veinfo");
8659 my $lref = &read_file_lines("/proc/vz/veinfo", 1);
8660 return 0 if (!$lref || !@$lref);
8661 foreach my $l (@$lref) {
8663 my @ll = split(/\s+/, $l);
8664 return 0 if ($ll[0] eq '0');
8669 =head2 list_categories(&modules, [include-empty])
8671 Returns a hash mapping category codes to names, including any custom-defined
8672 categories. The modules parameter must be an array ref of module hash objects,
8673 as returned by get_all_module_infos.
8678 my ($mods, $empty) = @_;
8679 my (%cats, %catnames);
8680 &read_file("$config_directory/webmin.catnames", \%catnames);
8681 foreach my $o (@lang_order_list) {
8682 &read_file("$config_directory/webmin.catnames.$o", \%catnames);
8687 foreach my $m (@$mods) {
8688 my $c = $m->{'category'};
8689 next if ($cats{$c});
8690 if (defined($catnames{$c})) {
8691 $cats{$c} = $catnames{$c};
8693 elsif ($text{"category_$c"}) {
8694 $cats{$c} = $text{"category_$c"};
8697 # try to get category name from module ..
8698 my %mtext = &load_language($m->{'dir'});
8699 if ($mtext{"category_$c"}) {
8700 $cats{$c} = $mtext{"category_$c"};
8703 $c = $m->{'category'} = "";
8704 $cats{$c} = $text{"category_$c"};
8711 =head2 is_readonly_mode
8713 Returns 1 if the current user is in read-only mode, and thus all writes
8714 to files and command execution should fail.
8717 sub is_readonly_mode
8719 if (!defined($main::readonly_mode_cache)) {
8720 my %gaccess = &get_module_acl(undef, "");
8721 $main::readonly_mode_cache = $gaccess{'readonly'} ? 1 : 0;
8723 return $main::readonly_mode_cache;
8726 =head2 command_as_user(user, with-env?, command, ...)
8728 Returns a command to execute some command as the given user, using the
8729 su statement. If on Linux, the /bin/sh shell is forced in case the user
8730 does not have a valid shell. If with-env is set to 1, the -s flag is added
8731 to the su command to read the user's .profile or .bashrc file.
8736 my ($user, $env, @args) = @_;
8737 my @uinfo = getpwnam($user);
8738 if ($uinfo[8] ne "/bin/sh" && $uinfo[8] !~ /\/bash$/) {
8739 # User shell doesn't appear to be valid
8740 if ($gconfig{'os_type'} =~ /-linux$/) {
8741 # Use -s /bin/sh to force it
8742 $shellarg = " -s /bin/sh";
8744 elsif ($gconfig{'os_type'} eq 'freebsd' ||
8745 $gconfig{'os_type'} eq 'solaris' &&
8746 $gconfig{'os_version'} >= 11 ||
8747 $gconfig{'os_type'} eq 'macos') {
8748 # Use -m and force /bin/sh
8749 @args = ( "/bin/sh", "-c", quotemeta(join(" ", @args)) );
8753 my $rv = "su".($env ? " -" : "").$shellarg.
8754 " ".quotemeta($user)." -c ".quotemeta(join(" ", @args));
8758 =head2 list_osdn_mirrors(project, file)
8760 This function is now deprecated in favor of letting sourceforge just
8761 redirect to the best mirror, and now just returns their primary download URL.
8764 sub list_osdn_mirrors
8766 my ($project, $file) = @_;
8767 return ( { 'url' => "http://downloads.sourceforge.net/$project/$file",
8769 'mirror' => 'downloads' } );
8772 =head2 convert_osdn_url(url)
8774 Given a URL like http://osdn.dl.sourceforge.net/sourceforge/project/file.zip
8775 or http://prdownloads.sourceforge.net/project/file.zip , convert it
8776 to a real URL on the sourceforge download redirector.
8779 sub convert_osdn_url
8782 if ($url =~ /^http:\/\/[^\.]+.dl.sourceforge.net\/sourceforge\/([^\/]+)\/(.*)$/ ||
8783 $url =~ /^http:\/\/prdownloads.sourceforge.net\/([^\/]+)\/(.*)$/) {
8784 # Always use the Sourceforge mail download URL, which does
8785 # a location-based redirect for us
8786 my ($project, $file) = ($1, $2);
8787 $url = "http://prdownloads.sourceforge.net/sourceforge/".
8789 return wantarray ? ( $url, 0 ) : $url;
8792 # Some other source .. don't change
8793 return wantarray ? ( $url, 2 ) : $url;
8797 =head2 get_current_dir
8799 Returns the directory the current process is running in.
8805 if ($gconfig{'os_type'} eq 'windows') {
8818 =head2 supports_users
8820 Returns 1 if the current OS supports Unix user concepts and functions like
8821 su , getpw* and so on. This will be true on Linux and other Unixes, but false
8827 return $gconfig{'os_type'} ne 'windows';
8830 =head2 supports_symlinks
8832 Returns 1 if the current OS supports symbolic and hard links. This will not
8833 be the case on Windows.
8836 sub supports_symlinks
8838 return $gconfig{'os_type'} ne 'windows';
8841 =head2 quote_path(path)
8843 Returns a path with safe quoting for the current operating system.
8849 if ($gconfig{'os_type'} eq 'windows' || $path =~ /^[a-z]:/i) {
8850 # Windows only supports "" style quoting
8854 return quotemeta($path);
8858 =head2 get_windows_root
8860 Returns the base windows system directory, like c:/windows.
8863 sub get_windows_root
8865 if ($ENV{'SystemRoot'}) {
8866 my $rv = $ENV{'SystemRoot'};
8871 return -d "c:/windows" ? "c:/windows" : "c:/winnt";
8875 =head2 read_file_contents(file)
8877 Given a filename, returns its complete contents as a string. Effectively
8878 the same as the Perl construct `cat file`.
8881 sub read_file_contents
8883 &open_readfile(FILE, $_[0]) || return undef;
8890 =head2 unix_crypt(password, salt)
8892 Performs Unix encryption on a password, using the built-in crypt function or
8893 the Crypt::UnixCrypt module if the former does not work. The salt parameter
8894 must be either an already-hashed password, or a two-character alpha-numeric
8900 my ($pass, $salt) = @_;
8901 return "" if ($salt !~ /^[a-zA-Z0-9\.\/]{2}/); # same as real crypt
8902 my $rv = eval "crypt(\$pass, \$salt)";
8904 return $rv if ($rv && !$@);
8905 eval "use Crypt::UnixCrypt";
8907 return Crypt::UnixCrypt::crypt($pass, $salt);
8910 &error("Failed to encrypt password : $err");
8914 =head2 split_quoted_string(string)
8916 Given a string like I<foo "bar baz" quux>, returns the array :
8920 sub split_quoted_string
8924 while($str =~ /^"([^"]*)"\s*([\000-\377]*)$/ ||
8925 $str =~ /^'([^']*)'\s*([\000-\377]*)$/ ||
8926 $str =~ /^(\S+)\s*([\000-\377]*)$/) {
8933 =head2 write_to_http_cache(url, file|&data)
8935 Updates the Webmin cache with the contents of the given file, possibly also
8936 clearing out old data. Mainly for internal use by http_download.
8939 sub write_to_http_cache
8941 my ($url, $file) = @_;
8942 return 0 if (!$gconfig{'cache_size'});
8944 # Don't cache downloads that look dynamic
8945 if ($url =~ /cgi-bin/ || $url =~ /\?/) {
8949 # Check if the current module should do caching
8950 if ($gconfig{'cache_mods'} =~ /^\!(.*)$/) {
8951 # Caching all except some modules
8952 my @mods = split(/\s+/, $1);
8953 return 0 if (&indexof(&get_module_name(), @mods) != -1);
8955 elsif ($gconfig{'cache_mods'}) {
8956 # Only caching some modules
8957 my @mods = split(/\s+/, $gconfig{'cache_mods'});
8958 return 0 if (&indexof(&get_module_name(), @mods) == -1);
8964 $size = length($$file);
8967 my @st = stat($file);
8971 if ($size > $gconfig{'cache_size'}) {
8972 # Bigger than the whole cache - so don't save it
8977 $cfile = "$main::http_cache_directory/$cfile";
8979 # See how much we have cached currently, clearing old files
8981 mkdir($main::http_cache_directory, 0700) if (!-d $main::http_cache_directory);
8982 opendir(CACHEDIR, $main::http_cache_directory);
8983 foreach my $f (readdir(CACHEDIR)) {
8984 next if ($f eq "." || $f eq "..");
8985 my $path = "$main::http_cache_directory/$f";
8986 my @st = stat($path);
8987 if ($gconfig{'cache_days'} &&
8988 time()-$st[9] > $gconfig{'cache_days'}*24*60*60) {
8989 # This file is too old .. trash it
8994 push(@cached, [ $path, $st[7], $st[9] ]);
8998 @cached = sort { $a->[2] <=> $b->[2] } @cached;
8999 while($total+$size > $gconfig{'cache_size'} && @cached) {
9000 # Cache is too big .. delete some files until the new one will fit
9001 unlink($cached[0]->[0]);
9002 $total -= $cached[0]->[1];
9006 # Finally, write out the new file
9008 &open_tempfile(CACHEFILE, ">$cfile");
9009 &print_tempfile(CACHEFILE, $$file);
9010 &close_tempfile(CACHEFILE);
9013 my ($ok, $err) = ©_source_dest($file, $cfile);
9019 =head2 check_in_http_cache(url)
9021 If some URL is in the cache and valid, return the filename for it. Mainly
9022 for internal use by http_download.
9025 sub check_in_http_cache
9028 return undef if (!$gconfig{'cache_size'});
9030 # Check if the current module should do caching
9031 if ($gconfig{'cache_mods'} =~ /^\!(.*)$/) {
9032 # Caching all except some modules
9033 my @mods = split(/\s+/, $1);
9034 return 0 if (&indexof(&get_module_name(), @mods) != -1);
9036 elsif ($gconfig{'cache_mods'}) {
9037 # Only caching some modules
9038 my @mods = split(/\s+/, $gconfig{'cache_mods'});
9039 return 0 if (&indexof(&get_module_name(), @mods) == -1);
9044 $cfile = "$main::http_cache_directory/$cfile";
9045 my @st = stat($cfile);
9046 return undef if (!@st || !$st[7]);
9047 if ($gconfig{'cache_days'} && time()-$st[9] > $gconfig{'cache_days'}*24*60*60) {
9052 open(TOUCH, ">>$cfile"); # Update the file time, to keep it in the cache
9057 =head2 supports_javascript
9059 Returns 1 if the current browser is assumed to support javascript.
9062 sub supports_javascript
9064 if (defined(&theme_supports_javascript)) {
9065 return &theme_supports_javascript();
9067 return $ENV{'MOBILE_DEVICE'} ? 0 : 1;
9070 =head2 get_module_name
9072 Returns the name of the Webmin module that called this function. For internal
9073 use only by other API functions.
9078 return &get_module_variable('$module_name');
9081 =head2 get_module_variable(name, [ref])
9083 Returns the value of some variable which is set in the caller's context, if
9084 using the new WebminCore package. For internal use only.
9087 sub get_module_variable
9089 my ($v, $wantref) = @_;
9090 my $slash = $wantref ? "\\" : "";
9091 my $thispkg = &web_libs_package();
9092 if ($thispkg eq 'WebminCore') {
9093 my ($vt, $vn) = split('', $v, 2);
9095 for(my $i=0; ($callpkg) = caller($i); $i++) {
9096 last if ($callpkg ne $thispkg);
9098 return eval "${slash}${vt}${callpkg}::${vn}";
9100 return eval "${slash}${v}";
9103 =head2 clear_time_locale()
9105 Temporarily force the locale to C, until reset_time_locale is called. This is
9106 useful if your code is going to call C<strftime> from the POSIX package, and
9107 you want to ensure that the output is in a consistent format.
9110 sub clear_time_locale
9112 if ($main::clear_time_locale_count == 0) {
9115 $main::clear_time_locale_old = POSIX::setlocale(POSIX::LC_TIME);
9116 POSIX::setlocale(POSIX::LC_TIME, "C");
9119 $main::clear_time_locale_count++;
9122 =head2 reset_time_locale()
9124 Revert the locale to whatever it was before clear_time_locale was called
9127 sub reset_time_locale
9129 if ($main::clear_time_locale_count == 1) {
9131 POSIX::setlocale(POSIX::LC_TIME, $main::clear_time_locale_old);
9132 $main::clear_time_locale_old = undef;
9135 $main::clear_time_locale_count--;
9138 =head2 callers_package(filehandle)
9140 Convert a non-module filehandle like FOO to one qualified with the
9141 caller's caller's package, like fsdump::FOO. For internal use only.
9147 my $callpkg = (caller(1))[0];
9148 my $thispkg = &web_libs_package();
9149 if (!ref($fh) && $fh !~ /::/ &&
9150 $callpkg ne $thispkg && $thispkg eq 'WebminCore') {
9151 $fh = $callpkg."::".$fh;
9156 =head2 web_libs_package()
9158 Returns the package this code is in. We can't always trust __PACKAGE__. For
9162 sub web_libs_package
9164 if ($called_from_webmin_core) {
9165 return "WebminCore";
9170 =head2 get_userdb_string
9172 Returns the URL-style string for connecting to the users and groups database
9175 sub get_userdb_string
9177 return undef if ($main::no_miniserv_userdb);
9179 &get_miniserv_config(\%miniserv);
9180 return $miniserv{'userdb'};
9183 =head2 connect_userdb(string)
9185 Returns a handle for talking to a user database - may be a DBI or LDAP handle.
9186 On failure returns an error message string. In an array context, returns the
9193 my ($proto, $user, $pass, $host, $prefix, $args) = &split_userdb_string($str);
9194 if ($proto eq "mysql") {
9195 # Connect to MySQL with DBI
9196 my $drh = eval "use DBI; DBI->install_driver('mysql');";
9197 $drh || return $text{'sql_emysqldriver'};
9198 my ($host, $port) = split(/:/, $host);
9199 my $cstr = "database=$prefix;host=$host";
9200 $cstr .= ";port=$port" if ($port);
9201 my $dbh = $drh->connect($cstr, $user, $pass, { });
9202 $dbh || return &text('sql_emysqlconnect', $drh->errstr);
9203 return wantarray ? ($dbh, $proto, $prefix, $args) : $dbh;
9205 elsif ($proto eq "postgresql") {
9206 # Connect to PostgreSQL with DBI
9207 my $drh = eval "use DBI; DBI->install_driver('Pg');";
9208 $drh || return $text{'sql_epostgresqldriver'};
9209 my ($host, $port) = split(/:/, $host);
9210 my $cstr = "dbname=$prefix;host=$host";
9211 $cstr .= ";port=$port" if ($port);
9212 my $dbh = $drh->connect($cstr, $user, $pass);
9213 $dbh || return &text('sql_epostgresqlconnect', $drh->errstr);
9214 return wantarray ? ($dbh, $proto, $prefix, $args) : $dbh;
9216 elsif ($proto eq "ldap") {
9217 # Connect with perl LDAP module
9218 eval "use Net::LDAP";
9219 $@ && return $text{'sql_eldapdriver'};
9220 my ($host, $port) = split(/:/, $host);
9221 my $scheme = $args->{'scheme'} || 'ldap';
9223 $port = $scheme eq 'ldaps' ? 636 : 389;
9225 my $ldap = Net::LDAP->new($host,
9227 'scheme' => $scheme);
9228 $ldap || return &text('sql_eldapconnect', $host);
9230 if ($args->{'tls'}) {
9231 # Switch to TLS mode
9232 eval { $mesg = $ldap->start_tls(); };
9233 if ($@ || !$mesg || $mesg->code) {
9234 return &text('sql_eldaptls',
9235 $@ ? $@ : $mesg ? $mesg->error : "Unknown error");
9238 # Login to the server
9240 $mesg = $ldap->bind(dn => $user, password => $pass);
9243 $mesg = $ldap->bind(dn => $user, anonymous => 1);
9245 if (!$mesg || $mesg->code) {
9246 return &text('sql_eldaplogin', $user,
9247 $mesg ? $mesg->error : "Unknown error");
9249 return wantarray ? ($ldap, $proto, $prefix, $args) : $ldap;
9252 return "Unknown protocol $proto";
9256 =head2 disconnect_userdb(string, &handle)
9258 Closes a handle opened by connect_userdb
9261 sub disconnect_userdb
9264 if ($str =~ /^(mysql|postgresql):/) {
9266 if (!$h->{'AutoCommit'}) {
9271 elsif ($str =~ /^ldap:/) {
9278 =head2 split_userdb_string(string)
9280 Converts a string like mysql://user:pass@host/db into separate parts
9283 sub split_userdb_string
9286 if ($str =~ /^([a-z]+):\/\/([^:]*):([^\@]*)\@([a-z0-9\.\-\_]+)\/([^\?]+)(\?(.*))?$/) {
9287 my ($proto, $user, $pass, $host, $prefix, $argstr) =
9288 ($1, $2, $3, $4, $5, $7);
9289 my %args = map { split(/=/, $_, 2) } split(/\&/, $argstr);
9290 return ($proto, $user, $pass, $host, $prefix, \%args);
9295 $done_web_lib_funcs = 1;