File Coverage

blib/lib/Parse/PlainConfig/Legacy.pm

Criterion	Covered	Total	%
statement	422	458	92.1
branch	188	246	76.4
condition	46	61	75.4
subroutine	32	33	96.9
pod	13	13	100.0
total	701	811	86.4

# Parse::PlainConfig::Legacy -- Parsing Engine Legacy for Parse::PlainConfig
#
# (c) 2002 - 2016, Arthur Corliss ,
#
# $Id: lib/Parse/PlainConfig/Legacy.pm, 3.04 2017/02/06 02:58:13 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::Legacy;

use 5.006;

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

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

use Parse::PlainConfig::Constants qw(:all);
use Text::ParseWords;
use Text::Tabs;
use Carp;
use Fcntl qw(:flock);
use Paranoid;
use Paranoid::Data;
use Paranoid::Debug;
use Paranoid::Filesystem;
use Paranoid::Input;
use Paranoid::IO qw(:all);
use Paranoid::IO::Line;

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

{
    my $ERROR = '';

    sub ERROR : lvalue {
        $ERROR;
    }
}

sub new {

    # Purpose:  Creates a new object
    # Returns:  Object reference if successful, undef if not
    # Usage:    $obj = Parse::PlainConfig->new(%PARAMS);

    my $class = shift;
    my $self  = {
        CONF         => {},
        ORDER        => [],
        FILE         => undef,
        PARAM_DELIM  => ':',
        LIST_DELIM   => ',',
        HASH_DELIM   => '=>',
        AUTOPURGE    => 0,
        COERCE       => {},
        DEFAULTS     => {},
        SMART_PARSER => 0,
        PADDING      => 2,
        MAX_BYTES    => PPC_DEF_SIZE,
        MTIME        => 0,
        };
    my %args = @_;
    my ( $k, $v, $rv );

    pdebug( 'entering', PPCDLEVEL1 );
    pIn();

    bless $self, $class;

    # Assign all the arguments
    $rv = 1;
    while ( $rv && scalar keys %args ) {
        $k = shift @{ [ keys %args ] };
        $v = $args{$k};
        delete $args{$k};
        $rv = 0 unless $self->property( $k, $v );
    }

    $self = undef unless $rv;

    pOut();
    pdebug( 'leaving w/rv: %s', PPCDLEVEL1, $self );

    return $self;
}

sub property {

    # Purpose:  Gets/sets object property value
    # Returns:  Value of property in Get mode, true/false in set mode
    # Usage:    $value = $obj->property($name);
    # Usage:    $rv = $obj->property($name, $value);

    my $self = shift;
    my @args = @_;
    my $arg  = $_[0];
    my $val  = $_[1];
    my $ival = defined $val ? $val : 'undef';
    my $rv   = 1;
    my ( $k, $v );

    croak 'Mandatory first argument must be a valid property name'
        unless defined $arg and exists $$self{$arg};

    pdebug( 'entering w/(%s)(%s)', PPCDLEVEL1, $arg, $ival );
    pIn();

    pdebug( 'method is in ' . ( scalar @args == 2 ? 'set' : 'get' ) . ' mode',
        PPCDLEVEL1 );
    $arg = uc $arg;

    # Validate arguments & value
    if ( scalar @args == 2 ) {

        if ( $arg eq 'ORDER' ) {

            # ORDER must be a list reference
            unless ( ref $val eq 'ARRAY' ) {
                $rv = 0;
                Parse::PlainConfig::Legacy::ERROR =
                    pdebug( '%s\'s value must be a list reference',
                    PPCDLEVEL1, $arg );
            }

        } elsif ( $arg eq 'CONF' or $arg eq 'COERCE' or $arg eq 'DEFAULTS' ) {

            # CONF, COERCE, and DEFAULTS must be a hash reference
            unless ( ref $val eq 'HASH' ) {
                $rv = 0;
                Parse::PlainConfig::Legacy::ERROR =
                    pdebug( '%s\'s value must be a hash reference',
                    PPCDLEVEL1, $arg );
            }

            if ($rv) {

                if ( $arg eq 'COERCE' ) {

                    # Validate each key/value pair in COERCE
                    foreach ( keys %$val ) {
                        $ival = defined $$val{$_} ? $$val{$_} : 'undef';
                        unless ( $ival eq 'string'
                            or $ival eq 'list'
                            or $ival eq 'hash' ) {
                            Parse::PlainConfig::Legacy::ERROR = pdebug(
                                'coerced data type (%s: %s) not a string, list, or hash',
                                PPCDLEVEL1, $_, $ival
                                );
                            $rv = 0;
                        }
                    }
                } elsif ( $arg eq 'DEFAULTS' ) {

                    # Copy over the defaults into CONF (not overriding
                    # existing values)
                    while ( ( $k, $v ) = each %{ $$self{DEFAULTS} } ) {
                        $$self{CONF}{$k} = { 'Value' => $v }
                            unless exists $$self{CONF}{$k};
                    }
                }
            }

            # TODO:  Validate properties like PADDING that have a concrete
            # TODO:  list of valid values?

        } elsif ( ref $val ne '' ) {

            # Everything else should be a scalar value
            $rv = 0;
            Parse::PlainConfig::Legacy::ERROR =
                pdebug( '%s\'s value must be a scalar value',
                PPCDLEVEL1, $arg );
        }
    }

    # Set the value if all's kosher
    if ($rv) {
        if ( scalar @args == 2 ) {

            # Assign the value
            if ( ref $val eq 'ARRAY' ) {

                # Copy array contents in
                $$self{$arg} = [@$val];

            } elsif ( ref $val eq 'HASH' ) {

                # Copy hash contents in
                $$self{$arg} = {%$val};

            } else {

                # Assign the scalar value
                $$self{$arg} = $val;
            }
        } else {

            # Copy the value
            if ( defined $$self{$arg} and ref $$self{$arg} ne '' ) {
                $rv =
                      ref $$self{$arg} eq 'ARRAY' ? []
                    : ref $$self{$arg} eq 'HASH'  ? {}
                    :                               undef;
                if ( defined $rv ) {
                    unless ( deepCopy( $$self{$arg}, $rv ) ) {
                        Parse::PlainConfig::Legacy::ERROR =
                            pdebug( 'failed to copy data from %s: %s',
                            PPCDLEVEL1, Paranoid::ERROR, $arg );
                    }
                } else {
                    Parse::PlainConfig::Legacy::ERROR =
                        pdebug( 'I don\'t know how to copy %s (%s)',
                        PPCDLEVEL1, $$self{$arg}, $arg );
                }
            } else {
                $rv = $$self{$arg};
            }
        }
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PPCDLEVEL1, $rv );

    return $rv;
}

sub purge {

    # Purpose:  Performs a manual purge of internal data
    # Returns:  True
    # Usage:    $obj->purge;

    my $self = shift;
    my ( $k, $v );

    pdebug( 'entering', PPCDLEVEL1 );
    pIn();

    # First, purge all existing values
    delete @{ $$self{CONF} }{ keys %{ $$self{CONF} } };

    # Second, apply default values
    while ( ( $k, $v ) = each %{ $$self{DEFAULTS} } ) {
        $$self{CONF}{$k} = { 'Value' => $v };
    }

    pOut();
    pdebug( 'leaving w/rv: 1', PPCDLEVEL1 );

    return 1;
}

sub read {

    # Purpose:  Reads either the passed filename or an internally recorded one
    # Returns:  True or false depending on success of read & parse
    # Usage:    $rv = $obj->read;
    # Usage:    $rv = $obj->read($filename);

    my $self    = shift;
    my $file    = shift || $$self{FILE};
    my $rv      = 0;
    my $oldSize = PIOMAXFSIZE;
    my ( $line, @lines );

    croak 'Optional first argument must be a defined filename or the FILE '
        . 'property must be set'
        unless defined $file;

    pdebug( 'entering w/(%s)', PPCDLEVEL1, $file );
    pIn();

    # Reset the error string and update the internal filename
    Parse::PlainConfig::Legacy::ERROR = '';
    $$self{FILE} = $file;

    # Temporarily set the specified size limit
    PIOMAXFSIZE = $$self{MAX_BYTES};

    # Store the file's current mtime
    $$self{MTIME} = ( stat $file )[MTIME];

    if ( detaint( $file, 'filename' ) ) {
        if ( slurp( $file, @lines, 1 ) ) {

            # Empty the current config hash and key order
            $self->purge if $$self{AUTOPURGE};

            # Parse the rc file's lines
            $rv = $self->_parse(@lines);

        } else {
            Parse::PlainConfig::Legacy::ERROR =
                pdebug( Paranoid::ERROR, PPCDLEVEL1 );
        }
    } else {
        Parse::PlainConfig::Legacy::ERROR =
            pdebug( 'Filename failed detaint check', PPCDLEVEL1 );
    }

    # Restore old size limit
    PIOMAXFSIZE = $oldSize;

    pOut();
    pdebug( 'leaving w/rv: %s', PPCDLEVEL1, $rv );

    # Return the result code
    return $rv;
}

sub readIfNewer ($) {

    # Purpose:  Performs a file read/parse if the file is newer than last read
    # Returns:  1 if read/parse was successful, 2 if file is the same age, 0
    #           on any errors
    # Usage:    $rv = $obj->readIfNewer;

    my $self   = shift;
    my $file   = $$self{FILE};
    my $omtime = $$self{MTIME};
    my $rv     = 0;
    my $mtime;

    croak 'The FILE property must be set' unless defined $file;

    pdebug( 'entering w/(%s)', PPCDLEVEL1, $file );
    pIn();

    # Try to read the file
    if ( -e $file && -r _ ) {

        # File exists and appears to be readable, get the mtime
        $mtime = ( stat _ )[MTIME];
        pdebug( 'current mtime: %s last: %s', PPCDLEVEL2, $mtime, $omtime );

        # Read the file if it's newer, or return 2
        $rv = $mtime > $omtime ? $self->read : 2;

    } else {

        # Report errors
        Parse::PlainConfig::Legacy::ERROR =
            pdebug( 'file (%s) does not exist or is not readable',
            PPCDLEVEL1, $file );
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PPCDLEVEL1, $rv );

    # Return the result code
    return $rv;
}

sub write {

    # Purpose:  Writes the file to disk
    # Returns:  True/False depending on success of write
    # Usage:    $rv = $obj->write;
    # Usage:    $rv = $obj->write($filename);

    my $self       = shift;
    my $file       = shift || $$self{FILE};
    my $padding    = shift;
    my $conf       = $$self{CONF};
    my $order      = $$self{ORDER};
    my $coerce     = $$self{COERCE};
    my $smart      = $$self{SMART_PARSER};
    my $paramDelim = $$self{PARAM_DELIM};
    my $hashDelim  = $$self{HASH_DELIM};
    my $listDelim  = $$self{LIST_DELIM};
    my $rv         = 0;
    my $tw         = DEFAULT_TW;
    my $delimRegex = qr/(?:\Q$hashDelim\E|\Q$listDelim\E)/sm;
    my ( @forder, $type, $param, $value, $description, $entry, $out );
    my ( $tmp, $tvalue, $lines, $fh );

    # TODO: Implement non-blocking flock support
    # TODO: Store read padding and/or use PADDING property value

    croak 'Optional first argument must be a defined filename or the FILE '
        . 'property must be set'
        unless defined $file;

    $padding = 2 unless defined $padding;
    $tw -= 2 unless $smart;

    pdebug( 'entering w/(%s)(%s)', PPCDLEVEL1, $file, $padding );
    pIn();

    # Pad the delimiter as specified
    $paramDelim =
          $padding == 0 ? $paramDelim
        : $padding == 1 ? " $paramDelim"
        : $padding == 2 ? "$paramDelim "
        :                 " $paramDelim ";
    pdebug( 'PARAM_DELIM w/padding is \'%s\'', PPCDLEVEL2, $paramDelim );

    # Create a list of parameters for output
    @forder = @$order;
    foreach $tmp ( sort keys %$conf ) {
        push @forder, $tmp
            unless grep /^\Q$tmp\E$/sm, @forder;
    }
    pdebug( "order of params to be written:\n\t%s", PPCDLEVEL2, @forder );

    # Compose the new output
    $out = '';
    foreach $param (@forder) {

        # Determine the datatype
        $value = exists $$conf{$param} ? $$conf{$param}{Value} : '';
        $description =
            exists $$conf{$param} ? $$conf{$param}{Description} : '';
        $type =
              exists $$coerce{$param} ? $$coerce{$param}
            : ref $value eq 'HASH'  ? 'hash'
            : ref $value eq 'ARRAY' ? 'list'
            :                         'string';
        pdebug( 'adding %s param (%s)', PPCDLEVEL2, $type, $param );

        # Append the comments
        $out .= $description;
        $out .= "\n" unless $out =~ /\n$/sm;

        # Start the new entry with the parameter name and delimiter
        $entry = "$param$paramDelim";

        # Append the value, taking into consideration the smart parser
        # and coercion settings
        if ( $type eq 'string' ) {

            # String type
            $tvalue = $value;
            unless ( $smart && exists $$coerce{$param} ) {
                $tvalue =~ s/"/\\"/smg;
                $tvalue = "\"$tvalue\"" if $tvalue =~ /$delimRegex/sm;
            }
            $lines = "$entry$tvalue";

        } elsif ( $type eq 'list' ) {

            # List type
            $tvalue = [@$value];
            foreach (@$tvalue) {
                s/"/\\"/smg;
                if ( $smart && exists $$coerce{$param} ) {
                    $_ = "\"$_\"" if /\Q$listDelim\E/sm;
                } else {
                    $_ = "\"$_\"" if /$delimRegex/sm;
                }
            }
            $lines = $entry . join " $listDelim ", @$tvalue;

        } else {

            # Hash type
            $tvalue = {%$value};
            foreach ( keys %$tvalue ) {
                $tmp = $_;
                $tmp =~ s/"/\\"/smg;
                $tmp = "\"$tmp\"" if /$delimRegex/sm;
                if ( $tmp ne $_ ) {
                    $$tvalue{$tmp} = $$tvalue{$_};
                    delete $$tvalue{$_};
                }
                $$tvalue{$tmp} =~ s/"/\\"/smg;
                $$tvalue{$tmp} = "\"$$tvalue{$tmp}\""
                    if $$tvalue{$tmp} =~ /$delimRegex/sm;
            }
            $lines = $entry
                . join " $listDelim ",
                map {"$_ $hashDelim $$tvalue{$_}"} sort keys %$tvalue;
        }

        # wrap the output to the column width and append to the output
        $out .= _wrap( '', "\t", $tw, ( $smart ? "\n" : "\\\n" ), $lines );
        $out .= "\n" unless $out =~ /\n$/sm;
    }

    # Write the file
    if ( detaint( $file, 'filename' ) ) {
        if ( open $fh, '>', $file ) {

            # Write the file
            flock $fh, LOCK_EX;
            if ( print $fh $out ) {
                $rv = 1;
            } else {
                Parse::PlainConfig::Legacy::ERROR = $!;
            }
            flock $fh, LOCK_UN;
            close $fh;

            # Store the new mtime on successful writes
            $$self{MTIME} = ( stat $file )[MTIME] if $rv;

        } else {

            # Report the errors
            Parse::PlainConfig::Legacy::ERROR =
                pdebug( 'error writing file: %s', PPCDLEVEL1, $! );
        }
    } else {

        # Detainting filename failed
        Parse::PlainConfig::Legacy::ERROR =
            pdebug( 'illegal characters in filename: %s', PPCDLEVEL1, $file );
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PPCDLEVEL1, $rv );

    return $rv;
}

sub parameters {

    # Purpose:  Returns a list of all parsed parameters
    # Returns:  List of parameter names with configure values
    # Usage:    @params = $obj->parameters;

    my $self       = shift;
    my @parameters = keys %{ $$self{CONF} };

    pdebug( 'called method -- rv: %s', PPCDLEVEL1, @parameters );

    return @parameters;
}

sub parameter {

    # Purpose:  Gets/sets named parameter
    # Returns:  True/false in set mode, Parameter value in get mode
    # Usage:    $rv = $obj->parameter($name);
    # Usage:    $rv = $obj->parameter($name, $value);

    my $self       = shift;
    my @args       = @_;
    my $param      = $args[0];
    my $value      = $args[1];
    my $ivalue     = defined $value ? $value : 'undef';
    my $conf       = $$self{CONF};
    my $listDelim  = $$self{LIST_DELIM};
    my $hashDelim  = $$self{HASH_DELIM};
    my $paramDelim = $$self{PARAM_DELIM};
    my $coerceType =
        exists $$self{COERCE}{$param}
        ? $$self{COERCE}{$param}
        : 'undef';
    my $defaults   = $$self{DEFAULTS};
    my $rv         = 1;
    my $delimRegex = qr/(?:\Q$hashDelim\E|\Q$listDelim\E)/sm;
    my ( $finalValue, @elements );

    # TODO: Consider storing a list/hash padding value as well, for use
    # TODO: in coercion to string.

    croak 'Mandatory firest argument must be a defined parameter name'
        unless defined $param;

    pdebug( 'entering w/(%s)(%s)', PPCDLEVEL1, $param, $ivalue );
    pIn();

    if ( scalar @args == 2 ) {
        pdebug( 'method in set mode', PPCDLEVEL1 );

        # Create a blank record if it hasn't been defined yet
        $$conf{$param} = {
            Value       => '',
            Description => '',
            }
            unless exists $$conf{$param};

        # Start processing value assignment
        if ( $coerceType ne 'undef' ) {
            pdebug( 'coercing into %s', PPCDLEVEL2, $coerceType );

            # Parameter has a specific data type to be coerced into
            if ( $coerceType eq 'string' && ref $value ne '' ) {

                # Coerce values into strings
                if ( ref $value eq 'ARRAY' ) {

                    # Convert lists into a string using the list delimiter
                    foreach (@$value) {
                        s/"/\\"/smg;
                        $_ = "\"$_\"" if /\Q$listDelim\E/sm;
                    }
                    $finalValue = join " $listDelim ", @$value;

                } elsif ( ref $value eq 'HASH' ) {

                    # Convert hashes into a string using the hash & list
                    # delimiters
                    foreach ( sort keys %$value ) {
                        $ivalue = $_;
                        $ivalue =~ s/"/\\"/smg;
                        $ivalue = "\"$ivalue\""
                            if /(?:\Q$hashDelim\E|\Q$listDelim\E)/sm;
                        $$value{$_} = '' unless defined $$value{$_};
                        $$value{$_} = "\"$$value{$_}\""
                            if $$value{$_} =~
                                /(?:\Q$hashDelim\E|\Q$listDelim\E)/sm;
                        push @elements,
                            join " $hashDelim ", $_,
                            ( defined $$value{$_} ? $$value{$_} : '' );
                    }
                    $finalValue = join " $listDelim ", @elements;

                } else {

                    # Try to stringify everything else
                    $finalValue = "$value";
                }

            } elsif ( $coerceType eq 'list' && ref $value ne 'ARRAY' ) {

                # Coerce value into a list
                if ( ref $value eq 'HASH' ) {

                    # Convert hashes into a list
                    $finalValue = [];
                    foreach ( sort keys %$value ) {
                        push @$finalValue, $_, $$value{$_};
                    }

                } elsif ( ref $value eq '' ) {

                    # Convert strings into a list
                    $self->_parse(
                        split /\n/sm,
                        "$$conf{$param}{Description}\n"
                            . "$param $paramDelim $value"
                            );
                    $finalValue = $$conf{$param}{Value};

                } else {

                    # Stringify everything else and put it into an array
                    $finalValue = ["$value"];
                }

            } elsif ( $coerceType eq 'hash' && ref $value ne 'HASH' ) {

                # Coerce value into a hash
                if ( ref $value eq 'ARRAY' ) {

                    # Convert a list into a hash using every two elements
                    # as a key/value pair
                    push @$value, ''
                        unless int( scalar @$value / 2 ) ==
                            scalar @$value / 2;
                    $finalValue = {@$value};

                } elsif ( ref $value eq '' ) {

                    # Convert strings into a hash
                    $self->_parse(
                        split /\n/sm,
                        "$$conf{$param}{Description}\n"
                            . "$param $paramDelim $value"
                            );
                    $finalValue = $$conf{$param}{Value};

                } else {

                    # Stringify everything else and put the value into the
                    # hash key
                    $finalValue = { "$value" => '' };
                }

            } else {

                # No coercion is necessary
                $finalValue = $value;
            }

        } else {
            pdebug( 'no coercion to do', PPCDLEVEL2 );
            $finalValue = $value;
        }
        $$conf{$param}{Value} = $finalValue;

    } else {
        pdebug( 'method in retrieve mode', PPCDLEVEL1 );
        $rv =
              exists $$conf{$param}     ? $$conf{$param}{Value}
            : exists $$defaults{$param} ? $$defaults{$param}
            :                             undef;
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PPCDLEVEL1, $rv );

    return ref $rv eq 'HASH' ? (%$rv) : ref $rv eq 'ARRAY' ? (@$rv) : $rv;
}

sub coerce {

    # Purpose:  Assigns the passed list to a data type and attempts to
    #           coerce each existing value into that data type.
    # Returns:  True or false.
    # Usage:    $rv = $obj->coerce($type, @fields);

    my $self   = shift;
    my $type   = shift;
    my $itype  = defined $type ? $type : 'undef';
    my @params = @_;
    my $rv     = 1;

    croak 'Mandatory first argument must be "string", "list", or "hash"'
        unless $itype eq 'string'
            or $itype eq 'list'
            or $itype eq 'hash';
    croak 'Remaining arguments must be defined parameter names'
        unless @params;

    pdebug( 'entering w/(%s)(%s)', PPCDLEVEL1, $type, @params );
    pIn();

    foreach (@params) {
        if (defined) {

            # Mark the parameter
            $$self{COERCE}{$_} = $type;
            $self->parameter( $_, $$self{CONF}{$_}{Value} )
                if exists $$self{CONF}{$_};
        } else {

            # Report undefined parameter names
            Parse::PlainConfig::Legacy::ERROR =
                pdebug( 'passed undefined parameter names to coerce',
                PPCDLEVEL1 );
            $rv = 0;
        }
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PPCDLEVEL1, $rv );

    return $rv;
}

sub describe {

    # Purpose:  Assigns descriptive comments to specific parameters
    # Returns:  True
    # Usage:    $obj->describe(%descriptions);

    my $self   = shift;
    my $conf   = $$self{CONF};
    my $coerce = $$self{COERCE};
    my %new    = (@_);

    pdebug( 'entering', PPCDLEVEL1 );
    pIn();

    # TODO: Consider allowing comment tags to be specified

    # TODO: Consider line splitting and comment tag prepending where
    # TODO: it's not already done.

    foreach ( keys %new ) {
        pdebug( '%s is described as \'%s\'', PPCDLEVEL1, $_, $new{$_} );
        unless ( exists $$conf{$_} ) {
            $$conf{$_} = {};
            if ( exists $$coerce{$_} ) {
                $$conf{$_}{Value} =
                      $$coerce{$_} eq 'list' ? []
                    : $$coerce{$_} eq 'hash' ? {}
                    :                          '';
            } else {
                $$conf{$_}{Value} = '';
            }
        }
        $$conf{$_}{Description} = $new{$_};
    }

    pOut();
    pdebug( 'leaving w/rv: 1', PPCDLEVEL1 );

    return 1;
}

sub order {

    # Purpose:  Gets/sets order of parameters in file
    # Returns:  Ordered list of named parameters
    # Usage:    @params = $obj->order;
    # Usage:    @params = $obj->order(@newOrder);

    my $self  = shift;
    my $order = $$self{ORDER};
    my @new   = (@_);

    pdebug( 'entering w/(%s)', PPCDLEVEL1, @new );

    @$order = (@new) if scalar @new;

    pdebug( 'leaving w/rv: %s', PPCDLEVEL1, @$order );

    return @$order;
}

sub _parse {

    # Purpose:  Parses the passed list of lines and extracts comments,
    #           fields, and values and storing everything into the CONF
    #           hash
    # Returns:  True or false
    # Usage:    $rv = $obj->_parse(@lines);

    my $self      = shift;
    my $conf      = $$self{CONF};
    my $order     = $$self{ORDER};
    my $smart     = $$self{SMART_PARSER};
    my $tagDelim  = $$self{PARAM_DELIM};
    my $hashDelim = $$self{HASH_DELIM};
    my $listDelim = $$self{LIST_DELIM};
    my @lines     = @_;
    my $rv        = 1;
    my ( $i, $line, $comment, $entry, $field, $value );
    my ( $indentation, $data, $saveEntry );

    # Make sure some of the properties are sane
    croak 'LIST_DELIM and HASH_DELIM cannot be the same character sequence!'
        unless $$self{LIST_DELIM} ne $$self{HASH_DELIM};

    pdebug( 'entering', PPCDLEVEL2 );
    pIn();

    # Flatten lines using an explicit backslash
    for ( $i = 0; $i <= $#lines; $i++ ) {

        # Let's disable uninitialized warnings since there's a few
        # places here we really don't care
        no warnings 'uninitialized';

        if ( $lines[$i] =~ /\\\s*$/sm ) {
            pdebug( 'joining lines %s & %s', PPCDLEVEL2, $i + 1, $i + 2 );

            # Lop off the trailing whitespace and backslash, preserving
            # only one space on the assumption that if it's there it's a
            # natural word break.
            $lines[$i] =~ s/(\s)?\s*\\\s*$/$1/sm;

            # Concatenate the following line (if there is one) after stripping
            # off preceding whitespace
            if ( $i < $#lines ) {
                $lines[ $i + 1 ] =~ s/^\s+//sm;
                $lines[$i] .= $lines[ $i + 1 ];
                splice @lines, $i + 1, 1;
                --$i;
            }
        }
    }

    $saveEntry = sub {

        # Saves the extracted data into the conf hash and resets
        # the vars.

        my ($type);

        ( $field, $value ) =
            ( $entry =~ /^\s*([^$tagDelim]+?)\s*\Q$tagDelim\E\s*(.*)$/sm );
        pdebug( "saving data:\n\t(%s: %s)", PPCDLEVEL2, $field, $value );

        if ( exists $$self{COERCE}{$field} ) {

            # Get the field data type from COERCE
            $type = $$self{COERCE}{$field};

        } else {

            # Otherwise, try to autodetect data type
            $type =
                scalar quotewords( qr/\s*\Q$hashDelim\E\s*/sm, 0, $value ) > 1
                ? 'hash'
                : scalar quotewords( qr/\s*\Q$listDelim\E\s*/sm, 0, $value ) >
                1 ? 'list'
                :   'scalar';
        }
        pdebug( 'detected type of %s is %s', PPCDLEVEL2, $field, $type );

        # For all data types we should strip leading/trailing whitespace.
        # If they really want it they should quote it.
        $value =~ s/^\s+|\s+$//smg unless $type eq 'scalar';

        # We'll apply quotewords to scalar values only if the smart parser is
        # not being used or if we're not coercing all values into scalar for
        # this field.
        #
        # I hate having to do this but I was an idiot in the previous versions
        # and this is necessary for backwards compatibility.
        if ( $type eq 'scalar' ) {
            $value = join '',
                quotewords( qr/\s*\Q$listDelim\E\s*/sm, 0, $value )
                unless $smart
                    && exists $$self{COERCE}{$field}
                    && $$self{COERCE}{$field} eq 'scalar';
        } elsif ( $type eq 'hash' ) {
            $value = {
                quotewords(
                    qr/\s*(?:\Q$hashDelim\E|\Q$listDelim\E)\s*/sm, 0,
                    $value
                    ) };
        } elsif ( $type eq 'list' ) {
            $value = [ quotewords( qr/\s*\Q$listDelim\E\s*/sm, 0, $value ) ];
        }

        # Create the parameter record
        $$conf{$field}              = {};
        $$conf{$field}{Value}       = $value;
        $$conf{$field}{Description} = $comment;
        push @$order, $field unless grep /^\Q$field\E$/sm, @$order;
        $comment = $entry = '';
    };

    # Process lines
    $comment = $entry = '';
    while ( defined( $line = shift @lines ) ) {

        if ( $line =~ /^\s*(?:#.*)?$/sm ) {

            # Grab comments and blank lines
            pdebug( "comment/blank line:\n\t%s", PPCDLEVEL3, $line );

            # First save previous entries if $entry has content
            &$saveEntry() and $i = 0 if length $entry;

            # Save the comments
            $comment = length($comment) > 0 ? "$comment$line\n" : "$line\n";

        } else {

            # Grab configuration lines

            # If this is the first line of a new entry and there's no
            # PARAM_DELIM skip the line -- something must be wrong.
            #
            # TODO:  Error out/raise exception
            unless ( length $entry || $line =~ /\Q$tagDelim\E/sm ) {
                pdebug( "skipping spurious text:\n\t%s", PPCDLEVEL3, $line );
                next;
            }

            # Grab indentation characters and line content
            ( $indentation, $data ) = ( $line =~ /^(\s*)(.+)$/sm );
            pdebug( "data line:\n\t%s", PPCDLEVEL3, $data );

            if ($smart) {

                # Smart parsing is enabled

                if ( length $entry ) {

                    # There's current content

                    if ( length($indentation) > $i ) {

                        # If new indentation is greater than original
                        # indentation we concatenate the lines as a
                        # continuation
                        $entry .= $data;

                    } else {

                        # Otherwise we treat this a a new entry, so we save
                        # the old and store the current
                        &$saveEntry();
                        ( $i, $entry ) = ( length($indentation), $data );
                    }

                } else {

                    # No current content, so just store the current data and
                    # continue processing
                    ( $i, $entry ) = ( length($indentation), $data );
                }

            } else {

                # Smart parsing is disabled, so treat every line as a new
                # entry
                $entry = $data;
                &$saveEntry();
            }
        }
    }
    &$saveEntry() if length $entry;

    pOut();
    pdebug( 'leaving w/rv: %s', PPCDLEVEL2, $rv );

    return $rv;
}

sub _wrap {

    # Purpose:  Parses the passed line of test and inserts indentation and
    #           line breaks as needed
    # Returns:  Formated string
    # Usage:    $out = $obj->_wrap($fIndent, $sIndent, $textWidth,
    #                              $lineBreak, $paragraph);

    my $firstIndent = shift;
    my $subIndent   = shift;
    my $textWidth   = shift;
    my $lineBreak   = shift;
    my $paragraph   = shift;
    my ( @lines, $segment, $output );

    pdebug( "entering w/(%s)(%s)(%s)(%s):\n\t%s",
        PPCDLEVEL2, $firstIndent, $subIndent, $textWidth, $lineBreak,
        $paragraph );
    pIn();

    # Expand tabs in everything -- sorry everyone
    ($firstIndent) = expand($firstIndent);
    ($subIndent)   = expand($subIndent);
    $paragraph = expand("$firstIndent$paragraph");

    $lines[0] = '';
    while ( length($paragraph) > 0 ) {

        # Get the next string segment (splitting on whitespace)
        ($segment) = ( $paragraph =~ /^(\s*\S+\s?)/sm );

        if ( length $segment <= $textWidth - length $lines[-1] ) {

            # The segment will fit appended to the current line,
            # concatenate it
            $lines[-1] .= $segment;

        } elsif ( length $segment <= $textWidth - length $subIndent ) {

            # The segment will fit into the next line, add it
            $lines[-1] .= $lineBreak;
            push @lines, "$subIndent$segment";

        } else {

            # Else, split on the text width
            $segment =
                $#lines == 0
                ? substr $paragraph, 0, $textWidth
                : substr $paragraph, 0, $textWidth - length $subIndent;
            if ( length $segment > $textWidth - length $lines[-1] ) {
                $lines[-1] .= $lineBreak;
                push @lines,
                    ( $#lines == 0 ? $segment : "$subIndent$segment" );
            } else {
                $lines[-1] .= $segment;
            }
        }
        $paragraph =~ s/^.{@{[length($segment)]}}//sm;
    }
    $lines[-1] .= "\n";

    $output = join '', @lines;

    pOut();
    pdebug( "leaving w/rv:\n%s", PPCDLEVEL2, $output );

    return $output;
}

sub hasParameter {

    # Purpose:  Checks to see if the specified parameter exists as a
    #           configuration parameter
    # Returns:  True or false
    # Usage:    $rv = $obj->hasParameter($name);

    my $self   = shift;
    my $param  = shift;
    my $rv     = 0;
    my @params = ( keys %{ $self->{CONF} }, keys %{ $self->{DEFAULTS} }, );

    croak 'Mandatory first parameter must be a defined parameter name'
        unless defined $param;

    pdebug( 'entering w/(%s)', PPCDLEVEL1, $param );
    pIn();

    $rv = scalar grep /^\Q$param\E$/sm, @params;

    pOut();
    pdebug( 'leaving w/rv: %s', PPCDLEVEL1, $rv );

    return $rv;
}

1;

__END__