File Coverage

blib/lib/Config/Trivial.pm

Criterion	Covered	Total	%
statement	177	177	100.0
branch	105	120	87.5
condition	15	18	83.3
subroutine	19	19	100.0
pod	8	8	100.0
total	324	342	94.7

#   $Id: Trivial.pm 63 2014-05-23 09:42:15Z adam $

package Config::Trivial;

use 5.010;		# May work on earlier perls but I've not tested
use utf8;
use strict;
use warnings;
use Carp;

our $VERSION = '0.81';
my ( $_package, $_file ) = caller;

#
#   NEW
#

sub new {
    my $class  = shift;
    my %args   = @_;
    my $object = bless {
        _config_file   => $_file,       # The Config file, default is caller
        _self          => 1,            # Set Self Read
        _error_message => q{},          # Error Messages
        _configuration => {},           # Where the configuration data goes
        _backup_char   => q{~},         # Backup marker
        _separator     => q{ },         # Separator
        _multi_file    => 0,            # Multi file mode
        _debug    => $args{debug}    || 0, # Debugging (verbose) mode
        _strict   => $args{strict}   || 0, # Strict mode
        _no_check => $args{no_check} || 0, # Skip filesystem checks
        },
        ref $class || $class;

    if ( $args{config_file} ) {
        croak "Unable to read config file $args{config_file}"
            unless set_config_file( $object, $args{config_file} );
    }
    return $object;
}

#
#   SET_CONFIG_FILE
#

sub set_config_file {
    my $self               = shift;
    my $configuration_file = shift;

    if ( ref $configuration_file ) {
        if ( ref $configuration_file eq 'HASH' ) {
            foreach my $sub_config_file ( sort keys %{$configuration_file} ) {
                my $config_file = $configuration_file->{$sub_config_file};
                if ( $config_file ) {
                    if (! $self->_check_file($config_file) ) {
                        return;
                    }
                }
                else {
                    return $self->_raise_error('File error: No file name supplied')
                }
            }
            $self->{_config_file} = $configuration_file;
            $self->{_self}        = 0;
            $self->{_multi_file}  = 1;
            return $self;
        }
        else {
            croak 'ERROR: Can only deal with a hash references';
        }
    }
    else {
        if ( $self->_check_file($configuration_file) ) {
            $self->{_config_file} = $configuration_file;
            $self->{_self}        = 0;
            $self->{_multi_file}  = 0;
            return $self;
        }
        else {
            return;
        }
    }
}

#
#   READ
#

sub read {
    my $self = shift;
    my $key  = shift;    # If there is a key, return only it's value

    if ( $self->{_multi_file} ) {
        croak 'ERROR: Read can only deal with a single file';
    }

    $self->_read_config( $self->{_config_file});

    return $self->{_configuration}->{$key} if $key;
    return $self->{_configuration};
}


#
#   MULTI_READ
#

sub multi_read {
    my $self = shift;
    my $hash = shift;   # If there is specific hash, return only it's value

    if ( ! $self->{_multi_file} ) {
        croak 'ERROR: Multi_Read is for multiple configuration files';
    }

    foreach my $config_key ( keys %{$self->{_config_file}} ) {
        my $config_file = $self->{_config_file}->{$config_key};
        $self->_read_config( $config_file, $config_key );
#        return unless $self->_check_file( $config_file );
    }

    return $self->{_configuration}->{$hash} if $hash;
    return $self->{_configuration};
}

#
#   GET_CONFIGURATION
#

sub get_configuration {
    my $self = shift;
    my $key  = shift;

    return $self->{_configuration}->{$key} if $key;
    return $self->{_configuration};
}

#
#   SET_CONFIGURATION
#

sub set_configuration {
    my $self = shift;
    my $hash = shift;

    return $self->_raise_error('No configuration data')
        unless $hash;
    return $self->_raise_error('Configuration not a reference')
        unless ref $hash;
    return $self->_raise_error(q{Configuration data isn't a hash reference})
        unless ref $hash eq 'HASH';

    $self->{_configuration} = $hash;
    return $self;
}

#
#   WRITE
#

sub write {
    my $self = shift;
    my %args = @_;

    my $settings = $args{'configuration'} || $self->{_configuration};

    croak 'ERROR: No settings hash to write.'
        unless $settings;
    croak 'ERROR: Settings not a hashref.'
        unless ref $settings eq 'HASH';

    my $file = $args{'config_file'} || $self->{_config_file};

    if ( $file ) {
        if (   ( $_file eq $file )
            || ( $0 eq $file ) )
        {
            return $self->_raise_error(
                'Not allowed to write to the calling file.');
        }
    }
    else {
        croak 'File error: No file name supplied';
    }

    if ( -e $file ) {
        croak "ERROR: Insufficient permissions to write to: $file"
            unless ( -w $file );
        rename $file, $file . $self->{_backup_char}
            or croak "ERROR: Unable to rename $file.";
    }

    open my $config, '>', $file
        or croak "ERROR: Unable to write configuration file: $file";
    print {$config}
        "#\n#\tConfig file written by $_file\n#\tUsing Config::Trivial version $VERSION\n#\n\n";

    foreach my $setting ( keys %{$settings} ) {
        if ( $setting =~ / / ) {                    # Check for spaces in keys
            croak qq{ERROR: Setting key "$setting" contains an illegal space}
                if $self->{_strict};
            carp qq{WARNING: Setting key "$setting" contains an illegal space}
                if $self->{_debug};
            my $old_setting = $setting;
            $setting =~ s/ /_/g;
            croak 'ERROR: Unable to fix space in key, replacement key exists already'
                if $settings->{$setting};
            $settings->{$old_setting} = q{ } unless $settings->{$old_setting};
            $settings->{$old_setting} =~ s/\\\s*$/\\ #/;
            printf {$config} "$setting%s$settings->{$old_setting}\n",
                length $old_setting >= 8 ? "\t" : "\t\t";
            next;
        }
        $settings->{$setting} = q{ } unless $settings->{$setting};
        $settings->{$setting} =~ s/\\\s*$/\\ #/;
        printf {$config} "$setting%s$settings->{$setting}\n",
            length $setting >= 8 ? "\t" : "\t\t";
    }

    my $time = localtime;
    print {$config} "\n#\n#\tThis file written at $time\n#\n";
    close $config;
    return 1;
}

#
#   GET_ERROR
#

sub get_error {
    my $self = shift;
    return $self->{_error_message};
}

#   #################
#   Private Functions
#   #################

#
#   Perform some file checks
#

sub _check_file {
    my $self = shift;
    my $file = shift;

#   Skip ALL checks if no_check is set
    if ( $self->{'_no_check'} ) {
        return $self;
    }

#   Check the filename before using - may be slow on some filesystems
    return $self->_raise_error('File error: No file name supplied')
        unless $file;
    return $self->_raise_error("File error: Cannot find $file")
        unless -e $file;
    return $self->_raise_error("File error: $file isn't a real file")
        unless -f _;
    return $self->_raise_error("File error: Cannot read file $file")
        unless -r _;
    return $self->_raise_error("File error: $file is zero bytes long")
        if -z _;
    return $self;
}

#
#   Open and read an individual config file
#

sub _read_config {
    my $self  = shift;
    my $file  = shift;
    my $f_key = shift;

    return unless $self->_check_file( $file );

    open my $config, '<', $file
        or croak "ERROR: Unable to open configuration file: $file";

    if ( $self->{_self} )
    {    # We are now parsing the calling file for it's __DATA__ section
        while ( <$config> ) {
            last if /^__DATA__\s*$/;
        }
    }
    while ( <$config> ) {
        next if /^\s*#/;                    # Skip comment lines starting #
        next if /^\s*\n/;                   # Skip any empty lines
        last if /^__END__\s*$/;             # Don't care what comes after this
        if ( s/\\\s*$// ) {                 # Look for a continuation character
            $_ .= <$config>;                # If found then glue the lines together
            redo unless eof $config;
        }
        $self->_process_line( $_, $., $f_key );    # Send the line off for processing
    }
    close $config;
    return;
}

#
#   Raise error condition
#
sub _raise_error {
    my $self    = shift;
    my $message = shift;

    croak $message if $self->{_strict};    # STRICT: die with the message
    carp $message  if $self->{_debug};     # DEBUG:  warn with the message
    $self->{_error_message} = $message;    # NORMAL: set the message
    return;
}

#
#   Parse a line and add to Config structure
#
sub _process_line {
    my $self    = shift;
    my $line    = shift;
    my $line_no = shift;
    my $f_key   = shift;
    my ( $key, $value );

    chomp $line;
    $line =~ s/^\s+|\s+$|\s*#+.*$//g;       # Remove comments, and spaces at start or end
    $line =~ s/\s+/ /g;                     # Multiple whitespace to one space globally

    if ( $line ) {
        ( $key, $value ) = split / /, $line, 2;
    }
    if ( $key ) {
	    no warnings 'uninitialized';
        $key = lc _clean_string( $key );
    }
    if ( exists $self->{_configuration}->{$key} ) {
        croak qq{ERROR: Duplicate key "$key" found in config file on line $line_no}
            if $self->{_strict};
        carp qq{WARNING: Duplicate key "$key" found in config file on line $line_no}
            if $self->{_debug};
    }
    if ( $key ) {
        if ( defined $value ) {
            if ( $f_key ) {
                $self->{_configuration}->{$f_key}->{$key} = $value;
            }
            else {
                $self->{_configuration}->{$key} = $value;
            }
        }
        else {
            carp qq{WARNING: Key "$key" has no valid value, on line $line_no of the config file}
                if $self->{_debug};
            $self->{_configuration}->{$key} = undef unless $self->{_strict};
        }
    }
    return;
}

#
#   Clean data up to make a key out of it
#
sub _clean_string {
    my $input = shift;
    my $output;

    $input =~ tr/\e\`\'"%//ds;                              # Remove less gross crud from the input
    $output = $1
        if ( $input =~ /^([\^\$-=\?\/\w.:\\\s\@~\|]+)$/ );  # De-Taint the input line
    $output =~ s/^\s+|\s+$//g if $output;                   # Remove spaces at start or end
    return $output;
}

1;


__END__