view release on metacpan or  search on metacpan

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

	print $fh "EOF\n";
    } elsif ($value =~ /^\s+/ ||
	     $value =~ /\s+$/) {
	# XXX split long lines with \
	# XXX escape embedded "
	print $fh "\"$value\"\n";
    } else {
	# XXX split long lines with \
	print $fh "$value\n";
    }
}

sub _format_key {
    my $self = shift;
    my $key = shift;
    if ($self->{features}->{quotedkeys}) {
	if ($key =~ /^((?:\w|-|\.)+)$/) {
	    return $key;
	} else {
	    $key =~ s/\\/\\\\/g;
	    $key =~ s/"/\\"/g;
	    return '"' . $key . '"';
	}
    } else {
	return $key;
    }
}


sub view {
    my $self = shift;
    my $key = shift;
    
    my $value = $self->get($key, @_);

    if (!ref($value) ||
	ref($value) ne "HASH") {
	confess "value for $key is not a hash";
    }
    return $self->new(record => $value,
		      debug => $self->{debug},
		      features => $self->{features});
}


sub get {
    my $self = shift;
    my $key = shift;
    
    my @key;

    warn "Key: '" . $key . "'\n" if $self->{debug};
    foreach (split /((?<!\\)\/)/, $key) {
	next if m,^/$,;
	warn "  -> '" . $_ . "'\n" if $self->{debug};
	push @key, $_;
    }

    my $entry = $self->{record};
    my $context;
    foreach my $fragment (@key) {
	$context = defined $context ? $context . "/" . $fragment : $fragment;
	
	if ($fragment =~ /^\[(\d+)\]$/) {
	    my $index = $1;
	    if (ref($entry) ne "ARRAY") {
		if (@_) {
		    return shift;
		}
		confess "cannot find array value at '$context' for parameter '$key'";
	    }
	    if ($#{$entry} < $index) {
		if (@_) {
		    return shift;
		}
		confess "cannot find array value at '$context' for parameter '$key'";
	    }
	    $entry = $entry->[$index];
	} elsif ($self->{features}->{quotedkeys}) {
	    $fragment =~ s/\\(\[|\]|\/|\\)/$1/g;
	    warn "Quote '$fragment'\n" if $self->{debug};
	    if (ref($entry) ne "HASH") {
		if (@_) {
		    return shift;
		}
		confess "cannot find hash value at '$context' for parameter '$key'";
	    }
	    if (!exists $entry->{$fragment}) {
		if (@_) {
		    return shift;
		}
		confess "cannot find hash value at '$context' for parameter '$key'";
	    }
	    $entry = $entry->{$fragment};
	} else {
	    warn "NonQuote '$fragment'\n" if $self->{debug};
	    if ($fragment =~ /((?:\w|-|\.)+)/) {
		if (ref($entry) ne "HASH") {
		    if (@_) {
			return shift;
		    }
		    confess "cannot find hash value at '$context' for parameter '$key'";
		}
		if (!exists $entry->{$fragment}) {
		    if (@_) {
			return shift;
		    }
		    confess "cannot find hash value at '$context' for parameter '$key'";
		}
		$entry = $entry->{$fragment};
	    } else {
		confess "fragment '$fragment' should be alphanumeric, or an array index";
	    }
	}
    }
    
    return $entry;
}


sub set {
    my $self = shift;
    my $key = shift;
    my $value = shift;
    
    my @key;
    warn "Key: '" . $key . "'\n" if $self->{debug};
    foreach (split /((?<!\\)\/)/, $key) {
	next if m,^/$,;
	warn "  -> '" . $_ . "'\n" if $self->{debug};
	push @key, $_;
    }


    my $entry = $self->{record};
    my $context;
    while (defined (my $fragment = shift @key)) {
	$context = defined $context ? $context . "/" . $fragment : $fragment;
	
	if ($fragment =~ /^\[(\d+)\]$/) {
	    my $index = $1;
	    if (ref($entry) ne "ARRAY") {
		confess "cannot find array value at $context for parameter $key";
	    }
	    if (@key) {
		if (exists $entry->[$index]) {
		    $entry = $entry->[$index];
		} else {
		    if ($key[0] =~ /^\[(\d+)\]$/) {
			$entry->[$index] = [];
		    } else {
			$entry->[$index] = {};
		    }
		    $entry = $entry->[$index];
		}
	    } else {
		$entry->[$index] = $value;
	    }
	} elsif ($self->{features}->{quotedkeys}) {
	    $fragment =~ s/\\(\[|\]|\/|\\)/$1/g;
	    warn "Quote '$fragment'\n" if $self->{debug};
	    if (ref($entry) ne "HASH") {
		confess "cannot find hash value at $context for parameter $key";
	    }
	    if (@key) {
		if (exists $entry->{$fragment}) {
		    $entry = $entry->{$fragment};
		} else {
		    if ($key[0] =~ /^\[(\d+)\]$/) {
			$entry->{$fragment} = [];
		    } else {
			$entry->{$fragment} = {};
		    }
		    $entry = $entry->[$fragment];
		}
	    } else {
		$entry->{$fragment} = $value;
	    }
	} else {
	    warn "NonQuote '$fragment'\n" if $self->{debug};
	    if ($fragment =~ /((?:\w|-|\.)+)/) {
		if (ref($entry) ne "HASH") {
		    confess "cannot find hash value at $context for parameter $key";
		}
		if (@key) {
		    if (exists $entry->{$fragment}) {
			$entry = $entry->{$fragment};
		    } else {
			if ($key[0] =~ /^\[(\d+)\]$/) {
			    $entry->{$fragment} = [];
			} else {
			    $entry->{$fragment} = {};
			}
			$entry = $entry->[$fragment];
		    }
		} else {
		    $entry->{$fragment} = $value;
		}
	    } else {
		confess "fragment '$fragment' should be alphanumeric, or an array index";
	    }
	}
    }
}


sub record {
    my $self = shift;
    
    return $self->{record};
}

1 # So that the require or use succeeds.