BEGIN { $| = 1; $^W = 1; eval { require Test; }; if ($@) { $^W=0; print "1..0 # skip no Test module\n"; CORE::exit(0); } Test->import; } use FindBin; use lib $FindBin::RealBin; use TkTest qw(display_test); BEGIN { display_test(); } use strict; use Tk; ## ## Test all widget classes: load module, create, pack, and ## destory an instance. Check in configure does not return ## an error so (some) ConfigSpecs errors are uncovered ## use vars '@class'; use vars '@tk_pod_modules'; my $tests; BEGIN { @class = qw( More PodText PodSearch PodTree Pod ); @tk_pod_modules = qw(Cache FindPods Search_db Search SimpleBridge Styles Util WWWBrowser); $tests = 10*@class+@tk_pod_modules; plan test => $tests; }; $ENV{TKPODDEBUG} = 0; if (!defined $ENV{BATCH}) { $ENV{BATCH} = 1; } my $mw; eval {$mw = Tk::MainWindow->new();}; if (!Tk::Exists($mw)) { for (1..$tests) { skip("Cannot create MainWindow", 1, 1); } CORE::exit(0); } my $w; foreach my $class (@class) { print "# Testing $class\n"; undef($w); if ($class =~ m{^Pod(Text|Search|Tree)$}) { my $module = "Tk::Pod::$1"; # Tks autoload does not find it. eval qq{ require $module; }; ok($@, "", "loading $module module"); } else { eval "require Tk::$class;"; ok($@, "", "Error loading Tk::$class"); } eval { $w = $mw->$class(); }; ok($@, "", "can't create $class widget"); skip($@, Tk::Exists($w), 1, "$class instance does not exist"); if (Tk::Exists($w)) { if ($w->isa('Tk::Wm')) { # KDE-beta4 wm with policies: # 'interactive placement' # okay with geometry and positionfrom # 'manual placement' # geometry and positionfrom do not help eval { $w->positionfrom('user'); }; #eval { $w->geometry('+10+10'); }; ok ($@, "", 'Problem set postitionform to user'); eval { $w->Popup; }; ok ($@, "", "Can't Popup a $class widget") } else { ok(1); # dummy for above positionfrom test eval { $w->pack; }; ok ($@, "", "Can't pack a $class widget") } eval { $mw->update; }; ok ($@, "", "Error during 'update' for $class widget"); if (!$ENV{BATCH}) { $mw->messageBox(-icon => "info", -message => "Showing '$class'", -type => "Continue"); } eval { my @dummy = $w->configure; }; ok ($@, "", "Error: configure list for $class"); eval { $mw->update; }; ok ($@, "", "Error: 'update' after configure for $class widget"); eval { $w->destroy; }; ok($@, "", "can't destroy $class widget"); ok(!Tk::Exists($w), 1, "$class: widget not really destroyed"); } else { # Widget $class couldn't be created: # Popup/pack, update, destroy skipped for (1..5) { skip (1,1,1, "skipped because widget could not be created"); } } } print "# Require all modules\n"; for my $base (@tk_pod_modules) { eval "require Tk::Pod::$base"; if ($@ && $base eq 'Search_db') { ok($@ =~ m{locate Text.*English}, 1, "Could not require Tk::Pod::$base: $@"); } else { ok($@, "", "Could not require Tk::Pod::$base: $@"); } } 1; __END__