1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
|
#!/usr/bin/perl -w
# -*- perl -*-
#
# Author: Slaven Rezic
#
# Subclassing test --- use Tk::ROText instead of Tk::More
# as the pager in the PodText widget
use strict;
use Tk;
use Tk::Pod;
BEGIN {
if (!eval q{
use Test::More;
1;
}) {
print "1..0 # skip tests only work with installed Test::More module\n";
CORE::exit(0);
}
if ($] < 5.006) {
print "1..0 # skip subclassing does not work with perl 5.005 and lesser\n";
CORE::exit(0);
}
}
my $mw = eval { MainWindow->new };
if (!$mw) {
print "1..0 # cannot create MainWindow\n";
CORE::exit(0);
}
$mw->geometry("+1+1"); # for twm
plan tests => 1;
{
package Tk::MyMore;
use base qw(Tk::Derived Tk::ROText);
Construct Tk::Widget "MyMore";
sub Populate {
my($w, $args) = @_;
$w->SUPER::Populate($args);
$w->Advertise(text => $w); # XXX hmmmm....
$w->ConfigSpecs(-searchcase => ['PASSIVE'],
-helpcommand => ['PASSIVE'],
);
}
}
{
package Tk::MyPodText;
use base qw(Tk::Pod::Text);
Construct Tk::Widget "MyPodText";
sub More_Module { }
sub More_Widget { "MyMore" }
}
{
package Tk::MyPod;
use base qw(Tk::Pod);
Construct Tk::Widget "MyPod";
sub Pod_Text_Module { }
sub Pod_Text_Widget { "MyPodText" }
}
$mw->withdraw;
my $pod = $mw->MyPod;
$pod->geometry('+1+1'); # for twm
SKIP: {
my $podfile = 'perl.pod';
my $podpath = Tk::Pod::Text::Find($podfile);
skip "Pod for $podfile not installed", 1
if !defined $podpath;
$pod->configure(-file => $podfile);
$mw->update;
pass 'Displayed derived MyPod widget';
}
if (!$ENV{PERL_INTERACTIVE_TEST}) {
$mw->after(1*1000, sub { $mw->destroy });
}
MainLoop;
|
