#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
$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);
+ $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 "</td></tr></table>\n";
print $tconfig{'postheader'};
}
+$miniserv::page_capture = 1;
}
=head2 get_html_title(title)
&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";
&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)) {
=cut
sub popup_footer
{
+$miniserv::page_capture = 0;
&load_theme_library();
if (defined(&theme_popup_footer)) {
&theme_popup_footer(@_);
=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 @_;
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
{
+my ($usermod, $userlist, $only) = @_;
if (!%main::acl_hash_cache) {
# Read from local files
local $_;
}
}
close(ACL);
+ }
+%$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) = $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'");
- if ($cmd && $cmd->execute()) {
- while(my ($user, $mods) = $cmd->fetchrow()) {
- my @mods = split(/\s+/, $mods);
- foreach my $m (@mods) {
- $main::acl_hash_cache{$user,
- $m}++;
- }
- $main::acl_array_cache{$user} = \@mods;
+# 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") {
- # XXX read from LDAP
+ $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);
}
+ &disconnect_userdb($userdb, $dbh);
}
-if ($_[0]) { %{$_[0]} = %main::acl_hash_cache; }
-if ($_[1]) { %{$_[1]} = %main::acl_array_cache; }
}
=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') {
$miniserv{'inetd'} && return;
my @oldst = stat($miniserv{'pidfile'});
$pid = $ENV{'MINISERV_PID'};
- if (!$pid) {
- open(PID, $miniserv{'pidfile'}) ||
- &error("Failed to open PID file $miniserv{'pidfile'}");
+ 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);
- $pid || &error("Invalid PID file $miniserv{'pidfile'}");
+ 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
}
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;
$pid = $ENV{'MINISERV_PID'};
- if (!$pid) {
- open(PID, $miniserv{'pidfile'}) ||
- &error("Failed to open PID file $miniserv{'pidfile'}");
+ 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);
- $pid || &error("Invalid PID file $miniserv{'pidfile'}");
+ 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");
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
}
-=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".
# 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 :
# 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,'*'});
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/\..*$//;
# Use normal Webmin ACL, if a user is set
my $userdb = &get_userdb_string();
my $foundindb = 0;
- if ($userdb) {
- # Look for this user in the user/group DB
- my ($dbh, $proto) = &connect_userdb($userdb);
+ 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
}
}
elsif ($proto eq "ldap") {
- # Fetch ACLs from LDAP
- # XXX
+ # 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);
}
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);
}
my $userdb = &get_userdb_string();
my $foundindb = 0;
-if ($userdb) {
+if ($userdb && ($u ne $base_remote_user || $remote_user_proto)) {
# Look for this user in the user/group DB
- my ($dbh, $proto) = &connect_userdb($userdb);
+ 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
}
}
elsif ($proto eq "ldap") {
- # Update ACLs in LDAP
- # XXX
+ # 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);
}
my $foundindb = 0;
if ($userdb) {
# Look for this group in the user/group DB
- my ($dbh, $proto) = &connect_userdb($userdb);
+ 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($u) ||
+ $cmd && $cmd->execute($g) ||
&error(&text('egroupdbacl2', $dbh->errstr));
my ($id) = $cmd->fetchrow();
$foundindb = 1 if (defined($id));
}
}
elsif ($proto eq "ldap") {
- # Update ACLs in LDAP
- # XXX
+ # 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") {
$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 &&
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 @dmods = split(/\s+/, $gconfig{'debug_modules'});
return 0 if (&indexof($main::initial_module_name, @dmods) < 0);
}
-my $now = time();
+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();
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,
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'}};
}
}
}
+=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
&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;
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]);
}
}
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.
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
=cut
sub get_userdb_string
{
+return undef if ($main::no_miniserv_userdb);
my %miniserv;
&get_miniserv_config(\%miniserv);
return $miniserv{'userdb'};
$cstr .= ";port=$port" if ($port);
my $dbh = $drh->connect($cstr, $user, $pass, { });
$dbh || return &text('sql_emysqlconnect', $drh->errstr);
- return wantarray ? ($dbh, $proto) : $dbh;
+ return wantarray ? ($dbh, $proto, $prefix, $args) : $dbh;
}
elsif ($proto eq "postgresql") {
# Connect to PostgreSQL with DBI
$cstr .= ";port=$port" if ($port);
my $dbh = $drh->connect($cstr, $user, $pass);
$dbh || return &text('sql_epostgresqlconnect', $drh->errstr);
- return wantarray ? ($dbh, $proto) : $dbh;
+ return wantarray ? ($dbh, $proto, $prefix, $args) : $dbh;
}
elsif ($proto eq "ldap") {
- # XXX
- return "LDAP not done yet";
+ # 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";
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();
}
}
projects / webmin.git / blobdiff