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;
+
+