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