File Coverage

blib/lib/Config/Std.pm

Criterion	Covered	Total	%
statement	253	277	91.3
branch	71	96	73.9
condition	32	61	52.4
subroutine	34	41	82.9
pod			n/a
total	390	475	82.1

package Config::Std;

our $VERSION = '0.903';

use 5.007_003; # Testing with 5.8.1 since that's cpanm minimum :-)
use strict;
use warnings;

my %global_def_sep;
my %global_inter_gap;

sub import {
    my ($package, $opt_ref) = @_;
    my $caller = caller();
    $global_def_sep{$caller} = $opt_ref->{def_sep};
    $global_inter_gap{$caller} = $opt_ref->{def_gap};
    for my $sub_name (qw( read_config write_config )) {
        $opt_ref->{$sub_name} ||= $sub_name;
    }
    no strict "refs";
    *{$caller.'::'.$opt_ref->{read_config}}  = \&Config::Std::Hash::read_config;
    *{$caller.'::'.$opt_ref->{write_config}} = \&Config::Std::Hash::write_config;
}

package Config::Std::Gap;
use Class::Std;
{
    sub serialize { return "\n" }
    sub update  {}
    sub extend  {}
    sub copy_to {}
}

package Config::Std::Comment;
use Class::Std;
{
    my %text_of : ATTR( :init_arg );

    sub serialize {
        my ($self) = @_;
        return $text_of{ident $self};
    }

    sub append_comment {
        my ($self, $new_text) = @_;
        $text_of{ident $self} .= $new_text;
    }

    sub update  {}
    sub extend  {}
    sub copy_to {}
}

package Config::Std::Keyval;
use Class::Std;
{
    my %key_of      : ATTR( :init_arg :get );
    my %vals_of     : ATTR;
    my %deleted_of  : ATTR;

    sub BUILD {
        my ($self, $ident, $arg_ref) = @_;

        $vals_of{$ident}     = [ { %{$arg_ref} } ];
    }

    my %SEPARATOR = ( ':' => ': ', '=' => ' = ' );

    use Carp;

    sub serialize {
        my ($self, $def_sep, $block_name) = @_;
        my $ident = ident $self;

        return "" if $deleted_of{$ident};

        my ($key, $vals) = ($key_of{$ident}, $vals_of{$ident});

        my $keyspace = q{ } x length($key);

        my $serialization = q{};

        for my $n (0..$#{$vals}) {
            my ($val,$sep,$comm) = @{$vals->[$n]}{qw(val sep comm)};

            my $val_type = ref $val;
            croak qq{Can't save \L$val_type\E ref as value for key {'$block_name'}{'$key'} (only scalars or array refs)}
                if $val_type && $val_type ne 'ARRAY';

            $sep = $SEPARATOR{$sep || $def_sep};

            my @vals = $val_type eq 'ARRAY' ? @{$val} : $val;
            s/ (?!\Z) \n /\n$keyspace$sep/gxms for @vals;

            $serialization .= $comm || q{};

            $serialization .= join q{}, map {"$key$sep$_\n"} @vals;
        }

        return $serialization;
    }

    sub update {
        my ($self, $hash_ref, $updated_ref) = @_;
        my $ident = ident $self;

        my $key = $key_of{$ident};

        if (!exists $hash_ref->{$key}) {
            $deleted_of{$ident} = 1;
        }
        else {
            my $val = $hash_ref->{$key};
            my @newvals = ref $val eq 'ARRAY' ? @{$val} : $val;
            for my $n (0..$#newvals) {
                $vals_of{$ident}[$n]{val} = $newvals[$n];
            }
            splice @{$vals_of{$ident}}, scalar @newvals;
        }

        $updated_ref->{$key} = 1;

        return 1;
    }

    sub copy_to {
        my ($self, $hash_ref)  = @_;
        my $ident = ident $self;
        my @vals = map $_->{val}, @{$vals_of{$ident}};
        $hash_ref->{$key_of{$ident}} = @vals > 1 ? \@vals : $vals[0];
    }

    sub multivalue {
        my ($self, $sep, $val, $comm) = @_;
        push @{$vals_of{ident $self}}, {val=>$val, sep=>$sep, comm=>$comm};
    }
}

package Config::Std::Block;
use Class::Std;
{
    my %name_of         : ATTR( :init_arg :get default => '' );
    my %sep_count_of    : ATTR;
    my %precomm_of      : ATTR( :init_arg default => '' );
    my %parcomm_of      : ATTR( :init_arg default => '' );
    my %components_of   : ATTR;
    my %deleted_of      : ATTR;
    my %seen            : ATTR;
    my %is_first        : ATTR( :init_arg default => '' );

    sub BUILD {
        my ($self, $ident) = @_;
        @{$sep_count_of{$ident}}{':','='} = (0,0);
        $components_of{$ident} = [];
        $seen{$ident} = {};
    }

    sub copy_to {
        my ($self, $hash_ref) = @_;
        my $ident = ident $self;

        my $keyvals = $hash_ref->{$name_of{$ident}} ||= {};

        for my $comp ( @{$components_of{$ident}} ) {
            $comp->copy_to($keyvals);
        }

        $hash_ref->{$name_of{$ident}} = $keyvals;
    }

    sub serialize {
        my ($self, $first, $caller, $post_gap, $inter_gap) = @_;
        my $ident = ident $self;

        return q{} if $deleted_of{$ident};

        my $is_anon = $first && length($name_of{$ident}) == 0;

        my $serialization = q{};
        if (!$is_anon) {
            $serialization = ($precomm_of{$ident} || q{})
                           . "[$name_of{$ident}]"
                           . (defined $parcomm_of{$ident}?$parcomm_of{$ident}:q{})
                           . "\n";
        }

        my $gds = $global_def_sep{$caller};
        my $def_sep
            = defined $gds                                             ? $gds
            : $sep_count_of{$ident}{':'} >= $sep_count_of{$ident}{'='} ? ':'
            :                                                            '='
            ;

        $self->ensure_gap() if $inter_gap && !$is_anon;

        for my $comp ( @{$components_of{$ident}} ) {
            $serialization .= $comp->serialize($def_sep, $name_of{$ident});
        }

        return $serialization;
    }

    sub update {
        my ($self, $hash_ref, $updated_ref) = @_;
        my $ident = ident $self;

        if (!defined $hash_ref) {
            $deleted_of{$ident} = 1;
            return;
        }

        for my $comp ( @{$components_of{$ident}} ) {
            $comp->update($hash_ref, $updated_ref) or next;
        }
    }

    sub extend {
        my ($self, $hash_ref, $updated_ref, $post_gap, $inter_gap) = @_;

        # Only the first occurrence of a block has new keys added...
        return unless $is_first{ident $self};

        my $first = 1;
	# RT 85956
        for my $key ( sort grep {!$updated_ref->{$_}} keys %{$hash_ref}) {
            my $value = $hash_ref->{$key};
            my $separate = ref $value || $value =~ m/\n./xms;
            $self->ensure_gap() if ($first ? $post_gap : $inter_gap)
                                    || $separate;
            $self->add_keyval($key, undef, $hash_ref->{$key});
            $self->add_gap() if $separate;
            $first = 0;
        }
    }

    sub ensure_gap {
        my ($self) = @_;
        my $comp_ref = $components_of{ident $self};
        return if @{$comp_ref} && $comp_ref->[-1]->isa('Config::Std::Gap');
        push @{$comp_ref}, Config::Std::Gap->new();
    }

    sub add_gap {
        my ($self) = @_;
        push @{$components_of{ident $self}}, Config::Std::Gap->new();
    }

    sub add_comment {
        my ($self, $text) = @_;
        my $comp_ref = $components_of{ident $self};
        if ($comp_ref && @{$comp_ref} && $comp_ref->[-1]->isa('Config::Std::Comment') ) {
            $comp_ref->[-1]->append_comment($text);
        }
        else {
            push @{$comp_ref}, Config::Std::Comment->new({text=>$text});
        }
    }

    sub add_keyval {
        my ($self, $key, $sep, $val, $comm) = @_;
        my $ident = ident $self;

        $sep_count_of{$ident}{$sep}++ if $sep;

        my $seen = $seen{$ident};

        if ($seen->{$key}) {
            $seen->{$key}->multivalue($sep, $val, $comm);
            return;
        }

        my $keyval
            = Config::Std::Keyval->new({key=>$key, sep=>$sep, val=>$val, comm=>$comm});
        push @{$components_of{$ident}}, $keyval;
        $seen->{$key} = $keyval;
    }
}

package Config::Std::Hash;
use Class::Std;
{

    use Carp;
    use Fcntl ':flock';     # import LOCK_* constants

    my %post_section_gap_for :ATTR;
    my %array_rep_for        :ATTR;
    my %filename_for         :ATTR;

    sub write_config (\[%$];$) {
        my ($hash_ref, $filename) = @_;
        $hash_ref = ${$hash_ref} if ref $hash_ref eq 'REF';

        $filename = $filename_for{$hash_ref} if @_<2;

        croak "Missing filename for call to write_config()"
            unless $filename;

        my $caller = caller;

        my $inter_gap
            = exists $global_inter_gap{$caller} ? $global_inter_gap{$caller}
            :                                      1;
        my $post_gap
            = $post_section_gap_for{$hash_ref}
            || (defined $global_inter_gap{$caller} ? $global_inter_gap{$caller}
                                                   : 1
               );

        # Update existing keyvals in each block...
        my %updated;
        for my $block ( @{$array_rep_for{$hash_ref}} ) {
            my $block_name = $block->get_name();
            $block->update($hash_ref->{$block_name}, $updated{$block_name}||={});
        }

        # Add new keyvals to the first section of block...
        for my $block ( @{$array_rep_for{$hash_ref}} ) {
            my $block_name = $block->get_name();
            $block->extend($hash_ref->{$block_name}, $updated{$block_name},
                           $post_gap, $inter_gap
                          );
        }

        # Add new blocks at the end...
        for my $block_name ( sort grep {!$updated{$_}} keys %{$hash_ref} ) {
            my $block = Config::Std::Block->new({name=>$block_name});
            my $subhash = $hash_ref->{$block_name};
            my $first = 1;
	    # RT 85956
            for my $key ( sort keys %{$subhash} ) {
                if (!defined $subhash->{$key}) {
                    croak "Can't save undefined value for key {'$block_name'}{'$key'} (only scalars or array refs)";
                }
                my $value = $subhash->{$key};
                my $separate = ref $value || $value =~ m/\n./xms;
                $block->ensure_gap() if ($first ? $post_gap : $inter_gap)
                                     || $separate;
                $block->add_keyval($key, undef, $value);
                $block->add_gap() if $separate;
                $first = 0;
            }
            $block->ensure_gap();
            push @{$array_rep_for{$hash_ref}}, $block;
        }

        open my $fh, '>', $filename
            or croak "Can't open config file '$filename' for writing (\L$!\E)";

        flock($fh,LOCK_EX|LOCK_NB)
            || croak "Can't write to locked config file '$filename'"
                if ! ref $filename;

        my $first = 1;
        for my $block ( @{$array_rep_for{$hash_ref}} ) {
            print {$fh} $block->serialize($first, scalar caller, $post_gap);
            $first = 0;
        }

        flock($fh,LOCK_UN) if ! ref $filename;

        return 1;
    }

    sub read_config ($\[%$]) {
        my ($filename, $var_ref, $opt_ref) = @_;
        my $var_type = ref($var_ref) || q{};
        my $hash_ref;
        if ($var_type eq 'SCALAR' && !defined ${$var_ref} ) {
            ${$var_ref} = $hash_ref = {};
        }
        elsif ($var_type eq 'HASH') {
            $hash_ref = $var_ref;
        }
        else {
            croak q{Scalar second argument to 'read_config' must be empty};
        }

        bless $hash_ref, 'Config::Std::Hash';

        my $blocks = $array_rep_for{$hash_ref}
                   = _load_config_for($filename, $hash_ref);

        for my $block ( @{$blocks} ) {
            $block->copy_to($hash_ref);
        }

        $filename_for{$hash_ref} = $filename;

        # Remove initial empty section if no data...
        if (!keys %{ $hash_ref->{q{}} }) {
            delete $hash_ref->{q{}};
        }

        return 1;
    }

    sub _load_config_for {
        my ($filename, $hash_ref) = @_;

        open my $fh, '<', $filename
            or croak "Can't open config file '$filename' (\L$!\E)";
        flock($fh,LOCK_SH|LOCK_NB)
            || croak "Can't read from locked config file '$filename'"
                if !ref $filename;
        my $text = do{local $/; <$fh>};
        flock($fh,LOCK_UN) if !ref $filename;

        my @config_file = Config::Std::Block->new({ name=>q{}, first=>1 });
        my $comment = q{};
        my %seen;

        # Start tracking whether section markers have gaps after them...
        $post_section_gap_for{$hash_ref} = 0;

        for ($text) {
            pos = 0;
            while (pos() < length() ) {
                # Gap...
                if (m/\G (?: [^\S\n]* (?:\n|\z)+)/gcxms) {
                    ### Found gap
                    $config_file[-1]->add_comment($comment) if $comment;
                    $config_file[-1]->add_gap();
                    $comment = q{};
                }

                # Comment...
                elsif (m/\G (\s* [#;] [^\n]* (?:\n|\z) )/gcxms) {
                    ### Found comment: $1
                    $comment .= $1;
                }

                # Block...
                elsif (m/\G ([^\S\n]*) [[]  ( [^]\n]* ) []] ( ([^\S\n]*) [#;] [^\n]* )? [^\S\n]* (?:\n|\z)/gcxms) {
                    my ($pre, $name, $parcomm, $ws) = ($1, $2, $3, $4);
                    ### Found block: $name
                    if ($parcomm) {
                        $pre = 2 + length($pre) + length($name) + length($ws);
                        if (m/\G ( (?: \n? [ ]{$pre,} [#] [^\n]* )+ )/gcxms) {
                            $parcomm .= "\n$1";
                        }
                    }
                    push @config_file,
                            Config::Std::Block->new({
                                name    => $name,
                                precomm => $comment,
                                parcomm => $parcomm,
                                first   => !$seen{$name}++,
                            });
                    $comment = q{};

                    # Check for trailing gap...
                    $post_section_gap_for{$hash_ref}
                        += m/\G (?= [^\S\n]* (?:\n|\z) )/xms ? +1 : -1;
                }

                # Key/value...
                elsif (m/\G [^\S\n]* ([^=:\n]+?) [^\S\n]* ([:=] [^\S\n]*) ([^\n]*) (?:\n|\z)/gcxms) {
                    my ($key, $sep, $val) = ($1, $2, $3);

                    my $pure_sep = $sep;
                    $pure_sep =~ s/\s*//g;

                    # Continuation lines...
                    my $continued = 0;
                    while (m/\G [^\S\n]* \Q$sep\E ([^\n]*) (?:\n|\z) /gcxms
                       ||  m/\G [^\S\n]* \Q$pure_sep\E ([^\n]*) (?:\n|\z) /gcxms
                    ) {
                        $val .= "\n$1";
                        $continued = 1;
                    }

                    $val =~ s/\A \s*|\s* \z//gxms if !$continued;

                    ### Found kv: $key, $val

                    $config_file[-1]->add_keyval($key, $pure_sep, $val,
                    $comment); $comment = q{}; }

                # Mystery...
                else {
                    my ($problem) = m/\G ([^\n]{10,40}|.{10}) /gcxms;
                    die "Error in config file '$filename' near:\n\n\t$problem\n";
                }
            }
        }

        return \@config_file;
    }

    sub DEMOLISH {
        my ($self, $ident) = @_;

        # Do nothing. Defined to suppress use warnings in Class::Std destructor.
    }


}


1; # Magic true value required at end of module
__END__