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