File Coverage

blib/lib/Config/Manager/Conf.pm

Criterion	Covered	Total	%
statement	262	307	85.3
branch	130	166	78.3
condition	76	119	63.8
subroutine	23	25	92.0
pod	0	13	0.0
total	491	630	77.9

###############################################################################
##                                                                           ##
##    Copyright (c) 2003 by Steffen Beyer & Gerhard Albers.                  ##
##    All rights reserved.                                                   ##
##                                                                           ##
##    This package is free software; you can redistribute it                 ##
##    and/or modify it under the same terms as Perl itself.                  ##
##                                                                           ##
###############################################################################

package Config::Manager::Conf;

################################################################################
# Im- und Exporte
################################################################################

use strict;
use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION %INC %SIG );

require Exporter;

@ISA = qw(Exporter);

@EXPORT = qw();

@EXPORT_OK = qw( whoami );

%EXPORT_TAGS = (all => [@EXPORT_OK]);

$VERSION = '1.7';

################################################################################
# Datenstrukturen
################################################################################

# Programminterne Konstanten

# Pattern zur Beschreibung von "privaten" Dateien (Sonderbehandlung)
my $PRIVATE  = "\\bPRIVATE?\\.ini\$";

# Besondere Datenquellen
my @WHOAMI   = qw( USERNAME LOGNAME USER LOGIN );
my $USR      = '';
my $SYS      = '';
my $EXT      = '';
# Sections
my $ENV      = 'ENV';
my $SPECIAL  = 'SPECIAL';
my $DEFAULT  = 'DEFAULT';
# Keys
my $SCOPE    = 'SCOPE';
my $NEXTCONF = 'NEXTCONF';
my $YEAR     = 'YEAR';
my $MONTH    = 'MONTH';
my $DAY      = 'DAY';
my $HOUR     = 'HOUR';
my $MIN      = 'MIN';
my $SEC      = 'SEC';
my $YDAY     = 'YDAY';
my $WDAY     = 'WDAY';
my $YY       = 'YY';
my $CC       = 'CC';
my $OS       = 'OS';
my $PERL     = 'PERL';
my $HOME     = 'HOME';
my $WHOAMI   = 'WHOAMI';
# Verarbeitungszustaende
my $RAW      = 1;
my $PENDING  = 2;
my $CACHED   = 3;
# Sonstige Konstanten
my $NONE     = 'NONE';

my $SYNTAX   = 'Syntax error';
my $INFINITE = 'Infinite recursion';

my $anchor;

my $default = Config::Manager::Conf->new();

################################################################################
# Oeffentliche Funktionen
################################################################################

sub whoami
{
    my($key,$value);

    foreach $key (@WHOAMI)
    {
        if (defined ($value = $ENV{$key})) { return ($value,$key); }
    }
    return ();
}

################################################################################
# Oeffentliche Methoden
################################################################################

sub add {
    my $self = shift;
    ref($self) || ($self = $default);
    local($_); # because of foreach
    foreach (@_) {
        next if (!(-r $_) && /$PRIVATE/io);
        open(FILE, $_) || return $self->_error("Unable to open file '$_':\n$!");
        my @lines = ;
        close(FILE) || return $self->_error("Unable to close file '$_':\n$!");
        $self->_add($_, \@lines) || return undef;
    }
    return 1;
}

sub default {
    return $default;
}

sub error {
    my $self = shift;
    ref($self) || ($self = $default);
    return $$self{''};
}

sub get {
    my $self = shift;
    ref($self) || ($self = $default);
    my $key = pop;
    my $section = pop || $DEFAULT;
    my $state = $$self{$section}{$key}{'state'};
    my $value;
    local($@); # because of eval{}; and parse()
    unless ($state) {
        return $ENV{$key} if $section eq $ENV && defined $ENV{$key};
        if ($section eq $SPECIAL &&
            ($key eq $WHOAMI || $key eq $HOME)) {
            $$self{$section}{$key}{'source'} = $SYS;
            $$self{$section}{$key}{'line'} = 0;
            unless (($value) = &whoami()) {
                return $self->_error( _not_found_($SPECIAL,$WHOAMI) );
            }
            return $value if $key eq $WHOAMI;
            {
                local($SIG{'__DIE__'}) = 'DEFAULT';
                eval {
                    ($value) = (getpwnam($value))[7];
                };
            }
            if ($@) {
                $value = $@;
                $value =~ s!\s+$!!;
                $value .= " on this platform" if ($value =~ s!\s+at\s+\S.+$!!);
                return $self->_error($value);
            }
            return $value if defined $value;
        }
        return $self->_error( _not_found_($section,$key) );
    }
    $value = $$self{$section}{$key}{'value'};
    return $value if $state == $CACHED;
    if ($state == $PENDING) {
        my $text   = _name_($section,$key) . " = \"$value\"";
        my $source = $$self{$section}{$key}{'source'};
        my $line   = $$self{$section}{$key}{'line'};
        return $self->_error($INFINITE, $text, $section, $source, $line);
    }
    $$self{$section}{$key}{'state'} = $PENDING;
    if (defined ($value = $self->parse($value, $section))) {
        $$self{$section}{$key}{'value'} = $value;
        $$self{$section}{$key}{'state'} = $CACHED;
        return $value;
    }
    else {
        $$self{''} = $@;
        $$self{$section}{$key}{'state'} = $RAW;
        return undef;
    }
}

sub init {
    my $self = shift;
    my $scope = shift || $DEFAULT;
    my $base = __PACKAGE__;
    ref($self) || ($self = $default);
    $self->_init();
    # Wenn Ankerdatei unbekannt bzw. nicht vorhanden bzw. leer: Neu ermitteln
    unless ($anchor && (-f $anchor) && (-r $anchor) && (-s $anchor)) {
        # Anker ist die Datei "Conf.ini", die im selben Verzeichnis wie die
        # Moduldatei "Conf.pm" selbst liegt; dazu wird %INC herangezogen.
        $base =~ s!::!/!g;
        $anchor = $INC{"$base.pm"};
        $anchor =~ s!\.pm$!.ini!;
        unless ($anchor && (-f $anchor) && (-r $anchor) && (-s $anchor)) {
            $anchor = undef;
            return $self->_error("Can't locate '$base.ini' in %INC");
        }
    }
    return $self->set($SYS, $SPECIAL, $SCOPE, $scope) && $self->add($anchor);
}

sub new {
    my $this = shift;
    my $class = ref($this) || $this || __PACKAGE__;
    my $self = {};
    bless $self, $class;
    return $self->_init();
}

sub parse {
    my($self,$text,$eval) = @_;
    my($left,$right,$first,$var);
    $@ = '';
    return $text unless $text =~ /\$/;
    $left = $`;
    $right = $';
    if (length($right) == 0) {
        $@ = "illegal '\$' at end of string";
        return undef;
    }
    $first = substr($right,0,1);
    if ($first eq '$') {
        $left .= '$' unless $eval;
        return undef unless defined($right = $self->parse(substr($right,1),$eval));
        return $left . '$' . $right;
    }
    else {
        return undef unless (($var,$right) = $self->_parse_var($first,$right,$eval));
        return undef unless defined($right = $self->parse($right,$eval));
        return $left . $var . $right;
    }
}

sub scope {
    my $self = shift;
    ref($self) || ($self = $default);
    return $self->get($SPECIAL, $SCOPE);
}

sub set {
    my $self = shift;
    ref($self) || ($self = $default);
    my $value   = pop;
    my $key     = pop;
    my $section = pop || $DEFAULT;
    my $source  = pop || $USR;
    return $self->_error( _read_only_($SPECIAL,$key) )
        if ($section eq $SPECIAL && $source ne $SYS &&
        ($key eq $OS || $key eq $PERL || $key eq $SCOPE));
    return $self->_set($source, 0, $section, $key, $value, 1);
}

sub get_all {
    my $self = shift;
    my $list = [];
    ref($self) || ($self = $default);
    foreach my $sec (sort keys(%{$self})) {
        next unless
            (($sec =~ /^[a-zA-Z][a-zA-Z0-9_-]*$/) &&
            (substr($sec,-1) ne '-'));
        foreach my $key (sort keys(%{${$self}{$sec}})) {
            my $val = $self->get($sec,$key);
            my $ok = 1;
            unless (defined $val) {
                $val = $self->error();
                $val =~ s!\s+$!!;
                $ok = 0;
            }
            push(
                @{$list},
                [
                    $ok,
                    _name_($sec,$key),
                    $val,
                    $$self{$sec}{$key}{'source'},
                    $$self{$sec}{$key}{'line'}
                ]
            );
        }
    }
    foreach my $key (sort keys(%ENV)) {
        push(
            @{$list},
            [
                1,
                _name_($ENV,$key),
                $ENV{$key},
                $EXT,
                0
            ]
        );
    }
    return $list;
}

sub get_section {
    my $self = shift;
    my $sec = shift || $DEFAULT;
    my $hash = {};
    ref($self) || ($self = $default);
    foreach my $key (keys %{${$self}{$sec}}) {
        my $val = $self->get($sec,$key);
        if (defined $val)
        {
            ${$hash}{$key} = $val;
        }
#       else
#       {
#           $val = $self->error();
#           $val =~ s!\s+$!!;
#           ${$hash}{$key} = $val;
#       }
    }
    return $hash;
}

sub get_files {
    return [ @{shift->{''}} ];
}

################################################################################
# Private Methoden
################################################################################

sub _init {
    my $self = shift;
    # Alle frueheren Eintraege loeschen:
    %{$self} = ();
    # Liste der eingelesenen Dateien anlegen:
    $$self{''} = [];
    # Datumsangaben fuer SPECIAL-Section aus localtime() holen:
    my @localtime = localtime();
    # Jahresangabe bezieht sich auf das Basisjahr 1900:
    $localtime[5] += 1900;
    # Monat ist im Bereich 0-11, daher eins addieren:
    $localtime[4]++;
    # Der erste Januar ist in localtime() der nullte Tag, daher eins addieren:
    $localtime[7]++;
    # Der Wochentag Sonntag ist in localtime() mit Null kodiert:
    $localtime[6] = 7 unless ($localtime[6]);
    # Tag und Monat zweistellig fuer eindeutige Zeitstempel (2000123 kann der
    # 3. Dezember oder der 23. Januar sein); Tag des Jahres dreistellig:
    $self->set($SYS, $SPECIAL, $YEAR,  $localtime[5]);
    $self->set($SYS, $SPECIAL, $MONTH, sprintf('%02d',$localtime[4]));
    $self->set($SYS, $SPECIAL, $DAY,   sprintf('%02d',$localtime[3]));
    $self->set($SYS, $SPECIAL, $HOUR,  sprintf('%02d',$localtime[2]));
    $self->set($SYS, $SPECIAL, $MIN,   sprintf('%02d',$localtime[1]));
    $self->set($SYS, $SPECIAL, $SEC,   sprintf('%02d',$localtime[0]));
    $self->set($SYS, $SPECIAL, $YDAY,  sprintf('%03d',$localtime[7]));
    $self->set($SYS, $SPECIAL, $WDAY,                 $localtime[6] );
    $self->set($SYS, $SPECIAL, $YY,    sprintf('%02d',$localtime[5]%100));
    $self->set($SYS, $SPECIAL, $CC,    int($localtime[5]/100));
    $self->set($SYS, $SPECIAL, $OS,    $^O);
    $self->set($SYS, $SPECIAL, $PERL,  $^X);
    $self->set($SYS, $SPECIAL, $SCOPE, $NONE);
    return $self;
}

sub _add {
    my($self,$file,$list) = @_;
    my $line = 0;
    my $section = $DEFAULT;
    my $scope = $self->scope();
    my $next = '';
    my @next = ();
    local($_); # because of foreach
    local($@); # because of parse()
    push( @{$$self{''}}, $file );
    foreach (@$list) {
        $line++;
        # Leerzeilen und Kommentarzeilen ignorieren
        /^\s*(\S)/ && $1 ne '#' || next;
        # Leerzeichen und Zeilenumbruch vom Zeilenende entfernen
        s/\s+$//;
        # Neuer Abschnitt?
        if (/^\s*\[\s*([a-zA-Z][a-zA-Z0-9_-]*)\s*\]$/ && substr($1,-1) ne '-') {
            $section = $1;
            next;
        }
        # Text in Schluessel und Wert zerlegen
        unless (/^\s*\$?([a-zA-Z][a-zA-Z0-9_-]*)\s*=\s*(.*?\S.*?)\s*$/ && substr($1,-1) ne '-') {
            return $self->_error($SYNTAX, $_, $section, $file, $line);
        }
        my $key = $1;
        my $value = $2; # ist ggf. in doppelte Anfuehrungszeichen verpackt
        $value =~ s/^\s*"(.*)"\s*$/$1/;
        return $self->_error( _read_only_($SPECIAL,$key) )
            if $section eq $SPECIAL;
        if (($key eq $NEXTCONF) && ($section eq $scope)) {
            $next = $value;
        }
        $self->_set($file, $line, $section, $key, $value) || return undef;
    }
    return 1 if $next eq '';
    return $self->add($next)
        if (defined ($next = $self->parse($next, $scope)));
    $$self{''} = $@;
    return undef;
}

sub _error {
    my($self, $text, $description, $section, $source, $line) = @_;
    my $location = '';
    if (defined $section || defined $source || defined $line) {
        $location = ' in';
        $location .= " file '$source'" if $source;
        $location .= " line #$line"    if $line;
        $location .= " [$section]"     if $section;
    }
    $description = $description ? ": $description" : '';
    $$self{''} = $text . $location . $description;
    return undef;
}

sub _set {
    my($self, $source, $line, $section, $key, $value, $override) = @_;
    local($@); # because of parse()
    return $self->_error( _read_only_($section,$key) )
        if ($section eq $ENV || ($section eq $SPECIAL &&
        ($key eq $HOME || $key eq $WHOAMI)));
    my $src = $$self{$section}{$key}{'source'};
    if (defined $src && $src eq $source && $src ne $SYS && $src ne $USR) {
        my $error = "Double entry in file '$src' for configuration constant " . _name_($section,$key);
        if ($line && $$self{$section}{$key}{'line'}) {
            $error .= " in line #$$self{$section}{$key}{'line'} and #$line";
        }
        return $self->_error($error);
    }
    unless (defined $self->parse($value)) {
        return $self->_error($SYNTAX, $@, $section, $source, $line);
    }
    if ($override || not $src) {
        $$self{$section}{$key}{'source'} = $source;
        $$self{$section}{$key}{'line'}   = $line;
        $$self{$section}{$key}{'value'}  = $value;
        $$self{$section}{$key}{'state'}  = $RAW;
    }
    return 1;
}

################################################################################
# Private Funktionen
################################################################################

sub _name_ {
    my $key = pop;
    my $sec = pop || $DEFAULT;
    return "\$[$sec]{$key}";
}

sub _not_found_ {
    return "Configuration constant " . _name_(@_) . " not found";
}

sub _read_only_ {
    return "Configuration constant " . _name_(@_) . " is read-only";
}

############################################################
# Private Hilfsmethoden fuer parse()
############################################################

sub _parse_id {
    # Aufrufer muss sicherstellen, dass $text mit einem Buchstaben [A-Za-z] beginnt!
    my($self,$text) = @_;
    $text =~ /^([a-zA-Z][a-zA-Z0-9_-]*)/;
    return ($1,$') unless substr($1,-1) eq '-';
    $@ = "illegal terminating '-' in identifier '$1'";
    return ();
}

sub _parse_sub {
    # Aufrufer muss sicherstellen, dass $rest auf dem Anfang eines moeglichen '$' oder [A-Za-z] steht
    my($self,$rest,$eval) = @_;
    my($first,$variable);
    if (length($rest) == 0) {
        $@ = "expecting identifier or variable, unexpected end of string";
        return ();
    }
    $first = substr($rest,0,1);
    if ($first eq '$') {
        $rest = substr($rest,1);
        if (length($rest) == 0) {
            $@ = "found '$', expecting variable, unexpected end of string";
            return ();
        }
        $first = substr($rest,0,1);
        return (($variable,$rest) = $self->_parse_var($first,$rest,$eval));
    }
    elsif ($first =~ /^[A-Za-z]$/) {
        return (($variable,$rest) = $self->_parse_id($rest,$eval));
    }
    else {
        $@ = "expecting identifier or variable, found '$first', expected '$' or [A-Za-z]";
        return ();
    }
}

sub _parse_var {
    # Aufrufer muss sicherstellen, dass vor $first ein '$' war und dass $first erster Char von $rest ist
    my($self,$first,$rest,$eval) = @_;
    my($section,$variable,$value);
    $section = '';
    if ($first eq '[') {
        return () unless (($section,$rest) = $self->_parse_sub(substr($rest,1),$eval));
        if (length($rest) == 0) {
            $@ = "missing ']' after section name '$section', unexpected end of string";
            return ();
        }
        $first = substr($rest,0,1);
        if ($first ne ']') {
            $@ = "missing ']' after section name '$section', found '$first' instead";
            return ();
        }
        $rest = substr($rest,1);
        if (length($rest) == 0) {
            $@ = "missing key name after section name '$section', unexpected end of string";
            return ();
        }
        $first = substr($rest,0,1);
    }
    if ($first eq '{') {
        return () unless (($variable,$rest) = $self->_parse_sub(substr($rest,1),$eval));
        if (length($rest) == 0) {
            $@ = "missing '}' after variable name '$variable', unexpected end of string";
            return ();
        }
        $first = substr($rest,0,1);
        if ($first ne '}') {
            $@ = "missing '}' after variable name '$variable', found '$first' instead";
            return ();
        }
        $rest = substr($rest,1);
        if ($eval) {
            return ($value,$rest) if defined ($value = $self->get($section || $eval, $variable));
            $@ = $self->error();
            return () if $section || $@ ne _not_found_($eval, $variable);
            $@ = '';
            return ($value,$rest) if defined ($value = $self->get($variable));
            $@ = $self->error();
            return ();
        }
        else {
            if ($section eq '') { return( "[$section]{$variable}", $rest ); }
            else                { return( "{$variable}",           $rest ); }
        }
    }
    elsif ($first =~ /^[A-Za-z]$/) {
        return () unless (($variable,$rest) = $self->_parse_id($rest,$eval));
        if ($eval) {
            return ($value,$rest) if defined ($value = $self->get($section || $eval, $variable));
            $@ = $self->error();
            return () if $section || $@ ne _not_found_($eval, $variable);
            $@ = '';
            return ($value,$rest) if defined ($value = $self->get($variable));
            $@ = $self->error();
            return ();
        }
        else {
            if ($section eq '') { return( "[$section]$variable", $rest ); }
            else                { return( $variable,             $rest ); }
        }
    }
    else {
        if ($section eq '') { $@ = "found '\$' followed by '$first', expecting '{' or [A-Za-z]"; }
        else                { $@ = "found '\$[$section]' followed by '$first', expecting '{' or [A-Za-z]"; }
        return ();
    }
}

1;

__END__