diff options
Diffstat (limited to 'beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver')
11 files changed, 1607 insertions, 0 deletions
diff --git a/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Backup.pm b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Backup.pm new file mode 100644 index 0000000..73206dc --- /dev/null +++ b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Backup.pm @@ -0,0 +1,81 @@ +#!/usr/bin/perl -w +# This file was preprocessed, do not edit! + + +package Debconf::DbDriver::Backup; +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 diff --git a/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Cache.pm b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Cache.pm new file mode 100644 index 0000000..0072407 --- /dev/null +++ b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Cache.pm @@ -0,0 +1,271 @@ +#!/usr/bin/perl -w +# This file was preprocessed, do not edit! + + +package Debconf::DbDriver::Cache; +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 diff --git a/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Copy.pm b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Copy.pm new file mode 100644 index 0000000..d4b3c71 --- /dev/null +++ b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Copy.pm @@ -0,0 +1,41 @@ +#!/usr/bin/perl -w +# This file was preprocessed, do not edit! + + +package Debconf::DbDriver::Copy; +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 diff --git a/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Debug.pm b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Debug.pm new file mode 100644 index 0000000..e5af031 --- /dev/null +++ b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Debug.pm @@ -0,0 +1,52 @@ +#!/usr/bin/perl -w +# This file was preprocessed, do not edit! + + +package Debconf::DbDriver::Debug; +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 diff --git a/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/DirTree.pm b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/DirTree.pm new file mode 100644 index 0000000..8447e20 --- /dev/null +++ b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/DirTree.pm @@ -0,0 +1,103 @@ +#!/usr/bin/perl -w +# This file was preprocessed, do not edit! + + +package Debconf::DbDriver::DirTree; +use strict; +use Debconf::Log qw(:all); +use base 'Debconf::DbDriver::Directory'; + + +sub init { + my $this=shift; + if (! defined $this->{extension} or ! 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 undef; + }); + + $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 diff --git a/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Directory.pm b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Directory.pm new file mode 100644 index 0000000..c9fbbaf --- /dev/null +++ b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Directory.pm @@ -0,0 +1,152 @@ +#!/usr/bin/perl -w +# This file was preprocessed, do not edit! + + +package Debconf::DbDriver::Directory; +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 (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 (!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 undef; + if (-e $file."-old") { + unlink $file."-old" or return undef; + } + return 1; +} + + +sub accept { + my $this=shift; + my $name=shift; + + return if $name=~m#\.\./# or $name=~m#/\.\.#; + $this->SUPER::accept($name, @_); +} + + +1 diff --git a/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/File.pm b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/File.pm new file mode 100644 index 0000000..ab09a47 --- /dev/null +++ b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/File.pm @@ -0,0 +1,138 @@ +#!/usr/bin/perl -w +# This file was preprocessed, do not edit! + + +package Debconf::DbDriver::File; +use strict; +use Debconf::Log qw(:all); +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}; + + 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 undef; +} + + +1 diff --git a/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/LDAP.pm b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/LDAP.pm new file mode 100644 index 0000000..f2664f6 --- /dev/null +++ b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/LDAP.pm @@ -0,0 +1,263 @@ +#!/usr/bin/perl -w +# This file was preprocessed, do not edit! + + +package Debconf::DbDriver::LDAP; +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 diff --git a/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/PackageDir.pm b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/PackageDir.pm new file mode 100644 index 0000000..a595c3f --- /dev/null +++ b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/PackageDir.pm @@ -0,0 +1,170 @@ +#!/usr/bin/perl -w +# This file was preprocessed, do not edit! + + +package Debconf::DbDriver::PackageDir; +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 (!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 diff --git a/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Pipe.pm b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Pipe.pm new file mode 100644 index 0000000..17a2132 --- /dev/null +++ b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Pipe.pm @@ -0,0 +1,90 @@ +#!/usr/bin/perl -w +# This file was preprocessed, do not edit! + + +package Debconf::DbDriver::Pipe; +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, '-'); + } + + $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, '>-'); + } + + 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 undef; +} + + +1 diff --git a/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Stack.pm b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Stack.pm new file mode 100644 index 0000000..ebfe5b3 --- /dev/null +++ b/beagle/debian-rfs/usr/share/perl5/Debconf/DbDriver/Stack.pm @@ -0,0 +1,246 @@ +#!/usr/bin/perl -w +# This file was preprocessed, do not edit! + + +package Debconf::DbDriver::Stack; +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 undef 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) { + $exists=1, last if $thing eq $i; + } + return $currentvalue unless $exists; + + return $currentvalue if $currentvalue eq $value; + return undef; +} + +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 |