1BEGIN 2 { 3 $| = 1; 4 $^W = 1; 5 6 eval { require Test; }; 7 if ($@) 8 { 9 $^W=0; 10 print "1..0 # skip no Test module\n"; 11 CORE::exit(0); 12 } 13 Test->import; 14 } 15 16use strict; 17use Tk; 18## 19## Test all widget classes: load module, create, pack, and 20## destory an instance. Check in configure does not return 21## an error so (some) ConfigSpecs errors are uncovered 22## 23 24use vars '@class'; 25use vars '@tk_pod_modules'; 26 27my $tests; 28BEGIN 29 { 30 @class = 31 qw( 32 More 33 PodText 34 PodSearch 35 PodTree 36 Pod 37 ); 38 @tk_pod_modules = qw(Cache FindPods Search_db Search SimpleBridge Styles 39 Util WWWBrowser); 40 41 $tests = 10*@class+@tk_pod_modules; 42 plan test => $tests; 43 44 }; 45 46$ENV{TKPODDEBUG} = 0; 47 48if (!defined $ENV{BATCH}) { 49 $ENV{BATCH} = 1; 50} 51 52my $mw; 53eval {$mw = Tk::MainWindow->new();}; 54if (!Tk::Exists($mw)) 55 { 56 for (1..$tests) 57 { 58 skip("Cannot create MainWindow", 1, 1); 59 } 60 CORE::exit(0); 61 } 62$mw->geometry("+1+1"); # for twm 63 64my $w; 65foreach my $class (@class) 66 { 67 print "# Testing $class\n"; 68 undef($w); 69 70 if ($class =~ m{^Pod(Text|Search|Tree)$}) 71 { 72 my $module = "Tk::Pod::$1"; 73 # Tks autoload does not find it. 74 eval qq{ require $module; }; 75 ok($@, "", "loading $module module"); 76 } 77 else 78 { 79 eval "require Tk::$class;"; 80 ok($@, "", "Error loading Tk::$class"); 81 } 82 83 eval { $w = $mw->$class(); }; 84 ok($@, "", "can't create $class widget"); 85 skip($@, Tk::Exists($w), 1, "$class instance does not exist"); 86 87 if (Tk::Exists($w)) 88 { 89 if ($w->isa('Tk::Wm')) 90 { 91 # KDE-beta4 wm with policies: 92 # 'interactive placement' 93 # okay with geometry and positionfrom 94 # 'manual placement' 95 # geometry and positionfrom do not help 96 eval { $w->positionfrom('user'); }; 97 #eval { $w->geometry('+10+10'); }; 98 ok ($@, "", 'Problem set postitionform to user'); 99 100 eval { $w->Popup; }; 101 ok ($@, "", "Can't Popup a $class widget") 102 } 103 else 104 { 105 ok(1); # dummy for above positionfrom test 106 eval { $w->pack; }; 107 ok ($@, "", "Can't pack a $class widget") 108 } 109 eval { $mw->update; }; 110 ok ($@, "", "Error during 'update' for $class widget"); 111 112 if (!$ENV{BATCH}) { 113 $mw->messageBox(-icon => "info", -message => "Showing '$class'", -type => "Continue"); 114 } 115 116 eval { my @dummy = $w->configure; }; 117 ok ($@, "", "Error: configure list for $class"); 118 eval { $mw->update; }; 119 ok ($@, "", "Error: 'update' after configure for $class widget"); 120 eval { $w->destroy; }; 121 ok($@, "", "can't destroy $class widget"); 122 ok(!Tk::Exists($w), 1, "$class: widget not really destroyed"); 123 } 124 else 125 { 126 # Widget $class couldn't be created: 127 # Popup/pack, update, destroy skipped 128 for (1..5) { skip (1,1,1, "skipped because widget could not be created"); } 129 } 130 } 131 132print "# Require all modules\n"; 133for my $base (@tk_pod_modules) { 134 eval "require Tk::Pod::$base"; 135 if ($@ && $base eq 'Search_db') { 136 ok($@ =~ m{locate Text.*English}, 1, "Could not require Tk::Pod::$base: $@"); 137 } else { 138 ok($@, "", "Could not require Tk::Pod::$base: $@"); 139 } 140} 141 1421; 143__END__ 144