EVERYTHING FROM THE OTHER REPO
This commit is contained in:
@@ -0,0 +1,82 @@
|
||||
#!/usr/bin/perl
|
||||
# This file was preprocessed, do not edit!
|
||||
|
||||
|
||||
package Debconf::DbDriver::Backup;
|
||||
use warnings;
|
||||
use strict;
|
||||
use Debconf::Log qw{:all};
|
||||
use base 'Debconf::DbDriver::Copy';
|
||||
|
||||
|
||||
|
||||
use fields qw(db backupdb);
|
||||
|
||||
|
||||
sub init {
|
||||
my $this=shift;
|
||||
|
||||
foreach my $f (qw(db backupdb)) {
|
||||
if (! ref $this->{$f}) {
|
||||
my $db=$this->driver($this->{$f});
|
||||
unless (defined $f) {
|
||||
$this->error("could not find a db named \"$this->{$f}\"");
|
||||
}
|
||||
$this->{$f}=$db;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub copy {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
|
||||
$this->SUPER::copy($item, $this->{db}, $this->{backupdb});
|
||||
}
|
||||
|
||||
|
||||
sub shutdown {
|
||||
my $this=shift;
|
||||
|
||||
$this->{backupdb}->shutdown(@_);
|
||||
$this->{db}->shutdown(@_);
|
||||
}
|
||||
|
||||
sub _query {
|
||||
my $this=shift;
|
||||
my $command=shift;
|
||||
shift; # this again
|
||||
|
||||
return $this->{db}->$command(@_);
|
||||
}
|
||||
|
||||
sub _change {
|
||||
my $this=shift;
|
||||
my $command=shift;
|
||||
shift; # this again
|
||||
|
||||
my $ret=$this->{db}->$command(@_);
|
||||
if (defined $ret) {
|
||||
$this->{backupdb}->$command(@_);
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub iterator { $_[0]->_query('iterator', @_) }
|
||||
sub exists { $_[0]->_query('exists', @_) }
|
||||
sub addowner { $_[0]->_change('addowner', @_) }
|
||||
sub removeowner { $_[0]->_change('removeowner', @_) }
|
||||
sub owners { $_[0]->_query('owners', @_) }
|
||||
sub getfield { $_[0]->_query('getfield', @_) }
|
||||
sub setfield { $_[0]->_change('setfield', @_) }
|
||||
sub fields { $_[0]->_query('fields', @_) }
|
||||
sub getflag { $_[0]->_query('getflag', @_) }
|
||||
sub setflag { $_[0]->_change('setflag', @_) }
|
||||
sub flags { $_[0]->_query('flags', @_) }
|
||||
sub getvariable { $_[0]->_query('getvariable', @_) }
|
||||
sub setvariable { $_[0]->_change('setvariable', @_) }
|
||||
sub variables { $_[0]->_query('variables', @_) }
|
||||
|
||||
|
||||
1
|
||||
@@ -0,0 +1,272 @@
|
||||
#!/usr/bin/perl
|
||||
# This file was preprocessed, do not edit!
|
||||
|
||||
|
||||
package Debconf::DbDriver::Cache;
|
||||
use warnings;
|
||||
use strict;
|
||||
use Debconf::Log qw{:all};
|
||||
use base 'Debconf::DbDriver';
|
||||
|
||||
|
||||
use fields qw(cache dirty);
|
||||
|
||||
|
||||
sub iterator {
|
||||
my $this=shift;
|
||||
my $subiterator=shift;
|
||||
|
||||
my @items=keys %{$this->{cache}};
|
||||
my $iterator=Debconf::Iterator->new(callback => sub {
|
||||
while (my $item = pop @items) {
|
||||
next unless defined $this->{cache}->{$item};
|
||||
return $item;
|
||||
}
|
||||
return unless $subiterator;
|
||||
my $ret;
|
||||
do {
|
||||
$ret=$subiterator->iterate;
|
||||
} while defined $ret and exists $this->{cache}->{$ret};
|
||||
return $ret;
|
||||
});
|
||||
return $iterator;
|
||||
}
|
||||
|
||||
|
||||
sub exists {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
|
||||
return $this->{cache}->{$item}
|
||||
if exists $this->{cache}->{$item};
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
sub init {
|
||||
my $this=shift;
|
||||
|
||||
$this->{cache} = {} unless exists $this->{cache};
|
||||
}
|
||||
|
||||
|
||||
sub cacheadd {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
my $entry=shift;
|
||||
|
||||
return if exists $this->{cache}->{$item};
|
||||
|
||||
$this->{cache}->{$item}=$entry;
|
||||
$this->{dirty}->{$item}=0;
|
||||
}
|
||||
|
||||
|
||||
sub cachedata {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
|
||||
return $this->{cache}->{$item};
|
||||
}
|
||||
|
||||
|
||||
sub cached {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
|
||||
unless (exists $this->{cache}->{$item}) {
|
||||
debug "db $this->{name}" => "cache miss on $item";
|
||||
$this->load($item);
|
||||
}
|
||||
return $this->{cache}->{$item};
|
||||
}
|
||||
|
||||
|
||||
sub shutdown {
|
||||
my $this=shift;
|
||||
|
||||
return if $this->{readonly};
|
||||
|
||||
my $ret=1;
|
||||
foreach my $item (keys %{$this->{cache}}) {
|
||||
if (not defined $this->{cache}->{$item}) {
|
||||
$ret=undef unless defined $this->remove($item);
|
||||
delete $this->{cache}->{$item};
|
||||
}
|
||||
elsif ($this->{dirty}->{$item}) {
|
||||
$ret=undef unless defined $this->save($item, $this->{cache}->{$item});
|
||||
$this->{dirty}->{$item}=0;
|
||||
}
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
|
||||
sub addowner {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
my $owner=shift;
|
||||
my $type=shift;
|
||||
|
||||
return if $this->{readonly};
|
||||
$this->cached($item);
|
||||
|
||||
if (! defined $this->{cache}->{$item}) {
|
||||
return if ! $this->accept($item, $type);
|
||||
debug "db $this->{name}" => "creating in-cache $item";
|
||||
$this->{cache}->{$item}={
|
||||
owners => {},
|
||||
fields => {},
|
||||
variables => {},
|
||||
flags => {},
|
||||
}
|
||||
}
|
||||
|
||||
if (! exists $this->{cache}->{$item}->{owners}->{$owner}) {
|
||||
$this->{cache}->{$item}->{owners}->{$owner}=1;
|
||||
$this->{dirty}->{$item}=1;
|
||||
}
|
||||
return $owner;
|
||||
}
|
||||
|
||||
|
||||
sub removeowner {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
my $owner=shift;
|
||||
|
||||
return if $this->{readonly};
|
||||
return unless $this->cached($item);
|
||||
|
||||
if (exists $this->{cache}->{$item}->{owners}->{$owner}) {
|
||||
delete $this->{cache}->{$item}->{owners}->{$owner};
|
||||
$this->{dirty}->{$item}=1;
|
||||
}
|
||||
unless (keys %{$this->{cache}->{$item}->{owners}}) {
|
||||
$this->{cache}->{$item}=undef;
|
||||
$this->{dirty}->{$item}=1;
|
||||
}
|
||||
return $owner;
|
||||
}
|
||||
|
||||
|
||||
sub owners {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
|
||||
return unless $this->cached($item);
|
||||
return keys %{$this->{cache}->{$item}->{owners}};
|
||||
}
|
||||
|
||||
|
||||
sub getfield {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
my $field=shift;
|
||||
|
||||
return unless $this->cached($item);
|
||||
return $this->{cache}->{$item}->{fields}->{$field};
|
||||
}
|
||||
|
||||
|
||||
sub setfield {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
my $field=shift;
|
||||
my $value=shift;
|
||||
|
||||
return if $this->{readonly};
|
||||
return unless $this->cached($item);
|
||||
$this->{dirty}->{$item}=1;
|
||||
return $this->{cache}->{$item}->{fields}->{$field} = $value;
|
||||
}
|
||||
|
||||
|
||||
sub removefield {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
my $field=shift;
|
||||
|
||||
return if $this->{readonly};
|
||||
return unless $this->cached($item);
|
||||
$this->{dirty}->{$item}=1;
|
||||
return delete $this->{cache}->{$item}->{fields}->{$field};
|
||||
}
|
||||
|
||||
|
||||
sub fields {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
|
||||
return unless $this->cached($item);
|
||||
return keys %{$this->{cache}->{$item}->{fields}};
|
||||
}
|
||||
|
||||
|
||||
sub getflag {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
my $flag=shift;
|
||||
|
||||
return unless $this->cached($item);
|
||||
return $this->{cache}->{$item}->{flags}->{$flag}
|
||||
if exists $this->{cache}->{$item}->{flags}->{$flag};
|
||||
return 'false';
|
||||
}
|
||||
|
||||
|
||||
sub setflag {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
my $flag=shift;
|
||||
my $value=shift;
|
||||
|
||||
return if $this->{readonly};
|
||||
return unless $this->cached($item);
|
||||
$this->{dirty}->{$item}=1;
|
||||
return $this->{cache}->{$item}->{flags}->{$flag} = $value;
|
||||
}
|
||||
|
||||
|
||||
sub flags {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
|
||||
return unless $this->cached($item);
|
||||
return keys %{$this->{cache}->{$item}->{flags}};
|
||||
}
|
||||
|
||||
|
||||
sub getvariable {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
my $variable=shift;
|
||||
|
||||
return unless $this->cached($item);
|
||||
return $this->{cache}->{$item}->{variables}->{$variable};
|
||||
}
|
||||
|
||||
|
||||
sub setvariable {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
my $variable=shift;
|
||||
my $value=shift;
|
||||
|
||||
return if $this->{readonly};
|
||||
return unless $this->cached($item);
|
||||
$this->{dirty}->{$item}=1;
|
||||
return $this->{cache}->{$item}->{variables}->{$variable} = $value;
|
||||
}
|
||||
|
||||
|
||||
sub variables {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
|
||||
return unless $this->cached($item);
|
||||
return keys %{$this->{cache}->{$item}->{variables}};
|
||||
}
|
||||
|
||||
|
||||
1
|
||||
@@ -0,0 +1,42 @@
|
||||
#!/usr/bin/perl
|
||||
# This file was preprocessed, do not edit!
|
||||
|
||||
|
||||
package Debconf::DbDriver::Copy;
|
||||
use warnings;
|
||||
use strict;
|
||||
use Debconf::Log qw{:all};
|
||||
use base 'Debconf::DbDriver';
|
||||
|
||||
|
||||
sub copy {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
my $src=shift;
|
||||
my $dest=shift;
|
||||
|
||||
debug "db $this->{name}" => "copying $item from $src->{name} to $dest->{name}";
|
||||
|
||||
my @owners=$src->owners($item);
|
||||
if (! @owners) {
|
||||
@owners=("unknown");
|
||||
}
|
||||
foreach my $owner (@owners) {
|
||||
my $template = Debconf::Template->get($src->getfield($item, 'template'));
|
||||
my $type="";
|
||||
$type = $template->type if $template;
|
||||
$dest->addowner($item, $owner, $type);
|
||||
}
|
||||
foreach my $field ($src->fields($item)) {
|
||||
$dest->setfield($item, $field, $src->getfield($item, $field));
|
||||
}
|
||||
foreach my $flag ($src->flags($item)) {
|
||||
$dest->setflag($item, $flag, $src->getflag($item, $flag));
|
||||
}
|
||||
foreach my $var ($src->variables($item)) {
|
||||
$dest->setvariable($item, $var, $src->getvariable($item, $var));
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
1
|
||||
@@ -0,0 +1,53 @@
|
||||
#!/usr/bin/perl
|
||||
# This file was preprocessed, do not edit!
|
||||
|
||||
|
||||
package Debconf::DbDriver::Debug;
|
||||
use warnings;
|
||||
use strict;
|
||||
use Debconf::Log qw{:all};
|
||||
use base 'Debconf::DbDriver';
|
||||
|
||||
|
||||
|
||||
use fields qw(db);
|
||||
|
||||
|
||||
sub init {
|
||||
my $this=shift;
|
||||
|
||||
if (! ref $this->{db}) {
|
||||
$this->{db}=$this->driver($this->{db});
|
||||
unless (defined $this->{db}) {
|
||||
$this->error("could not find db");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub DESTROY {}
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $this=shift;
|
||||
(my $command = our $AUTOLOAD) =~ s/.*://;
|
||||
|
||||
debug "db $this->{name}" => "running $command(".join(",", map { "'$_'" } @_).") ..";
|
||||
if (wantarray) {
|
||||
my @ret=$this->{db}->$command(@_);
|
||||
debug "db $this->{name}" => "$command returned (".join(", ", @ret).")";
|
||||
return @ret if @ret;
|
||||
}
|
||||
else {
|
||||
my $ret=$this->{db}->$command(@_);
|
||||
if (defined $ret) {
|
||||
debug "db $this->{name}" => "$command returned \'$ret\'";
|
||||
return $ret;
|
||||
}
|
||||
else {
|
||||
debug "db $this->{name}" => "$command returned undef";
|
||||
}
|
||||
}
|
||||
return; # failure
|
||||
}
|
||||
|
||||
|
||||
1
|
||||
@@ -0,0 +1,104 @@
|
||||
#!/usr/bin/perl
|
||||
# This file was preprocessed, do not edit!
|
||||
|
||||
|
||||
package Debconf::DbDriver::DirTree;
|
||||
use warnings;
|
||||
use strict;
|
||||
use Debconf::Log qw(:all);
|
||||
use base 'Debconf::DbDriver::Directory';
|
||||
|
||||
|
||||
sub init {
|
||||
my $this=shift;
|
||||
if (not defined $this->{extension} or not length $this->{extension}) {
|
||||
$this->{extension}=".dat";
|
||||
}
|
||||
$this->SUPER::init(@_);
|
||||
}
|
||||
|
||||
|
||||
sub save {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
|
||||
return unless $this->accept($item);
|
||||
return if $this->{readonly};
|
||||
|
||||
my @dirs=split(m:/:, $this->filename($item));
|
||||
pop @dirs; # the base filename
|
||||
my $base=$this->{directory};
|
||||
foreach (@dirs) {
|
||||
$base.="/$_";
|
||||
next if -d $base;
|
||||
mkdir $base or $this->error("mkdir $base: $!");
|
||||
}
|
||||
|
||||
$this->SUPER::save($item, @_);
|
||||
}
|
||||
|
||||
|
||||
sub filename {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
$item =~ s/\.\.//g;
|
||||
return $item.$this->{extension};
|
||||
}
|
||||
|
||||
|
||||
sub iterator {
|
||||
my $this=shift;
|
||||
|
||||
my @stack=();
|
||||
my $currentdir="";
|
||||
my $handle;
|
||||
opendir($handle, $this->{directory}) or
|
||||
$this->error("opendir: $this->{directory}: $!");
|
||||
|
||||
my $iterator=Debconf::Iterator->new(callback => sub {
|
||||
my $i;
|
||||
while ($handle or @stack) {
|
||||
while (@stack and not $handle) {
|
||||
$currentdir=pop @stack;
|
||||
opendir($handle, "$this->{directory}/$currentdir") or
|
||||
$this->error("opendir: $this->{directory}/$currentdir: $!");
|
||||
}
|
||||
$i=readdir($handle);
|
||||
if (not defined $i) {
|
||||
closedir $handle;
|
||||
$handle=undef;
|
||||
next;
|
||||
}
|
||||
next if $i eq '.lock' || $i =~ /-old$/;
|
||||
if (-d "$this->{directory}/$currentdir$i") {
|
||||
if ($i ne '..' and $i ne '.') {
|
||||
push @stack, "$currentdir$i/";
|
||||
}
|
||||
next;
|
||||
}
|
||||
next unless $i=~s/$this->{extension}$//;
|
||||
return $currentdir.$i;
|
||||
}
|
||||
return;
|
||||
});
|
||||
|
||||
$this->SUPER::iterator($iterator);
|
||||
}
|
||||
|
||||
|
||||
sub remove {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
|
||||
my $ret=$this->SUPER::remove($item);
|
||||
return $ret unless $ret;
|
||||
|
||||
my $dir=$this->filename($item);
|
||||
while ($dir=~s:(.*)/[^/]*:$1: and length $dir) {
|
||||
rmdir "$this->{directory}/$dir" or last; # not empty, I presume
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
|
||||
1
|
||||
@@ -0,0 +1,156 @@
|
||||
#!/usr/bin/perl
|
||||
# This file was preprocessed, do not edit!
|
||||
|
||||
|
||||
package Debconf::DbDriver::Directory;
|
||||
use warnings;
|
||||
use strict;
|
||||
use Debconf::Log qw(:all);
|
||||
use IO::File;
|
||||
use POSIX ();
|
||||
use Fcntl qw(:DEFAULT :flock);
|
||||
use Debconf::Iterator;
|
||||
use base 'Debconf::DbDriver::Cache';
|
||||
|
||||
|
||||
use fields qw(directory extension lock format);
|
||||
|
||||
|
||||
sub init {
|
||||
my $this=shift;
|
||||
|
||||
$this->{extension} = "" unless exists $this->{extension};
|
||||
$this->{format} = "822" unless exists $this->{format};
|
||||
$this->{backup} = 1 unless exists $this->{backup};
|
||||
|
||||
$this->error("No format specified") unless $this->{format};
|
||||
eval "use Debconf::Format::$this->{format}";
|
||||
if ($@) {
|
||||
$this->error("Error setting up format object $this->{format}: $@");
|
||||
}
|
||||
$this->{format}="Debconf::Format::$this->{format}"->new;
|
||||
if (not ref $this->{format}) {
|
||||
$this->error("Unable to make format object");
|
||||
}
|
||||
|
||||
$this->error("No directory specified") unless $this->{directory};
|
||||
if (exists $this->{root}) {
|
||||
$this->{directory} = $this->{root} . $this->{directory};
|
||||
}
|
||||
if (not -d $this->{directory} and not $this->{readonly}) {
|
||||
mkdir $this->{directory} ||
|
||||
$this->error("mkdir $this->{directory}:$!");
|
||||
}
|
||||
if (not -d $this->{directory}) {
|
||||
$this->error($this->{directory}." does not exist");
|
||||
}
|
||||
debug "db $this->{name}" => "started; directory is $this->{directory}";
|
||||
|
||||
if (! $this->{readonly}) {
|
||||
open ($this->{lock}, ">", $this->{directory}."/.lock") or
|
||||
$this->error("could not lock $this->{directory}: $!");
|
||||
while (! flock($this->{lock}, LOCK_EX | LOCK_NB)) {
|
||||
next if $! == &POSIX::EINTR;
|
||||
$this->error("$this->{directory} is locked by another process: $!");
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub load {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
|
||||
debug "db $this->{name}" => "loading $item";
|
||||
my $file=$this->{directory}.'/'.$this->filename($item);
|
||||
return unless -e $file;
|
||||
|
||||
my $fh=IO::File->new;
|
||||
open($fh, "<", $file) or $this->error("$file: $!");
|
||||
$this->cacheadd($this->{format}->read($fh));
|
||||
close $fh;
|
||||
}
|
||||
|
||||
|
||||
sub save {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
my $data=shift;
|
||||
|
||||
return unless $this->accept($item);
|
||||
return if $this->{readonly};
|
||||
debug "db $this->{name}" => "saving $item";
|
||||
|
||||
my $file=$this->{directory}.'/'.$this->filename($item);
|
||||
|
||||
my $fh=IO::File->new;
|
||||
if ($this->ispassword($item)) {
|
||||
sysopen($fh, $file."-new", O_WRONLY|O_TRUNC|O_CREAT, 0600)
|
||||
or $this->error("$file-new: $!");
|
||||
}
|
||||
else {
|
||||
open($fh, ">", "$file-new") or $this->error("$file-new: $!");
|
||||
}
|
||||
$this->{format}->beginfile;
|
||||
$this->{format}->write($fh, $data, $item)
|
||||
or $this->error("could not write $file-new: $!");
|
||||
$this->{format}->endfile;
|
||||
|
||||
$fh->flush or $this->error("could not flush $file-new: $!");
|
||||
$fh->sync or $this->error("could not sync $file-new: $!");
|
||||
close $fh or $this->error("could not close $file-new: $!");
|
||||
|
||||
if (-e $file && $this->{backup}) {
|
||||
rename($file, $file."-old") or
|
||||
debug "db $this->{name}" => "rename failed: $!";
|
||||
}
|
||||
rename("$file-new", $file) or $this->error("rename failed: $!");
|
||||
}
|
||||
|
||||
|
||||
sub shutdown {
|
||||
my $this=shift;
|
||||
|
||||
$this->SUPER::shutdown(@_);
|
||||
delete $this->{lock};
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
sub exists {
|
||||
my $this=shift;
|
||||
my $name=shift;
|
||||
|
||||
my $incache=$this->SUPER::exists($name);
|
||||
return $incache if not defined $incache or $incache;
|
||||
|
||||
return -e $this->{directory}.'/'.$this->filename($name);
|
||||
}
|
||||
|
||||
|
||||
sub remove {
|
||||
my $this=shift;
|
||||
my $name=shift;
|
||||
|
||||
return if $this->{readonly} or not $this->accept($name);
|
||||
debug "db $this->{name}" => "removing $name";
|
||||
my $file=$this->{directory}.'/'.$this->filename($name);
|
||||
unlink $file or return;
|
||||
if (-e $file."-old") {
|
||||
unlink $file."-old" or return;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
sub accept {
|
||||
my $this=shift;
|
||||
my $name=shift;
|
||||
|
||||
return if $name=~m#\.\./# or $name=~m#/\.\.#;
|
||||
$this->SUPER::accept($name, @_);
|
||||
}
|
||||
|
||||
|
||||
1
|
||||
@@ -0,0 +1,150 @@
|
||||
#!/usr/bin/perl
|
||||
# This file was preprocessed, do not edit!
|
||||
|
||||
|
||||
package Debconf::DbDriver::File;
|
||||
use warnings;
|
||||
use strict;
|
||||
use Debconf::Log qw(:all);
|
||||
use Cwd 'abs_path';
|
||||
use POSIX ();
|
||||
use Fcntl qw(:DEFAULT :flock);
|
||||
use IO::Handle;
|
||||
use base 'Debconf::DbDriver::Cache';
|
||||
|
||||
|
||||
use fields qw(filename mode format _fh);
|
||||
|
||||
|
||||
sub init {
|
||||
my $this=shift;
|
||||
|
||||
if (exists $this->{mode}) {
|
||||
$this->{mode} = oct($this->{mode});
|
||||
}
|
||||
else {
|
||||
$this->{mode} = 0600;
|
||||
}
|
||||
$this->{format} = "822" unless exists $this->{format};
|
||||
$this->{backup} = 1 unless exists $this->{backup};
|
||||
|
||||
$this->error("No format specified") unless $this->{format};
|
||||
eval "use Debconf::Format::$this->{format}";
|
||||
if ($@) {
|
||||
$this->error("Error setting up format object $this->{format}: $@");
|
||||
}
|
||||
$this->{format}="Debconf::Format::$this->{format}"->new;
|
||||
if (not ref $this->{format}) {
|
||||
$this->error("Unable to make format object");
|
||||
}
|
||||
|
||||
$this->error("No filename specified") unless $this->{filename};
|
||||
|
||||
my ($directory)=$this->{filename}=~m!^(.*)/[^/]+!;
|
||||
if (length $directory and not -d $directory) {
|
||||
mkdir $directory || $this->error("mkdir $directory:$!");
|
||||
}
|
||||
|
||||
if (exists $this->{root}) {
|
||||
$this->{filename} = $this->{root} . $this->{filename};
|
||||
}
|
||||
$this->{filename} = abs_path($this->{filename});
|
||||
|
||||
debug "db $this->{name}" => "started; filename is $this->{filename}";
|
||||
|
||||
if (! -e $this->{filename}) {
|
||||
$this->{backup}=0;
|
||||
sysopen(my $fh, $this->{filename},
|
||||
O_WRONLY|O_TRUNC|O_CREAT,$this->{mode}) or
|
||||
$this->error("could not open $this->{filename}");
|
||||
close $fh;
|
||||
}
|
||||
|
||||
my $implicit_readonly=0;
|
||||
if (! $this->{readonly}) {
|
||||
if (open ($this->{_fh}, "+<", $this->{filename})) {
|
||||
while (! flock($this->{_fh}, LOCK_EX | LOCK_NB)) {
|
||||
next if $! == &POSIX::EINTR;
|
||||
$this->error("$this->{filename} is locked by another process: $!");
|
||||
last;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$implicit_readonly=1;
|
||||
}
|
||||
}
|
||||
if ($this->{readonly} || $implicit_readonly) {
|
||||
if (! open ($this->{_fh}, "<", $this->{filename})) {
|
||||
$this->error("could not open $this->{filename}: $!");
|
||||
return; # always abort, even if not throwing fatal error
|
||||
}
|
||||
}
|
||||
|
||||
$this->SUPER::init(@_);
|
||||
|
||||
debug "db $this->{name}" => "loading database";
|
||||
|
||||
while (! eof $this->{_fh}) {
|
||||
my ($item, $cache)=$this->{format}->read($this->{_fh});
|
||||
$this->{cache}->{$item}=$cache;
|
||||
}
|
||||
if ($this->{readonly} || $implicit_readonly) {
|
||||
close $this->{_fh};
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub shutdown {
|
||||
my $this=shift;
|
||||
|
||||
return if $this->{readonly};
|
||||
|
||||
if (grep { $this->{dirty}->{$_} } keys %{$this->{cache}}) {
|
||||
debug "db $this->{name}" => "saving database";
|
||||
}
|
||||
else {
|
||||
debug "db $this->{name}" => "no database changes, not saving";
|
||||
|
||||
delete $this->{_fh};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sysopen(my $fh, $this->{filename}."-new",
|
||||
O_WRONLY|O_TRUNC|O_CREAT,$this->{mode}) or
|
||||
$this->error("could not write $this->{filename}-new: $!");
|
||||
while (! flock($fh, LOCK_EX | LOCK_NB)) {
|
||||
next if $! == &POSIX::EINTR;
|
||||
$this->error("$this->{filename}-new is locked by another process: $!");
|
||||
last;
|
||||
}
|
||||
$this->{format}->beginfile;
|
||||
foreach my $item (sort keys %{$this->{cache}}) {
|
||||
next unless defined $this->{cache}->{$item}; # skip deleted
|
||||
$this->{format}->write($fh, $this->{cache}->{$item}, $item)
|
||||
or $this->error("could not write $this->{filename}-new: $!");
|
||||
}
|
||||
$this->{format}->endfile;
|
||||
|
||||
$fh->flush or $this->error("could not flush $this->{filename}-new: $!");
|
||||
$fh->sync or $this->error("could not sync $this->{filename}-new: $!");
|
||||
|
||||
if (-e $this->{filename} && $this->{backup}) {
|
||||
rename($this->{filename}, $this->{filename}."-old") or
|
||||
debug "db $this->{name}" => "rename failed: $!";
|
||||
}
|
||||
rename($this->{filename}."-new", $this->{filename}) or
|
||||
$this->error("rename failed: $!");
|
||||
|
||||
delete $this->{_fh};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
sub load {
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
1
|
||||
@@ -0,0 +1,264 @@
|
||||
#!/usr/bin/perl
|
||||
# This file was preprocessed, do not edit!
|
||||
|
||||
|
||||
package Debconf::DbDriver::LDAP;
|
||||
use warnings;
|
||||
use strict;
|
||||
use Debconf::Log qw(:all);
|
||||
use Net::LDAP;
|
||||
use base 'Debconf::DbDriver::Cache';
|
||||
|
||||
|
||||
use fields qw(server port basedn binddn bindpasswd exists keybykey ds accept_attribute reject_attribute);
|
||||
|
||||
|
||||
sub binddb {
|
||||
my $this=shift;
|
||||
|
||||
$this->error("No server specified") unless exists $this->{server};
|
||||
$this->error("No Base DN specified") unless exists $this->{basedn};
|
||||
|
||||
$this->{binddn} = "" unless exists $this->{binddn};
|
||||
$this->{port} = 389 unless exists $this->{port};
|
||||
|
||||
debug "db $this->{name}" => "talking to $this->{server}, data under $this->{basedn}";
|
||||
|
||||
$this->{ds} = Net::LDAP->new($this->{server}, port => $this->{port}, version => 3);
|
||||
if (! $this->{ds}) {
|
||||
$this->error("Unable to connect to LDAP server");
|
||||
return; # if not fatal, give up anyway
|
||||
}
|
||||
|
||||
my $rv = "";
|
||||
if (!($this->{binddn} && $this->{bindpasswd})) {
|
||||
debug "db $this->{name}" => "binding anonymously; hope that's OK";
|
||||
$rv = $this->{ds}->bind;
|
||||
} else {
|
||||
debug "db $this->{name}" => "binding as $this->{binddn}";
|
||||
$rv = $this->{ds}->bind($this->{binddn}, password => $this->{bindpasswd});
|
||||
}
|
||||
if ($rv->code) {
|
||||
$this->error("Bind Failed: ".$rv->error);
|
||||
}
|
||||
|
||||
return $this->{ds};
|
||||
}
|
||||
|
||||
|
||||
sub init {
|
||||
my $this = shift;
|
||||
|
||||
$this->SUPER::init(@_);
|
||||
|
||||
$this->binddb;
|
||||
return unless $this->{ds};
|
||||
|
||||
$this->{exists} = {};
|
||||
|
||||
if ($this->{keybykey}) {
|
||||
debug "db $this->{name}" => "will get database data key by key";
|
||||
}
|
||||
else {
|
||||
debug "db $this->{name}" => "getting database data";
|
||||
my $data = $this->{ds}->search(base => $this->{basedn}, sizelimit => 0, timelimit => 0, filter => "(objectclass=debconfDbEntry)");
|
||||
if ($data->code) {
|
||||
$this->error("Search failed: ".$data->error);
|
||||
}
|
||||
|
||||
my $records = $data->as_struct();
|
||||
debug "db $this->{name}" => "Read ".$data->count()." entries";
|
||||
|
||||
$this->parse_records($records);
|
||||
|
||||
$this->{ds}->unbind;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub shutdown
|
||||
{
|
||||
my $this = shift;
|
||||
|
||||
return if $this->{readonly};
|
||||
|
||||
if (grep { $this->{dirty}->{$_} } keys %{$this->{cache}}) {
|
||||
debug "db $this->{name}" => "saving changes";
|
||||
} else {
|
||||
debug "db $this->{name}" => "no database changes, not saving";
|
||||
return 1;
|
||||
}
|
||||
|
||||
unless ($this->{keybykey}) {
|
||||
$this->binddb;
|
||||
return unless $this->{ds};
|
||||
}
|
||||
|
||||
foreach my $item (keys %{$this->{cache}}) {
|
||||
next unless defined $this->{cache}->{$item}; # skip deleted
|
||||
next unless $this->{dirty}->{$item}; # skip unchanged
|
||||
(my $entry_cn = $item) =~ s/([,+="<>#;])/\\$1/g;
|
||||
my $entry_dn = "cn=$entry_cn,$this->{basedn}";
|
||||
debug "db $this->{name}" => "writing out to $entry_dn";
|
||||
|
||||
my %data = %{$this->{cache}->{$item}};
|
||||
my %modify_data;
|
||||
my $add_data = [ 'objectclass' => 'top',
|
||||
'objectclass' => 'debconfdbentry',
|
||||
'cn' => $item
|
||||
];
|
||||
|
||||
my @fields = keys %{$data{fields}};
|
||||
foreach my $field (@fields) {
|
||||
my $ldapname = $field;
|
||||
if ( $ldapname =~ s/_(\w)/uc($1)/ge ) {
|
||||
$data{fields}->{$ldapname} = $data{fields}->{$field};
|
||||
delete $data{fields}->{$field};
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $field (keys %{$data{fields}}) {
|
||||
next if ($data{fields}->{$field} eq '' &&
|
||||
!($field eq 'value'));
|
||||
if ((exists $this->{accept_attribute} &&
|
||||
$field !~ /$this->{accept_attribute}/) or
|
||||
(exists $this->{reject_attribute} &&
|
||||
$field =~ /$this->{reject_attribute}/)) {
|
||||
debug "db $item" => "reject $field";
|
||||
next;
|
||||
}
|
||||
|
||||
$modify_data{$field}=$data{fields}->{$field};
|
||||
push(@{$add_data}, $field);
|
||||
push(@{$add_data}, $data{fields}->{$field});
|
||||
}
|
||||
|
||||
my @owners = keys %{$data{owners}};
|
||||
debug "db $this->{name}" => "owners is ".join(" ", @owners);
|
||||
$modify_data{owners} = \@owners;
|
||||
push(@{$add_data}, 'owners');
|
||||
push(@{$add_data}, \@owners);
|
||||
|
||||
my @flags = grep { $data{flags}->{$_} eq 'true' } keys %{$data{flags}};
|
||||
if (@flags) {
|
||||
$modify_data{flags} = \@flags;
|
||||
push(@{$add_data}, 'flags');
|
||||
push(@{$add_data}, \@flags);
|
||||
}
|
||||
|
||||
$modify_data{variables} = [];
|
||||
foreach my $var (keys %{$data{variables}}) {
|
||||
my $variable = "$var=$data{variables}->{$var}";
|
||||
push (@{$modify_data{variables}}, $variable);
|
||||
push(@{$add_data}, 'variables');
|
||||
push(@{$add_data}, $variable);
|
||||
}
|
||||
|
||||
my $rv="";
|
||||
if ($this->{exists}->{$item}) {
|
||||
$rv = $this->{ds}->modify($entry_dn, replace => \%modify_data);
|
||||
} else {
|
||||
$rv = $this->{ds}->add($entry_dn, attrs => $add_data);
|
||||
}
|
||||
if ($rv->code) {
|
||||
$this->error("Modify failed: ".$rv->error);
|
||||
}
|
||||
}
|
||||
|
||||
$this->{ds}->unbind();
|
||||
|
||||
$this->SUPER::shutdown(@_);
|
||||
}
|
||||
|
||||
|
||||
sub load {
|
||||
my $this = shift;
|
||||
return unless $this->{keybykey};
|
||||
my $entry_cn = shift;
|
||||
|
||||
my $records = $this->get_key($entry_cn);
|
||||
return unless $records;
|
||||
|
||||
debug "db $this->{name}" => "Read entry for $entry_cn";
|
||||
|
||||
$this->parse_records($records);
|
||||
}
|
||||
|
||||
|
||||
sub remove {
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
sub save {
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
sub get_key {
|
||||
my $this = shift;
|
||||
return unless $this->{keybykey};
|
||||
my $entry_cn = shift;
|
||||
|
||||
my $data = $this->{ds}->search(
|
||||
base => 'cn=' . $entry_cn . ',' . $this->{basedn},
|
||||
sizelimit => 0,
|
||||
timelimit => 0,
|
||||
filter => "(objectclass=debconfDbEntry)");
|
||||
|
||||
if ($data->code) {
|
||||
$this->error("Search failed: ".$data->error);
|
||||
}
|
||||
|
||||
return unless $data->entries;
|
||||
$data->as_struct();
|
||||
}
|
||||
|
||||
sub parse_records {
|
||||
my $this = shift;
|
||||
my $records = shift;
|
||||
|
||||
foreach my $dn (keys %{$records}) {
|
||||
my $entry = $records->{$dn};
|
||||
debug "db $this->{name}" => "Reading data from $dn";
|
||||
my %ret = (owners => {},
|
||||
fields => {},
|
||||
variables => {},
|
||||
flags => {},
|
||||
);
|
||||
my $name = "";
|
||||
|
||||
foreach my $attr (keys %{$entry}) {
|
||||
if ($attr eq 'objectclass') {
|
||||
next;
|
||||
}
|
||||
my $values = $entry->{$attr};
|
||||
|
||||
$attr =~ s/([a-z])([A-Z])/$1.'_'.lc($2)/ge;
|
||||
|
||||
debug "db $this->{name}" => "Setting data for $attr";
|
||||
foreach my $val (@{$values}) {
|
||||
debug "db $this->{name}" => "$attr = $val";
|
||||
if ($attr eq 'owners') {
|
||||
$ret{owners}->{$val}=1;
|
||||
} elsif ($attr eq 'flags') {
|
||||
$ret{flags}->{$val}='true';
|
||||
} elsif ($attr eq 'cn') {
|
||||
$name = $val;
|
||||
} elsif ($attr eq 'variables') {
|
||||
my ($var, $value)=split(/\s*=\s*/, $val, 2);
|
||||
$ret{variables}->{$var}=$value;
|
||||
} else {
|
||||
$val=~s/\\n/\n/g;
|
||||
$ret{fields}->{$attr}=$val;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$this->{cache}->{$name} = \%ret;
|
||||
$this->{exists}->{$name} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
1
|
||||
@@ -0,0 +1,171 @@
|
||||
#!/usr/bin/perl
|
||||
# This file was preprocessed, do not edit!
|
||||
|
||||
|
||||
package Debconf::DbDriver::PackageDir;
|
||||
use warnings;
|
||||
use strict;
|
||||
use Debconf::Log qw(:all);
|
||||
use IO::File;
|
||||
use Fcntl qw(:DEFAULT :flock);
|
||||
use Debconf::Iterator;
|
||||
use base 'Debconf::DbDriver::Directory';
|
||||
|
||||
|
||||
use fields qw(mode _loaded);
|
||||
|
||||
|
||||
sub init {
|
||||
my $this=shift;
|
||||
|
||||
if (exists $this->{mode}) {
|
||||
$this->{mode} = oct($this->{mode});
|
||||
}
|
||||
else {
|
||||
$this->{mode} = 0600;
|
||||
}
|
||||
$this->SUPER::init(@_);
|
||||
}
|
||||
|
||||
|
||||
sub loadfile {
|
||||
my $this=shift;
|
||||
my $file=$this->{directory}."/".shift;
|
||||
|
||||
return if $this->{_loaded}->{$file};
|
||||
$this->{_loaded}->{$file}=1;
|
||||
|
||||
debug "db $this->{name}" => "loading $file";
|
||||
return unless -e $file;
|
||||
|
||||
my $fh=IO::File->new;
|
||||
open($fh, "<", $file) or $this->error("$file: $!");
|
||||
my @item = $this->{format}->read($fh);
|
||||
while (@item) {
|
||||
$this->cacheadd(@item);
|
||||
@item = $this->{format}->read($fh);
|
||||
}
|
||||
close $fh;
|
||||
}
|
||||
|
||||
|
||||
sub load {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
$this->loadfile($this->filename($item));
|
||||
}
|
||||
|
||||
|
||||
sub filename {
|
||||
my $this=shift;
|
||||
my $item=shift;
|
||||
|
||||
if ($item =~ m!^([^/]+)(?:/|$)!) {
|
||||
return $1.$this->{extension};
|
||||
}
|
||||
else {
|
||||
$this->error("failed parsing item name \"$item\"\n");
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub iterator {
|
||||
my $this=shift;
|
||||
|
||||
my $handle;
|
||||
opendir($handle, $this->{directory}) ||
|
||||
$this->error("opendir: $!");
|
||||
|
||||
while (my $file=readdir($handle)) {
|
||||
next if length $this->{extension} and
|
||||
not $file=~m/$this->{extension}/;
|
||||
next unless -f $this->{directory}."/".$file;
|
||||
next if $file eq '.lock' || $file =~ /-old$/;
|
||||
$this->loadfile($file);
|
||||
}
|
||||
|
||||
$this->SUPER::iterator;
|
||||
}
|
||||
|
||||
|
||||
sub exists {
|
||||
my $this=shift;
|
||||
my $name=shift;
|
||||
my $incache=$this->Debconf::DbDriver::Cache::exists($name);
|
||||
return $incache if not defined $incache or $incache;
|
||||
my $file=$this->{directory}.'/'.$this->filename($name);
|
||||
return unless -e $file;
|
||||
|
||||
$this->load($name);
|
||||
|
||||
return $this->Debconf::DbDriver::Cache::exists($name);
|
||||
}
|
||||
|
||||
|
||||
sub shutdown {
|
||||
my $this=shift;
|
||||
|
||||
return if $this->{readonly};
|
||||
|
||||
my (%files, %filecontents, %killfiles, %dirtyfiles);
|
||||
foreach my $item (keys %{$this->{cache}}) {
|
||||
my $file=$this->filename($item);
|
||||
$files{$file}++;
|
||||
|
||||
if (! defined $this->{cache}->{$item}) {
|
||||
$killfiles{$file}++;
|
||||
delete $this->{cache}->{$item};
|
||||
}
|
||||
else {
|
||||
push @{$filecontents{$file}}, $item;
|
||||
}
|
||||
|
||||
if ($this->{dirty}->{$item}) {
|
||||
$dirtyfiles{$file}++;
|
||||
$this->{dirty}->{$item}=0;
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $file (keys %files) {
|
||||
if (! $filecontents{$file} && $killfiles{$file}) {
|
||||
debug "db $this->{name}" => "removing $file";
|
||||
my $filename=$this->{directory}."/".$file;
|
||||
unlink $filename or
|
||||
$this->error("unable to remove $filename: $!");
|
||||
if (-e $filename."-old") {
|
||||
unlink $filename."-old" or
|
||||
$this->error("unable to remove $filename-old: $!");
|
||||
}
|
||||
}
|
||||
elsif ($dirtyfiles{$file}) {
|
||||
debug "db $this->{name}" => "saving $file";
|
||||
my $filename=$this->{directory}."/".$file;
|
||||
|
||||
sysopen(my $fh, $filename."-new",
|
||||
O_WRONLY|O_TRUNC|O_CREAT,$this->{mode}) or
|
||||
$this->error("could not write $filename-new: $!");
|
||||
$this->{format}->beginfile;
|
||||
foreach my $item (@{$filecontents{$file}}) {
|
||||
$this->{format}->write($fh, $this->{cache}->{$item}, $item)
|
||||
or $this->error("could not write $filename-new: $!");
|
||||
}
|
||||
$this->{format}->endfile;
|
||||
|
||||
$fh->flush or $this->error("could not flush $filename-new: $!");
|
||||
$fh->sync or $this->error("could not sync $filename-new: $!");
|
||||
|
||||
if (-e $filename && $this->{backup}) {
|
||||
rename($filename, $filename."-old") or
|
||||
debug "db $this->{name}" => "rename failed: $!";
|
||||
}
|
||||
rename($filename."-new", $filename) or
|
||||
$this->error("rename failed: $!");
|
||||
}
|
||||
}
|
||||
|
||||
$this->SUPER::shutdown(@_);
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
1
|
||||
@@ -0,0 +1,91 @@
|
||||
#!/usr/bin/perl
|
||||
# This file was preprocessed, do not edit!
|
||||
|
||||
|
||||
package Debconf::DbDriver::Pipe;
|
||||
use warnings;
|
||||
use strict;
|
||||
use Debconf::Log qw(:all);
|
||||
use base 'Debconf::DbDriver::Cache';
|
||||
|
||||
|
||||
use fields qw(infd outfd format);
|
||||
|
||||
|
||||
sub init {
|
||||
my $this=shift;
|
||||
|
||||
$this->{format} = "822" unless exists $this->{format};
|
||||
|
||||
$this->error("No format specified") unless $this->{format};
|
||||
eval "use Debconf::Format::$this->{format}";
|
||||
if ($@) {
|
||||
$this->error("Error setting up format object $this->{format}: $@");
|
||||
}
|
||||
$this->{format}="Debconf::Format::$this->{format}"->new;
|
||||
if (not ref $this->{format}) {
|
||||
$this->error("Unable to make format object");
|
||||
}
|
||||
|
||||
my $fh;
|
||||
if (defined $this->{infd}) {
|
||||
if ($this->{infd} ne 'none') {
|
||||
open ($fh, "<&=", $this->{infd}) or
|
||||
$this->error("could not open file descriptor #$this->{infd}: $!");
|
||||
}
|
||||
}
|
||||
else {
|
||||
open ($fh, '<&', \*STDIN);
|
||||
}
|
||||
|
||||
$this->SUPER::init(@_);
|
||||
|
||||
debug "db $this->{name}" => "loading database";
|
||||
|
||||
if (defined $fh) {
|
||||
while (! eof $fh) {
|
||||
my ($item, $cache)=$this->{format}->read($fh);
|
||||
$this->{cache}->{$item}=$cache;
|
||||
}
|
||||
close $fh;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub shutdown {
|
||||
my $this=shift;
|
||||
|
||||
return if $this->{readonly};
|
||||
|
||||
my $fh;
|
||||
if (defined $this->{outfd}) {
|
||||
if ($this->{outfd} ne 'none') {
|
||||
open ($fh, ">&=", $this->{outfd}) or
|
||||
$this->error("could not open file descriptor #$this->{outfd}: $!");
|
||||
}
|
||||
}
|
||||
else {
|
||||
open ($fh, '>&', \*STDOUT);
|
||||
}
|
||||
|
||||
if (defined $fh) {
|
||||
$this->{format}->beginfile;
|
||||
foreach my $item (sort keys %{$this->{cache}}) {
|
||||
next unless defined $this->{cache}->{$item}; # skip deleted
|
||||
$this->{format}->write($fh, $this->{cache}->{$item}, $item)
|
||||
or $this->error("could not write to pipe: $!");
|
||||
}
|
||||
$this->{format}->endfile;
|
||||
close $fh or $this->error("could not close pipe: $!");
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
sub load {
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
1
|
||||
@@ -0,0 +1,250 @@
|
||||
#!/usr/bin/perl
|
||||
# This file was preprocessed, do not edit!
|
||||
|
||||
|
||||
package Debconf::DbDriver::Stack;
|
||||
use warnings;
|
||||
use strict;
|
||||
use Debconf::Log qw{:all};
|
||||
use Debconf::Iterator;
|
||||
use base 'Debconf::DbDriver::Copy';
|
||||
|
||||
|
||||
|
||||
use fields qw(stack stack_change_errors);
|
||||
|
||||
|
||||
sub init {
|
||||
my $this=shift;
|
||||
|
||||
if (! ref $this->{stack}) {
|
||||
my @stack;
|
||||
foreach my $name (split(/\s*,\s/, $this->{stack})) {
|
||||
my $driver=$this->driver($name);
|
||||
unless (defined $driver) {
|
||||
$this->error("could not find a db named \"$name\" to use in the stack (it should be defined before the stack in the config file)");
|
||||
next;
|
||||
}
|
||||
push @stack, $driver;
|
||||
}
|
||||
$this->{stack}=[@stack];
|
||||
}
|
||||
|
||||
$this->error("no stack set") if ! ref $this->{stack};
|
||||
$this->error("stack is empty") if ! @{$this->{stack}};
|
||||
}
|
||||
|
||||
|
||||
sub iterator {
|
||||
my $this=shift;
|
||||
|
||||
my %seen;
|
||||
my @iterators = map { $_->iterator } @{$this->{stack}};
|
||||
my $i = pop @iterators;
|
||||
my $iterator=Debconf::Iterator->new(callback => sub {
|
||||
for (;;) {
|
||||
while (my $ret = $i->iterate) {
|
||||
next if $seen{$ret};
|
||||
$seen{$ret}=1;
|
||||
return $ret;
|
||||
}
|
||||
$i = pop @iterators;
|
||||
return unless defined $i;
|
||||
}
|
||||
});
|
||||
}
|
||||
|
||||
|
||||
sub shutdown {
|
||||
my $this=shift;
|
||||
|
||||
my $ret=1;
|
||||
foreach my $driver (@{$this->{stack}}) {
|
||||
$ret=undef if not defined $driver->shutdown(@_);
|
||||
}
|
||||
|
||||
if ($this->{stack_change_errors}) {
|
||||
$this->error("unable to save changes to: ".
|
||||
join(" ", @{$this->{stack_change_errors}}));
|
||||
$ret=undef;
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
|
||||
sub exists {
|
||||
my $this=shift;
|
||||
|
||||
foreach my $driver (@{$this->{stack}}) {
|
||||
return 1 if $driver->exists(@_);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _query {
|
||||
my $this=shift;
|
||||
my $command=shift;
|
||||
shift; # this again
|
||||
|
||||
debug "db $this->{name}" => "trying to $command(@_) ..";
|
||||
foreach my $driver (@{$this->{stack}}) {
|
||||
if (wantarray) {
|
||||
my @ret=$driver->$command(@_);
|
||||
debug "db $this->{name}" => "$command done by $driver->{name}" if @ret;
|
||||
return @ret if @ret;
|
||||
}
|
||||
else {
|
||||
my $ret=$driver->$command(@_);
|
||||
debug "db $this->{name}" => "$command done by $driver->{name}" if defined $ret;
|
||||
return $ret if defined $ret;
|
||||
}
|
||||
}
|
||||
return; # failure
|
||||
}
|
||||
|
||||
sub _change {
|
||||
my $this=shift;
|
||||
my $command=shift;
|
||||
shift; # this again
|
||||
my $item=shift;
|
||||
|
||||
debug "db $this->{name}" => "trying to $command($item @_) ..";
|
||||
|
||||
foreach my $driver (@{$this->{stack}}) {
|
||||
if ($driver->exists($item)) {
|
||||
last if $driver->{readonly}; # nope, hit a readonly one
|
||||
debug "db $this->{name}" => "passing to $driver->{name} ..";
|
||||
return $driver->$command($item, @_);
|
||||
}
|
||||
}
|
||||
|
||||
my $src=0;
|
||||
|
||||
foreach my $driver (@{$this->{stack}}) {
|
||||
if ($driver->exists($item)) {
|
||||
my $ret=$this->_nochange($driver, $command, $item, @_);
|
||||
if (defined $ret) {
|
||||
debug "db $this->{name}" => "skipped $command($item) as it would have no effect";
|
||||
return $ret;
|
||||
}
|
||||
|
||||
$src=$driver;
|
||||
last
|
||||
}
|
||||
}
|
||||
|
||||
my $writer;
|
||||
foreach my $driver (@{$this->{stack}}) {
|
||||
if ($driver == $src) {
|
||||
push @{$this->{stack_change_errors}}, $item;
|
||||
return;
|
||||
}
|
||||
if (! $driver->{readonly}) {
|
||||
if ($command eq 'addowner') {
|
||||
if ($driver->accept($item, $_[1])) {
|
||||
$writer=$driver;
|
||||
last;
|
||||
}
|
||||
}
|
||||
elsif ($driver->accept($item)) {
|
||||
$writer=$driver;
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
unless ($writer) {
|
||||
debug "db $this->{name}" => "FAILED $command";
|
||||
return;
|
||||
}
|
||||
|
||||
if ($src) {
|
||||
$this->copy($item, $src, $writer);
|
||||
}
|
||||
|
||||
debug "db $this->{name}" => "passing to $writer->{name} ..";
|
||||
return $writer->$command($item, @_);
|
||||
}
|
||||
|
||||
sub _nochange {
|
||||
my $this=shift;
|
||||
my $driver=shift;
|
||||
my $command=shift;
|
||||
my $item=shift;
|
||||
|
||||
if ($command eq 'addowner') {
|
||||
my $value=shift;
|
||||
foreach my $owner ($driver->owners($item)) {
|
||||
return $value if $owner eq $value;
|
||||
}
|
||||
return;
|
||||
}
|
||||
elsif ($command eq 'removeowner') {
|
||||
my $value=shift;
|
||||
|
||||
foreach my $owner ($driver->owners($item)) {
|
||||
return if $owner eq $value;
|
||||
}
|
||||
return $value; # no change
|
||||
}
|
||||
elsif ($command eq 'removefield') {
|
||||
my $value=shift;
|
||||
|
||||
foreach my $field ($driver->fields($item)) {
|
||||
return if $field eq $value;
|
||||
}
|
||||
return $value; # no change
|
||||
}
|
||||
|
||||
my @list;
|
||||
my $get;
|
||||
if ($command eq 'setfield') {
|
||||
@list=$driver->fields($item);
|
||||
$get='getfield';
|
||||
}
|
||||
elsif ($command eq 'setflag') {
|
||||
@list=$driver->flags($item);
|
||||
$get='getflag';
|
||||
}
|
||||
elsif ($command eq 'setvariable') {
|
||||
@list=$driver->variables($item);
|
||||
$get='getvariable';
|
||||
}
|
||||
else {
|
||||
$this->error("internal error; bad command: $command");
|
||||
}
|
||||
|
||||
my $thing=shift;
|
||||
my $value=shift;
|
||||
my $currentvalue=$driver->$get($item, $thing);
|
||||
|
||||
my $exists=0;
|
||||
foreach my $i (@list) {
|
||||
if ($thing eq $i) {
|
||||
$exists=1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
return $currentvalue unless $exists;
|
||||
|
||||
return $currentvalue if $currentvalue eq $value;
|
||||
return;
|
||||
}
|
||||
|
||||
sub addowner { $_[0]->_change('addowner', @_) }
|
||||
sub removeowner { $_[0]->_change('removeowner', @_) }
|
||||
sub owners { $_[0]->_query('owners', @_) }
|
||||
sub getfield { $_[0]->_query('getfield', @_) }
|
||||
sub setfield { $_[0]->_change('setfield', @_) }
|
||||
sub removefield { $_[0]->_change('removefield', @_) }
|
||||
sub fields { $_[0]->_query('fields', @_) }
|
||||
sub getflag { $_[0]->_query('getflag', @_) }
|
||||
sub setflag { $_[0]->_change('setflag', @_) }
|
||||
sub flags { $_[0]->_query('flags', @_) }
|
||||
sub getvariable { $_[0]->_query('getvariable', @_) }
|
||||
sub setvariable { $_[0]->_change('setvariable', @_) }
|
||||
sub variables { $_[0]->_query('variables', @_) }
|
||||
|
||||
|
||||
1
|
||||
Reference in New Issue
Block a user