"Fossies" - the Fresh Open Source Software Archive

Member "sendpage-1.001001/lib/Sendpage/KeesConf.pm" (3 Jan 2008, 14079 Bytes) of package /linux/privat/old/sendpage-1.001001.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "KeesConf.pm" see the Fossies "Dox" file reference documentation.

    1 package Sendpage::KeesConf;
    2 
    3 # KeesConf.pm implements a quick-and-dirty configfile parser
    4 #
    5 # $Id: KeesConf.pm 224 2006-08-27 17:55:05Z keescook $
    6 #
    7 # Copyright (C) 2000-2004 Kees Cook
    8 # kees@outflux.net, http://outflux.net/
    9 #
   10 # This program is free software; you can redistribute it and/or
   11 # modify it under the terms of the GNU General Public License
   12 # as published by the Free Software Foundation; either version 2
   13 # of the License, or (at your option) any later version.
   14 #
   15 # This program is distributed in the hope that it will be useful,
   16 # but WITHOUT ANY WARRANTY; without even the implied warranty of
   17 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   18 # GNU General Public License for more details.
   19 #
   20 # You should have received a copy of the GNU General Public License
   21 # along with this program; if not, write to the Free Software
   22 # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
   23 # <URL:http://www.gnu.org/copyleft/gpl.html>
   24 
   25 use strict;
   26 use warnings;
   27 
   28 use Carp;
   29 
   30 =head1 NAME
   31 
   32 Sendpage::KeesConf - implements a configuration file reader
   33 
   34 =head1 SYNOPSIS
   35 
   36  use Sendpage::KeesConf;
   37  $config = Sendpage::KeesConf->new();
   38 
   39  $config->define("variable", { DEFAULT => "setting" });
   40 
   41  $config->file("config.cfg");
   42 
   43  $setting = $config->get("variable");
   44 
   45 =head1 DESCRIPTION
   46 
   47 I have borrowed VERY heavily from Andy Wardley's (abw@cre.canon.co.uk)
   48 C<AppConfig> tool, which can be found on CPAN (http://cpan.perl.org) but
   49 I found it not dynamic enough for multi-instance variable defaults.  As
   50 a result, I wrote this massively trimmed-down version for my use.
   51 
   52 The following methods are available:
   53 
   54 =over 4
   55 
   56 =cut
   57 
   58 # off-limits chars in section names are    : @ =
   59 #
   60 # -Kees
   61 
   62 # argument count types
   63 my $ARGCOUNT_NONE  = 0;
   64 my $ARGCOUNT_ONE   = 1;
   65 my $ARGCOUNT_LIST  = 2;
   66 #$ARGCOUNT_HASH  = 3;
   67 
   68 =item $config = Sendpage::KeesConf->new();
   69 
   70 The constructor doesn't take an arguement, but it should in the future.
   71 
   72 =cut
   73 
   74 sub new
   75 {
   76     my $proto = shift;
   77     my $class = ref($proto) || $proto;
   78     my $self  = { };
   79 
   80     # get our args
   81     my $config = shift;     # Hmmm, where does this go???
   82 
   83     $self->{DEFAULTS} = undef;
   84     $self->{KNOWN}    = undef;
   85 
   86     return bless $self => $class;
   87 }
   88 
   89 =item $config->forget();
   90 
   91 This call will make $config forget about any variables it has loaded.
   92 It does NOT forget C<define>d variables, just instantiated ones via
   93 C<file>.
   94 
   95 =cut
   96 
   97 # forget all configurations
   98 sub dump
   99 {
  100     my $self          = shift;
  101     $self->{KNOWN}    = undef;
  102     $self->{SECTIONS} = undef;
  103 }
  104 
  105 =item $config->define($name, $options);
  106 
  107 This will define a variable by the name of $name.
  108 
  109 $options can contain:
  110 
  111 =over 4
  112 
  113 =item ARGCOUNT
  114 
  115 What type of variable this should be.  Default value is "1".  The
  116 available types are:
  117 
  118 =over 4
  119 
  120 =item 0
  121 
  122 Boolean (true/false, yes/no, 1/0)
  123 
  124 =item 1
  125 
  126 Scalar (any string)
  127 
  128 =item 2
  129 
  130 List (an array of strings)
  131 
  132 =back
  133 
  134 =item DEFAULT
  135 
  136 The default value the variable should have if it is not overridden
  137 during the call to C<file>.  The DEFAULT must be the same data type as
  138 ARGCOUNT.  The default DEFAULT is the string "<unset>".
  139 
  140 =item UNSET
  141 
  142 set this to 1 if you want the default value to be undefined.  This is
  143 a hack to get around the default DEFAULT.
  144 
  145 =back
  146 
  147 =cut
  148 
  149 # define a variable
  150 sub define
  151 {
  152     my $self          = shift;
  153     my ($name, $vars) = @_;
  154 
  155     my $default;
  156 
  157     $self->{DEFAULTS}->{$name}->{ARGCOUNT} = defined($vars->{ARGCOUNT})
  158     ? $vars->{ARGCOUNT} : $ARGCOUNT_ONE;
  159     if ($self->{DEFAULTS}->{$name}->{ARGCOUNT} == $ARGCOUNT_LIST) {
  160     $self->{DEFAULTS}->{$name}->{DEFAULT} = defined($vars->{DEFAULT})
  161         ? $vars->{DEFAULT} : undef;
  162     } else {
  163     $self->{DEFAULTS}->{$name}->{DEFAULT} = defined($vars->{DEFAULT})
  164         ? $vars->{DEFAULT} : "<unset>";
  165     }
  166 
  167     undef $self->{DEFAULTS}->{$name}->{DEFAULT}
  168     if defined $vars->{UNSET};
  169 
  170     #   warn "'$name' defined with '".$self->{DEFAULTS}->{$name}->{ARGCOUNT}.
  171     #       "' and '".$self->{DEFAULTS}->{$name}->{DEFAULT}."'\n";
  172 
  173 }
  174 
  175 =item $config->instance_exists($name);
  176 
  177 This tests to see if there is a section loaded named $name
  178 
  179 =cut
  180 
  181 # check to see if a section exists in the KNOWN space
  182 sub instance_exists
  183 {
  184     my ($self, $name) = @_;
  185 
  186     #warn "\tchecking for instance: '$name'\n";
  187 
  188     my (%hash, $thing);
  189 
  190     foreach $thing (@{ $self->{SECTIONS} }) {
  191     $hash{$thing} = 1;
  192     #warn "\t\tI have: '$thing'\n";
  193     }
  194 
  195     return defined $hash{$name};
  196 }
  197 
  198 =item $var = $config->ifset($name);
  199 
  200 This call will search for the variable named $name.  If it is not found,
  201 it will return undef.  If the value exists, it will return the value.
  202 This is a way to call "get" without having a default passed through.
  203 
  204 =cut
  205 
  206 sub ifset
  207 {
  208     my $self    = shift;
  209     my ($whole) = @_;
  210 
  211     return $self->exists($whole) ? $self->get($whole) : undef;
  212 }
  213 
  214 =item $var = $config->exists($name);
  215 
  216 This call will search for the variable named $name.  If it is not found,
  217 it will return false.  If the value exists, it will return true.  This is
  218 a way for the user to find out if they will get a "default" on a call
  219 to "get".
  220 
  221 =cut
  222 
  223 # return a variable or default for that variable
  224 sub exists
  225 {
  226     my $self    = shift;
  227     my ($whole) = @_;
  228 
  229     return defined $self->{KNOWN}->{$whole};
  230 }
  231 
  232 =item $var = $config->fallbackget($name,$quiet);
  233 
  234 This call will search for the variable named $name.  If it is not found,
  235 the section portion will be removed, and retried for a sectionless "get"
  236 call.
  237 
  238 That way, global variables can be overridden by section-specific
  239 variables.  If "SECTION:Instance@name" does not exist, "name" will be
  240 tried.
  241 
  242 =cut
  243 
  244 sub fallbackget
  245 {
  246     my $self        = shift;
  247     my ($whole, $quiet) = @_;
  248     my ($class, $instance, $name, $var);
  249 
  250     #warn "trying '$whole'...\n";
  251     $var = $self->get($whole, 1);
  252     unless (defined $var) {
  253     ($class, $instance, $name) = $self->breakdown($whole);
  254     #warn "now trying '$name'...\n";
  255     $var = $self->get($name, $quiet);
  256     }
  257     return $var;
  258 }
  259 
  260 
  261 =item $var = $config->get($name);
  262 
  263 This call will search for the variable named $name.  If it is not found,
  264 it will fall back to the default for the section.  Sections are
  265 explained in more detail later.
  266 
  267 =cut
  268 
  269 # return a variable or default for that variable
  270 sub get
  271 {
  272     my $self        = shift;
  273     my ($whole, $quiet) = @_;
  274     my ($name, $class, $instance, $var, @parts);
  275 
  276     # Vars can be in CLASS:Instance@variable format
  277     # knowns use the entire name,
  278     # defaults use CLASS:variable format
  279 
  280     undef $name;        # hmm, redundant?
  281     #warn "asking for '$whole'\n";
  282 
  283     my $value = $self->{KNOWN}->{$whole};
  284 
  285     unless (defined $value) {
  286     # save our original value
  287     $name = $whole;
  288 
  289     ($class, $instance, $name) = $self->breakdown($name);
  290 
  291     # reduce our variable to just class/var
  292     $whole = sprintf("%s$name", $class ? "$class:" : "");
  293 
  294     #warn "getting default for '$whole'\n";
  295     my $def = $self->{DEFAULTS}->{$whole};
  296     if (!defined($def) && $class) {
  297         $def = $self->{DEFAULTS}->{"$class:"};
  298     }
  299     if (defined($def)) {
  300         # getting classed default
  301         #warn "found default for '$whole'\n";
  302         $value = $def->{DEFAULT};
  303     }
  304     }
  305 
  306     if (!defined($value) && !$quiet) {
  307     croak "'$whole' not defined";
  308     }
  309 
  310     return $value;
  311 }
  312 
  313 =item $config->instances($class);
  314 
  315 Returns an array of the names of all the variables in the class $class.
  316 
  317 =cut
  318 
  319 sub instances
  320 {
  321     my $self    = shift;
  322     my ($class) = @_;
  323     my @array   = sort @{ $self->{SECTIONS} };
  324 
  325     return grep(s/^${class}://, @array); # hmm, shouldn't this be map()?
  326 }
  327 
  328 =item $config->file('program.cfg');
  329 
  330 Loads variables from the named file.  Syntax for this file is:
  331 
  332     [SECTION:INSTANCE]
  333     VARIABLE1 = VALUE1
  334     VARIABLE2 = VALUE2
  335     .
  336     .
  337     .
  338 
  339 If VARIABLE is an array, VALUE is loaded using commas (,) as the
  340 list separator.  The variable will be available under the name of the
  341 section.  For example, to see VALUE2, it would be accessed as:
  342 
  343     $config->get("SECTION:INSTANCE\@VARIABLE2");
  344 
  345 Notice, that "=", ":", and "@" are all not allowed in section or
  346 variable names.
  347 
  348 =cut
  349 
  350 # load variables from a file
  351 sub file
  352 {
  353     my $self     = shift;
  354     my $filename = shift;
  355     my (@lines, @merged, $line);
  356 
  357     # for parsing, I prefer this methodology:
  358     #   1) strip all lines starting with a "#"
  359     #   2) join any lines that have a "\" as the last character
  360     #   3) drop any blank lines
  361     #   4) parse, one line at a time
  362 
  363     open FILE, "< $filename" or die "Cannot read '$filename'\n";
  364     @lines = grep(!/^\s*#/, <FILE>); # drop any lines starting with #
  365     close FILE;
  366 
  367     # merge any line with a trailing \
  368     undef @merged;
  369     undef $line;
  370     while ($#lines >= 0) {
  371     $line =shift @lines;
  372     chomp $line;        # drop crs
  373     while ($line =~ /\\$/ && $#lines >= 0) {
  374         $line .= shift @lines;
  375     }
  376     push @merged, $line;
  377     undef $line;
  378     }
  379 
  380     @lines = grep(!/^\s*$/, @merged); # drop any blank lines
  381 
  382     my $section = "";
  383 
  384     foreach $line (@lines) {
  385     #warn "saw line '$line'\n";
  386     my ($token, $value) = split(/=/, $line, 2);
  387 
  388     # drop any white-space surrounding the token
  389     $token =~ s/^\s*//;
  390     $token =~ s/\s*$//;
  391 
  392     if ($token =~ /^\[([^\]]+)\]/) {
  393         $section = $1;
  394         # drop any white-space surrounding the section
  395         $section =~ s/^\s*//;
  396         $section =~ s/\s*$//;
  397         # clean up section name (no @s)
  398         $section =~ s/\@//g;
  399 
  400         #warn "saw section '$section'\n";
  401         if ($self->instance_exists($section)) {
  402         $main::log->do('warning',
  403                    "section '$section' already defined -- merging!");
  404         } else {
  405         push @{ $self->{SECTIONS} }, $section;
  406         }
  407 
  408         $section .= "\@";
  409 
  410         next;
  411     }
  412 
  413     # drop any white-space surrounding the value
  414     $value =~ s/^\s*//;
  415     $value =~ s/\s*$//;
  416 
  417     # drop any quotes (not really syntax-smart, ya know?)
  418     $value =~ s/^"//;
  419     $value =~ s/"$//;
  420 
  421     # add our section header
  422     $token = "${section}${token}";
  423 
  424     #warn "token: '$token' value: '$value'\n";
  425     # now our token/values are "clean".  Let's insert them
  426     # into our various structures
  427 
  428     #warn "Checking on defaults for '$token'\n";
  429     my ($class, $instance, $name) = $self->breakdown($token);
  430     #warn "got '$class' : '$instance' \@ '$name'\n";
  431     # reduce our variable to just class/var
  432     my $whole = sprintf("%s$name", $class ? "$class:" : "");
  433 
  434     #warn "Checking on defaults for '$whole'\n";
  435 
  436     my $def = $self->{DEFAULTS}->{$whole};
  437     if (!defined($def) && $class) {
  438         $def = $self->{DEFAULTS}->{"$class:"};
  439         #warn "tried '$class:'\n";
  440     }
  441     if (defined($def)) {
  442         if ($def->{ARGCOUNT} == $ARGCOUNT_NONE) {
  443         if ($value =~ /^[ty1]/i) {
  444             $self->{KNOWN}->{$token} = 1;
  445             #warn "stored '$token' as '1'\n";
  446         } elsif ($value =~ /^[fn0]/i) {
  447             $self->{KNOWN}->{$token} = 0;
  448             #warn "stored '$token' as '0'\n";
  449         } else {
  450             $main::log->do('warning',
  451                    "value for '$token' not true/false, yes/no, 1/0");
  452         }
  453         } elsif ($def->{ARGCOUNT} == $ARGCOUNT_ONE) {
  454         $self->{KNOWN}->{$token} = $value;
  455                 #warn "stored '$token' as '$value'\n";
  456         } elsif ($def->{ARGCOUNT} == $ARGCOUNT_LIST) {
  457                 #warn "adding to '$token'\n";
  458         my @parts = split /[\s,]+/, $value;
  459         my $item;
  460         foreach $item (@parts) {
  461             # drop white space
  462             $item =~ s/^\s*//;
  463             $item =~ s/\s*$//;
  464             #warn "\t'$item'\n";
  465             push @{ $self->{KNOWN}->{$token} }, $item;
  466         }
  467         } else {
  468         $main::log->do('warning',
  469                    "default for '$whole' has strange ARGCOUNT");
  470         }
  471     } else {
  472         $main::log->do('warning',
  473                "unknown variable '$token' found in file '$filename'");
  474     }
  475     }
  476 
  477     return 1;
  478 }
  479 
  480 # "dangerous" hack to set a variable
  481 sub set
  482 {
  483     my($self, $var, $value) = @_;
  484 
  485     $self->{KNOWN}->{$var} = $value;
  486 }
  487 
  488 # breakdown a variable name into class, instance, and variable
  489 #
  490 #   input string: "CLASS:INSTANCE@NAME" where "CLASS:" is optional
  491 #           and "INSTANCE@" is optional
  492 #
  493 sub breakdown
  494 {
  495     my $self   = shift;
  496     my ($name) = @_;
  497     my (@parts, $class, $instance);
  498 
  499     # strip off the class, if it exists
  500     @parts = split(/:/, $name, 2);
  501     $class = $parts[0];
  502     if ($class eq $name) {
  503     undef $class;
  504     } else {
  505     #warn "class: '$class'\n";
  506     $name = $parts[1];
  507     }
  508 
  509     # strip off the instance if it exists
  510     @parts = split(/\@/, $name, 2);
  511     $instance = $parts[0];
  512     if ($instance eq $name) {
  513     undef $instance;
  514     } else {
  515     #warn "instance: '$instance'\n";
  516     $name = $parts[1];
  517     }
  518 
  519     return ($class,$instance,$name);
  520 }
  521 
  522 1;              # This is a module
  523 
  524 __END__
  525 
  526 =back
  527 
  528 Sections can be defined (and loaded) so that defaults can pass back to a
  529 defined section default.  For example, lets say that you have several
  530 modems, and most of them have different settings.  You can define all
  531 the modem variables like so:
  532 
  533     $config->define("modem:baud",{ DEFAULT => 9600 });
  534     $config->define("modem:flowctl",{ DEFAULT => "hardware" });
  535 
  536 Then, when you load them, let's say the config file has:
  537 
  538     [modem:sportster]
  539     baud = 115200
  540 
  541     [modem:hayes]
  542 
  543 The baud rate for the sportster will come back as 115200, but the hayes
  544 will fall back during a C<get> call, and find the default for the modem
  545 section: 9600.  Both fallback to have "flowctl" as "hardware":
  546 
  547     # returns specific value 115200
  548     $config->get("modem:sportster\@baud");
  549 
  550     # returns default value 9600
  551     $config->get("modem:hayes\@baud");
  552 
  553     # both return default value "hardware"
  554     $config->get("modem:sportster\@flowctl");
  555     $config->get("modem:hayes\@flowctl");
  556 
  557 =head1 CAVEATS
  558 
  559 =over 4
  560 
  561 =item character limitations
  562 
  563 As mentioned above, variable names (and section names) cannot have the
  564 characters ":", "@", or "=" in them.
  565 
  566 =item default defaults
  567 
  568 There should be a way to pass default defaults into C<new>.  That would
  569 be handy, and could eliminate the need for the UNSET option in C<define>.
  570 
  571 =back
  572 
  573 =head1 AUTHOR
  574 
  575 Kees Cook <kees@outflux.net>
  576 
  577 =head1 SEE ALSO
  578 
  579 Man pages: L<perl>, L<sendpage>.
  580 
  581 Module documentation: L<Sendpage::KeesLog>, L<Sendpage::Modem>,
  582 L<Sendpage::PagingCentral>, L<Sendpage::PageQueue>, L<Sendpage::Page>,
  583 L<Sendpage::Recipient>, L<Sendpage::Queue>.
  584 
  585 =head1 COPYRIGHT
  586 
  587 Copyright 2000 Kees Cook.
  588 
  589 This library is free software; you can redistribute it and/or
  590 modify it under the same terms as Perl itself.
  591 
  592 =cut