view release on metacpan or  search on metacpan

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

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<text> );

    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<key> :get<key> );
    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<name> :get<name> default => '' );
    my %sep_count_of    : ATTR;
    my %precomm_of      : ATTR( :init_arg<precomm> default => '' );
    my %parcomm_of      : ATTR( :init_arg<parcomm> default => '' );
    my %components_of   : ATTR;
    my %deleted_of      : ATTR;
    my %seen            : ATTR;
    my %is_first        : ATTR( :init_arg<first> 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;