view release on metacpan or  search on metacpan

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

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

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