=cut
+#use warnings;
use Socket;
use POSIX;
+eval "use Socket6";
+$ipv6_module_error = $@;
use vars qw($user_risk_level $loaded_theme_library $wait_for_input
$done_webmin_header $trust_unknown_referers $unsafe_index_cgi
%done_foreign_require $webmin_feedback_address
$user_skill_level $pragma_no_cache $foreign_args);
+# Globals
+use vars qw($module_index_name $number_to_month_map $month_to_number_map
+ $umask_already $default_charset $licence_status $os_type
+ $licence_message $script_name $loaded_theme_oo_library
+ $done_web_lib_funcs $os_version $module_index_link
+ $called_from_webmin_core $ipv6_module_error);
=head2 read_file(file, &hash, [&order], [lowercase], [split-char])
}
}
}
+
+=head2 read_file_cached_with_stat(file, &hash, [&order], [lowercase], [split-char])
+
+Like read_file, but reads from an in-memory cache if the file has already been
+read in this Webmin script AND has not changed.
+
+=cut
+sub read_file_cached_with_stat
+{
+my $realfile = &translate_filename($_[0]);
+my $t = $main::read_file_cache_time{$realfile};
+my @st = stat($realfile);
+if ($t && $st[9] != $t) {
+ # Changed, invalidate cache
+ delete($main::read_file_cache{$realfile});
+ }
+my $rv = &read_file_cached(@_);
+$main::read_file_cache_time{$realfile} = $st[9];
+return $rv;
+}
=head2 write_file(file, &hash, [join-char])
my $tmp_base = $gconfig{'tempdir_'.&get_module_name()} ?
$gconfig{'tempdir_'.&get_module_name()} :
$gconfig{'tempdir'} ? $gconfig{'tempdir'} :
- $ENV{'TEMP'} ? $ENV{'TEMP'} :
- $ENV{'TMP'} ? $ENV{'TMP'} :
+ $ENV{'TEMP'} && $ENV{'TEMP'} ne "/tmp" ? $ENV{'TEMP'} :
+ $ENV{'TMP'} && $ENV{'TMP'} ne "/tmp" ? $ENV{'TMP'} :
-d "c:/temp" ? "c:/temp" : "/tmp/.webmin";
my $tmp_dir = -d $remote_user_info[7] && !$gconfig{'nohometemp'} ?
"$remote_user_info[7]/.tmp" :
if (defined(&theme_header)) {
$module_name = &get_module_name();
&theme_header(@_);
+ $miniserv::page_capture = 1;
return;
}
print "<!doctype html public \"-//W3C//DTD HTML 3.2 Final//EN\">\n";
}
print "$tconfig{'headhtml'}\n" if ($tconfig{'headhtml'});
if ($tconfig{'headinclude'}) {
- local $_;
- open(INC, "$theme_root_directory/$tconfig{'headinclude'}");
- while(<INC>) {
- print;
- }
- close(INC);
+ print &read_file_contents(
+ "$theme_root_directory/$tconfig{'headinclude'}");
}
print "</head>\n";
my $bgcolor = defined($tconfig{'cs_page'}) ? $tconfig{'cs_page'} :
print "</td></tr></table>\n";
print $tconfig{'postheader'};
}
+$miniserv::page_capture = 1;
}
=head2 get_html_title(title)
my $title;
my $os_type = $gconfig{'real_os_type'} || $gconfig{'os_type'};
my $os_version = $gconfig{'real_os_version'} || $gconfig{'os_version'};
+my $host = &get_display_hostname();
if ($gconfig{'sysinfo'} == 1 && $remote_user) {
$title = sprintf "%s : %s on %s (%s %s)\n",
- $msg, $remote_user, &get_display_hostname(),
+ $msg, $remote_user, $host,
$os_type, $os_version;
}
elsif ($gconfig{'sysinfo'} == 4 && $remote_user) {
$title = sprintf "%s on %s (%s %s)\n",
- $remote_user, &get_display_hostname(),
+ $remote_user, $host,
$os_type, $os_version;
}
else {
$title = $msg;
}
if ($gconfig{'showlogin'} && $remote_user) {
- $title = $remote_user." : ".$title;
+ $title = $remote_user.($title ? " : ".$title : "");
+ }
+if ($gconfig{'showhost'}) {
+ $title = $host.($title ? " : ".$title : "");
}
return $title;
}
$ostr = "$os_type $os_version";
}
my $host = &get_display_hostname();
+ my $ver = &get_webmin_version();
$title = $gconfig{'nohostname'} ? $text{'main_title2'} :
- &text('main_title', &get_webmin_version(), $host, $ostr);
+ $gconfig{'showhost'} ? &text('main_title3', $ver, $ostr) :
+ &text('main_title', $ver, $host, $ostr);
if ($gconfig{'showlogin'}) {
- $title = $remote_user." : ".$title;
+ $title = $remote_user.($title ? " : ".$title : "");
+ }
+ if ($gconfig{'showhost'}) {
+ $title = $host.($title ? " : ".$title : "");
}
}
return $title;
}
}
-=head2 popup_header([title], [head-stuff], [body-stuff])
+=head2 popup_header([title], [head-stuff], [body-stuff], [no-body])
Outputs a page header, suitable for a popup window. If no title is given,
absolutely no decorations are output. Also useful in framesets. The parameters
=item body-stuff - HTML attributes to be include in the <body> tag.
+=item no-body - If set to 1, don't generate a body tag
+
=cut
sub popup_header
{
&load_theme_library();
if (defined(&theme_popup_header)) {
&theme_popup_header(@_);
+ $miniserv::page_capture = 1;
return;
}
print "<!doctype html public \"-//W3C//DTD HTML 3.2 Final//EN\">\n";
print $_[1];
print "$tconfig{'headhtml'}\n" if ($tconfig{'headhtml'});
if ($tconfig{'headinclude'}) {
- local $_;
- open(INC, "$theme_root_directory/$tconfig{'headinclude'}");
- while(<INC>) {
- print;
- }
- close(INC);
+ print &read_file_contents(
+ "$theme_root_directory/$tconfig{'headinclude'}");
}
print "</head>\n";
my $bgcolor = defined($tconfig{'cs_page'}) ? $tconfig{'cs_page'} :
defined($gconfig{'cs_text'}) ? $gconfig{'cs_text'} : "000000";
my $bgimage = defined($tconfig{'bgimage'}) ? "background=$tconfig{'bgimage'}"
: "";
-print "<body id='popup' bgcolor=#$bgcolor link=#$link vlink=#$link ",
- "text=#$text $bgimage $tconfig{'inbody'} $_[2]>\n";
-if (defined(&theme_popup_prebody)) {
- &theme_popup_prebody(@_);
+if (!$_[3]) {
+ print "<body id='popup' bgcolor=#$bgcolor link=#$link vlink=#$link ",
+ "text=#$text $bgimage $tconfig{'inbody'} $_[2]>\n";
+ if (defined(&theme_popup_prebody)) {
+ &theme_popup_prebody(@_);
+ }
}
+$miniserv::page_capture = 1;
}
=head2 footer([page, name]+, [noendbody])
=cut
sub footer
{
+$miniserv::page_capture = 0;
&load_theme_library();
my %this_module_info = &get_module_info(&get_module_name());
if (defined(&theme_footer)) {
}
}
-=head2 popup_footer
+=head2 popup_footer([no-body])
Outputs html for a footer for a popup window, started by popup_header.
=cut
sub popup_footer
{
+$miniserv::page_capture = 0;
&load_theme_library();
if (defined(&theme_popup_footer)) {
&theme_popup_footer(@_);
return;
}
-print "</body></html>\n";
+if (!$_[0]) {
+ print "</body>\n";
+ }
+print "</html>\n";
}
=head2 load_theme_library
=cut
sub error
{
+$main::no_miniserv_userdb = 1;
my $msg = join("", @_);
$msg =~ s/<[^>]*>//g;
if (!$main::error_must_die) {
=cut
sub popup_error
{
+$main::no_miniserv_userdb = 1;
&load_theme_library();
if ($main::error_must_die) {
die @_;
elsif ($fmt eq 'yyyy/mm/dd') {
$date = sprintf "%4.4d/%2.2d/%2.2d", $tm[5]+1900, $tm[4]+1, $tm[3];
}
+elsif ($fmt eq 'd. mon yyyy') {
+ $date = sprintf "%d. %s %4.4d",
+ $tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900;
+ }
+elsif ($fmt eq 'dd.mm.yyyy') {
+ $date = sprintf "%2.2d.%2.2d.%4.4d", $tm[3], $tm[4]+1, $tm[5]+1900;
+ }
+elsif ($fmt eq 'yyyy-mm-dd') {
+ $date = sprintf "%4.4d-%2.2d-%2.2d", $tm[5]+1900, $tm[4]+1, $tm[3];
+ }
if (!$only) {
$date .= sprintf " %2.2d:%2.2d", $tm[2], $tm[1];
}
return $rv;
}
-=head2 read_acl(&user-module-hash, &user-list-hash)
+=head2 read_acl(&user-module-hash, &user-list-hash, [&only-users])
Reads the Webmin acl file into the given hash references. The first is indexed
by a combined key of username,module , with the value being set to 1 when
This function is deprecated in favour of foreign_available, which performs a
more comprehensive check of module availability.
+If the only-users array ref parameter is given, the results may be limited to
+users in that list of names.
+
=cut
sub read_acl
{
-if (!defined(%main::acl_hash_cache)) {
+my ($usermod, $userlist, $only) = @_;
+if (!%main::acl_hash_cache) {
+ # Read from local files
local $_;
open(ACL, &acl_filename());
while(<ACL>) {
}
close(ACL);
}
-if ($_[0]) { %{$_[0]} = %main::acl_hash_cache; }
-if ($_[1]) { %{$_[1]} = %main::acl_array_cache; }
+%$usermod = %main::acl_hash_cache if ($usermod);
+%$userlist = %main::acl_array_cache if ($userlist);
+
+# Read from user DB
+my $userdb = &get_userdb_string();
+my ($dbh, $proto, $prefix, $args) =
+ $userdb ? &connect_userdb($userdb) : ( );
+if (ref($dbh)) {
+ if ($proto eq "mysql" || $proto eq "postgresql") {
+ # Select usernames and modules from SQL DB
+ my $cmd = $dbh->prepare(
+ "select webmin_user.name,webmin_user_attr.value ".
+ "from webmin_user,webmin_user_attr ".
+ "where webmin_user.id = webmin_user_attr.id ".
+ "and webmin_user_attr.attr = 'modules' ".
+ ($only ? " and webmin_user.name in (".
+ join(",", map { "'$_'" } @$only).")" : ""));
+ if ($cmd && $cmd->execute()) {
+ while(my ($user, $mods) = $cmd->fetchrow()) {
+ my @mods = split(/\s+/, $mods);
+ foreach my $m (@mods) {
+ $usermod->{$user,$m}++ if ($usermod);
+ }
+ $userlist->{$user} = \@mods if ($userlist);
+ }
+ }
+ $cmd->finish() if ($cmd);
+ }
+ elsif ($proto eq "ldap") {
+ # Find users in LDAP
+ my $filter = '(objectClass='.$args->{'userclass'}.')';
+ if ($only) {
+ my $ufilter =
+ "(|".join("", map { "(cn=$_)" } @$only).")";
+ $filter = "(&".$filter.$ufilter.")";
+ }
+ my $rv = $dbh->search(
+ base => $prefix,
+ filter => $filter,
+ scope => 'sub',
+ attrs => [ 'cn', 'webminModule' ]);
+ if ($rv && !$rv->code) {
+ foreach my $u ($rv->all_entries) {
+ my $user = $u->get_value('cn');
+ my @mods =$u->get_value('webminModule');
+ foreach my $m (@mods) {
+ $usermod->{$user,$m}++ if ($usermod);
+ }
+ $userlist->{$user} = \@mods if ($userlist);
+ }
+ }
+ }
+ &disconnect_userdb($userdb, $dbh);
+ }
}
=head2 acl_filename
return undef if (&is_readonly_mode());
my %miniserv;
&get_miniserv_config(\%miniserv) || return;
+if ($main::webmin_script_type eq 'web' && !$ENV{"MINISERV_CONFIG"} &&
+ !$ENV{'MINISERV_PID'}) {
+ # Running under some web server other than miniserv, so do nothing
+ return;
+ }
my $i;
if ($gconfig{'os_type'} ne 'windows') {
my ($pid, $addr, $i);
$miniserv{'inetd'} && return;
my @oldst = stat($miniserv{'pidfile'});
- open(PID, $miniserv{'pidfile'}) || &error("Failed to open PID file");
- chop($pid = <PID>);
- close(PID);
- if (!$pid) { &error("Invalid PID file"); }
+ $pid = $ENV{'MINISERV_PID'};
+ if (!$pid || !kill(0, $pid)) {
+ if (!open(PID, $miniserv{'pidfile'})) {
+ print STDERR "PID file $miniserv{'pidfile'} does ",
+ "not exist\n";
+ return;
+ }
+ chop($pid = <PID>);
+ close(PID);
+ if (!$pid) {
+ print STDERR "Invalid PID file $miniserv{'pidfile'}\n";
+ return;
+ }
+ if (!kill(0, $pid)) {
+ print STDERR "PID $pid from file $miniserv{'pidfile'} ",
+ "is not valid\n";
+ return;
+ }
+ }
# Just signal miniserv to restart
&kill_logged('HUP', $pid) || &error("Incorrect Webmin PID $pid");
}
if (!$nowait) {
- # wait for miniserv to come back up
- $addr = inet_aton($miniserv{'bind'} ? $miniserv{'bind'} : "127.0.0.1");
+ # Wait for miniserv to come back up
+ my $addr = $miniserv{'bind'} || "127.0.0.1";
my $ok = 0;
for($i=0; $i<20; $i++) {
+ my $err;
sleep(1);
- socket(STEST, PF_INET, SOCK_STREAM, getprotobyname("tcp"));
- my $rv = connect(STEST,
- pack_sockaddr_in($miniserv{'port'}, $addr));
+ &open_socket($addr, $miniserv{'port'}, STEST, \$err);
close(STEST);
- last if ($rv && ++$ok >= 2);
+ last if (!$err && ++$ok >= 2);
}
$i < 20 || &error("Failed to restart Webmin server!");
}
return undef if (&is_readonly_mode());
my %miniserv;
&get_miniserv_config(\%miniserv) || return;
+if ($main::webmin_script_type eq 'web' && !$ENV{"MINISERV_CONFIG"} &&
+ !$ENV{'MINISERV_PID'}) {
+ # Running under some web server other than miniserv, so do nothing
+ return;
+ }
if ($gconfig{'os_type'} ne 'windows') {
# Send a USR1 signal to re-read the config
my ($pid, $addr, $i);
$miniserv{'inetd'} && return;
- open(PID, $miniserv{'pidfile'}) || &error("Failed to open PID file");
- chop($pid = <PID>);
- close(PID);
- if (!$pid) { &error("Invalid PID file"); }
+ $pid = $ENV{'MINISERV_PID'};
+ if (!$pid || !kill(0, $pid)) {
+ if (!open(PID, $miniserv{'pidfile'})) {
+ print STDERR "PID file $miniserv{'pidfile'} does ",
+ "not exist\n";
+ return;
+ }
+ chop($pid = <PID>);
+ close(PID);
+ if (!$pid) {
+ print STDERR "Invalid PID file $miniserv{'pidfile'}\n";
+ return;
+ }
+ if (!kill(0, $pid)) {
+ print STDERR "PID $pid from file $miniserv{'pidfile'} ",
+ "is not valid\n";
+ return;
+ }
+ }
&kill_logged('USR1', $pid) || &error("Incorrect Webmin PID $pid");
# Make sure this didn't kill Webmin!
return 0;
}
if ($_[0]->{'novserver'} && &running_in_vserver()) {
- # Not supported in a Linux vserver
+ # Not supported in a Linux Vserver
+ return 0;
+ }
+if ($_[0]->{'noopenvz'} && &running_in_openvz()) {
+ # Not supported in an OpenVZ container
return 0;
}
return 1 if (!$oss || $oss eq '*');
my @headers;
push(@headers, [ "Host", $host ]);
push(@headers, [ "User-agent", "Webmin" ]);
+push(@headers, [ "Accept-language", "en" ]);
if ($user) {
my $auth = &encode_base64("$user:$pass");
$auth =~ tr/\r\n//d;
else { &error($h); }
}
&complete_http_download($h, $dest, $error, $cbfunc, $osdn, $host, $port,
- $headers, $ssl);
+ $headers, $ssl, $nocache);
if ((!$error || !$$error) && !$nocache) {
&write_to_http_cache($url, $dest);
}
}
-=head2 complete_http_download(handle, destfile, [&error], [&callback], [osdn], [oldhost], [oldport], [&send-headers], [old-ssl])
+=head2 complete_http_download(handle, destfile, [&error], [&callback], [osdn], [oldhost], [oldport], [&send-headers], [old-ssl], [no-cache])
Do a HTTP download, after the headers have been sent. For internal use only,
typically called by http_download.
my ($host, $port, $page, $ssl);
if ($header{'location'} =~ /^(http|https):\/\/([^:]+):(\d+)(\/.*)?$/) {
$ssl = $1 eq 'https' ? 1 : 0;
- $host = $2; $port = $3; $page = $4 || "/";
+ $host = $2;
+ $port = $3;
+ $page = $4 || "/";
}
elsif ($header{'location'} =~ /^(http|https):\/\/([^:\/]+)(\/.*)?$/) {
$ssl = $1 eq 'https' ? 1 : 0;
- $host = $2; $port = 80; $page = $3 || "/";
+ $host = $2;
+ $port = $ssl ? 443 : 80;
+ $page = $3 || "/";
}
elsif ($header{'location'} =~ /^\// && $_[5]) {
# Relative to same server
$page =~ s/ /%20/g;
$page .= "?".$params if (defined($params));
&http_download($host, $port, $page, $_[1], $_[2], $cbfunc, $ssl,
- undef, undef, undef, $_[4], 0, $_[7]);
+ undef, undef, undef, $_[4], $_[9], $_[7]);
}
else {
# read data
}
-=head2 ftp_download(host, file, destfile, [&error], [&callback], [user, pass], [port])
+=head2 http_post(host, port, page, content, destfile, [&error], [&callback], [sslmode], [user, pass], [timeout], [osdn-convert], [no-cache], [&headers])
+
+Posts data to an HTTP url and downloads the response to a local file or string. The parameters are :
+
+=item host - The hostname part of the URL, such as www.google.com
+
+=item port - The HTTP port number, such as 80
+
+=item page - The filename part of the URL, like /index.html
+
+=item content - The data to post
+
+=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.
+
+=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.
+
+=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.
+
+=item sslmode - If set to 1, an HTTPS connection is used instead of HTTP.
+
+=item user - If set, HTTP authentication is done with this username.
+
+=item pass - The HTTP password to use with the username above.
+
+=item timeout - A timeout in seconds to wait for the TCP connection to be established before failing.
+
+=item osdn-convert - If set to 1, URL for downloads from sourceforge are converted to use an appropriate mirror site.
+
+=item no-cache - If set to 1, Webmin's internal caching for this URL is disabled.
+
+=item headers - If set to a hash ref of additional HTTP headers, they will be added to the request.
+
+=cut
+sub http_post
+{
+my ($host, $port, $page, $content, $dest, $error, $cbfunc, $ssl, $user, $pass,
+ $timeout, $osdn, $nocache, $headers) = @_;
+if ($gconfig{'debug_what_net'}) {
+ &webmin_debug_log('HTTP', "host=$host port=$port page=$page ssl=$ssl".
+ ($user ? " user=$user pass=$pass" : "").
+ (ref($dest) ? "" : " dest=$dest"));
+ }
+if ($osdn) {
+ # Convert OSDN URL first
+ my $prot = $ssl ? "https://" : "http://";
+ my $portstr = $ssl && $port == 443 ||
+ !$ssl && $port == 80 ? "" : ":$port";
+ ($host, $port, $page, $ssl) = &parse_http_url(
+ &convert_osdn_url($prot.$host.$portstr.$page));
+ }
+
+# Build headers
+my @headers;
+push(@headers, [ "Host", $host ]);
+push(@headers, [ "User-agent", "Webmin" ]);
+push(@headers, [ "Accept-language", "en" ]);
+push(@headers, [ "Content-type", "application/x-www-form-urlencoded" ]);
+push(@headers, [ "Content-length", length($content) ]);
+if ($user) {
+ my $auth = &encode_base64("$user:$pass");
+ $auth =~ tr/\r\n//d;
+ push(@headers, [ "Authorization", "Basic $auth" ]);
+ }
+foreach my $hname (keys %$headers) {
+ push(@headers, [ $hname, $headers->{$hname} ]);
+ }
+
+# Actually download it
+$main::download_timed_out = undef;
+local $SIG{ALRM} = \&download_timeout;
+alarm($timeout || 60);
+my $h = &make_http_connection($host, $port, $ssl, "POST", $page, \@headers);
+alarm(0);
+$h = $main::download_timed_out if ($main::download_timed_out);
+if (!ref($h)) {
+ if ($error) { $$error = $h; return; }
+ else { &error($h); }
+ }
+&write_http_connection($content."\r\n");
+&complete_http_download($h, $dest, $error, $cbfunc, $osdn, $host, $port,
+ $headers, $ssl, $nocache);
+if ((!$error || !$$error) && !$nocache) {
+ &write_to_http_cache($url, $dest);
+ }
+}
+
+=head2 ftp_download(host, file, destfile, [&error], [&callback], [user, pass], [port], [no-cache])
Download data from an FTP site to a local file. The parameters are :
=item port - FTP server port number, which defaults to 21 if not set.
+=item no-cache - If set to 1, Webmin's internal caching for this URL is disabled.
+
=cut
sub ftp_download
{
-my ($host, $file, $dest, $error, $cbfunc, $user, $pass, $port) = @_;
+my ($host, $file, $dest, $error, $cbfunc, $user, $pass, $port, $nocache) = @_;
$port ||= 21;
if ($gconfig{'debug_what_net'}) {
&webmin_debug_log('FTP', "host=$host port=$port file=$file".
(ref($dest) ? "" : " dest=$dest"));
}
my ($buf, @n);
-my $cbfunc = $_[4];
+$cbfunc = $_[4];
if (&is_readonly_mode()) {
if ($_[3]) { ${$_[3]} = "FTP connections not allowed in readonly mode";
return 0; }
# Check if we already have cached the URL
my $url = "ftp://".$host.$file;
my $cfile = &check_in_http_cache($url);
-if ($cfile) {
+if ($cfile && !$nocache) {
# Yes! Copy to dest file or variable
&$cbfunc(6, $url) if ($cbfunc);
if (ref($dest)) {
print SOCK "Proxy-Authorization: Basic $auth\r\n";
}
print SOCK "\r\n";
- &complete_http_download({ 'fh' => "SOCK" }, $_[2], $_[3], $_[4]);
+ &complete_http_download({ 'fh' => "SOCK" }, $_[2], $_[3], $_[4],
+ undef, undef, undef, undef, 0, $nocache);
$connected = 1;
}
elsif (!$gconfig{'proxy_fallback'}) {
if ($gconfig{'debug_what_net'}) {
&webmin_debug_log('TCP', "host=$host port=$port");
}
-if (!socket($fh, PF_INET, SOCK_STREAM, getprotobyname("tcp"))) {
- if ($err) { $$err = "Failed to create socket : $!"; return 0; }
- else { &error("Failed to create socket : $!"); }
- }
-my $addr;
-if (!($addr = inet_aton($host))) {
- if ($err) { $$err = "Failed to lookup IP address for $host"; return 0; }
- else { &error("Failed to lookup IP address for $host"); }
+
+# Lookup IP address for the host. Try v4 first, and failing that v6
+my $ip;
+my $proto = getprotobyname("tcp");
+if ($ip = &to_ipaddress($host)) {
+ # Create IPv4 socket and connection
+ if (!socket($fh, PF_INET(), SOCK_STREAM, $proto)) {
+ my $msg = "Failed to create socket : $!";
+ if ($err) { $$err = $msg; return 0; }
+ else { &error($msg); }
+ }
+ my $addr = inet_aton($ip);
+ if ($gconfig{'bind_proxy'}) {
+ # BIND to outgoing IP
+ if (!bind($fh,pack_sockaddr_in(0, inet_aton($gconfig{'bind_proxy'})))) {
+ my $msg = "Failed to bind to source address : $!";
+ if ($err) { $$err = $msg; return 0; }
+ else { &error($msg); }
+ }
+ }
+ if (!connect($fh, pack_sockaddr_in($port, $addr))) {
+ my $msg = "Failed to connect to $host:$port : $!";
+ if ($err) { $$err = $msg; return 0; }
+ else { &error($msg); }
+ }
}
-if ($gconfig{'bind_proxy'}) {
- if (!bind($fh,pack_sockaddr_in(0, inet_aton($gconfig{'bind_proxy'})))) {
- if ($err) { $$err = "Failed to bind to source address : $!"; return 0; }
- else { &error("Failed to bind to source address : $!"); }
+elsif ($ip = &to_ip6address($host)) {
+ # Create IPv6 socket and connection
+ if (!&supports_ipv6()) {
+ $msg = "IPv6 connections are not supported";
+ if ($err) { $$err = $msg; return 0; }
+ else { &error($msg); }
+ }
+ if (!socket($fh, Socket6::PF_INET6(), SOCK_STREAM, $proto)) {
+ my $msg = "Failed to create IPv6 socket : $!";
+ if ($err) { $$err = $msg; return 0; }
+ else { &error($msg); }
+ }
+ my $addr = inet_pton(Socket6::AF_INET6(), $ip);
+ if (!connect($fh, pack_sockaddr_in6($port, $addr))) {
+ my $msg = "Failed to IPv6 connect to $host:$port : $!";
+ if ($err) { $$err = $msg; return 0; }
+ else { &error($msg); }
}
}
-if (!connect($fh, pack_sockaddr_in($port, $addr))) {
- if ($err) { $$err = "Failed to connect to $host:$port : $!"; return 0; }
- else { &error("Failed to connect to $host:$port : $!"); }
+else {
+ # Resolution failed
+ my $msg = "Failed to lookup IP address for $host";
+ if ($err) { $$err = $msg; return 0; }
+ else { &error($msg); }
}
-my $old = select($fh); $| =1; select($old);
+
+# Disable buffering
+my $old = select($fh);
+$| = 1;
+select($old);
return 1;
}
sub to_ipaddress
{
if (&check_ipaddress($_[0])) {
- return $_[0];
+ return $_[0]; # Already in v4 format
+ }
+elsif (&check_ip6address($_[0])) {
+ return undef; # A v6 address cannot be converted to v4
}
else {
my $hn = gethostbyname($_[0]);
}
}
+=head2 to_ip6address(hostname)
+
+Converts a hostname to IPv6 address, or returns undef if it cannot be resolved.
+
+=cut
+sub to_ip6address
+{
+if (&check_ip6address($_[0])) {
+ return $_[0]; # Already in v6 format
+ }
+elsif (&check_ipaddress($_[0])) {
+ return undef; # A v4 address cannot be v6
+ }
+elsif (!&supports_ipv6()) {
+ return undef; # Cannot lookup
+ }
+else {
+ # Perform IPv6 DNS lookup
+ my $inaddr;
+ (undef, undef, undef, $inaddr) =
+ getaddrinfo($_[0], undef, Socket6::AF_INET6(), SOCK_STREAM);
+ return undef if (!$inaddr);
+ my $addr;
+ (undef, $addr) = unpack_sockaddr_in6($inaddr);
+ return inet_ntop(Socket6::AF_INET6(), $addr);
+ }
+}
+
+=head2 to_hostname(ipv4|ipv6-address)
+
+Reverse-resolves an IPv4 or 6 address to a hostname
+
+=cut
+sub to_hostname
+{
+my ($addr) = @_;
+if (&check_ip6address($addr) && &supports_ipv6()) {
+ return gethostbyaddr(inet_pton(Socket6::AF_INET6(), $addr),
+ Socket6::AF_INET6());
+ }
+else {
+ return gethostbyaddr(inet_aton($addr), AF_INET);
+ }
+}
+
=head2 icons_table(&links, &titles, &icons, [columns], [href], [width], [height], &befores, &afters)
Renders a 4-column table of icons. The useful parameters are :
foreach my $f (@files) {
my $eol = $_[1] || $main::file_cache_eol{$f} || "\n";
if (!$main::file_cache_noflush{$f}) {
+ no warnings; # XXX Bareword file handles should go away
&open_tempfile(FLUSHFILE, ">$f");
foreach my $line (@{$main::file_cache{$f}}) {
(print FLUSHFILE $line,$eol) ||
# Check list of allowed modules
my %acl;
-&read_acl(\%acl, undef);
+&read_acl(\%acl, undef, [ $base_remote_user ]);
return 0 if (!$acl{$base_remote_user,$_[0]} &&
!$acl{$base_remote_user,'*'});
my $rbacs = &get_rbac_module_acl($remote_user, $_[0]);
return 0 if (!$rbacs);
}
- elsif ($gconfig{'rbacdeny_'.$u}) {
+ elsif ($gconfig{'rbacdeny_'.$base_remote_user}) {
# If denying access to modules not specifically allowed by
# RBAC, then prevent access
return 0;
@files = ( $mod."-lib.pl" );
}
}
-my @files = grep { !$main::done_foreign_require{$pkg,$_} } @files;
+@files = grep { !$main::done_foreign_require{$pkg,$_} } @files;
return 1 if (!@files);
foreach my $f (@files) {
$main::done_foreign_require{$pkg,$f}++;
return defined(&$func);
}
-=head2 get_system_hostname([short])
+=head2 get_system_hostname([short], [skip-file])
Returns the hostname of this system. If the short parameter is set to 1,
then the domain name is not prepended - otherwise, Webmin will attempt to get
sub get_system_hostname
{
my $m = int($_[0]);
+my $skipfile = $_[1];
if (!$main::get_system_hostname[$m]) {
if ($gconfig{'os_type'} ne 'windows') {
# Try some common Linux hostname files first
my $fromfile;
- if ($gconfig{'os_type'} eq 'redhat-linux') {
+ if ($skipfile) {
+ # Never get from file
+ }
+ elsif ($gconfig{'os_type'} eq 'redhat-linux') {
my %nc;
&read_env_file("/etc/sysconfig/network", \%nc);
if ($nc{'HOSTNAME'}) {
}
}
- # If we found a hostname, use it if value
+ # If we found a hostname in a file, use it
if ($fromfile && ($m || $fromfile =~ /\./)) {
if ($m) {
$fromfile =~ s/\..*$//;
}
elsif ($u ne '') {
# Use normal Webmin ACL, if a user is set
- &read_file_cached("$config_directory/$m/$u.acl", \%rv);
- if ($remote_user ne $base_remote_user && !defined($_[0])) {
- &read_file_cached("$config_directory/$m/$remote_user.acl",\%rv);
+ my $userdb = &get_userdb_string();
+ my $foundindb = 0;
+ if ($userdb && ($u ne $base_remote_user || $remote_user_proto)) {
+ # Look for this user in the user/group DB, if one is defined
+ # and if the user might be in the DB
+ my ($dbh, $proto, $prefix, $args) = &connect_userdb($userdb);
+ ref($dbh) || &error(&text('euserdbacl', $dbh));
+ if ($proto eq "mysql" || $proto eq "postgresql") {
+ # Find the user in the SQL DB
+ my $cmd = $dbh->prepare(
+ "select id from webmin_user where name = ?");
+ $cmd && $cmd->execute($u) ||
+ &error(&text('euserdbacl', $dbh->errstr));
+ my ($id) = $cmd->fetchrow();
+ $foundindb = 1 if (defined($id));
+ $cmd->finish();
+
+ # Fetch ACLs with SQL
+ if ($foundindb) {
+ my $cmd = $dbh->prepare(
+ "select attr,value from webmin_user_acl ".
+ "where id = ? and module = ?");
+ $cmd && $cmd->execute($id, $m) ||
+ &error(&text('euserdbacl', $dbh->errstr));
+ while(my ($a, $v) = $cmd->fetchrow()) {
+ $rv{$a} = $v;
+ }
+ $cmd->finish();
+ }
+ }
+ elsif ($proto eq "ldap") {
+ # Find user in LDAP
+ my $rv = $dbh->search(
+ base => $prefix,
+ filter => '(&(cn='.$u.')(objectClass='.
+ $args->{'userclass'}.'))',
+ scope => 'sub');
+ if (!$rv || $rv->code) {
+ &error(&text('euserdbacl',
+ $rv ? $rv->error : "Unknown error"));
+ }
+ my ($user) = $rv->all_entries;
+
+ # Find ACL sub-object for the module
+ my $ldapm = $m || "global";
+ if ($user) {
+ my $rv = $dbh->search(
+ base => $user->dn(),
+ filter => '(cn='.$ldapm.')',
+ scope => 'one');
+ if (!$rv || $rv->code) {
+ &error(&text('euserdbacl',
+ $rv ? $rv->error : "Unknown error"));
+ }
+ my ($acl) = $rv->all_entries;
+ if ($acl) {
+ foreach my $av ($acl->get_value(
+ 'webminAclEntry')) {
+ my ($a, $v) = split(/=/, $av,2);
+ $rv{$a} = $v;
+ }
+ }
+ }
+ }
+ &disconnect_userdb($userdb, $dbh);
+ }
+
+ if (!$foundindb) {
+ # Read from local files
+ &read_file_cached("$config_directory/$m/$u.acl", \%rv);
+ if ($remote_user ne $base_remote_user && !defined($_[0])) {
+ &read_file_cached(
+ "$config_directory/$m/$remote_user.acl",\%rv);
+ }
}
}
if ($tconfig{'preload_functions'}) {
return %rv;
}
-=head2 get_group_module_acl(group, [module])
+=head2 get_group_module_acl(group, [module], [no-default])
Returns the ACL for a Webmin group, in an optional module (which defaults to
the current module).
my $m = defined($_[1]) ? $_[1] : &get_module_name();
my $mdir = &module_root_directory($m);
my %rv;
-&read_file_cached("$mdir/defaultacl", \%rv);
-&read_file_cached("$config_directory/$m/$g.gacl", \%rv);
+if (!$_[2]) {
+ &read_file_cached("$mdir/defaultacl", \%rv);
+ }
+
+my $userdb = &get_userdb_string();
+my $foundindb = 0;
+if ($userdb) {
+ # Look for this group in the user/group DB
+ my ($dbh, $proto, $prefix, $args) = &connect_userdb($userdb);
+ ref($dbh) || &error(&text('egroupdbacl', $dbh));
+ if ($proto eq "mysql" || $proto eq "postgresql") {
+ # Find the group in the SQL DB
+ my $cmd = $dbh->prepare(
+ "select id from webmin_group where name = ?");
+ $cmd && $cmd->execute($g) ||
+ &error(&text('egroupdbacl', $dbh->errstr));
+ my ($id) = $cmd->fetchrow();
+ $foundindb = 1 if (defined($id));
+ $cmd->finish();
+
+ # Fetch ACLs with SQL
+ if ($foundindb) {
+ my $cmd = $dbh->prepare(
+ "select attr,value from webmin_group_acl ".
+ "where id = ? and module = ?");
+ $cmd && $cmd->execute($id, $m) ||
+ &error(&text('egroupdbacl', $dbh->errstr));
+ while(my ($a, $v) = $cmd->fetchrow()) {
+ $rv{$a} = $v;
+ }
+ $cmd->finish();
+ }
+ }
+ elsif ($proto eq "ldap") {
+ # Find group in LDAP
+ my $rv = $dbh->search(
+ base => $prefix,
+ filter => '(&(cn='.$g.')(objectClass='.
+ $args->{'groupclass'}.'))',
+ scope => 'sub');
+ if (!$rv || $rv->code) {
+ &error(&text('egroupdbacl',
+ $rv ? $rv->error : "Unknown error"));
+ }
+ my ($group) = $rv->all_entries;
+
+ # Find ACL sub-object for the module
+ my $ldapm = $m || "global";
+ if ($group) {
+ my $rv = $dbh->search(
+ base => $group->dn(),
+ filter => '(cn='.$ldapm.')',
+ scope => 'one');
+ if (!$rv || $rv->code) {
+ &error(&text('egroupdbacl',
+ $rv ? $rv->error : "Unknown error"));
+ }
+ my ($acl) = $rv->all_entries;
+ if ($acl) {
+ foreach my $av ($acl->get_value(
+ 'webminAclEntry')) {
+ my ($a, $v) = split(/=/, $av, 2);
+ $rv{$a} = $v;
+ }
+ }
+ }
+ }
+ &disconnect_userdb($userdb, $dbh);
+ }
+if (!$foundindb) {
+ # Read from local files
+ &read_file_cached("$config_directory/$m/$g.gacl", \%rv);
+ }
if (defined(&theme_get_module_acl)) {
%rv = &theme_get_module_acl($g, $m, \%rv);
}
return %rv;
}
-=head2 save_module_acl(&acl, [user], [module])
+=head2 save_module_acl(&acl, [user], [module], [never-update-group])
Updates the acl hash for some user and module. The parameters are :
-=item acl - Hash reference for the new access control options.
+=item acl - Hash reference for the new access control options, or undef to clear
=item user - User to update, defaulting to the current user.
=item module - Module to update, defaulting to the caller.
+=item never-update-group - Never update the user's group's ACL
+
=cut
sub save_module_acl
{
my $u = defined($_[1]) ? $_[1] : $base_remote_user;
my $m = defined($_[2]) ? $_[2] : &get_module_name();
-if (&foreign_check("acl")) {
+if (!$_[3] && &foreign_check("acl")) {
# Check if this user is a member of a group, and if he gets the
# module from a group. If so, update its ACL as well
&foreign_require("acl", "acl-lib.pl");
&save_group_module_acl($_[0], $group->{'name'}, $m);
}
}
-if (!-d "$config_directory/$m") {
- mkdir("$config_directory/$m", 0755);
+
+my $userdb = &get_userdb_string();
+my $foundindb = 0;
+if ($userdb && ($u ne $base_remote_user || $remote_user_proto)) {
+ # Look for this user in the user/group DB
+ my ($dbh, $proto, $prefix, $args) = &connect_userdb($userdb);
+ ref($dbh) || &error(&text('euserdbacl', $dbh));
+ if ($proto eq "mysql" || $proto eq "postgresql") {
+ # Find the user in the SQL DB
+ my $cmd = $dbh->prepare(
+ "select id from webmin_user where name = ?");
+ $cmd && $cmd->execute($u) ||
+ &error(&text('euserdbacl2', $dbh->errstr));
+ my ($id) = $cmd->fetchrow();
+ $foundindb = 1 if (defined($id));
+ $cmd->finish();
+
+ # Replace ACLs for user
+ if ($foundindb) {
+ my $cmd = $dbh->prepare("delete from webmin_user_acl ".
+ "where id = ? and module = ?");
+ $cmd && $cmd->execute($id, $m) ||
+ &error(&text('euserdbacl', $dbh->errstr));
+ $cmd->finish();
+ if ($_[0]) {
+ my $cmd = $dbh->prepare(
+ "insert into webmin_user_acl ".
+ "(id,module,attr,value) values (?,?,?,?)");
+ $cmd || &error(&text('euserdbacl2',
+ $dbh->errstr));
+ foreach my $a (keys %{$_[0]}) {
+ $cmd->execute($id,$m,$a,$_[0]->{$a}) ||
+ &error(&text('euserdbacl2',
+ $dbh->errstr));
+ $cmd->finish();
+ }
+ }
+ }
+ }
+ elsif ($proto eq "ldap") {
+ # Find the user in LDAP
+ my $rv = $dbh->search(
+ base => $prefix,
+ filter => '(&(cn='.$u.')(objectClass='.
+ $args->{'userclass'}.'))',
+ scope => 'sub');
+ if (!$rv || $rv->code) {
+ &error(&text('euserdbacl',
+ $rv ? $rv->error : "Unknown error"));
+ }
+ my ($user) = $rv->all_entries;
+
+ if ($user) {
+ # Find the ACL sub-object for the module
+ $foundindb = 1;
+ my $ldapm = $m || "global";
+ my $rv = $dbh->search(
+ base => $user->dn(),
+ filter => '(cn='.$ldapm.')',
+ scope => 'one');
+ if (!$rv || $rv->code) {
+ &error(&text('euserdbacl',
+ $rv ? $rv->error : "Unknown error"));
+ }
+ my ($acl) = $rv->all_entries;
+
+ my @al;
+ foreach my $a (keys %{$_[0]}) {
+ push(@al, $a."=".$_[0]->{$a});
+ }
+ if ($acl) {
+ # Update attributes
+ $rv = $dbh->modify($acl->dn(),
+ replace => { "webminAclEntry", \@al });
+ }
+ else {
+ # Add a sub-object
+ my @attrs = ( "cn", $ldapm,
+ "objectClass", "webminAcl",
+ "webminAclEntry", \@al );
+ $rv = $dbh->add("cn=".$ldapm.",".$user->dn(),
+ attr => \@attrs);
+ }
+ if (!$rv || $rv->code) {
+ &error(&text('euserdbacl2',
+ $rv ? $rv->error : "Unknown error"));
+ }
+ }
+ }
+ &disconnect_userdb($userdb, $dbh);
+ }
+
+if (!$foundindb) {
+ # Save ACL to local file
+ if (!-d "$config_directory/$m") {
+ mkdir("$config_directory/$m", 0755);
+ }
+ if ($_[0]) {
+ &write_file("$config_directory/$m/$u.acl", $_[0]);
+ }
+ else {
+ &unlink_file("$config_directory/$m/$u.acl");
+ }
}
-&write_file("$config_directory/$m/$u.acl", $_[0]);
}
-=head2 save_group_module_acl(&acl, group, [module])
+=head2 save_group_module_acl(&acl, group, [module], [never-update-group])
Updates the acl hash for some group and module. The parameters are :
=item module - Module to update, defaulting to the caller.
+=item never-update-group - Never update the parent group's ACL
+
=cut
sub save_group_module_acl
{
my $g = $_[1];
my $m = defined($_[2]) ? $_[2] : &get_module_name();
-if (&foreign_check("acl")) {
+if (!$_[3] && &foreign_check("acl")) {
# Check if this group is a member of a group, and if it gets the
# module from a group. If so, update the parent ACL as well
&foreign_require("acl", "acl-lib.pl");
&save_group_module_acl($_[0], $group->{'name'}, $m);
}
}
-if (!-d "$config_directory/$m") {
- mkdir("$config_directory/$m", 0755);
+
+my $userdb = &get_userdb_string();
+my $foundindb = 0;
+if ($userdb) {
+ # Look for this group in the user/group DB
+ my ($dbh, $proto, $prefix, $args) = &connect_userdb($userdb);
+ ref($dbh) || &error(&text('egroupdbacl', $dbh));
+ if ($proto eq "mysql" || $proto eq "postgresql") {
+ # Find the group in the SQL DB
+ my $cmd = $dbh->prepare(
+ "select id from webmin_group where name = ?");
+ $cmd && $cmd->execute($g) ||
+ &error(&text('egroupdbacl2', $dbh->errstr));
+ my ($id) = $cmd->fetchrow();
+ $foundindb = 1 if (defined($id));
+ $cmd->finish();
+
+ # Replace ACLs for group
+ if ($foundindb) {
+ my $cmd = $dbh->prepare("delete from webmin_group_acl ".
+ "where id = ? and module = ?");
+ $cmd && $cmd->execute($id, $m) ||
+ &error(&text('egroupdbacl', $dbh->errstr));
+ $cmd->finish();
+ if ($_[0]) {
+ my $cmd = $dbh->prepare(
+ "insert into webmin_group_acl ".
+ "(id,module,attr,value) values (?,?,?,?)");
+ $cmd || &error(&text('egroupdbacl2',
+ $dbh->errstr));
+ foreach my $a (keys %{$_[0]}) {
+ $cmd->execute($id,$m,$a,$_[0]->{$a}) ||
+ &error(&text('egroupdbacl2',
+ $dbh->errstr));
+ $cmd->finish();
+ }
+ }
+ }
+ }
+ elsif ($proto eq "ldap") {
+ # Find the group in LDAP
+ my $rv = $dbh->search(
+ base => $prefix,
+ filter => '(&(cn='.$g.')(objectClass='.
+ $args->{'groupclass'}.'))',
+ scope => 'sub');
+ if (!$rv || $rv->code) {
+ &error(&text('egroupdbacl',
+ $rv ? $rv->error : "Unknown error"));
+ }
+ my ($group) = $rv->all_entries;
+
+ my $ldapm = $m || "global";
+ if ($group) {
+ # Find the ACL sub-object for the module
+ $foundindb = 1;
+ my $rv = $dbh->search(
+ base => $group->dn(),
+ filter => '(cn='.$ldapm.')',
+ scope => 'one');
+ if (!$rv || $rv->code) {
+ &error(&text('egroupdbacl',
+ $rv ? $rv->error : "Unknown error"));
+ }
+ my ($acl) = $rv->all_entries;
+
+ my @al;
+ foreach my $a (keys %{$_[0]}) {
+ push(@al, $a."=".$_[0]->{$a});
+ }
+ if ($acl) {
+ # Update attributes
+ $rv = $dbh->modify($acl->dn(),
+ replace => { "webminAclEntry", \@al });
+ }
+ else {
+ # Add a sub-object
+ my @attrs = ( "cn", $ldapm,
+ "objectClass", "webminAcl",
+ "webminAclEntry", \@al );
+ $rv = $dbh->add("cn=".$ldapm.",".$group->dn(),
+ attr => \@attrs);
+ }
+ if (!$rv || $rv->code) {
+ &error(&text('egroupdbacl2',
+ $rv ? $rv->error : "Unknown error"));
+ }
+ }
+ }
+ &disconnect_userdb($userdb, $dbh);
+ }
+
+if (!$foundindb) {
+ # Save ACL to local file
+ if (!-d "$config_directory/$m") {
+ mkdir("$config_directory/$m", 0755);
+ }
+ if ($_[0]) {
+ &write_file("$config_directory/$m/$g.gacl", $_[0]);
+ }
+ else {
+ &unlink_file("$config_directory/$m/$g.gacl");
+ }
}
-&write_file("$config_directory/$m/$g.gacl", $_[0]);
}
=head2 init_config
$config_file = "$config_directory/config";
%gconfig = ( );
&read_file_cached($config_file, \%gconfig);
+$gconfig{'webprefix'} = '' if (!exists($gconfig{'webprefix'}));
$null_file = $gconfig{'os_type'} eq 'windows' ? "NUL" : "/dev/null";
$path_separator = $gconfig{'os_type'} eq 'windows' ? ';' : ':';
+# Work out of this is a web, command line or cron job
+if (!$main::webmin_script_type) {
+ if ($ENV{'SCRIPT_NAME'}) {
+ # Run via a CGI
+ $main::webmin_script_type = 'web';
+ }
+ else {
+ # Cron jobs have no TTY
+ if ($gconfig{'os_type'} eq 'windows' ||
+ open(DEVTTY, ">/dev/tty")) {
+ $main::webmin_script_type = 'cmd';
+ close(DEVTTY);
+ }
+ else {
+ $main::webmin_script_type = 'cron';
+ }
+ }
+ }
+
+# If this is a cron job, suppress STDERR warnings
+if ($main::webmin_script_type eq 'cron') {
+ $SIG{__WARN__} = sub { };
+ }
+
# If debugging is enabled, open the debug log
-if ($gconfig{'debug_enabled'} && !$main::opened_debug_log++) {
+if (($ENV{'WEBMIN_DEBUG'} || $gconfig{'debug_enabled'}) &&
+ !$main::opened_debug_log++) {
my $dlog = $gconfig{'debug_file'} || $main::default_debug_log_file;
if ($gconfig{'debug_size'}) {
my @st = stat($dlog);
my $script_name = $0 =~ /([^\/]+)$/ ? $1 : '-';
$main::debug_log_start_time = time();
&webmin_debug_log("START", "script=$script_name");
- $main::debug_log_start_module = $module_name;
}
}
&error("Script was not run with full path (failed to find $0 under $root_directory)") if (!$rok);
}
-# Work out of this is a web, command line or cron job
-if (!$main::webmin_script_type) {
- if ($ENV{'SCRIPT_NAME'}) {
- # Run via a CGI
- $main::webmin_script_type = 'web';
- }
- else {
- # Cron jobs have no TTY
- if ($gconfig{'os_type'} eq 'windows' ||
- open(DEVTTY, ">/dev/tty")) {
- $main::webmin_script_type = 'cmd';
- close(DEVTTY);
- }
- else {
- $main::webmin_script_type = 'cron';
- }
- }
- }
-
# Set the umask based on config
if ($gconfig{'umask'} && !$main::umask_already++) {
umask(oct($gconfig{'umask'}));
$base_remote_user = $u;
$remote_user = $ENV{'REMOTE_USER'};
+# Work out if user is definitely in the DB, and if so get his attrs
+$remote_user_proto = $ENV{"REMOTE_USER_PROTO"};
+%remote_user_attrs = ( );
+if ($remote_user_proto) {
+ my $userdb = &get_userdb_string();
+ my ($dbh, $proto, $prefix, $args) =
+ $userdb ? &connect_userdb($userdb) : ( );
+ if (ref($dbh)) {
+ if ($proto eq "mysql" || $proto eq "postgresql") {
+ # Read attrs from SQL
+ 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 = ?");
+ if ($cmd && $cmd->execute($base_remote_user)) {
+ while(my ($attr, $value) = $cmd->fetchrow()) {
+ $remote_user_attrs{$attr} = $value;
+ }
+ $cmd->finish();
+ }
+ }
+ elsif ($proto eq "ldap") {
+ # Read attrs from LDAP
+ my $rv = $dbh->search(
+ base => $prefix,
+ filter => '(&(cn='.$base_remote_user.')'.
+ '(objectClass='.
+ $args->{'userclass'}.'))',
+ scope => 'sub');
+ my ($u) = $rv && !$rv->code ? $rv->all_entries : ( );
+ if ($u) {
+ foreach $la ($u->get_value('webminAttr')) {
+ my ($attr, $value) = split(/=/, $la, 2);
+ $remote_user_attrs{$attr} = $value;
+ }
+ }
+ }
+ &disconnect_userdb($userdb, $dbh);
+ }
+ }
+
if ($module_name) {
# Find and load the configuration file for this module
my (@ruinfo, $rgroup);
my $current_themes;
$current_themes = $ENV{'MOBILE_DEVICE'} && defined($gconfig{'mobile_theme'}) ?
$gconfig{'mobile_theme'} :
+ defined($remote_user_attrs{'theme'}) ?
+ $remote_user_attrs{'theme'} :
defined($gconfig{'theme_'.$remote_user}) ?
$gconfig{'theme_'.$remote_user} :
defined($gconfig{'theme_'.$base_remote_user}) ?
my $accepted_lang;
if ($gconfig{'acceptlang'}) {
foreach my $a (split(/,/, $ENV{'HTTP_ACCEPT_LANGUAGE'})) {
+ $a =~ s/;.*//; # Remove ;q=0.5 or similar
my ($al) = grep { $_->{'lang'} eq $a } @langs;
if ($al) {
$accepted_lang = $al->{'lang'};
}
$current_lang = $force_lang ? $force_lang :
$accepted_lang ? $accepted_lang :
+ $remote_user_attrs{'lang'} ? $remote_user_attrs{'lang'} :
$gconfig{"lang_$remote_user"} ? $gconfig{"lang_$remote_user"} :
$gconfig{"lang_$base_remote_user"} ? $gconfig{"lang_$base_remote_user"} :
$gconfig{"lang"} ? $gconfig{"lang"} : $default_lang;
# Check the Referer: header for nasty redirects
my @referers = split(/\s+/, $gconfig{'referers'});
my $referer_site;
-if ($ENV{'HTTP_REFERER'} =~/^(http|https|ftp):\/\/([^:\/]+:[^@\/]+@)?([^\/:@]+)/) {
+my $r = $ENV{'HTTP_REFERER'};
+if ($r =~ /^(http|https|ftp):\/\/([^:\/]+:[^@\/]+@)?\[([^\]]+)\]/ ||
+ $r =~ /^(http|https|ftp):\/\/([^:\/]+:[^@\/]+@)?([^\/:@]+)/) {
$referer_site = $3;
}
my $http_host = $ENV{'HTTP_HOST'};
$http_host =~ s/:\d+$//;
+$http_host =~ s/^\[(\S+)\]$/$1/;
+my $unsafe_index = $unsafe_index_cgi ||
+ &get_module_variable('$unsafe_index_cgi');
if ($0 &&
- ($ENV{'SCRIPT_NAME'} !~ /^\/(index.cgi)?$/ || $unsafe_index_cgi) &&
+ ($ENV{'SCRIPT_NAME'} !~ /^\/(index.cgi)?$/ || $unsafe_index) &&
($ENV{'SCRIPT_NAME'} !~ /^\/([a-z0-9\_\-]+)\/(index.cgi)?$/i ||
- $unsafe_index_cgi) &&
+ $unsafe_index) &&
$0 !~ /(session_login|pam_login)\.cgi$/ && !$gconfig{'referer'} &&
$ENV{'MINISERV_CONFIG'} && !$main::no_referers_check &&
$ENV{'HTTP_USER_AGENT'} !~ /^Webmin/i &&
if ($referer_site) {
# From a known host
print &text('referer_warn',
- "<tt>".&html_escape($ENV{'HTTP_REFERER'})."</tt>", $url);
+ "<tt>".&html_escape($r)."</tt>", $url);
print "<p>\n";
print &text('referer_fix1', &html_escape($http_host)),"<p>\n";
print &text('referer_fix2', &html_escape($http_host)),"<p>\n";
'$path_separator', '@root_directories',
'$root_directory', '$module_name',
'$base_remote_user', '$remote_user',
+ '$remote_user_proto', '%remote_user_attrs',
'$module_config_directory', '$module_config_file',
'%config', '@current_themes', '$current_theme',
'@theme_root_directories', '$theme_root_directory',
# Read global lang files
foreach my $o (@lang_order_list) {
- my $ok = &read_file_cached("$root/$dir/$o", \%text);
+ my $ok = &read_file_cached_with_stat("$root/$dir/$o", \%text);
return () if (!$ok && $o eq $default_lang);
}
if ($ol) {
}
}
&read_file_cached("$config_directory/custom-lang", \%text);
+foreach my $o (@lang_order_list) {
+ next if ($o eq "en");
+ &read_file_cached("$config_directory/custom-lang.$o", \%text);
+ }
+my $norefs = $text{'__norefs'};
if ($_[0]) {
# Read module's lang files
+ delete($text{'__norefs'});
my $mdir = &module_root_directory($_[0]);
foreach my $o (@lang_order_list) {
- &read_file_cached("$mdir/$dir/$o", \%text);
+ &read_file_cached_with_stat("$mdir/$dir/$o", \%text);
}
if ($ol) {
- foreach $o (@lang_order_list) {
+ foreach my $o (@lang_order_list) {
&read_file_cached("$mdir/$ol/$o", \%text);
}
}
&read_file_cached("$config_directory/$_[0]/custom-lang", \%text);
+ foreach my $o (@lang_order_list) {
+ next if ($o eq "en");
+ &read_file_cached("$config_directory/$_[0]/custom-lang.$o",
+ \%text);
+ }
+ $norefs = $text{'__norefs'} if ($norefs);
}
-foreach $k (keys %text) {
- $text{$k} =~ s/\$(\{([^\}]+)\}|([A-Za-z0-9\.\-\_]+))/text_subs($2 || $3,\%text)/ge;
+
+# Replace references to other strings
+if (!$norefs) {
+ foreach $k (keys %text) {
+ $text{$k} =~ s/\$(\{([^\}]+)\}|([A-Za-z0-9\.\-\_]+))/text_subs($2 || $3,\%text)/ge;
+ }
}
if (defined(&theme_load_language)) {
my (%rv, $clone, $o);
my $mdir = &module_root_directory($_[0]);
&read_file_cached("$mdir/module.info", \%rv) || return ();
-$clone = -l $mdir;
+if (-l $mdir) {
+ # A clone is a module that links to another directory under the root
+ foreach my $r (@root_directories) {
+ if (&is_under_directory($r, $mdir)) {
+ $clone = 1;
+ last;
+ }
+ }
+ }
foreach $o (@lang_order_list) {
$rv{"desc"} = $rv{"desc_$o"} if ($rv{"desc_$o"});
$rv{"longdesc"} = $rv{"longdesc_$o"} if ($rv{"longdesc_$o"});
$rv{'realdesc'} = $rv{'desc'};
my %descs;
&read_file_cached("$config_directory/webmin.descs", \%descs);
-if ($descs{$_[0]." ".$current_lang}) {
- $rv{'desc'} = $descs{$_[0]." ".$current_lang};
- }
-elsif ($descs{$_[0]}) {
+if ($descs{$_[0]}) {
$rv{'desc'} = $descs{$_[0]};
}
+foreach my $o (@lang_order_list) {
+ my $ov = $descs{$_[0]." ".$o} || $descs{$_[0]."_".$o};
+ $rv{'desc'} = $ov if ($ov);
+ }
if (!$_[2]) {
# Apply per-user description overridde
$cache{'mtime_'.$r} = $st[9];
}
$cache{'lang'} = $current_lang;
- &write_file($cache_file, \%cache) if (!$_[0] && $< == 0 && $> == 0);
+ if (!$_[0] && $< == 0 && $> == 0) {
+ eval {
+ # Don't fail if cache write fails
+ local $main::error_must_die = 1;
+ &write_file($cache_file, \%cache);
+ }
+ }
}
# Override descriptions for modules for current user
return @rv;
}
+=head2 list_themes
+
+Returns an array of all installed themes, each of which is a hash ref
+corresponding to the theme.info file.
+
+=cut
+sub list_themes
+{
+my @rv;
+opendir(DIR, $root_directory);
+foreach my $m (readdir(DIR)) {
+ my %tinfo;
+ next if ($m =~ /^\./);
+ next if (!&read_file_cached("$root_directory/$m/theme.info", \%tinfo));
+ next if (!&check_os_support(\%tinfo));
+ foreach my $o (@lang_order_list) {
+ if ($tinfo{'desc_'.$o}) {
+ $tinfo{'desc'} = $tinfo{'desc_'.$o};
+ }
+ }
+ $tinfo{'dir'} = $m;
+ push(@rv, \%tinfo);
+ }
+closedir(DIR);
+return sort { lc($a->{'desc'}) cmp lc($b->{'desc'}) } @rv;
+}
+
=head2 get_theme_info(theme)
Returns a hash containing a theme's details, taken from it's theme.info file.
return @main::list_languages_cache;
}
-=head2 read_env_file(file, &hash)
+=head2 read_env_file(file, &hash, [include-commented])
Similar to Webmin's read_file function, but handles files containing shell
environment variables formatted like :
local $_;
&open_readfile(FILE, $_[0]) || return 0;
while(<FILE>) {
+ if ($_[2]) {
+ # Remove start of line comments
+ s/^\s*#+\s*//;
+ }
s/#.*$//g;
if (/^\s*(export\s*)?([A-Za-z0-9_\.]+)\s*=\s*"(.*)"/i ||
/^\s*(export\s*)?([A-Za-z0-9_\.]+)\s*=\s*'(.*)'/i ||
my @tm = localtime($now);
my $script_name = $0 =~ /([^\/]+)$/ ? $1 : '-';
my $id = sprintf "%d.%d.%d", $now, $$, $main::action_id_count;
+my $idprefix = substr($now, 0, 5);
$main::action_id_count++;
my $line = sprintf "%s [%2.2d/%s/%4.4d %2.2d:%2.2d:%2.2d] %s %s %s %s %s \"%s\" \"%s\" \"%s\"",
- $id, $tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900,
+ $id, $tm[3], ucfirst($number_to_month_map{$tm[4]}), $tm[5]+1900,
$tm[2], $tm[1], $tm[0],
$remote_user || '-',
$main::session_id || '-',
my $i = 0;
mkdir("$ENV{'WEBMIN_VAR'}/diffs", 0700);
foreach my $d (@main::locked_file_diff) {
- mkdir("$ENV{'WEBMIN_VAR'}/diffs/$id", 0700);
- open(DIFFLOG, ">$ENV{'WEBMIN_VAR'}/diffs/$id/$i");
+ mkdir("$ENV{'WEBMIN_VAR'}/diffs/$idprefix", 0700);
+ mkdir("$ENV{'WEBMIN_VAR'}/diffs/$idprefix/$id", 0700);
+ open(DIFFLOG, ">$ENV{'WEBMIN_VAR'}/diffs/$idprefix/$id/$i");
print DIFFLOG "$d->{'type'} $d->{'object'}\n";
print DIFFLOG $d->{'data'};
close(DIFFLOG);
if ($d->{'input'}) {
- open(DIFFLOG, ">$ENV{'WEBMIN_VAR'}/diffs/$id/$i.input");
+ open(DIFFLOG,
+ ">$ENV{'WEBMIN_VAR'}/diffs/$idprefix/$id/$i.input");
print DIFFLOG $d->{'input'};
close(DIFFLOG);
}
if ($gconfig{'logperms'}) {
chmod(oct($gconfig{'logperms'}),
- "$ENV{'WEBMIN_VAR'}/diffs/$id/$i",
- "$ENV{'WEBMIN_VAR'}/diffs/$id/$i.input");
+ "$ENV{'WEBMIN_VAR'}/diffs/$idprefix/$id/$i",
+ "$ENV{'WEBMIN_VAR'}/diffs/$idprefix/$id/$i.input");
}
$i++;
}
@main::locked_file_diff = undef;
}
+
if ($gconfig{'logfullfiles'}) {
# Save the original contents of any modified files
my $i = 0;
mkdir("$ENV{'WEBMIN_VAR'}/files", 0700);
foreach my $f (keys %main::orig_file_data) {
- mkdir("$ENV{'WEBMIN_VAR'}/files/$id", 0700);
- open(ORIGLOG, ">$ENV{'WEBMIN_VAR'}/files/$id/$i");
+ mkdir("$ENV{'WEBMIN_VAR'}/files/$idprefix", 0700);
+ mkdir("$ENV{'WEBMIN_VAR'}/files/$idprefix/$id", 0700);
+ open(ORIGLOG, ">$ENV{'WEBMIN_VAR'}/files/$idprefix/$id/$i");
if (!defined($main::orig_file_type{$f})) {
print ORIGLOG -1," ",$f,"\n";
}
close(ORIGLOG);
if ($gconfig{'logperms'}) {
chmod(oct($gconfig{'logperms'}),
- "$ENV{'WEBMIN_VAR'}/files/$id.$i");
+ "$ENV{'WEBMIN_VAR'}/files/$idprefix/$id.$i");
}
$i++;
}
%main::orig_file_type = undef;
}
+if ($miniserv::page_capture_out) {
+ # Save the whole page output
+ mkdir("$ENV{'WEBMIN_VAR'}/output", 0700);
+ mkdir("$ENV{'WEBMIN_VAR'}/output/$idprefix", 0700);
+ open(PAGEOUT, ">$ENV{'WEBMIN_VAR'}/output/$idprefix/$id");
+ print PAGEOUT $miniserv::page_capture_out;
+ close(PAGEOUT);
+ if ($gconfig{'logperms'}) {
+ chmod(oct($gconfig{'logperms'}),
+ "$ENV{'WEBMIN_VAR'}/output/$idprefix/$id");
+ }
+ $miniserv::page_capture_out = undef;
+ }
+
# Log to syslog too
if ($gconfig{'logsyslog'}) {
eval 'use Sys::Syslog qw(:DEFAULT setlogsock);
my ($type, $msg) = @_;
return 0 if (!$main::opened_debug_log);
return 0 if ($gconfig{'debug_no'.$main::webmin_script_type});
-my $now = time();
+if ($gconfig{'debug_modules'}) {
+ my @dmods = split(/\s+/, $gconfig{'debug_modules'});
+ return 0 if (&indexof($main::initial_module_name, @dmods) < 0);
+ }
+my $now;
+eval 'use Time::HiRes qw(gettimeofday); ($now, $ms) = gettimeofday';
+$now ||= time();
my @tm = localtime($now);
my $line = sprintf
- "%s [%2.2d/%s/%4.4d %2.2d:%2.2d:%2.2d] %s %s %s %s \"%s\"",
- $$, $tm[3], $text{"smonth_".($tm[4]+1)}, $tm[5]+1900,
- $tm[2], $tm[1], $tm[0],
+ "%s [%2.2d/%s/%4.4d %2.2d:%2.2d:%2.2d.%6.6d] %s %s %s %s \"%s\"",
+ $$, $tm[3], ucfirst($number_to_month_map{$tm[4]}), $tm[5]+1900,
+ $tm[2], $tm[1], $tm[0], $ms,
$remote_user || "-",
$ENV{'REMOTE_HOST'} || "-",
&get_module_name() || "-",
sub backquote_with_timeout
{
my $realcmd = &translate_command($_[0]);
-&webmin_debug_log('CMD', "cmd=$realcmd timeout=$_[1]")
- if ($gconfig{'debug_what_cmd'});
my $out;
my $pid = &open_execute_command(OUT, "($realcmd) <$null_file", 1, $_[2]);
my $start = time();
my $rv = 1;
my $err;
foreach my $f (@_) {
+ &unflush_file_lines($f);
my $realf = &translate_filename($f);
&webmin_debug_log('UNLINK', $realf) if ($gconfig{'debug_what_ops'});
if (-d $realf) {
if (!rmdir($realf)) {
+ my $out;
if ($gconfig{'os_type'} eq 'windows') {
# Call del and rmdir commands
my $qm = $realf;
else {
# Use rm command
my $qm = quotemeta($realf);
- my $out = `rm -rf $qm 2>&1`;
+ $out = `rm -rf $qm 2>&1`;
}
if ($?) {
$rv = 0;
delete($remote_session{$sn});
delete($remote_session_server{$sn});
}
-foreach $fh (keys %fast_fh_cache) {
+foreach my $fh (keys %fast_fh_cache) {
close($fh);
delete($fast_fh_cache{$fh});
}
$main::remote_error_handler = $_[0] || \&error;
}
-=head2 remote_rpc_call(server, structure)
+=head2 remote_rpc_call(server, &structure)
Calls rpc.cgi on some server and passes it a perl structure (hash,array,etc)
and then reads back a reply structure. This is mainly for internal use only,
}
elsif ($_[0]) {
# lookup the server in the webmin servers module if needed
- if (!defined(%main::remote_servers_cache)) {
+ if (!%main::remote_servers_cache) {
&foreign_require("servers", "servers-lib.pl");
foreach $s (&foreign_call("servers", "list_servers")) {
$main::remote_servers_cache{$s->{'host'}} = $s;
$serv->{'user'} || return &$main::remote_error_handler(
"No login set for server $_[0]");
}
+my $ip = $serv->{'ip'} || $serv->{'host'};
# Work out the username and password
my ($user, $pass);
if (!$fast_fh_cache{$sn} && $sn) {
# Need to open the connection
my $con = &make_http_connection(
- $serv->{'host'}, $serv->{'port'}, $serv->{'ssl'},
+ $ip, $serv->{'port'}, $serv->{'ssl'},
"POST", "/fastrpc.cgi");
return &$main::remote_error_handler(
"Failed to connect to $serv->{'host'} : $con")
# Started ok .. connect and save SID
&close_http_connection($con);
my ($port, $sid, $version, $error) = ($1, $2, $3);
- &open_socket($serv->{'host'}, $port, $sid, \$error);
+ &open_socket($ip, $port, $sid, \$error);
return &$main::remote_error_handler("Failed to connect to fastrpc.cgi : $error")
if ($error);
$fast_fh_cache{$sn} = $sid;
if ($base_remote_user ne 'root' &&
$base_remote_user ne 'admin') {
# Need to fake up a login for the CGI!
- &read_acl(undef, \%acl);
+ &read_acl(undef, \%acl, [ 'root' ]);
$ENV{'BASE_REMOTE_USER'} =
$ENV{'REMOTE_USER'} =
$acl{'root'} ? 'root' : 'admin';
my $tostr = &serialise_variable($_[1]);
print $fh length($tostr)," $fh\n";
print $fh $tostr;
- my $rlen = int(<$fh>);
+ my $rstr = <$fh>;
+ if ($rstr eq '') {
+ return &$main::remote_error_handler(
+ "Error reading response length from fastrpc.cgi : $!")
+ }
+ my $rlen = int($rstr);
my ($fromstr, $got);
while(length($fromstr) < $rlen) {
- return &$main::remote_error_handler("Failed to read from fastrpc.cgi")
+ return &$main::remote_error_handler(
+ "Failed to read from fastrpc.cgi : $!")
if (read($fh, $got, $rlen - length($fromstr)) <= 0);
$fromstr .= $got;
}
my $from = &unserialise_variable($fromstr);
if (!$from) {
+ # No response at all
return &$main::remote_error_handler("Remote Webmin error");
}
+ elsif (ref($from) ne 'HASH') {
+ # Not a hash?!
+ return &$main::remote_error_handler(
+ "Invalid remote Webmin response : $from");
+ }
+ elsif (!$from->{'status'}) {
+ # Call failed
+ $from->{'rv'} =~ s/\s+at\s+(\S+)\s+line\s+(\d+)(,\s+<\S+>\s+line\s+(\d+))?//;
+ return &$main::remote_error_handler($from->{'rv'});
+ }
if (defined($from->{'arv'})) {
return @{$from->{'arv'}};
}
# Call rpc.cgi on remote server
my $tostr = &serialise_variable($_[1]);
my $error = 0;
- my $con = &make_http_connection($serv->{'host'}, $serv->{'port'},
+ my $con = &make_http_connection($ip, $serv->{'port'},
$serv->{'ssl'}, "POST", "/rpc.cgi");
return &$main::remote_error_handler("Failed to connect to $serv->{'host'} : $con") if (!ref($con));
my $mdir = &module_root_directory($_[0]);
my $dir = "$mdir/help";
foreach my $o (@lang_order_list) {
- my $lang = "$dir/$_[1].$current_lang.html";
+ my $lang = "$dir/$_[1].$o.html";
return $lang if (-r $lang);
}
return "$dir/$_[1].html";
return $out =~ /^([0-9]+)/ ? $1 : "???";
}
-=head2 recursive_disk_usage(directory)
+=head2 recursive_disk_usage(directory, [skip-regexp], [only-regexp])
Returns the number of bytes taken up by all files in some directory and all
sub-directories, by summing up their lengths. The disk_usage_kb is more
sub recursive_disk_usage
{
my $dir = &translate_filename($_[0]);
+my $skip = $_[1];
+my $only = $_[2];
if (-l $dir) {
return 0;
}
closedir(DIR);
foreach my $f (@files) {
next if ($f eq "." || $f eq "..");
- $rv += &recursive_disk_usage("$dir/$f");
+ next if ($skip && $f =~ /$skip/);
+ next if ($only && $f !~ /$only/);
+ $rv += &recursive_disk_usage("$dir/$f", $skip, $only);
}
return $rv;
}
'MINISERV_CONFIG', 'SCRIPT_NAME', 'SERVER_ADMIN', 'CONTENT_LENGTH',
'HTTPS', 'FOREIGN_MODULE_NAME', 'FOREIGN_ROOT_DIRECTORY',
'SCRIPT_FILENAME', 'PATH_TRANSLATED', 'BASE_REMOTE_USER',
- 'DOCUMENT_REALROOT', 'MINISERV_CONFIG', 'MYSQL_PWD') {
+ 'DOCUMENT_REALROOT', 'MINISERV_CONFIG', 'MYSQL_PWD',
+ 'MINISERV_PID') {
delete($ENV{$e});
}
}
=cut
sub reset_environment
{
-if (defined(%UNCLEAN_ENV)) {
+if (%UNCLEAN_ENV) {
foreach my $k (keys %UNCLEAN_ENV) {
$ENV{$k} = $UNCLEAN_ENV{$k};
}
}
}
+=head2 clean_language
+
+Sets all language and locale-related environment variables to US english, to
+ensure that commands run output in the expected language. Can be reverted by
+reset_environment.
+
+=cut
+sub clean_language
+{
+%UNCLEAN_ENV = %ENV;
+$ENV{'LANG'} = '';
+$ENV{'LANGUAGE'} = '';
+$ENV{'LC_ALL'} = '';
+$ENV{'LOCALE'} = '';
+}
+
=head2 progress_callback
Never called directly, but useful for passing to &http_download to print
if ($_[1]) {
$progress_size = $_[1];
$progress_step = int($_[1] / 10);
- print &text('progress_size', $progress_callback_url,
- $progress_size),"<br>\n";
+ print &text('progress_size2', $progress_callback_url,
+ &nice_size($progress_size)),"<br>\n";
}
else {
+ $progress_size = undef;
print &text('progress_nosize', $progress_callback_url),"<br>\n";
}
$last_progress_time = $last_progress_size = undef;
if ($st != $progress_step ||
$time_now - $last_progress_time > 60) {
# Show progress every 10% or 60 seconds
- print $sp,&text('progress_data', $_[1], int($_[1]*100/$progress_size)),"<br>\n";
+ print $sp,&text('progress_datan', &nice_size($_[1]),
+ int($_[1]*100/$progress_size)),"<br>\n";
$last_progress_time = $time_now;
}
$progress_step = $st;
else {
# No total size .. so only show in 100k jumps
if ($_[1] > $last_progress_size+100*1024) {
- print $sp,&text('progress_data2', $_[1]),"<br>\n";
+ print $sp,&text('progress_data2n',
+ &nice_size($_[1])),"<br>\n";
$last_progress_size = $_[1];
}
}
{
my ($user, $code) = @_;
my @uinfo = getpwnam($user);
-defined(@uinfo) || &error("eval_as_unix_user called with invalid user $user");
+if (!scalar(@uinfo)) {
+ &error("eval_as_unix_user called with invalid user $user");
+ }
$) = $uinfo[3]." ".join(" ", $uinfo[3], &other_groups($user));
$> = $uinfo[2];
my @rv;
sub get_available_module_infos
{
my (%acl, %uacl);
-&read_acl(\%acl, \%uacl);
+&read_acl(\%acl, \%uacl, [ $base_remote_user ]);
my $risk = $gconfig{'risk_'.$base_remote_user};
my @rv;
foreach my $minfo (&get_all_module_infos($_[0])) {
=head2 parse_http_url(url, [basehost, baseport, basepage, basessl])
Given an absolute URL, returns the host, port, page and ssl flag components.
+If a username and password are given before the hostname, return those too.
Relative URLs can also be parsed, if the base information is provided.
=cut
sub parse_http_url
{
-if ($_[0] =~ /^(http|https):\/\/([^:\/]+)(:(\d+))?(\/\S*)?$/) {
+if ($_[0] =~ /^(http|https):\/\/([^\@]+\@)?\[([^\]]+)\](:(\d+))?(\/\S*)?$/ ||
+ $_[0] =~ /^(http|https):\/\/([^\@]+\@)?([^:\/]+)(:(\d+))?(\/\S*)?$/) {
# An absolute URL
my $ssl = $1 eq 'https';
- return ($2, $3 ? $4 : $ssl ? 443 : 80, $5 || "/", $ssl);
+ my @rv = ($3, $4 ? $5 : $ssl ? 443 : 80, $6 || "/", $ssl);
+ if ($2 =~ /^([^:]+):(\S+)\@/) {
+ push(@rv, $1, $2);
+ }
+ return @rv;
}
elsif (!$_[1]) {
# Could not parse
}
elsif ($_[0] =~ /^\/\S*$/) {
# A relative to the server URL
- return ($_[1], $_[2], $_[0], $_[4]);
+ return ($_[1], $_[2], $_[0], $_[4], $_[5], $_[6]);
}
else {
# A relative to the directory URL
my $page = $_[3];
$page =~ s/[^\/]+$//;
- return ($_[1], $_[2], $page.$_[0], $_[4]);
+ return ($_[1], $_[2], $page.$_[0], $_[4], $_[5], $_[6]);
}
}
=cut
sub load_entities_map
{
-if (!defined(%entities_map_cache)) {
+if (!%entities_map_cache) {
local $_;
open(EMAP, "$root_directory/entities_map.txt");
while(<EMAP>) {
my ($field, $form, $text) = @_;
$form = int($form);
$text ||= $text{'ui_selall'};
-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>";
+return "<a class='select_all' href='#' onClick='var ff = document.forms[$form].$field; ff.checked = true; for(i=0; i<ff.length; i++) { if (!ff[i].disabled) { ff[i].checked = true; } } return false'>$text</a>";
}
=head2 select_invert_link(field, form, text)
my ($field, $form, $text) = @_;
$form = int($form);
$text ||= $text{'ui_selinv'};
-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>";
+return "<a class='select_invert' href='#' onClick='var ff = document.forms[$form].$field; ff.checked = !ff.checked; for(i=0; i<ff.length; i++) { if (!ff[i].disabled) { ff[i].checked = !ff[i].checked; } } return false'>$text</a>";
}
=head2 select_rows_link(field, form, text, &rows)
my $lockfile = $file;
$lockfile =~ s/^[^\/]*//;
if ($lockfile =~ /^\//) {
+ while(-l $lockfile) {
+ # If the file is a link, follow it so that locking is done on
+ # the same file that gets unlocked later
+ $lockfile = &resolve_links($lockfile);
+ }
$main::open_templocks{$lockfile} = &lock_file($lockfile);
}
return &open_tempfile($fh, $file, $noerror, $notemp, $safe);
if ($$ == $main::initial_process_id) {
# Exiting from initial process
&cleanup_tempnames();
- if ($gconfig{'debug_what_start'} && $main::debug_log_start_time &&
- $main::debug_log_start_module eq &get_module_name()) {
+ if ($gconfig{'debug_what_start'} && $main::debug_log_start_time) {
my $len = time() - $main::debug_log_start_time;
&webmin_debug_log("STOP", "runtime=$len");
$main::debug_log_start_time = 0;
}
- if (!$ENV{'SCRIPT_NAME'} &&
- $main::initial_module_name eq &get_module_name()) {
+ if (!$ENV{'SCRIPT_NAME'}) {
# In a command-line script - call the real exit, so that the
# exit status gets properly propogated. In some cases this
# was not happening.
}
}
close(RBAC);
-return !$foundany ? undef : defined(%rv) ? \%rv : undef;
+return !$foundany ? undef : %rv ? \%rv : undef;
}
=head2 supports_rbac([module])
return 1;
}
+=head2 supports_ipv6()
+
+Returns 1 if outgoing IPv6 connections can be made
+
+=cut
+sub supports_ipv6
+{
+return $ipv6_module_error ? 0 : 1;
+}
+
=head2 use_rbac_module_acl(user, module)
Returns 1 if some user should use RBAC to get permissions for a module
$? = 0;
return 0;
}
-my $cmd = &translate_command($cmd);
+$cmd = &translate_command($cmd);
# Use ` operator where possible
+&webmin_debug_log('CMD', "cmd=$cmd") if ($gconfig{'debug_what_cmd'});
if (!$stdin && ref($stdout) && !$stderr) {
$cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
$$stdout = `$cmd 2>$null_file`;
$cmd = "($cmd)" if ($gconfig{'os_type'} ne 'windows');
return system("$cmd >$null_file 2>$null_file <$null_file");
}
-&webmin_debug_log('CMD', "cmd=$cmd") if ($gconfig{'debug_what_cmd'});
# Setup pipes
$| = 1; # needed on some systems to flush before forking
if ($sv) {
# Replace ${IF}..${ELSE}..${ENDIF} block with first value,
# and ${IF}..${ENDIF} with value
- $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/\2/g;
- $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/\2/g;
+ $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/$2/g;
+ $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/$2/g;
# Replace $IF..$ELSE..$ENDIF block with first value,
# and $IF..$ENDIF with value
- $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ELSE-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/\2/g;
- $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/\2/g;
+ $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ELSE-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/$2/g;
+ $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/$2/g;
# Replace ${IFEQ}..${ENDIFEQ} block with first value if
# matching, nothing if not
- $rv =~ s/\$\{IFEQ-\Q$us\E-\Q$sv\E\}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-\Q$sv\E\}(\n?)/\2/g;
+ $rv =~ s/\$\{IFEQ-\Q$us\E-\Q$sv\E\}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-\Q$sv\E\}(\n?)/$2/g;
$rv =~ s/\$\{IFEQ-\Q$us\E-[^\}]+}(\n?)([\000-\377]*?)\$\{ENDIFEQ-\Q$us\E-[^\}]+\}(\n?)//g;
# Replace $IFEQ..$ENDIFEQ block with first value if
# matching, nothing if not
- $rv =~ s/\$IFEQ-\Q$us\E-\Q$sv\E(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\Q$sv\E(\n?)/\2/g;
+ $rv =~ s/\$IFEQ-\Q$us\E-\Q$sv\E(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\Q$sv\E(\n?)/$2/g;
$rv =~ s/\$IFEQ-\Q$us\E-\S+(\n?)([\000-\377]*?)\$ENDIFEQ-\Q$us\E-\S+(\n?)//g;
}
else {
# Replace ${IF}..${ELSE}..${ENDIF} block with second value,
# and ${IF}..${ENDIF} with nothing
- $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/\4/g;
+ $rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ELSE-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)/$4/g;
$rv =~ s/\$\{IF-\Q$us\E\}(\n?)([\000-\377]*?)\$\{ENDIF-\Q$us\E\}(\n?)//g;
# Replace $IF..$ELSE..$ENDIF block with second value,
# and $IF..$ENDIF with nothing
- $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ELSE-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/\4/g;
+ $rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ELSE-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)/$4/g;
$rv =~ s/\$IF-\Q$us\E(\n?)([\000-\377]*?)\$ENDIF-\Q$us\E(\n?)//g;
# Replace ${IFEQ}..${ENDIFEQ} block with nothing
return $cap =~ /control_d/ ? 0 : 1;
}
+=head2 running_in_openvz
+
+Returns 1 if Webmin is running inside an OpenVZ container, by looking
+at /proc/vz/veinfo for a non-zero line.
+
+=cut
+sub running_in_openvz
+{
+return 0 if (!-r "/proc/vz/veinfo");
+my $lref = &read_file_lines("/proc/vz/veinfo", 1);
+return 0 if (!$lref || !@$lref);
+foreach my $l (@$lref) {
+ $l =~ s/^\s+//;
+ my @ll = split(/\s+/, $l);
+ return 0 if ($ll[0] eq '0');
+ }
+return 1;
+}
+
=head2 list_categories(&modules, [include-empty])
Returns a hash mapping category codes to names, including any custom-defined
return __PACKAGE__;
}
+=head2 get_userdb_string
+
+Returns the URL-style string for connecting to the users and groups database
+
+=cut
+sub get_userdb_string
+{
+return undef if ($main::no_miniserv_userdb);
+my %miniserv;
+&get_miniserv_config(\%miniserv);
+return $miniserv{'userdb'};
+}
+
+=head2 connect_userdb(string)
+
+Returns a handle for talking to a user database - may be a DBI or LDAP handle.
+On failure returns an error message string. In an array context, returns the
+protocol type too.
+
+=cut
+sub connect_userdb
+{
+my ($str) = @_;
+my ($proto, $user, $pass, $host, $prefix, $args) = &split_userdb_string($str);
+if ($proto eq "mysql") {
+ # Connect to MySQL with DBI
+ my $drh = eval "use DBI; DBI->install_driver('mysql');";
+ $drh || return $text{'sql_emysqldriver'};
+ my ($host, $port) = split(/:/, $host);
+ my $cstr = "database=$prefix;host=$host";
+ $cstr .= ";port=$port" if ($port);
+ my $dbh = $drh->connect($cstr, $user, $pass, { });
+ $dbh || return &text('sql_emysqlconnect', $drh->errstr);
+ return wantarray ? ($dbh, $proto, $prefix, $args) : $dbh;
+ }
+elsif ($proto eq "postgresql") {
+ # Connect to PostgreSQL with DBI
+ my $drh = eval "use DBI; DBI->install_driver('Pg');";
+ $drh || return $text{'sql_epostgresqldriver'};
+ my ($host, $port) = split(/:/, $host);
+ my $cstr = "dbname=$prefix;host=$host";
+ $cstr .= ";port=$port" if ($port);
+ my $dbh = $drh->connect($cstr, $user, $pass);
+ $dbh || return &text('sql_epostgresqlconnect', $drh->errstr);
+ return wantarray ? ($dbh, $proto, $prefix, $args) : $dbh;
+ }
+elsif ($proto eq "ldap") {
+ # Connect with perl LDAP module
+ eval "use Net::LDAP";
+ $@ && return $text{'sql_eldapdriver'};
+ my ($host, $port) = split(/:/, $host);
+ my $scheme = $args->{'scheme'} || 'ldap';
+ if (!$port) {
+ $port = $scheme eq 'ldaps' ? 636 : 389;
+ }
+ my $ldap = Net::LDAP->new($host,
+ port => $port,
+ 'scheme' => $scheme);
+ $ldap || return &text('sql_eldapconnect', $host);
+ my $mesg;
+ if ($args->{'tls'}) {
+ # Switch to TLS mode
+ eval { $mesg = $ldap->start_tls(); };
+ if ($@ || !$mesg || $mesg->code) {
+ return &text('sql_eldaptls',
+ $@ ? $@ : $mesg ? $mesg->error : "Unknown error");
+ }
+ }
+ # Login to the server
+ if ($pass) {
+ $mesg = $ldap->bind(dn => $user, password => $pass);
+ }
+ else {
+ $mesg = $ldap->bind(dn => $user, anonymous => 1);
+ }
+ if (!$mesg || $mesg->code) {
+ return &text('sql_eldaplogin', $user,
+ $mesg ? $mesg->error : "Unknown error");
+ }
+ return wantarray ? ($ldap, $proto, $prefix, $args) : $ldap;
+ }
+else {
+ return "Unknown protocol $proto";
+ }
+}
+
+=head2 disconnect_userdb(string, &handle)
+
+Closes a handle opened by connect_userdb
+
+=cut
+sub disconnect_userdb
+{
+my ($str, $h) = @_;
+if ($str =~ /^(mysql|postgresql):/) {
+ # DBI disconnnect
+ if (!$h->{'AutoCommit'}) {
+ $h->commit();
+ }
+ $h->disconnect();
+ }
+elsif ($str =~ /^ldap:/) {
+ # LDAP disconnect
+ $h->unbind();
+ $h->disconnect();
+ }
+}
+
+=head2 split_userdb_string(string)
+
+Converts a string like mysql://user:pass@host/db into separate parts
+
+=cut
+sub split_userdb_string
+{
+my ($str) = @_;
+if ($str =~ /^([a-z]+):\/\/([^:]*):([^\@]*)\@([a-z0-9\.\-\_]+)\/([^\?]+)(\?(.*))?$/) {
+ my ($proto, $user, $pass, $host, $prefix, $argstr) =
+ ($1, $2, $3, $4, $5, $7);
+ my %args = map { split(/=/, $_, 2) } split(/\&/, $argstr);
+ return ($proto, $user, $pass, $host, $prefix, \%args);
+ }
+return ( );
+}
+
$done_web_lib_funcs = 1;
1;