# -*- cperl -*-
use warnings FATAL => qw(all);
use ExtUtils::testlib;
use Test::More ;
use Test::Warn 0.11;
use Tk;
use Config::Model::TkUI;
use Config::Model ;
use Log::Log4perl qw(:easy) ;
use strict;
use lib 't/lib';
sub test_all {
my ($mw, $delay,$test_ref) = @_ ;
my $test = shift @$test_ref ;
$test->() ;
$mw->after($delay, sub { test_all($mw, $delay,$test_ref) } ) if @$test_ref;
}
my $arg = shift || '';
my ($log,$show) = (0) x 2 ;
my $trace = $arg =~ /t/ ? 1 : 0 ;
$log = 1 if $arg =~ /l/;
$show = 1 if $arg =~ /s|i/;
print "You can play with the widget if you run the test with 's' argument\n";
my $home = $ENV{HOME} || '';
my $log4perl_user_conf_file = "$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/;
ok(1,"Compilation done");
my $model = Config::Model -> new () ;
my $cmu ;
my $inst = $model->instance (
root_class_name => 'Master',
instance_name => 'test1',
root_dir => 'wr_data',
on_message_cb => sub { $cmu->show_message(@_) ;}
);
ok($inst,"created dummy instance") ;
my $root = $inst -> config_root ;
ok($root,"Config root created") ;
my $step = qq!
#"class comment\nbig\nreally big"
std_id#"std_id comment"
std_id:ab X=Bv -
std_id:ab2 -
std_id:bc X=Av -
std_id:"a b" X=Av -
std_id:"a b.c" X=Av -
tree_macro=mXY#"big lever here"
a_string="utf8 smiley \x{263A}"
a_long_string="a very long string with\nembedded return"
hash_a:toto=toto_value
hash_a:toto#"index comment"
hash_a:titi=titi_value
hash_a:"ti ti"="ti ti value"
ordered_hash:z=1
ordered_hash:y=2
ordered_hash:x=3
ordered_hash_of_nodes:N1 X=Av -
ordered_hash_of_nodes:N2 X=Bv -
lista=a,b,c,d
olist:0 X=Av -
olist:1 X=Bv -
my_ref_check_list=toto
my_reference="titi"
my_plain_check_list=AA,AC
warp warp2 aa2="foo bar"
!;
$step .= '! a_very_long_string=~"s/\s*general\s*/ /ig"';
ok( $root->load( step => $step ),
"set up data in tree");
my $load_fix = "a_mandatory_string=foo1 another_mandatory_string=foo2
ordered_hash_of_mandatory:foo=hashfoo
warp a_string=warpfoo a_long_string=longfoo another_string=anotherfoo -
slave_y a_string=slave_y_foo a_long_string=sylongfoo another_string=sy_anotherfoo" ;
#$root->load(step => "tree_macro=XZ") ;
$root->fetch_element('ordered_hash_of_mandatory')->fetch_with_id('foo') ;
# use Tk::ObjScanner; Tk::ObjScanner::scan_object($root) ;
# eval this and skip test in case of failure.
SKIP: {
my $mw = eval {MainWindow-> new ; };
# cannot create Tk window
skip "Cannot create Tk window",1 unless $mw;
$mw->withdraw ;
$cmu = $mw->ConfigModelUI (-root => $root, ) ;
my $delay = 200 ;
my $tktree= $cmu->Subwidget('tree') ;
my $mgr = $cmu->Subwidget('multi_mgr') ;
my $widget ; # ugly global variable. Use with care
my $idx = 1 ;
my @test
= (
sub { $cmu->reload ; ok(1,"forced test: reload") } ,
) ;
push @test,
sub { $cmu->create_element_widget('edit','test1'); ok(1,"test ".$idx++)},
sub { $inst->show_message("Hello World")},
sub { $cmu->force_element_display($root->grab('std_id:dd DX')) ; ok(1,"test ".$idx++)},
sub { $cmu->edit_copy('test1.std_id'); ok(1,"test ".$idx++)},
sub { $cmu->force_element_display($root->grab('hash_a:titi')) ; ok(1,"test ".$idx++)},
sub { $cmu->edit_copy('test1.hash_a.titi'); ok(1,"test ".$idx++)},
sub { $cmu->create_element_widget('view','test1'); ok(1,"test ".$idx++)},
sub { $tktree->open('test1.lista') ; ok(1,"test ".$idx++)},
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 reload ".$idx++)} ,
sub { $cmu->create_element_widget('view','test1.std_id'); ok(1,"test ".$idx++)},
sub { $inst->show_message("Hello again World")},
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 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 load ".$idx++)} ,
sub { $cmu->create_element_widget('view','test1.a_very_long_string'); ok(1,"test diff view ".$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++)},
sub { $cmu->create_element_widget('edit','test1.a_long_string'); ok(1,"test ".$idx++)},
sub { $cmu->create_element_widget('view','test1.int_v'); ok(1,"test ".$idx++)},
sub { $cmu->create_element_widget('edit','test1.int_v'); ok(1,"test ".$idx++)},
sub { $cmu->create_element_widget('view','test1.my_plain_check_list'); ok(1,"test ".$idx++)},
sub { $cmu->create_element_widget('edit','test1.my_plain_check_list'); ok(1,"test ".$idx++)},
sub { $cmu->create_element_widget('view','test1.my_ref_check_list'); ok(1,"test ".$idx++)},
sub { $cmu->create_element_widget('edit','test1.my_ref_check_list'); ok(1,"test ".$idx++)},
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 { my $name = "check_list_with_upstream_default";
my $clwud = $root->grab(step => $name) ;
$cmu->force_element_display($clwud);
ok(1,"show check list with upstream value ".$idx++)} ,
sub { my $name = "check_list_with_upstream_default";
my $clwud = $root->grab(step => $name) ;
my @set = $clwud->get_choice; $clwud->check(@set);
$cmu->force_element_display($clwud);
ok(1,"test check list with upstream data ".$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 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 selectionSet ".$idx++)}, # Z
sub { $widget->move_selected_down ; ok(1,"test move_selected_down ".$idx++)},
# cannot save with pending 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 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 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/ ) x 2 ] ,"warn test always_warn 2 ".$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 warn_unless ".$idx++);
},
sub { warnings_like { $root->load("warn_unless=bar") ; $cmu->reload ;}
[ ( qr/warn_unless/ ) x 2 ] ,"warn test warn_unless ".$idx++ ;
},
sub { $root->load('warn_unless=foo2') ; $cmu->reload ;; ok(1,"test fix warn_unless ".$idx++)},
sub { $cmu ->show_changes ; ok(1,"test show_changes ".$idx++)} ,
sub { $mw->destroy; },
unless $show;
test_all($mw , $delay, \@test) ;
ok(1,"window launched") ;
# $mw->WidgetDump ;
MainLoop ; # Tk's
}
ok(1,"All tests are done");
done_testing;