File Coverage

blib/lib/Parse/PlainConfig.pm

Criterion	Covered	Total	%
statement	382	400	95.5
branch	105	144	72.9
condition	35	48	72.9
subroutine	36	36	100.0
pod	9	9	100.0
total	567	637	89.0

# Parse::PlainConfig -- Parsing Engine for Parse::PlainConfig
#
# (c) 2002 - 2023, Arthur Corliss ,
#
# $Id: lib/Parse/PlainConfig.pm, 3.07 2024/01/10 13:32:06 acorliss Exp $
#
#    This software is licensed under the same terms as Perl, itself.
#    Please see http://dev.perl.org/licenses/ for more information.
#
#####################################################################

#####################################################################
#
# Environment definitions
#
#####################################################################

package Parse::PlainConfig;

use 5.008;

use strict;
use warnings;
use vars qw($VERSION);

($VERSION) = ( q$Revision: 3.07 $ =~ /(\d+(?:\.(\d+))+)/sm );

use Class::EHierarchy qw(:all);
use Parse::PlainConfig::Constants qw(:all);
use Parse::PlainConfig::Settings;
use Text::ParseWords;
use Text::Tabs;
use Fcntl qw(:seek :DEFAULT);
use Paranoid;
use Paranoid::Debug;
use Paranoid::IO;
use Paranoid::IO::Line;
use Paranoid::Input qw(:all);
use Paranoid::Glob;

use base qw(Class::EHierarchy);

use vars qw(@_properties @_methods %_parameters %_prototypes);

#####################################################################
#
# Module code follows
#
#####################################################################

sub _findAllClasses {

    # Purpose:  Returns a list of all parent class names
    # Returns:  Array of scalars
    # Usage:    @pclasses = _findAllClasses(ref $obj);

    my $class = shift;
    my ( @classes, %c, $c, @rv );

    subPreamble( PPCDLEVEL3, '$', $class );

    # Pull all parent class and recursively loop
    {
        no strict 'refs';

        if ( defined *{"${class}::ISA"}{ARRAY} ) {

            foreach $c ( @{ *{"${class}::ISA"}{ARRAY} } ) {
                push @classes, _findAllClasses($c);
            }

            push @classes, $class
                if scalar @classes
                    or grep { $_ eq __PACKAGE__ }
                    @{ *{"${class}::ISA"}{ARRAY} };
        }
    }

    # Consolidate redundant entries
    foreach $c (@classes) {
        push @rv, $c unless exists $c{$c};
        $c{$c} = 1;
    }

    subPostamble( PPCDLEVEL3, '@', @rv );

    return @rv;
}

sub _initialize {

    # Purpose:  Initialize config object and loads class defaults
    # Returns:  Boolean
    # Usage:    $rv = $obj->_initialize(@args);

    my $obj   = shift;
    my $class = ref $obj;
    my $rv    = 1;
    my ( @classes, $settings, %new, %_globals, %_parameters, %_prototypes );

    subPreamble( PPCDLEVEL1, '$$', $obj, $class );

    # Create & adopt the settings object
    $settings = new Parse::PlainConfig::Settings;
    $obj->adopt($settings);
    $settings->alias('settings');

    # Get a list of all parent classes
    @classes = ( _findAllClasses($class) );

    # Read in class global settings
    unless ( __PACKAGE__ eq $class ) {

        foreach $class (@classes) {
            if ( defined *{"${class}::_globals"} ) {
                pdebug( 'loading globals from %s', PPCDLEVEL2, $class );

                {
                    no strict 'refs';

                    %new = %{ *{"${class}::_globals"}{HASH} };
                }

                if ( scalar keys %new ) {
                    foreach ( keys %new ) {
                        $_globals{$_} = $new{$_};
                        pdebug( 'overriding %s with (%s)',
                            PPCDLEVEL3, $_, $_globals{$_} );
                        $rv = 0 unless $settings->set( $_, $_globals{$_} );
                    }
                }
            }
        }

        foreach $class (@classes) {
            if ( defined *{"${class}::_parameters"} ) {
                pdebug( 'loading parameters from %s', PPCDLEVEL2, $class );

                {
                    no strict 'refs';

                    %new = %{ *{"${class}::_parameters"}{HASH} };
                }

                if ( scalar keys %new ) {
                    %_parameters = ( %_parameters, %new );
                    $settings->set( 'property types', %_parameters );
                    foreach ( keys %new ) {

                        pdebug( 'creating property %s', PPCDLEVEL3, $_ );
                        unless (
                            _declProperty(
                                $obj, $_,
                                CEH_PUB | (
                                    $_parameters{$_} == PPC_HDOC
                                    ? PPC_SCALAR
                                    : $_parameters{$_}
                                    ),
                            )
                            ) {
                            $rv = 0;
                            last;
                        }

                        # merge property regex
                        $settings->merge(
                            'property regexes',
                            $_,
                            qr#(\s*)(\Q$_\E)\s*\Q@{[ $settings->delimiter ]}\E\s*(.*)#s
                            );
                    }
                }
            }

            if ( defined *{"${class}::_prototypes"} ) {
                pdebug( 'loading prototypes from %s', PPCDLEVEL2, $class );

                {
                    no strict 'refs';

                    %new = %{ *{"${class}::_prototypes"}{HASH} };
                }

                if ( scalar keys %new ) {
                    %_prototypes = ( %_prototypes, %new );
                    $settings->set( 'prototypes', %_prototypes );
                    foreach ( keys %new ) {

                        # merge property meta-data
                        $settings->merge(
                            'prototype regexes',
                            $_,
                            qr#(\s*)(\Q$_\E)\s+(\S+)\s*\Q@{[ $settings->delimiter ]}\E\s*(.*)#s
                            );
                    }
                }
            }
        }
    }

    # Store all parent classes
    $settings->set( '_ppcClasses', @classes );

    # Load the defaults
    $rv = $obj->parse( $obj->default );

    subPostamble( PPCDLEVEL1, '$', $rv );

    return $rv;
}

sub settings {

    # Purpose:  Returns object reference to the settings object
    # Returns:  Object reference
    # Usage:    $settings = $obj->settings;

    my $obj = shift;

    return $obj->getByAlias('settings');
}

sub _default {

    # Purpose:  Returns the DATA block from the calling
    # Returns:  Array
    # Usage:    @lines = $obj->_default;

    my $obj   = shift;
    my $class = shift;
    my ( $fn, @chunk, @lines );

    subPreamble( PPCDLEVEL2, '$', $obj );

    $class =~ s#::#/#sg;
    $class .= '.pm';
    $fn = $INC{$class};

    pdebug( 'attempting to read from %s', PPCDLEVEL3, $fn );
    if ( popen( $fn, O_RDONLY ) ) {

        # Read in file
        while ( sip( $fn, @chunk ) and @chunk ) { push @lines, @chunk }

        # empty all lines prior to __DATA__
        while ( @lines and $lines[0] !~ /^\s*__DATA__\s*$/s ) {
            shift @lines;
        }
        shift @lines;

        # empty all lines after __END__
        if ( @lines and grep /^\s*__END__\s*$/s, @lines ) {
            while ( @lines and $lines[-1] !~ /^\s*__END__\s*$/s ) {
                pop @lines;
            }
            pop @lines;
        }
        pseek( $fn, 0, SEEK_SET );
    }

    subPostamble( PPCDLEVEL2, '@', @lines );

    return wantarray ? @lines : join '', @lines;
}

sub default {

    # Purpose:  Returns the DATA block from the specified class,
    #           or the object class if not specified
    # Returns:  Array
    # Usage:    @lines = $obj->default;
    # Usage:    @lines = $obj->default($class);

    my $obj     = shift;
    my @classes = $obj->getByAlias('settings')->get('_ppcClasses');
    my ( $class, @rv );

    subPreamble( PPCDLEVEL1, '$', $obj );

    foreach $class (@classes) {
        push @rv, $obj->_default($class);
    }

    subPostamble( PPCDLEVEL1, '@', @rv );

    return @rv;
}

sub get {

    # Purpose:  Returns the value of the specified parameter
    # Returns:  Scalar/List/Hash
    # Usage:    $val = $obj->get('foo');

    my $obj = shift;
    my $p   = shift;
    my ( $valp, $valt, $rv );

    subPreamble( PPCDLEVEL1, '$$', $obj, $p );

    if ( defined $p ) {
        $valp = scalar grep /^\Q$p\E$/s, $obj->properties;
        if ($valp) {
            ($valt) = $obj->settings->subset( 'property types', $p );
            $valt = PPC_SCALAR if $valt == PPC_HDOC;
        }
    }
    $obj->error(
        pdebug( 'specified invalid parameter name: %s', PPCDLEVEL1, $p ) )
        unless $valp;

    # Return values get a little dicier because of different data types
    if ( defined $valt ) {
        if ( $valt == PPC_SCALAR ) {
            $rv = $obj->SUPER::get($p);
            subPostamble( PPCDLEVEL1, '$', $rv );
            return $rv;
        } elsif ( $valt == PPC_ARRAY ) {
            $rv = [ $obj->SUPER::get($p) ];
            subPostamble( PPCDLEVEL1, '@', @$rv );
            return @$rv;
        } else {
            $rv = { $obj->SUPER::get($p) };
            subPostamble( PPCDLEVEL1, '%', %$rv );
            return %$rv;
        }
    }

    subPostamble( PPCDLEVEL1, '$', $rv );

    return $rv;
}

sub set {

    # Purpose:  Assigns the desired values to the specified parameter
    # Returns:  Boolean
    # Usage:    $rv = $obj->set($prop, @values);

    my $obj       = shift;
    my $p         = shift;
    my @vals      = @_;
    my %propTypes = $obj->settings->propertyTypes;
    my ( $valp, $rv );

    subPreamble( PPCDLEVEL1, '$$@', $obj, $p, @vals );

    if ( defined $p ) {
        $valp = scalar grep /^\Q$p\E$/s, $obj->properties;
    }
    $obj->error(
        pdebug( 'specified invalid parameter name: %s', PPCDLEVEL1, $p ) )
        unless $valp;

    if ($valp) {
        if (@vals) {

            # Set whatever's assigned
            $rv = $obj->SUPER::set( $p, @vals );
        } else {

            # Assume that no values means empty/undef
            if (   $propTypes{$p} == PPC_SCALAR
                or $propTypes{$p} == PPC_HDOC ) {
                $rv = $obj->SUPER::set( $p, undef );
            } else {
                $rv = $obj->empty($p);
            }
        }
    }

    subPostamble( PPCDLEVEL1, '$', $valp ? $rv : undef );

    return $valp ? $rv : undef;
}

sub _snarfBlock (\@\$\$$) {

    # Purpose:  Finds and returns the block with the value
    #           string extracted.
    # Returns:  Boolean
    # Usage:    $rv = _snarfBlock(@lines, $val);

    my $lref       = shift;
    my $pref       = shift;
    my $vref       = shift;
    my $settings   = shift;
    my $obj        = $settings->parent;
    my %regex      = $settings->propertyRegexes;
    my %pregex     = $settings->prototypeRegexes;
    my %propTypes  = $settings->propertyTypes;
    my %prototypes = $settings->prototypes;
    my $subi       = $settings->subindentation;
    my ( $rv, $indent, $prop, $proto, $trailer, $iwidth, $line, $preg );

    subPreamble( PPCDLEVEL2, '$$$$', $lref, $pref, $vref, $settings );

    # Match line to a property/prototype declaration
    #
    # First try to match against properties
    foreach ( keys %regex ) {
        if ( $$lref[0] =~ /^$regex{$_}$/s ) {
            ( $indent, $prop, $trailer ) = ( $1, $2, $3 );
            $rv = 1;
            shift @$lref;
            last;
        }
    }
    unless ( $rv and defined $prop and length $prop ) {
        foreach ( keys %pregex ) {
            if ( $$lref[0] =~ /^$pregex{$_}$/s ) {
                ( $indent, $proto, $prop, $trailer ) = ( $1, $2, $3, $4 );
                $rv = 1;
                shift @$lref;
                last;
            }
        }
    }

    # Define all prototyped properties
    if ( defined $proto and length $proto ) {
        if ( defined $prop and length $prop ) {

            if ( exists $regex{$prop} ) {
                $obj->error(
                    pdebug(
                        'token (%s) for prototype (%s) attempted to override property',
                        PPCDLEVEL1,
                        $prop,
                        $proto
                        ) );
                $rv = 0;
            } else {

                if ( exists $propTypes{$prop} ) {

                    # Make sure they haven't been previously defined,
                    # or if they have, they match the same type
                    unless ( $propTypes{$prop} == $prototypes{$proto} ) {
                        $rv = 0;
                        $obj->error(
                            pdebug(
                                'prototype mismatch with previous declaration: %s',
                                PPCDLEVEL1,
                                $proto
                                ) );
                        pdebug( 'current type: %s prototype: %s',
                            PPCDLEVEL1, $propTypes{$prop},
                            $prototypes{$proto} );
                    }
                } else {

                    # Create a new property
                    pdebug( 'creating property based on prototype %s: %s',
                        PPCDLEVEL3, $proto, $prop );

                    $rv = _declProperty(
                        $obj, $prop,
                        CEH_PUB | (
                            $prototypes{$proto} == PPC_HDOC
                            ? PPC_SCALAR
                            : $prototypes{$proto}
                            ),
                            );

                    # Record the prop type
                    if ($rv) {
                        $settings->merge( 'property types',
                            $prop, $propTypes{$prop} = $prototypes{$proto} );
                        ($preg) =
                            $settings->subset( 'prototype registry', $proto );
                        $preg = [] unless defined $preg;
                        push @$preg, $prop;
                        $settings->merge( 'prototype registry',
                            $proto => $preg );
                    } else {
                        $obj->error(
                            pdebug(
                                'failed to declare prototype: %s %s',
                                PPCDLEVEL1, $proto, $prop
                                ) );
                    }
                }
            }
        } else {
            $obj->error(
                pdebug(
                    'invalid token used for prototype %s: %s', PPCDLEVEL1,
                    $proto,                                    $prop
                    ) );
            $rv = 0;
        }
    }

    # Grab additional lines as needed
    if ($rv) {

        if ( $propTypes{$prop} == PPC_HDOC ) {

            # Snarf all lines until we hit the HDOC marker
            $rv = 0;
            while (@$lref) {
                $line = shift @$lref;
                if ( $line =~ /^\s*\Q@{[ $settings->hereDoc ]}\E\s*$/s ) {
                    $rv = 1;
                    last;
                } else {
                    $line =~ s/^\s{1,$subi}//s;
                    $trailer .= $line;
                }
            }

            # Error out if we never found the marker
            $obj->error(
                pdebug( 'failed to find the here doc marker', PPCDLEVEL1 ) )
                unless $rv;

        } else {

            # All non-HDOCs are handled the same
            $iwidth = defined $indent ? length $indent : 0;
            while (@$lref) {

                # We're done if this is a line break
                last if $$lref[0] =~ /^\s*$/s;

                # We're also done if indentation isn't greater
                # than the parameter declaration line
                ($indent) = ( $$lref[0] =~ /^(\s*)/s );
                last if !defined $indent or $iwidth >= length $indent;

                # Append content to the trailer
                $line = shift @$lref;
                $line =~ s/^\s{1,$subi}//s;
                pchomp($line);
                $trailer .= $line;
            }
        }
        $trailer =~ s/\s+$//s if defined $trailer;
    }

    if ($rv) {
        pchomp($trailer);
        ( $$pref, $$vref ) = ( $prop, $trailer );
        pdebug( 'extracted value for %s: %s', PPCDLEVEL3, $prop, $trailer );
    }

    subPostamble( PPCDLEVEL2, '$', $rv );

    return $rv;
}

sub _snarfProp {

    # Purpose:  Takes the property value and parses according to its type,
    #           then merges it
    # Returns:  Boolean
    # Usage:    $rv = _snarfProp($obj, $prop, $val);

    my $obj       = shift;
    my $prop      = shift;
    my $val       = shift;
    my $settings  = $obj->settings;
    my %propTypes = $settings->propertyTypes;
    my $ldelim    = $settings->listDelimiter;
    my $hdelim    = $settings->hashDelimiter;
    my $rv        = 1;
    my @elements;

    subPreamble( PPCDLEVEL2, '$$$', $obj, $prop, $val );

    if (   $propTypes{$prop} == PPC_HDOC
        or $propTypes{$prop} == PPC_SCALAR ) {

        # Here Docs and scalars are merged as-is
        $obj->SUPER::set( $prop, $val );

    } else {

        if ( $propTypes{$prop} == PPC_ARRAY ) {

            # Split into a list
            @elements = quotewords( qr/\Q$ldelim\E/s, 0, $val );
            foreach (@elements) { s/^\s+//s; s/\s+$//s; }

        } else {

            # Split into a hash
            @elements =
                quotewords( qr/(?:\Q$ldelim\E|\Q$hdelim\E)/s, 0, $val );
            foreach (@elements) { s/^\s+//s; s/\s+$//s; }

        }

        # merge the list value
        pdebug( 'storing in %s: %s', PPCDLEVEL3, $prop, @elements );
        $obj->empty($prop);
        $obj->SUPER::set( $prop, @elements );
    }

    subPostamble( PPCDLEVEL2, '$', $rv );

    return $rv;
}

sub parse {

    # Purpose:  Parses passed content and extracts values
    # Returns:  Boolean
    # Usage:    $rv = $obj->parse(@lines);

    my $obj      = shift;
    my @lines    = @_;
    my $settings = $obj->settings;
    my $delim    = $settings->delimiter;
    my $cre      = qr#^\s*\Q@{[ $settings->comment ]}\E#s;
    my $rv       = 1;
    my ( $text, $prop, $value, $glob );

    subPreamble( PPCDLEVEL1, '$@', $obj, @lines );

    # Some preprocessing of lines
    if (@lines) {
        $tabstop = $settings->tabStop;
        @lines   = expand(@lines);
        foreach (@lines) {
            $text =
                ( defined $text and length $text )
                ? join "\n", $text, split NEWLINE_REGEX, $_
                : join "\n", split NEWLINE_REGEX, $_;
        }
    }

    while (@lines) {

        # Skip comments and empty lines
        if (   $lines[0] =~ /^$cre/s
            or $lines[0] =~ /^\s*(?:@{[ NEWLINE_REGEX ]})?$/s ) {
            shift @lines;
            next;
        }

        # Handle "include" statements
        if ( $lines[0] =~ /^\s*include\s+(.+?)\s*$/s ) {
            $glob = new Paranoid::Glob globs => [$1];
            shift @lines;
            $rv = 0 unless $obj->read($glob);
            next;
        }

        # See if we have property block
        if ( _snarfBlock( @lines, $prop, $value, $settings ) ) {

            # Parse the block (but preserve earlier errors)
            $rv = 0 unless _snarfProp( $obj, $prop, $value );

        } else {

            pdebug( 'discarding invalid input: %s', PPCDLEVEL1, $lines[0] );
            shift @lines;
            $rv = 0;
        }
    }

    subPostamble( PPCDLEVEL1, '$', $rv );

    return $rv;
}

sub read {

    # Purpose:  Reads the passed file(s)
    # Returns:  Boolean
    # Usage:    $rv = $obj->read($filename);

    my $obj    = shift;
    my $source = shift;
    my ( $rv, @lines );

    subPreamble( PPCDLEVEL1, '$$', $obj, $source );

    if (@_) {

        # Work all entries passed if handed a list
        $rv = $obj->read($source);
        foreach (@_) { $rv = 0 unless $obj->read($_) }

    } elsif ( ref $source eq '' ) {

        # Treat all non-reference files as filenames
        if ( slurp( $source, @lines ) ) {
            $rv = $obj->parse(@lines);
            pdebug( 'errors parsing %s', PPCDLEVEL1, $source ) unless $rv;
        } else {
            $obj->error(
                pdebug(
                    'failed to read %s: %s', PPCDLEVEL1,
                    $source,                 Paranoid::ERROR() ) );
        }

    } elsif ( ref $source eq 'Paranoid::Glob' ) {

        # Handle Paranoid globs specially
        $rv = 1;
        foreach (@$source) { $rv = 0 unless $obj->read($_) }

    } else {

        # Handle everything else as if it was a glob
        if ( slurp( $source, @lines ) ) {
            $rv = $obj->parse(@lines);
            pdebug( 'errors parsing %s', PPCDLEVEL1, $source ) unless $rv;
        } else {
            $obj->error(
                pdebug(
                    'failed to read %s: %s', PPCDLEVEL1,
                    $source,                 Paranoid::ERROR() ) );
        }
    }

    subPostamble( PPCDLEVEL1, '$', $rv );

    return $rv;
}

sub reset {

    # Purpose:  Resets configuration state to defaults
    # Returns:  Boolean
    # Usage:    $rv = $obj->reset;

    my $obj       = shift;
    my $settings  = $obj->settings;
    my %propTypes = $settings->propertyTypes;
    my $rv;

    subPreamble( PPCDLEVEL1, '$', $obj );

    # empty all property values
    foreach ( keys %propTypes ) {
        pdebug( 'clearing merged values for %s', PPCDLEVEL2, $_ );
        if ( $propTypes{$_} == PPC_SCALAR or $propTypes{$_} == PPC_HDOC ) {
            $obj->SUPER::set( $_, undef );
        } else {
            $obj->empty($_);
        }
    }
    $rv = $obj->parse( $obj->default );

    subPostamble( PPCDLEVEL1, '$', $rv );

    return $rv;
}

sub prototyped {

    # Purpose:  Returns a list of properties that were created with
    #           prototypes
    # Returns:  Array
    # Usage:    @protos = $obj->prototyped;
    # Usage:    @protos = $obj->prototyped($proto);

    my $obj   = shift;
    my $proto = shift;
    my ( %preg, @prval );

    subPreamble( PPCDLEVEL1, '$$', $obj, $proto );

    %preg = $obj->settings->get('prototype registry');

    if ( defined $proto and length $proto ) {
        if ( exists $preg{$proto} ) {
            @prval = @{ $preg{$proto} };
        } else {
            pdebug( 'no prototype properties declared w/%s',
                PPCDLEVEL2, $proto );
        }
    } else {
        pdebug( 'dumping all declared prototyped properties', PPCDLEVEL2 );
        foreach ( keys %preg ) { push @prval, @{ $preg{$_} } }
    }

    subPostamble( PPCDLEVEL1, '@', @prval );

    return @prval;
}

sub error {

    # Purpose:  Sets/gets the last error message
    # Returns:  Scalar/undef
    # Usage:    $errStr = $obj->error;
    # Usage:    $errStr = $obj->error($msg);

    my $obj = shift;
    my $msg = shift;

    if ( defined $msg ) {
        $obj->settings->set( 'error', $msg );
    } else {
        $msg = $obj->settings->get('error');
    }

    return $msg;
}

1;

__END__