r70294 - in /branches/upstream/libconfig-model-tkui-perl/current: ./ lib/Config/Model/ lib/Config/Model/Tk/ t/
ddumont-guest at users.alioth.debian.org
ddumont-guest at users.alioth.debian.org
Thu Mar 3 11:25:23 UTC 2011
Author: ddumont-guest
Date: Thu Mar 3 11:25:15 2011
New Revision: 70294
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=70294
Log:
[svn-upgrade] new version libconfig-model-tkui-perl (1.321)
Modified:
branches/upstream/libconfig-model-tkui-perl/current/Build.PL
branches/upstream/libconfig-model-tkui-perl/current/ChangeLog
branches/upstream/libconfig-model-tkui-perl/current/META.yml
branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/AnyViewer.pm
branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/CheckListEditor.pm
branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/CheckListViewer.pm
branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/HashEditor.pm
branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/HashViewer.pm
branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/LeafEditor.pm
branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/LeafViewer.pm
branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/ListEditor.pm
branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/ListViewer.pm
branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/NodeEditor.pm
branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/NodeViewer.pm
branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/NoteEditor.pm
branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/Wizard.pm
branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/TkUI.pm
branches/upstream/libconfig-model-tkui-perl/current/t/config-model-ui.t
branches/upstream/libconfig-model-tkui-perl/current/t/config-model-wizard.t
Modified: branches/upstream/libconfig-model-tkui-perl/current/Build.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/Build.PL?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/Build.PL (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/Build.PL Thu Mar 3 11:25:15 2011
@@ -51,7 +51,7 @@
'Tk::ObjScanner' => '0'
},
'requires' => {
- 'Config::Model' => '1.228',
+ 'Config::Model' => '1.235',
'Exception::Class' => '0',
'File::Slurp' => '0',
'Log::Log4perl' => '1.11',
Modified: branches/upstream/libconfig-model-tkui-perl/current/ChangeLog
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/ChangeLog?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/ChangeLog (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/ChangeLog Thu Mar 3 11:25:15 2011
@@ -1,3 +1,9 @@
+2011-03-01 Dominique Dumont <domi.dumont at free.fr> 1.321
+
+ * TkUi.pm: renamed 'check' menu to 'check for errors'. Added 'check for warnings'
+ * AnyViewer: renamed warning widget to 'issue'. Display errors with red background
+ * NodeEditor: added widget to edit node annotations
+
2011-01-11 Dominique Dumont <domi.dumont at free.fr> 1.320
* LeafViewer: removed 'apply fix' button. This one is reserved for
Modified: branches/upstream/libconfig-model-tkui-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/META.yml?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/META.yml (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/META.yml Thu Mar 3 11:25:15 2011
@@ -9,7 +9,7 @@
configure_requires:
Module::Build: 0.3601
dynamic_config: 0
-generated_by: 'Dist::Zilla version 4.200000, CPAN::Meta::Converter version 2.102400'
+generated_by: 'Dist::Zilla version 4.200003, CPAN::Meta::Converter version 2.102400'
license: lgpl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -18,7 +18,7 @@
recommends:
Tk::ObjScanner: 0
requires:
- Config::Model: 1.228
+ Config::Model: 1.235
Exception::Class: 0
File::Slurp: 0
Log::Log4perl: 1.11
@@ -26,4 +26,4 @@
Tk: 0
Tk::DirSelect: 0
Tk::Tree: 0
-version: 1.320
+version: 1.321
Modified: branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/AnyViewer.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/AnyViewer.pm?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/AnyViewer.pm (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/AnyViewer.pm Thu Mar 3 11:25:15 2011
@@ -27,7 +27,7 @@
package Config::Model::Tk::AnyViewer ;
BEGIN {
- $Config::Model::Tk::AnyViewer::VERSION = '1.320';
+ $Config::Model::Tk::AnyViewer::VERSION = '1.321';
}
use strict;
@@ -38,8 +38,11 @@
use Tk::ROText;
use Tk::Dialog ;
use Config::Model::TkUI ;
+use Log::Log4perl qw(get_logger :levels);
use vars qw/$icon_path/ ;
+
+my $logger = get_logger("Tk");
my @fbe1 = qw/-fill both -expand 1/ ;
my @fxe1 = qw/-fill x -expand 1/ ;
@@ -170,14 +173,12 @@
sub add_warning {
my ($cw, $elt_obj,$usage) = @_ ;
- my $msg = $elt_obj->warning_msg || '' . "with " . $elt_obj->has_fixes." fixes";
-
my $frame = $cw -> Frame ; # packed by caller
my $inner_frame = $frame->Frame ; # packed by update_warning
my $label_button_frame = $inner_frame->Frame->pack(@fxe1) ;
$label_button_frame ->Label(
- -text => 'Warning',
+ -text => 'Issues',
) ->pack(-anchor => 'w', -side => 'left', -fill =>'x');
if ($usage eq 'edit') {
@@ -199,8 +200,16 @@
-height => 4,
);
+ my $err = $elt_obj->error_msg || '';
+ $warn_widget ->pack( @fbe1 ) ->insert('end',$err,'error') ;
+ $warn_widget ->tagConfigure(qw/error -lmargin1 2 -lmargin2 2 -rmargin 2 -background red/);
+
+ my $msg = $elt_obj->warning_msg || '' ;
+ $msg .= "with " . $elt_obj->has_fixes." fixes" if $msg ;
$warn_widget ->pack( @fbe1 ) ->insert('end',$msg,'warning') ;
$warn_widget ->tagConfigure(qw/warning -lmargin1 2 -lmargin2 2 -rmargin 2 -background orange/);
+
+ $logger->debug("creating warning widget". ($err ? " with errors": '').($msg ? " with warnings":''));
$cw->Advertise(warn_widget => $warn_widget) ;
$cw->Advertise(warn_frame => $inner_frame ) ;
@@ -211,23 +220,31 @@
}
sub update_warning {
- my ($cw, $elt_obj,$usage) = @_ ;
-
- my $msg = $elt_obj->warning_msg ;
- if (ref ($msg) eq 'HASH') {
- $msg = join('', map { join("\n\t",@{$msg->{$_}}) } sort keys %$msg ) ;
- }
+ my ($cw, $elt_obj) = @_ ;
my $wf = $cw->Subwidget('warn_frame') ;
my $ww = $cw->Subwidget('warn_widget') ;
my $fw = $cw->Subwidget('fix_widget') ;
- if ($msg) {
- $ww->delete('0.0', 'end') ;
- $ww->insert('end',$msg,'warning') ;
+ $ww->delete('0.0', 'end') ;
+
+ my $err = $elt_obj -> error_msg || '' ;
+ $ww->insert('end',$err,'error') if $err ;
+
+
+ my $msg .= $elt_obj->warning_msg || '';
+ if (ref ($msg) eq 'HASH') {
+ $msg = join('', map { join("\n\t",@{$msg->{$_}}) } sort keys %$msg ) ;
+ }
+ $ww->insert('end',$msg,'warning') if $msg ;
+
+ $logger->debug("updating warning widget". ($err ? " with errors": '').($msg ? " with warnings":''));
+
+
+ if ($msg or $err) {
$wf->pack(@fbe1) ;
- if ( defined $fw ) {
+ if ( $msg and defined $fw ) {
my $nb_fixes = $elt_obj->has_fixes;
$fw->configure(
-text => "Apply $nb_fixes fixes",
Modified: branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/CheckListEditor.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/CheckListEditor.pm?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/CheckListEditor.pm (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/CheckListEditor.pm Thu Mar 3 11:25:15 2011
@@ -9,7 +9,7 @@
#
package Config::Model::Tk::CheckListEditor ;
BEGIN {
- $Config::Model::Tk::CheckListEditor::VERSION = '1.320';
+ $Config::Model::Tk::CheckListEditor::VERSION = '1.321';
}
use strict;
Modified: branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/CheckListViewer.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/CheckListViewer.pm?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/CheckListViewer.pm (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/CheckListViewer.pm Thu Mar 3 11:25:15 2011
@@ -9,7 +9,7 @@
#
package Config::Model::Tk::CheckListViewer ;
BEGIN {
- $Config::Model::Tk::CheckListViewer::VERSION = '1.320';
+ $Config::Model::Tk::CheckListViewer::VERSION = '1.321';
}
use strict;
Modified: branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/HashEditor.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/HashEditor.pm?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/HashEditor.pm (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/HashEditor.pm Thu Mar 3 11:25:15 2011
@@ -9,7 +9,7 @@
#
package Config::Model::Tk::HashEditor ;
BEGIN {
- $Config::Model::Tk::HashEditor::VERSION = '1.320';
+ $Config::Model::Tk::HashEditor::VERSION = '1.321';
}
use strict;
@@ -30,7 +30,7 @@
my @fbe1 = qw/-fill both -expand 1/ ;
my @fxe1 = qw/-fill x -expand 1/ ;
my @fx = qw/-fill x / ;
-my $logger = Log::Log4perl::get_logger(__PACKAGE__);
+my $logger = Log::Log4perl::get_logger(")Tk::HashEditor");
my $entry_width = 15 ;
Modified: branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/HashViewer.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/HashViewer.pm?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/HashViewer.pm (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/HashViewer.pm Thu Mar 3 11:25:15 2011
@@ -9,7 +9,7 @@
#
package Config::Model::Tk::HashViewer ;
BEGIN {
- $Config::Model::Tk::HashViewer::VERSION = '1.320';
+ $Config::Model::Tk::HashViewer::VERSION = '1.321';
}
use strict;
Modified: branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/LeafEditor.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/LeafEditor.pm?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/LeafEditor.pm (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/LeafEditor.pm Thu Mar 3 11:25:15 2011
@@ -9,7 +9,7 @@
#
package Config::Model::Tk::LeafEditor ;
BEGIN {
- $Config::Model::Tk::LeafEditor::VERSION = '1.320';
+ $Config::Model::Tk::LeafEditor::VERSION = '1.321';
}
use strict;
@@ -30,7 +30,7 @@
my @fxe1 = qw/-fill x -expand 1/ ;
my @fx = qw/-fill x / ;
-my $logger = Log::Log4perl::get_logger(__PACKAGE__);
+my $logger = Log::Log4perl::get_logger("Tk::LeafEditor");
sub ClassInit {
my ($cw, $args) = @_;
@@ -50,10 +50,11 @@
my $inst = $leaf->instance ;
my $vt = $leaf -> value_type ;
$logger->info("Creating leaf editor for value_type $vt");
+ $cw->{value} = $leaf->fetch ( check => 'no');
+ $logger->info("Creating leaf editor with error ".$leaf->error_msg);
$cw->add_header(Edit => $leaf)->pack(@fx) ;
- $cw->{value} = $leaf->fetch ( check => 'no');
my $vref = \$cw->{value};
my @pack_args = @fx ;
@@ -188,7 +189,7 @@
: $cw->{value} ;
}
- return unless defined $v;
+ $v = '' unless defined $v ;
chomp $v ;
$logger->debug( "try: value $v") ;
Modified: branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/LeafViewer.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/LeafViewer.pm?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/LeafViewer.pm (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/LeafViewer.pm Thu Mar 3 11:25:15 2011
@@ -9,7 +9,7 @@
#
package Config::Model::Tk::LeafViewer ;
BEGIN {
- $Config::Model::Tk::LeafViewer::VERSION = '1.320';
+ $Config::Model::Tk::LeafViewer::VERSION = '1.321';
}
use strict;
@@ -25,7 +25,7 @@
my @fxe1 = qw/-fill x -expand 1/ ;
my @fx = qw/-fill x / ;
-my $logger = Log::Log4perl::get_logger(__PACKAGE__);
+my $logger = Log::Log4perl::get_logger("Tk::LeafViewer");
sub ClassInit {
my ($cw, $args) = @_;
Modified: branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/ListEditor.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/ListEditor.pm?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/ListEditor.pm (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/ListEditor.pm Thu Mar 3 11:25:15 2011
@@ -9,7 +9,7 @@
#
package Config::Model::Tk::ListEditor ;
BEGIN {
- $Config::Model::Tk::ListEditor::VERSION = '1.320';
+ $Config::Model::Tk::ListEditor::VERSION = '1.321';
}
use strict;
@@ -29,7 +29,7 @@
my @fbe1 = qw/-fill both -expand 1/ ;
my @fxe1 = qw/-fill x -expand 1/ ;
my @fx = qw/-fill x / ;
-my $logger = Log::Log4perl::get_logger(__PACKAGE__);
+my $logger = Log::Log4perl::get_logger("Tk::ListEditor");
my $up_img;
my $down_img;
Modified: branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/ListViewer.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/ListViewer.pm?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/ListViewer.pm (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/ListViewer.pm Thu Mar 3 11:25:15 2011
@@ -9,7 +9,7 @@
#
package Config::Model::Tk::ListViewer ;
BEGIN {
- $Config::Model::Tk::ListViewer::VERSION = '1.320';
+ $Config::Model::Tk::ListViewer::VERSION = '1.321';
}
use strict;
Modified: branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/NodeEditor.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/NodeEditor.pm?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/NodeEditor.pm (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/NodeEditor.pm Thu Mar 3 11:25:15 2011
@@ -9,7 +9,7 @@
#
package Config::Model::Tk::NodeEditor ;
BEGIN {
- $Config::Model::Tk::NodeEditor::VERSION = '1.320';
+ $Config::Model::Tk::NodeEditor::VERSION = '1.321';
}
use strict;
@@ -19,6 +19,7 @@
use Tk::Pane ;
use Tk::Balloon;
use Text::Wrap;
+use Config::Model::Tk::NoteEditor ;
use base qw/Tk::Frame Config::Model::Tk::AnyViewer/;
use subs qw/menu_struct/ ;
@@ -30,7 +31,7 @@
my @fxe1 = qw/-fill x -expand 1/ ;
my @fx = qw/-fill x -expand 0/ ;
-my $logger = Log::Log4perl::get_logger(__PACKAGE__);
+my $logger = Log::Log4perl::get_logger("Tk::NodeEditor");
sub ClassInit {
my ($cw, $args) = @_;
@@ -60,6 +61,7 @@
#require Tk::Adjuster;
#$cw -> Adjuster()->pack(-fill => 'x' , -side => 'top') ;
+ $cw->ConfigModelNoteEditor( -object => $node )->pack;
$cw->add_info_button()->pack(@fxe1, qw/-anchor n/) ;
if ($node->parent) {
Modified: branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/NodeViewer.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/NodeViewer.pm?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/NodeViewer.pm (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/NodeViewer.pm Thu Mar 3 11:25:15 2011
@@ -9,7 +9,7 @@
#
package Config::Model::Tk::NodeViewer ;
BEGIN {
- $Config::Model::Tk::NodeViewer::VERSION = '1.320';
+ $Config::Model::Tk::NodeViewer::VERSION = '1.321';
}
use strict;
Modified: branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/NoteEditor.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/NoteEditor.pm?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/NoteEditor.pm (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/NoteEditor.pm Thu Mar 3 11:25:15 2011
@@ -9,7 +9,7 @@
#
package Config::Model::Tk::NoteEditor ;
BEGIN {
- $Config::Model::Tk::NoteEditor::VERSION = '1.320';
+ $Config::Model::Tk::NoteEditor::VERSION = '1.321';
}
use strict;
Modified: branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/Wizard.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/Wizard.pm?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/Wizard.pm (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/Tk/Wizard.pm Thu Mar 3 11:25:15 2011
@@ -10,7 +10,7 @@
package Config::Model::Tk::Wizard ;
BEGIN {
- $Config::Model::Tk::Wizard::VERSION = '1.320';
+ $Config::Model::Tk::Wizard::VERSION = '1.321';
}
use strict;
@@ -62,6 +62,7 @@
$logger->info("Creating wizard widget");
$cw->{show_cb} ||= sub {} ;
$cw->{store_cb} ||= sub {} ;
+ $cw->{has_stopped} = 0;
my $title = delete $args->{'-title'}
|| "config wizard ".$cw->{root}->config_class_name ;
@@ -105,6 +106,7 @@
sub leaf_cb {
my ( $cw, $scanner, $data_ref, $node, $element_name, $index, $leaf_object )
= @_;
+ $cw->{has_stopped} = 1;
# cleanup existing widget contained in this frame
$cw->{show_cb}->($leaf_object);
@@ -116,6 +118,7 @@
sub list_element_cb {
my ( $cw, $scanner, $data_ref, $node, $element_name, @indexes ) = @_;
+ $cw->{has_stopped} = 1;
# cleanup existing widget contained in this frame
my $obj = $node->fetch_element($element_name);
@@ -128,6 +131,7 @@
sub hash_element_cb {
my ( $cw, $scanner, $data_ref, $node, $element_name, @keys ) = @_;
+ $cw->{has_stopped} = 1;
# cleanup existing widget contained in this frame
my $obj = $node->fetch_element($element_name);
@@ -140,6 +144,7 @@
sub check_list_element_cb {
my ( $cw, $scanner, $data_ref, $node, $element_name, @items ) = @_;
+ $cw->{has_stopped} = 1;
# cleanup existing widget contained in this frame
my $obj = $node->fetch_element($element_name);
@@ -150,10 +155,14 @@
)->pack(@fbe1);
}
-sub start_wizard {
- my ($cw,$exp) = @_ ;
-
- my $text = 'The wizard will scan all configuration items and stop on "important" items or on error (like missing mandatory values). If no "important" item and no error are found, the wizard will exit immediately' ;
+sub prepare_wizard {
+ my ($cw,%args) = @_ ;
+
+ my $exp = $args{experience} || 'beginner' ;
+
+ my $text = 'The wizard will scan all configuration items and stop on '
+ . '"important" items or on error (like missing mandatory values). If no '
+ . '"important" item and no error are found, the wizard will exit immediately' ;
my $edf = $cw->{ed_frame} ;
@@ -180,17 +189,18 @@
$edf->Checkbutton (-text => 'stop on warning', -variable => \$stop_on_warn )->pack(qw/-side top -anchor w/);
$edf->Button(-text => 'OK',
- -command => sub {$cw->_start_wizard($exp,$stop_on_warn)}
+ -command => sub {$cw->start_wizard($exp,$stop_on_warn)}
) -> pack (qw/-side right -anchor e/) ;
$edf->Button(-text => 'cancel',
-command => sub {$cw->destroy_wizard()}
) -> pack (qw/-side left -anchor w/) ;
}
-sub _start_wizard {
- my ( $cw, $exp, $stop_on_warn ) = @_;
+sub start_wizard {
+ my ( $cw, %args) = @_;
my $button_f = $cw->Frame->pack(qw/-pady 0 -fill x -expand 1/);
+ $cw->{has_stopped} = 0;
my $back = $button_f->Button(
-text => 'Back',
@@ -248,15 +258,19 @@
}
my @wiz_args = (
- experience => $exp,
- call_back_on_warning => $stop_on_warn,
+ experience => $args{experience} || 'beginner',
%cb_table
);
+ foreach (qw/warning important/) {
+ push @wiz_args, "call_back_on_$_" => $args{"stop_on_$_"}
+ if defined $args{"stop_on_$_"} ;
+ }
+
#Tk::ObjScanner::scan_object(\@wiz_args) ;
- $cw->{wizard} = $cw->{root}->instance->wizard_helper(@wiz_args);
-
- # exits when wizard is done (but not when stopped)
+ $cw->{wizard} = $cw->{root}->instance->iterator(@wiz_args);
+
+ # exits when wizard is done
$cw->{wizard}->start;
$cw->destroy_wizard;
}
@@ -267,13 +281,14 @@
delete $cw->{ed_w} ;
delete $cw->{wizard} ;
+ # print "Destroying wizard\n" ;
+ $logger->debug("Destroying wizard");
+ $cw->destroy ;
+
if (defined $cw->{end_cb}) {
$logger->debug("Calling end_cb");
- $cw->{end_cb}->() ;
- }
-
- $logger->debug("Destroying wizard");
- $cw->destroy ;
+ $cw->{end_cb}->($cw->{has_stopped}) ;
+ }
}
1;
Modified: branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/TkUI.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/TkUI.pm?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/TkUI.pm (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/lib/Config/Model/TkUI.pm Thu Mar 3 11:25:15 2011
@@ -11,7 +11,7 @@
package Config::Model::TkUI ;
BEGIN {
- $Config::Model::TkUI::VERSION = '1.320';
+ $Config::Model::TkUI::VERSION = '1.321';
}
use strict;
@@ -130,7 +130,8 @@
my $file_items = [[ qw/command wizard -command/, sub{ $cw->wizard }],
[ qw/command reload -command/, sub{ $cw->reload }],
- [ qw/command check -command/, sub{ $cw->check(1)}],
+ [ command => 'check for errors', -command => sub{ $cw->check(1)} ],
+ [ command => 'check for warnings', -command => sub{ $cw->check(1)} ],
[ qw/command save -command/, sub{ $cw->save }],
[ command => 'save in dir ...',
-command => sub{ $cw->save_in_dir ;} ],
@@ -347,53 +348,25 @@
sub check {
my $cw = shift ;
- my $show = shift || 0 ;
-
- # first check for errors, will die on errors
- eval { $cw->{root}->dump_tree(auto_vivify => 1, full_dump => 1) } ;
-
- if ($@) {
- $cw->handle_error($@) ;
- }
- elsif ($show) {
+ my $show = shift || 0;
+ my $check_warnings = shift || 0;
+
+ my $wiz = $cw->setup_wizard(sub{ $cw->check_end($show, at _) ;});
+
+ $wiz->start_wizard(experience => $cw->{experience}, stop_on_warning => $check_warnings ) ;
+}
+
+sub check_end {
+ my $cw = shift ;
+ my $show = shift ;
+ my $has_stopped = shift ;
+
+ $cw->reload if $has_stopped ;
+
+ if ($show and not $has_stopped) {
$cw->Dialog(-title => 'Check',
- -text => "No errors found"
+ -text => "No issue found"
) -> Show ;
- }
-}
-
-sub handle_error {
- my $cw = shift;
- my $e_obj = shift ;
- my $mode = shift || '' ;
-
- my @buttons = qw/ok/ ;
-
- my $conf_obj = $e_obj->object ;
- push @buttons, 'edit' if defined $conf_obj ;
-
- push @buttons, 'trace' unless $mode eq 'trace' ;
-
- my $d = $cw->DialogBox(-title => 'Error',
- -buttons => \@buttons,
- ) ;
-
- if ($mode eq 'trace') {
- my $t = $d->add('ROText') -> pack;
- $t->insert(end => $e_obj->trace->as_string);
- }
- else {
- $d->add('Label',
- -text => $e_obj-> as_string ) -> pack ;
- }
-
- my $answer = $d -> Show ;
-
- if ($answer eq 'trace') {
- $cw->handle_error($e_obj,$answer) ;
- }
- elsif ($answer eq 'edit') {
- $cw->force_element_display($conf_obj) ;
}
}
@@ -407,18 +380,18 @@
$cw->check() ;
if (defined $cw->{store_sub}) {
- $logger->info( "Saving data in $trace_dir directory with store call-back" );
- $cw->{store_sub}->($dir) ;
+ $logger->info( "Saving data in $trace_dir directory with store call-back" );
+ $cw->{store_sub}->($dir) ;
}
else {
- $logger->info( "Saving data in $trace_dir directory with instance write_back" );
- eval { $cw->{root}->instance->write_back(@wb_args); } ;
- if ($@) {
- $cw -> Dialog ( -title => 'Save error',
- -text => $@->as_string,
- )
+ $logger->info( "Saving data in $trace_dir directory with instance write_back" );
+ eval { $cw->{root}->instance->write_back(@wb_args); } ;
+ if ($@) {
+ $cw -> Dialog ( -title => 'Save error',
+ -text => $@->as_string,
+ )
-> Show ;
- }
+ }
}
$cw->{modified_data} = 0 ;
}
@@ -842,6 +815,7 @@
fallback => 'node',
experience => 'master', #'beginner',
+ check => 'no',
# node callback
node_content_cb => \&disp_obj_elt ,
@@ -1026,23 +1000,28 @@
sub wizard {
my $cw = shift ;
- my $tree = $cw->{tktree} ;
+
+ my $wiz = $cw->setup_wizard(sub{ $cw->deiconify; $cw->raise ; $cw->reload ;});
+
+ # hide main window while wizard is running
+ # end_cb callback will raise the main window
+ $cw->withdraw ;
+
+ $wiz->prepare_wizard(experience => $cw->{experience}) ;
+}
+
+sub setup_wizard {
+ my $cw = shift ;
+ my $end_sub = shift ;
# when wizard is run, there's no need to update editor window in
# main widget
- my $wiz = $cw->ConfigModelWizard
+ return $cw->ConfigModelWizard
(
-root => $cw->{root},
-store_cb => sub{ $cw->{modified_data} = 1 ;},
- -end_cb => sub{ $cw->deiconify; $cw->raise ; $cw->reload ;},
- # -show_cb => sub{ $cw->force_element_display(@_)},
+ -end_cb => $end_sub,
) ;
-
- # hide main window while wizard is running
- # end_cb callback will raise the main window
- $cw->withdraw ;
-
- $wiz->start_wizard($cw->{experience}) ;
}
1;
Modified: branches/upstream/libconfig-model-tkui-perl/current/t/config-model-ui.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/t/config-model-ui.t?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/t/config-model-ui.t (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/t/config-model-ui.t Thu Mar 3 11:25:15 2011
@@ -3,7 +3,7 @@
use warnings FATAL => qw(all);
use ExtUtils::testlib;
-use Test::More tests => 53 ;
+use Test::More tests => 52 ;
use Test::Warn ;
use Tk;
use Config::Model::TkUI;
@@ -24,7 +24,14 @@
print "You can play with the widget if you run the test with 's' argument\n";
-Log::Log4perl->easy_init($log ? $TRACE: $WARN);
+my $log4perl_user_conf_file = $ENV{HOME}.'/.log4config-model' ;
+
+if ($log and -e $log4perl_user_conf_file ) {
+ Log::Log4perl::init($log4perl_user_conf_file);
+}
+else {
+ Log::Log4perl->easy_init($log ? $WARN: $ERROR);
+}
Config::Model::Exception::Any->Trace(1) if $arg =~ /e/;
@@ -126,15 +133,15 @@
sub { $cmu->create_element_widget('edit','test1.std_id');; ok(1,"test ".$idx++)},
sub { $cmu->{editor}->add_entry('e'); ok(1,"test ".$idx++)},
sub { $tktree->open('test1.std_id') ; ok(1,"test ".$idx++)},
- sub { $cmu->reload; ok(1,"test ".$idx++)} ,
+ sub { $cmu->reload; ok(1,"test reload ".$idx++)} ,
sub { $cmu->create_element_widget('view','test1.std_id'); ok(1,"test ".$idx++)},
sub { $cmu->create_element_widget('edit','test1.std_id'); ok(1,"test ".$idx++)},
sub { $tktree->open('test1.std_id.ab') ; ok(1,"test ".$idx++)},
sub { $cmu->create_element_widget('view','test1.std_id.ab.Z'); ok(1,"test ".$idx++)},
- sub { $root->load(step => "std_id:ab Z=Cv") ; $cmu->reload ;; ok(1,"test ".$idx++)},
+ sub { $root->load(step => "std_id:ab Z=Cv") ; $cmu->reload ;; ok(1,"test load ".$idx++)},
sub { $tktree->open('test1.std_id.ab') ; ok(1,"test ".$idx++)},
sub { $cmu->create_element_widget('edit','test1.std_id.ab.DX'); ok(1,"test ".$idx++)},
- sub { $root->load(step => "std_id:ab3") ; $cmu->reload ;; ok(1,"test ".$idx++)} ,
+ sub { $root->load(step => "std_id:ab3") ; $cmu->reload ;; ok(1,"test load ".$idx++)} ,
sub { $cmu->create_element_widget('view','test1.string_with_def'); ok(1,"test ".$idx++)},
sub { $cmu->create_element_widget('edit','test1.string_with_def'); ok(1,"test ".$idx++)},
sub { $cmu->create_element_widget('view','test1.a_long_string'); ok(1,"test ".$idx++)},
@@ -148,36 +155,36 @@
sub { $cmu->create_element_widget('view','test1.my_reference'); ok(1,"test ".$idx++)},
sub { $cmu->create_element_widget('edit','test1.my_reference'); ok(1,"test ".$idx++)},
- sub { $root->load(step => "ordered_checklist=A,Z,G") ; $cmu->reload ;; ok(1,"test ".$idx++)} ,
+ sub { $root->load(step => "ordered_checklist=A,Z,G") ; $cmu->reload ;; ok(1,"test load ".$idx++)} ,
sub { $widget = $cmu->create_element_widget('edit','test1.ordered_checklist'); ok(1,"test ".$idx++)},
- sub { $widget->Subwidget('notebook')->raise('order') ;; ok(1,"test ".$idx++)},
- sub { $widget->Subwidget('notebook')->raise('order') ;; ok(1,"test ".$idx++)},
+ sub { $widget->Subwidget('notebook')->raise('order') ;; ok(1,"test notebook raise 1 ".$idx++)},
+ sub { $widget->Subwidget('notebook')->raise('order') ;; ok(1,"test notebook raise 2 ".$idx++)},
sub { $widget->{order_list}->selectionSet(1,1) ;; ok(1,"test ".$idx++)}, # Z
sub { $widget->move_selected_down ;; ok(1,"test ".$idx++)},
- sub { $cmu->save(); ok(1,"test ".$idx++)},
+ # cannot save with pernding errors sub { $cmu->save(); ok(1,"test save 1 ".$idx++)},
sub {
- for ($cmu->children) { $_->destroy if $_->name =~ /dialog/i; } ;
- $root->load($load_fix);; ok(1,"test ".$idx++)},
- sub { $cmu->save(); ok(1,"test ".$idx++)},
+ #for ($cmu->children) { $_->destroy if $_->name =~ /dialog/i; } ;
+ $root->load($load_fix);; ok(1,"test load_fix ".$idx++)},
+ sub { $cmu->save(); ok(1,"test save 2 ".$idx++)},
sub { $cmu->create_element_widget('edit','test1.always_warn');
$cmu -> force_element_display($root->grab('always_warn')) ;
- ; ok(1,"test ".$idx++)},
+ ; ok(1,"test always_warn ".$idx++)},
# warn test, 3 warnings: load, fetch for hlist, fetch for editor
sub { warnings_like { $root->load("always_warn=foo") ; $cmu->reload ;}
- [ qr/always/ , qr/always/, qr/always/] ,"warn test ".$idx++ ;
+ [ qr/always/ , qr/always/, qr/always/] ,"warn test always_warn 2 ".$idx++ ;
},
- sub { $root->load('always_warn~') ; $cmu->reload ;; ok(1,"test ".$idx++)},
+ sub { $root->load('always_warn~') ; $cmu->reload ;; ok(1,"test remove always_warn ".$idx++)},
sub { $cmu->create_element_widget('edit','test1.warn_unless');
$cmu -> force_element_display($root->grab('warn_unless')) ;
- ok(1,"test ".$idx++);
+ ok(1,"test warn_unless ".$idx++);
},
sub { warnings_like { $root->load("warn_unless=bar") ; $cmu->reload ;}
- [ qr/warn_unless/ , qr/warn_unless/, qr/warn_unless/] ,"warn test ".$idx++ ;
+ [ qr/warn_unless/ , qr/warn_unless/, qr/warn_unless/] ,"warn test warn_unless ".$idx++ ;
},
- sub { $root->load('warn_unless=foo2') ; $cmu->reload ;; ok(1,"test ".$idx++)},
+ sub { $root->load('warn_unless=foo2') ; $cmu->reload ;; ok(1,"test fix warn_unless ".$idx++)},
sub { $mw->destroy; }
);
Modified: branches/upstream/libconfig-model-tkui-perl/current/t/config-model-wizard.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libconfig-model-tkui-perl/current/t/config-model-wizard.t?rev=70294&op=diff
==============================================================================
--- branches/upstream/libconfig-model-tkui-perl/current/t/config-model-wizard.t (original)
+++ branches/upstream/libconfig-model-tkui-perl/current/t/config-model-wizard.t Thu Mar 3 11:25:15 2011
@@ -124,7 +124,7 @@
}
}
- $cmw->_start_wizard('master',1) ;
+ $cmw->start_wizard('master',1) ;
ok(1,"wizard done") ;
More information about the Pkg-perl-cvs-commits
mailing list