File Coverage

blib/lib/Config/Properties.pm

Criterion	Covered	Total	%
statement	207	314	65.9
branch	58	154	37.6
condition	19	44	43.1
subroutine	39	55	70.9
pod	19	32	59.3
total	342	599	57.1

package Config::Properties;

use strict;
use warnings;

our $VERSION = '1.78';

use IO::Handle;
use Carp;
use PerlIO qw();
use Errno qw();

{
    no warnings;
    sub _t_key ($) {
	my $k=shift;
	defined($k) && length($k)
	    or croak "invalid property key '$k'";
    }

    sub _t_value ($) {
	my $v=shift;
	defined $v
	    or croak "undef is not a valid value for a property";
    }

    sub _t_format ($) {
	my $f=shift;
	defined ($f) && $f=~/\%s.*\%s/
	    or croak "invalid format '%f'";
    }

    sub _t_validator ($) {
	my $v=shift;
	defined($v) &&
	    UNIVERSAL::isa($v, 'CODE') or
		croak "invalid property validator '$v'";
    }

    sub _t_file ($) {
	my $f=shift;
	defined ($f) or
	    croak "invalid file '$f'";
    }

    sub _t_order ($) {
        my $o = shift;
        $o =~ /^(?:keep|alpha|none)$/ or
            croak "invalid order";
    }

    sub _t_encoding ($) {
        my $e = shift;
        $e =~ /^[\w\-]+$/ or
            croak "invalid encoding '$e'";
    }
}

#   new() - Constructor
#
#   The constructor can take one optional argument "$defaultProperties"
#   which is an instance of Config::Properties to be used as defaults
#   for this object.
sub new {
    my $class = shift;
    my $defaults;
    $defaults = shift if @_ & 1;
    my %opts = @_;
    $defaults = delete $opts{defaults} unless defined $defaults;
    my $format = delete $opts{format};
    $format = '%s=%s' unless defined $format;
    my $wrap = delete $opts{wrap};
    $wrap = 1 unless defined $wrap;
    my $order = delete $opts{order};
    $order = 'keep' unless defined $order;
    _t_order($order);
    my $file = delete $opts{file};
    my $encoding = delete $opts{encoding} || 'latin1';
    _t_encoding($encoding);
    my $eol_re = delete $opts{eol_re};
    $eol_re = qr/\r\n|\n|\r/ unless defined $eol_re;
    my $line_re = qr/^(.*?)(?:$eol_re)/s;

    %opts and croak "invalid option(s) '" . join("', '", keys %opts) . "'";

    if (defined $defaults) {
        if (ref $defaults eq 'HASH') {
            my $d = Config::Properties->new;
            while (my ($k, $v) = each %$defaults) {
                $d->setProperty($k, $v);
            }
            $defaults = $d;
        }
        elsif (!$defaults->isa('Config::Properties')) {
            croak die "defaults parameter is not a Config::Properties object or a hash"
        }
    }

    my $self = { defaults => $defaults,
		 format => $format,
                 wrap => $wrap,
                 order => $order,
		 properties => {},
		 last_line_number => 0,
		 property_line_numbers => {},
                 file => $file,
                 encoding => $encoding,
                 line_re => $line_re };
    bless $self, $class;

    if (defined $file) {
        open my $fh, '<', $file or croak "unable to open file '$file': $!";
        $self->load($fh);
        close $fh or croak "unable to load file '$file': $!";
    }
    return $self;
}

# set property only if its going to change the property value.
#
sub changeProperty {
    my ($self, $key, $new, @defaults) = @_;
    _t_key $key;
    _t_value $new;
    my $old=$self->getProperty($key, @defaults);
    if (!defined $old or $old ne $new) {
	$self->setProperty($key, $new);
	return 1;
    }
    return 0;
}

sub deleteProperty {
    my ($self, $key, $recurse) = @_;
    _t_key $key;

    if (exists $self->{properties}{$key}) {
      delete $self->{properties}{$key};
      delete $self->{property_line_numbers}{$key};
    }

    $self->{defaults}->deleteProperty($key, 1)
	if ($recurse and $self->{defaults});
}

#	setProperty() - Set the value for a specific property
sub setProperty {
    my ($self, $key, $value)=@_;
    _t_key $key;
    _t_value $value;

    defined(wantarray) and
	carp "warning: setProperty doesn't return the old value anymore";

    $self->{property_line_numbers}{$key} ||= ++$self->{last_line_number};
    $self->{properties}{$key} = $value;
}

sub _properties {
    my $self=shift;
    if (defined ($self->{defaults})) {
	my %p=($self->{defaults}->_properties, %{$self->{properties}});
	return %p;
    }
    return %{ $self->{properties} }
}

#       properties() - return a flated hash with all the properties
sub properties {
    my $self = shift;
    my %p = $self->_properties;
    map { $_ => $p{$_} } $self->_sort_keys(keys %p);
}



#	getProperties() - Return a hashref of all of the properties
sub getProperties { return { shift->_properties }; }


#	getFormat() - Return the output format for the properties
sub getFormat { shift->{format} }


#	setFormat() - Set the output format for the properties
sub setFormat {
    my ($self, $format) = @_;
    defined $format or $format='%s=%s';
    _t_format $format;
    $self->{format} = $format;
}

#	format() - Alias for get/setFormat();
sub format {
    my $self = shift;
    if (@_) {
	return $self->setFormat(@_)
    }
    $self->getFormat();
}


#       setValidator(\&validator) - Set sub to be called to validate
#                property/value pairs.  It is called
#                &validator($property, $value, $config) being $config
#                the Config::Properties object.  $property and $key
#                can be modified by the validator via $_[0] and $_[1]
sub setValidator {
    my ($self, $validator) = @_;
    _t_validator $validator;
    $self->{validator} = $validator;
}


#       getValidator() - Return the current validator sub
sub getValidator { shift->{validator} }

#       validator() - Alias for get/setValidator();
sub validator {
    my $self=shift;
    if (@_) {
	return $self->setValidator(@_)
    }
    $self->getValidator
}

sub setOrder {
    my ($self, $order) = @_;
    _t_order $order;
    $self->{order} = $order
}

sub getOrder { shift->{order} }

sub order {
    my $self = shift;
    $self->setOrder(@_) if @_;
    $self->{order};
}

#	load() - Load the properties from a filehandle
sub load {
    my ($self, $file) = @_;
    _t_file $file;

    # check whether it is a real file handle
    my $fn = do {
        local $@;
        eval { fileno($file) }
    };
    if (defined $fn and $fn >0) {
        unless (grep /^(?:encoding|utf8)\b/, PerlIO::get_layers($file)) {
            binmode $file, ":encoding($self->{encoding})"
                or croak "Unable to set file encoding layer: $!";
        }
    }
    $self->{properties} = {};
    $self->{property_line_numbers} = {};
    my $ln = $file->input_line_number;
    $self->{last_line_number} = ($ln > 0 ? $ln : 0);
    $self->{buffer_in} = '';
    1 while $self->process_line($file);
    $self->{last_line_number};
}


#        escape_key(string), escape_value(string), unescape(string) -
#               subroutines to convert escaped characters to their
#               real counterparts back and forward.

my %esc = ( "\n" => 'n',
	    "\r" => 'r',
	    "\t" => 't' );
my %unesc = reverse %esc;

sub escape_key {
    $_[0]=~s{([\t\n\r\\"' =:])}{
	"\\".($esc{$1}||$1) }ge;
    $_[0]=~s{([^\x20-\x7e])}{sprintf "\\u%04x", ord $1}ge;
    $_[0]=~s/^ /\\ /;
    $_[0]=~s/^([#!])/\\$1/;
    $_[0]=~s/(?
}

sub escape_value {
    $_[0]=~s{([\t\n\r\\])}{
	"\\".($esc{$1}||$1) }ge;
    $_[0]=~s{([^\x20-\x7e])}{sprintf "\\u%04x", ord $1}ge;
    $_[0]=~s/^ /\\ /;
}

sub unescape {
    $_[0]=~s/\\([tnr\\"' =:#!])|\\u([\da-fA-F]{4})/
	defined $1 ? $unesc{$1}||$1 : chr hex $2 /ge;
}

sub read_line {
    my ($self, $file) = @_;
    my $bin = \$self->{buffer_in};
    my $line_re = $self->{line_re};
    while (1) {
        if ($$bin =~ s/$line_re//) {
            $self->{last_line_number}++;
            return $1;
        }
        else {
            my $bytes = read($file, $$bin, 8192, length $$bin);
            last unless $bytes or (not defined $bytes and
                                   ($! == Errno::EGAIN()       or
                                    $! == Errno::EWOULDBLOCK() or
                                    $! == Errno::EINTR()));
        }
    }

    if (length $$bin) {
        $self->{last_line_number}++;
        my $line = $$bin;
        $$bin = '';
        return $line
    }
    undef;
}


#	process_line() - read and parse a line from the properties file.

# this is to workaround a bug in perl 5.6.0 related to unicode
my $bomre = eval(q< qr/^\\x{FEFF}/ >) || qr//;

sub process_line {
    my ($self, $file) = @_;
    my $line = $self->read_line($file);
    defined $line or return undef;

    # remove utf8 byte order mark
    my $ln = $self->{last_line_number};
    $line =~ s/$bomre// if $ln < 2;

    # ignore comments
    $line =~ /^\s*(\#|\!|$)/ and return 1;

    # handle continuation lines
    my @lines;
    while ($line =~ /(\\+)$/ and length($1) & 1) {
	$line =~ s/\\$//;
	push @lines, $line;
	$line = $self->read_line($file);
        $line = '' unless defined $line;
	$line =~ s/^\s+//;
    }
    $line = join('', @lines, $line) if @lines;

    my ($key, $value) = $line =~ /^
				  \s*
				  ((?:[^\s:=\\]|\\.)+)
				  \s*
				  [:=\s]
				  \s*
				  (.*)
				  $
				  /x
       or $self->fail("invalid property line '$line'");

    unescape $key;
    unescape $value;

    $self->validate($key, $value);

    $self->{property_line_numbers}{$key} = $ln;
    $self->{properties}{$key} = $value;

    return 1;
}

sub validate {
    my $self=shift;
    my $validator = $self->{validator};
    if (defined $validator) {
	&{$validator}(@_, $self) or $self->fail("invalid value '$_[1]' for '$_[0]'");
    }
}


#       line_number() - number for the last line read from the configuration file
sub line_number { shift->{last_line_number} }


#       fail(error) - report errors in the configuration file while reading.
sub fail {
    my ($self, $error) = @_;
    die "$error at line ".$self->line_number()."\n";
}

sub _sort_keys {
    my $self = shift;
    my $order = $self->{order};
    if ($order eq 'keep') {
        my $sk = $self->{property_line_numbers};
        no warnings 'uninitialized';
        return sort { $sk->{$a} <=> $sk->{$b} } @_;
    }
    if ($order eq 'alpha') {
        return sort @_;
    }
    return @_;
}

#	_save() - Utility function that performs the actual saving of
#		the properties file to a filehandle.
sub _save {
    my ($self, $file) = @_;
    _t_file $file;

    my $wrap;
    if ($self->{wrap}) {
        eval {
            no warnings;
            require Text::Wrap;
            $wrap=($Text::Wrap::VERSION >= 2001.0929);
        };
        unless ($wrap) {
            carp "Text::Wrap module is to old, version 2001.0929 or newer required: long lines will not be wrapped"
        }
    }

    local($Text::Wrap::separator)=" \\\n"       if $wrap;
    local($Text::Wrap::unexpand)=undef          if $wrap;
    local($Text::Wrap::huge)='overflow'         if $wrap;
    local($Text::Wrap::break)=qr/(?

    foreach ($self->_sort_keys(keys %{$self->{properties}})) {
	my $key=$_;
	my $value=$self->{properties}{$key};
	escape_key $key;
	escape_value $value;

	if ($wrap) {
	    $file->print( Text::Wrap::wrap( "",
					    "    ",
					    sprintf( $self->{'format'},
						     $key, $value ) ),
			  "\n" );
	}
	else {
	    $file->print(sprintf( $self->{'format'}, $key, $value ), "\n")
	}
    }
}


#	save() - Save the properties to a filehandle with the given header.
sub save {
    my ($self, $file, $header) = @_;
    _t_file($file);

    if (defined $header) {
	$header=~s/\n/# \n/sg;
	print $file "# $header\n#\n";
    }
    print $file '# ' . localtime() . "\n\n";
    $self->_save( $file );
}

sub saveToString {
    my $self = shift;
    my $str = '';
    open my $fh, '>', \$str
	or die "unable to open string ref as file";
    $self->save($fh, @_);
    close $fh
	or die "unable to write to in memory file";
    return $str;
}

sub _split_to_tree {
    my ($self, $tree, $re, $start) = @_;
    if (defined $self->{defaults}) {
	$self->{defaults}->_split_to_tree($tree, $re, $start);
    }
    for my $key (keys %{$self->{properties}}) {
        my $ekey = $key;

        if (defined $start) {
            $ekey =~ s/$start// or next;
        }

	my @parts = split $re, $ekey;
	@parts = '' unless @parts;
	my $t = $tree;
	while (@parts) {
	    my $part = shift @parts;
	    my $old = $t->{$part};

	    if (@parts) {
		if (defined $old) {
		    if (ref $old) {
			$t = $old;
		    }
		    else {
			$t = $t->{$part} = { '' => $old };
		    }
		}
		else {
		    $t = $t->{$part} = {};
		}
	    }
	    else {
		my $value = $self->{properties}{$key};
		if (ref $old) {
		    $old->{''} = $value;
		}
		else {
		    $t->{$part} = $value;
		}
	    }
	}
    }
}

sub splitToTree {
    my ($self, $re, $start) = @_;
    $re = qr/\./ unless defined $re;
    $re = qr/$re/ unless ref $re;
    if (defined $start) {
        $start = quotemeta $start;
        $start = qr/^$start$re/
    }
    my $tree = {};
    $self->_split_to_tree($tree, $re, $start);
    $tree;
}

sub _unsplit_from_tree {
    my ($self, $method, $tree, $sep, @start) = @_;
    $sep = '.' unless defined $sep;
    my $ref = ref $tree;
    if ($ref eq 'HASH') {
        for my $key (keys %$tree) {
            $self->_unsplit_from_tree($method, $tree->{$key}, $sep,
                               @start, ($key ne '' ? $key : ()))
        }
    }
    elsif ($ref eq 'ARRAY') {
        for my $key (0..$#$tree) {
            $self->_unsplit_from_tree($method, $tree->[$key], $sep, @start, $key)
        }
    }
    elsif ($ref) {
        croak "unexpected object '$ref' found inside tree"
    }
    else {
        $self->$method(join($sep, @start), $tree)
    }
}

sub setFromTree { shift->_unsplit_from_tree(setProperty => @_) }
sub changeFromTree { shift->_unsplit_from_tree(changeProperty => @_) }

#	store() - Synonym for save()
*store = \&save;

#	getProperty() - Return the value of a property key. Returns the default
#		for that key (if there is one) if no value exists for that key.
sub getProperty {
    my $self = shift;
    my $key = shift;
    _t_key $key;

    if (exists $self->{properties}{$key}) {
	return $self->{properties}{$key}
    }
    elsif (defined $self->{defaults}) {
	return $self->{defaults}->getProperty($key, @_);
    }
    for (@_) {
	return $_ if defined $_
    }
    undef
}

sub requireProperty {
    my $this = shift;
    my $prop = $this->getProperty(@_);
    defined $prop
	or die "required property '$_[0]' not found on configuration file\n";
    return $prop;
}

sub _property_line_number {
    my ($self, $key)=@_;
    $self->{property_line_numbers}{$key}
}


#	propertyName() - Returns an array of the keys of the Properties
sub propertyNames {
    my $self = shift;
    my %p = $self->_properties;
    $self->_sort_keys(keys %p);
}


1;
__END__