r25566 - in /trunk/libconfig-model-perl: ./ augeas-box/etc/ssh/ debian/ lib/Config/ lib/Config/Model/ t/
nxvl-guest at users.alioth.debian.org
nxvl-guest at users.alioth.debian.org
Tue Sep 23 15:37:55 UTC 2008
Author: nxvl-guest
Date: Tue Sep 23 15:37:52 2008
New Revision: 25566
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=25566
Log:
Updated changelog
Added:
trunk/libconfig-model-perl/README.augeas
- copied unchanged from r25564, branches/upstream/libconfig-model-perl/current/README.augeas
trunk/libconfig-model-perl/augeas-box/etc/ssh/
- copied from r25564, branches/upstream/libconfig-model-perl/current/augeas-box/etc/ssh/
Modified:
trunk/libconfig-model-perl/ChangeLog
trunk/libconfig-model-perl/MANIFEST
trunk/libconfig-model-perl/META.yml
trunk/libconfig-model-perl/README
trunk/libconfig-model-perl/debian/changelog
trunk/libconfig-model-perl/lib/Config/Model.pm
trunk/libconfig-model-perl/lib/Config/Model/AutoRead.pm
trunk/libconfig-model-perl/lib/Config/Model/ListId.pm
trunk/libconfig-model-perl/lib/Config/Model/Node.pm
trunk/libconfig-model-perl/lib/Config/Model/Value.pm
trunk/libconfig-model-perl/t/augeas_backend.t
trunk/libconfig-model-perl/t/node.t
trunk/libconfig-model-perl/t/smooth_upgrade.t
Modified: trunk/libconfig-model-perl/ChangeLog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libconfig-model-perl/ChangeLog?rev=25566&op=diff
==============================================================================
--- trunk/libconfig-model-perl/ChangeLog (original)
+++ trunk/libconfig-model-perl/ChangeLog Tue Sep 23 15:37:52 2008
@@ -1,3 +1,30 @@
+2008-09-23 Dominique Dumont <dominique.dumont at hp.com> v0.627
+
+ * ChangeLog: I plainly forgot to update this file for v0.626. This
+ is fixed now.
+
+2008-09-22 Dominique Dumont <dominique.dumont at hp.com> v0.626
+
+ * lib/Config/Model/AutoRead.pm (read_augeas): Lot of bug fix to
+ read and write through Augeas. Now, lens containing 'seq' lenses
+ must be explicitely declared.
+
+2008-07-31 Dominique Dumont <dominique.dumont at hp.com>
+
+ * lib/Config/Model/Value.pm (migrate_value): No longer fails when
+ a migrated value is also a mandatory value.
+
+ * lib/Config/Model.pm (create_config_class): No longer creates
+ empty include in model when skip_include is true (breaks
+ Config::Itself tests)
+
+2008-07-30 Dominique Dumont <dominique.dumont at hp.com> v0.625
+
+ * lib/Config/Model/ListId.pm (swap): Swapped or moved values in a
+ list no longer provides wrong location in config
+ tree. (index_value were not updated in objects contained in List
+ after a swap or a move)
+
2008-07-24 Dominique Dumont v0.624
* lib/Config/Model/Value.pm and others: Modified to allow smooth
Modified: trunk/libconfig-model-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libconfig-model-perl/MANIFEST?rev=25566&op=diff
==============================================================================
--- trunk/libconfig-model-perl/MANIFEST (original)
+++ trunk/libconfig-model-perl/MANIFEST Tue Sep 23 15:37:52 2008
@@ -3,9 +3,12 @@
MANIFEST This list of files
Build.PL
README
+README.augeas
TODO
META.yml
augeas-box/etc/hosts
+augeas-box/etc/ssh/sshd_config
+augeas-box/etc/ssh/ssh_config
config-edit
examples/fstab/Fstab.pl
examples/fstab/README
Modified: trunk/libconfig-model-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libconfig-model-perl/META.yml?rev=25566&op=diff
==============================================================================
--- trunk/libconfig-model-perl/META.yml (original)
+++ trunk/libconfig-model-perl/META.yml Tue Sep 23 15:37:52 2008
@@ -1,6 +1,6 @@
---
name: Config-Model
-version: 0.624
+version: 0.627
author:
- Dominique Dumont (ddumont at cpan dot org)
abstract: Describe and edit configuration data
@@ -25,7 +25,7 @@
provides:
Config::Model:
file: lib/Config/Model.pm
- version: 0.624
+ version: 0.627
Config::Model::AnyId:
file: lib/Config/Model/AnyId.pm
version: 1.0721
@@ -34,7 +34,7 @@
version: 1.0660
Config::Model::AutoRead:
file: lib/Config/Model/AutoRead.pm
- version: 1.0731
+ version: 1.0756
Config::Model::CheckList:
file: lib/Config/Model/CheckList.pm
version: 1.0718
@@ -83,13 +83,13 @@
version: 1.0716
Config::Model::ListId:
file: lib/Config/Model/ListId.pm
- version: 1.0708
+ version: 1.0743
Config::Model::Loader:
file: lib/Config/Model/Loader.pm
version: 1.0717
Config::Model::Node:
file: lib/Config/Model/Node.pm
- version: 1.0729
+ version: 1.0752
Config::Model::ObjTreeScanner:
file: lib/Config/Model/ObjTreeScanner.pm
version: 1.0715
@@ -107,7 +107,7 @@
version: 1.0669
Config::Model::Value:
file: lib/Config/Model/Value.pm
- version: 1.0729
+ version: 1.0745
Config::Model::ValueComputer:
file: lib/Config/Model/ValueComputer.pm
version: 1.0728
Modified: trunk/libconfig-model-perl/README
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libconfig-model-perl/README?rev=25566&op=diff
==============================================================================
--- trunk/libconfig-model-perl/README (original)
+++ trunk/libconfig-model-perl/README Tue Sep 23 15:37:52 2008
@@ -4,10 +4,11 @@
Config::Model enables a project developer to provide an interactive
configuration editor (graphical, curses based or plain terminal) to
his users. For this he must:
-- describe the structure and constraint of his project's configuration
-- if the configuration data is not stored in INI file or in Perl data
- file, he must provide some code to read and write configuration from
- configuration files.
+- describe the structure and constraints of his project's configuration
+- find a way to read and write configuration data. This can be provided:
+ * by Config::Model (INI file or Perl data file)
+ * through RedHat's Augeas library (See README.augeas)
+ * by custom code
With the elements above, Config::Model will generate interactive
configuration editors (with integrated help and data validation).
@@ -120,10 +121,13 @@
- Most of the model handling code is Beta
- Terminal interface (TermUI.pm) is alpha
- Curses interface (provided by Config::Model::CursesUI) is beta
-- Perl/Tk interface (provided by Config::Model::TkUI) is beta
+- Graphical configuration editor is beta (provided by Config::Model::TkUI)
+- Graphical configuration model editor is beta (yes, you can also edit
+ configuration model the same way you edit configuration data)
- Xorg model (provided by Config::Model::Xorg) is alpha (and still
incomplete)
-- OpenSsh model (sshd_config model is done. ssh_config is to be done)
+- OpenSsh model is beta (sshd_config model is done. ssh_config is to
+ be done)
- Krb5 model is being developed
Help is welcome on:
Modified: trunk/libconfig-model-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libconfig-model-perl/debian/changelog?rev=25566&op=diff
==============================================================================
--- trunk/libconfig-model-perl/debian/changelog (original)
+++ trunk/libconfig-model-perl/debian/changelog Tue Sep 23 15:37:52 2008
@@ -1,4 +1,4 @@
-libconfig-model-perl (0.625-1) UNRELEASED; urgency=low
+libconfig-model-perl (0.627-1) UNRELEASED; urgency=low
* Initial Release. (Closes: #493308)
Modified: trunk/libconfig-model-perl/lib/Config/Model.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libconfig-model-perl/lib/Config/Model.pm?rev=25566&op=diff
==============================================================================
--- trunk/libconfig-model-perl/lib/Config/Model.pm (original)
+++ trunk/libconfig-model-perl/lib/Config/Model.pm Tue Sep 23 15:37:52 2008
@@ -1,6 +1,6 @@
# $Author: ddumont $
-# $Date: 2008-07-20 16:59:30 +0200 (Sun, 20 Jul 2008) $
-# $Revision: 725 $
+# $Date: 2008-09-23 13:03:10 +0200 (Tue, 23 Sep 2008) $
+# $Revision: 759 $
# Copyright (c) 2005-2008 Dominique Dumont.
#
@@ -34,7 +34,7 @@
# this class holds the version number of the package
use vars qw($VERSION @status @level @experience_list %experience_index) ;
-$VERSION = '0.624';
+$VERSION = '0.627';
=head1 NAME
@@ -483,10 +483,11 @@
my %model = ( element_list => [] );
# add included items
- if ($self->{skip_include}) {
+ if ($self->{skip_include} and defined $raw_copy->{include}) {
my $inc = delete $raw_copy->{include} ;
$model{include} = ref $inc ? $inc : [ $inc ];
- $model{include_after} = delete $raw_copy->{include_after} ;
+ $model{include_after} = delete $raw_copy->{include_after}
+ if defined $raw_copy->{include_after};
}
else {
$self->include_class($config_class_name, $raw_copy ) ;
Modified: trunk/libconfig-model-perl/lib/Config/Model/AutoRead.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libconfig-model-perl/lib/Config/Model/AutoRead.pm?rev=25566&op=diff
==============================================================================
--- trunk/libconfig-model-perl/lib/Config/Model/AutoRead.pm (original)
+++ trunk/libconfig-model-perl/lib/Config/Model/AutoRead.pm Tue Sep 23 15:37:52 2008
@@ -1,6 +1,6 @@
# $Author: ddumont $
-# $Date: 2008-07-25 13:30:10 +0200 (Fri, 25 Jul 2008) $
-# $Revision: 731 $
+# $Date: 2008-09-22 14:13:48 +0200 (Mon, 22 Sep 2008) $
+# $Revision: 756 $
# Copyright (c) 2005-2008 Dominique Dumont.
#
@@ -36,7 +36,7 @@
use base qw/Config::Model::AnyThing/ ;
-our $VERSION = sprintf "1.%04d", q$Revision: 731 $ =~ /(\d+)/;
+our $VERSION = sprintf "1.%04d", q$Revision: 756 $ =~ /(\d+)/;
=head1 NAME
@@ -72,7 +72,11 @@
config_class_name => 'OpenSsh::Sshd',
# try Augeas and fall-back with custom method
- read_config => [ { backend => 'augeas' , config_file => '/etc/ssh/sshd_config'},
+ read_config => [ { backend => 'augeas' ,
+ config_file => '/etc/ssh/sshd_config',
+ # declare "seq" Augeas elements
+ lens_with_seq => [/AcceptEnv AllowGroups [etc]/],
+ },
{ backend => 'custom' , # dir hardcoded in custom class
class => 'Config::Model::Sshd'
}
@@ -649,6 +653,55 @@
die "write_xml: not yet implemented";
}
+=head1 Read and write with Augeas library
+
+You can use L<Config::Augeas> to read and write data back. This way,
+the structure and commments of the original configuration file will
+preserved.
+
+To use Augeas as a backend, you must specify the following
+C<read_config> parameters:
+
+=over
+
+=item backend
+
+Use C<augeas> in this case.
+
+=item save
+
+Either C<backup> or C<newfile>. See L<Config::Augeas/Constructor> for
+details.
+
+=item config_file
+
+Name of the config_file.
+
+=item lens_with_seq
+
+This one is tricky. When an Augeas lens use the C<seq> keywords in a
+lens, a special type of list element is created (See
+L<http://augeas.net/docs/lenses.html> for details on lenses). This
+special list element must be declared so that Config::Model can use
+the correct Augeas call to write this list values. C<lens_with_seq>
+must be passed a list ref of all lens names that contains a C<seq>
+statement.
+
+=back
+
+For instance:
+
+ read_config => [ { backend => 'augeas' ,
+ save => 'backup',
+ config_file => '/etc/ssh/sshd_config',
+ # declare "seq" Augeas elements
+ lens_with_seq => [/AcceptEnv AllowGroups/],
+ },
+ ],
+
+
+=cut
+
# for tests only
sub _augeas_object {return shift->{augeas_obj} ; } ;
@@ -688,6 +741,9 @@
s!/+!/!g;
} @cm_path ;
+ # Create a hash of lens that contain a seq lens
+ my %has_seq = map { ( $_ => 1 ) ;} @{$args{lens_with_seq} || []} ;
+
my $augeas_obj = $self->{augeas_obj} ;
# this may break as data will be written in the tree in an order
@@ -701,18 +757,34 @@
print "read-augeas read $aug_p, set $cm_p with $v\n" if $::debug ;
$cm_p =~ s!^/!! ;
- my @cm_steps = split m!/!, $cm_p ;
+ # With 'seq' type list, we can get
+ # /files/etc/ssh/sshd_config/AcceptEnv[1]/1/ = LC_PAPER
+ # /files/etc/ssh/sshd_config/AcceptEnv[1]/2/ = LC_NAME
+ # /files/etc/ssh/sshd_config/AcceptEnv[2]/3/ = LC_ADDRESS
+ # /files/etc/ssh/sshd_config/AcceptEnv[2]/4/ = LC_TELEPHONE
+ my @cm_steps = split m!/+!, $cm_p ;
my $obj = $self;
while (my $step = shift @cm_steps) {
+ my ($label,$idx) = ( $step =~ /(\w+)(?:\[(\d+)\])?/ ) ;
+
+ # idx will be treated next iteration if needed
+ if ( $obj->get_type eq 'node'
+ and $obj->element_type($label) eq 'list') {
+ $idx = 1 unless defined $idx ;
+ unshift @cm_steps , $idx unless $has_seq{$label} ;
+ }
+
# augeas list begin at 1 not 0
- $step -= 1 if $obj->get_type eq 'list';
+ $label -= 1 if $obj->get_type eq 'list';
if (@cm_steps) {
- $obj = $obj->get($step) ;
+ print "read-augeas: get $label ",
+ ( $has_seq{$label} ? 'seq' : '' ),"\n" if $::debug;
+ $obj = $obj->get($label) ;
}
else {
# last step
- $obj->set($step,$v) ;
+ $obj->set($label,$v) ;
}
}
}
@@ -742,8 +814,6 @@
return @result ;
}
-# FIXME: deal with deleted entries while writing file through Augeas
-# .... Ouch
sub write_augeas
{
my $self = shift;
@@ -765,65 +835,78 @@
my $mainpath = '/files'.$args{config_file} ;
my $augeas_obj = $self->{augeas_obj} ;
- my %old_path = map { ($_ => 1) } $self->augeas_deep_match($mainpath) ;
-
- my %to_set = $self->dump_as_path($set_in) ;
- foreach my $path (keys %to_set) {
- my $aug_path = "$mainpath$path" ;
- my $v = $to_set{$path} ;
- print "write-augeas $path, set $aug_path with $v\n" if $::debug ;
- # remove all Augeas paths that are included in the path found in
- # config-model
- map {delete $old_path{$_} if index($aug_path,$_,0) == 0} keys %old_path ;
- $augeas_obj->set($aug_path,$v) ;
- }
+ my %to_set = $self->copy_in_augeas($augeas_obj,$mainpath,$set_in,
+ $args{lens_with_seq}) ;
+
+ # foreach my $path (keys %to_set) {
+ # my $aug_path = "$mainpath$path" ;
+ # my $v = $to_set{$path} ;
+ # print "write-augeas $path, set $aug_path with $v\n" if $::debug ;
+ # # remove all Augeas paths that are included in the path found in
+ # # config-model
+ # map {delete $old_path{$_} if index($aug_path,$_,0) == 0} keys %old_path ;
+ # $augeas_obj->set($aug_path,$v) ;
+ # }
# remove path no longer present in config-model
- map { print "deleting aug path $_\n" if $::debug;
- $augeas_obj->remove($_) } reverse sort keys %old_path ;
+ #map { print "deleting aug path $_\n" if $::debug;
+ # $augeas_obj->remove($_) } reverse sort keys %old_path ;
$augeas_obj->save || warn "Augeas save failed";;
}
-sub dump_as_path{
+sub copy_in_augeas {
my $self = shift ;
+ my $augeas_obj = shift ;
+ my $mainpath = shift ;
my $set_in = shift ;
-
- # data_ref = ( current_path, \%result )
+ my $seq_list = shift || [];
+ my %has_seq = map { ( $_ => 1 ) ;} @$seq_list ;
+
+ # cleanup the tree. This is not subtle and may be improved when the
+ # following bugs are fixed:
+ # https://fedorahosted.org/augeas/ticket/23
+ # https://fedorahosted.org/augeas/ticket/24
+
+ $augeas_obj->remove("$mainpath/*") ;
+
+ # data_ref = ( current_path )
my $std_cb = sub {
my ( $scanner, $data_ref, $obj, $element, $index, $value_obj ) = @_;
my $p = $data_ref->[0] ;
my $v = $value_obj->fetch () ;
- $data_ref->[1]{$p} = $v if defined $v ;
+ if (defined $v) {
+ $augeas_obj->set($p , $v) ;
+ print "copy_in_augeas: set $p = '$v'\n" if $::debug;
+ }
};
my $hash_element_cb = sub {
my ($scanner, $data_ref,$node,$element_name, at keys) = @_ ;
my $p = $data_ref->[0] ;
- my $r = $data_ref->[1] ;
-
- map {$scanner->scan_hash([$p."/$_",$r],$node,$element_name,$_)} @keys ;
+
+ map {$scanner->scan_hash([$p."/$_"],$node,$element_name,$_)} @keys ;
};
my $list_element_cb = sub {
my ($scanner, $data_ref,$node,$element_name, at idx) = @_ ;
my $p = $data_ref->[0] ;
- my $r = $data_ref->[1] ;
-
- # Augeas lists begin at 1 not 0
- map {$scanner->scan_list([$p.'/'.($_+1),$r],
- $node,$element_name,$_)} @idx ;
+
+ my $seq_item = $has_seq{$element_name} || 0 ;
+ map { my $aug_idx = $_ + 1 ; # Augeas lists begin at 1 not 0
+ my $subpath = $seq_item ? "[last()]/$aug_idx" : "[$aug_idx]" ;
+ $scanner->scan_list([$p.$subpath], $node,$element_name,$_);
+ } @idx ;
};
my $node_content_cb = sub {
my ($scanner, $data_ref,$node, at element) = @_ ;
my $p = $data_ref->[0] ;
- my $r = $data_ref->[1] ;
map {
# Deal with the fact that Augeas tree can start directly into
# a list element
- my $np = $set_in eq $_ ? $p : $p."/$_" ;
- $scanner->scan_element([$np,$r], $node,$_)
+ my $np = (defined $set_in and $set_in eq $_) ? $p : $p."/$_" ;
+ $scanner->scan_element([$np], $node,$_)
} @element ;
};
@@ -841,10 +924,7 @@
# perform the scan
my $view_scanner = Config::Model::ObjTreeScanner->new(@scan_args);
- my %result ;
- $view_scanner->scan_node(['',\%result] ,$self);
-
- return %result ;
+ $view_scanner->scan_node([$mainpath] ,$self);
}
1;
@@ -858,7 +938,7 @@
=head1 SEE ALSO
L<Config::Model>, L<Config::Model::Instance>,
-L<Config::Model::Node>, L<Config::Model::Dumper>
+L<Config::Model::Node>, L<Config::Model::Dumper>, L<Config::Augeas>
=cut
Modified: trunk/libconfig-model-perl/lib/Config/Model/ListId.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libconfig-model-perl/lib/Config/Model/ListId.pm?rev=25566&op=diff
==============================================================================
--- trunk/libconfig-model-perl/lib/Config/Model/ListId.pm (original)
+++ trunk/libconfig-model-perl/lib/Config/Model/ListId.pm Tue Sep 23 15:37:52 2008
@@ -1,6 +1,6 @@
# $Author: ddumont $
-# $Date: 2008-07-07 17:52:23 +0200 (Mon, 07 Jul 2008) $
-# $Revision: 708 $
+# $Date: 2008-07-31 14:35:16 +0200 (Thu, 31 Jul 2008) $
+# $Revision: 743 $
# Copyright (c) 2005-2007 Dominique Dumont.
#
@@ -30,7 +30,7 @@
use base qw/Config::Model::AnyId/ ;
use vars qw($VERSION) ;
-$VERSION = sprintf "1.%04d", q$Revision: 708 $ =~ /(\d+)/;
+$VERSION = sprintf "1.%04d", q$Revision: 743 $ =~ /(\d+)/;
=head1 NAME
@@ -279,7 +279,8 @@
$obj -> load_data($item) ;
}
}
- else {
+ # do now create one element of undef data.
+ elsif (defined $data) {
print "ListId load_data (",$self->location,") will load idx ",
"0\n" if $::verbose ;
$self->clear ;
Modified: trunk/libconfig-model-perl/lib/Config/Model/Node.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libconfig-model-perl/lib/Config/Model/Node.pm?rev=25566&op=diff
==============================================================================
--- trunk/libconfig-model-perl/lib/Config/Model/Node.pm (original)
+++ trunk/libconfig-model-perl/lib/Config/Model/Node.pm Tue Sep 23 15:37:52 2008
@@ -1,6 +1,6 @@
# $Author: ddumont $
-# $Date: 2008-07-24 18:29:18 +0200 (Thu, 24 Jul 2008) $
-# $Revision: 729 $
+# $Date: 2008-09-19 14:17:56 +0200 (Fri, 19 Sep 2008) $
+# $Revision: 752 $
# Copyright (c) 2005-2007 Dominique Dumont.
#
@@ -40,7 +40,7 @@
use vars qw($VERSION $AUTOLOAD @status @level
@experience_list %experience_index );
-$VERSION = sprintf "1.%04d", q$Revision: 729 $ =~ /(\d+)/;
+$VERSION = sprintf "1.%04d", q$Revision: 752 $ =~ /(\d+)/;
*status = *Config::Model::status ;
*level = *Config::Model::level ;
@@ -684,7 +684,17 @@
sub element_type {
my $self= shift ;
croak "element_type: missing element name" unless @_ ;
- return $self->{model}{element}{$_[0]}{type} ;
+ my $element_info = $self->{model}{element}{$_[0]} ;
+
+ Config::Model::Exception::UnknownElement->throw(
+ object => $self,
+ function => 'element_type',
+ where => $self->location || 'configuration root',
+ element => $_[0],
+ )
+ unless defined $element_info ;
+
+ return $element_info->{type} ;
}
=head2 element_name()
@@ -1182,7 +1192,12 @@
my $path = shift ;
$path =~ s!^/!! ;
my ($item,$new_path) = split m!/!,$path,2 ;
- return $self->fetch_element($item)->set($new_path, at _) ;
+ if ($item =~ /([\w\-]+)\[(\d+)\]/) {
+ return $self->fetch_element($1)->fetch_with_id($2)->set($new_path, at _) ;
+ }
+ else {
+ return $self->fetch_element($item)->set($new_path, at _) ;
+ }
}
=head1 Serialisation
Modified: trunk/libconfig-model-perl/lib/Config/Model/Value.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libconfig-model-perl/lib/Config/Model/Value.pm?rev=25566&op=diff
==============================================================================
--- trunk/libconfig-model-perl/lib/Config/Model/Value.pm (original)
+++ trunk/libconfig-model-perl/lib/Config/Model/Value.pm Tue Sep 23 15:37:52 2008
@@ -1,6 +1,6 @@
# $Author: ddumont $
-# $Date: 2008-07-24 18:29:18 +0200 (Thu, 24 Jul 2008) $
-# $Revision: 729 $
+# $Date: 2008-07-31 18:22:43 +0200 (Thu, 31 Jul 2008) $
+# $Revision: 745 $
# Copyright (c) 2005-2007 Dominique Dumont.
#
@@ -36,7 +36,7 @@
use vars qw($VERSION) ;
-$VERSION = sprintf "1.%04d", q$Revision: 729 $ =~ /(\d+)/;
+$VERSION = sprintf "1.%04d", q$Revision: 745 $ =~ /(\d+)/;
=head1 NAME
@@ -360,7 +360,7 @@
# check if the migrated result fits with the constraints of the
# Value object
- my $ok = $self->check($result) ;
+ my $ok = $self->check_value($result) ;
#print "check result: $ok\n";
if (not $ok) {
@@ -1070,9 +1070,10 @@
return @error ;
}
-=head2 check( value , [ 0 | 1 ] )
-
-Check if the value is acceptable or not.
+=head2 check_value ( value , [ 0 | 1 ] )
+
+Check the consistency of the value. Does not check for undefined
+mandatory values.
When the 2nd parameter is non null, check will not try to get extra
informations from the tree. This is required in some cases to avoid
@@ -1086,7 +1087,7 @@
=cut
-sub check {
+sub check_value {
my ($self,$value,$quiet) = @_ ;
$quiet = 0 unless defined $quiet ;
@@ -1095,9 +1096,6 @@
if ( $self->{hidden}) {
push @error, "value is hidden" ;
- }
- elsif (not defined $value and $self->{mandatory}) {
- push @error, "Mandatory value is not defined" ;
}
elsif (not defined $value) {
# accept with no other check
@@ -1153,6 +1151,28 @@
$self->{error} = \@error ;
return wantarray ? @error : not scalar @error ;
}
+
+=head2 check( value , [ 0 | 1 ] )
+
+Like L</check_value>. Also ensure that mandatory value are defined
+
+=cut
+
+sub check {
+ my ($self,$value,$quiet) = @_ ;
+
+ $quiet = 0 unless defined $quiet ;
+
+ my @error = $self->check_value($value,$quiet) ;
+
+ if (not $self->{hidden} and not defined $value and $self->{mandatory}) {
+ push @error, "Mandatory value is not defined" ;
+ }
+
+ $self->{error} = \@error ;
+ return wantarray ? @error : not scalar @error ;
+}
+
=head1 Information management
Modified: trunk/libconfig-model-perl/t/augeas_backend.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libconfig-model-perl/t/augeas_backend.t?rev=25566&op=diff
==============================================================================
--- trunk/libconfig-model-perl/t/augeas_backend.t (original)
+++ trunk/libconfig-model-perl/t/augeas_backend.t Tue Sep 23 15:37:52 2008
@@ -31,7 +31,7 @@
plan skip_all => 'Config::Augeas is not installed';
}
else {
- plan tests => 7;
+ plan tests => 13;
}
ok(1,"compiled");
@@ -44,8 +44,9 @@
# cleanup before tests
rmtree($wr_root);
-mkpath($wr_root.'etc/', { mode => 0755 }) ;
-copy($r_root.'etc/hosts',$wr_root.'/etc/') ;
+mkpath($wr_root.'etc/ssh/', { mode => 0755 }) ;
+copy($r_root.'etc/hosts',$wr_root.'etc/') ;
+copy($r_root.'etc/ssh/sshd_config',$wr_root.'etc/ssh/') ;
# set_up data
@@ -69,17 +70,66 @@
read_config => [ { backend => 'augeas',
config_file => '/etc/hosts',
- set_in => 'top',
+ set_in => 'record',
save => 'backup',
+ lens_with_seq => ['record'],
},
],
element => [
- top => { type => 'list',
- cargo => { type => 'node',
- config_class_name => 'Host',
- } ,
- },
+ record => { type => 'list',
+ cargo => { type => 'node',
+ config_class_name => 'Host',
+ } ,
+ },
+ ]
+ );
+
+$model->create_config_class
+ (
+ name => 'Sshd',
+
+ 'read_config'
+ => [ { backend => 'augeas',
+ config_file => '/etc/ssh/sshd_config',
+ save => 'backup',
+ lens_with_seq => [qw/AcceptEnv AllowGroups AllowUsers
+ DenyGroups DenyUsers/],
+ },
+ ],
+
+ element => [
+ 'AcceptEnv',
+ {
+ 'cargo' => {
+ 'value_type' => 'uniline',
+ 'type' => 'leaf'
+ },
+ 'type' => 'list',
+ },
+ 'HostbasedAuthentication',
+ {
+ 'value_type' => 'boolean',
+ 'type' => 'leaf',
+ },
+ 'HostKey',
+ {
+ 'cargo' => {
+ 'value_type' => 'uniline',
+ 'type' => 'leaf'
+ },
+ 'type' => 'list',
+ },
+ 'Subsystem',
+ {
+ 'cargo' => {
+ 'value_type' => 'uniline',
+ 'mandatory' => '1',
+ 'type' => 'leaf'
+ },
+ 'type' => 'hash',
+ 'index_type' => 'string'
+ },
]
);
@@ -89,15 +139,15 @@
read_root_dir => $wr_root ,
);
-ok( $i_hosts, "Created instance (from scratch)" );
+ok( $i_hosts, "Created instance for /etc/hosts" );
my $i_root = $i_hosts->config_root ;
-my $expect = "top:0
+my $expect = "record:0
ipaddr=127.0.0.1
canonical=localhost
alias=localhost -
-top:1
+record:1
ipaddr=192.168.0.1
canonical=bilbo - -
" ;
@@ -106,32 +156,30 @@
print $dump if $trace ;
is( $dump , $expect,"check dump of augeas data");
-# change data content, '~' is like a splice, 'top~0' like a "shift"
-$i_root->load("top~0 top:0 canonical=buildbot -
- top:1 canonical=komarr ipaddr=192.168.0.10 -
- top:2 canonical=repoman ipaddr=192.168.0.11 -
- top:3 canonical=goner ipaddr=192.168.0.111") ;
+# change data content, '~' is like a splice, 'record~0' like a "shift"
+$i_root->load("record~0 record:0 canonical=buildbot -
+ record:1 canonical=komarr ipaddr=192.168.0.10 -
+ record:2 canonical=repoman ipaddr=192.168.0.11 -
+ record:3 canonical=goner ipaddr=192.168.0.111") ;
$dump = $i_root->dump_tree ;
print $dump if $trace ;
-my %h = $i_root->dump_as_path('top') ;
-print Dumper \%h if $trace ;
-my $expect_h = {
- '/1/canonical' => 'buildbot',
- '/1/ipaddr' => '192.168.0.1',
- '/2/canonical' => 'komarr',
- '/2/ipaddr' => '192.168.0.10',
- '/3/canonical' => 'repoman',
- '/3/ipaddr' => '192.168.0.11',
- '/4/canonical' => 'goner',
- '/4/ipaddr' => '192.168.0.111',
- };
-is_deeply(\%h,$expect_h,"Check dump_as_path") ;
-
$i_hosts->write_back ;
-ok(-e $wr_root.'/etc/hosts.augsave',
- "check that backup config file was written");
+
+my $aug_file = $wr_root.'etc/hosts';
+my $aug_save_file = $aug_file.'.augsave' ;
+ok(-e $aug_save_file, "check that backup config file $aug_save_file was written");
+
+my @expect = ("192.168.0.1 buildbot\n",
+ "192.168.0.10\tkomarr\n",
+ "192.168.0.11\trepoman\n",
+ "192.168.0.111\tgoner\n"
+ );
+
+open(AUG,$aug_file) || die "Can't open $aug_file:$!";
+is_deeply([<AUG>],\@expect,"check content of $aug_file") ;
+close AUG;
# check directly the content of augeas
my $augeas_obj = $i_root->_augeas_object ;
@@ -140,10 +188,73 @@
is($nb,4,"Check nb of hosts in Augeas") ;
# delete last entry
-$i_root->load("top~3");
+$i_root->load("record~3");
$i_hosts->write_back ;
$nb = $augeas_obj -> count_match("/files/etc/hosts/*") ;
is($nb,3,"Check nb of hosts in Augeas after deletion") ;
+pop @expect; # remove goner entry
+open(AUG,$aug_file) || die "Can't open $aug_file:$!";
+is_deeply([<AUG>],\@expect,"check content of $aug_file after deletion of goner") ;
+close AUG;
+
+
+
$augeas_obj->print(*STDOUT, '') if $trace;
+
+my $i_sshd = $model->instance(instance_name => 'sshd_inst',
+ root_class_name => 'Sshd',
+ read_root_dir => $wr_root ,
+ );
+
+ok( $i_sshd, "Created instance for sshd" );
+
+ok( $i_sshd, "Created instance for /etc/ssh/sshd_config" );
+
+my $sshd_root = $i_sshd->config_root ;
+
+my $ssh_augeas_obj = $sshd_root->_augeas_object ;
+
+$ssh_augeas_obj->print(*STDOUT, '/files/etc/ssh/sshd_config/*') if $trace;
+#my @aug_content = $ssh_augeas_obj->match("/files/etc/ssh/sshd_config/*") ;
+#print join("\n", at aug_content) ;
+
+$expect = "AcceptEnv=LC_PAPER,LC_NAME,LC_ADDRESS,LC_TELEPHONE,LC_MEASUREMENT,LC_IDENTIFICATION,LC_ALL
+HostbasedAuthentication=0
+HostKey=/etc/ssh/ssh_host_key,/etc/ssh/ssh_host_rsa_key,/etc/ssh/ssh_host_dsa_key
+Subsystem:internal=/usr/lib/openssh/sftp-server
+Subsystem:sftp=/usr/lib/openssh/sftp-server -
+";
+
+$dump = $sshd_root->dump_tree ;
+print $dump if $trace ;
+is( $dump , $expect,"check dump of augeas data");
+
+# change data content, '~' is like a splice, 'record~0' like a "shift"
+$sshd_root->load("HostbasedAuthentication=1") ;
+
+$dump = $sshd_root->dump_tree ;
+print $dump if $trace ;
+
+$i_sshd->write_back ;
+
+my $aug_sshd_file = $wr_root.'etc/ssh/sshd_config';
+my $aug_save_sshd_file = $aug_sshd_file.'.augsave' ;
+ok(-e $aug_save_sshd_file,
+ "check that backup config file $aug_save_sshd_file was written");
+
+ at expect = (
+"# only a few parameters for augeas tests in core module\n",
+"# leaf, list and hash elements\n",
+"AcceptEnv LC_PAPER LC_NAME LC_ADDRESS LC_TELEPHONE LC_MEASUREMENT LC_IDENTIFICATION LC_ALL\n",
+"HostbasedAuthentication 1\n",
+"HostKey /etc/ssh/ssh_host_key\n",
+"HostKey /etc/ssh/ssh_host_rsa_key\n",
+"HostKey /etc/ssh/ssh_host_dsa_key\n",
+"Subsystem internal /usr/lib/openssh/sftp-server\n",
+ );
+
+open(AUG,$aug_sshd_file) || die "Can't open $aug_sshd_file:$!";
+is_deeply([<AUG>],\@expect,"check content of $aug_sshd_file") ;
+close AUG;
Modified: trunk/libconfig-model-perl/t/node.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libconfig-model-perl/t/node.t?rev=25566&op=diff
==============================================================================
--- trunk/libconfig-model-perl/t/node.t (original)
+++ trunk/libconfig-model-perl/t/node.t Tue Sep 23 15:37:52 2008
@@ -1,10 +1,12 @@
# -*- cperl -*-
# $Author: ddumont $
-# $Date: 2008-05-14 18:02:59 +0200 (Wed, 14 May 2008) $
-# $Revision: 660 $
+# $Date: 2008-09-22 13:02:32 +0200 (Mon, 22 Sep 2008) $
+# $Revision: 755 $
use ExtUtils::testlib;
-use Test::More tests => 45;
+use Test::More tests => 44;
+use Test::Exception ;
+use Test::Warn ;
use Config::Model;
use warnings;
@@ -20,11 +22,11 @@
permission => [ [qw/Y/] => 'beginner', # default
X => 'master'
],
- status => [ X => 'deprecated' ], #could be obsolete, standard
+ status => [ D => 'deprecated' ], #could be obsolete, standard
description => [ X => 'X-ray' ],
element => [
- [qw/X Y Z/] => {
+ [qw/D X Y Z/] => {
type => 'leaf',
class => 'Config::Model::Value',
value_type => 'enum',
@@ -116,21 +118,24 @@
is( $b->fetch_element_value('Z'), undef, "test Z value" );
-eval { $b->fetch_element('Z','user');} ;
-ok($@,"fetch_element with unexpected experience") ;
-like($@,qr/Unexpected experience/,"check error message") ;
+throws_ok {$b->fetch_element('Z','user')}
+ qr/Unexpected experience/, "fetch_element with unexpected experience" ;
# translated into beginner
-eval { $b->fetch_element('X','beginner');} ;
-ok($@,"fetch_element with unexpected experience") ;
-like($@,qr/restricted element/,"check error message") ;
+throws_ok { $b->fetch_element('X','beginner'); }
+ 'Config::Model::Exception::RestrictedElement',
+ 'Restricted element error';
+
+warning_like { $b->fetch_element('D'); }
+ qr/Element 'D' of node 'captain bar' is deprecated/,
+ 'Check deprecated element warning';
is( $root->fetch_element('array_args')
->get_element_property(property => 'experience',element => 'bar'),
- 'beginner' );
+ 'beginner' , "check 'bar' experience");
is( $root->fetch_element('array_args')->fetch_element('bar')
->get_element_property(property => 'experience',element => 'X'),
- 'master' );
+ 'master', "check 'X' experience" );
my $tested = $root->fetch_element('hash_args')->fetch_element('bar');
Modified: trunk/libconfig-model-perl/t/smooth_upgrade.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libconfig-model-perl/t/smooth_upgrade.t?rev=25566&op=diff
==============================================================================
--- trunk/libconfig-model-perl/t/smooth_upgrade.t (original)
+++ trunk/libconfig-model-perl/t/smooth_upgrade.t Tue Sep 23 15:37:52 2008
@@ -6,7 +6,7 @@
use warnings FATAL => qw(all);
use ExtUtils::testlib;
-use Test::More tests => 19 ;
+use Test::More tests => 21 ;
use Test::Exception ;
use Test::Warn ;
use Config::Model ;
@@ -68,7 +68,15 @@
level => 'hidden',
description => 'hidden_p is replaced by new_from_hidden',
},
+ ]
+ );
+
+$model ->create_config_class
+ (
+ name => "UrlMigration",
+ 'element'
+ => [
'old_url' => { type => 'leaf',
value_type => 'uniline',
status => 'deprecated',
@@ -76,6 +84,7 @@
'host'
=> { type => 'leaf',
value_type => 'uniline',
+ mandatory => 1,
migrate_from => { formula => '$old =~ m!http://([\w\.]+)!; $1 ;' ,
variables => { old => '- old_url' } ,
use_eval => 1 ,
@@ -133,7 +142,7 @@
# check element list
is_deeply( [$root->get_element_name ],
- [qw/new_from_deprecated host port path/],
+ [qw/new_from_deprecated/],
"check that deprecated and obsolete parameters are hidden"
) ;
@@ -151,18 +160,30 @@
is( $nfd->fetch_standard, undef, "but standard value is undef");
# test migration with regexp value
+my $uinst = $model->instance (root_class_name => 'UrlMigration',
+ instance_name => 'urltest');
+ok($uinst,"created url test instance") ;
+
+my $uroot = $uinst -> config_root ;
+
my $host = 'foo.gre.hp.com';
my $port = 2345 ;
my $path = '/bar/baz.html';
my $url = "http://$host:$port$path" ;
-warning_like {$dp = $root->fetch_element('old_url')->store($url) ;}
- qr/Element 'old_url' of node 'Master' is deprecated/ ,
+# check element list
+is_deeply( [$uroot->get_element_name ],
+ [qw/host port path/],
+ "check that url deprecated and obsolete parameters are hidden"
+ ) ;
+
+warning_like {$dp = $uroot->fetch_element('old_url')->store($url) ;}
+ qr/Element 'old_url' of node 'UrlMigration' is deprecated/ ,
"check warning when fetching deprecated element" ;
-my $h = $root->fetch_element('host');
+my $h = $uroot->fetch_element('host');
is($h->fetch,$host,"check extracted host") ;
-is($root->fetch_element('port')->fetch,$port,"check extracted port") ;
-is($root->fetch_element('path')->fetch,$path,"check extracted path") ;
+is($uroot->fetch_element('port')->fetch,$port,"check extracted port") ;
+is($uroot->fetch_element('path')->fetch,$path,"check extracted path") ;
More information about the Pkg-perl-cvs-commits
mailing list