diff --git a/CHANGELOG.md b/CHANGELOG.md
index 36b1ae06b..db4f438ad 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,6 +1,9 @@
## Changelog
#### 2.654 (August, 2026)
* Add incremental ban time options to the Fail2Ban module
+* Add Btrfs subvolume quota management to the Disk Quotas module, with full and simple accounting modes
+* Add support for creating `vfsv1` Linux quota files for limits above 4 TiB, while preserving existing quota file formats
+* Add support for openSUSE 16 vendor and local Logrotate configuration overlays [#2682](https://github.com/webmin/webmin/issues/2682)
* Fix to ignore failures when adding IPv6 link-local (fe80::) addresses that may already be configured automatically
* Fixed creation of permissions new log files in the System Logs module (thanks to Kevin Carter)
* Update the Authentic theme to the latest version with various improvements:
diff --git a/firewall/firewall-lib.pl b/firewall/firewall-lib.pl
index 7b3b5c069..f66adda43 100755
--- a/firewall/firewall-lib.pl
+++ b/firewall/firewall-lib.pl
@@ -527,7 +527,7 @@ local @oldjumps = grep { $_->{'chain'} eq 'INPUT' &&
# Get all new fail2ban chain rules and inputs that jump to them
local @newrules = grep { $_->{'chain'} =~ /^f2b-/ } @$newrules;
local @newjumps = grep { $_->{'chain'} eq 'INPUT' &&
- $_->{'j'}->[1] =~ /^f2b-/ } @newrules;
+ $_->{'j'}->[1] =~ /^f2b-/ } @$newrules;
# Re-create the chains
my @oldchains = &unique(map { $_->{'chain'} } @oldrules);
diff --git a/lang/en b/lang/en
index be1fa3b29..2247b5102 100644
--- a/lang/en
+++ b/lang/en
@@ -195,6 +195,7 @@ pam_restart=Restart
login_notsecure=Not Secure
login_notsecure_desc=This connection is not secure and could let a man-in-the-middle attack intercept your password or session cookie. Click here to switch to an HTTPS connection, unless you are on a trusted local network or behind a secure reverse proxy.
+login_notsecure_http_desc=This connection is not encrypted and could let a man-in-the-middle attack intercept your password or session cookie. HTTPS is not enabled in Webmin; enable it unless you are on a trusted local network or behind a secure reverse proxy.
acl_root=Root directory for file chooser
acl_otherdirs=Other visible directories in file chooser
diff --git a/login-lib.pl b/login-lib.pl
new file mode 100755
index 000000000..eb22a83b6
--- /dev/null
+++ b/login-lib.pl
@@ -0,0 +1,27 @@
+# login-lib.pl
+# Common functions for the built-in login pages.
+
+# get_login_http_warning(&miniserv-config)
+# Returns the insecure-login warning HTML, or undef if none is needed
+sub get_login_http_warning
+{
+my ($miniserv) = @_;
+return undef if ($ENV{'HTTPS'} eq 'ON' ||
+ (!$miniserv->{'ssl'} && $miniserv->{'no_ssl_warn'}));
+
+my $warning = "⚠ $text{'login_notsecure'}";
+my $description = $text{'login_notsecure_http_desc'};
+if ($miniserv->{'ssl'}) {
+ $warning = ui_tag('a', $warning,
+ { 'href' => "javascript:void(0);",
+ 'class' => 'inherit-color',
+ 'onclick' => "window.location.href = ".
+ "window.location.href.replace(/^http:/, 'https:'); return false;",
+ });
+ $description = $text{'login_notsecure_desc'};
+ }
+return ui_tag('span', $warning,
+ { class => 'not-secure', title => $description });
+}
+
+1;
diff --git a/logrotate/backup_config.pl b/logrotate/backup_config.pl
index 9a8c1be45..d25f2f837 100755
--- a/logrotate/backup_config.pl
+++ b/logrotate/backup_config.pl
@@ -5,8 +5,18 @@ do 'logrotate-lib.pl';
# Returns files and directories that can be backed up
sub backup_config_files
{
-local $conf = &get_config();
-return &unique(map { $_->{'file'} } @$conf);
+# Keep backup behavior unchanged on systems without the vendor overlay.
+if (!$config{'vendor_logrotate_conf'} && !$config{'vendor_add_file'}) {
+ local $conf = &get_config();
+ return &unique(map { $_->{'file'} } @$conf);
+ }
+
+# Back up only writable files. Use the complete effective file list so an
+# empty local file that intentionally shadows a vendor file is preserved.
+local ($conf, $lnum, $files) = &get_config();
+return &unique(grep { !&is_vendor_main_config($_) &&
+ !&is_vendor_config_file($_) }
+ @$files);
}
# pre_backup(&files)
diff --git a/logrotate/config-openSUSE-Linux-16.0-ALL b/logrotate/config-openSUSE-Linux-16.0-ALL
index 6ddca8e5c..af724fb7f 100644
--- a/logrotate/config-openSUSE-Linux-16.0-ALL
+++ b/logrotate/config-openSUSE-Linux-16.0-ALL
@@ -1,5 +1,8 @@
sort_mode=0
logrotate_conf=/etc/logrotate.conf
+vendor_logrotate_conf=/usr/etc/logrotate.conf
add_file=/etc/logrotate.d
+vendor_add_file=/usr/etc/logrotate.d
scan_add_file=1
logrotate=logrotate
+logrotate_all=/usr/sbin/logrotate-all
diff --git a/logrotate/delete_logs.cgi b/logrotate/delete_logs.cgi
index ea0af75f2..bf6477aaf 100755
--- a/logrotate/delete_logs.cgi
+++ b/logrotate/delete_logs.cgi
@@ -12,6 +12,19 @@ require './logrotate-lib.pl';
# Delete the sections
$parent = &get_config_parent();
$conf = $parent->{'members'};
+
+# Copy each selected vendor file to the local override tree before changing
+# it. Reload the parsed configuration after copying so all line references
+# point at the writable files.
+%vendor_files = map { $conf->[$_]->{'file'}, 1 }
+ grep { &is_vendor_config_file($conf->[$_]->{'file'}) } @d;
+if (%vendor_files) {
+ foreach $f (keys %vendor_files) {
+ &ensure_local_config_override($f);
+ }
+ $parent = &get_config_parent();
+ $conf = $parent->{'members'};
+ }
foreach $d (sort { $b <=> $a } @d) {
$log = $conf->[$d];
&lock_file($log->{'file'});
diff --git a/logrotate/edit_log.cgi b/logrotate/edit_log.cgi
index 5124ec254..6ef61531d 100755
--- a/logrotate/edit_log.cgi
+++ b/logrotate/edit_log.cgi
@@ -20,6 +20,23 @@ else {
$lconf = $log->{'members'};
}
+# Explain which side of the vendor/local overlay is displayed and where a
+# copy-on-write edit will be saved before presenting the form.
+if ($in{'global'} && &is_vendor_main_config(&get_main_config_file())) {
+ print &ui_alert_box(&text('global_vendor',
+ "".&html_escape($config{'logrotate_conf'}).""),
+ 'info');
+ }
+elsif ($log && &is_vendor_config_file($log->{'file'})) {
+ print &ui_alert_box(&text('edit_vendor',
+ "".&html_escape(&get_local_override_file(
+ $log->{'file'})).""), 'info');
+ }
+elsif ($log && (my $vendor = &get_vendor_config_file($log->{'file'}))) {
+ print &ui_alert_box(&text('edit_override',
+ "".&html_escape($vendor).""), 'info');
+ }
+
print &ui_form_start("save_log.cgi", "post", undef, "id='edit_log_form'");
print &ui_hidden("new", $in{'new'}),"\n";
print &ui_hidden("idx", $in{'idx'}),"\n";
diff --git a/logrotate/edit_sched.cgi b/logrotate/edit_sched.cgi
index 97bfb8d02..61d64d9dd 100755
--- a/logrotate/edit_sched.cgi
+++ b/logrotate/edit_sched.cgi
@@ -5,7 +5,13 @@
require './logrotate-lib.pl';
&ui_print_header(undef, $text{'sched_title'}, "");
-print "
",&text('sched_desc', "$config{'logrotate'}"),"
\n";
+# Show the wrapper or fallback command on vendor-overlay systems, while
+# retaining the original short program name everywhere else.
+my $sched_command = ($config{'logrotate_all'} ||
+ $config{'vendor_logrotate_conf'} || $config{'vendor_add_file'}) ?
+ &get_scheduled_logrotate_command() : $config{'logrotate'};
+print "
",&text('sched_desc', "".
+ &html_escape($sched_command).""),"
\n";
# Find the job, looking in daily directories too
&foreign_require("cron", "cron-lib.pl");
diff --git a/logrotate/force.cgi b/logrotate/force.cgi
index 0a8bbf2d1..c1fde6870 100755
--- a/logrotate/force.cgi
+++ b/logrotate/force.cgi
@@ -10,8 +10,12 @@ $SIG{'TERM'} = 'IGNORE';
print $text{'force_doing'},"\n";
&clean_environment();
-my (undef, undef, $files) = &get_config($config{'logrotate_conf'});
-my @configs = ($config{'logrotate_conf'}, &get_add_file_configs($files));
+
+# Force the same effective main and drop-in configs selected by the distro
+# wrapper, while avoiding duplicate files already reached through includes.
+my $main = &get_main_config_file();
+my (undef, undef, $files) = &get_config($main);
+my @configs = ($main, &get_add_file_configs($files));
my $configs = join(" ", map { "e_path($_) } @configs);
$out = &backquote_logged("$config{'logrotate'} -f $configs 2>&1");
&reset_environment();
diff --git a/logrotate/index.cgi b/logrotate/index.cgi
index 7ee559eb6..802205c62 100755
--- a/logrotate/index.cgi
+++ b/logrotate/index.cgi
@@ -19,11 +19,12 @@ if (!&has_command($config{'logrotate'})) {
&ui_print_footer("/", $text{'index'});
exit;
}
-if (!-r $config{'logrotate_conf'}) {
+my $main_config = &get_main_config_file();
+if (!-r $main_config) {
&ui_print_header(undef, $text{'index_title'}, "", "intro", 1, 1);
&ui_print_endpage(
&ui_config_link('index_econf',
- [ "$config{'logrotate_conf'}", undef ]));
+ [ "$main_config", undef ]));
}
# Get the version
@@ -52,9 +53,19 @@ foreach $c ($config{'sort_mode'} ?
local $p = &get_period($c->{'members'}) || $defp;
local $r = &find_value("postrotate", $c->{'members'});
$r =~ s/\n/
\n/g;
+ local $label = join(" ", map { "$_
" }
+ @{$c->{'name'}});
+
+ # Distinguish read-only vendor entries from writable local files
+ # that shadow a vendor entry at the same relative path.
+ if (&is_vendor_config_file($c->{'file'})) {
+ $label .= "$text{'index_vendor'}";
+ }
+ elsif (&get_vendor_config_file($c->{'file'})) {
+ $label .= "$text{'index_override'}";
+ }
push(@table, [ &ui_link("edit_log.cgi?idx=".$c->{'index'},
- join(" ", map { "$_
" }
- @{$c->{'name'}}) ),
+ $label),
$text{'period_'.$p} ||
"$text{'index_notset'}",
$r ? "$r"
diff --git a/logrotate/install_check.pl b/logrotate/install_check.pl
index 60a66a796..0d5ca01c0 100755
--- a/logrotate/install_check.pl
+++ b/logrotate/install_check.pl
@@ -6,7 +6,9 @@ do 'logrotate-lib.pl';
# For mode 0, returns 1 if installed, 0 if not.
sub is_installed
{
-return 0 if (!-r $config{'logrotate_conf'} && !-r $config{'sample_conf'});
+# Accept the vendor main config when the optional local override is absent.
+my $main = &get_main_config_file();
+return 0 if (!-r $main && !-r $config{'sample_conf'});
return 0 if (!&has_command($config{'logrotate'}));
return $_[0] ? 2 : 1;
}
diff --git a/logrotate/lang/en b/logrotate/lang/en
index 8d57c99be..9cc0c7d95 100644
--- a/logrotate/lang/en
+++ b/logrotate/lang/en
@@ -19,6 +19,8 @@ index_force=Force Log Rotation
index_forcedesc=Force the immediate rotation of all log files, even if it is not yet time.
index_logrotate=Logrotate
index_delete=Delete Selected Log Rotations
+index_vendor=Vendor configuration
+index_override=Local vendor override
period_daily=Daily
period_weekly=Weekly
@@ -65,11 +67,17 @@ edit_default=Default ($1)
edit_sharedscripts=Only run scripts once for all files?
edit_now=Rotate Now
edit_clone=Clone
+edit_vendor=This is a vendor-provided configuration. Saving or deleting it will first create the local override $1; the file under /usr/etc will not be changed.
+edit_override=This local configuration overrides the vendor file $1.
global_title=Global Options
global_header=Default options for all log files
+global_vendor=These defaults currently come from the vendor configuration. Saving will first create the writable local configuration $1; the file under /usr/etc will not be changed.
save_err=Failed to save log
+save_eoverride=Cannot create local override $1 because that path already exists and is not a regular file.
+save_ecopy=Failed to create local override $1: $2
+save_evendorwrite=Refusing to modify vendor configuration $1 without first creating a local override.
save_efile=Missing or invalid log filename
save_esize=Missing or invalid maximum size
save_eminsize=Missing or invalid minimum size
diff --git a/logrotate/logrotate-lib.pl b/logrotate/logrotate-lib.pl
index 907f95975..e02dbae51 100755
--- a/logrotate/logrotate-lib.pl
+++ b/logrotate/logrotate-lib.pl
@@ -15,10 +15,15 @@ if (!-r $config{'logrotate_conf'} && -r $config{'sample_conf'}) {
©_source_dest($config{'sample_conf'}, $config{'logrotate_conf'});
}
+# get_config_parent()
+# Returns the parsed global config while keeping the writable local file as
+# its save target. Callers must materialize that file before global writes.
sub get_config_parent
{
if (!$get_config_parent_cache) {
local ($conf, $lines) = &get_config();
+ # Even when members came from the vendor config, never make /usr the
+ # destination for newly-added global directives.
$get_config_parent_cache = { 'members' => $conf,
'file' => $config{'logrotate_conf'},
'line' => 0,
@@ -28,28 +33,235 @@ if (!$get_config_parent_cache) {
return $get_config_parent_cache;
}
+# get_main_config_file()
+# Returns the local main config, or the vendor default if no local one exists
+sub get_main_config_file
+{
+return $config{'logrotate_conf'} if (-e $config{'logrotate_conf'});
+return $config{'vendor_logrotate_conf'}
+ if ($config{'vendor_logrotate_conf'});
+return $config{'logrotate_conf'};
+}
+
+# is_vendor_main_config(file)
+# Returns 1 if a file is the vendor-provided main config
+sub is_vendor_main_config
+{
+my ($file) = @_;
+return $config{'vendor_logrotate_conf'} &&
+ &same_file($file, $config{'vendor_logrotate_conf'});
+}
+
+# relative_config_path(file, directory)
+# Returns a file's path relative to a config directory
+sub relative_config_path
+{
+my ($file, $dir) = @_;
+return undef if (!$file || !$dir);
+$dir =~ s/\/+$//;
+$dir .= '/';
+return $file =~ /^\Q$dir\E(.+)$/ ? $1 : undef;
+}
+
+# is_vendor_config_file(file)
+# Returns 1 if a drop-in comes from the vendor directory
+sub is_vendor_config_file
+{
+my ($file) = @_;
+return defined(&relative_config_path(
+ $file, $config{'vendor_add_file'}));
+}
+
+# get_local_override_file(vendor-file)
+# Returns the local path that overrides a vendor drop-in
+sub get_local_override_file
+{
+my ($file) = @_;
+my $rel = &relative_config_path($file, $config{'vendor_add_file'});
+return undef if (!defined($rel) || !$config{'add_file'});
+return $config{'add_file'}.'/'.$rel;
+}
+
+# get_vendor_config_file(local-file)
+# Returns the vendor file shadowed by a local drop-in, if any
+sub get_vendor_config_file
+{
+my ($file) = @_;
+my $rel = &relative_config_path($file, $config{'add_file'});
+return undef if (!defined($rel) || !$config{'vendor_add_file'});
+my $vendor = $config{'vendor_add_file'}.'/'.$rel;
+return -f $vendor ? $vendor : undef;
+}
+
+# flush_logrotate_config_cache()
+# Clears parsed config state after creating a local override
+sub flush_logrotate_config_cache
+{
+%get_config_cache = ( );
+%get_config_lnum_cache = ( );
+%get_config_files_cache = ( );
+$get_config_parent_cache = undef;
+}
+
+# copy_vendor_config(source, destination)
+# Copies a vendor config to the writable local tree
+sub copy_vendor_config
+{
+my ($source, $dest) = @_;
+
+# An existing independent regular destination is already a usable override.
+# Refuse links to the vendor file, symlinks, and other non-regular file types
+# so the local path cannot redirect writes back into the read-only tree.
+if (-e $dest || -l $dest) {
+ if (-f $dest && !-l $dest) {
+ if (&same_file($source, $dest)) {
+ &error(&text('save_evendorwrite', "".
+ &html_escape($source).""));
+ }
+ else {
+ &flush_logrotate_config_cache();
+ return $dest;
+ }
+ }
+ &error(&text('save_eoverride', "".
+ &html_escape($dest).""));
+ }
+
+# Create missing subdirectories before copying the complete vendor file.
+# Following a source symlink produces an editable snapshot, not another link.
+my $dir = $dest;
+$dir =~ s/\/[^\/]+$//;
+&make_dir_recursive($dir, 0755) if (!-d $dir);
+my ($ok, $err) = ©_source_dest($source, $dest, 1);
+
+# Do not leave a partial override behind after a copy or chmod failure, since
+# even an incomplete local file would hide the valid vendor configuration.
+if (!$ok || !&set_ownership_permissions(undef, undef, 0644, $dest)) {
+ $err ||= $!;
+ &unlink_file($dest) if (-e $dest || -l $dest);
+ &error(&text('save_ecopy', "".&html_escape($dest)."",
+ &html_escape($err)));
+ }
+
+# Force the next read to select and parse the newly-created local file.
+&flush_logrotate_config_cache();
+return $dest;
+}
+
+# ensure_local_main_config()
+# Creates a writable local main config when only the vendor default exists
+sub ensure_local_main_config
+{
+my $main = &get_main_config_file();
+return $config{'logrotate_conf'}
+ if (!&is_vendor_main_config($main));
+return ©_vendor_config($main, $config{'logrotate_conf'});
+}
+
+# ensure_local_config_override(vendor-file)
+# Creates a writable local copy that shadows a vendor drop-in
+sub ensure_local_config_override
+{
+my ($file) = @_;
+my $local = &get_local_override_file($file);
+return $file if (!$local);
+return ©_vendor_config($file, $local);
+}
+
+# list_config_dir_files(directory, [relative-subdirectory])
+# Returns relative and absolute paths for regular files below a directory
+sub list_config_dir_files
+{
+my ($dir, $subdir) = @_;
+my $path = $subdir ? $dir.'/'.$subdir : $dir;
+opendir(my $dh, $path) || return ( );
+my @names = sort { $a cmp $b } readdir($dh);
+closedir($dh);
+my @rv;
+foreach my $name (@names) {
+ next if ($name eq '.' || $name eq '..');
+ my $rel = $subdir ? $subdir.'/'.$name : $name;
+ my $file = $dir.'/'.$rel;
+
+ # Match find without -L: ignore symlinks, recurse into real directories,
+ # and return only regular files with paths relative to the scanned root.
+ next if (-l $file);
+ if (-d $file) {
+ push(@rv, &list_config_dir_files($dir, $rel));
+ }
+ elsif (-f $file) {
+ push(@rv, [ $rel, $file ]);
+ }
+ }
+return @rv;
+}
+
# get_add_file_configs([&already-loaded-files])
-# Returns configs loaded externally from the add-file directory
+# Returns the effective vendor and local configs loaded by logrotate-all
sub get_add_file_configs
{
my ($files) = @_;
-return ( ) if (!$config{'scan_add_file'} || !$config{'add_file'} ||
- !-d $config{'add_file'});
+return ( ) if (!$config{'scan_add_file'});
+
+# Collect the same relative names produced by the wrapper's recursive find.
+# Processing the local tree last records its regular files directly.
+my %effective;
+foreach my $dir ($config{'vendor_add_file'}, $config{'add_file'}) {
+ next if (!$dir || !-d $dir);
+ foreach my $entry (&list_config_dir_files($dir)) {
+ $effective{$entry->[0]} = $entry->[1];
+ }
+ }
+
+# Match the wrapper's stable lexical order and omit files already reached by
+# an explicit include in the main configuration. The existence check also
+# honors a local non-regular counterpart exactly as the wrapper does.
my @rv;
-foreach my $f (glob("$config{'add_file'}/*")) {
- next if (!-f $f || $files &&
+foreach my $name (sort { $a cmp $b } keys %effective) {
+ my $local = $config{'add_file'} ?
+ $config{'add_file'}.'/'.$name : undef;
+ my $f = $local && -e $local ? $local : $effective{$name};
+ next if ($files &&
grep { &same_file($_, $f) } @$files);
push(@rv, $f);
}
return @rv;
}
+# get_scheduled_logrotate_command()
+# Returns the distro wrapper, or a command for the effective config files
+sub get_scheduled_logrotate_command
+{
+# The distro wrapper discovers the effective drop-in set on every run, so it
+# remains correct when packages or administrators add files later.
+if ($config{'logrotate_all'} && -x $config{'logrotate_all'}) {
+ return "e_path($config{'logrotate_all'});
+ }
+
+# Preserve the historical command exactly on systems that do not opt into
+# external or vendor configuration discovery.
+if (!$config{'vendor_logrotate_conf'} && !$config{'vendor_add_file'} &&
+ !$config{'scan_add_file'}) {
+ return &has_command($config{'logrotate'})." ".
+ $config{'logrotate_conf'};
+ }
+
+# If the configured wrapper is unavailable, build a usable command from the
+# effective main config and the drop-ins visible at schedule creation time.
+my $main = &get_main_config_file();
+my (undef, undef, $files) = &get_config($main);
+my @configs = ($main, &get_add_file_configs($files));
+my $program = &has_command($config{'logrotate'}) || $config{'logrotate'};
+return "e_path($program).' '.
+ join(' ', map { "e_path($_) } @configs);
+}
+
# get_config([file])
# Returns a list of logrotate config file entries
sub get_config
{
my ($argfile) = @_;
-my $file = $argfile || $config{'logrotate_conf'};
+my $file = $argfile || &get_main_config_file();
if (!$argfile && $get_config_cache{$file}) {
return wantarray ? ( $get_config_cache{$file},
$get_config_lnum_cache{$file},
@@ -210,17 +422,57 @@ return undef;
}
# save_directive(&parent, &old|name, &new, [indent])
-# Update a single entry in the config, identified by either name or
-# the direcctive being replaced
+# Updates one entry identified by either its name or parsed object
sub save_directive
{
my ($parent, $oldv, $newv, $indent) = @_;
my $conf = $parent->{'members'};
my $old = !defined($oldv) ? undef : ref($oldv) ? $oldv : &find($oldv, $conf);
-my $lref = &read_file_lines($old ? $old->{'file'} : $parent->{'file'});
my $new = !defined($newv) ? undef : ref($newv) ? $newv :
{ 'name' => $old ? $old->{'name'} : $oldv,
'value' => $newv };
+
+# Deleting an entry that is already absent is a true no-op. In particular,
+# do not put a missing local main config into the writable line cache.
+return if (!$old && !$new);
+
+# Find the file behind this write. Existing directives use their own file,
+# new sections may name a separate file, and other additions use the parent
+# section or effective main config.
+my $vendor_file;
+my $write_file = $parent->{'file'};
+if ($old) {
+ $write_file = $old->{'file'};
+ }
+elsif ($new && $new->{'file'} &&
+ !($parent->{'global'} && !$new->{'members'})) {
+ $write_file = $new->{'file'};
+ }
+if ($write_file) {
+ my $shadowed_vendor = &get_vendor_config_file($write_file);
+ if (&is_vendor_main_config($write_file) ||
+ &is_vendor_config_file($write_file)) {
+ $vendor_file = $write_file;
+ }
+ elsif ($shadowed_vendor &&
+ (!-f $write_file || -l $write_file ||
+ &same_file($write_file, $shadowed_vendor))) {
+ $vendor_file = $shadowed_vendor;
+ }
+ }
+if (!$vendor_file && !$old && $parent->{'global'} &&
+ &same_file($write_file, $parent->{'file'}) &&
+ &is_vendor_main_config(&get_main_config_file())) {
+ $vendor_file = &get_main_config_file();
+ }
+
+# Copying changes which file owns the parsed objects, so callers must create
+# and reload a local override before editing. Never write through a stale
+# object that still points at the vendor tree.
+&error(&text('save_evendorwrite',
+ "".&html_escape($vendor_file)."")) if ($vendor_file);
+
+my $lref = &read_file_lines($write_file);
my @lines = &directive_lines($new, $indent) if ($new);
my $gparent = &get_config_parent();
if ($old && $new) {
@@ -324,10 +576,12 @@ return @rv;
}
# delete_if_empty(file)
-# Remove a file if it has no more lines in the config
+# Removes a file if it has no more parsed entries, unless it is a local
+# override whose continued existence is needed to hide a vendor file
sub delete_if_empty
{
my ($file) = @_;
+return if (&get_vendor_config_file($file));
my $conf = &get_config();
my %files = map { $_, 1 } &unique(map { $_->{'file'} } @$conf);
&unlink_file($file) if (!$files{$file});
diff --git a/logrotate/save_log.cgi b/logrotate/save_log.cgi
index ad3a194b9..0be324331 100755
--- a/logrotate/save_log.cgi
+++ b/logrotate/save_log.cgi
@@ -4,18 +4,56 @@
require './logrotate-lib.pl';
&ReadParse();
+
+# Resolve a new section's destination before loading any parsed objects. If
+# its relative name already exists in the vendor tree, materialize the whole
+# local override before appending the new section.
+@files = split(/\s+/, $in{'file'});
+if ($in{'new'} ||
+ (!$in{'global'} && !$in{'delete'} && !$in{'now'})) {
+ &error_setup($text{'save_err'});
+ foreach $f (@files) {
+ $f =~ /^\/\S+$/ || &error($text{'save_efile'});
+ }
+ @files || &error($text{'save_enofiles'});
+ $in{'file'} =~ s/\r//g;
+ }
+if ($in{'new'}) {
+ $cfilename = $files[0] =~ /\/([^\/]+)$/ ? $1 : undef;
+ $new_config_file = &get_add_file($cfilename);
+ $vendor_file = &get_vendor_config_file($new_config_file);
+ if ($vendor_file) {
+ &ensure_local_config_override($vendor_file);
+ }
+ elsif (&same_file($new_config_file, $config{'logrotate_conf'}) &&
+ &is_vendor_main_config(&get_main_config_file())) {
+ &ensure_local_main_config();
+ }
+ }
+
+# On systems with vendor configuration below /usr, create the writable local
+# main config before changing global options. The parent object intentionally
+# keeps this local path as its write destination.
+&ensure_local_main_config() if ($in{'global'});
$parent = &get_config_parent();
$conf = $parent->{'members'};
-@files = split(/\s+/, $in{'file'});
+
+# A local drop-in shadows the whole vendor file, so copy it intact before
+# editing or deleting one section. Rotate Now is read-only and needs no copy.
+if (!$in{'global'} && !$in{'new'} && !$in{'now'} &&
+ &is_vendor_config_file($conf->[$in{'idx'}]->{'file'})) {
+ &ensure_local_config_override($conf->[$in{'idx'}]->{'file'});
+ $parent = &get_config_parent();
+ $conf = $parent->{'members'};
+ }
if ($in{'global'}) {
# Editing the global options
$log = $parent;
}
elsif ($in{'new'}) {
# Adding a new section
- $cfilename = $files[0] =~ /\/([^\/]+)$/ ? $1 : undef;
$log = { 'members' => [ ],
- 'file' => &get_add_file($cfilename) };
+ 'file' => $new_config_file };
$logfile = $in{'file'};
}
else {
@@ -52,11 +90,6 @@ else {
&lock_file($log->{'file'});
&error_setup($text{'save_err'});
if (!$in{'global'}) {
- foreach $f (@files) {
- $f =~ /^\/\S+$/ || &error($text{'save_efile'});
- }
- @files || &error($text{'save_enofiles'});
- $in{'file'} =~ s/\r//g;
$log->{'name'} = [ split(/\n/, $in{'file'}) ];
}
diff --git a/logrotate/save_sched.cgi b/logrotate/save_sched.cgi
index 23a6b027f..c1688eed5 100755
--- a/logrotate/save_sched.cgi
+++ b/logrotate/save_sched.cgi
@@ -11,9 +11,10 @@ if ($in{'idx'} ne "") {
$oldjob = $job = $jobs[$in{'idx'}];
}
else {
+ # Prefer the distro wrapper, when available, so future runs discover the
+ # then-current vendor and local drop-in set.
$job = { 'user' => 'root',
- 'command' => &has_command($config{'logrotate'})." ".
- $config{'logrotate_conf'},
+ 'command' => &get_scheduled_logrotate_command(),
'active' => 1 };
}
&lock_file(&cron::cron_file($job));
diff --git a/logrotate/t/run-tests.t b/logrotate/t/run-tests.t
index e5efba992..9ab92d237 100644
--- a/logrotate/t/run-tests.t
+++ b/logrotate/t/run-tests.t
@@ -7,34 +7,55 @@ use File::Basename qw(dirname);
use File::Path qw(make_path);
use File::Temp qw(tempdir);
-my $module_dir = abs_path(dirname(abs_path($0))."/..");
+# Locate the repository and load its common test helpers.
+my $test_dir = dirname(abs_path($0));
+my $module_dir = abs_path("$test_dir/..");
my $root_dir = abs_path("$module_dir/..");
+require "$root_dir/t/test-lib.pl";
+
+# Build an isolated openSUSE-style /etc and /usr/etc configuration layout.
my $config_dir = tempdir(CLEANUP => 1);
my $var_dir = tempdir(CLEANUP => 1);
my $fixture_dir = tempdir(CLEANUP => 1);
-my $add_dir = "$fixture_dir/logrotate.d";
-my $main_file = "$fixture_dir/logrotate.conf";
-make_path("$config_dir/logrotate", $add_dir);
-
-sub write_text
-{
-my ($file, $text) = @_;
-open(my $fh, ">", $file) or die "open $file: $!";
-print $fh $text;
-close($fh) or die "close $file: $!";
-}
+my $local_add_dir = "$fixture_dir/etc/logrotate.d";
+my $vendor_add_dir = "$fixture_dir/usr/etc/logrotate.d";
+my $local_main_file = "$fixture_dir/etc/logrotate.conf";
+my $vendor_main_file = "$fixture_dir/usr/etc/logrotate.conf";
+my $wrapper = "$fixture_dir/usr/sbin/logrotate-all";
+make_path("$config_dir/logrotate", $local_add_dir,
+ "$local_add_dir/nested", "$vendor_add_dir/deep",
+ "$vendor_add_dir/nested", dirname($wrapper));
+# Populate both trees with vendor-only, local-only, nested, and overridden
+# files so the fixture exercises the wrapper's key overlay rules.
+my $vendor_main_text =
+ "weekly\n/var/log/vendor-main.log {\n\trotate 4\n}\n";
write_text("$config_dir/config", "os_type=linux\nos_version=0\n");
write_text("$config_dir/logrotate/config",
"sort_mode=0\n".
- "logrotate_conf=$main_file\n".
- "add_file=$add_dir\n".
+ "logrotate_conf=$local_main_file\n".
+ "vendor_logrotate_conf=$vendor_main_file\n".
+ "add_file=$local_add_dir\n".
+ "vendor_add_file=$vendor_add_dir\n".
"scan_add_file=1\n".
- "logrotate=logrotate\n");
-write_text($main_file, "weekly\n/var/log/main.log {\n\trotate 4\n}\n");
-write_text("$add_dir/one", "/var/log/one.log {\n\tdaily\n}\n");
-write_text("$add_dir/two", "/var/log/two.log {\n\tmonthly\n}\n");
+ "logrotate=/bin/echo\n".
+ "logrotate_all=$wrapper\n");
+write_text($vendor_main_file, $vendor_main_text);
+write_text("$vendor_add_dir/one", "/var/log/vendor-one.log {\n\tdaily\n}\n");
+write_text("$vendor_add_dir/shared",
+ "/var/log/vendor-shared.log {\n\tdaily\n}\n");
+write_text("$vendor_add_dir/deep/vendor",
+ "/var/log/deep-vendor.log {\n\tmonthly\n}\n");
+write_text("$local_add_dir/local-only",
+ "/var/log/local-only.log {\n\tweekly\n}\n");
+write_text("$local_add_dir/shared",
+ "/var/log/local-shared.log {\n\tweekly\n}\n");
+write_text("$local_add_dir/nested/local",
+ "/var/log/nested-local.log {\n\tweekly\n}\n");
+write_text($wrapper, "#!/bin/sh\nexit 0\n");
+chmod(0755, $wrapper) or die "chmod $wrapper: $!";
+# Point Webmin at the isolated fixture before loading the module library.
$ENV{'WEBMIN_CONFIG'} = $config_dir;
$ENV{'WEBMIN_VAR'} = $var_dir;
$ENV{'FOREIGN_MODULE_NAME'} = 'logrotate';
@@ -42,6 +63,8 @@ $ENV{'FOREIGN_ROOT_DIRECTORY'} = $root_dir;
chdir($module_dir) or die "chdir $module_dir: $!";
require "$module_dir/logrotate-lib.pl";
+# clear_config_cache()
+# Forces each test phase to parse the configuration from disk again
sub clear_config_cache
{
no warnings 'once';
@@ -51,6 +74,8 @@ no warnings 'once';
$main::get_config_parent_cache = undef;
}
+# log_names(config)
+# Returns only the log path names from parsed rotation sections
sub log_names
{
my ($config) = @_;
@@ -58,40 +83,297 @@ return [ map { $_->{'name'}->[0] }
grep { $_->{'members'} } @$config ];
}
+# The vendor main file is the initial fallback because no local main exists.
+is(main::get_main_config_file(), $vendor_main_file,
+ 'vendor main config is used when no local main config exists');
+ok(main::is_vendor_main_config($vendor_main_file),
+ 'vendor main config is recognized');
+
+# Match the wrapper's existence test rather than requiring a regular file.
+my $nonregular_main = "$fixture_dir/etc/nonregular-main";
+make_path($nonregular_main);
+{
+local $main::config{'logrotate_conf'} = $nonregular_main;
+is(main::get_main_config_file(), $nonregular_main,
+ 'local main path wins whenever it exists');
+}
+{
+local $main::config{'logrotate_conf'} = "$fixture_dir/etc/missing-main";
+local $main::config{'vendor_logrotate_conf'} =
+ "$fixture_dir/usr/etc/missing-main";
+is(main::get_main_config_file(), $main::config{'vendor_logrotate_conf'},
+ 'configured vendor main path is used whenever the local path is absent');
+}
+
+# The effective list is sorted by relative path, with local files replacing
+# vendor files that have the same relative path.
+my @effective_add_files = (
+ "$vendor_add_dir/deep/vendor",
+ "$local_add_dir/local-only",
+ "$local_add_dir/nested/local",
+ "$vendor_add_dir/one",
+ "$local_add_dir/shared",
+ );
my ($config, undef, $files) = main::get_config();
is_deeply(log_names($config),
- [ '/var/log/main.log', '/var/log/one.log', '/var/log/two.log' ],
- 'opt-in scan loads sections from add_file directory');
+ [ '/var/log/vendor-main.log', '/var/log/deep-vendor.log',
+ '/var/log/local-only.log', '/var/log/nested-local.log',
+ '/var/log/vendor-one.log', '/var/log/local-shared.log' ],
+ 'vendor and local trees are recursively merged with local precedence');
is_deeply([ map { $_->{'index'} } grep { $_->{'members'} } @$config ],
- [ 1, 2, 3 ], 'scanned sections keep stable top-level indexes');
-is_deeply($files,
- [ $main_file, "$add_dir/one", "$add_dir/two" ],
- 'file cache contains the primary and scanned configuration files');
-my (undef, undef, $primary_files) = main::get_config($main_file);
-is_deeply([ main::get_add_file_configs($primary_files) ],
- [ "$add_dir/one", "$add_dir/two" ],
- 'force rotation adds externally loaded configuration files');
+ [ 1, 2, 3, 4, 5, 6 ],
+ 'effective sections keep stable top-level indexes');
+is_deeply($files, [ $vendor_main_file, @effective_add_files ],
+ 'file cache contains the effective main and merged drop-ins');
+ok(!grep({ $_ eq "$vendor_add_dir/shared" } @$files),
+ 'local file hides the same relative vendor file');
+my (undef, undef, $primary_files) = main::get_config($vendor_main_file);
+is_deeply([ main::get_add_file_configs($primary_files) ],
+ \@effective_add_files,
+ 'externally loaded configuration files match the effective overlay');
+is(main::get_scheduled_logrotate_command(), main::quote_path($wrapper),
+ 'scheduled rotations use the distribution wrapper');
+
+# Disabling the opt-in must restore the behavior used by other distributions.
$main::config{'scan_add_file'} = 0;
clear_config_cache();
($config, undef, $files) = main::get_config();
-is_deeply(log_names($config), [ '/var/log/main.log' ],
- 'add_file is not scanned without explicit opt-in');
-is_deeply($files, [ $main_file ],
- 'file cache excludes add_file directory when scanning is disabled');
+is_deeply(log_names($config), [ '/var/log/vendor-main.log' ],
+ 'vendor and local trees are not scanned without explicit opt-in');
+is_deeply($files, [ $vendor_main_file ],
+ 'file cache excludes external directories when scanning is disabled');
+# The low-level writer must fail closed if a caller skips copy-on-write.
+{
+no warnings qw(once redefine);
+local *main::error = sub { die $_[0]; };
+eval {
+ main::save_directive(main::get_config_parent(), 'weekly', '');
+ };
+like($@, qr/Refusing to modify vendor configuration/,
+ 'direct writes to the vendor main configuration are rejected');
+}
+
+# Deleting an already-absent option is a no-op and must not cache an empty
+# local main file that a later unscoped flush could accidentally create.
+main::save_directive(main::get_config_parent(),
+ 'missing-vendor-option', undef);
+main::flush_file_lines();
+ok(!-e $local_main_file,
+ 'missing global option deletion leaves the local main config absent');
+
+# A new section with an explicit vendor destination must also fail closed.
+my $vendor_target = "$vendor_add_dir/one";
+my $vendor_target_text = read_text($vendor_target);
+{
+no warnings qw(once redefine);
+local *main::error = sub { die $_[0]; };
+eval {
+ main::save_directive(main::get_config_parent(), undef,
+ { 'file' => $vendor_target,
+ 'name' => [ '/var/log/unsafe-vendor-write.log' ],
+ 'members' => [ ] });
+ };
+like($@, qr/Refusing to modify vendor configuration/,
+ 'new sections cannot target a vendor drop-in directly');
+}
+is(read_text($vendor_target), $vendor_target_text,
+ 'rejecting a new vendor section leaves its destination unchanged');
+
+# A section without its own file would create an incomplete local main config.
+{
+no warnings qw(once redefine);
+local *main::error = sub { die $_[0]; };
+eval {
+ main::save_directive(main::get_config_parent(), undef,
+ { 'name' => [ '/var/log/unsafe-main-write.log' ],
+ 'members' => [ ] });
+ };
+like($@, qr/Refusing to modify vendor configuration/,
+ 'new sections cannot replace the vendor main config implicitly');
+}
+ok(!-e $local_main_file,
+ 'rejecting an implicit main write does not create a partial override');
+
+# Adding a fresh local drop-in must not put the absent local main in the line
+# cache, because the normal unscoped flush would then create it as an empty
+# file and hide the complete vendor main configuration.
+my $new_local_dropin = "$local_add_dir/new-local";
+main::save_directive(main::get_config_parent(), undef,
+ { 'file' => $new_local_dropin,
+ 'name' => [ '/var/log/new-local.log' ],
+ 'members' => [ { 'name' => 'weekly' } ] });
+main::flush_file_lines();
+ok(-f $new_local_dropin,
+ 'new sections are written to their explicit local drop-in');
+ok(!-e $local_main_file,
+ 'adding a local drop-in does not create an empty local main config');
+is(read_text($vendor_main_file), $vendor_main_text,
+ 'adding a local drop-in leaves the vendor main config unchanged');
+
+# A missing local file cannot safely replace a whole same-named vendor file.
+my $missing_local_override = "$local_add_dir/one";
+{
+no warnings qw(once redefine);
+local *main::error = sub { die $_[0]; };
+eval {
+ main::save_directive(main::get_config_parent(), undef,
+ { 'file' => $missing_local_override,
+ 'name' => [ '/var/log/incomplete-override.log' ],
+ 'members' => [ ] });
+ };
+like($@, qr/Refusing to modify vendor configuration/,
+ 'new sections cannot create incomplete vendor overrides');
+}
+ok(!-e $missing_local_override,
+ 'rejecting an incomplete override leaves its local path absent');
+
+# Editing global options materializes an exact local copy before parsing.
$main::config{'scan_add_file'} = 1;
-write_text($main_file,
- "weekly\ninclude $add_dir\n/var/log/main.log {\n\trotate 4\n}\n");
+clear_config_cache();
+is(main::ensure_local_main_config(), $local_main_file,
+ 'editing the vendor main config creates a local main config');
+is(read_text($local_main_file), $vendor_main_text,
+ 'local main config starts as an exact vendor copy');
+is(read_text($vendor_main_file), $vendor_main_text,
+ 'copying the main config does not alter the vendor file');
+is(main::get_main_config_file(), $local_main_file,
+ 'local main config takes precedence after it is created');
+
+# A new section may be appended after the same-named vendor file has been
+# copied in full, which is the preflight performed by save_log.cgi.
+is(main::ensure_local_config_override($vendor_target),
+ $missing_local_override,
+ 'new-section preflight creates the complete local override');
+my $prepared_parent = main::get_config_parent();
+main::save_directive($prepared_parent, undef,
+ { 'file' => $missing_local_override,
+ 'name' => [ '/var/log/appended-local.log' ],
+ 'members' => [ { 'name' => 'weekly' } ] });
+main::flush_file_lines($missing_local_override);
+like(read_text($missing_local_override), qr{/var/log/vendor-one\.log},
+ 'prepared override retains the original vendor section');
+like(read_text($missing_local_override), qr{/var/log/appended-local\.log},
+ 'prepared override receives the new local section');
+is(read_text($vendor_target), $vendor_target_text,
+ 'appending locally leaves the same-named vendor file unchanged');
+
+# Editing a vendor drop-in must also be prepared before parsed objects change.
+my $vendor_dropin = "$vendor_add_dir/deep/vendor";
+my $local_dropin = "$local_add_dir/deep/vendor";
+($config, undef, $files) = main::get_config();
+my ($deep_log) = grep { $_->{'members'} &&
+ $_->{'name'}->[0] eq '/var/log/deep-vendor.log' }
+ @$config;
+{
+no warnings qw(once redefine);
+local *main::error = sub { die $_[0]; };
+eval { main::save_directive($deep_log, 'monthly', '', "\t"); };
+like($@, qr/Refusing to modify vendor configuration/,
+ 'direct writes to a vendor drop-in are rejected');
+}
+is(main::ensure_local_config_override($vendor_dropin), $local_dropin,
+ 'editing a vendor drop-in creates its matching local override');
+is(read_text($local_dropin), read_text($vendor_dropin),
+ 'local drop-in starts as an exact copy of the whole vendor file');
+is(main::get_local_override_file($vendor_dropin), $local_dropin,
+ 'vendor drop-in maps to the correct writable path');
+is(main::get_vendor_config_file($local_dropin), $vendor_dropin,
+ 'local override maps back to the shadowed vendor file');
+
+($config, undef, $files) = main::get_config();
+($deep_log) = grep { $_->{'members'} &&
+ $_->{'name'}->[0] eq '/var/log/deep-vendor.log' }
+ @$config;
+is($deep_log->{'file'}, $local_dropin,
+ 'parser switches to the local copy after an override is created');
+main::save_directive($deep_log, 'monthly', undef, "\t");
+main::flush_file_lines($local_dropin);
+unlike(read_text($local_dropin), qr/^\s*monthly\s*$/m,
+ 'prepared drop-in can be changed through its local override');
+like(read_text($vendor_dropin), qr/^\s*monthly\s*$/m,
+ 'changing the local override leaves the vendor drop-in unchanged');
+
+# An empty local file must remain both effective and backup-visible because
+# its existence is what prevents the vendor file from becoming active again.
+write_text($local_dropin, '');
+clear_config_cache();
+main::delete_if_empty($local_dropin);
+ok(-e $local_dropin,
+ 'empty local override is retained so the vendor file stays disabled');
+(undef, undef, $files) = main::get_config();
+ok(grep({ $_ eq $local_dropin } @$files),
+ 'empty local override remains in the effective file cache for backups');
+ok(!grep({ $_ eq $vendor_dropin } @$files),
+ 'empty local override continues to hide the vendor file');
+
+# Explicit includes and external discovery must not parse the same file twice.
+write_text($local_main_file,
+ "weekly\ninclude $local_add_dir\n".
+ "/var/log/main.log {\n\trotate 4\n}\n");
clear_config_cache();
($config, undef, $files) = main::get_config();
-is_deeply(log_names($config),
- [ '/var/log/one.log', '/var/log/two.log', '/var/log/main.log' ],
- 'explicitly included files are not loaded a second time');
-is(scalar(grep { main::same_file($_, "$add_dir/one") } @$files), 1,
+is(scalar(grep { $_->{'members'} &&
+ $_->{'name'}->[0] eq '/var/log/local-only.log' }
+ @$config), 1,
+ 'explicitly included files are not parsed a second time');
+is(scalar(grep { main::same_file($_, "$local_add_dir/local-only") }
+ @$files), 1,
'explicit include is represented once in the file cache');
-(undef, undef, $primary_files) = main::get_config($main_file);
-is_deeply([ main::get_add_file_configs($primary_files) ], [ ],
- 'force rotation does not repeat explicitly included files');
+
+# A local path selected by the wrapper's existence check wins even when find
+# discovers the relative name only from the regular vendor file.
+my $edge_dir = tempdir(CLEANUP => 1);
+my $edge_local_dir = "$edge_dir/etc/logrotate.d";
+my $edge_vendor_dir = "$edge_dir/usr/etc/logrotate.d";
+my $edge_target = "$edge_dir/local-target";
+make_path($edge_local_dir, $edge_vendor_dir);
+write_text("$edge_vendor_dir/linked", "vendor\n");
+write_text($edge_target, "local\n");
+symlink($edge_target, "$edge_local_dir/linked") or
+ die "symlink $edge_local_dir/linked: $!";
+{
+local $main::config{'add_file'} = $edge_local_dir;
+local $main::config{'vendor_add_file'} = $edge_vendor_dir;
+is_deeply([ main::get_add_file_configs() ], [ "$edge_local_dir/linked" ],
+ 'local existing path overrides the matching vendor file');
+
+# Discovery follows the wrapper's existence rule, but editing must not follow
+# a local symlink when it shadows a same-named vendor configuration.
+{
+no warnings qw(once redefine);
+local *main::error = sub { die $_[0]; };
+eval {
+ main::save_directive(
+ { 'members' => [ ], 'file' => "$edge_dir/parent" },
+ undef,
+ { 'file' => "$edge_local_dir/linked",
+ 'name' => [ '/var/log/symlink-write.log' ],
+ 'members' => [ ] });
+ };
+like($@, qr/Refusing to modify vendor configuration/,
+ 'local symlink overrides are rejected for editing');
+}
+is(read_text($edge_target), "local\n",
+ 'rejecting a symlink override leaves its target unchanged');
+}
+
+# A regular local path must still be rejected when it is a hard link to its
+# vendor source, because otherwise an apparently local write would alter /usr.
+my $hardlink_dir = tempdir(CLEANUP => 1);
+my $hardlink_vendor = "$hardlink_dir/vendor";
+my $hardlink_local = "$hardlink_dir/local";
+write_text($hardlink_vendor, "vendor\n");
+link($hardlink_vendor, $hardlink_local) or
+ die "link $hardlink_local: $!";
+{
+no warnings qw(once redefine);
+local *main::error = sub { die $_[0]; };
+eval { main::copy_vendor_config($hardlink_vendor, $hardlink_local); };
+ok($@, 'a hard-linked local override is rejected');
+}
+is(read_text($hardlink_vendor), "vendor\n",
+ 'rejecting a hard-linked override leaves the vendor source unchanged');
done_testing();
diff --git a/makedist.pl b/makedist.pl
index 5b6040e3a..6f8175433 100755
--- a/makedist.pl
+++ b/makedist.pl
@@ -30,7 +30,7 @@ $vers || usage();
"miniserv.pl", "miniserv-lib.pl", "os_list.txt", "perlpath.pl",
"setup.sh", "setup.pl", "setup.bat",
"setup-repos.sh", "version", "web-lib.pl", "web-lib-funcs.pl",
- "config_save.cgi", "chooser.cgi", "miniserv.pem",
+ "config_save.cgi", "chooser.cgi",
"config-aix", "update-from-repo.sh", "README.md",
"newmods.pl", "copyconfig.pl", "config-hpux", "config-freebsd",
"changepass.pl", "help.cgi", "user_chooser.cgi",
@@ -40,7 +40,7 @@ $vers || usage();
"webmin-systemd", "webmin-init", "webmin-daemon",
"config-openbsd",
"config-macos", "LICENCE",
- "session_login.cgi", "acl_security.pl",
+ "session_login.cgi", "login-lib.pl", "acl_security.pl",
"defaultacl", "rpc.cgi", "date_chooser.cgi",
"safeacl", "install-module.pl", "LICENCE.ja",
"favicon.ico", "config-netbsd", "fastrpc.cgi",
diff --git a/miniserv.pem b/miniserv.pem
deleted file mode 100644
index 16ef412af..000000000
--- a/miniserv.pem
+++ /dev/null
@@ -1,49 +0,0 @@
------BEGIN CERTIFICATE-----
-MIIDejCCAmKgAwIBAgIUI7oycX7XtLsNCJb1v2GGl1pZS28wDQYJKoZIhvcNAQEL
-BQAwNzESMBAGA1UEAwwJbG9jYWxob3N0MQswCQYDVQQGEwJVUzEUMBIGA1UEBwwL
-U2FudGEgQ2xhcmEwHhcNMjIxMDEwMjEyNzI4WhcNMzIxMDA3MjEyNzI4WjA3MRIw
-EAYDVQQDDAlsb2NhbGhvc3QxCzAJBgNVBAYTAlVTMRQwEgYDVQQHDAtTYW50YSBD
-bGFyYTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBANSUOgVKjclwwmdL
-OD3jSKHjuS9YqmfVqB+AyUfE97Lq9qvmydbSrpaEvXgmcG8Qlh6PwtIH9dSmCYl8
-obftWC4ReN4ubl5meyEc0BRZmEPxC8j6s18S8ICTEQ7ZiNxoDwAciXA2Op6sAuS4
-42HxcArHFpRXYMrgwGP4mes4j3L6ugWivvpz0zGDMNG+zWlMnlx9NJ4klSVvDueW
-bsAd+KPuzF5S4QaTJ0oASu5UCK/JmHpDtXFGDwm72fWNdfspRYblSrmxFFiZUNoQ
-t9iggMMaPlxIwajLTvrDi/Jzp0OXKdu5fRRsgPmzvgq/SWH9kDidZwpxw67BC1rm
-g/EDtmMCAwEAAaN+MHwwHQYDVR0OBBYEFCjRwPscxpufLiIXn8nPb5S8ruIMMB8G
-A1UdIwQYMBaAFCjRwPscxpufLiIXn8nPb5S8ruIMMA8GA1UdEwEB/wQFMAMBAf8w
-FAYDVR0RBA0wC4IJbG9jYWxob3N0MBMGA1UdJQQMMAoGCCsGAQUFBwMBMA0GCSqG
-SIb3DQEBCwUAA4IBAQAAMHPYjlF++zsrpVU44HqfwkQ6Y123eqGWw6HXDF9ga+oW
-aAD6iHIf06rmpFQ/GnU5QzIAR0QkhCCcnpCFIX5Quluv5aQ1pxBtLuRW8QB7jugg
-m/Bk204Ck4dj5EgJ5CGOj5yVjKanaMXa3hLp1dYMkas6VQyYBdMAJosrGWdFczvQ
-/bpfgPWF0DZhzskTdTWce3rv6VHc6biDGUHNaCH7dtTJfenUZfgtNXMNl4raBQMC
-83mEfJYhe1pqJRvzoC0dTeYeF/66Q5CfIxSpb2cMCtNl6wWqS4WJtQCOBCoKqQtH
-9qDGxQCiISyMTqiTUU9GYYWsTZ9do8ZSc5VvO6uf
------END CERTIFICATE-----
------BEGIN PRIVATE KEY-----
-MIIEvgIBADANBgkqhkiG9w0BAQEFAASCBKgwggSkAgEAAoIBAQDUlDoFSo3JcMJn
-Szg940ih47kvWKpn1agfgMlHxPey6var5snW0q6WhL14JnBvEJYej8LSB/XUpgmJ
-fKG37VguEXjeLm5eZnshHNAUWZhD8QvI+rNfEvCAkxEO2YjcaA8AHIlwNjqerALk
-uONh8XAKxxaUV2DK4MBj+JnrOI9y+roFor76c9MxgzDRvs1pTJ5cfTSeJJUlbw7n
-lm7AHfij7sxeUuEGkydKAEruVAivyZh6Q7VxRg8Ju9n1jXX7KUWG5Uq5sRRYmVDa
-ELfYoIDDGj5cSMGoy076w4vyc6dDlynbuX0UbID5s74Kv0lh/ZA4nWcKccOuwQta
-5oPxA7ZjAgMBAAECggEBAMeftmiXnVRIblafvV3onKFh/tnmUoeVjP6gauPZpJ3A
-pgnBfVMdn1O7rU0yE61IjyB98f5X+VNK5HPWtOrKmF8Si0VhpsVBSWlL7F7fz+wl
-ZOLEAkNKvsyOzpr6TtpjYYrCQZI9aojskP8GXIjyODv2v05oS33Y1vJKVwgboiHe
-d3CbRn9nbarNdJ5FHrv6qbz9xiRREdsNeYTafzPNzKXnkLrJ9T0lsOItichwXk+e
-e47fYi7cqmPc8mZ+cx3ct8z4RF/iGmdLc/nVd9k68/ola7DEtNVGGCw/1zAgAiJG
-vKbVK/rWJ0qWKXjW2Vf0Uc7M4gmhU9tmq9wYXmYUKrkCgYEA/5f+VmpdDUAu75el
-D8D7L6LvJDH4NoClpbHJ3srJ1gpGniL2mWR9xplRe7Sth9rWMziPo2vcpb0n8CKB
-799sTLyY/F4/pjlnQrLGhs6ZipdCnx0Wp6cCcNTchJV7fsvJWQi96z69m9z4aOCY
-ls5J0lgostgGmqJ0tUTLAJn4af0CgYEA1Oq6wx/2+NkaQSL3JhlBmybbaK/L7B5X
-Bn2uwxaIBGKsWaH02VNx3kv7tbsEJ9bj2Zsf47CAJaw8ojNyT754YDBjnqawoI+G
-RGP5Rjz7+IiW3EgACHQBhmxASjBTpCFcpszxjLwhL6i/0yyaosIq0459iz4dN9he
-27nNjM48398CgYA8zQVdvTOhgVEpAaPsWXXnYRUOQSzQmk3NWruw2gClgBBIcfzD
-hJo+8h3mFZbqKG6oBJ52u6PjcVncz/ik/TsgDgU+k5UEj8c2oJyFWQRBabYZb6wB
-+cKk4J4MlBqqkQO2wFOdcHFecHRPTo494ZjCBuK3mJgJlPe6X0EDRZ1IaQKBgACF
-Ei+nxFKXNRkznKbbKO3YCnEW/Mh2yn+ZjvOq+moIU6NkYdSl/4ErblHjQv9V5viB
-CHLl22o8IWnD9mN7c4/IjnW0snmx4AIKvHEPdQ4GR1gCVP2wStCpMv77XzjnW/KM
-TYqqaupS3yUE1tvO3YvmrSfJ3whj3tdqfLX7SurBAoGBAOW8Pn8/kIB0l5Hm5lKm
-lh52bhoBzptiPfnddwXROl2IGieALZU/lKUvZv79aVJuoY86+qOfSZqiUypGiIPR
-+VWa7deV7Stugf6KmnRzOp0ZdS/SCX9rppoJmdwORW58cfIhmdQV+vKlCL9ZO0HF
-QqbKXdpb8BfqgsmIwTV+7zbF
------END PRIVATE KEY-----
diff --git a/miniserv.pl b/miniserv.pl
index efefad1df..3ad64bef7 100755
--- a/miniserv.pl
+++ b/miniserv.pl
@@ -915,6 +915,13 @@ while(1) {
# Initialize SSL for this connection
if ($use_ssl) {
my $byte = '';
+ # Don't wait forever for a client that
+ # connects but never sends anything
+ my $pmask;
+ vec($pmask, fileno(SOCK), 1) = 1;
+ select($pmask, undef, undef,
+ $config{'peek_timeout'} || 60)
+ || exit;
# Look at the first byte of the socket
# buffer but don't consume it
recv(SOCK, $byte, 1, MSG_PEEK);
diff --git a/mount/linux-lib.pl b/mount/linux-lib.pl
index 26cd4524c..0a3af656b 100755
--- a/mount/linux-lib.pl
+++ b/mount/linux-lib.pl
@@ -1924,7 +1924,30 @@ elsif ($_[0] =~ /^ext\d+$/) {
($u, $g) = ("usrjquota", "grpjquota");
$jufile ||= "aquota.user";
$jgfile ||= "aquota.group";
- $options{"jqfmt"} = "vfsv0";
+ if (!$options{"jqfmt"}) {
+ # Keep the format of existing external quota files when
+ # switching them to journaled quotas.
+ my $jqfmt;
+ foreach my $qfile ($jufile, $jgfile) {
+ next if (!-s "$_[2]/$qfile");
+ if (open(my $qfh, "<", "$_[2]/$qfile")) {
+ my $header;
+ if (read($qfh, $header, 8) == 8) {
+ my (undef, $version) = unpack("V2", $header);
+ $jqfmt = $version == 0 ? "vfsv0" :
+ $version == 1 ? "vfsv1" : undef;
+ }
+ close($qfh);
+ }
+ last if ($jqfmt);
+ }
+ if (!$jqfmt) {
+ my $qver = &backquote_command("quota -V 2>&1");
+ $jqfmt = $qver =~ /\s(\d+)\.\d+/ && $1 >= 4 ?
+ "vfsv1" : "vfsv0";
+ }
+ $options{"jqfmt"} = $jqfmt;
+ }
}
else {
$jufile = "";
diff --git a/net/debian-linux-lib.pl b/net/debian-linux-lib.pl
index 693f69084..694f7f2d7 100755
--- a/net/debian-linux-lib.pl
+++ b/net/debian-linux-lib.pl
@@ -230,12 +230,12 @@ if ($cfg->{'bridge'}) {
# Set bonding parameters
if(($cfg->{'bond'} == 1) && ($gconfig{'os_version'} >= 5)) {
- push(@options, [&bonding_option('mode').' '.$cfg->{'mode'}]);
- push(@options, [&bonding_option('miimon').' '.$cfg->{'miimon'}]) if ($cfg->{'miimon'});
- push(@options, [&bonding_option('updelay').' '.$cfg->{'updelay'}]) if ($cfg->{'updelay'});
- push(@options, [&bonding_option('downdelay').' '.$cfg->{'downdelay'}]) if ($cfg->{'downdelay'});
- push(@options, [&bonding_option('primary').' '.$cfg->{'primary'}]) if ($cfg->{'primary'});
- push(@options, ['slaves '.$cfg->{'partner'}]);
+ push(@options, [&bonding_option('mode'), $cfg->{'mode'}]);
+ push(@options, [&bonding_option('miimon'), $cfg->{'miimon'}]) if ($cfg->{'miimon'});
+ push(@options, [&bonding_option('updelay'), $cfg->{'updelay'}]) if ($cfg->{'updelay'});
+ push(@options, [&bonding_option('downdelay'), $cfg->{'downdelay'}]) if ($cfg->{'downdelay'});
+ push(@options, [&bonding_option('primary'), $cfg->{'primary'}]) if ($cfg->{'primary'});
+ push(@options, ['slaves', $cfg->{'partner'}]);
}
elsif ($cfg->{'bond'} == 1) {
push(@options, ['up', '/sbin/ifenslave '.$cfg->{'name'}." ".
diff --git a/net/delete_bifcs.cgi b/net/delete_bifcs.cgi
index bd60b7d65..a8598d7f1 100755
--- a/net/delete_bifcs.cgi
+++ b/net/delete_bifcs.cgi
@@ -51,6 +51,10 @@ foreach $d (reverse(@d)) {
else {&unload_module($b->{'name'});}
}
}
+ # Remove the virtual device after deactivation
+ if (defined(&destroy_interface_device)) {
+ &destroy_interface_device($b);
+ }
}
# Delete config
diff --git a/net/linux-lib.pl b/net/linux-lib.pl
index f0727db96..4bbb78f22 100755
--- a/net/linux-lib.pl
+++ b/net/linux-lib.pl
@@ -329,9 +329,22 @@ if (&has_command("ip") && $a->{'bond'} && $a->{'up'} && !$old) {
}
}
-if (($a->{'bond'} || $a->{'vlan'} || !&has_command("ifconfig")) &&
- &has_command("ip")) {
- # For a real interface, activate or de-activate the link
+if (&has_command("ip") && $a->{'bridge'} && $a->{'up'} && !$old) {
+ # Create the bridge before assigning addresses to it.
+ my $cmd = "ip link add ".quotemeta($a->{'name'})." type bridge";
+ my $out = &backquote_logged("$cmd 2>&1");
+ &error("Failed to create bridge device : $out") if ($?);
+ if ($a->{'bridgeto'}) {
+ $cmd = "ip link set dev ".quotemeta($a->{'bridgeto'}).
+ " master ".quotemeta($a->{'name'});
+ $out = &backquote_logged("$cmd 2>&1");
+ &error("Failed to add interface to bridge : $out") if ($?);
+ }
+ }
+
+if (&has_command("ip")) {
+ # Manage link state for all interfaces when ip is used, since ip is also
+ # used for address assignment below regardless of ifconfig availability.
if ($a->{'virtual'} eq '' && $a->{'up'} && (!$old || !$old->{'up'})) {
# Bring up
my $cmd = "ip link set dev ".quotemeta($devname)." up";
@@ -597,6 +610,22 @@ else {
}
}
+# destroy_interface_device(&details)
+# Remove a virtual network device (bond, VLAN, bridge) from the kernel.
+# Should be called after deactivate_interface when deleting, not just
+# deactivating, a virtual interface.
+sub destroy_interface_device
+{
+my ($a) = @_;
+my $name = $a->{'fullname'} || $a->{'name'};
+if (&has_command("ip") && $a->{'virtual'} eq '' &&
+ &iface_type($name) =~ /(?:Bonded|VLAN|Bridge)$/) {
+ my $out = &backquote_logged(
+ "ip link delete ".quotemeta($name)." 2>&1");
+ &error("Failed to delete virtual interface : $out") if ($?);
+ }
+}
+
# use_ifup_command(&iface)
# Returns 1 if the ifup command must be used to bring up some interface.
# True on Debian 5.0+ for non-ethernet, typically bonding and VLAN tagged interfaces.
diff --git a/net/save_bifc.cgi b/net/save_bifc.cgi
index 1006669a5..b27c9c059 100755
--- a/net/save_bifc.cgi
+++ b/net/save_bifc.cgi
@@ -32,6 +32,10 @@ if ($in{'delete'} || $in{'unapply'}) {
else {
&deactivate_interface($act);
}
+ # Remove the virtual device after deactivation
+ if (defined(&destroy_interface_device)) {
+ &destroy_interface_device($b);
+ }
}
}
@@ -294,7 +298,7 @@ else {
$b->{'bond'} = 1;
$in{'partner'} =~ /^\S+( +\S+)*$/ || &error($text{'bonding_epartner'});
$b->{'partner'} = $in{'partner'};
- $in{'bondmode'} =~ /^\d*$/ || &error($text{'bonding_ebondmode'});
+ $in{'bondmode'} =~ /^[0-6]$/ || &error($text{'bonding_ebondmode'});
$b->{'mode'} = $in{'bondmode'};
$in{'primary'} =~ /^\S*$/ || &error($text{'bonding_eprimary'});
$b->{'primary'} = $in{'primary'};
diff --git a/net/t/run-tests.t b/net/t/run-tests.t
index d0c6f4ae4..8aeb2f6ac 100644
--- a/net/t/run-tests.t
+++ b/net/t/run-tests.t
@@ -964,4 +964,89 @@ is_deeply(\@commands,
"cd / ; ifconfig eth0.10 10\\.0\\.0\\.2 netmask 255\\.255\\.255\\.0 up 2>&1" ],
"Linux VLAN interface falls back to vconfig without ip");
+# Test: Bond deactivation only brings it down, does not delete device
+@commands = ( );
+{
+no warnings 'redefine';
+local *main::has_command = sub {
+ return $_[0] eq "ip" ? "/sbin/ip" : undef;
+ };
+main::deactivate_interface({
+ 'name' => 'bond0',
+ 'fullname' => 'bond0',
+ 'virtual' => '',
+ 'address' => '10.0.0.2',
+ 'netmask' => '255.255.255.0',
+ 'address6' => [ ],
+ 'netmask6' => [ ],
+ 'up' => 1
+ });
+}
+is_deeply(\@commands, [
+ "ip addr del 10\\.0\\.0\\.2\\/24 dev bond0 2>&1",
+ "ip link set dev bond0 down 2>&1"
+ ], "Linux bond deactivation removes address and brings link down");
+
+# Test: Bond deletion removes virtual device after deactivation
+@commands = ( );
+{
+no warnings 'redefine';
+no warnings 'once';
+local $main::gconfig{'os_type'} = 'debian-linux';
+local $main::gconfig{'os_version'} = 12;
+local *main::has_command = sub {
+ return $_[0] eq "ip" ? "/sbin/ip" :
+ $_[0] eq "ifup" ? "/sbin/ifup" : undef;
+ };
+main::deactivate_interface({
+ 'name' => 'bond0',
+ 'fullname' => 'bond0',
+ 'virtual' => '',
+ 'address' => '10.0.0.2',
+ 'netmask' => '255.255.255.0',
+ 'address6' => [ ],
+ 'netmask6' => [ ],
+ 'up' => 1
+ });
+# Simulate delete path: destroy_interface_device after deactivation
+my $b = { 'name' => 'bond0', 'fullname' => 'bond0', 'virtual' => '' };
+main::destroy_interface_device($b);
+}
+is_deeply(\@commands, [
+ "ip addr del 10\\.0\\.0\\.2\\/24 dev bond0 2>&1",
+ "ip link set dev bond0 down 2>&1",
+ "ip link delete bond0 2>&1"
+ ], "Linux bond deletion removes device after deactivation");
+
+# Test: VLAN deletion removes virtual device after deactivation
+@commands = ( );
+{
+no warnings 'redefine';
+no warnings 'once';
+local $main::gconfig{'os_type'} = 'debian-linux';
+local $main::gconfig{'os_version'} = 12;
+local *main::has_command = sub {
+ return $_[0] eq "ip" ? "/sbin/ip" :
+ $_[0] eq "ifup" ? "/sbin/ifup" : undef;
+ };
+main::deactivate_interface({
+ 'name' => 'eth0.10',
+ 'fullname' => 'eth0.10',
+ 'virtual' => '',
+ 'address' => '10.0.10.2',
+ 'netmask' => '255.255.255.0',
+ 'address6' => [ ],
+ 'netmask6' => [ ],
+ 'up' => 1
+ });
+# Simulate delete path: destroy_interface_device after deactivation
+my $b = { 'name' => 'eth0.10', 'fullname' => 'eth0.10', 'virtual' => '' };
+main::destroy_interface_device($b);
+}
+is_deeply(\@commands, [
+ "ip addr del 10\\.0\\.10\\.2\\/24 dev eth0\\.10 2>&1",
+ "ip link set dev eth0\\.10 down 2>&1",
+ "ip link delete eth0\\.10 2>&1"
+ ], "Linux VLAN deletion removes device after deactivation");
+
done_testing();
diff --git a/package-updates/CHANGELOG b/package-updates/CHANGELOG
index c6dd08cd9..806fb24bd 100644
--- a/package-updates/CHANGELOG
+++ b/package-updates/CHANGELOG
@@ -1,3 +1,5 @@
+---- Changes since 2.641 ----
+Added a Held updates view with controls to hold, unhold or explicitly update APT-held packages.
---- Changes since 1.490 ----
First version of this module.
---- Changes since 1.500 ----
diff --git a/package-updates/index.cgi b/package-updates/index.cgi
index 8df9e0eb5..e0f820d28 100755
--- a/package-updates/index.cgi
+++ b/package-updates/index.cgi
@@ -9,6 +9,7 @@ if ($in{'clear'}) {
$in{'search'} = '';
}
$has_repos = defined(&software::list_package_repos);
+$has_holds = &supports_package_holds();
# Start of mode tabs
print &ui_tabs_start([ [ 'pkgs', $text{'index_tabpkgs'} ],
@@ -23,7 +24,10 @@ $in{'mode'} ||= 'updates';
# Show mode selector (all, updates only, updates and new)
@grid = ( );
-foreach $m ('current', 'updates', 'security', 'new') {
+@modes = ('current', 'updates');
+push(@modes, 'held') if ($has_holds);
+push(@modes, 'security', 'new');
+foreach $m (@modes) {
$mmsg = $text{'index_mode_'.$m};
if ($in{'mode'} eq $m) {
push(@mlinks, "$mmsg");
@@ -68,15 +72,21 @@ foreach $p (sort { $a->{'name'} cmp $b->{'name'} } (@current, @avail)) {
$c = $current{$p->{'name'}."/".$p->{'system'}};
$a = $avail{$p->{'name'}."/".$p->{'system'}};
- if ($a && $c && (&compare_versions($a, $c) > 0 || $upmode)) {
+ if ($a && $c && (&compare_versions($a, $c) > 0 || $upmode ||
+ $in{'mode'} eq 'held')) {
# An update is available
- $msg = "".
- &text('index_new', $a->{'version'})."";
- $need = 1;
+ $msg = $a->{'held'} ?
+ "".
+ &text('index_held', $c->{'version'}, $a->{'version'}).
+ "" :
+ "".
+ &text('index_new', $a->{'version'})."";
+ $need = $a->{'held'} ? 0 : 1;
next if ($in{'mode'} eq 'security' && !$a->{'security'});
next if ($in{'mode'} ne 'updates' &&
$in{'mode'} ne 'current' &&
- $in{'mode'} ne 'security');
+ $in{'mode'} ne 'security' &&
+ $in{'mode'} ne 'held');
}
elsif ($a && !$c) {
# Could be installed, but isn't currently
@@ -143,18 +153,20 @@ if ($in{'mode'} eq 'new' && !$in{'search'}) {
}
else {
# Show the packages, if any
+ $update_label = $in{'mode'} eq 'new' ? $text{'index_install'} :
+ $in{'mode'} eq 'held' ? $text{'index_updateheld'} :
+ $text{'index_update'};
if (@rows) {
print &text('index_count', scalar(@rows)),"
\n";
print &ui_form_start("update.cgi", "post");
- print &ui_submit($in{'mode'} eq 'new' ? $text{'index_install'}
- : $text{'index_update'}, "ok_top" );
+ print &ui_submit($update_label, "ok_top" );
print &ui_submit($text{'index_refresh'}, "refresh_top"), "
";
}
+ @buttons = ( [ "ok", $update_label ] );
+ push(@buttons, [ "refresh", $text{'index_refresh'} ]);
print &ui_form_columns_table(
"",
- [ [ "ok", $in{'mode'} eq 'new' ? $text{'index_install'}
- : $text{'index_update'} ],
- [ "refresh", $text{'index_refresh'} ] ],
+ \@buttons,
1,
undef,
[ [ "mode", $in{'mode'} ],
@@ -296,4 +308,3 @@ if ($has_repos) {
print &ui_tabs_end(1);
&ui_print_footer("/", $text{'index'});
-
diff --git a/package-updates/lang/en b/package-updates/lang/en
index df86114cf..c865d450a 100644
--- a/package-updates/lang/en
+++ b/package-updates/lang/en
@@ -6,8 +6,10 @@ index_source=Source
index_bad2=Update to version $1 not yet available : $1
index_bad=Update to version $1 advised : $2
index_new=New version $1
+index_held=Held at version $1; version $2 is available
index_ok=Running latest $1
index_update=Update Selected Packages
+index_updateheld=Update Selected Held Packages
index_install=Install Selected Packages
index_return=package list
index_header=Scheduled checking options
@@ -39,6 +41,7 @@ index_webmintheme=Webmin theme $1
index_mode=States to display:
index_mode_current=Installed
index_mode_updates=Only updates
+index_mode_held=Held updates
index_mode_new=Only new
index_mode_security=Only security updates
index_allsel=Packages to show:
@@ -46,6 +49,7 @@ index_all_0=Only Virtualmin related
index_all_1=All packages
index_none_all=No packages managed by an update system were found on your system!
index_none_updates=No packages available to be updated were found.
+index_none_held=No held packages with available updates were found.
index_none_both=No new packages or packages available to be updated were found.
index_none_new=No new packages for installation were found.
index_none_security=No packages available for security updates were found.
@@ -100,6 +104,10 @@ update_rusure=Are you sure you wish to install the $1 packages listed below? Thi
update_oldver=Current version
update_newver=New version
update_confirm=Install Now
+update_confirmheld=Update Held Packages
+update_heldnote=These packages are held. This action explicitly updates them once, and leaves them held for future updates.
+update_enotheld=Package $1 is not currently held by APT
+update_enoheldops=No update operation was found for the selected held packages. Refresh the package list and try again.
update_none=None
update_ops=Building complete list of packages ..
update_rebootdesc=One of the installed packages requires a reboot to be fully applied.
@@ -114,6 +122,8 @@ log_schedup=Background installed $1 updated packages
log_sched=Enabled scheduled updates
log_unsched=Disabled scheduled updates
log_refresh=Refreshed available packages
+log_hold=Held updates for $1 packages
+log_unhold=Unheld updates for $1 packages
log_enable_repos=Enabled $1 package repositories
log_disable_repos=Disabled $1 package repositories
log_delete_repos=Deleted $1 package repositories
@@ -140,6 +150,10 @@ view_source=Installation source
view_changelog=Changelog for available version
view_software=Manage Package
view_update=Update Package
+view_updateheld=Update Held Package
+view_hold=Hold Package
+view_unhold=Unhold Package
+view_held=Held at version $1
view_install=Install Package
system_yum=YUM
@@ -159,4 +173,12 @@ repos_title=Delete Repositories
repos_rusure=Are you sure you want to delete the $1 selected package repositories? Packages installed from them will still be available, but may not be updatable.
repos_ok=Delete Now
+hold_enotsupported=The active package update system does not support package holds
+hold_enone=No packages were selected
+hold_enotinstalled=Package $1 is not installed
+hold_enotheld=Package $1 is not currently held
+hold_esystem=Package $1 is not managed by the active package update system
+hold_efailed=Failed to hold packages: $1
+unhold_efailed=Failed to unhold packages: $1
+
__norefs=1
diff --git a/package-updates/log_parser.pl b/package-updates/log_parser.pl
index fed1dbbd4..c5f7618ff 100644
--- a/package-updates/log_parser.pl
+++ b/package-updates/log_parser.pl
@@ -21,6 +21,9 @@ elsif ($action eq 'update') {
elsif ($action eq 'schedup') {
return &text('log_schedup', $object);
}
+elsif ($action eq 'hold' || $action eq 'unhold') {
+ return &text('log_'.$action, $object);
+ }
elsif ($action eq 'sched') {
return $text{$object ? 'log_sched' : 'log_unsched'};
}
diff --git a/package-updates/package-updates-lib.pl b/package-updates/package-updates-lib.pl
index 54eed7eb2..9612d7397 100644
--- a/package-updates/package-updates-lib.pl
+++ b/package-updates/package-updates-lib.pl
@@ -21,6 +21,7 @@ eval "use WebminCore;";
$available_cache_file = &cache_file_path("available.cache");
$current_cache_file = &cache_file_path("current.cache");
$updates_cache_file = &cache_file_path("updates.cache");
+$held_updates_cache_file = &cache_file_path("held-updates.cache");
$cron_cmd = "$module_config_directory/update.pl";
$yum_cache_file = &cache_file_path("yumcache");
@@ -308,30 +309,74 @@ sub supports_updates_available
return defined(&software::update_system_updates);
}
-# updates_available(no-cache)
+# supports_package_holds()
+# Returns true if the current update system can list and change package holds.
+sub supports_package_holds
+{
+return defined(&software::list_update_system_holds) &&
+ defined(&software::update_system_hold);
+}
+
+# list_package_holds()
+# Returns the package names currently held by the update system.
+sub list_package_holds
+{
+return ( ) if (!&supports_package_holds());
+return &software::list_update_system_holds();
+}
+
+# package_is_held(package, [holds])
+# Returns true if a package is in a supplied or freshly-read list of holds.
+sub package_is_held
+{
+my ($name, $holds) = @_;
+my @holds = $holds ? @$holds : &list_package_holds();
+return 1 if (grep { $_ eq $name } @holds);
+if ($software::update_system eq 'apt' &&
+ defined(&software::strip_apt_package_arch)) {
+ my $base = &software::strip_apt_package_arch($name);
+ return 1 if (grep {
+ &software::strip_apt_package_arch($_) eq $base
+ } @holds);
+ }
+return 0;
+}
+
+# update_package_holds(&packages, hold)
+# Holds or unholds packages. Returns undef on success, or an error message.
+sub update_package_holds
+{
+my ($packages, $hold) = @_;
+return $text{'hold_enotsupported'} if (!&supports_package_holds());
+return &software::update_system_hold($packages, $hold);
+}
+
+# updates_available(no-cache, [include-held])
# Returns an array of hash refs of package updates available, according to
# the update system, with caching.
sub updates_available
{
-my ($nocache) = @_;
-if (!scalar(@updates_available_cache)) {
- if ($nocache || &cache_expired($updates_cache_file)) {
+my ($nocache, $include_held) = @_;
+my $cache_file = $include_held ? $held_updates_cache_file :
+ $updates_cache_file;
+my $cache = $include_held ? \@held_updates_available_cache :
+ \@updates_available_cache;
+if (!scalar(@$cache)) {
+ if ($nocache || &cache_expired($cache_file)) {
# Get from original source
- @updates_available_cache = &software::update_system_updates();
- foreach my $a (@updates_available_cache) {
+ @$cache = &software::update_system_updates($include_held);
+ foreach my $a (@$cache) {
$a->{'update'} = $a->{'name'};
$a->{'system'} = $software::update_system;
}
- &write_cache_file($updates_cache_file,
- \@updates_available_cache);
+ &write_cache_file($cache_file, $cache);
}
else {
# Use on-disk cache
- @updates_available_cache =
- &read_cache_file($updates_cache_file);
+ @$cache = &read_cache_file($cache_file);
}
}
-return @updates_available_cache;
+return @$cache;
}
# package_install(package-name, [system], [new-install], [flags])
@@ -343,12 +388,14 @@ my ($name, $system, $install, $flags) = @_;
$system ||= $software::update_system;
my @rv;
my $pkg;
+my $include_held = $system eq 'apt' && defined($flags) &&
+ $flags eq '--allow-change-held-packages';
# First get from list of updates
($pkg) = grep { $_->{'update'} eq $name &&
($_->{'system'} eq $system || !$system) }
sort { &compare_versions($b, $a) }
- &list_possible_updates(0);
+ &list_possible_updates(0, 0, $include_held);
if (!$pkg) {
# Then try list of all available packages
($pkg) = grep { $_->{'update'} eq $name &&
@@ -458,14 +505,14 @@ if (defined(&software::update_system_operations)) {
return ( );
}
-# list_possible_updates([nocache], [nocache-no-data])
+# list_possible_updates([nocache], [nocache-no-data], [include-held])
# Returns a list of updates that are available. Each element in the array
# is a hash ref containing a name, version, description and severity flag.
# Intended for calling from themes. Nocache 0=cache everything, 1=flush all
# caches, 2=flush only current. Nocache-no-data prohibits collecting data
sub list_possible_updates
{
-my ($nocache, $nocache_no_data) = @_;
+my ($nocache, $nocache_no_data, $include_held) = @_;
my @rv;
return @rv if ($nocache_no_data);
my @current = &list_current($nocache);
@@ -476,9 +523,10 @@ if (&supports_updates_available()) {
foreach my $c (@current) {
$currentmap{$c->{'name'},$c->{'system'}} ||= $c;
}
- foreach my $a (&updates_available($nocache == 1)) {
+ foreach my $a (&updates_available($nocache == 1, $include_held)) {
my $c = $currentmap{$a->{'name'},$a->{'system'}};
next if (!$c);
+ next if ($a->{'held'} && !$include_held);
next if ($a->{'version'} eq $c->{'version'} &&
$a->{'epoch'} eq $c->{'epoch'});
push(@rv, { 'name' => $a->{'name'},
@@ -489,6 +537,7 @@ if (&supports_updates_available()) {
'epoch' => $a->{'epoch'},
'oldepoch' => $c->{'epoch'},
'security' => $a->{'security'},
+ 'held' => $a->{'held'},
'source' => $a->{'source'},
'desc' => $c->{'desc'} || $a->{'desc'} });
}
@@ -700,10 +749,13 @@ sub flush_package_caches
{
unlink($current_cache_file);
unlink($updates_cache_file);
+unlink($held_updates_cache_file);
unlink($available_cache_file);
unlink($available_cache_file.'0');
unlink($available_cache_file.'1');
@packages_available_cache = ( );
+@updates_available_cache = ( );
+@held_updates_available_cache = ( );
%read_cache_file_cache = ( );
}
@@ -713,6 +765,8 @@ unlink($available_cache_file.'1');
sub list_for_mode
{
my ($mode, $nocache) = @_;
+return grep { $_->{'held'} }
+ &list_possible_updates($nocache, 0, 1) if ($mode eq 'held');
return $mode eq 'updates' || $mode eq 'security' ?
&list_possible_updates($nocache) : &list_available($nocache);
}
diff --git a/package-updates/save_view.cgi b/package-updates/save_view.cgi
index 2fd5f2866..fbff27020 100755
--- a/package-updates/save_view.cgi
+++ b/package-updates/save_view.cgi
@@ -8,8 +8,14 @@ if ($in{'software'}) {
&redirect("../software/edit_pack.cgi?package=".&urlize($in{'name'}).
"&version=".&urlize($in{'version'}));
}
-else {
+elsif ($in{'hold'} || $in{'unhold'}) {
+ $action = $in{'hold'} ? "hold" : "unhold";
&redirect("update.cgi?u=".&urlize($in{'name'}."/".$in{'system'}).
- "&all=$in{'all'}&mode=$in{'mode'}");
+ "&$action=1&mode=".&urlize($in{'mode'}));
+ }
+else {
+ $mode = $in{'held'} ? "held" : $in{'mode'};
+ &redirect("update.cgi?u=".&urlize($in{'name'}."/".$in{'system'}).
+ "&all=$in{'all'}&mode=".&urlize($mode));
}
diff --git a/package-updates/update.cgi b/package-updates/update.cgi
index af66b8d30..4a2b88602 100755
--- a/package-updates/update.cgi
+++ b/package-updates/update.cgi
@@ -19,7 +19,38 @@ else {
$redir =~ /\?/ ? "$redir&tab=pkgs" : "$redir?tab=pkgs";
}
-if ($in{'refresh'} || $in{'refresh_top'}) {
+$hold_action = $in{'hold'} ? 1 : $in{'unhold'} ? 0 : undef;
+if (defined($hold_action)) {
+ # Hold or unhold selected packages
+ &supports_package_holds() || &error($text{'hold_enotsupported'});
+ @holdpkgs = split(/\0/, $in{'u'});
+ @holdpkgs || &error($text{'hold_enone'});
+ @current = &list_current(1);
+ %current = map { $_->{'name'}."/".$_->{'system'}, 1 } @current;
+ @held = &list_package_holds();
+ @holdnames = ( );
+ foreach $ps (@holdpkgs) {
+ ($p, $s) = split(/\//, $ps, 2);
+ $current{$p."/".$s} || &error(&text('hold_enotinstalled', $p));
+ $s eq $software::update_system ||
+ &error(&text('hold_esystem', $p));
+ if (!$hold_action && !&package_is_held($p, \@held)) {
+ &error(&text('hold_enotheld', $p));
+ }
+ push(@holdnames, $p);
+ }
+ @holdnames = &unique(@holdnames);
+ $err = &update_package_holds(\@holdnames, $hold_action);
+ &error(&text($hold_action ? 'hold_efailed' : 'unhold_efailed', $err))
+ if ($err);
+ &flush_package_caches();
+ $logaction = $hold_action ? 'hold' : 'unhold';
+ &webmin_log($logaction, "packages", scalar(@holdnames),
+ { 'packages' => \@holdnames });
+ &redirect("index.cgi?mode=".&urlize($in{'mode'}).
+ "&search=".&urlize($in{'search'}));
+ }
+elsif ($in{'refresh'} || $in{'refresh_top'}) {
&ui_print_unbuffered_header(undef, $text{'refresh_title'}, "");
# Clear all caches
@@ -40,6 +71,21 @@ else {
# Upgrade some packages
my @pkgs = split(/\0/, $in{'u'});
@pkgs || &error($text{'update_enone'});
+ $allow_held = 0;
+ if ($in{'mode'} eq 'held') {
+ # The held-updates page is the only UI that can explicitly
+ # override an APT hold for a single update transaction.
+ &supports_package_holds() || &error($text{'hold_enotsupported'});
+ @held = &list_package_holds();
+ foreach $ps (@pkgs) {
+ ($p, $s) = split(/\//, $ps, 2);
+ $s eq 'apt' && &package_is_held($p, \@held) ||
+ &error(&text('update_enotheld', $p));
+ }
+ $allow_held = 1;
+ }
+ $install_flags = $allow_held ? '--allow-change-held-packages' :
+ $in{'flags'};
&ui_print_unbuffered_header(undef,
$in{'mode'} eq 'new' ? $text{'update_title2'} : $text{'update_title'}, "");
@@ -57,6 +103,7 @@ else {
push(@pkgnames, $p);
}
@ops = &list_package_operations(join(" ", @pkgnames), $s);
+ &error($text{'update_enoheldops'}) if (!@ops && $allow_held);
}
if (@ops) {
@@ -74,9 +121,14 @@ else {
foreach $ps (@pkgs) {
$confform .= &ui_hidden("u", $ps);
}
+ $confform .= &ui_alert_box($text{'update_heldnote'},
+ 'warn', undef, undef, '')
+ if ($allow_held && !$bottom);
$confform .= &text('update_rusure', scalar(@ops)),"
\n"
if (!$bottom);
- $confform .= &ui_form_end([ [ "confirm", $text{'update_confirm'} ] ]);
+ $confform .= &ui_form_end([ [ "confirm",
+ $allow_held ? $text{'update_confirmheld'} :
+ $text{'update_confirm'} ] ]);
};
print &$getconfform();
@@ -127,7 +179,7 @@ else {
"
\n";
print "
\n";
@got = &package_install_multiple(
- \@pkgnames, $pkgsystem, $in{'mode'} eq 'new', $in{'flags'});
+ \@pkgnames, $pkgsystem, $in{'mode'} eq 'new', $install_flags);
print "
\n";
}
else {
@@ -138,7 +190,7 @@ else {
print &text($msg, "@{[&html_escape($p)]}"),"
\n";
print "\n";
@pgot = &package_install(
- $p, $s, $in{'mode'} eq 'new', $in{'flags'});
+ $p, $s, $in{'mode'} eq 'new', $install_flags);
foreach $g (@pgot) {
$donedep{$g}++;
}
diff --git a/package-updates/view.cgi b/package-updates/view.cgi
index 52c00309d..a80702760 100755
--- a/package-updates/view.cgi
+++ b/package-updates/view.cgi
@@ -13,12 +13,17 @@ require './package-updates-lib.pl';
($c) = grep { $_->{'name'} eq $in{'name'} &&
$_->{'system'} eq $in{'system'} } @current;
$p = $a || $c;
+$has_holds = &supports_package_holds();
+$held = $has_holds && $c &&
+ $c->{'system'} eq $software::update_system &&
+ &package_is_held($p->{'name'});
print &ui_form_start("save_view.cgi");
print &ui_hidden("name", $p->{'name'});
print &ui_hidden("system", $p->{'system'});
print &ui_hidden("version", $p->{'version'});
print &ui_hidden("mode", $in{'mode'});
+print &ui_hidden("held", $held);
print &ui_table_start($text{'view_header'}, undef, 2);
# Package name and type
@@ -29,6 +34,11 @@ print &ui_table_row($text{'view_desc'}, $p->{'desc'});
# Current state
print &ui_table_row($text{'view_state'},
+ $held && $a && $c && &compare_versions($a, $c) > 0 ?
+ "".
+ &text('index_held', $c->{'version'}, $a->{'version'})."" :
+ $held && $c ? "".
+ &text('view_held', $c->{'version'})."" :
$a && !$c ? "$text{'index_caninstall'}" :
!$a && $c ? "".
&text('index_noupdate', $c->{'version'})."" :
@@ -69,11 +79,16 @@ if ($c && &foreign_available("software") && $c->{'software'}) {
push(@buts, [ "software", $text{'view_software'} ]);
}
if ($a && $c && &compare_versions($a, $c) > 0) {
- push(@buts, [ "update", $text{'view_update'} ]);
+ push(@buts, [ "update", $held ? $text{'view_updateheld'} :
+ $text{'view_update'} ]);
}
elsif ($a && !$c) {
push(@buts, [ "update", $text{'view_install'} ]);
}
+if ($c && $has_holds && $c->{'system'} eq $software::update_system) {
+ push(@buts, [ $held ? "unhold" : "hold",
+ $held ? $text{'view_unhold'} : $text{'view_hold'} ]);
+ }
print &ui_form_end(\@buts);
&ui_print_footer("index.cgi?mode=$in{'mode'}&search=".
diff --git a/pam_login.cgi b/pam_login.cgi
index e0d139021..4b3b40814 100755
--- a/pam_login.cgi
+++ b/pam_login.cgi
@@ -3,6 +3,7 @@
BEGIN { push(@INC, "."); };
use WebminCore;
+require './login-lib.pl';
$pragma_no_cache = 1;
#$ENV{'MINISERV_INTERNAL'} || die "Can only be called by miniserv.pl";
@@ -73,17 +74,7 @@ print "$text{'pam_prefix'}\n";
print &ui_form_start("@{[&get_webprefix()]}/pam_login.cgi", "post");
print &ui_hidden("cid", $in{'cid'});
-my $not_secure;
-if ($ENV{'HTTPS'} ne 'ON' && $miniserv{'ssl'}) {
- my $link = ui_tag('a', "⚠ $text{'login_notsecure'}",
- { 'href' => "javascript:void(0);",
- 'class' => 'inherit-color',
- 'onclick' => "window.location.href = ".
- "window.location.href.replace(/^http:/, 'https:'); return false;",
- });
- $not_secure = ui_tag('span', $link,
- { class => 'not-secure', title => $text{'login_notsecure_desc'} });
- }
+my $not_secure = &get_login_http_warning(\%miniserv);
print &ui_table_start($text{'pam_header'} . $not_secure,
"width=40% class='loginform'", 2);
@@ -153,4 +144,3 @@ EOF
}
&ui_print_footer();
-
diff --git a/quota/btrfs_action.cgi b/quota/btrfs_action.cgi
new file mode 100755
index 000000000..099e8431c
--- /dev/null
+++ b/quota/btrfs_action.cgi
@@ -0,0 +1,61 @@
+#!/usr/local/bin/perl
+# Enable, disable or rescan Btrfs quotas
+
+require './quota-lib.pl';
+&ReadParse();
+$dir = $in{'dir'};
+
+# Require quota activation access and a valid mounted Btrfs filesystem before
+# running any command that can change filesystem quota state.
+&can_edit_btrfs_filesys($dir) && $access{'enable'} && !$access{'ro'} ||
+ &error($text{'btrfs_eenable'});
+defined(&btrfs_quota_status) && &is_btrfs_fs($dir) ||
+ &error($text{'btrfs_enotbtrfs'});
+
+# Accept only the three operations implemented by this handler.
+$in{'action'} =~ /^(enable|disable|rescan)$/ ||
+ &error($text{'btrfs_eaction'});
+
+# Disabling Btrfs quotas removes every qgroup and limit, so require an explicit
+# confirmation before performing this destructive operation.
+if ($in{'action'} eq "disable" && !$in{'confirm'}) {
+ # Mark the filesystem and qgroup terms as literal technical values.
+ my $dir_label = &ui_tag("tt", &html_escape($dir));
+ my $qgroup_label = &ui_tag("tt", "qgroup");
+ chomp($dir_label);
+ chomp($qgroup_label);
+
+ # Display the destructive warning inside the confirmation form.
+ &ui_print_header(undef, $text{'btrfs_disable'}, "", "btrfs");
+ print &ui_confirmation_form(
+ "btrfs_action.cgi",
+ &text('btrfs_disable_confirm', $dir_label),
+ [ [ "dir", $dir ], [ "action", "disable" ] ],
+ [ [ "confirm", $text{'btrfs_disable'} ] ],
+ &ui_alert_box(&text('btrfs_disable_warning', $qgroup_label), "warn",
+ undef, undef, ""));
+ &ui_print_footer("", $text{'index_return'});
+ exit;
+ }
+
+&error_setup($text{'btrfs_efailed'});
+# Enable quotas using the accounting mode selected in the module configuration.
+if ($in{'action'} eq "enable") {
+ $err = &enable_btrfs_quotas($dir,
+ $config{'btrfs_mode'} eq "simple" ? 1 : 0);
+ }
+# Disable quotas after the confirmation branch above has been completed.
+elsif ($in{'action'} eq "disable") {
+ $err = &disable_btrfs_quotas($dir);
+ }
+# The remaining valid action starts a full-accounting quota rescan.
+else {
+ $err = &rescan_btrfs_quotas($dir, 0);
+ }
+
+# Report command failures, record successful changes, and return to the most
+# relevant page for the completed action.
+&error($err) if ($err);
+&webmin_log($in{'action'}, "btrfs", $dir, \%in);
+&redirect($in{'action'} eq "rescan" ?
+ "list_btrfs.cgi?dir=".&urlize($dir) : "");
diff --git a/quota/config-ALL-linux b/quota/config-ALL-linux
index 370c3c8c2..c6658128a 100644
--- a/quota/config-ALL-linux
+++ b/quota/config-ALL-linux
@@ -23,3 +23,4 @@ show_grace=1
email_msg=Disk usage for user ${USER} on filesystem ${FS} has reached ${PERCENT}% of the allowed quota. ${USED} of disk space is being used, out of a maximum of ${QUOTA}.
pc_show=1
hide_uids=0
+btrfs_mode=full
diff --git a/quota/config.info b/quota/config.info
index 0f5dfcae4..df6bcdd03 100644
--- a/quota/config.info
+++ b/quota/config.info
@@ -5,6 +5,7 @@ pc_show=Usage percentages to show,1,2-Hard and soft,1-Hard only,0-Soft only
sort_mode=Sort users and groups by,1,0-Blocks used,2-Name,1-Order from repquota,3-Hard block quota,4-Soft block quota,5-Percent of hard quota used,6-Percent of soft quota used
block_mode=Show quotas in,1,1-Kilobytes (where possible),0-Blocks
hide_uids=Show deleted users?,1,0-Yes,1-No
+btrfs_mode=Btrfs accounting mode when enabling quotas,4,full-Full accounting, recommended for shared space and snapshots,simple-Simple accounting, lower overhead with original ownership tracking
line1.1=Quota email messages,11
email_msg=Email message for users over quota,9,80,5,\t
email_subject=Subject for email message to users,3,Default
diff --git a/quota/config_info.pl b/quota/config_info.pl
new file mode 100755
index 000000000..b9abbf0d0
--- /dev/null
+++ b/quota/config_info.pl
@@ -0,0 +1,18 @@
+# Hide Btrfs-specific configuration when it cannot be used.
+require './quota-lib.pl';
+
+# config_pre_load(info, [order])
+# Hide Btrfs-specific settings unless both a mounted Btrfs filesystem and the
+# command-line tool needed to manage it are available.
+sub config_pre_load
+{
+my ($info, $order) = @_;
+my @btrfs = &list_btrfs_filesystems();
+return if (@btrfs && &has_command("btrfs"));
+
+# Remove the field from both the configuration metadata and display order.
+delete($info->{'btrfs_mode'});
+@$order = grep { $_ ne "btrfs_mode" } @$order if ($order);
+}
+
+1;
diff --git a/quota/edit_btrfs.cgi b/quota/edit_btrfs.cgi
new file mode 100755
index 000000000..972868c76
--- /dev/null
+++ b/quota/edit_btrfs.cgi
@@ -0,0 +1,54 @@
+#!/usr/local/bin/perl
+# Edit the limits for a Btrfs qgroup
+
+require './quota-lib.pl';
+&ReadParse();
+$dir = $in{'dir'};
+
+# Limit editing requires write access to an allowed mounted Btrfs filesystem
+# and a syntactically valid qgroup ID.
+$access{'ro'} && &error($text{'btrfs_eedit'});
+&can_edit_btrfs_filesys($dir) || &error($text{'btrfs_eallow'});
+defined(&btrfs_quota_status) && &is_btrfs_fs($dir) ||
+ &error($text{'btrfs_enotbtrfs'});
+&valid_btrfs_qgroup_id($in{'qgroup'}) || &error($text{'btrfs_eqgroup'});
+$in{'qgroup'} eq "0/5" && &error($text{'btrfs_etoplevel'});
+
+# Load the current qgroups and ensure the requested ID still exists.
+$qgroups = &list_btrfs_qgroups($dir, 0, \$listerr);
+&error($listerr) if (!$qgroups);
+($qgroup) = grep { $_->{'id'} eq $in{'qgroup'} } @$qgroups;
+$qgroup || &error($text{'btrfs_eqgroup'});
+
+# Start a form bound to the selected filesystem and qgroup.
+&ui_print_header(undef, $text{'btrfs_edit_title'}, "", "btrfs");
+print "$text{'btrfs_edit_info'}
\n";
+print &ui_form_start("save_btrfs.cgi", "post");
+print &ui_hidden("dir", $dir);
+print &ui_hidden("qgroup", $qgroup->{'id'});
+print &ui_table_start(&text('btrfs_edit_header',
+ &html_escape($qgroup->{'id'}), &html_escape($dir)), "width=100%", 2);
+
+# Show the current path and accounted usage as read-only values.
+print &ui_table_row($text{'btrfs_path'},
+ $qgroup->{'path'} ne "" ? &html_escape($qgroup->{'path'}) : "-");
+print &ui_table_row($text{'btrfs_referenced'},
+ &nice_size($qgroup->{'referenced'}));
+print &ui_table_row($text{'btrfs_exclusive'},
+ &nice_size($qgroup->{'exclusive'}));
+print &ui_table_hr();
+
+# Allow referenced and exclusive limits to be changed independently.
+print &ui_table_row($text{'btrfs_max_referenced'},
+ "a_input("max_referenced",
+ defined($qgroup->{'max_referenced'}) ?
+ $qgroup->{'max_referenced'} : 0, 1));
+print &ui_table_row($text{'btrfs_max_exclusive'},
+ "a_input("max_exclusive",
+ defined($qgroup->{'max_exclusive'}) ?
+ $qgroup->{'max_exclusive'} : 0, 1));
+print &ui_table_end();
+print &ui_form_end([ [ undef, $text{'btrfs_update'} ] ]);
+
+# Return to the qgroup list for this filesystem.
+&ui_print_footer("list_btrfs.cgi?dir=".&urlize($dir), $text{'btrfs_title'});
diff --git a/quota/help/btrfs.html b/quota/help/btrfs.html
new file mode 100644
index 000000000..f02a26ca3
--- /dev/null
+++ b/quota/help/btrfs.html
@@ -0,0 +1,57 @@
+
+
+Introduction
+Btrfs quotas control disk usage for subvolumes through quota groups, usually
+called qgroups. Unlike traditional Unix quotas, they do not limit an
+individual user or group and do not provide soft limits, grace periods, or
+file-count limits.
+
+Each Btrfs subvolume has a level-0 qgroup. The module displays the
+following usage and limit values for each qgroup :
+
+- Referenced
+
- All data reachable from the subvolume, including data shared with other
+subvolumes or snapshots.
+
- Exclusive
+
- Data used only by the subvolume, which would be freed if it were deleted.
+
- Referenced limit
+
- The maximum referenced space that the qgroup may use.
+
- Exclusive limit
+
- The maximum exclusive space that the qgroup may use.
+
+
+Accounting Modes
+When Btrfs quotas are enabled, the accounting mode configured in the module
+settings is used :
+
+- Full accounting
+
- Tracks shared space between subvolumes and snapshots. This is the
+recommended mode when accurate referenced and exclusive usage is required.
+
- Simple accounting
+
- Tracks original ownership with lower overhead, but does not fully track
+space shared between subvolumes and snapshots.
+
+In simple accounting mode, both values show space assigned to the subvolume
+that first wrote the data.
+Changing the module setting does not convert an already-enabled filesystem.
+The selected mode is used the next time quotas are enabled.
+
+
Managing Btrfs Quotas
+The main module page shows each mounted Btrfs filesystem, its accounting mode,
+consistency state, and an action to enable or disable quotas. Click a filesystem
+path to view its qgroups, usage, and limits. Click a qgroup ID
+to edit its referenced and exclusive limits. The top-level qgroup
+0/5 is shown for information only because limiting it could stop
+filesystem changes.
+
+Because quota state and qgroup IDs apply to the whole underlying Btrfs
+filesystem, delegated Webmin users must be allowed to manage all filesystems to
+access these controls. A permission scoped to one mounted subvolume is not
+sufficient.
+
+Full accounting also provides a rescan action for rebuilding qgroup
+accounting in the background. Disabling Btrfs quotas removes all
+qgroup configuration and limits on the filesystem, so the module
+always requests confirmation first.
+
+
diff --git a/quota/index.cgi b/quota/index.cgi
index 69cdb8139..b599dafe3 100755
--- a/quota/index.cgi
+++ b/quota/index.cgi
@@ -1,21 +1,31 @@
#!/usr/local/bin/perl
# index.cgi
# Display a list of all local filesystems, and allow editing of quotas
-# on those which have quotas turned on. The actual turning on of quotas must
-# be done in the mount module first.
+# on those which have quotas turned on. Traditional quota mount options are
+# configured in the mount module, while Btrfs quotas are managed here.
require './quota-lib.pl';
-&ui_print_header(undef, $text{'index_title'}, "", "intro", 1, 1, 0,
+
+# Discover allowed Btrfs mounts independently of the traditional quota tools.
+@btrfs = grep { &can_edit_btrfs_filesys($_->[0]) } &list_btrfs_filesystems();
+$err = "as_init();
+
+# Traditional filesystems are unavailable when quota-tools initialization fails.
+@list = $err ? ( ) : &list_filesystems();
+
+# Use focused Btrfs help when it is the only quota model shown on this page.
+$help = @btrfs && !@list ? "btrfs" : "intro";
+&ui_print_header(undef, $text{'index_title'}, "", $help, 1, 1, 0,
&help_search_link("quota", "man", "howto"));
-$err = "as_init();
-if ($err) {
+# Stop only when neither traditional quota tools nor Btrfs tools can provide a
+# usable filesystem list.
+if ($err && (!@btrfs || !&has_command("btrfs"))) {
print "$err
\n";
&ui_print_footer("/", $text{'index_return'});
exit;
}
-@list = &list_filesystems();
if (@list) {
print &ui_columns_start([
$text{'index_fs'},
@@ -97,13 +107,84 @@ if (@list) {
}
print &ui_columns_end();
}
-else {
+# Report no support only when neither traditional nor Btrfs filesystems exist.
+elsif (!@btrfs) {
print "$text{'index_nosupport'}
\n";
if (&foreign_available("mount")) {
print &text('index_mountmod', "../mount/"),"
\n";
}
}
+# Btrfs subvolume quotas use qgroups instead of Unix users and groups, so they
+# are shown separately from the traditional quota filesystems above.
+if (@btrfs) {
+ # Activation controls require both enable permission and write access.
+ $btrfs_canactivate = $access{'enable'} && !$access{'ro'};
+
+ # Start a table with an action column only for users who can change state.
+ print &ui_columns_start([
+ $text{'index_fs'},
+ $text{'index_type'},
+ $text{'index_mount'},
+ $text{'index_status'},
+ $btrfs_canactivate ? ( $text{'index_action'} ) : (),
+ ], 100, 0, undef, &hlink($text{'index_btrfs_title'}, "btrfs"));
+ foreach $f (@btrfs) {
+ # Query each mount independently so failures remain visible per row.
+ undef($action);
+ $status = &btrfs_quota_status($f->[0]);
+
+ # The OS library could not identify this path as manageable Btrfs.
+ if (!$status) {
+ $msg = $text{'index_btrfs_unavailable'};
+ }
+ # Surface command or parsing errors without offering a state change.
+ elsif ($status->{'error'}) {
+ $msg = &text('index_btrfs_error',
+ &html_escape($status->{'error'}));
+ }
+ # Disabled filesystems can be enabled using the configured mode.
+ elsif (!$status->{'enabled'}) {
+ $msg = $text{'index_btrfs_disabled'};
+ $action = "enable";
+ }
+ # Enabled filesystems expose their accounting and consistency state.
+ else {
+ $mode = $status->{'mode'} eq "squota" ?
+ $text{'index_btrfs_simple'} :
+ $status->{'mode'} eq "qgroup" ?
+ $text{'index_btrfs_full'} :
+ $text{'index_btrfs_unknown'};
+ $msg = &text('index_btrfs_enabled', $mode);
+ $msg .= ", $text{'index_btrfs_inconsistent'}"
+ if ($status->{'inconsistent'});
+ $action = "disable";
+ }
+
+ # Build the common filesystem, type, source and status columns.
+ local @cols = (
+ &ui_link("list_btrfs.cgi?dir=".&urlize($f->[0]),
+ &html_escape($f->[0])),
+ &foreign_call("mount", "fstype_name", $f->[2]),
+ &foreign_call("mount", "device_name", $f->[1]),
+ $msg,
+ );
+
+ # Add the state-changing link only when the ACL allows it.
+ if ($btrfs_canactivate) {
+ push(@cols, $action ?
+ &ui_link("btrfs_action.cgi?dir=".&urlize($f->[0]).
+ "&action=$action",
+ $action eq "enable" ? $text{'index_enable'} :
+ $text{'index_disable'}) : "-");
+ }
+ print &ui_columns_row(\@cols);
+ }
+
+ # Close the separately titled Btrfs filesystem table.
+ print &ui_columns_end();
+ }
+
# Buttons to edit and specific user or group
if ($useractive || $groupactive) {
print &ui_hr();
diff --git a/quota/install_check.pl b/quota/install_check.pl
index 9e5911d7d..d031ce62e 100755
--- a/quota/install_check.pl
+++ b/quota/install_check.pl
@@ -8,9 +8,15 @@ do 'quota-lib.pl';
# For mode 0, returns 1 if installed, 0 if not
sub is_installed
{
+# Check the traditional quota-tools dependency when this OS implements it.
if (defined("as_init)) {
local $err = "as_init();
- return 0 if ($err);
+ # A usable Btrfs mount and command provide an alternative when the
+ # traditional quota-tools package is not installed.
+ if ($err) {
+ local @btrfs = &list_btrfs_filesystems();
+ return 0 if (!@btrfs || !&has_command("btrfs"));
+ }
}
return $_[0] ? 2 : 1;
}
diff --git a/quota/lang/en b/quota/lang/en
index 17aa8497b..1ef3573b2 100644
--- a/quota/lang/en
+++ b/quota/lang/en
@@ -167,6 +167,56 @@ index_egroup=Edit Group Quotas:
index_egroupdesc=Enter or select a group, and click this button to view its quotas on all filesystems.
index_nosupport=No local filesystems can support quotas.
index_mountmod=You can enable quotas for a filesystem in the Disk and Network Filesystems module.
+index_btrfs_title=Btrfs Subvolume Quotas
+index_btrfs_enabled=Enabled, $1
+index_btrfs_disabled=Disabled
+index_btrfs_full=full accounting
+index_btrfs_simple=simple accounting
+index_btrfs_unknown=accounting mode unavailable
+index_btrfs_inconsistent=inconsistent
+index_btrfs_unavailable=Unavailable
+index_btrfs_error=Error: $1
+
+btrfs_title=Btrfs Subvolume Quotas
+btrfs_return=filesystem list
+btrfs_status_header=Quota status for $1
+btrfs_status=Status
+btrfs_enabled=Enabled
+btrfs_disabled=Disabled
+btrfs_mode=Accounting mode
+btrfs_full=Full accounting
+btrfs_simple=Simple accounting
+btrfs_unknown=Unavailable from this version of btrfs-progs
+btrfs_consistency=Accounting state
+btrfs_consistent=Consistent
+btrfs_inconsistent=Inconsistent - a rescan is recommended
+btrfs_qgroups=Subvolume quota groups
+btrfs_qgroup=qgroup
+btrfs_path=Subvolume path
+btrfs_referenced=Referenced usage
+btrfs_exclusive=Exclusive usage
+btrfs_max_referenced=Referenced limit
+btrfs_max_exclusive=Exclusive limit
+btrfs_disable=Disable quotas
+btrfs_disable_confirm=Disable Btrfs quotas on $1?
+btrfs_disable_warning=All $1 configuration and limits on this filesystem will be removed!
+btrfs_rescan=Rescan quotas
+btrfs_rescan_desc=Rebuild full qgroup accounting in the background.
+btrfs_edit_title=Edit Btrfs Quota
+btrfs_edit_header=Limits for qgroup $1 on $2
+btrfs_edit_info=Full accounting shows space reachable from the subvolume and space freed by deleting it. Simple accounting shows space assigned to the subvolume that first wrote the data.
+btrfs_update=Update
+btrfs_eallow=Btrfs quota management requires permission to manage all filesystems because qgroups apply to the whole underlying filesystem
+btrfs_eenable=You are not allowed to enable or disable quotas on this filesystem
+btrfs_eedit=You are not allowed to edit Btrfs quota limits
+btrfs_enotbtrfs=The selected path is not on a mounted Btrfs filesystem
+btrfs_eqgroup=The selected Btrfs qgroup does not exist
+btrfs_etoplevel=The top-level Btrfs qgroup cannot be limited because doing so can block the entire filesystem
+btrfs_eaction=Invalid Btrfs quota action
+btrfs_efailed=Failed to manage Btrfs quotas
+btrfs_esave=Failed to save the Btrfs quota
+btrfs_elimit=Quota limits must be positive numbers
+btrfs_emax=You are not allowed to grant limits above $1
lgroups_failed=Failed to list groups
lgroups_tablist=Group list
diff --git a/quota/linux-lib.pl b/quota/linux-lib.pl
index c9a3a3bc5..93757287c 100755
--- a/quota/linux-lib.pl
+++ b/quota/linux-lib.pl
@@ -82,6 +82,12 @@ the following :
=cut
sub quota_can
{
+my ($mnttab) = @_;
+
+# The quota-tools commands used by this module cannot reliably manage tmpfs
+# mounts, even when they expose usrquota or grpquota mount options.
+return 0 if ($mnttab->[2] eq "tmpfs");
+
my %exclude_mounts;
if (&has_command("findmnt")) {
%exclude_mounts = map { $_ => 1 } split( /\n/m, backquote_command('findmnt -r | grep -oP \'^(\S+)(?=.*\[\/)\'') );
@@ -289,15 +295,22 @@ if ($out =~ /\s(\d+\.\d+)/) {
# Force load of quota kernel modules
&system_logged("modprobe quota_v2 >/dev/null 2>&1");
-local $fmt = $version >= 2 ? "vfsv0" : "vfsold";
+# Quota tools 4 and later support 64-bit limits in vfsv1 files
+local $fmt = $version >= 4 ? "vfsv1" :
+ $version >= 2 ? "vfsv0" : "vfsold";
local $hidden = &hidden_ext_quota_mode($_[0]);
if ($_[1]%2 == 1) {
# turn on user quotas
local $qf = $version >= 2 ? "aquota.user" : "quota.user";
- if (!-s "$_[0]/$qf" && !($hidden & 1)) {
+ local $legacy = $version >= 4 && !($hidden & 1) &&
+ $qf ne "quota.user" &&
+ !-s "$_[0]/$qf" &&
+ -s "$_[0]/quota.user";
+ if (!-s "$_[0]/$qf" && !$legacy && !($hidden & 1)) {
# Setting up for the first time
local $ok = 0;
- if (&has_command("convertquota") && $version >= 2) {
+ if (&has_command("convertquota") && $version >= 2 &&
+ $version < 4) {
# Try creating a quota.user file and converting it
&open_tempfile(QUOTAFILE, ">>$_[0]/quota.user", 0, 1);
&close_tempfile(QUOTAFILE);
@@ -315,24 +328,32 @@ if ($_[1]%2 == 1) {
&set_ownership_permissions(undef, undef, 0600,
"$_[0]/$qf");
}
- &run_quotacheck($_[0]) ||
- &run_quotacheck($_[0], "-u -f") ||
- &run_quotacheck($_[0], "-u -f -m") ||
- &run_quotacheck($_[0], "-u -f -m -c") ||
- &run_quotacheck($_[0], "-u -f -m -c -F $fmt");
+ local $fflag = $fmt eq "vfsv1" ? " -F $fmt" : "";
+ $ok = &run_quotacheck($_[0], "-u$fflag") ||
+ &run_quotacheck($_[0], "-u -f$fflag") ||
+ &run_quotacheck($_[0], "-u -f -m$fflag") ||
+ &run_quotacheck($_[0], "-u -f -m -c$fflag");
+ &run_quotacheck($_[0], "-u -f -m -c -F ".
+ ($fmt eq "vfsv1" ? "vfsv0" : $fmt)) if (!$ok);
}
}
- $out = &backquote_logged(
- "$config{'user_quotaon_command'} ".quotemeta($_[0])." 2>&1");
+ local $fflag = $legacy ? " -F vfsold" : "";
+ $out = &backquote_logged("$config{'user_quotaon_command'}$fflag ".
+ quotemeta($_[0])." 2>&1");
if ($?) { return $out; }
}
if ($_[1] > 1) {
# turn on group quotas
local $qf = $version >= 2 ? "aquota.group" : "quota.group";
- if (!-s "$_[0]/$qf" && !($hidden & 2)) {
+ local $legacy = $version >= 4 && !($hidden & 2) &&
+ $qf ne "quota.group" &&
+ !-s "$_[0]/$qf" &&
+ -s "$_[0]/quota.group";
+ if (!-s "$_[0]/$qf" && !$legacy && !($hidden & 2)) {
# Setting up for the first time
local $ok = 0;
- if (!$ok && &has_command("convertquota") && $version >= 2) {
+ if (!$ok && &has_command("convertquota") && $version >= 2 &&
+ $version < 4) {
# Try creating a quota.group file and converting it
&open_tempfile(QUOTAFILE, ">>$_[0]/quota.group", 0, 1);
&close_tempfile(QUOTAFILE);
@@ -350,15 +371,18 @@ if ($_[1] > 1) {
&set_ownership_permissions(undef, undef, 0600,
"$_[0]/$qf");
}
- &run_quotacheck($_[0]) ||
- &run_quotacheck($_[0], "-g -f") ||
- &run_quotacheck($_[0], "-g -f -m") ||
- &run_quotacheck($_[0], "-g -f -m -c") ||
- &run_quotacheck($_[0], "-g -f -m -c -F $fmt");
+ local $fflag = $fmt eq "vfsv1" ? " -F $fmt" : "";
+ $ok = &run_quotacheck($_[0], "-g$fflag") ||
+ &run_quotacheck($_[0], "-g -f$fflag") ||
+ &run_quotacheck($_[0], "-g -f -m$fflag") ||
+ &run_quotacheck($_[0], "-g -f -m -c$fflag");
+ &run_quotacheck($_[0], "-g -f -m -c -F ".
+ ($fmt eq "vfsv1" ? "vfsv0" : $fmt)) if (!$ok);
}
}
- $out = &backquote_logged(
- "$config{'group_quotaon_command'} ".quotemeta($_[0])." 2>&1");
+ local $fflag = $legacy ? " -F vfsold" : "";
+ $out = &backquote_logged("$config{'group_quotaon_command'}$fflag ".
+ quotemeta($_[0])." 2>&1");
if ($?) { return $out; }
}
return undef;
@@ -373,8 +397,10 @@ Runs the quotacheck command on some filesystem, and returns 1 on success or
sub run_quotacheck
{
&clean_language();
+local $cmd = $config{'quotacheck_command'};
+$cmd =~ s/\s+-[ug]+(?=\s|$)//g;
local $out = &backquote_logged(
- "$config{'quotacheck_command'} $_[1] ".quotemeta($_[0])." 2>&1");
+ "$cmd $_[1] ".quotemeta($_[0])." 2>&1");
&reset_environment();
return $? || $out =~ /cannot guess|cannot remount|cannot find|please stop/i ? 0 : 1;
}
@@ -767,18 +793,28 @@ if ($_[1] == 0 || $_[1] == 2) {
&unlink_file("$_[0]/aquota.group.new");
}
local $cmd = $config{'quotacheck_command'};
-$cmd =~ s/\s+-[ug]//g;
+$cmd =~ s/\s+-[ug]+(?=\s|$)//g;
local $flag = $_[1] == 1 ? "-u" : $_[1] == 2 ? "-g" : "-u -g";
-$out = &backquote_logged("$cmd $flag ".quotemeta($_[0])." 2>&1");
+local $new = $_[1] == 1 ?
+ !-s "$_[0]/aquota.user" && !-s "$_[0]/quota.user" :
+ $_[1] == 2 ?
+ !-s "$_[0]/aquota.group" && !-s "$_[0]/quota.group" :
+ !-s "$_[0]/aquota.user" && !-s "$_[0]/quota.user" &&
+ !-s "$_[0]/aquota.group" && !-s "$_[0]/quota.group";
+local $qver = $new ? &backquote_command("quota -V 2>&1") : "";
+local $fmt = $new && $qver =~ /\s(\d+)\.\d+/ && $1 >= 4 ? "vfsv1" : undef;
+local $fflag = $fmt ? " -F $fmt" : "";
+$out = &backquote_logged("$cmd $flag$fflag ".quotemeta($_[0])." 2>&1");
if ($?) {
# Try with the -f and -m options
$out = &backquote_logged(
- "$cmd $flag -f -m ".quotemeta($_[0])." 2>&1");
+ "$cmd $flag -f -m$fflag ".quotemeta($_[0])." 2>&1");
if ($?) {
# Try with the -F option
- foreach my $fmt ("vfsv1", "vfsv0", "vfsold") {
+ foreach my $tryfmt ($fmt ? ("vfsv0", "vfsold") :
+ ("vfsv1", "vfsv0", "vfsold")) {
$out = &backquote_logged(
- "$cmd $flag -f -m -F $fmt ".quotemeta($_[0])." 2>&1");
+ "$cmd $flag -f -m -F $tryfmt ".quotemeta($_[0])." 2>&1");
last if (!$?);
}
}
@@ -1105,6 +1141,84 @@ foreach my $m (&mount::list_mounted()) {
return $best && $best->[2] eq "btrfs" ? 1 : 0;
}
+# decode_btrfs_mount_path(path)
+# Decodes the octal escapes used by /proc/self/mountinfo.
+sub decode_btrfs_mount_path
+{
+my ($path) = @_;
+$path =~ s/\\([0-7]{3})/chr(oct($1))/eg;
+return $path;
+}
+
+# parse_btrfs_mountinfo(text, path)
+# Returns the deepest Btrfs mount point containing path and its filesystem root.
+sub parse_btrfs_mountinfo
+{
+my ($text, $path) = @_;
+my ($best_mount, $best_root);
+# Parse only Btrfs mountinfo records that can contain the requested path.
+foreach my $line (split(/\r?\n/, $text)) {
+ my ($left, $right) = split(/\s+-\s+/, $line, 2);
+ next if (!defined($right));
+ my @right = split(/\s+/, $right);
+ next if ($right[0] ne "btrfs");
+ my @left = split(/\s+/, $left);
+ next if (@left < 5);
+ my $root = &decode_btrfs_mount_path($left[3]);
+ my $mount = &decode_btrfs_mount_path($left[4]);
+ next if (!&is_under_directory($mount, $path));
+ # Prefer the deepest match when nested Btrfs subvolumes are mounted.
+ if (!defined($best_mount) || length($mount) > length($best_mount)) {
+ $best_mount = $mount;
+ $best_root = $root;
+ }
+ }
+return defined($best_mount) ? ($best_mount, $best_root) : ( );
+}
+
+=head2 btrfs_mountinfo(path)
+
+Returns the visible Btrfs mount point containing a path and its filesystem
+root, or an empty list when no containing Btrfs mount can be found.
+
+=cut
+sub btrfs_mountinfo
+{
+my ($path) = @_;
+open(my $fh, "<", "/proc/self/mountinfo") || return ( );
+local $/ = undef;
+my $text = <$fh>;
+close($fh);
+return &parse_btrfs_mountinfo($text, $path);
+}
+
+=head2 btrfs_qgroup_absolute_path(mount, filesystem-root, qgroup-path)
+
+Converts the filesystem-relative path reported by C to a
+visible absolute path, or returns undef when it is outside the mounted root.
+
+=cut
+sub btrfs_qgroup_absolute_path
+{
+my ($mount, $root, $path) = @_;
+return undef if (!defined($path) || $path eq "" || $path =~ /^);
+$root ||= "/";
+$root =~ s/^\/+//;
+$root =~ s/\/+\z//;
+$path =~ s/^\/+//;
+# Strip the mounted subvolume root from the filesystem-relative qgroup path.
+if ($root ne "") {
+ return undef if ($path ne $root && index($path, "$root/") != 0);
+ $path = substr($path, length($root));
+ $path =~ s/^\/+//;
+ }
+$mount =~ s/\/+\z// if ($mount ne "/");
+my $absolute = $path eq "" ? ($mount || "/") :
+ ($mount eq "/" ? "/$path" : "$mount/$path");
+$absolute =~ s{//+}{/}g;
+return $absolute;
+}
+
# valid_btrfs_path(path)
# Returns 1 for an absolute path that is safe to pass to Btrfs tools.
sub valid_btrfs_path
@@ -1168,6 +1282,53 @@ $rv{'levels'} = \%levels if (%levels);
return \%rv;
}
+# btrfs_filesystem_uuid(path)
+# Returns the UUID of the Btrfs filesystem containing a path.
+sub btrfs_filesystem_uuid
+{
+my ($path) = @_;
+my ($out, $err) = &run_btrfs_command(
+ 0, "filesystem", "show", "--raw", $path);
+return undef if (!defined($out) ||
+ $out !~ /^\s*Label:.*\buuid:\s*([0-9a-f]{8}(?:-[0-9a-f]{4}){3}-[0-9a-f]{12})\s*$/mi);
+return lc($1);
+}
+
+# btrfs_sysfs_quota_status(path)
+# Reads quota state exported by the kernel. This preserves accounting mode and
+# consistency information on btrfs-progs releases older than `quota status`.
+sub btrfs_sysfs_quota_status
+{
+my ($path) = @_;
+my $uuid = &btrfs_filesystem_uuid($path);
+return undef if (!$uuid);
+my $sysfs = $btrfs_sysfs_root || "/sys/fs/btrfs";
+my $qdir = "$sysfs/$uuid/qgroups";
+return undef if (!-d $qdir);
+
+my %rv = ( 'supported' => 1, 'enabled' => 1 );
+foreach my $field (qw(enabled mode inconsistent)) {
+ my $file = "$qdir/$field";
+ next if (!-r $file);
+ open(my $fh, "<", $file) || next;
+ my $value = <$fh>;
+ close($fh);
+ next if (!defined($value));
+ $value =~ s/^\s+|\s+$//g;
+ if ($field eq "mode" && $value =~ /^(qgroup|squota)$/) {
+ $rv{$field} = $value;
+ }
+ elsif ($field ne "mode" && $value =~ /^([01])$/) {
+ $rv{$field} = int($1);
+ }
+ }
+
+# Kernels predating simple quotas expose the qgroups directory without a mode
+# file. Their only possible accounting mode is full qgroups.
+$rv{'mode'} = "qgroup" if (!defined($rv{'mode'}) && !-e "$qdir/mode");
+return \%rv;
+}
+
=head2 btrfs_quota_status(path)
Returns a hash reference describing the Btrfs quota status for a path. The
@@ -1194,8 +1355,20 @@ if (defined($out)) {
# quotas are enabled, and reports a missing quota root when disabled.
my ($qout, $qerr) = &run_btrfs_command(0, "qgroup", "show", "--raw", $path);
if (defined($qout)) {
- return { 'supported' => 1,
- 'enabled' => 1 };
+ my $rv = &btrfs_sysfs_quota_status($path) ||
+ { 'supported' => 1, 'enabled' => 1 };
+ # Old qgroup-show versions warn on stdout when the counters are
+ # inconsistent. Retain that signal if sysfs did not provide the flag.
+ if (!defined($rv->{'inconsistent'})) {
+ $rv->{'inconsistent'} =
+ $qout =~ /^\s*(?:warning|error):.*qgroup.*inconsistent/mi ?
+ 1 : 0;
+ }
+ # A simple-quota space holder is definitive even when sysfs is unavailable.
+ $rv->{'mode'} = "squota"
+ if (!defined($rv->{'mode'}) &&
+ $qout =~ //i);
+ return $rv;
}
elsif ($qerr =~ /(?:quota root does not exist|quotas? (?:are |is )?not enabled)/i) {
return { 'supported' => 1,
@@ -1243,6 +1416,27 @@ foreach my $line (split(/\r?\n/, $out)) {
return \@rv;
}
+=head2 parse_btrfs_subvolume_list_output(output)
+
+Parses raw output from C and returns a hash reference
+mapping numeric subvolume IDs to filesystem-relative paths. This is used to
+fill qgroup paths on btrfs-progs versions older than 6.0.1.
+
+=cut
+sub parse_btrfs_subvolume_list_output
+{
+my ($out) = @_;
+my %rv;
+foreach my $line (split(/\r?\n/, $out)) {
+ # The default output ends in "path ".
+ # Keep the final field intact because Btrfs paths may contain spaces.
+ if ($line =~ /^ID\s+(\d+)\s+.*?\s+path\s+(.*)$/) {
+ $rv{int($1)} = $2;
+ }
+ }
+return \%rv;
+}
+
=head2 list_btrfs_qgroups(path, [sync], [&error])
Returns an array reference containing all Btrfs qgroups on the filesystem
@@ -1272,6 +1466,22 @@ if (!@$rv && $out =~ /\S/) {
$$errref = "Unable to parse Btrfs qgroup output" if ($errref);
return undef;
}
+# qgroup paths were not printed by default until btrfs-progs 6.0.1. Populate
+# missing level-0 paths from the long-established subvolume-list output so
+# callers can keep identifying subvolumes by path on supported older systems.
+if (grep { $_->{'id'} =~ /^0\/(\d+)$/ && $_->{'path'} eq '' } @$rv) {
+ my ($subvolout) = &run_btrfs_command(
+ 0, "subvolume", "list", $path);
+ if (defined($subvolout)) {
+ my $paths = &parse_btrfs_subvolume_list_output($subvolout);
+ foreach my $q (@$rv) {
+ if ($q->{'id'} =~ /^0\/(\d+)$/ && $q->{'path'} eq '' &&
+ defined($paths->{$1})) {
+ $q->{'path'} = $paths->{$1};
+ }
+ }
+ }
+ }
$$errref = undef if ($errref);
return $rv;
}
diff --git a/quota/list_btrfs.cgi b/quota/list_btrfs.cgi
new file mode 100755
index 000000000..06515d7b4
--- /dev/null
+++ b/quota/list_btrfs.cgi
@@ -0,0 +1,91 @@
+#!/usr/local/bin/perl
+# Display Btrfs quota status and subvolume qgroups
+
+require './quota-lib.pl';
+&ReadParse();
+$dir = $in{'dir'};
+
+# Restrict the page to allowed paths on mounted Btrfs filesystems.
+&can_edit_btrfs_filesys($dir) || &error($text{'btrfs_eallow'});
+defined(&btrfs_quota_status) && &is_btrfs_fs($dir) ||
+ &error($text{'btrfs_enotbtrfs'});
+&error_setup($text{'btrfs_efailed'});
+
+# Read quota status before building the status and qgroup tables.
+$status = &btrfs_quota_status($dir);
+$status || &error($text{'btrfs_enotbtrfs'});
+&error($status->{'error'}) if ($status->{'error'});
+
+&ui_print_header(undef, $text{'btrfs_title'}, "", "btrfs");
+
+# Map the command's accounting mode to a user-facing label.
+$mode = $status->{'mode'} eq "squota" ? $text{'btrfs_simple'} :
+ $status->{'mode'} eq "qgroup" ? $text{'btrfs_full'} :
+ $text{'btrfs_unknown'};
+
+# Display the current enablement, accounting mode and consistency state.
+print &ui_table_start(&text('btrfs_status_header', &html_escape($dir)),
+ "width=100%", 2);
+print &ui_table_row($text{'btrfs_status'},
+ $status->{'enabled'} ? $text{'btrfs_enabled'} : $text{'btrfs_disabled'});
+print &ui_table_row($text{'btrfs_mode'}, $mode) if ($status->{'enabled'});
+# Show consistency only when btrfs-progs or the kernel reports it.
+if (defined($status->{'inconsistent'})) {
+ print &ui_table_row($text{'btrfs_consistency'},
+ $status->{'inconsistent'} ? $text{'btrfs_inconsistent'} :
+ $text{'btrfs_consistent'});
+ }
+print &ui_table_end();
+
+# A disabled filesystem has no qgroups to list or edit.
+if (!$status->{'enabled'}) {
+ &ui_print_footer("", $text{'btrfs_return'});
+ exit;
+ }
+
+# Load all qgroups and start the usage and limit table.
+$qgroups = &list_btrfs_qgroups($dir, 0, \$listerr);
+&error($listerr) if (!$qgroups);
+print &ui_columns_start([
+ $text{'btrfs_qgroup'},
+ $text{'btrfs_path'},
+ $text{'btrfs_referenced'},
+ $text{'btrfs_exclusive'},
+ $text{'btrfs_max_referenced'},
+ $text{'btrfs_max_exclusive'},
+ ], 100, 0, undef, $text{'btrfs_qgroups'});
+foreach $q (@$qgroups) {
+ # Read-only users and the filesystem-wide top-level qgroup get no edit
+ # link. Limiting 0/5 can block Webmin from changing the limit back.
+ $qid = &ui_tag("tt", &html_escape($q->{'id'}));
+ chomp($qid);
+ if (!$access{'ro'} && $q->{'id'} ne "0/5") {
+ $qid = &ui_link("edit_btrfs.cgi?dir=".&urlize($dir).
+ "&qgroup=".&urlize($q->{'id'}), $qid);
+ }
+
+ # Display usage and use the standard unlimited label for missing limits.
+ print &ui_columns_row([
+ $qid,
+ $q->{'path'} ne "" ? &html_escape($q->{'path'}) : "-",
+ &nice_size($q->{'referenced'}),
+ &nice_size($q->{'exclusive'}),
+ defined($q->{'max_referenced'}) ?
+ &nice_size($q->{'max_referenced'}) : $text{'quota_unlimited'},
+ defined($q->{'max_exclusive'}) ?
+ &nice_size($q->{'max_exclusive'}) : $text{'quota_unlimited'},
+ ]);
+ }
+print &ui_columns_end();
+
+# Full accounting supports rescanning; simple accounting deliberately hides it.
+if (!$access{'ro'} && $access{'enable'} && $status->{'mode'} ne "squota") {
+ print &ui_hr();
+ print &ui_buttons_start();
+ print &ui_buttons_row("btrfs_action.cgi", $text{'btrfs_rescan'},
+ $text{'btrfs_rescan_desc'},
+ [ [ "dir", $dir ], [ "action", "rescan" ] ]);
+ print &ui_buttons_end();
+ }
+
+&ui_print_footer("", $text{'btrfs_return'});
diff --git a/quota/module.info b/quota/module.info
index 13275131e..c87a541bf 100644
--- a/quota/module.info
+++ b/quota/module.info
@@ -3,5 +3,5 @@ category=system
os_support=solaris *-linux hpux freebsd unixware openbsd irix netbsd macos
desc=Disk Quotas
depends=mount
-longdesc=Setup and edit user or group disk quotas for local filesystems.
+longdesc=Setup and edit user, group and Btrfs subvolume quotas for local filesystems.
readonly=1
diff --git a/quota/quota-lib.pl b/quota/quota-lib.pl
index 265c8e7b3..78e79e288 100755
--- a/quota/quota-lib.pl
+++ b/quota/quota-lib.pl
@@ -82,6 +82,32 @@ if (defined("a_possible)) {
return grep { $_->[4] || $_->[6] } @mtab;
}
+=head2 list_btrfs_filesystems
+
+Returns one entry for each mounted Btrfs filesystem when the OS library
+provides the Btrfs quota API. Command availability and quota status are checked
+separately by callers; on systems without the API, this function returns an
+empty list.
+
+=cut
+sub list_btrfs_filesystems
+{
+# The OS-specific library determines whether Btrfs quota operations exist.
+return ( ) if (!defined(&btrfs_quota_status));
+
+# Separately mounted subvolumes share quota state, so keep only the first mount
+# for each underlying source while preserving the original display order.
+my %seen;
+my @filesystems;
+foreach my $fs (&mount::list_mounted()) {
+ next if ($fs->[2] ne "btrfs");
+ (my $source = $fs->[1]) =~ s/\[[^\]]*\]$//;
+ next if ($seen{$source}++);
+ push(@filesystems, $fs);
+ }
+return @filesystems;
+}
+
=head2 parse_options(type, options)
Convert an options string for some filesystem into the global hash %options.
@@ -412,6 +438,20 @@ foreach $fs (split(/\s+/, $access{'filesys'})) {
return 0;
}
+=head2 can_edit_btrfs_filesys(filesys)
+
+Returns 1 if the current Webmin user can manage Btrfs quotas. Btrfs quota state
+and qgroup IDs belong to the whole underlying filesystem, so a mount-path ACL
+cannot safely confine access to one separately mounted subvolume.
+
+=cut
+sub can_edit_btrfs_filesys
+{
+my ($filesys) = @_;
+return 0 if (!&can_edit_filesys($filesys));
+return scalar(grep { $_ eq "*" } split(/\s+/, $access{'filesys'})) ? 1 : 0;
+}
+
=head2 can_edit_user(user)
Returns 1 if the current Webmin user can manage quotas for some Unix user.
diff --git a/quota/save_btrfs.cgi b/quota/save_btrfs.cgi
new file mode 100755
index 000000000..f49a7b97e
--- /dev/null
+++ b/quota/save_btrfs.cgi
@@ -0,0 +1,86 @@
+#!/usr/local/bin/perl
+# Save the limits for a Btrfs qgroup
+
+require './quota-lib.pl';
+&ReadParse();
+$dir = $in{'dir'};
+
+# Require write access to an allowed mounted Btrfs filesystem and reject
+# malformed qgroup IDs before parsing or applying limits.
+$access{'ro'} && &error($text{'btrfs_eedit'});
+&can_edit_btrfs_filesys($dir) || &error($text{'btrfs_eallow'});
+defined(&btrfs_quota_status) && &is_btrfs_fs($dir) ||
+ &error($text{'btrfs_enotbtrfs'});
+&valid_btrfs_qgroup_id($in{'qgroup'}) || &error($text{'btrfs_eqgroup'});
+$in{'qgroup'} eq "0/5" && &error($text{'btrfs_etoplevel'});
+&error_setup($text{'btrfs_esave'});
+
+# parse_limit(name)
+# Parse one optional byte limit from quota_input and validate its unit factor.
+sub parse_limit
+{
+my ($name) = @_;
+
+# A selected default means that this limit should be removed.
+return undef if ($in{$name."_def"});
+
+# Accept only positive decimal values and units offered by ui_bytesbox.
+$in{$name} =~ /^\d+(?:\.\d+)?$/ && $in{$name} > 0 ||
+ &error($text{'btrfs_elimit'});
+local %units = map { $_, 1 } ( 1, 1024, 1024**2, 1024**3,
+ 1024**4, 1024**5 );
+$units{$in{$name."_units"}} || &error($text{'btrfs_elimit'});
+return int($in{$name} * $in{$name."_units"});
+}
+
+# Parse both limits completely before making either filesystem change.
+$max_referenced = &parse_limit("max_referenced");
+$max_exclusive = &parse_limit("max_exclusive");
+
+# Apply the existing ACL ceiling, converting its KiB value to bytes.
+if ($access{'maxblocks'}) {
+ $maxbytes = $access{'maxblocks'} * 1024;
+ defined($max_referenced) && $max_referenced <= $maxbytes &&
+ defined($max_exclusive) && $max_exclusive <= $maxbytes ||
+ &error(&text('btrfs_emax', &nice_size($maxbytes)));
+ }
+
+# Refresh the selected qgroup so unchanged limits are not re-applied. This
+# lookup only needs the stored limit values, so no filesystem sync is needed.
+$qgroups = &list_btrfs_qgroups($dir, 0, \$listerr);
+&error($listerr) if (!$qgroups);
+($qgroup) = grep { $_->{'id'} eq $in{'qgroup'} } @$qgroups;
+$qgroup || &error($text{'btrfs_eqgroup'});
+
+# same_limit(first, second)
+# Returns true when two optional byte limits are identical.
+sub same_limit
+{
+my ($first, $second) = @_;
+return !defined($first) && !defined($second) ||
+ defined($first) && defined($second) && $first == $second;
+}
+
+# Compare the submitted referenced and exclusive limits with their current
+# values before running either Btrfs command.
+$same_referenced = &same_limit(
+ $max_referenced, $qgroup->{'max_referenced'});
+$same_exclusive = &same_limit(
+ $max_exclusive, $qgroup->{'max_exclusive'});
+
+# Apply only changed limits so each independent setting is left untouched when
+# the submitted value already matches it.
+if (!$same_referenced) {
+ $err = &set_btrfs_qgroup_limit(
+ $dir, $in{'qgroup'}, $max_referenced, 0);
+ &error($err) if ($err);
+ }
+if (!$same_exclusive) {
+ $err = &set_btrfs_qgroup_limit(
+ $dir, $in{'qgroup'}, $max_exclusive, 1);
+ &error($err) if ($err);
+ }
+
+# Log the completed update and return to the qgroup list.
+&webmin_log("save", "btrfs", $in{'qgroup'}, \%in);
+&redirect("list_btrfs.cgi?dir=".&urlize($dir));
diff --git a/quota/t/run-tests.t b/quota/t/run-tests.t
index 361fd30fb..f0bbad357 100644
--- a/quota/t/run-tests.t
+++ b/quota/t/run-tests.t
@@ -5,6 +5,8 @@ no warnings 'once';
use Test::More;
use Cwd qw(abs_path);
use File::Basename qw(dirname);
+use File::Path qw(make_path);
+use File::Temp qw(tempdir);
my $root = abs_path(dirname(__FILE__)."/../..") or die "rootdir: $!";
my @commands;
@@ -22,6 +24,9 @@ return $_[0] eq "btrfs" ? "/usr/bin/btrfs" : undef;
sub clean_language { }
sub reset_environment { }
+sub is_readonly_mode { return 0; }
+sub system_logged { return 0; }
+sub unlink_file { return unlink($_[0]); }
sub is_under_directory
{
@@ -71,6 +76,137 @@ return @{$main::mounted[0]};
do "$root/quota/linux-lib.pl" or die "linux-lib.pl: $@ $!";
+$main::config{'quotacheck_command'} = "quotacheck -ug";
+$main::config{'user_quotaon_command'} = "quotaon -u";
+$main::config{'group_quotaon_command'} = "quotaon -g";
+
+my $newquota = tempdir(CLEANUP => 1);
+@commands = ( );
+@responses = (
+ { 'out' => "Quota utilities version 4.06.\n", 'status' => 0 },
+ { 'out' => "", 'status' => 0 },
+ );
+is(main::quotacheck($newquota, 1), undef,
+ "new user quota file can be checked");
+like($commands[1], qr/quotacheck -u -F vfsv1 /,
+ "combined configured flags are replaced and new files prefer vfsv1");
+unlike($commands[1], qr/ -g(?: |$)/,
+ "user quota check does not also create group quotas");
+
+my $oldquota = tempdir(CLEANUP => 1);
+open(my $oldfh, '>', "$oldquota/aquota.user") or die $!;
+print {$oldfh} "existing\n";
+close($oldfh);
+@commands = ( );
+@responses = ({ 'out' => "", 'status' => 0 });
+is(main::quotacheck($oldquota, 1), undef,
+ "existing user quota file can be checked");
+is(scalar(@commands), 1,
+ "existing quota check does not probe the quota tools version");
+unlike($commands[0], qr/ -F /,
+ "existing quota file format is auto-detected");
+
+my $groupquota = tempdir(CLEANUP => 1);
+@commands = ( );
+@responses = (
+ { 'out' => "Quota utilities version 4.06.\n", 'status' => 0 },
+ { 'out' => "", 'status' => 0 },
+ );
+is(main::quotacheck($groupquota, 2), undef,
+ "new group quota file can be checked");
+like($commands[1], qr/quotacheck -g -F vfsv1 /,
+ "group-only creation also prefers vfsv1");
+
+my $legacyquota = tempdir(CLEANUP => 1);
+@commands = ( );
+@responses = (
+ { 'out' => "Quota utilities version 3.17.\n", 'status' => 0 },
+ { 'out' => "", 'status' => 0 },
+ );
+is(main::quotacheck($legacyquota, 1), undef,
+ "legacy quota tools can create quota files");
+unlike($commands[1], qr/ -F vfsv1 /,
+ "legacy quota tools retain their default format");
+
+my $fallbackquota = tempdir(CLEANUP => 1);
+@commands = ( );
+@responses = (
+ { 'out' => "Quota utilities version 4.06.\n", 'status' => 0 },
+ { 'out' => "failed\n", 'status' => 1 },
+ { 'out' => "failed\n", 'status' => 1 },
+ { 'out' => "", 'status' => 0 },
+ );
+is(main::quotacheck($fallbackquota, 1), undef,
+ "quota check falls back when vfsv1 creation fails");
+like($commands[3], qr/ -F vfsv0 /,
+ "vfsv0 is the first creation fallback");
+
+my $activatequota = tempdir(CLEANUP => 1);
+@commands = ( );
+@responses = (
+ { 'out' => "Quota utilities version 4.06.\n", 'status' => 0 },
+ { 'out' => "", 'status' => 0 },
+ { 'out' => "", 'status' => 0 },
+ );
+is(main::quotaon($activatequota, 1), undef,
+ "new user quotas can be activated");
+like($commands[1], qr/quotacheck -u -F vfsv1 /,
+ "quota activation creates vfsv1 files");
+unlike($commands[1], qr/ -g(?: |$)/,
+ "user quota activation does not also create group quotas");
+
+my $legacyfile = tempdir(CLEANUP => 1);
+open(my $legacyfh, '>', "$legacyfile/quota.user") or die $!;
+print {$legacyfh} "existing legacy quotas\n";
+close($legacyfh);
+@commands = ( );
+@responses = (
+ { 'out' => "Quota utilities version 4.06.\n", 'status' => 0 },
+ { 'out' => "", 'status' => 0 },
+ );
+is(main::quotaon($legacyfile, 1), undef,
+ "legacy user quota files can be activated");
+like($commands[1], qr/^quotaon -u -F vfsold /,
+ "legacy user quota files are activated without conversion");
+ok(-s "$legacyfile/quota.user",
+ "legacy user quota files are preserved");
+
+my $legacygroup = tempdir(CLEANUP => 1);
+open(my $legacygfh, '>', "$legacygroup/quota.group") or die $!;
+print {$legacygfh} "existing legacy quotas\n";
+close($legacygfh);
+@commands = ( );
+@responses = (
+ { 'out' => "Quota utilities version 4.06.\n", 'status' => 0 },
+ { 'out' => "", 'status' => 0 },
+ );
+is(main::quotaon($legacygroup, 2), undef,
+ "legacy group quota files can be activated");
+like($commands[1], qr/^quotaon -g -F vfsold /,
+ "legacy group quota files are activated without conversion");
+ok(-s "$legacygroup/quota.group",
+ "legacy group quota files are preserved");
+
+my $mixedquota = tempdir(CLEANUP => 1);
+foreach my $file (qw(aquota.user quota.user aquota.group quota.group)) {
+ open(my $mixedfh, '>', "$mixedquota/$file") or die $!;
+ print {$mixedfh} "existing quotas\n";
+ close($mixedfh);
+ }
+@commands = ( );
+@responses = (
+ { 'out' => "Quota utilities version 4.06.\n", 'status' => 0 },
+ { 'out' => "", 'status' => 0 },
+ { 'out' => "", 'status' => 0 },
+ );
+is(main::quotaon($mixedquota, 3), undef,
+ "modern quota files take precedence over stale legacy files");
+unlike(join("\n", @commands), qr/ -F vfsold /,
+ "stale legacy files do not override modern quota formats");
+
+# Device-less tmpfs quota options must not create unusable filesystem rows.
+is(main::quota_can([ "/tmp", "tmpfs", "tmpfs", "rw,usrquota" ], undef),
+ 0, "tmpfs quota mount options are ignored");
ok(main::is_btrfs_fs("/srv/btrfs"),
"Btrfs mount point is detected");
ok(main::is_btrfs_fs("/srv/btrfs/domain1"),
@@ -82,6 +218,23 @@ ok(!main::is_btrfs_fs("/"),
ok(!defined(main::btrfs_quota_status("/")),
"quota status is unavailable for non-Btrfs paths");
+my $mountinfo = <<'EOF';
+24 1 0:20 / / rw,relatime - ext4 /dev/root rw
+31 24 0:42 /@home /home rw,relatime - btrfs /dev/vdb rw,compress=zstd
+32 31 0:42 /@home/example/homes/bob /srv/bob rw,relatime - btrfs /dev/vdb rw,compress=zstd
+EOF
+my ($mount, $fsroot) = main::parse_btrfs_mountinfo(
+ $mountinfo, "/home/example/homes/alice");
+is($mount, "/home", "containing Btrfs mount is selected");
+is($fsroot, '/@home', "mounted Btrfs filesystem root is returned");
+is(main::btrfs_qgroup_absolute_path(
+ $mount, $fsroot, '@home/example/homes/alice'),
+ "/home/example/homes/alice",
+ "qgroup path is translated through a mounted subvolume root");
+ok(!defined(main::btrfs_qgroup_absolute_path(
+ $mount, $fsroot, '@var/lib/mysql')),
+ "qgroups outside the mounted filesystem root are ignored");
+
my $status_text = <<'EOF';
Quotas on /srv/btrfs:
Enabled: yes
@@ -132,6 +285,27 @@ is(scalar(@commands), 1, "successful status does not run fallback");
$status = main::btrfs_quota_status("/srv/btrfs");
ok($status->{'enabled'}, "legacy qgroup fallback detects enabled quotas");
+my $sysfs = tempdir(CLEANUP => 1);
+my $fsuuid = "12345678-1234-1234-1234-123456789abc";
+make_path("$sysfs/$fsuuid/qgroups");
+foreach my $pair ([ 'enabled', 1 ], [ 'mode', 'squota' ],
+ [ 'inconsistent', 1 ]) {
+ open(my $fh, '>', "$sysfs/$fsuuid/qgroups/$pair->[0]") or die $!;
+ print {$fh} "$pair->[1]\n";
+ close($fh);
+ }
+local $main::btrfs_sysfs_root = $sysfs;
+@responses = (
+ { 'out' => "ERROR: unknown token 'status'\n", 'status' => 1 },
+ { 'out' => "qgroupid rfer excl\n0/5 16384 16384\n", 'status' => 0 },
+ { 'out' => "Label: none uuid: $fsuuid\n", 'status' => 0 },
+ );
+$status = main::btrfs_quota_status("/srv/btrfs");
+is($status->{'mode'}, 'squota',
+ "legacy fallback reads simple-quota mode from sysfs");
+ok($status->{'inconsistent'},
+ "legacy fallback reads inconsistent accounting from sysfs");
+
@responses = (
{ 'out' => "ERROR: unknown token 'status'\n", 'status' => 1 },
{ 'out' => "ERROR: quota root does not exist\n", 'status' => 1 },
@@ -173,6 +347,27 @@ ok(!defined($list_error), "successful qgroup list clears the error");
like($commands[0], qr/qgroup show .*\\-\\-sync .*srv.*btrfs/,
"synchronized qgroup listing requests --sync");
+my $legacy_qgroup_text = <<'EOF';
+Qgroupid Referenced Exclusive Max_referenced Max_exclusive Parent Child
+0/256 16384 16384 67108864 none 1/100 -
+0/257 0 0 none 33554432 1/100 -
+1/100 16384 16384 100663296 none - 0/256,0/257
+EOF
+@commands = ( );
+@responses = (
+ { 'out' => $legacy_qgroup_text, 'status' => 0 },
+ { 'out' => "ID 256 gen 10 top level 5 path domain1\n".
+ "ID 257 gen 11 top level 5 path domain path two\n",
+ 'status' => 0 },
+ );
+$qgroups = main::list_btrfs_qgroups("/srv/btrfs", 0, \$list_error);
+is($qgroups->[0]->{'path'}, "domain1",
+ "legacy qgroup rows gain paths from the subvolume list");
+is($qgroups->[1]->{'path'}, "domain path two",
+ "legacy subvolume paths containing spaces and path are preserved");
+like($commands[1], qr/subvolume list .*srv.*btrfs/,
+ "legacy qgroup output triggers one compatibility lookup");
+
@responses = ({ 'out' => "ERROR: quotas not enabled\n", 'status' => 1 });
$qgroups = main::list_btrfs_qgroups("/srv/btrfs", 0, \$list_error);
ok(!defined($qgroups), "failed qgroup listing returns undef");
@@ -240,6 +435,13 @@ is(main::set_btrfs_qgroup_limit("/srv/btrfs", "1/100", "1M"),
is(main::assign_btrfs_qgroup("/srv/btrfs", "bad", "1/100"),
"Invalid child Btrfs qgroup ID", "invalid child assignment is rejected");
+@commands = ( );
+@responses = ({ 'out' => "ERROR: unable to limit requested quota group: ".
+ "Disk quota exceeded\n", 'status' => 1 });
+like(main::set_btrfs_qgroup_limit("/srv/btrfs", "1/100", 2097152),
+ qr/Disk quota exceeded/, "qgroup limit errors are returned without retry");
+is(scalar(@commands), 1, "a failed qgroup limit command is not retried");
+
@responses = ({ 'out' => "ERROR: qgroup exists\n", 'status' => 1 });
is(main::create_btrfs_qgroup("/srv/btrfs", "1/100"),
"ERROR: qgroup exists", "Btrfs command errors are returned to callers");
diff --git a/session_login.cgi b/session_login.cgi
index ec7851bdf..31e7a48df 100755
--- a/session_login.cgi
+++ b/session_login.cgi
@@ -4,6 +4,7 @@
BEGIN { push(@INC, "."); };
use WebminCore;
+require './login-lib.pl';
$pragma_no_cache = 1;
#$ENV{'MINISERV_INTERNAL'} || die "Can only be called by miniserv.pl";
@@ -93,17 +94,7 @@ print "$text{'session_prefix'}\n";
print &ui_form_start("@{[&get_webprefix()]}/session_login.cgi", "post");
print &ui_hidden("page", $in{'page'});
-my $not_secure;
-if ($ENV{'HTTPS'} ne 'ON' && $miniserv{'ssl'}) {
- my $link = ui_tag('a', "⚠ $text{'login_notsecure'}",
- { 'href' => "javascript:void(0);",
- 'class' => 'inherit-color',
- 'onclick' => "window.location.href = ".
- "window.location.href.replace(/^http:/, 'https:'); return false;",
- });
- $not_secure = ui_tag('span', $link,
- { class => 'not-secure', title => $text{'login_notsecure_desc'} });
- }
+my $not_secure = &get_login_http_warning(\%miniserv);
print &ui_table_start($text{'session_header'} . $not_secure,
"width=40% class='loginform'", 2);
diff --git a/setup.pl b/setup.pl
index 274f14840..22edd1ca7 100755
--- a/setup.pl
+++ b/setup.pl
@@ -66,7 +66,7 @@ if ($ENV{'perllib'}) {
# Validate source directory
@allmods = map { s/\/module.info$//; $_ } glob("*/module.info");
if (!@allmods) {
- &errorexit("ERROR: Failed to get module list");
+ &errorexit("Failed to get module list");
}
$allmods = join(" ", @allmods);
print "\n";
@@ -341,6 +341,7 @@ else {
# Ask the user if SSL should be used
if ($ENV{'ssl'} ne '') {
$ssl = $ENV{'ssl'};
+ $no_ssl_warn = 1 if (!$ssl);
}
else {
$ssl = 0;
@@ -351,6 +352,9 @@ else {
if ($sslyn =~ /^y/i) {
$ssl = 1;
}
+ else {
+ $no_ssl_warn = 1;
+ }
}
else {
print "The Perl SSLeay library is not installed. SSL not available.\n"
@@ -431,6 +435,7 @@ else {
if ($ENV{'allow'}) {
$miniserv{'allow'} = $ENV{'allow'};
}
+ $miniserv{'no_ssl_warn'} = 1 if ($no_ssl_warn);
if ($ENV{'session'} eq '') {
$miniserv{'session'} = $os_type eq 'windows' ? 0 : 1;
}
@@ -488,7 +493,8 @@ else {
chmod(0600, $ufile);
# Generate cert
- if (system("openssl version >/dev/null 2>&1") == 0) {
+ $openssl_available = system("openssl version >/dev/null 2>&1") == 0;
+ if ($openssl_available) {
# We can generate a new SSL key for this host
$host = &get_system_hostname();
$cert = &tempname();
@@ -519,11 +525,27 @@ else {
}
unlink($cert, $key);
}
- if (!-r $kfile) {
- # Fall back to the built-in key
- ©_source_dest("$wadir/miniserv.pem", $kfile);
+ if (-r $kfile) {
+ chmod(0600, $kfile);
+ }
+ else {
+ delete($miniserv{'keyfile'});
+ if ($ssl) {
+ print "\n";
+ if ($openssl_available) {
+ print "ERROR: Failed to generate or install a unique TLS certificate for this host.\n";
+ }
+ else {
+ print "ERROR: OpenSSL is not available, so a unique TLS certificate could not be generated.\n";
+ }
+ print "WARNING: Webmin will be configured to use HTTP only.\n";
+ print "Login credentials and sessions will not be encrypted until SSL is enabled\n";
+ print "with a valid certificate. See https://webmin.com/docs/modules/webmin-configuration/#ssl-encryption for help.\n\n";
+ $ssl = 0;
+ $miniserv{'ssl'} = 0;
+ }
+ &put_miniserv_config(\%miniserv);
}
- chmod(0600, $kfile);
print ".. done\n";
print "\n";
diff --git a/setup.sh b/setup.sh
index d235621c6..1cfbcee7c 100755
--- a/setup.sh
+++ b/setup.sh
@@ -458,6 +458,9 @@ else
fi
# Ask the user if SSL should be used
+ if [ "$ssl" = "0" ]; then
+ no_ssl_warn=1
+ fi
if [ "$ssl" = "" ]; then
ssl=0
$perl -e 'use Net::SSLeay' >/dev/null 2>/dev/null
@@ -466,6 +469,8 @@ else
read sslyn
if [ "$sslyn" = "y" -o "$sslyn" = "Y" ]; then
ssl=1
+ else
+ no_ssl_warn=1
fi
else
echo "The Perl SSLeay library is not installed. SSL not available."
@@ -528,6 +533,9 @@ else
echo "pidfile=$var_dir/miniserv.pid" >> $cfile
echo "logtime=168" >> $cfile
echo "ssl=$ssl" >> $cfile
+ if [ "$no_ssl_warn" = "1" ]; then
+ echo "no_ssl_warn=1" >> $cfile
+ fi
echo "no_ssl2=1" >> $cfile
echo "no_ssl3=1" >> $cfile
openssl version 2>&1 | grep "OpenSSL 1" >/dev/null
@@ -598,8 +606,10 @@ else
echo "userfile=$ufile" >> $cfile
kfile=$config_dir/miniserv.pem
+ openssl_available=0
openssl version >/dev/null 2>&1
if [ "$?" = "0" ]; then
+ openssl_available=1
# OpenSSL support `-addext` flag?
addtextsup="-addext subjectAltName=DNS:$host,DNS:localhost -addext extendedKeyUsage=serverAuth"
openssl version 2>&1 | grep "OpenSSL 1.0" >/dev/null
@@ -621,12 +631,28 @@ EOF
fi
rm -f $tempdir/cert $tempdir/key
fi
- if [ ! -r $kfile ]; then
- # Fall back to the built-in key
- cp "$wadir/miniserv.pem" $kfile
+ if [ -r "$kfile" ]; then
+ chmod 600 "$kfile"
+ echo "keyfile=$config_dir/miniserv.pem" >> $cfile
+ elif [ "$ssl" = "1" ]; then
+ echo ""
+ if [ "$openssl_available" = "1" ]; then
+ echo "ERROR: Failed to generate or install a unique TLS certificate for this host."
+ else
+ echo "ERROR: OpenSSL is not available, so a unique TLS certificate could not be generated."
+ fi
+ echo "WARNING: Webmin will be configured to use HTTP only."
+ echo "Login credentials and sessions will not be encrypted until SSL is enabled"
+ echo "with a valid certificate. See https://webmin.com/docs/modules/webmin-configuration/#ssl-encryption for help."
+ echo ""
+ ssl=0
+ new_cfile=$tempdir/$$.miniserv.conf
+ if ! sed 's/^ssl=.*/ssl=0/' "$cfile" >"$new_cfile" ||
+ ! mv "$new_cfile" "$cfile"; then
+ echo "ERROR: Failed to switch Webmin to HTTP-only mode."
+ exit 1
+ fi
fi
- chmod 600 $kfile
- echo "keyfile=$config_dir/miniserv.pem" >> $cfile
chmod 600 $cfile
echo ".. done"
@@ -980,9 +1006,11 @@ for m in $newmods; do
done
# Make miniserv config files non-world-readable
for f in miniserv.conf miniserv.pem miniserv.users; do
- chown -R root $config_dir/$f
- chgrp -R bin $config_dir/$f
- chmod -R og-rw $config_dir/$f
+ if [ -e "$config_dir/$f" ]; then
+ chown -R root $config_dir/$f
+ chgrp -R bin $config_dir/$f
+ chmod -R og-rw $config_dir/$f
+ fi
done
chmod +r $config_dir/version
if [ "$nochown" = "" ]; then
diff --git a/software/CHANGELOG b/software/CHANGELOG
index 988952cae..82ef37064 100644
--- a/software/CHANGELOG
+++ b/software/CHANGELOG
@@ -1,5 +1,6 @@
---- Changes since 2.641 ----
Fix Alpine Linux mysql/mariadb package installs names due missing server utils (means at least Alpine Linux package installation is supported since Alpine linux v 3.16 up to edge)
+Added APT functions for listing, holding, unholding and explicitly updating held packages.
---- Changes since 1.130 ----
Packages can now be installed directly from yum, if installed.
The entire system can also be upgraded from yum.
diff --git a/software/apt-lib.pl b/software/apt-lib.pl
index e0f9f5add..ccf1ac286 100755
--- a/software/apt-lib.pl
+++ b/software/apt-lib.pl
@@ -20,20 +20,33 @@ $name =~ s/:[A-Za-z0-9][A-Za-z0-9._-]*$//;
return $name;
}
-# update_system_install([package], [&in], [no-force])
+# update_system_install([package], [&in], [no-force], [flags])
# Install some package with apt
sub update_system_install
{
local $update = $_[0] || $in{'update'};
local $force = !$_[2];
+local $flags = $_[3];
local (@rv, @newpacks);
+# Only accept the one flag needed for an explicit update of held packages.
+# Other update systems use this argument for their own package-manager flags,
+# but APT historically ignored it.
+local $holdflag = defined($flags) &&
+ $flags eq '--allow-change-held-packages'
+ ? ' --allow-change-held-packages'
+ : '';
+local $install_command = $holdflag ? 'apt-get' : $apt_get_command;
+local @rehold = $holdflag ? &list_update_system_holds() : ( );
+
# Build the command to run
$ENV{'UCF_FORCE_CONFFOLD'} = 'YES';
$ENV{'DEBIAN_FRONTEND'} = 'noninteractive';
-local $uicmd = "$apt_get_command -y ".($force ? " -f" : "")." install $update";
+local $uicmd = "$install_command -y".$holdflag.
+ ($force ? " -f" : "")." install $update";
$update = join(" ", map { quotemeta($_) } split(/\s+/, $update));
-local $cmd = "$apt_get_command -y ".($force ? " -f" : "")." install $update";
+local $cmd = "$install_command -y".$holdflag.
+ ($force ? " -f" : "")." install $update";
print &text('apt_install', "".&html_escape($uicmd).""),"\n";
print "";
&additional_log('exec', undef, $cmd);
@@ -68,14 +81,27 @@ while() {
print &html_escape("$_");
}
close(CMD);
+local $status = $?;
+
+# Restore holds after --allow-change-held-packages, which applies to the whole
+# transaction and can clear holds on selected packages or dependencies.
+if (@rehold) {
+ local $rehold_error = &update_system_hold(\@rehold, 1);
+ if ($rehold_error) {
+ print &text('apt_reholdfailed',
+ "".&html_escape(join(" ", @rehold))."",
+ &html_escape($rehold_error)),"\n";
+ }
+ }
&reset_environment();
-if (!@rv && $config{'package_system'} ne 'debian' && !$?) {
+if (!@rv && $config{'package_system'} ne 'debian' && !$status) {
# Other systems don't list the packages installed!
@rv = @newpacks;
}
print "
\n";
-if ($?) { print "$text{'apt_failed'}\n"; }
+if ($status) { print "$text{'apt_failed'}
\n"; }
else { print "$text{'apt_ok'}
\n"; }
+$? = $status;
return @rv;
}
@@ -239,21 +265,13 @@ return @rv;
# Returns a list of available package updates
sub update_system_updates
{
+my ($include_holds) = @_;
&execute_command("$apt_get_command update");
-# Find held packages by dpkg
-local %holds;
-if ($config{'package_system'} eq 'debian') {
- &clean_language();
- &open_execute_command(HOLDS, "dpkg --get-selections", 1, 1);
- while() {
- if (/^(\S+)\s+hold/) {
- $holds{$1}++;
- }
- }
- close(HOLDS);
- &reset_environment();
- }
+# Find held packages. By default these remain excluded, but callers can ask
+# for them so that a dedicated held-updates view can display them.
+local %holds = map { &strip_apt_package_arch($_), 1 }
+ &list_update_system_holds();
if (&has_command("apt-show-versions")) {
# This awesome command can give us all updates in one hit, and takes
@@ -264,7 +282,7 @@ if (&has_command("apt-show-versions")) {
&open_execute_command(PKGS, "apt-show-versions 2>/dev/null", 1, 1);
while() {
if (/^(\S+)\/(\S+)\s+upgradeable\s+from\s+(\S+)\s+to\s+(\S+)/ &&
- !$holds{$1}) {
+ ($include_holds || !$holds{&strip_apt_package_arch($1)})) {
# Old format
local $pkg = { 'name' => $1,
'source' => $2,
@@ -272,9 +290,12 @@ if (&has_command("apt-show-versions")) {
if ($pkg->{'version'} =~ s/^(\S+)://) {
$pkg->{'epoch'} = $1;
}
+ $pkg->{'held'} = 1
+ if ($holds{&strip_apt_package_arch($pkg->{'name'})});
push(@rv, $pkg);
}
- elsif (/^(\S+):(\S+)\/(\S+)\s+(\S+)\s+upgradeable\s+to\s+(\S+)/ && !$holds{$1}) {
+ elsif (/^(\S+):(\S+)\/(\S+)\s+(\S+)\s+upgradeable\s+to\s+(\S+)/ &&
+ ($include_holds || !$holds{$1})) {
# New format, like
# libgomp1:i386/unstable 4.8.2-2 upgradeable to 4.8.2-4
local $pkg = { 'name' => $1,
@@ -284,12 +305,14 @@ if (&has_command("apt-show-versions")) {
if ($pkg->{'version'} =~ s/^(\S+)://) {
$pkg->{'epoch'} = $1;
}
+ $pkg->{'held'} = 1 if ($holds{$pkg->{'name'}});
push(@rv, $pkg);
}
}
close(PKGS);
&reset_environment();
- @rv = &filter_held_packages(@rv);
+ @rv = grep { !$holds{&strip_apt_package_arch($_->{'name'})} } @rv
+ if (!$include_holds);
foreach my $pkg (@rv) {
$pkg->{'security'} = 1 if ($pkg->{'source'} =~ /security/i);
}
@@ -301,7 +324,8 @@ elsif (&has_command("apt")) {
&clean_language();
&open_execute_command(PKGS, "apt list --upgradable 2>/dev/null", 1, 1);
while() {
- if (/^(\S+)\/(\S+)\s+(\S+)\s+(\S+)\s+\[upgradable\s+from:\s+(\S+)\]/ && !$holds{$1}) {
+ if (/^(\S+)\/(\S+)\s+(\S+)\s+(\S+)\s+\[upgradable\s+from:\s+(\S+)\]/ &&
+ ($include_holds || !$holds{&strip_apt_package_arch($1)})) {
local $pkg = { 'name' => $1,
'source' => $2,
'version' => $3,
@@ -310,12 +334,15 @@ elsif (&has_command("apt")) {
$pkg->{'epoch'} = $1;
}
$pkg->{'source'} =~ s/,.*$//;
+ $pkg->{'held'} = 1
+ if ($holds{&strip_apt_package_arch($pkg->{'name'})});
push(@rv, $pkg);
}
}
close(PKGS);
&reset_environment();
- @rv = &filter_held_packages(@rv);
+ @rv = grep { !$holds{&strip_apt_package_arch($_->{'name'})} } @rv
+ if (!$include_holds);
foreach my $pkg (@rv) {
$pkg->{'security'} = 1 if ($pkg->{'source'} =~ /security/i);
}
@@ -334,7 +361,8 @@ else {
$currentmap{$pkg->{'name'}} ||= $pkg;
}
local @rv;
- local @names = grep { !$holds{$_} } keys %currentmap;
+ local @names = $include_holds ? keys %currentmap :
+ grep { !$holds{$_} } keys %currentmap;
while(scalar(@names)) {
local @somenames;
if (scalar(@names) > 100) {
@@ -371,6 +399,8 @@ else {
&compare_versions($pkg->{'version'},
$pkg->{'oldversion'});
if ($newer > 0) {
+ $pkg->{'held'} = 1
+ if ($holds{$pkg->{'name'}});
push(@rv, $pkg);
}
}
@@ -378,7 +408,8 @@ else {
close(PKGS);
&reset_environment();
}
- @rv = &filter_held_packages(@rv);
+ @rv = grep { !$holds{&strip_apt_package_arch($_->{'name'})} } @rv
+ if (!$include_holds);
&set_pinned_versions(\@rv);
return @rv;
}
@@ -411,11 +442,10 @@ close(PKGS);
&reset_environment();
}
-# filter_held_packages(package, ...)
-# Returns a list of package updates, minus those that are held
-sub filter_held_packages
+# list_update_system_holds()
+# Returns the unique names of all packages currently held by APT or dpkg.
+sub list_update_system_holds
{
-my @pkgs = @_;
my %hold;
# Get holds from dpkg
@@ -447,15 +477,47 @@ if (&has_command("apt-mark")) {
&clean_language();
&open_execute_command(PKGS, "apt-mark showhold 2>/dev/null", 1, 1);
while() {
- if (/^([^:\s]+)/) {
+ if (/^(\S+)/) {
$hold{$1} = 1;
}
}
close(PKGS);
&reset_environment();
}
+return sort keys %hold;
+}
-return grep { !$hold{$_->{'name'}} } @pkgs;
+# update_system_hold(&packages, hold)
+# Holds or unholds a list of packages. Returns undef on success, or an error.
+sub update_system_hold
+{
+my ($packages, $hold) = @_;
+return "The apt-mark command is not installed"
+ if (!&has_command("apt-mark"));
+my @packages = &unique(@$packages);
+return "No packages were specified" if (!@packages);
+my $action = $hold ? 'hold' : 'unhold';
+my $cmd = "apt-mark $action ".
+ join(" ", map { quotemeta($_) } @packages);
+my $out;
+&clean_language();
+my $status = &execute_command_logged($cmd, undef, \$out, \$out);
+&reset_environment();
+if ($status) {
+ $out = &trim($out);
+ return $out || "apt-mark $action failed";
+ }
+return undef;
+}
+
+# filter_held_packages(package, ...)
+# Returns a list of package updates, minus those that are held
+sub filter_held_packages
+{
+my @pkgs = @_;
+my %hold = map { &strip_apt_package_arch($_), 1 }
+ &list_update_system_holds();
+return grep { !$hold{&strip_apt_package_arch($_->{'name'})} } @pkgs;
}
# list_package_repos()
diff --git a/software/lang/en b/software/lang/en
index 8a890e515..aa84dbace 100644
--- a/software/lang/en
+++ b/software/lang/en
@@ -235,6 +235,7 @@ apt_input=Package from APT
apt_install=Installing package(s) with command $1 ..
apt_ok=.. install complete
apt_failed=.. install failed!
+apt_reholdfailed=.. failed to restore the hold on $1 : $2
apt_form=Upgrade All Packages
apt_header=APT package upgrade options
apt_update=Resynchronize package list (update)
diff --git a/t/software-apt.t b/t/software-apt.t
index 1d91f976a..3e05ec256 100644
--- a/t/software-apt.t
+++ b/t/software-apt.t
@@ -8,6 +8,7 @@ use File::Spec;
use Cwd qw(abs_path);
our %config;
+our $apt_get_command;
my $root = abs_path(File::Spec->catdir(dirname(__FILE__), '..'));
chdir($root) or die "chdir($root): $!";
@@ -39,11 +40,21 @@ is($ops[0]->{'name'}, 'libtinfo6',
no warnings qw(once redefine);
my $apt_output = "Setting up libtinfo6:amd64 (6.3-2ubuntu0.2) ...\n";
my $yes_input = "";
+my $executed_command = "";
+my @reheld;
local *additional_log = sub { };
local *backquote_logged = sub { return ""; };
local *clean_language = sub { };
local *html_escape = sub { return $_[0]; };
local *reset_environment = sub { };
+local *list_update_system_holds = sub {
+ return ('libtinfo6:amd64', 'held-dependency:i386');
+ };
+local *update_system_hold = sub {
+ my ($packages, $hold) = @_;
+ @reheld = @$packages if ($hold);
+ return undef;
+ };
local *text = sub { return $_[0]; };
local *transname = sub { return "/tmp/software-apt-test-yes"; };
local *open_tempfile = sub {
@@ -64,19 +75,116 @@ local *close_tempfile = sub {
close(ref($fh) ? $fh : \*{$fh});
};
local *open_execute_command = sub {
- my ($fh) = @_;
+ my ($fh, $command) = @_;
+ $executed_command = $command;
no strict 'refs';
open(ref($fh) ? $fh : \*{$fh}, "<", \$apt_output)
or die "open simulated apt output: $!";
};
local $config{'package_system'} = 'debian';
+local $apt_get_command = 'aptitude';
my $printed = "";
open(my $stdout, ">", \$printed) or die "open captured stdout: $!";
local *STDOUT = $stdout;
-my @installed = update_system_install('libtinfo6', undef, 1);
+my @installed = update_system_install(
+ 'libtinfo6', undef, 1, '--allow-change-held-packages');
is_deeply(\@installed, [ 'libtinfo6' ],
'normalizes package names returned by apt install output');
+like($executed_command, qr/apt-get -y --allow-change-held-packages install/,
+ 'uses apt-get for the held-package override even in aptitude mode');
+is_deeply(\@reheld, [ 'libtinfo6:amd64', 'held-dependency:i386' ],
+ 'restores all exact holds after explicitly updating a held package');
+
+$executed_command = "";
+@reheld = ( );
+update_system_install('libtinfo6', undef, 1);
+like($executed_command, qr/^aptitude -y install/,
+ 'continues using configured aptitude mode for regular installs');
+is_deeply(\@reheld, [ ], 'does not reapply holds after a regular install');
+}
+
+{
+no warnings qw(once redefine);
+local *clean_language = sub { };
+local *reset_environment = sub { };
+local *has_command = sub {
+ return $_[0] eq 'aptitude' || $_[0] eq 'apt-mark';
+ };
+local *open_execute_command = sub {
+ my ($fh, $command) = @_;
+ my $output = $command =~ /^dpkg / ?
+ "alpha hold\ndelta:amd64 hold\n" :
+ $command =~ /^aptitude / ?
+ ".h beta 1.0 installed\n" :
+ $command =~ /^apt-mark / ?
+ "gamma\ndelta:amd64\n" : "";
+ no strict 'refs';
+ open(ref($fh) ? $fh : \*{$fh}, '<', \$output)
+ or die "open simulated holds: $!";
+ };
+
+is_deeply([ list_update_system_holds() ],
+ [ qw(alpha beta delta:amd64 gamma) ],
+ 'combines held packages without discarding architecture qualifiers');
+}
+
+{
+no warnings qw(once redefine);
+my $apt_output =
+ "Listing...\n".
+ "held-pkg/stable 2.0 amd64 [upgradable from: 1.0]\n".
+ "regular-pkg/stable 3.0 amd64 [upgradable from: 2.0]\n";
+local *clean_language = sub { };
+local *reset_environment = sub { };
+local *execute_command = sub { return 0; };
+local *list_update_system_holds = sub { return ('held-pkg'); };
+local *has_command = sub { return $_[0] eq 'apt'; };
+local *open_execute_command = sub {
+ my ($fh, $command) = @_;
+ my $output = $command =~ /^apt list / ? $apt_output : "";
+ no strict 'refs';
+ open(ref($fh) ? $fh : \*{$fh}, '<', \$output)
+ or die "open simulated updates: $!";
+ };
+
+my @normal = update_system_updates(0);
+is_deeply([ map { $_->{'name'} } @normal ], [ 'regular-pkg' ],
+ 'default APT updates still exclude held packages');
+my @with_holds = update_system_updates(1);
+is_deeply([ map { $_->{'name'} } @with_holds ],
+ [ 'held-pkg', 'regular-pkg' ],
+ 'held-update query includes regular and held packages');
+ok($with_holds[0]->{'held'}, 'marks the held update');
+ok(!$with_holds[1]->{'held'}, 'does not mark a regular update as held');
+}
+
+{
+no warnings qw(once redefine);
+my $command;
+local *has_command = sub { return '/usr/bin/apt-mark'; };
+local *unique = sub {
+ my %seen;
+ return grep { !$seen{$_}++ } @_;
+ };
+local *trim = sub {
+ my ($value) = @_;
+ $value =~ s/^\s+|\s+$//g;
+ return $value;
+ };
+local *clean_language = sub { };
+local *reset_environment = sub { };
+local *execute_command_logged = sub {
+ my ($cmd, undef, $stdout) = @_;
+ $command = $cmd;
+ $$stdout = "";
+ return 0;
+ };
+
+is(update_system_hold([ 'webmin-virtual-server', 'webmin-virtual-server' ], 1),
+ undef, 'holds packages successfully');
+is($command, 'apt-mark hold webmin\-virtual\-server',
+ 'builds a quoted apt-mark hold command without duplicates');
}
done_testing();
diff --git a/t/test-lib.pl b/t/test-lib.pl
new file mode 100644
index 000000000..d3611e8ee
--- /dev/null
+++ b/t/test-lib.pl
@@ -0,0 +1,28 @@
+# Common helpers for Webmin tests.
+
+use strict;
+use warnings;
+
+# write_text(file, contents)
+# Writes a text fixture and fails the test immediately on an I/O error
+sub write_text
+{
+my ($file, $text) = @_;
+open(my $fh, ">", $file) or die "open $file: $!";
+print $fh $text;
+close($fh) or die "close $file: $!";
+}
+
+# read_text(file)
+# Returns the complete contents of a text fixture
+sub read_text
+{
+my ($file) = @_;
+open(my $fh, "<", $file) or die "open $file: $!";
+local $/;
+my $text = <$fh>;
+close($fh) or die "close $file: $!";
+return $text;
+}
+
+1;
diff --git a/t/web-lib-funcs-default-cert.t b/t/web-lib-funcs-default-cert.t
new file mode 100644
index 000000000..12aaed5a9
--- /dev/null
+++ b/t/web-lib-funcs-default-cert.t
@@ -0,0 +1,42 @@
+#!/usr/bin/perl
+# Regression tests for detection of certificates bundled by older releases.
+
+use strict;
+use warnings;
+use Test::More;
+use File::Basename qw(dirname);
+use File::Spec;
+use File::Temp qw(tempdir);
+
+my $script = File::Spec->rel2abs(
+ File::Spec->catfile(dirname(__FILE__), '..', 'web-lib-funcs.pl'));
+require $script;
+
+my $cert = File::Spec->catfile(tempdir(CLEANUP => 1), 'miniserv.pem');
+open(my $fh, '>', $cert) or die "open($cert): $!";
+print {$fh} "legacy certificate fixture\n";
+close($fh) or die "close($cert): $!";
+
+no warnings qw(redefine once);
+my $digest = 'fcc4fc2ba3c00ede7008725668ff3af9';
+local *main::execute_command = sub {
+ my (undef, undef, $output) = @_;
+ ${$output} = "$digest $cert\n";
+ $? = 0;
+ };
+
+local $ENV{'HTTPS'} = 'OFF';
+ok(main::miniserv_using_default_cert($cert),
+ 'a formerly bundled certificate remains detectable without a bundled file');
+
+$digest = '0123456789abcdef0123456789abcdef';
+ok(!main::miniserv_using_default_cert($cert),
+ 'a machine-generated certificate is not flagged');
+
+local $ENV{'MINISERV_KEYFILE'} = $cert;
+local $ENV{'HTTPS'} = 'ON';
+$digest = '2bb1926297df3d0429be3a4cd00b43ce';
+ok(main::miniserv_using_default_cert(),
+ 'HTTPS login detects the other legacy certificate');
+
+done_testing();
diff --git a/usermin/edit_ssl.cgi b/usermin/edit_ssl.cgi
index dbcb73df7..70212e50b 100755
--- a/usermin/edit_ssl.cgi
+++ b/usermin/edit_ssl.cgi
@@ -125,9 +125,7 @@ print &ui_tabs_end_tab();
# SSL key generation form
print &ui_tabs_start_tab("mode", "create");
print "$text{'ssl_newkey'}\n";
-my $curkey = &read_file_contents($miniserv{'keyfile'});
-my $origkey = &read_file_contents("$root_directory/miniserv.pem");
-if ($curkey eq $origkey) {
+if (&miniserv_using_default_cert($miniserv{'keyfile'})) {
# System is using the original (insecure) Webmin key!
print "$text{'ssl_hole'}
\n";
}
diff --git a/vendor_perl/Text/ASCIITable.pm b/vendor_perl/Text/ASCIITable.pm
new file mode 100644
index 000000000..2fc85a11a
--- /dev/null
+++ b/vendor_perl/Text/ASCIITable.pm
@@ -0,0 +1,1092 @@
+package Text::ASCIITable;
+# by Håkon Nessjøen
+
+@ISA=qw(Exporter);
+@EXPORT = qw();
+@EXPORT_OK = qw();
+$VERSION = '0.22';
+use Exporter;
+use strict;
+use Carp;
+use Text::ASCIITable::Wrap qw{ wrap };
+use overload '@{}' => 'addrow_overload', '""' => 'drawit';
+use utf8;
+use List::Util qw(reduce max sum);
+
+=encoding utf8
+
+=head1 NAME
+
+Text::ASCIITable - Create a nice formatted table using ASCII characters.
+
+=head1 SHORT DESCRIPTION
+
+Pretty nifty if you want to output dynamic text to your console or other
+fixed-size-font displays, and at the same time it will display it in a
+nice human-readable, or "cool" way.
+
+=head1 SYNOPSIS
+
+ use Text::ASCIITable;
+ $t = Text::ASCIITable->new({ headingText => 'Basket' });
+
+ $t->setCols('Id','Name','Price');
+ $t->addRow(1,'Dummy product 1',24.4);
+ $t->addRow(2,'Dummy product 2',21.2);
+ $t->addRow(3,'Dummy product 3',12.3);
+ $t->addRowLine();
+ $t->addRow('','Total',57.9);
+ print $t;
+
+ # Result:
+ .------------------------------.
+ | Basket |
+ +----+-----------------+-------+
+ | Id | Name | Price |
+ +----+-----------------+-------+
+ | 1 | Dummy product 1 | 24.4 |
+ | 2 | Dummy product 2 | 21.2 |
+ | 3 | Dummy product 3 | 12.3 |
+ +----+-----------------+-------+
+ | | Total | 57.9 |
+ '----+-----------------+-------'
+
+=head1 FUNCTIONS
+
+=head2 new(options)
+
+Initialize a new table. You can specify output-options. For more options, check out the usage for setOptions()
+
+ Usage:
+ $t = Text::ASCIITable->new();
+
+ Or with options:
+ $t = Text::ASCIITable->new({ hide_Lastline => 1, reportErrors => 0});
+
+=cut
+
+sub new {
+ my $self = {
+ tbl_cols => [],
+ tbl_rows => [],
+ tbl_cuts => [],
+ tbl_align => {},
+ tbl_lines => {},
+
+ des_top => ['.','.','-','-'],
+ des_middle => ['+','+','-','+'],
+ des_bottom => ["'","'",'-','+'],
+ des_rowline => ['+','+','-','+'],
+
+ des_toprow => ['|','|','|'],
+ des_middlerow => ['|','|','|'],
+
+ cache_width => {},
+
+ options => $_[1] || { }
+ };
+
+ $self->{options}{reportErrors} = defined($self->{options}{reportErrors}) ? $self->{options}{reportErrors} : 1; # default setting
+ $self->{options}{alignHeadRow} = $self->{options}{alignHeadRow} || 'auto'; # default setting
+ $self->{options}{undef_as} = $self->{options}{undef_as} || ''; # default setting
+ $self->{options}{chaining} = $self->{options}{chaining} || 0; # default setting
+
+ bless $self;
+
+ return $self;
+}
+
+=head2 setCols(@cols)
+
+Define the columns for the table(compare with in HTML). For example C.
+B that you cannot add Cols after you have added a row. Multiline columnnames are allowed.
+
+=cut
+
+sub setCols {
+ my $self = shift;
+ do { $self->reperror("setCols needs an array"); return $self->{options}{chaining} ? $self : 1; } unless defined($_[0]);
+ @_ = @{$_[0]} if (ref($_[0]) eq 'ARRAY');
+ do { $self->reperror("setCols needs an array"); return $self->{options}{chaining} ? $self : 1; } unless scalar(@_) != 0;
+ do { $self->reperror("Cannot edit cols at this state"); return $self->{options}{chaining} ? $self : 1; } unless scalar(@{$self->{tbl_rows}}) == 0;
+
+ my @lines = map { [ split(/\n/,$_) ] } @_;
+
+ # Multiline support
+ my $max=0;
+ my @out;
+ grep {$max = scalar(@{$_}) if scalar(@{$_}) > $max} @lines;
+ foreach my $num (0..($max-1)) {
+ my @tmp = map defined $$_[$num] && $$_[$num], @lines;
+ push @out, \@tmp;
+ }
+
+ @{$self->{tbl_cols}} = @_;
+ @{$self->{tbl_multilinecols}} = @out if ($max);
+ $self->{tbl_colsismultiline} = $max;
+
+ return $self->{options}{chaining} ? $self : undef;
+}
+
+=head2 addRow(@collist)
+
+Adds one row to the table. This must be an array of strings. If you defined 3 columns. This array must
+have 3 items in it. And so on. Should be self explanatory. The strings can contain newlines.
+
+ Note: It does not require argument to be an array, thus;
+ $t->addRow(['id','name']) and $t->addRow('id','name') does the same thing.
+
+This module is also overloaded to accept push. To construct a table with the use of overloading you might do the following:
+
+ $t = Text::ASCIITable->new();
+ $t->setCols('one','two','three','four');
+ push @$t, ( "one\ntwo" ) x 4; # Replaces $t->addrow();
+ print $t; # Replaces print $t->draw();
+
+ Which would construct:
+ .-----+-----+-------+------.
+ | one | two | three | four |
+ |=----+-----+-------+-----=|
+ | one | one | one | one | # Note that theese two lines
+ | two | two | two | two | # with text are one singe row.
+ '-----+-----+-------+------'
+
+There is also possible to give this function an array of arrayrefs and hence support the output from
+DBI::selectall_arrayref($sql) without changes.
+
+ Example of multiple-rows pushing:
+ $t->addRow([
+ [ 1, 2, 3 ],
+ [ 4, 5, 6 ],
+ [ 7, 8, 9 ],
+ ]);
+
+=cut
+
+sub addRow {
+ my $self = shift;
+ @_ = @{$_[0]} if (ref($_[0]) eq 'ARRAY');
+ do { $self->reperror("Received too many columns"); return $self->{options}{chaining} ? $self : 1; } if scalar(@_) > scalar(@{$self->{tbl_cols}}) && ref($_[0]) ne 'ARRAY';
+ my (@in,@out,@lines,$max);
+
+ if (scalar(@_) > 0 && ref($_[0]) eq 'ARRAY') {
+ foreach my $row (@_) {
+ $self->addRow($row);
+ }
+ return $self->{options}{chaining} ? $self : undef;
+ }
+
+ # Fill out row, if columns are missing (requested) Mar 21 2004 by a anonymous person
+ while (scalar(@_) < scalar(@{$self->{tbl_cols}})) {
+ push @_, ' ';
+ }
+
+ # Word wrapping & undef-replacing
+ foreach my $c (0..$#_) {
+ $_[$c] = $self->{options}{undef_as} unless defined $_[$c]; # requested by david@landgren.net/dland@cpan.org - https://rt.cpan.org/NoAuth/Bugs.html?Dist=Text-ASCIITable
+ my $colname = $self->{tbl_cols}[$c];
+ my $width = $self->{tbl_width}{$colname} || 0;
+ if ($width > 0) {
+ $in[$c] = wrap($_[$c],$width);
+ } else {
+ $in[$c] = $_[$c];
+ }
+ }
+
+ # Multiline support:
+ @lines = map { [ split /\n/ ] } @in;
+ $max = max map {scalar @$_} @lines;
+ foreach my $num (0..($max-1)) {
+ my @tmp = map { defined(@{$_}[$num]) && $self->count(@{$_}[$num]) ? @{$_}[$num] : '' } @lines;
+ push @out, [ @tmp ];
+ }
+
+ # Add row(s)
+ push @{$self->{tbl_rows}}, @out;
+
+ # Rowlinesupport:
+ $self->{tbl_rowline}{scalar(@{$self->{tbl_rows}})} = 1;
+
+ return $self->{options}{chaining} ? $self : undef;
+}
+
+sub addrow_overload {
+ my $self = shift;
+ my @arr;
+ tie @arr, $self;
+ return \@arr;
+}
+
+=head2 addRowLine([$row])
+
+Will add a line after the current row. As an argument, you may specify after which row you want a line (first row is 1)
+or an array of row numbers. (HINT: If you want a line after every row, read about the drawRowLine option in setOptions())
+
+Example without arguments:
+ $t->addRow('one','two','three');
+ $t->addRowLine();
+ $t->addRow('one','two','three');
+
+Example with argument:
+ $t->addRow('one','two','three');
+ $t->addRow('one','two','three');
+ $t->addRow('one','two','three');
+ $t->addRow('one','two','three');
+ $t->addRowLine(1); # or multiple: $t->addRowLine([2,3]);
+
+=cut
+
+sub addRowLine {
+ my ($self,$row) = @_;
+ do { $self->reperror("rows not added yet"); return $self->{options}{chaining} ? $self : 1; } unless scalar(@{$self->{tbl_rows}}) > 0;
+
+ if (defined($row) && ref($row) eq 'ARRAY') {
+ foreach (@$row) {
+ $_=int($_);
+ $self->{tbl_lines}{$_} = 1;
+ }
+ }
+ elsif (defined($row)) {
+ $row = int($row);
+ do { $self->reperror("$row is higher than number of rows added"); return $self->{options}{chaining} ? $self : 1; } if ($row < 0 || $row > scalar(@{$self->{tbl_rows}}));
+ $self->{tbl_lines}{$row} = 1;
+ } else {
+ $self->{tbl_lines}{scalar(@{$self->{tbl_rows}})} = 1;
+ }
+
+ return $self->{options}{chaining} ? $self : undef;
+}
+
+# backwardscompatibility, deprecated
+sub alignColRight {
+ my ($self,$col) = @_;
+ do { $self->reperror("alignColRight is missing parameter(s)"); return $self->{options}{chaining} ? $self : 1; } unless defined($col);
+ return $self->alignCol($col,'right');
+}
+
+=head2 alignCol($col,$direction) or alignCol({col1 => direction1, col2 => direction2, ... })
+
+Given a columnname, it aligns all data to the given direction in the table. This looks nice on numerical displays
+in a column. The column names in the table will be unaffected by the alignment. Possible directions is: left,
+center, right, justify, auto or your own subroutine. (Hint: Using auto(default), aligns numbers right and text left)
+
+=cut
+
+sub alignCol {
+ my ($self,$col,$direction) = @_;
+ do { $self->reperror("alignCol is missing parameter(s)"); return $self->{options}{chaining} ? $self : 1; } unless defined($col) && defined($direction) || (defined($col) && ref($col) eq 'HASH');
+ do { $self->reperror("Could not find '$col' in columnlist"); return $self->{options}{chaining} ? $self : 1; } unless defined(&find($col,$self->{tbl_cols})) || (defined($col) && ref($col) eq 'HASH');
+
+ if (ref($col) eq 'HASH') {
+ for (keys %{$col}) {
+ do { $self->reperror("Could not find '$_' in columnlist"); return $self->{options}{chaining} ? $self : 1; } unless defined(&find($_,$self->{tbl_cols}));
+ $self->{tbl_align}{$_} = $col->{$_};
+ }
+ } else {
+ $self->{tbl_align}{$col} = $direction;
+ }
+ return $self->{options}{chaining} ? $self : undef;
+}
+
+=head2 alignColName($col,$direction)
+
+Given a columnname, it aligns the columnname in the row explaining columnnames, to the given direction. (auto,left,right,center,justify
+or a subroutine) (Hint: Overrides the 'alignHeadRow' option for the specified column.)
+
+=cut
+
+sub alignColName {
+ my ($self,$col,$direction) = @_;
+ do { $self->reperror("alignColName is missing parameter(s)"); return $self->{options}{chaining} ? $self : 1; } unless defined($col) && defined($direction);
+ do { $self->reperror("Could not find '$col' in columnlist"); return $self->{options}{chaining} ? $self : 1; } unless defined(&find($col,$self->{tbl_cols}));
+
+ $self->{tbl_colalign}{$col} = $direction;
+ return $self->{options}{chaining} ? $self : undef;
+}
+
+=head2 setColWidth($col,$width,$strict)
+
+Wordwrapping/strict size. Set a max-width(in chars) for a column.
+If last parameter is 1, the column will be set to the specified width, even if no text is that long.
+
+ Usage:
+ $t->setColWidth('Description',30);
+
+=cut
+
+sub setColWidth {
+ my ($self,$col,$width,$strict) = @_;
+ do { $self->reperror("setColWidth is missing parameter(s)"); return $self->{options}{chaining} ? $self : 1; } unless defined($col) && defined($width);
+ do { $self->reperror("Could not find '$col' in columnlist"); return $self->{options}{chaining} ? $self : 1; } unless defined(&find($col,$self->{tbl_cols}));
+ do { $self->reperror("Cannot change width at this state"); return $self->{options}{chaining} ? $self : 1; } unless scalar(@{$self->{tbl_rows}}) == 0;
+
+ $self->{tbl_width}{$col} = int($width);
+ $self->{tbl_width_strict}{$col} = $strict ? 1 : 0;
+
+ return $self->{options}{chaining} ? $self : undef;
+}
+
+sub headingWidth {
+ my $self = shift;
+ my $title = $self->{options}{headingText};
+ return max map {$self->count($_)} split /\r?\n/, $self->{options}{headingText};
+}
+
+# drawing etc, below
+sub getColWidth {
+ my ($self,$colname) = @_;
+ $self->reperror("Could not find '$colname' in columnlist") unless defined find($colname, $self->{tbl_cols});
+
+ return $self->{cache_width}{$colname};
+}
+
+# Width-calculating functions rewritten for more speed by Alexey Sheynuk
+# Thanks :)
+sub calculateColWidths {
+ my ($self) = @_;
+ $self->{cache_width} = undef;
+ my $cols = $self->{tbl_cols};
+ foreach my $c (0..$#{$cols}) {
+ my $colname = $cols->[$c];
+ if (defined($self->{tbl_width_strict}{$colname}) && ($self->{tbl_width_strict}{$colname} == 1) && int($self->{tbl_width}{$colname}) > 0) {
+ # maxsize plus the spaces on each side
+ $self->{cache_width}{$colname} = $self->{tbl_width}{$colname} + 2;
+ } else {
+ my $colwidth = max((map {$self->count($_)} split(/\n/,$colname)), (map {$self->count($_->[$c])} @{$self->{tbl_rows}}));
+ $self->{cache_width}{$colname} = $colwidth + 2;
+ }
+ }
+ $self->addExtraHeadingWidth;
+}
+
+sub addExtraHeadingWidth {
+ my ($self) = @_;
+ return unless defined $self->{options}{headingText};
+ my $tablewidth = -3 + sum map {$_ + 1} values %{$self->{cache_width}};
+ my $headingwidth = $self->headingWidth();
+ if ($headingwidth > $tablewidth) {
+ my $extra = $headingwidth - $tablewidth;
+ my $cols = scalar(@{$self->{tbl_cols}});
+ my $extra_for_all = int($extra/$cols);
+ my $extrasome = $extra % $cols;
+ my $antall = 0;
+ foreach my $col (@{$self->{tbl_cols}}) {
+ my $extrawidth = $extra_for_all;
+ if ($antall < $extrasome) {
+ $antall++;
+ $extrawidth++;
+ }
+ $self->{cache_width}{$col} += $extrawidth;
+ }
+ }
+}
+
+=head2 getTableWidth()
+
+If you need to know how wide your table will be before you draw it. Use this function.
+
+=cut
+
+sub getTableWidth {
+ my $self = shift;
+ my $totalsize = 1;
+ if (!defined($self->{cache_TableWidth})) {
+ $self->calculateColWidths;
+ grep {$totalsize += $self->getColWidth($_,undef) + 1} @{$self->{tbl_cols}};
+ $self->{cache_TableWidth} = $totalsize;
+ }
+ return $self->{cache_TableWidth};
+}
+
+sub drawLine {
+ my ($self,$start,$stop,$line,$delim) = @_;
+ do { $self->reperror("Missing reqired parameters"); return 1; } unless defined($stop);
+ $line = defined($line) ? $line : '-';
+ $delim = defined($delim) ? $delim : '+';
+
+ my $contents;
+
+ $contents = $start;
+
+ for (my $i=0;$i < scalar(@{$self->{tbl_cols}});$i++) {
+ my $offset = 0;
+ $offset = $self->count($start) - 1 if ($i == 0);
+ $offset = $self->count($stop) - 1 if ($i == scalar(@{$self->{tbl_cols}}) -1);
+
+ $contents .= $line x ($self->getColWidth(@{$self->{tbl_cols}}[$i]) - $offset);
+
+ $contents .= $delim if ($i != scalar(@{$self->{tbl_cols}}) - 1);
+ }
+ return $contents.$stop."\n";
+}
+
+=head2 setOptions(name,value) or setOptions({ option1 => value1, option2 => value2, ... })
+
+Use this to set options like: hide_FirstLine,reportErrors, etc.
+
+ Usage:
+ $t->setOptions('hide_HeadLine',1);
+
+ Or set more than one option on the fly:
+ $t->setOptions({ hide_HeadLine => 1, hide_HeadRow => 1 });
+
+B
+
+=over 4
+
+=item hide_HeadRow
+
+Hides output of the columnlisting. Together with hide_HeadLine, this makes a table only show the rows. (However, even though
+the column-names will not be shown, they will affect the output if they have for example ridiculoustly long
+names, and the rows contains small amount of info. You would end up with a lot of whitespace)
+
+=item reportErrors
+
+Set to 0 to disable error reporting. Though if a function encounters an error, it will still return the value 1, to
+tell you that things didn't go exactly as they should.
+
+=item allowHTML
+
+If you are going to use Text::ASCIITable to be shown on HTML pages, you should set this option to 1 when you are going
+to use HTML tags to for example color the text inside the rows, and you want the browser to handle the table correct.
+
+=item allowANSI
+
+If you use ANSI codes like [1mHi this is bold[m or similar. This option will make the table to be
+displayed correct when showed in a ANSI compliant terminal. Set this to 1 to enable. There is an example of ANSI support
+in this package, named ansi-example.pl.
+
+=item alignHeadRow
+
+Set wich direction the Column-names(in the headrow) are supposed to point. Must be left, right, center, justify, auto or a user-defined subroutine.
+
+=item hide_FirstLine, hide_HeadLine, hide_LastLine
+
+Speaks for it self?
+
+=item drawRowLine
+
+Set this to 1 to print a line between each row. You can also define the outputstyle
+of this line in the draw() function.
+
+=item headingText
+
+Add a heading above the columnnames/rows wich uses the whole width of the table to output
+a heading/title to the table. The heading-part of the table is automatically shown when
+the headingText option contains text. B If this text is so long that it makes the
+table wider, it will not hesitate to change width of columns that have "strict width".
+
+It supports multiline, and with Text::ASCIITable::Wrap you may wrap your text before entering
+it, to prevent the title from expanding the table. Internal wrapping-support for headingText
+might come in the future.
+
+=item headingAlign
+
+Align the heading(as mentioned above) to left, right, center, auto or using a subroutine.
+
+=item headingStartChar, headingStopChar
+
+Choose the startingchar and endingchar of the row where the title is. The default is
+'|' on both. If you didn't understand this, try reading about the draw() function.
+
+=item cb_count
+
+Set the callback subroutine to use when counting characters inside the table. This is useful
+to make support for having characters or codes inside the table that are not shown on the
+screen to the user, so the table should not count these characters. This could be for example
+HTML tags, or ANSI codes. Though those two examples are alredy supported internally with the
+allowHTML and allowANSI, options. This option expects a CODE reference. (\&callback_function)
+
+=item undef_as
+
+Sets the replacing string that replaces an undef value sent to addRow() (or even the overloaded
+push version of addRow()). The default value is an empty string ''. An example of use would be
+to set it to '(undef)', to show that the input really was undefined.
+
+
+=item chaining
+
+Set this to 1 to support chainging of methods. The default is 0, where the methods return 1 if
+they come upon an error as mentioned in the reportErrors option description.
+
+ Usage example:
+ print Text::ASCIITable->new({ chaining => 1 })
+ ->setCols('One','Two','Three')
+ ->addRow([
+ [ 1, 2, 3 ],
+ [ 4, 5, 6 ],
+ [ 7, 8, 9 ],
+ ])
+ ->draw();
+
+Note that ->draw() can be omitted, since Text::ASCIITable is overloaded to print the table by default.
+
+=back
+
+=cut
+
+sub setOptions {
+ my ($self,$name,$value) = @_;
+ my $old;
+ if (ref($name) eq 'HASH') {
+ for (keys %{$name}) {
+ $self->{options}{$_} = $name->{$_};
+ }
+ } else {
+ $old = $self->{options}{$name} || undef;
+ $self->{options}{$name} = $value;
+ }
+ return $old;
+}
+
+# Thanks to Khemir Nadim ibn Hamouda
+# Original code from Spreadsheet::Perl::ASCIITable
+sub prepareParts {
+ my ($self)=@_;
+ my $running_width = 1 ;
+
+ $self->{tbl_cuts} = [];
+ foreach my $column (@{$self->{tbl_cols}}) {
+ my $column_width = $self->getColWidth($column,undef);
+ if ($running_width + $column_width >= $self->{options}{outputWidth}) {
+ push @{$self->{tbl_cuts}}, $running_width;
+ $running_width = $column_width + 2;
+ } else {
+ $running_width += $column_width + 1 ;
+ }
+ }
+ push @{$self->{tbl_cuts}}, $self->getTableWidth() ;
+}
+
+sub pageCount {
+ my $self = shift;
+ do { $self->reperror("Table has no max output-width set"); return 1; } unless defined($self->{options}{outputWidth});
+
+ return 1 if ($self->getTableWidth() < $self->{options}{outputWidth});
+ $self->prepareParts() if (scalar(@{$self->{tbl_cuts}}) < 1);
+
+ return scalar(@{$self->{tbl_cuts}});
+}
+
+sub drawSingleColumnRow {
+ my ($self,$text,$start,$stop,$align,$opt) = @_;
+ do { $self->reperror("Missing reqired parameters"); return 1; } unless defined($text);
+
+ my $contents = $start;
+ my $width = 0;
+ my $tablewidth = $self->getTableWidth();
+ # ok this is a bad shortcut, but 'till i get up with a better one, I use this.
+ if (($tablewidth - 4) < $self->count($text) && $opt eq 'title') {
+ $width = $self->count($text);
+ }
+ else {
+ $width = $tablewidth - 4;
+ }
+ $contents .= ' '.$self->align(
+ $text,
+ $align || 'left',
+ $width,
+ ($self->{options}{allowHTML} || $self->{options}{allowANSI} || $self->{options}{cb_count} ?0:1)
+ ).' ';
+ return $contents.$stop."\n";
+}
+
+sub drawRow {
+ my ($self,$row,$isheader,$start,$stop,$delim) = @_;
+ do { $self->reperror("Missing reqired parameters"); return 1; } unless defined($row);
+ $isheader = $isheader || 0;
+ $delim = $delim || '|';
+
+ my $contents = $start;
+ for (my $i=0;$igetColWidth(@{$self->{tbl_cols}}[$i]);
+ my $text = @{$row}[$i];
+
+ if ($isheader != 1 && defined($self->{tbl_align}{@{$self->{tbl_cols}}[$i]})) {
+ $contents .= ' '.$self->align(
+ $text,
+ $self->{tbl_align}{@{$self->{tbl_cols}}[$i]} || 'auto',
+ $colwidth-2,
+ ($self->{options}{allowHTML} || $self->{options}{allowANSI} || $self->{options}{cb_count}?0:1)
+ ).' ';
+ } elsif ($isheader == 1) {
+
+ $contents .= ' '.$self->align(
+ $text,
+ $self->{tbl_colalign}{@{$self->{tbl_cols}}[$i]} || $self->{options}{alignHeadRow} || 'left',
+ $colwidth-2,
+ ($self->{options}{allowHTML} || $self->{options}{allowANSI} || $self->{options}{cb_count}?0:1)
+ ).' ';
+ } else {
+ $contents .= ' '.$self->align(
+ $text,
+ 'auto',
+ $colwidth-2,
+ ($self->{options}{allowHTML} || $self->{options}{allowANSI} || $self->{options}{cb_count}?0:1)
+ ).' ';
+ }
+ $contents .= $delim if ($i != scalar(@{$row}) - 1);
+ }
+ return $contents.$stop."\n";
+}
+
+=head2 draw([@topdesign,@toprow,@middle,@middlerow,@bottom,@rowline])
+
+All the arrays containing the layout is optional. If you want to make your own "design" to the table, you
+can do that by giving this method these arrays containing information about which characters to use
+where.
+
+B
+
+The draw method takes C<6> arrays of strings to define the layout. The first, third, fifth and sixth is B
+layout and the second and fourth is B layout. The C parameter is repeated for each row in the table.
+The sixth parameter is only used if drawRowLine is enabled.
+
+ $t->draw(,,,,,[])
+
+=over 4
+
+=item LINE
+
+Takes an array of C<4> strings. For example C<['|','|','-','+']>
+
+=over 4
+
+=item *
+
+LEFT - Defines the left chars. May be more than one char.
+
+=item *
+
+RIGHT - Defines the right chars. May be more then one char.
+
+=item *
+
+LINE - Defines the char used for the line. B.
+
+=item *
+
+DELIMETER - Defines the char used for the delimeters. B.
+
+=back
+
+=item ROW
+
+Takes an array of C<3> strings. You should not give more than one char to any of these parameters,
+if you do.. it will probably destroy the output.. Unless you do it with the knowledge
+of how it will end up. An example: C<['|','|','+']>
+
+=over 4
+
+=item *
+
+LEFT - Define the char used for the left side of the table.
+
+=item *
+
+RIGHT - Define the char used for the right side of the table.
+
+=item *
+
+DELIMETER - Defines the char used for the delimeters.
+
+=back
+
+=back
+
+Examples:
+
+The easiest way:
+
+ print $t;
+
+Explanatory example:
+
+ print $t->draw( ['L','R','l','D'], # LllllllDllllllR
+ ['L','R','D'], # L info D info R
+ ['L','R','l','D'], # LllllllDllllllR
+ ['L','R','D'], # L info D info R
+ ['L','R','l','D'] # LllllllDllllllR
+ );
+
+Nice example:
+
+ print $t->draw( ['.','.','-','-'], # .-------------.
+ ['|','|','|'], # | info | info |
+ ['|','|','-','-'], # |-------------|
+ ['|','|','|'], # | info | info |
+ [' \\','/ ','_','|'] # \_____|_____/
+ );
+
+Nice example2:
+
+ print $t->draw( ['.=','=.','-','-'], # .=-----------=.
+ ['|','|','|'], # | info | info |
+ ['|=','=|','-','+'], # |=-----+-----=|
+ ['|','|','|'], # | info | info |
+ ["'=","='",'-','-'] # '=-----------='
+ );
+
+With Options:
+
+ $t->setOptions('drawRowLine',1);
+ print $t->draw( ['.=','=.','-','-'], # .=-----------=.
+ ['|','|','|'], # | info | info |
+ ['|-','-|','=','='], # |-===========-|
+ ['|','|','|'], # | info | info |
+ ["'=","='",'-','-'], # '=-----------='
+ ['|=','=|','-','+'] # rowseperator
+ );
+ Which makes this output:
+ .=-----------=.
+ | col1 | col2 |
+ |-===========-|
+ | info | info |
+ |=-----+-----=| <-- rowseperator between each row
+ | info | info |
+ '=-----------='
+
+A tips is to enable allowANSI, and use the extra charset in your terminal to create
+a beautiful table. But don't expect to get good results if you use ANSI-formatted table
+with $t->drawPage.
+
+B
+
+If you want to format your text more throughoutly than "auto", or think you
+have a better way of aligning text; you can make your own subroutine.
+
+ Here's a exampleroutine that aligns the text to the right.
+
+ sub myownalign_cb {
+ my ($text,$length,$count,$strict) = @_;
+ $text = (" " x ($length - $count)) . $text;
+ return substr($text,0,$length) if ($strict);
+ return $text;
+ }
+
+ $t->alignCol('Info',\&myownalign_cb);
+
+B
+
+This is a feature to use if you are not happy with the internal allowHTML or allowANSI
+support. Given is an example of how you make a count-callback that makes ASCIITable support
+ANSI codes inside the table. (would make the same result as setting allowANSI to 1)
+
+ $t->setOptions('cb_count',\&myallowansi_cb);
+ sub myallowansi_cb {
+ $_=shift;
+ s/\33\[(\d+(;\d+)?)?[musfwhojBCDHRJK]//g;
+ return length($_);
+ }
+
+=cut
+
+sub drawit {scalar shift()->draw()}
+
+=head2 drawPage($page,@topdesign,@toprow,@middle,@middlerow,@bottom,@rowline)
+
+If you don't want your table to be wider than your screen you can use this
+with $t->setOptions('outputWidth',40) to set the max size of the output.
+
+Example:
+
+ $t->setOptions('outputWidth',80);
+ for my $page (1..$t->pageCount()) {
+ print $t->drawPage($page)."\n";
+ print "continued..\n\n";
+ }
+
+=cut
+
+sub drawPage {
+ my $self = shift;
+ my ($pagenum,$top,$toprow,$middle,$middlerow,$bottom,$rowline) = @_;
+ return $self->draw($top,$toprow,$middle,$middlerow,$bottom,$rowline,$pagenum);
+}
+
+# Thanks to Khemir Nadim ibn Hamouda for code and idea.
+sub getPart {
+ my ($self,$page,$text) = @_;
+ my $offset=0;
+
+ return $text unless $page > 0;
+ $text =~ s/\n$//;
+
+ $self->prepareParts() if (scalar(@{$self->{tbl_cuts}}) < 1);
+ $offset += (@{$self->{tbl_cuts}}[$_] - 1) for(0..$page-2);
+
+ return substr($text, $offset, @{$self->{tbl_cuts}}[$page-1]) . "\n" ;
+}
+
+sub draw {
+ my $self = shift;
+ my ($top,$toprow,$middle,$middlerow,$bottom,$rowline,$page) = @_;
+ my ($tstart,$tstop,$tline,$tdelim) = defined($top) ? @{$top} : @{$self->{des_top}};
+ my ($trstart,$trstop,$trdelim) = defined($toprow) ? @{$toprow} : @{$self->{des_toprow}};
+ my ($mstart,$mstop,$mline,$mdelim) = defined($middle) ? @{$middle} : @{$self->{des_middle}};
+ my ($mrstart,$mrstop,$mrdelim) = defined($middlerow) ? @{$middlerow} : @{$self->{des_middlerow}};
+ my ($bstart,$bstop,$bline,$bdelim) = defined($bottom) ? @{$bottom} : @{$self->{des_bottom}};
+ my ($rstart,$rstop,$rline,$rdelim) = defined($rowline) ? @{$rowline} : @{$self->{des_rowline}};
+ my $contents=""; $page = defined($page) ? $page : 0;
+
+ delete $self->{cache_TableWidth}; # Clear cache
+ $self->calculateColWidths;
+
+ $contents .= $self->getPart($page,$self->drawLine($tstart,$tstop,$tline,$tdelim)) unless $self->{options}{hide_FirstLine};
+ if (defined($self->{options}{headingText})) {
+ my $title = $self->{options}{headingText};
+ if ($title =~ m/\n/) { # Multiline title-support
+ my @lines = split(/\r?\n/,$title);
+ foreach my $line (@lines) {
+ $contents .= $self->getPart($page,$self->drawSingleColumnRow($line,$self->{options}{headingStartChar} || '|',$self->{options}{headingStopChar} || '|',$self->{options}{headingAlign} || 'center','title'));
+ }
+ } else {
+ $contents .= $self->getPart($page,$self->drawSingleColumnRow($self->{options}{headingText},$self->{options}{headingStartChar} || '|',$self->{options}{headingStopChar} || '|',$self->{options}{headingAlign} || 'center','title'));
+ }
+ $contents .= $self->getPart($page,$self->drawLine($mstart,$mstop,$mline,$mdelim)) unless $self->{options}{hide_HeadLine};
+ }
+
+ unless ($self->{options}{hide_HeadRow}) {
+ # multiline-column-support
+ foreach my $row (@{$self->{tbl_multilinecols}}) {
+ $contents .= $self->getPart($page,$self->drawRow($row,1,$trstart,$trstop,$trdelim));
+ }
+ }
+ $contents .= $self->getPart($page,$self->drawLine($mstart,$mstop,$mline,$mdelim)) unless $self->{options}{hide_HeadLine};
+ my $i=0;
+ for (@{$self->{tbl_rows}}) {
+ $i++;
+ $contents .= $self->getPart($page,$self->drawRow($_,0,$mrstart,$mrstop,$mrdelim));
+ if (($self->{options}{drawRowLine} && $self->{tbl_rowline}{$i} && ($i != scalar(@{$self->{tbl_rows}}))) ||
+ (defined($self->{tbl_lines}{$i}) && $self->{tbl_lines}{$i} && ($i != scalar(@{$self->{tbl_rows}})) && ($i != scalar(@{$self->{tbl_rows}})))) {
+ $contents .= $self->getPart($page,$self->drawLine($rstart,$rstop,$rline,$rdelim))
+ }
+ }
+ $contents .= $self->getPart($page,$self->drawLine($bstart,$bstop,$bline,$bdelim)) unless $self->{options}{hide_LastLine};
+
+ return $contents;
+}
+
+# nifty subs
+
+# Replaces length() because of optional HTML and ANSI stripping
+sub count {
+ my ($self,$str) = @_;
+
+ if (defined($self->{options}{cb_count}) && ref($self->{options}{cb_count}) eq 'CODE') {
+ my $ret = eval { return &{$self->{options}{cb_count}}($str); };
+ return $ret if (!$@);
+ do { $self->reperror("Error: 'cb_count' callback returned error, ".$@); return 1; } if ($@);
+ }
+ elsif (defined($self->{options}{cb_count}) && ref($self->{options}{cb_count}) ne 'CODE') {
+ $self->reperror("Error: 'cb_count' set but no valid callback found, found ".ref($self->{options}{cb_count}));
+ return length($str);
+ }
+ $str =~ s/<.+?>//g if $self->{options}{allowHTML};
+ $str =~ s/\33\[(\d+(;\d+)?)?[musfwhojBCDHRJK]//g if $self->{options}{allowANSI}; # maybe i should only have allowed ESC[#;#m and not things not related to
+ $str =~ s/\33\([0B]//g if $self->{options}{allowANSI}; # color/bold/underline.. But I want to give people as much room as they need.
+
+ return length($str);
+}
+
+sub align {
+
+ my ($self,$text,$dir,$length,$strict) = @_;
+
+ if ($dir =~ /auto/i) {
+ if ($text =~ /^-?\d+([.,]\d+)*[%\w]?$/) {
+ $dir = 'right';
+ } else {
+ $dir = 'left';
+ }
+ }
+ if (ref($dir) eq 'CODE') {
+ my $ret = eval { return &{$dir}($text,$length,$self->count($text),$strict); };
+ return 'CB-ERR' if ($@);
+ # Removed in v0.14 # return 'CB-LEN-ERR' if ($self->count($ret) != $length);
+ return $ret;
+ } elsif ($dir =~ /right/i) {
+ my $visuallen = $self->count($text);
+ my $reallen = length($text);
+ if ($length - $visuallen > 0) {
+ $text = (" " x ($length - $visuallen)).$text;
+ }
+ return substr($text,0,$length - ($visuallen-$reallen)) if ($strict);
+ return $text;
+ } elsif ($dir =~ /left/i) {
+ my $visuallen = $self->count($text);
+ my $reallen = length($text);
+ if ($length - $visuallen > 0) {
+ $text = $text.(" " x ($length - $visuallen));
+ }
+ return substr($text,0,$length - ($visuallen-$reallen)) if ($strict);
+ return $text;
+ } elsif ($dir =~ /justify/i) {
+ my $visuallen = $self->count($text);
+ my $reallen = length($text);
+ $text = substr($text,0,$length - ($visuallen-$reallen)) if ($strict);
+ if ($self->count($text) < $length - ($visuallen-$reallen)) {
+ $text =~ s/^\s+//; # trailing whitespace
+ $text =~ s/\s+$//; # tailing whitespace
+
+ my @tmp = split(/\s+/,$text); # split them words
+
+ if (scalar(@tmp)) {
+ my $extra = $length - $self->count(join('',@tmp)); # Length of text without spaces
+
+ my $modulus = $extra % (scalar(@tmp)); # modulus
+ $extra = int($extra / (scalar(@tmp))); # for each word
+
+ $text = '';
+ foreach my $word (@tmp) {
+ $text .= $word . (' ' x $extra); # each word
+ if ($modulus) {
+ $modulus--;
+ $text .= ' '; # the first $modulus words, to even out
+ }
+ }
+ }
+ }
+ return $text; # either way, output text
+ } elsif ($dir =~ /center/i) {
+ my $visuallen = $self->count($text);
+ my $reallen = length($text);
+ my $left = ( $length - $visuallen ) / 2;
+ # Someone tell me if this is matematecally totally wrong. :P
+ $left = int($left) + 1 if ($left != int($left) && $left > 0.4);
+ my $right = int(( $length - $visuallen ) / 2);
+ $text = ($left > 0 ? " " x $left : '').$text.($right > 0 ? " " x $right : '');
+ return substr($text,0,$length) if ($strict);
+ return $text;
+ } else {
+ return $self->align($text,'auto',$length,$strict);
+ }
+}
+
+sub TIEARRAY {
+ my $self = shift;
+
+ return bless { workaround => $self } , ref $self;
+}
+sub FETCH {
+ shift->{workaround}->reperror('usage: push @$t,qw{ one more row };');
+ return undef;
+}
+sub STORE {
+ my $self = shift->{workaround};
+ my ($index, $value) = @_;
+
+ $self->reperror('usage: push @$t,qw{ one more row };');
+}
+sub FETCHSIZE {return 0;}
+sub STORESIZE {return;}
+
+# PodMaster should be really happy now, since this was in his wishlist. (ref: http://perlmonks.thepen.com/338456.html)
+sub PUSH {
+ my $self = shift->{workaround};
+ my @list = @_;
+
+ if (scalar(@list) > scalar(@{$self->{tbl_cols}})) {
+ $self->reperror("too many elements added");
+ return;
+ }
+
+ $self->addRow(@list);
+}
+
+sub reperror {
+ my $self = shift;
+ print STDERR Carp::shortmess(shift) if $self->{options}{reportErrors};
+}
+
+# Best way I could think of, to search the array.. Please tell me if you got a better way.
+sub find {
+ return undef unless defined $_[1];
+ grep {return $_ if @{$_[1]}[$_] eq $_[0];} (0..scalar(@{$_[1]})-1);
+ return undef;
+}
+
+1;
+
+__END__
+
+=head1 FEATURES
+
+In case you need to know if this module has what you need, I have made this list
+of features included in Text::ASCIITable.
+
+=over 4
+
+=item Configurable layout
+
+You can easily alter how the table should look, in many ways. There are a few examples
+in the draw() section of this documentation. And you can remove parts of the layout
+or even add a heading-part to the table.
+
+=item Text Aligning
+
+Align the text in a column auto(matically), left, right, center or justify. Usually you want to align text
+to right if you only have numbers in that row. The 'auto' direction aligns text to left, and numbers
+to the right. The 'justify' alignment evens out your text on each line, so the first and the last word
+always are at the beginning and the end of the current line. This gives you the newspaper paragraph look.
+You can also use your own subroutine as a callback-function to align your text.
+
+=item Multiline support in rows
+
+With the \n(ewline) character you can have rows use more than just one line on
+the output. (This looks nice with the drawRowLine option enabled)
+
+=item Wordwrap support
+
+You can set a column to not be wider than a set amount of characters. If a line exceedes
+for example 30 characters, the line will be broken up in several lines.
+
+=item HTML support
+
+If you put in tags inside the rows, the output would usually be broken when
+viewed in a browser, since the browser "execute" the tags instead of displaying it.
+But if you enable allowHTML. You are able to write html tags inside the rows without the
+output being broken if you display it in a browser. But you should not mix this with
+wordwrap, since this could make undesirable results.
+
+=item ANSI support
+
+Allows you to decorate your tables with colors or bold/underline when you display
+your tables to a terminal window.
+
+=item Page-flipping support
+
+If you don't want the table to get wider than your terminal-width.
+
+=item Errorreporting
+
+If you write a script in perl, and don't want users to be notified of the errormessages
+from Text::ASCIITable. You can easily turn of error reporting by setting reportErrors to 0.
+You will still get an 1 instead of undef returned from the function.
+
+=back
+
+=head1 REQUIRES
+
+Exporter, Carp
+
+=head1 AUTHOR
+
+Håkon Nessjøen,
+
+=head1 VERSION
+
+Current version is 0.22.
+
+=head1 COPYRIGHT
+
+Copyright 2002-2011 by Håkon Nessjøen.
+All rights reserved.
+This module is free software;
+you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+Text::FormatTable, Text::Table, Text::SimpleTable
+
+=cut
diff --git a/vendor_perl/Text/ASCIITable/Wrap.pm b/vendor_perl/Text/ASCIITable/Wrap.pm
new file mode 100644
index 000000000..9080f5981
--- /dev/null
+++ b/vendor_perl/Text/ASCIITable/Wrap.pm
@@ -0,0 +1,99 @@
+package Text::ASCIITable::Wrap;
+
+@ISA=qw(Exporter);
+@EXPORT = qw();
+@EXPORT_OK = qw(wrap);
+$VERSION = '0.2';
+use Exporter;
+use strict;
+use Carp;
+
+=encoding utf8
+
+=head1 NAME
+
+Text::ASCIITable::Wrap - Wrap text
+
+=head1 SHORT DESCRIPTION
+
+Make sure a text never gets wider than the specified width using wordwrap.
+
+=head1 SYNOPSIS
+
+ use Text::ASCIITable::Wrap qw{ wrap };
+ print wrap('This is a long line which will be cut down to several lines',10);
+
+=head1 FUNCTIONS
+
+=head2 wrap($text,$width[,$nostrict]) (exportable)
+
+Wraps text at the specified width. Unless the $nostrict parameter is set, it
+will cut down the word if a word is wider than $width. Also supports text with linebreaks.
+
+=cut
+
+sub wrap {
+ my ($text,$width,$nostrict) = @_;
+ Carp::shortmess('Missing required text or width parameter.') if (!defined($text) || !defined($width));
+ my $result='';
+ for (split(/\n/,$text)) {
+ $result .= _wrap($_,$width,$nostrict)."\n";
+ }
+ chop($result);
+ return $result;
+}
+
+sub _wrap {
+ my ($text,$width,$nostrict) = @_;
+ my @result;
+ my $line='';
+ $nostrict = defined($nostrict) && $nostrict == 1 ? 1 : 0;
+ for (split(/ /,$text)) {
+ my $spc = $line eq '' ? 0 : 1;
+ my $len = length($line);
+ my $newlen = $len + $spc + length($_);
+ if ($len == 0 && $newlen > $width) {
+ push @result, $nostrict == 1 ? $_ : substr($_,0,$width); # kutt ned bredden
+ $line='';
+ }
+ elsif ($len != 0 && $newlen > $width) {
+ push @result, $nostrict == 1 ? $line : substr($line,0,$width);
+ $line = $_;
+ } else {
+ $line .= (' ' x $spc).$_;
+ }
+ }
+ push @result,$nostrict == 1 ? $line : substr($line,0,$width) if $line ne '';
+ return join("\n",@result);
+}
+
+
+1;
+
+__END__
+
+=head1 REQUIRES
+
+Exporter, Carp
+
+=head1 AUTHOR
+
+Håkon Nessjøen, lunatic@cpan.org
+
+=head1 VERSION
+
+Current version is 0.2.
+
+=head1 COPYRIGHT
+
+Copyright 2002-2003 by Håkon Nessjøen.
+All rights reserved.
+This module is free software;
+you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+Text::ASCIITable, Text::Wrap
+
+=cut
+
diff --git a/web-lib-funcs.pl b/web-lib-funcs.pl
index 97f0d4571..2285cb49b 100755
--- a/web-lib-funcs.pl
+++ b/web-lib-funcs.pl
@@ -14367,21 +14367,21 @@ if (!%current_theme_info || $nocache) {
return \%current_theme_info;
}
-# miniserv_using_default_cert()
-# Returns 1 if miniserv is using one of the hard-coded certs
+# miniserv_using_default_cert([certificate-file])
+# Returns 1 if miniserv is using one of the formerly bundled certificates
sub miniserv_using_default_cert
{
-return 0 if ($ENV{'HTTPS'} ne 'ON');
+my ($currentcertfile) = @_;
+return 0 if (!$currentcertfile && $ENV{'HTTPS'} ne 'ON');
my $defaultcertname = 'miniserv.pem';
-my $bundledcertfile = "$root_directory/$defaultcertname";
-my $currentcertfile = $ENV{'MINISERV_KEYFILE'};
+$currentcertfile ||= $ENV{'MINISERV_KEYFILE'};
if (!$currentcertfile) {
my %miniserv;
&get_miniserv_config(\%miniserv);
$currentcertfile = $miniserv{'keyfile'};
}
-if ( $currentcertfile =~ /$defaultcertname$/ &&
- -r $currentcertfile && -r $bundledcertfile) {
+if ($currentcertfile && $currentcertfile =~ /\Q$defaultcertname\E$/ &&
+ -r $currentcertfile) {
my $out;
&execute_command("md5sum ".quotemeta($currentcertfile), undef, \$out);
return 0 if ($?);
diff --git a/webmin/edit_ssl.cgi b/webmin/edit_ssl.cgi
index c127fed5b..2d378ec6b 100755
--- a/webmin/edit_ssl.cgi
+++ b/webmin/edit_ssl.cgi
@@ -17,7 +17,6 @@ our $module_name;
our $strong_ssl_ciphers;
our $pfs_ssl_ciphers;
our $info;
-our $root_directory;
our %config;
our $letsencrypt_cmd;
@@ -165,9 +164,7 @@ print ui_tabs_end_tab();
# SSL key generation form
print ui_tabs_start_tab("mode", "create");
print "$text{'ssl_newkey'}\n";
-my $curkey = read_file_contents($miniserv{'keyfile'});
-my $origkey = read_file_contents("$root_directory/miniserv.pem");
-if ($curkey eq $origkey) {
+if (miniserv_using_default_cert($miniserv{'keyfile'})) {
# System is using the original (insecure) Webmin key!
print "$text{'ssl_hole'} \n";
}
|