1# ConfigReader/Spec.pm: specifies a set of configuration directives
2#
3# Copyright 1996 by Andrew Wilcox <awilcox@world.std.com>.
4# All rights reserved.
5#
6# This library is free software; you can redistribute it and/or
7# modify it under the terms of the GNU Library General Public
8# License as published by the Free Software Foundation; either
9# version 2 of the License, or (at your option) any later version.
10#
11# This library is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14# Library General Public License for more details.
15#
16# You should have received a copy of the GNU Library General Public
17# License along with this library; if not, write to the Free
18# Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
19
20package ConfigReader::Spec;
21$VERSION = "0.5";
22
23my $This_file = __FILE__;       # used to get our filename out of error msgs
24
25require 5.001;
26use Carp;
27use strict;
28
29=head1 NAME
30
31ConfigReader::Spec
32
33=head1 DESCRIPTION
34
35The ConfigReader::Spec class stores a specification about
36configuration directives: their names, whether they are required or if
37they have default values, and what parsing function or method to use.
38
39=cut
40
41## Public methods
42
43sub new {
44    my ($class) = @_;
45    my $self = {directives => {},          # directive name => 1
46                alias_to_directive => {},  # map alias to name
47                default => {},             # name => default value
48                whence_default => {},      # name => source location of default
49                parser => {},              # name => value parser
50                name => {},                # name => 1, ignore this directive
51                required => {}             # name => 1, required directive
52            };
53    return bless $self, $class;
54}
55
56sub directives {
57    my ($self) = @_;
58    return keys %{$self->{'directives'}};
59}
60
61sub value {
62    my ($self, $directive, $values, $whence) = @_;
63    $directive = $self->canonical_name($directive);
64
65    my $name = $self->{'alias_to_directive'}{$directive};
66    $self->_error("Undefined directive '$directive'", $whence)
67        unless defined $name;
68
69    $self->_error("The directive '$directive' has not been assigned a value",
70                  $whence)
71        unless exists($values->{$name});
72
73    return $values->{$name};
74}
75
76
77sub alias {
78    my ($self, $directive, @aliases) = @_;
79    $directive = $self->canonical_name($directive);
80    my $alias;
81    foreach $alias (@aliases) {
82        $self->{'alias_to_directive'}{$self->canonical_name($alias)} =
83            $directive;
84    }
85}
86
87sub define_directive {
88    my ($self, $directive, $parser, $whence) = @_;
89
90    my ($name, @aliases);
91
92    my $ref = ref($directive);
93    if (defined $ref and $ref eq 'ARRAY') {
94        $name = shift @$directive;
95        @aliases = @$directive;
96    }
97    else {
98        $name = $directive;
99        @aliases = ($directive);
100    }
101    $name = $self->canonical_name($name);
102
103    $self->{'directives'}{$name} = 1;
104    $self->alias($name, @aliases);
105
106    if (defined $parser) {
107        $self->{'parser'}{$name} =
108            $self->_resolve_code($parser,
109                                 'specified as parser',
110                                 $whence);
111    }
112    else {
113        delete $self->{'parser'};
114    }
115
116    return $name;
117}
118
119sub required {
120    my ($self, $directive, $parser, $whence) = @_;
121
122    my $name = $self->define_directive($directive,
123                                       $parser,
124                                       $whence);
125    $self->{'required'}{$name} = 1;
126}
127
128
129sub directive {
130    my ($self, $directive, $parser, $default, $whence) = @_;
131
132    my $name = $self->define_directive($directive,
133                                       $parser,
134                                       $whence);
135    $self->{'default'}{$name} = $default;
136    $self->{'whence_default'}{$name} = $whence;
137    return $name;
138}
139
140sub ignore {
141    my ($self, $directive, $whence) = @_;
142
143    my $name = $self->define_directive($directive, undef, undef, $whence);
144    $self->{'ignore'}{$name} = 1;
145}
146
147sub assign {
148    my ($self, $directive, $value_string, $values, $whence) = @_;
149    $directive = $self->canonical_name($directive);
150
151    my $name = $self->{'alias_to_directive'}{$directive};
152    $self->undefined_directive($directive, $value_string, $whence)
153        unless defined $name;
154
155    return undef if $self->{'ignore'}{$name};
156
157    $self->duplicate_directive($directive, $value_string, $whence)
158        if defined $values and exists $values->{$name};
159
160    if (not defined $value_string) {
161        $values->{$name} = undef if defined $values;
162        return undef;
163    }
164
165    my $parser = $self->{parser}{$name};
166    my $value;
167
168    if (defined $parser) {
169        my @warnings = ();
170        local $SIG{'__WARN__'} = sub { push @warnings, $_[0] };
171        my $saved_eval_error = $@;
172        eval { $value = &$parser($value_string) };
173        my $error = $@;
174        $@ = $saved_eval_error;
175
176        my $warning;
177        foreach $warning (@warnings) {
178            $warning =~ s/ at $This_file line \d+$//o;  # uncarp
179            if (defined $whence) {
180                warn
181"While parsing '$value_string' as the value for the
182'$directive' directive as specified
183$whence,
184I got this warning:
185$warning";
186            }
187            else {
188                $warning =~ s/\n?$/\n/;
189                carp $warning .
190" while parsing '$value_string' as the value for the '$directive' directive";
191            }
192        }
193
194        if ($error) {
195            $error =~ s/ at $This_file line \d+$//o;  # uncroak
196            if (defined $whence) {
197                $whence =~ s,\n$,,;
198                die
199"I tried to parse '$value_string' as the value for the '$directive' directive as specified $whence
200but the following error occurred:
201
202$error";
203            }
204            else {
205                $error =~ s/\n?$/\n/;
206                croak $error."while parsing '$value_string' as the value for the '$directive' directive";
207            }
208        }
209    }
210    else {
211        $value = $value_string;
212    }
213
214    $values->{$name} = $value if defined $values;
215    return $value;
216}
217
218sub assign_defaults {
219    my ($self, $values, $whence) = @_;
220
221    my $name;
222    foreach $name ($self->directives()) {
223        $self->assign_default($name, $values, $whence);
224    }
225}
226
227sub assign_default {
228    my ($self, $directive, $values, $whence) = @_;
229    $directive = $self->canonical_name($directive);
230
231    my $name = $self->{'alias_to_directive'}{$directive};
232    $self->_error("Undefined directive '$directive'", $whence)
233        unless defined $name;
234
235    return $values->{$name} if defined $values and exists $values->{$name};
236
237    if ($self->{'required'}{$name}) {
238        $self->_error("Please specify the '$name' directive", $whence);
239    }
240    elsif ($self->{'ignore'}{$name}) {
241        return undef;
242    }
243
244    my $default = $self->{'default'}{$name};
245    # "as the default value "
246    my $whence_default = $self->{'whence_default'}{$name};
247    my $value;
248
249    if (not defined $default) {
250        return $self->assign($name, undef, $values, $whence_default);
251    }
252    elsif (not ref $default) {
253        return $self->assign($name, $default, $values, $whence_default);
254    }
255    elsif (ref($default) eq 'CODE') {
256        local $SIG{'__DIE__'} = sub {
257            $self->_error("$_[0]\nwhile assigning the default value for the '$name' directive", $whence_default);
258        };
259        $value = &$default();
260        $values->{$name} = $value if defined $values;
261        return $value;
262    }
263    else {
264        $value = $default;
265        $values->{$name} = $value if defined $values;
266        return $value;
267    }
268}
269
270## subclass hooks
271
272sub canonical_name {
273    my ($self, $directive) = @_;
274    return $directive;
275}
276
277sub undefined_directive {
278    my ($self, $directive, $value_string, $whence) = @_;
279
280    $self->_error("Unknown directive '$directive' specified", $whence);
281}
282
283sub duplicate_directive {
284    my ($self, $directive, $value_string, $whence) = @_;
285
286    $self->_error("Duplicate directive '$directive' specified", $whence);
287}
288
289
290## Internal methods
291
292# Allows the user to specify code to run in several different ways.
293# Returns a code ref that will run the desired code.
294#    'new URI::URL'       calls static method 'new' in class 'URI::URL'
295#    $coderef             calls the code ref
296#    [new => 'URI::URL']  calls new URI::URL
297#    [parse => $obj]      calls $obj->parse()
298
299sub _resolve_code {
300    my ($self, $sub, $purpose, $whence) = @_;
301    my ($r, $class, $static_method, $function);
302
303    $r = ref($sub);
304    if (not $r) {
305        if (($static_method, $class) = ($sub =~ m/^(\w+) \s+ ([\w:]+)$/x)) {
306            return sub {
307                $class->$static_method(@_);
308            };
309        }
310        else {
311            $self->_error("Syntax error in function name '$sub' $purpose",
312                          $whence);
313        }
314    }
315    elsif ($r eq 'CODE') {
316        return $sub;
317    }
318    elsif ($r eq 'ARRAY') {
319        my ($method, $class_or_obj) = @$sub;
320        $self->_error("Empty array used to $purpose", $whence)
321            unless defined $method;
322        $self->_error("Class or object not specified in array used to $purpose",
323                      $whence)
324            unless defined $class_or_obj;
325        return sub {
326            $class_or_obj->$method(@_);
327        };
328    }
329    else {
330        $self->_error("Unknown object $purpose", $whence);
331    }
332}
333
334sub _error {
335    my ($self, $msg, $whence) = @_;
336
337    if (defined $whence) {
338        $whence =~ s,\n?$,\n,;
339        die "$msg $whence";
340    }
341    else {
342        croak $msg;
343    }
344}
345
3461;
347