debconf-trunk/Debconf/Config.pm

#!/usr/bin/perl -w

=head1 NAME

Debconf::Config - Debconf meta-configuration module

=cut

package Debconf::Config;
use strict;
use Debconf::Question;
use Debconf::Gettext;
use Debconf::Db;

use fields qw(config templates frontend priority helpvisible
              showold admin_email log debug);
our $config=fields::new('Debconf::Config');

our @config_files=("$ENV{HOME}/.debconfrc", "/etc/debconf.conf",
                   "/usr/share/debconf/debconf.conf");

=head1 DESCRIPTION

This package holds configuration values for debconf. It supplies defaults,
and allows them to be overridden by values from the command line, the 
environment, the config file, and values pulled out of the debconf database.

=head1 METHODS

=over 4

=item load

This class method reads and parses a config file. The config file format is
a series of stanzas; the first stanza configures debconf as a whole, and
then each of the rest sets up a database driver. This lacks the glorious
nested bindish beauty of Wichert's original idea, but it captures the
essence of it. It will load from a set of standard locations unless a file
to load is specified.

=cut

# Turns a chunk of text into a hash. Returns number of fields
# that were processed. Also handles env variable expansion.
sub _hashify ($$) {
        my $text=shift;
        my $hash=shift;

        $text =~ s/\${([^}]+)}/$ENV{$1}/eg;
        
        my %ret;
        my $i;
        foreach my $line (split /\n/, $text) {
                next if $line=~/^\s*#/; # comment
                next if $line=~/^\s*$/; # blank
                $i++;
                my ($key, $value)=split(/\s*:\s*/, $line, 2);
                $key=~tr/-/_/;
                die "Parse error" unless defined $key and length $key;
                $hash->{lc($key)}=$value;
        }
        return $i;
}

sub load {
        my $class=shift;
        my $cf=shift;
        
        if (! $cf) {
                for my $file (@config_files) {
                        $cf=$file, last if -e $file;
                }
        }
        die "No config file found" unless $cf;

        open (DEBCONF_CONFIG, $cf) or die "$cf: $!\n";
        local $/="\n\n"; # read a stanza at a time

        # Read global options stanza.
        1 until _hashify(<DEBCONF_CONFIG>, $config);

        # Verify that all options are sane.
        if (! exists $config->{config}) {
                print STDERR gettext("Config database not specified in config file.");
                exit(1);
        }
        if (! exists $config->{templates}) {
                print STDERR gettext("Template database not specified in config file.");
                exit(1);
        }

        # Now read in each database driver, and set it up.
        while (<DEBCONF_CONFIG>) {
                my %config=();
                next unless _hashify($_, \%config);
                Debconf::Db->makedriver(%config);
        }
        close DEBCONF_CONFIG;
}

=item getopt

This class method parses command line options in @ARGV with GetOptions from
Getopt::Long.  Many meta configuration items can be overridden with command
line options.

The first parameter should be basic usage text for the program in
question. Usage text for the globally supported options will be prepended
to this if usage help must be printed.

If any additonal parameters are passed to this function, they are also
passed to GetOptions. This can be used to handle additional options.

=cut

sub getopt {
        my $class=shift;
        my $usage=shift;

        my $showusage=sub { # closure
                print STDERR $usage."\n";
                print STDERR <<EOF;
  -f,  --frontend               Specify debconf frontend to use.
  -p,  --priority               Specify minimum priority question to show.
  -s,  --showold                Redisplay old, already seen questions.
EOF
                exit 1;
        };

        require Getopt::Long; # Load only if this function is called.
        Getopt::Long::Configure('bundling');
        Getopt::Long::GetOptions(
                'frontend|f=s', sub { shift; $config->{frontend} = shift },
                'priority|p=s', sub { shift; $config->{priority} = shift },
                'showold|s',    sub { $config->{showold} = 'true' },
                'help|h',       $showusage,
                @_,
        ) || $showusage->();
}

=item frontend

The frontend to use. Looks at first the value of DEBIAN_FRONTEND, second the
config file, third the database, and if all of those fail, defaults to the
dialog frontend.

If a value is passed to this function, it changes it temporarily (for
the lifetime of the program) to override what's in the database or config
file.

=cut

sub frontend {
        my $class=shift;
        return $ENV{DEBIAN_FRONTEND} if exists $ENV{DEBIAN_FRONTEND};
        $config->{frontend}=shift if @_;
        return $config->{frontend} if exists $config->{frontend};
        
        my $ret='Dialog';
        my $question=Debconf::Question->get('debconf/frontend');
        if ($question) {
                $ret=$question->value || $ret;
        }
        return $ret;
}

=item priority

The lowest priority of questions you want to see. Looks at first the value
of DEBIAN_PRIORITYD, second the config file, third the database, and if all
of those fail, defaults to "medium".

If a value is passed to this function, it changes it temporarily (for
the lifetime of the program) to override what's in the database or config
file.

=cut

sub priority {
        my $class=shift;
        return $ENV{DEBIAN_PRIORITY} if exists $ENV{DEBIAN_PRIORITY};
        $config->{priority}=shift if @_;
        return $config->{priority} if exists $config->{priority};

        my $ret='medium';
        my $question=Debconf::Question->get('debconf/priority');
        if ($question) {
                $ret=$question->value || $ret;
        }
        return $ret;
}

=item helpvisible

Whether extended help should be displayed in some frontends. Looks first at
the config file, then at the database, and if both fail, defaults to true.

If a value is passed to this function, it changes it permanantly in the
database and for the lifetime of the program overrides anything that might
be in the config file.

=cut

sub helpvisible {
        my $class=shift;
        $config->{helpvisible}=$_[0] if @_;
        return $config->{helpvisible} if exists $config->{helpvisible};

        my $ret='true';
        my $question=Debconf::Question->get('debconf/helpvisible');
        if ($question) {
                return $question->value || $ret;
        }
        return $ret;
}

=item showold

If true, then old questions the user has already seen are shown to them again.
A value is pulled out of the config file or database if possible, otherwise a
default of false is used.

If a value is passed to this function, it changes it temporarily (for
the lifetime of the program) to override what's in the database or config
file.

=cut

sub showold {
        my $class=shift;
        $config->{showold}=shift if @_;
        return $config->{showold} if exists $config->{showold};
        
        my $ret='false';
        my $question=Debconf::Question->get('debconf/showold');
        if ($question) {
                $ret=$question->value || $ret;
        }
        return $ret;
}

=item debug

Returns debconf's debug regex. This is pulled out of the config file,
and may be overridden by DEBCONF_DEBUG in the environment.

=cut

sub debug {
        my $class=shift;
        return $ENV{DEBCONF_DEBUG} if exists $ENV{DEBCONF_DEBUG};
        return $config->{debug} if exists $config->{debug};
        return '';
}

=item admin_email

Returns an email address to use to send notes to. This is pulled out of the
config file, and may be overridden by the DEBCONF_ADMIN_MAIL environment
variable. If neither is set, it defaults to root.

=cut

sub admin_mail {
        my $class=shift;
        return $ENV{DEBCONF_ADMIN_EMAIL} if exists $ENV{DEBCONF_ADMIN_EMAIL};
        return $config->{admin_email} if exists $config->{admin_email};
        return 'root';
}

=back

=head1 FIELDS

Other fields can be accessed and set by calling class methods.

=cut

sub AUTOLOAD {
        (my $field = our $AUTOLOAD) =~ s/.*://;
        my $class=shift;
        
        return $config->{$field}=shift if @_;
        return $config->{$field} if defined $config->{$field};
        return '';
}

=head1 AUTHOR

Joey Hess <joey@kitenet.net>

=cut

1
1	#!/usr/bin/perl -w
2
3	=head1 NAME
4
5	Debconf::Config - Debconf meta-configuration module
6
7	=cut
8
9	package Debconf::Config;
10	use strict;
11	use Debconf::Question;
12	use Debconf::Gettext;
13	use Debconf::Db;
14
15	use fields qw(config templates frontend priority helpvisible
16	showold admin_email log debug);
17	our $config=fields::new('Debconf::Config');
18
19	our @config_files=("$ENV{HOME}/.debconfrc", "/etc/debconf.conf",
20	"/usr/share/debconf/debconf.conf");
21
22	=head1 DESCRIPTION
23
24	This package holds configuration values for debconf. It supplies defaults,
25	and allows them to be overridden by values from the command line, the
26	environment, the config file, and values pulled out of the debconf database.
27
28	=head1 METHODS
29
30	=over 4
31
32	=item load
33
34	This class method reads and parses a config file. The config file format is
35	a series of stanzas; the first stanza configures debconf as a whole, and
36	then each of the rest sets up a database driver. This lacks the glorious
37	nested bindish beauty of Wichert's original idea, but it captures the
38	essence of it. It will load from a set of standard locations unless a file
39	to load is specified.
40
41	=cut
42
43	# Turns a chunk of text into a hash. Returns number of fields
44	# that were processed. Also handles env variable expansion.
45	sub _hashify ($$) {
46	my $text=shift;
47	my $hash=shift;
48
49	$text =~ s/\${([^}]+)}/$ENV{$1}/eg;
50
51	my %ret;
52	my $i;
53	foreach my $line (split /\n/, $text) {
54	next if $line=~/^\s*#/; # comment
55	next if $line=~/^\s*$/; # blank
56	$i++;
57	my ($key, $value)=split(/\s:\s/, $line, 2);
58	$key=~tr/-/_/;
59	die "Parse error" unless defined $key and length $key;
60	$hash->{lc($key)}=$value;
61	}
62	return $i;
63	}
64
65	sub load {
66	my $class=shift;
67	my $cf=shift;
68
69	if (! $cf) {
70	for my $file (@config_files) {
71	$cf=$file, last if -e $file;
72	}
73	}
74	die "No config file found" unless $cf;
75
76	open (DEBCONF_CONFIG, $cf) or die "$cf: $!\n";
77	local $/="\n\n"; # read a stanza at a time
78
79	# Read global options stanza.
80	1 until _hashify(<DEBCONF_CONFIG>, $config);
81
82	# Verify that all options are sane.
83	if (! exists $config->{config}) {
84	print STDERR gettext("Config database not specified in config file.");
85	exit(1);
86	}
87	if (! exists $config->{templates}) {
88	print STDERR gettext("Template database not specified in config file.");
89	exit(1);
90	}
91
92	# Now read in each database driver, and set it up.
93	while (<DEBCONF_CONFIG>) {
94	my %config=();
95	next unless _hashify($_, \%config);
96	Debconf::Db->makedriver(%config);
97	}
98	close DEBCONF_CONFIG;
99	}
100
101	=item getopt
102
103	This class method parses command line options in @ARGV with GetOptions from
104	Getopt::Long. Many meta configuration items can be overridden with command
105	line options.
106
107	The first parameter should be basic usage text for the program in
108	question. Usage text for the globally supported options will be prepended
109	to this if usage help must be printed.
110
111	If any additonal parameters are passed to this function, they are also
112	passed to GetOptions. This can be used to handle additional options.
113
114	=cut
115
116	sub getopt {
117	my $class=shift;
118	my $usage=shift;
119
120	my $showusage=sub { # closure
121	print STDERR $usage."\n";
122	print STDERR <<EOF;
123	-f, --frontend Specify debconf frontend to use.
124	-p, --priority Specify minimum priority question to show.
125	-s, --showold Redisplay old, already seen questions.
126	EOF
127	exit 1;
128	};
129
130	require Getopt::Long; # Load only if this function is called.
131	Getopt::Long::Configure('bundling');
132	Getopt::Long::GetOptions(
133	'frontend\|f=s', sub { shift; $config->{frontend} = shift },
134	'priority\|p=s', sub { shift; $config->{priority} = shift },
135	'showold\|s', sub { $config->{showold} = 'true' },
136	'help\|h', $showusage,
137	@_,
138	) \|\| $showusage->();
139	}
140
141	=item frontend
142
143	The frontend to use. Looks at first the value of DEBIAN_FRONTEND, second the
144	config file, third the database, and if all of those fail, defaults to the
145	dialog frontend.
146
147	If a value is passed to this function, it changes it temporarily (for
148	the lifetime of the program) to override what's in the database or config
149	file.
150
151	=cut
152
153	sub frontend {
154	my $class=shift;
155	return $ENV{DEBIAN_FRONTEND} if exists $ENV{DEBIAN_FRONTEND};
156	$config->{frontend}=shift if @_;
157	return $config->{frontend} if exists $config->{frontend};
158
159	my $ret='Dialog';
160	my $question=Debconf::Question->get('debconf/frontend');
161	if ($question) {
162	$ret=$question->value \|\| $ret;
163	}
164	return $ret;
165	}
166
167	=item priority
168
169	The lowest priority of questions you want to see. Looks at first the value
170	of DEBIAN_PRIORITYD, second the config file, third the database, and if all
171	of those fail, defaults to "medium".
172
173	If a value is passed to this function, it changes it temporarily (for
174	the lifetime of the program) to override what's in the database or config
175	file.
176
177	=cut
178
179	sub priority {
180	my $class=shift;
181	return $ENV{DEBIAN_PRIORITY} if exists $ENV{DEBIAN_PRIORITY};
182	$config->{priority}=shift if @_;
183	return $config->{priority} if exists $config->{priority};
184
185	my $ret='medium';
186	my $question=Debconf::Question->get('debconf/priority');
187	if ($question) {
188	$ret=$question->value \|\| $ret;
189	}
190	return $ret;
191	}
192
193	=item helpvisible
194
195	Whether extended help should be displayed in some frontends. Looks first at
196	the config file, then at the database, and if both fail, defaults to true.
197
198	If a value is passed to this function, it changes it permanantly in the
199	database and for the lifetime of the program overrides anything that might
200	be in the config file.
201
202	=cut
203
204	sub helpvisible {
205	my $class=shift;
206	$config->{helpvisible}=$_[0] if @_;
207	return $config->{helpvisible} if exists $config->{helpvisible};
208
209	my $ret='true';
210	my $question=Debconf::Question->get('debconf/helpvisible');
211	if ($question) {
212	return $question->value \|\| $ret;
213	}
214	return $ret;
215	}
216
217	=item showold
218
219	If true, then old questions the user has already seen are shown to them again.
220	A value is pulled out of the config file or database if possible, otherwise a
221	default of false is used.
222
223	If a value is passed to this function, it changes it temporarily (for
224	the lifetime of the program) to override what's in the database or config
225	file.
226
227	=cut
228
229	sub showold {
230	my $class=shift;
231	$config->{showold}=shift if @_;
232	return $config->{showold} if exists $config->{showold};
233
234	my $ret='false';
235	my $question=Debconf::Question->get('debconf/showold');
236	if ($question) {
237	$ret=$question->value \|\| $ret;
238	}
239	return $ret;
240	}
241
242	=item debug
243
244	Returns debconf's debug regex. This is pulled out of the config file,
245	and may be overridden by DEBCONF_DEBUG in the environment.
246
247	=cut
248
249	sub debug {
250	my $class=shift;
251	return $ENV{DEBCONF_DEBUG} if exists $ENV{DEBCONF_DEBUG};
252	return $config->{debug} if exists $config->{debug};
253	return '';
254	}
255
256	=item admin_email
257
258	Returns an email address to use to send notes to. This is pulled out of the
259	config file, and may be overridden by the DEBCONF_ADMIN_MAIL environment
260	variable. If neither is set, it defaults to root.
261
262	=cut
263
264	sub admin_mail {
265	my $class=shift;
266	return $ENV{DEBCONF_ADMIN_EMAIL} if exists $ENV{DEBCONF_ADMIN_EMAIL};
267	return $config->{admin_email} if exists $config->{admin_email};
268	return 'root';
269	}
270
271	=back
272
273	=head1 FIELDS
274
275	Other fields can be accessed and set by calling class methods.
276
277	=cut
278
279	sub AUTOLOAD {
280	(my $field = our $AUTOLOAD) =~ s/.*://;
281	my $class=shift;
282
283	return $config->{$field}=shift if @_;
284	return $config->{$field} if defined $config->{$field};
285	return '';
286	}
287
288	=head1 AUTHOR
289
290	Joey Hess <joey@kitenet.net>
291
292	=cut
293
294	1