package App::Acmeman::Config; use strict; use warnings; use Carp; require Exporter; our @ISA = qw(Exporter); our $VERSION = "1.00"; sub new { my ($class, $filename, %args) = @_; my $self = bless { _filename => $filename }, $class; my $defaults; my $v; if (defined($v = delete $args{syntax})) { $self->{_syntax} = $v; } $defaults = delete $args{defaults}; carp "unrecognized parameters" if keys(%args); $self->{_conf} = {}; if (-e $filename) { $self->_readconfig($filename, $self->{_conf}); } elsif ($defaults) { while (my ($k, $v) = each %$defaults) { $self->set(split(/\./, $k), $v); } } else { $self->error("configuration file \"$filename\" does not exist"); } $self->finalize; return $self; } sub finalize { my $self = shift; if ($self->success && exists($self->{_syntax})) { $self->_fixup($self->{_syntax}, $self->{_conf}); } } sub error { my ($self, $msg) = @_; push @{$self->{_errors}}, $msg; } sub errors { my $self = shift; if (wantarray) { return exists($self->{_errors}) ? (@{$self->{_errors}}) : (); } elsif (!exists($self->{_errors})) { return 0; } else { return 0 + @{$self->{_errors}}; } } sub clrerr { my $self = shift; delete $self->{_errors}; } sub success { my $self = shift; return $self->errors == 0; } sub _parse_section { my ($self, $conf, $input) = @_; my $quote; my $kw = $self->{_syntax} if exists $self->{_syntax}; 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 { error("unparsable input $input"); exit(2); } } if (defined($name)) { $conf->{$name} = {} unless ref($conf->{$name}) eq 'HASH'; $conf = $conf->{$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; } } else { $kw = undef; } $name = undef; } } return ($conf, $kw); } sub _readconfig { my ($self, $file, $conf) = @_; # debug(2, "reading $file"); open(my $fd, "<", $file) or do { $self->error("can't open configuration file $file: $!"); return; }; my $line; my $err; my $section = $conf; my $kw = $self->{_syntax}; my $include = 0; my $rootname; while (<$fd>) { ++$line; chomp; if (/\\$/) { chop; $_ .= <$fd>; redo; } s/^\s+//; s/\s+$//; s/#.*//; next if ($_ eq ""); if (/^\[(.+?)\]$/) { $include = 0; my $arg = $1; $arg =~ s/^\s+//; $arg =~ s/\s+$//; if ($arg eq 'include') { $include = 1; } else { ($section, $kw) = $self->_parse_section($conf, $1); if (exists($self->{_syntax}) && !defined($kw)) { $self->error("$file:$line: unknown section"); } } } elsif (/([\w_-]+)\s*=\s*(.*)/) { my ($k, $v) = ($1, $2); if ($include) { if ($k eq 'path') { $self->_readconfig($v, $conf); } elsif ($k eq 'pathopt') { $self->_readconfig($v, $conf) if -f $v; } elsif ($k eq 'glob') { foreach my $file (bsd_glob($v, 0)) { $self->_readconfig($file, $conf); } } else { $self->error("$file:$line: unknown keyword"); } next; } if (defined($kw)) { my $x = $kw->{$k}; if (!defined($x)) { $self->error("$file:$line: unknown keyword $k"); next; } elsif (ref($x) eq 'HASH') { if (exists($x->{re})) { if ($v !~ /$x->{re}/) { $self->error("$file:$line: invalid value for $k"); next; } } if (exists($x->{check})) { if (my $errstr = &{$x->{check}}($k, $v)) { $self->error("$file:$line: $errstr"); next; } } if (exists($x->{parser})) { if (my $errstr = &{$x->{parser}}($k, \$v)) { $self->error("$file:$line: $errstr"); next; } } if ($x->{array}) { if (exists($section->{$k})) { $v = [ @{$section->{$k}}, $v ]; } else { $v = [ $v ] } } } } $section->{$k} = $v; } else { $self->error("$file:$line: malformed line"); next; } } close $fd; } sub _is_section_ref { my ($ref) = @_; return ref($ref) eq 'HASH'; } sub _fixup { my ($self, $kw, $section, @path) = @_; while (my ($k, $d) = each %{$kw}) { if (ref($d) eq 'HASH') { if (exists($d->{default}) && !exists($section->{$k})) { $section->{$k} = $d->{default}; } if (exists($d->{section})) { if ($k eq '*') { while (my ($name, $vref) = each %{$section}) { if (_is_section_ref($vref)) { $self->_fixup($d->{section}, $vref, @path, $name); } } } else { my $temp; unless (exists $section->{$k}) { $section->{$k} = {} ; $temp = 1; } $self->_fixup($d->{section}, $section->{$k}, @path, $k); delete $section->{$k} if $temp && keys(%{$section->{$k}}) == 0; } } if ($d->{mandatory} && !exists($section->{$k})) { $self->error(exists($d->{section}) ? "mandatory section [" . join(' ', @path, $k) . "] not present" : "mandatory variable \"" . join('.', @path, $k) . "\" not set"); } } } } sub _getref { my $self = shift; return undef unless exists $self->{_conf}; my $ref = $self->{_conf}; for (@_) { carp "component undefined" unless defined $_; return undef unless exists $ref->{$_}; $ref = $ref->{$_}; } return $ref; } sub get { my $self = shift; if (my $ref = $self->_getref(@_)) { if (ref($ref) eq 'ARRAY') { if (wantarray) { return (@{$ref}); } else { return $ref->[0]; } } return $ref; } } sub isset { my $self = shift; return defined $self->_getref(@_); } sub set { my $self = shift; $self->{_conf} = {} unless exists $self->{_conf}; my $ref = $self->{_conf}; my $synt = $self->{_syntax}; # print "SET ".join('.',@_)."\n"; while (my $arg = shift) { if ($synt) { if (exists($synt->{$arg})) { $synt = $synt->{$arg}; } elsif (exists($synt->{'*'})) { $synt = $synt->{'*'}; } else { croak "no such component in syntax: $arg"; } } if (@_ == 1) { my $v = shift; if ($synt && ref($synt) eq 'HASH') { if ($synt->{array}) { if (exists($ref->{$arg})) { $v = [ @{$ref->{$arg}}, $v ]; } else { $v = [ $v ]; } } } $ref->{$arg} = $v; return; } if ($synt) { croak "component not a section: $arg" unless $synt->{section}; $synt = $synt->{section}; } $ref->{$arg} = {} unless exists $ref->{$arg}; $ref = $ref->{$arg}; } } 1;