App-Glacier
view release on metacpan or search on metacpan
lib/App/Glacier/Config.pm view on Meta::CPAN
require Exporter;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'sort' => [ qw(NO_SORT SORT_NATURAL SORT_PATH) ] );
our @EXPORT_OK = qw(NO_SORT SORT_NATURAL SORT_PATH);
our $VERSION = "1.00";
=head1 NAME
App::Glacier::Config - generalized configuration file parser
=head1 SYNOPSIS
my $cfg = new App::Glacier::Config($filename, %opts);
$cfg->parse() or die;
if ($cfg->isset('core', 'variable')) {
...
}
my $x = $cfg->get('file', 'locking');
$cfg->set('file', 'locking', 'true');
$cfg->unset('file', 'locking');
=head1 DESCRIPTION
=cut
=head2 $cfg = new App::Glacier::Config($filename, %opts);
Creates new configuration object for file B<$filename>. Valid
options are:
=over 4
=item B<debug> => I<NUM>
Sets debug verbosity level.
=item B<ci> => B<0> | B<1>
If B<1>, enables case-insensitive keyword matching. Default is B<0>,
i.e. the keywords are case-sensitive.
=item B<parameters> => \%hash
Defines the syntax table. See below for a description of B<%hash>.
=item B<cachefile> => I<FILENAME>
Sets the location of the cache file. If passed, the parsed configuration
will be stored in binary form in the I<FILENAME>. Before parsing the
configuration file, the constructor will chech if the cache file exists and
has the same timestamp as the configuration file. If so, the configuration
will be loaded from the cache (using B<Storable>(3)), avoiding parsing
overhead. Otherwise, the cached data will be discarded, and the source file
will be parsed as usual.
The destructor will first check if the configuration was updated, and if
so will recreate the cache file prior to destructing the object instance.
=item B<rw> => B<0> | B<1>
Whether or not the configuration is read-write. This setting is in effect
only if B<cachefile> is also set.
If set to B<0> (the default) any local changes to the configuration (using
B<set> and B<unset> methods), will not be saved to the cache file upon
exiting. Otherwise, the eventual modifications will be stored in the cache.
=back
=head3 Syntax hash
The hash passed via the B<parameters> keyword defines the keywords and
sections allowed within a configuration file. In a simplest case, a
keyword is described as
name => 1
This means that B<name> is a valid keyword, but does not imply anything
more about it or its value. A most complex declaration is possible, in
which the value is a hash reference, containing on or more of the following
keywords:
=over 4
=item mandatory => 0 | 1
Whether or not this setting is mandatory.
=item array => 0 | 1
If B<1>, the value of the setting is an array. Each subsequent occurrence
of the statement appends its value to the end of the array.
=item re => I<regexp>
Defines a regular expression to which must be matched by the value of the
setting, otherwise a syntax error will be reported.
=item select => I<coderef>
Points to a function to be called to decide whether to apply this hash to
a particular configuration setting. The function is called as
&{$coderef}($vref, @path)
where $vref is a reference to the setting (use $vref->{-value}, to obtain
the actual value), and @path is its patname.
=item check => I<coderef>
Defines a code which will be called after parsing the statement in order to
verify its value. The I<coderef> is called as
$err = &{$coderef}($valref, $prev_value)
where B<$valref> is a reference to its value, and B<$prev_value> is the value
lib/App/Glacier/Config.pm view on Meta::CPAN
if (defined($v = delete $_{rw})) {
$self->{rw} = $v;
}
if (keys(%_)) {
foreach my $k (keys %_) {
carp "unknown parameter $k"
}
++$err;
}
return undef if $err;
return $self;
}
sub DESTROY {
my $self = shift;
$self->writecache();
}
=head2 $cfg->error($message)
=head2 $cfg->error($message, locus => $loc)
Prints the B<$message> on STDERR. If <locus> is given, its value must
be a reference to a valid B<Text::Locus>(3) object. In that
case, the object will be formatted first, then followed by a ": " and the
B<$message>.
=cut
sub error {
my $self = shift;
my $err = shift;
local %_ = @_;
$err = "$_{locus}: $err" if $_{locus};
print STDERR "$err\n";
}
=head2 $cfg->debug($lev, @msg)
If B<$lev> is greater than or equal to the B<debug> value used when
creating B<$cfg>, outputs on standard error the strings from @msg,
separating them with a single space character.
Otherwise, does nothing.
=cut
sub debug {
my $self = shift;
my $lev = shift;
return unless $self->{debug} >= $lev;
$self->error("DEBUG: " . join(' ', @_));
}
sub writecache {
my $self = shift;
return unless exists $self->{cachefile};
return unless exists $self->{conf};
return unless $self->{updated};
$self->debug(1, "storing cache file $self->{cachefile}");
store $self->{conf}, $self->{cachefile};
}
sub parse_section {
my ($self, $conf, $input, $locus) = @_;
my $ref = $conf;
my $quote;
my $kw = $self->{parameters} if exists $self->{parameters};
while ($input ne '') {
my $name;
if (!defined($quote)) {
if ($input =~ /^"(.*)/) {
$quote = '';
$input = $1;
} elsif ($input =~ /^(.+?)(?:\s+|")(.*)/) {
$name = $1;
$input = $2;
} else {
$name = $input;
$input = '';
}
} else {
if ($input =~ /^([^\\"]*)\\(.)(.*)/) {
$quote .= $1 . $2;
$input = $3;
} elsif ($input =~ /^([^\\"]*)"\s*(.*)/) {
$name = $quote . $1;
$input = $2;
$quote = undef;
} else {
croak "unparsable input $input";
}
}
if (defined($name)) {
$ref->{$name} = {
-order => $self->{order}++,
-locus => $locus
} unless ref($ref->{$name}) eq 'HASH';
$ref = $ref->{$name};
if (defined($kw) and ref($kw) eq 'HASH') {
my $synt;
if (exists($kw->{$name})) {
$synt = $kw->{$name};
} elsif (exists($kw->{'*'})) {
$synt = $kw->{'*'};
if ($synt eq '*') {
$name = undef;
next;
}
}
if (defined($synt)
&& ref($synt) eq 'HASH'
&& exists($synt->{section})) {
$kw = $synt->{section};
} else {
$kw = undef;
}
lib/App/Glacier/Config.pm view on Meta::CPAN
$section->{-locus}->add($file, $line);
unless (exists($section->{$k})) {
$section->{$k}{-locus} = new Text::Locus();
}
$section->{$k}{-locus}->add($file, $line);
$section->{$k}{-order} = $self->{order}++;
$section->{$k}{-value} = $v;
} else {
$self->error("malformed line",
locus => new Text::Locus($file, $line));
$self->{error_count}++;
next;
}
}
close $fd;
return $self->{error_count} == 0;
}
sub fixup {
my $self = shift;
my $params = shift;
while (my ($kv, $descr) = each %$params) {
next unless ref($descr) eq 'HASH';
if (exists($descr->{section})) {
$self->fixup($descr->{section}, @_, $kv);
} elsif (exists($descr->{default}) && !$self->isset(@_, $kv)) {
$self->set(@_, $kv, $descr->{default});
}
}
}
sub file_up_to_date {
my ($self, $file) = @_;
my $st_conf = stat($self->{filename}) or return 1;
my $st_file = stat($file)
or carp "can't stat $file: $!";
return $st_conf->mtime <= $st_file->mtime;
}
=head2 $cfg->parse()
Parses the configuration file and stores the data in the object. Returns
true on success and false on failure. Eventual errors in the configuration
are reported using B<error>.
=cut
sub parse {
my ($self) = @_;
my %conf;
return if exists $self->{conf};
$self->{error_count} = 0;
if (exists($self->{cachefile}) and -f $self->{cachefile}) {
if ($self->file_up_to_date($self->{cachefile})) {
my $ref;
$self->debug(1, "reading from cache file $self->{cachefile}");
eval { $ref = retrieve($self->{cachefile}); };
if (defined($ref)) {
$self->{conf} = $ref;
$self->{updated} = $self->{rw};
return 1;
} elsif ($@) {
$self->error("warning: unable to load configuration cache: $@");
}
}
unlink $self->{cachefile};
}
$self->debug(1, "parsing $self->{filename}");
$self->readconfig($self->{filename}, \%conf);
$self->check_mandatory($self->{parameters}, \%conf);
if ($self->{error_count} == 0) {
$self->{conf} = \%conf ;
$self->{updated} = 1;
$self->fixup($self->{parameters}) if exists $self->{parameters};
return 1;
}
return 0;
}
sub getref {
my $self = shift;
return undef unless exists $self->{conf};
my $ref = $self->{conf};
for (@_) {
my $k = $self->{ci} ? lc($_) : $_;
return undef unless exists $ref->{$k};
$ref = $ref->{$k};
}
return $ref;
}
=head2 $var = $cfg->get(@path);
Returns the value of the configuration variable represented by its
I<path>, or B<undef> if the variable is not set. The path is a list
of configuration variables leading to the value in question. For example,
the following statement:
pidfile = /var/run/x.pid
has the path
( 'pidfile' )
The path of the B<pidfile> statement in section B<core>, e.g.:
[core]
pidfile = /var/run/x.pid
is
( 'core', 'pidfile' )
Similarly, the path of the B<file> setting in the following configuration
file:
[item foo]
file = bar
is
( 'item', 'foo', 'bar' )
=head2 $ret = $cfg->get({ variable => $pathref, return => all | value | locus })
I<$pathref> is a reference to the configuration setting path as described
above. This invocation is similar to B<get(@{$pathref})>, except that
it returns additional data as controlled by the B<return> keyword. The
valid values for the B<return> are:
=over 4
=item 'value'
lib/App/Glacier/Config.pm view on Meta::CPAN
set.
=cut
sub isset {
my $self = shift;
return defined $self->getref(@_);
}
sub is_section_ref {
my ($ref) = @_;
return ref($ref) eq 'HASH'
&& !exists($ref->{-value});
}
=head2 $cfg->issection(@path)
Returns true if the configuration section addressed by B<@path> is
set.
=cut
sub issection {
my $self = shift;
my $ref = $self->getref(@_);
return defined($ref) && is_section_ref($ref);
}
=head2 $cfg->isvariable(@path)
Returns true if the configuration variable addressed by B<@path> is
set.
=cut
sub isvariable {
my $self = shift;
my $ref = $self->getref(@_);
return defined($ref) && !is_section_ref($ref);
}
=head2 $cfg->set(@path, $value)
Sets the configuration variable B<@path> to B<$value>.
=cut
sub set {
my $self = shift;
$self->{conf} = {} unless exists $self->{conf};
my $ref = $self->{conf};
while ($#_ > 1) {
my $arg = shift;
$ref->{$arg} = {} unless exists $ref->{$arg};
$ref = $ref->{$arg};
}
$ref->{$_[0]}{-order} = $self->{order}++
unless exists $ref->{$_[0]}{-order};
$ref->{$_[0]}{-value} = $_[1];
$self->{updated} = $self->{rw};
}
=head2 cfg->unset(@path)
Unsets the configuration variable.
=cut
sub unset {
my $self = shift;
return unless exists $self->{conf};
my $ref = $self->{conf};
my @path;
for (@_) {
return unless exists $ref->{$_};
push @path, [ $ref, $_ ];
$ref = $ref->{$_};
}
while (1) {
my $loc = pop @path;
delete ${$loc->[0]}{$loc->[1]};
last unless (defined($loc) and keys(%{$loc->[0]}) == 0);
}
$self->{updated} = $self->{rw};
}
=head2 @array = $cfg->names_of(@path)
If B<@path> refers to an existing configuration section, returns a list
of names of variables and subsections defined within that section. E.g.,
if you have
[item foo]
x = 1
[item bar]
x = 1
[item baz]
y = 2
the call
$cfg->names_of('item')
will return
( 'foo', 'bar', 'baz' )
=cut
sub names_of {
my $self = shift;
my $ref = $self->getref(@_);
return () if !defined($ref) || ref($ref) ne 'HASH';
return map { /^-/ ? () : $_ } keys %{$ref};
}
#sub each {
# my $self = shift;
# return @{[ each %{$self->{conf}} ]};
#}
=head2 @array = $cfg->flatten()
=head2 @array = $cfg->flatten(sort => $sort)
Returns a I<flattened> representation of the configuration, as a
list of pairs B<[ $path, $value ]>, where B<$path> is a reference
to the variable pathname, and B<$value> is a reference to a hash
containing the following keys:
=over 4
=item B<-value>
The value of the setting.
=item B<-order>
The ordinal number of the setting.
=item B<-locus>
Location of the setting in the configuration file. See
B<Text::Locus>(3). It is available only if the B<locations>
( run in 0.545 second using v1.01-cache-2.11-cpan-5b529ec07f3 )