File Coverage

blib/lib/Config/Properties/Simple.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

package Config::Properties::Simple;

use 5.006;

our $VERSION = '0.14';

use strict;
use warnings;
use Carp;

use Config::Properties;
use Config::Find;

our @ISA=qw(Config::Properties Config::Find);

sub new {
    my ($class, %opts)=@_;

    my $defaults;
    if (defined $opts{defaults}) {
	if (UNIVERSAL::isa($opts{defaults}, 'Config::Properties')) {
	    $defaults=$opts{defaults}
	}
	else {
	    $defaults=Config::Properties->new();
	    for my $k (keys %{$opts{defaults}}) {
		$defaults->setProperty($k, $opts{defaults}->{$k})
	    }
	}
    }

    my $this=$class->SUPER::new($defaults);

    $this->{simple_opts}=\%opts;

    exists $opts{format}
	and $this->setFormat($opts{format});

    unless ($opts{noread}
	    or (exists $opts{mode} and $opts{mode}=~/^w(?:rite)?/i)) {
	my $fn=$this->{simple_fn}=$this->find(%opts);
	unless (defined $fn) {
	    return $this if ($opts{optional} and (!defined $opts{file} or $opts{optional} > 1));
	    croak 'configuration file not found';
	}
	my $fh=IO::File->new($fn, "r");
	binmode $fh, ':utf8' if $this->{simple_opts}{utf8};
	unless ($fh) {
	    return $this if ($opts{optional} and !defined $opts{file})
		or croak 'unable to open configuration file for reading';
	}
	$this->load($fh);
	close $fh
	    or croak 'unable to read configuration file';

	my $required=$opts{required};
	if (defined $required) {
	    UNIVERSAL::isa($required, 'ARRAY')
		or croak "invalid object passed for 'required' option, array reference expected";
	    foreach my $req (@{$required}) {
		die "required property '$req' not found in $fn"
		    unless defined $this->getProperty($req);
	    }
	}
    }

    return $this;
}

sub find {
    my $this=shift;
    return $this->SUPER::find(%{$this->{simple_opts}}, @_)
}

sub file_name { shift->{simple_fn} }

sub save {
    my $this=shift;
    my %opts= (%{$this->{simple_opts}}, mode => 'w', @_);
    my $fh=$this->open(%opts)
	or croak 'unable to open configuration file for writing';
    binmode $fh, ':utf8' if $this->{simple_opts}{utf8};
    my $header=$opts{header}
	|| 'Automatically generated configuration file';
    $this->SUPER::save($fh, $header);
    close $fh
	or croak 'unable to write configuration file';
}

sub fail {
    my ($this, $error)=@_;
    die "$error at ".$this->file_name." line ".$this->line_number."\n";
}

sub validate {
    my $this = shift;
    my $okey = $_[0];
    $this->validate_1(@_);
    my $oln=$this->_property_line_number($_[0]);
    if (defined $oln
	and !$this->{simple_opts}{dups_ok}) {
	$this->fail($okey eq $_[0]
		    ? "duplicated property '$okey' (previous appearance at line $oln)"
		    : "duplicated property '$okey' (resolves to '$_[0]', previous appearance at line $oln)" )
    }
}

sub validate_1 {
    my $this = shift;
    my $alias=$this->{simple_opts}{aliases};
    if (defined $alias) {
	$_[0]=$alias->{$_[0]} if exists $alias->{$_[0]};
    }
    my $vtor=$this->{simple_opts}{validate};
    if (defined $vtor) {
	my $fn=$this->{simple_fn};
	if (UNIVERSAL::isa($vtor, 'CODE')) {
	    &$vtor(@_, $this) or $this->fail("invalid property '$_[0]' value '$_[1]'");
	    return;
	}
	if (UNIVERSAL::isa($vtor, 'ARRAY')) {
	    foreach my $vtor2 (@{$vtor}) {
		if (UNIVERSAL::isa($vtor2, 'Regexp')) {
		    return if $_[0]=~$vtor2;
		}
		else {
		    return if $vtor2 eq $_[0];
		}
	    }
	    $this->fail("unknown property '$_[0]' found");
	}
	if (UNIVERSAL::isa($vtor, 'HASH')) {
	    # warn "validate is hash";
	    my $vtor2;
	    if (exists $vtor->{$_[0]}) {
		$vtor2=$vtor->{$_[0]}
	    }
	    elsif (exists $vtor->{__default}) {
		$vtor2=$vtor->{__default}
	    }
	    else {
		$this->fail("unknow property '$_[0]' found");
	    }
	    if (UNIVERSAL::isa($vtor2, 'CODE')) {
		&$vtor2(@_, $this) or $this->fail("invalid property '$_[0]' value '$_[1]'");
		return;
	    }
	    if (UNIVERSAL::isa($vtor2, 'Regexp')) {
		return if $_[1]=~$vtor2;
		$this->fail("property '$_[0]' value '$_[1]' not allowed: it doesn't match regexp '$vtor2'");
	    }
	    if (UNIVERSAL::isa($vtor2, 'ARRAY')) {
		return if (grep { $_[1] eq $_} @{$vtor2});
		$this->fail("property '$_[0]' value '$_[1]' is not allowed");
	    }
	    if (UNIVERSAL::isa($vtor2, 'HASH')) {
		if (exists $vtor2->{$_[1]}) {
		    $_[1]=$vtor->{$_[1]};
		    return
		}
		$this->fail("property '$_[0]' value '$_[1]' is not allowed");
	    }
	    if ($vtor2=~/^s(?:tring)?$/i or $vtor2=~/^a(?:ny)?$/i) {
		return;
	    }
	    if ($vtor2=~/^b(?:oolean)?$/i) {
		if ( $_[1] eq '1' or
		     $_[1]=~/^y(?:es)?$/i or
		     $_[1]=~/^t(?:rue)?$/i) {
		    $_[1]=1;
		    return;
		}
		if ( $_[1] eq '' or
		     $_[1] eq '0' or
		     $_[1]=~/^no?$/i or
		     $_[1]=~/^f(?:alse)?$/i) {
		    $_[1]=0;
		    return;
		}
		$this->fail("property '$_[0]' value '$_[1]' is not allowed: boolean expected");
	    }
	    if ($vtor2=~/^u(?:nsigned)?$/i) {
		if ($_[1]=~/^\d+$/) {
		    $_[1]=int $_[1];
		    return;
		}
		$this->fail("property '$_[0]' value '$_[1]' is not allowed: unsigned integer expected");
	    }
	    if ($vtor2=~/^i(?:nteger)?$/i) {
		if ($_[1]=~/^[+\-]?\d+$/) {
		    $_[1]=int $_[1];
		    return;
		}
		$this->fail("property '$_[0]' value '$_[1]' is not allowed: integer expected");
	    }
	    if ($vtor2=~/^f(?:loat)?$/i or $vtor2=~/^n(?:umber)?$/i) {
		if ($_[1]=~/^[+-]?(?:\d+|\d*\.\d+|\d+\.\d*)(?:[eE][+-]?\d+)?$/) {
		    $_[1]=$_[1]+0;
		    return;
		}
		$this->fail("property '$_[0]' value '$_[1]' is not allowed: number expected");
	    }

	    croak "invalid object '$vtor2' for validate";
	}
	else {
	    croak "invalid object '$vtor' for validate";
	}
    }
}

1;
__END__