1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
#!/usr/bin/perl -w
=head1 NAME
Debconf::DbDriver::DirTree - store database in a directory hierarchy
=cut
package Debconf::DbDriver::DirTree;
use strict;
use Debconf::Log qw(:all);
use base 'Debconf::DbDriver::Directory';
# Works around a bug in perl. This was fixed as of perl 5.8.3-2, but I am
# leaving this for upgrades for a while.
use fields "perl_hates_dirtree";
=head1 DESCRIPTION
This is an extension to the Directory driver that uses a deeper directory
tree. I find such a tree easier to navigate, and it will also scale better
for huge databases on ext2. It does use a little more disk space/inodes
though.
=head1 FIELDS
=over 4
=item extension
This field is mandatory for this driver. If it is not set, it will be set
to ".dat" by default.
=back
=head1 METHODS
Note that the extension field is mandatory for this driver, so it checks
that on initialization.
=cut
sub init {
my $this=shift;
if (! defined $this->{extension} or ! length $this->{extension}) {
$this->{extension}=".dat";
}
$this->SUPER::init(@_);
}
=head2 save(itemname,value)
Before saving as usual, we have to make sure the subdirectory exists.
=cut
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, @_);
}
=head2 filename(itemname)
We actually use the item name as the filename, subdirs and all.
We also still append the extension to the item name. And the extension is
_mandatory_ here; otherwise this would try to use filenames and directories
with the same names sometimes.
=cut
sub filename {
my $this=shift;
my $item=shift;
$item =~ s/\.\.//g;
return $item.$this->{extension};
}
=head2 iterator
Iterating over the whole directory hierarchy is the one annoying part of
his driver.
=cut
sub iterator {
my $this=shift;
# Stack of pending directories.
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;
}
# Ignore files w/o our extension, and strip it.
next unless $i=~s/$this->{extension}$//;
return $currentdir.$i;
}
return undef;
});
$this->SUPER::iterator($iterator);
}
=head2 remove(itemname)
Unlink a file. Then, rmdir any empty directories.
=cut
sub remove {
my $this=shift;
my $item=shift;
# Do actual remove.
my $ret=$this->SUPER::remove($item);
return $ret unless $ret;
# Clean up.
my $dir=$this->filename($item);
while ($dir=~s:(.*)/[^/]*:$1: and length $dir) {
rmdir "$this->{directory}/$dir" or last; # not empty, I presume
}
return $ret;
}
=head1 AUTHOR
Joey Hess <joeyh@debian.org>
=cut
1
|
