Config::Properties - Read and write property files

  use Config::Properties;

  # reading...

  open PROPS, "< my_config.props"
    or die "unable to open configuration file";

  my $properties = new Config::Properties();
  $properties->load(*PROPS);

  $value = $properties->getProperty( $key );




  # saving...

  open PROPS, "> my_config.props"
    or die "unable to open configuration file for writing";

  $properties->setProperty( $key, $value );

  $properties->format( '%s => %s' );
  $properties->store(*PROPS, $header );

package Config::Properties;

use strict;
use warnings;

our $VERSION = '1.71';

use IO::Handle;
use Carp;

{
    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'";
    }
}

#   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, $defaults) = @_;

    my $self = { defaults => $defaults,
		 format => '%s=%s',
		 properties => {},
		 next_line_number => 1,
		 property_line_numbers => {} };
    bless $self, $class;

    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->{next_line_number}++;
    $self->{properties}{$key} = $value;
}

#       properties() - return a flated hash with all the properties
sub properties {
    my $self=shift;
    if (defined ($self->{defaults})) {
	my %p=($self->{defaults}->properties, %{$self->{properties}});
	return %p;
    }
    return %{ $self->{properties} }
}

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


#	load() - Load the properties from a filehandle
sub load {
    my ($self, $file) = @_;
    _t_file $file;
    $self->{properties}={};
    $self->{property_line_numbers}={};
    $self->{next_line_number}=1;
    1 while $self->process_line($file);
}


#        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/(?<!\\)((?:\\\\)*) $/$1\\ /;
}

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;
}


#	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=<$file>;

    defined $line or return undef;
    my $ln=$self->{line_number}=$file->input_line_number;
    if ($ln == 1) {
        # remove utf8 byte order mark
        $line =~ s/$bomre//;
    }
    # ignore comments
    $line =~ /^\s*(\#|\!|$)/ and return 1;

    $line =~ s/\x0D*\x0A$//;

    # handle continuation lines
    my @lines;
    while ($line =~ /(\\+)$/ and length($1) & 1) {
	$line =~ s/\\$//;
	push @lines, $line;
	$line = <$file>;
	$line =~ s/\x0D*\x0A$//;
	$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->{next_line_number}=$ln+1;

    $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->{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";
}

#	_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;
    eval {
	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";
    local($Text::Wrap::unexpand)=undef;
    local($Text::Wrap::huge)='overflow';
    local($Text::Wrap::break)=qr/(?<!\\) (?! )/;

    my $sk=$self->{property_line_numbers};
    foreach (sort { $sk->{$a} <=> $sk->{$b} } 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()
sub store { shift->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 %p=shift->properties;
    keys %p;
}


1;
__END__