1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
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;
|