#
# This file is part of Config-Model
#
# This software is Copyright (c) 2014 by Dominique Dumont.
#
# This is free software, licensed under:
#
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Dumper;
$Config::Model::Dumper::VERSION = '2.060';
use Carp;
use strict;
use warnings;
use Config::Model::Exception;
use Config::Model::ObjTreeScanner;
sub new {
bless {}, shift;
}
sub quote {
_quote( qr/(\s|"|\*)/, @_ );
}
sub id_quote {
_quote( qr/[\s"\*<>.=#]/, @_ );
}
sub _quote {
my ( $re, @res ) = @_;
foreach (@res) {
if ( defined $_ and ( /$re/ or $_ eq '' ) ) {
s/"/\\"/g; # escape present quotes
$_ = '"' . $_ . '"'; # add my quotes
}
}
return wantarray ? @res : $res[0];
}
sub note_quote {
my @res = @_;
foreach (@res) {
if ( defined $_ and $_ and (/(\s|"|\*)/) ) {
s/"/\\"/g; # escape present quotes
$_ = '"' . $_ . '"'; # add my quotes
}
}
return wantarray ? @res : $res[0];
}
sub dump_tree {
my $self = shift;
my %args = @_;
my $full = delete $args{full_dump} || 0;
my $skip_aw = delete $args{skip_auto_write} || '';
my $auto_v = delete $args{auto_vivify} || 0;
my $mode = delete $args{mode} || '';
if ( $mode and $mode !~ /full|preset|custom/ ) {
croak "dump_tree: unexpected 'mode' value: $mode";
}
my $check = delete $args{check} || 'yes';
if ( $check !~ /yes|no|skip/ ) {
croak "dump_tree: unexpected 'check' value: $check";
}
# mode parameter is slightly different from fetch's mode
my $fetch_mode =
$full ? ''
: $mode eq 'full' ? ''
: $mode ? $mode
: 'custom';
my $node = delete $args{node}
|| croak "dump_tree: missing 'node' parameter";
my $compute_pad = sub {
my $depth = 0;
my $obj = shift;
while ( defined $obj->parent ) {
$depth++;
$obj = $obj->parent;
}
return ' ' x $depth;
};
my $leaf_cb = sub {
my ( $scanner, $data_r, $node, $element, $index, $value_obj ) = @_;
# get value or only customized value
my $value = quote( $value_obj->fetch( mode => $fetch_mode, check => $check ) );
$index = id_quote($index);
my $pad = $compute_pad->($node);
my $name =
defined $index
? "$element:$index"
: $element;
# add annotation for obj contained in hash or list
my $note = note_quote( $value_obj->annotation );
$$data_r .= "\n" . $pad . $name if defined $value or $note;
$$data_r .= '=' . $value if defined $value;
$$data_r .= '#' . $note if $note;
};
my $check_list_cb = sub {
my ( $scanner, $data_r, $node, $element, $index, $value_obj ) = @_;
# get value or only customized value
my $value = $value_obj->fetch( mode => $fetch_mode, check => $check );
my $qvalue = quote($value);
$index = id_quote($index);
my $pad = $compute_pad->($node);
my $name =
defined $index
? "$element:$index"
: $element;
# add annotation for obj contained in hash or list
my $note = note_quote( $value_obj->annotation );
$$data_r .= "\n" . $pad . $name if $value or $note;
$$data_r .= '=' . $qvalue if $value;
$$data_r .= '#' . $note if $note;
};
my $list_element_cb = sub {
my ( $scanner, $data_r, $node, $element, @keys ) = @_;
my $pad = $compute_pad->($node);
my $list_obj = $node->fetch_element($element);
# add annotation for list element
my $list_note = note_quote( $list_obj->annotation );
$$data_r .= "\n$pad$element#$list_note" if $list_note;
if ( $list_obj->cargo_type eq 'node' ) {
foreach my $k (@keys) {
$scanner->scan_list( $data_r, $node, $element, $k );
}
}
else {
# write value comments
foreach my $idx ( $list_obj->fetch_all_indexes ) {
my $note = $list_obj->fetch_with_id($idx)->annotation;
$$data_r .= "\n$pad$element:$idx#" . note_quote($note) if $note;
}
# skip undef values
my @val = id_quote(
grep ( defined $_,
$list_obj->fetch_all_values(
mode => $fetch_mode,
check => $check
) ) );
$$data_r .= "\n$pad$element:=" . join( ',', @val ) if @val;
}
};
my $hash_element_cb = sub {
my ( $scanner, $data_r, $node, $element, @keys ) = @_;
my $pad = $compute_pad->($node);
my $hash_obj = $node->fetch_element($element);
# add annotation for list or hash element
my $note = note_quote( $hash_obj->annotation );
$$data_r .= "\n$pad$element#$note" if $note;
# resume exploration
map { $scanner->scan_hash( $data_r, $node, $element, $_ ); } @keys;
};
# called for nodes contained in nodes (not root).
# This node can be held by a plain element or a hash element or a list element
my $node_element_cb = sub {
my ( $scanner, $data_r, $node, $element, $key, $contained_node ) = @_;
my $type = $node->element_type($element);
return if $skip_aw and $contained_node->is_auto_write_for_type($skip_aw);
my $pad = $compute_pad->($node);
my $elt = $node->fetch_element($element);
# load string can feature only one comment per element_type
# ie foo#comment foo:bar#comment foo:bar=val#comment are fine
# but foo#comment:bar if not valid -> foo#commaent foo:bar
my $head = "\n$pad$element";
my $node_note = note_quote( $contained_node->annotation );
if ( $type eq 'list' or $type eq 'hash' ) {
$head .= ':' . id_quote($key);
$head .= '#' . $node_note if $node_note;
my $sub_data = '';
$scanner->scan_node( \$sub_data, $contained_node );
$$data_r .= $head . $sub_data . ' -';
}
else {
$head .= '#' . $node_note if $node_note;
my $sub_data = '';
$scanner->scan_node( \$sub_data, $contained_node );
# skip simple nodes that do not bring data
$$data_r .= $head . $sub_data . ' -' if $sub_data;
}
};
my @scan_args = (
fallback => 'all',
auto_vivify => $auto_v,
list_element_cb => $list_element_cb,
hash_element_cb => $hash_element_cb,
leaf_cb => $leaf_cb,
node_element_cb => $node_element_cb,
check_list_element_cb => $check_list_cb,
check => $check,
);
my @left = keys %args;
croak "Dumper: unknown parameter:@left" if @left;
# perform the scan
my $view_scanner = Config::Model::ObjTreeScanner->new(@scan_args);
my $ret = '';
my $root_note = note_quote( $node->annotation );
$ret .= "\n#$root_note" if $root_note;
$view_scanner->scan_node( \$ret, $node );
substr( $ret, 0, 1, '' ); # remove leading \n
$ret .= ' -' if $ret;
return $ret . "\n";
}
1;
# ABSTRACT: Serialize data of config tree
__END__
=pod
=encoding UTF-8
=head1 NAME
Config::Model::Dumper - Serialize data of config tree
=head1 VERSION
version 2.060
=head1 SYNOPSIS
use Config::Model ;
use Log::Log4perl qw(:easy) ;
Log::Log4perl->easy_init($WARN);
# define configuration tree object
my $model = Config::Model->new ;
$model ->create_config_class (
name => "MyClass",
element => [
[qw/foo bar/] => {
type => 'leaf',
value_type => 'string'
},
baz => {
type => 'hash',
index_type => 'string' ,
cargo => {
type => 'leaf',
value_type => 'string',
},
},
],
) ;
my $inst = $model->instance(root_class_name => 'MyClass' );
my $root = $inst->config_root ;
# put some data in config tree the hard way
$root->fetch_element('foo')->store('yada') ;
$root->fetch_element('bar')->store('bla bla') ;
$root->fetch_element('baz')->fetch_with_id('en')->store('hello') ;
# put more data the easy way
my $step = 'baz:fr=bonjour baz:hr="dobar dan"';
$root->load( step => $step ) ;
# dump only customized data
print $root->dump_tree;
=head1 DESCRIPTION
This module is used directly by L<Config::Model::Node> to serialize
configuration data in a compact (but readable) string.
The serialization can be done in standard mode where only customized
values are dumped in the string. I.e. only data modified by the user
are dumped.
The other mode is C<full_dump> mode where all all data, including
default values, are dumped.
The serialized string can be used by L<Config::Model::Loader> to store
the data back into a configuration tree.
Note that undefined values are skipped for list element. I.e. if a list
element contains C<('a',undef,'b')>, the dump will contain C<'a','b'>.
=head1 CONSTRUCTOR
=head2 new ( )
No parameter. The constructor should be used only by
L<Config::Model::Node>.
=head1 Methods
=head2 dump_tree
Return a string that contains a dump of the object tree with all the
values. This string follows the convention defined by
L<Config::Model::Loader>.
The serialized string can be used by L<Config::Model::Loader> to store
the data back into a configuration tree.
Parameters are:
=over
=item mode ( full | preset | custom )
C<full> will dump all configuration data including default
values.
C<preset> will dump only value entered in preset mode.
By default, the dump contains only data modified by the user
(i.e. C<custom> data that differ from default or preset values).
=item node
Reference to the L<Config::Model::Node> object that is dumped. All
nodes and leaves attached to this node are also dumped.
=item skip_auto_write ( <backend_name> )
Skip node that have a write capability matching C<backend_name> in
their model. See L<Config::Model::BackendMgr>.
=item auto_vivify
Scan and create data for nodes elements even if no actual data was
stored in them. This may be useful to trap missing mandatory values.
(default: 0)
=item check
Check value before dumping. Valid check are 'yes', 'no' and 'skip'.
=back
=head1 AUTHOR
Dominique Dumont, (ddumont at cpan dot org)
=head1 SEE ALSO
L<Config::Model>,L<Config::Model::Node>,L<Config::Model::Loader>
=head1 AUTHOR
Dominique Dumont
=head1 COPYRIGHT AND LICENSE
This software is Copyright (c) 2014 by Dominique Dumont.
This is free software, licensed under:
The GNU Lesser General Public License, Version 2.1, February 1999
=cut