File Coverage

lib/Config/NameValue.pm

Criterion	Covered	Total	%
statement	71	94	75.5
branch	33	46	71.7
condition	14	27	51.8
subroutine	13	13	100.0
pod	6	6	100.0
total	137	186	73.6

package Config::NameValue;

# ABSTRACT: Round trip simple name/value config file handling.

# VERSION


use strict;
use warnings;
use namespace::autoclean;

use Carp;
use File::Slurp qw( slurp );
use Scalar::Util qw( blessed );
use POSIX qw( strftime );

our $VERSION = 1.00;

{  # Quick! Hide!

  my $error;


  sub new {

    my ( $class, $file ) = @_;

    croak 'Calling new as a function is not supported'
      unless $class && $class ne '';

    my $self = bless {}, ref $class || $class;

    $self->load( $file )
      if $file && $file ne '';

    return $self;

  }


  sub load {

    my ( $self, $file ) = @_;

    croak 'Calling load as a function is not supported'
      unless blessed $self;

    if ( ! $file || $file eq '' ) {

      croak 'No file to load'
        unless exists $self->{ file } && $self->{ file } ne '';

      $file = $self->{ file };

    }

    my @lines = slurp( $file, { chomp => 1 } );

    for ( my $i = 0 ; $i < @lines ; $i++ ) {

      my $line = $lines[ $i ];

      next if $line =~ /^\s*(#.*)?$/;  # Ignore blank lines and comment lines
      $line =~ s/(?

      $line =~ s/^\s*(.*?)\s*$/$1/;    # Strip leading and trailing whitespace

      my @data = split /\s*=\s*/, $line, 2;
      $data[ 0 ] =~ s/^\s*(.*)/$1/;
      $data[ 1 ] =~ s/^(["'])(.*)\1$/$2/;
      $data[ 1 ] =~ s/\\#/#/g;

      $self->{ name }{ $data[ 0 ] } = { value => $data[ 1 ], line => $i, modified => 0 };

    }

    $self->{ file }     = $file;
    $self->{ lines }    = \@lines;
    $self->{ count }    = scalar @lines;
    $self->{ modified } = 0;

    return 1;

  } ## end sub load


  sub save {

    my ( $self, $file ) = @_;

    croak 'Calling save as a function is not supported'
      unless blessed $self;

    if ( ! $file || $file eq '' ) {

      croak 'No file to save'
        unless exists $self->{ file } && $self->{ file } ne '';

      $file = $self->{ file };

    } elsif ( $file eq $self->{ file } ) {

      croak 'No changes, not saving'
        unless $self->{ modified };

    }

    if ( $self->{ modified } ) {

      my @modified = grep { $self->{ name }{ $_ }{ modified } } keys %{ $self->{ name } };

      for my $name ( @modified ) {

        my ( $value, $line ) = @{ $self->{ name }{ $name } }{ qw( value line ) };
        $self->{ lines }[ $line ] =~ s/^(\s*(["'])$name\2\s*=\s*)(["'])(?:.*)\3\s*$/$1$3$value$3/;

      }
    }

    my $work_file = "$file.work";

    require IO::Handle;

    open my $FH, '>', $work_file
      or croak "Unable to open $work_file: $!";

    print $FH "$_\n" for @{ $self->{ lines } };

    $FH->close
      or carp "Unable to close $work_file: $!\n";  # How do I test this to satisfy Devel::Cover?

    rename $work_file, $file
      or croak "Unable to rename $work_file to $file: $!";

  } ## end sub save


  sub get {

    my ( $self, $name ) = @_;

    croak 'Calling get as a function is not supported'
      unless blessed $self;

    croak "Nothing loaded"
      if ! exists $self->{ count } || $self->{ count } == 0;

    croak "Can't get nothing (no name passed)"
      if $name eq '';

    do { $error = "$name does not exist"; return }
      unless exists $self->{ name }{ $name };

    return $self->{ name }{ $name }{ value };

  } ## end sub get


  sub set {

    my ( $self, $name, $value ) = @_;

    croak 'Calling set as a function is not supported'
      unless blessed $self;

    croak "Nothing loaded"
      if ! exists $self->{ count } || $self->{ count } == 0;

    croak "Can't set nothing (no name passed)"
      if $name eq '';

    if ( ! exists $self->{ name }{ $name } ) {

      #    my $date = do {
      #
      #      my @d = localtime( time );
      #      $d[5] += 1900;
      #      $d[4]++;
      #
      #      join '-', @d[4,3,5];
      #
      #    };

      $value =~ s/#/\\#/;

      my $comment = sprintf '# %s added by %s on %s', $name, __PACKAGE__, strftime( '%F', gmtime );

      push @{ $self->{ lines } }, $comment;
      push @{ $self->{ lines } }, "$name=\"$value\"";

      $self->{ count }++;
      $self->{ name }{ $name } = { value => $value, line => $self->{ count }++, modified => 0, };

    } else {

      @{ $self->{ name }{ $name } }{ qw( value modified ) } = ( $value, 1 );

    }

    $self->{ modified } = 1;

    return 1;

  } ## end sub set


  sub error { $error }

}  # You can come out now!

1;

__END__