aboutsummaryrefslogtreecommitdiff
path: root/lib/Config/Parser.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Config/Parser.pm')
-rw-r--r--lib/Config/Parser.pm116
1 files changed, 116 insertions, 0 deletions
diff --git a/lib/Config/Parser.pm b/lib/Config/Parser.pm
new file mode 100644
index 0000000..c0a2179
--- /dev/null
+++ b/lib/Config/Parser.pm
@@ -0,0 +1,116 @@
+package Config::Parser;
+use strict;
+use warnings;
+use parent 'Config::Tree';
+use Carp;
+use Cwd qw(abs_path);
+use Text::ParseWords;
+use Class::Inspector;
+
+our $VERSION = "1.00";
+
+sub new {
+ my $class = shift;
+ local %_ = @_;
+
+ my @parseargs;
+ if (my $filename = delete $_{filename}) {
+ push @parseargs, $filename;
+ foreach my $k (qw(fh line)) {
+ if (my $v = delete $_{$k}) {
+ push @parseargs, ($k, $v);
+ }
+ }
+ }
+
+ unless ($_{parameters}) {
+ my $subs = Class::Inspector->subclasses(__PACKAGE__);
+ if ($subs) {
+ $_{parameters} = {};
+ foreach my $c (@$subs) {
+# print "LOADING FROM $c\n";
+ if (my $s = loadsynt($c)) {
+ $_{parameters} = { %{$_{parameters}}, %$s };
+ }
+ last if $c eq $class;
+ }
+ delete $_{parameters} unless keys %{$_{parameters}};
+ }
+ }
+
+ my $self = $class->SUPER::new(%_);
+
+ if (@parseargs) {
+ $self->parse(@parseargs);
+ $self->commit or croak "configuration failed";
+ }
+
+ return $self;
+}
+
+sub findsynt {
+ my $class = shift;
+ my $file = $class;
+ $file =~ s{::}{/}g;
+ $file .= '.pm';
+ $file = abs_path($INC{$file})
+ or croak "can't find module file for $class";
+ local ($/, *FILE);
+ open FILE, $file or croak "Can't open $file";
+ my ($text, $data) = split /(?m)^__DATA__$/, <FILE>, 2;
+ close FILE;
+
+ return () unless $data;
+ return ($file, 1+($text =~ tr/\n//), $data);
+}
+
+sub loadsynt {
+ my ($class) = @_;
+ if (my ($file, $line, $data) = findsynt($class)) {
+ open(my $fh, '<', \$data);
+ my $d = $class->new(filename => $file,
+ fh => $fh,
+ line => $line,
+ parameters => { '*' => '*' })
+ or croak "Failed to parse template at $file:$line";
+ close $fh;
+ $d->as_hash(sub {
+ my ($what, $name, $val) = @_;
+ $name = '*' if $name eq 'ANY';
+ if ($what eq 'section') {
+ $val->{section} = {};
+ if ($name =~ s/:mandatory$//) {
+ $val->{mandatory} = 1;
+ }
+ ($name, $val->{section});
+ } else {
+ my @words = parse_line('\s+', 0, $val);
+ my $ret = {};
+ $val = shift @words;
+
+ if ($val eq 'STRING') {
+ # nothing
+ } elsif ($val eq 'NUMBER') {
+ $ret->{re} = '\d+';
+ } elsif ($val eq 'OCTAL') {
+ $ret->{re} = '[0-7]+';
+ } elsif ($val eq 'HEX') {
+ $ret->{re} = '([0-9][A-Fa-f])+';
+ } else {
+ unshift @words, $val;
+ }
+
+ while (($val = shift @words)
+ && $val =~ /^:(?<kw>.+?)(?:\s*=\s*(?<val>.*))?$/) {
+ $ret->{$+{kw}} = $+{val} // 1;
+ }
+ $ret->{default} = $val if $val;
+ ($name, $ret);
+ }
+ })->{section};
+ }
+}
+
+1;
+
+

Return to:

Send suggestions and report system problems to the System administrator.