view release on metacpan or  search on metacpan

lib/Config/Trivial.pm  view on Meta::CPAN

#   $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

lib/Config/Trivial.pm  view on Meta::CPAN

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;