← Back to branch summary

~ubuntu-branches/ubuntu/natty/perl-tk/natty

« back to all changes in this revision

Viewing changes to t/browseentry-subclassing.t

  • Committer: Bazaar Package Importer
  • Author(s): Stephen Zander
  • Date: 2004-03-14 13:54:44 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20040314135444-prc09u2or4dbr3to
Tags: 1:800.025-2
http://bugs.debian.org/237942
Add xlibs-dev to Build-Depends:,
Closes: #237942

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/browseentry-subclassing.t
 
1
#!/usr/bin/perl -w
 
2
# -*- perl -*-
 
3
 
 
4
#
 
5
# $Id: browseentry-subclassing.t,v 1.4 2003/04/21 19:49:27 eserte Exp $
 
6
# Author: Slaven Rezic
 
7
#
 
8
 
 
9
use strict;
 
10
 
 
11
use Tk;
 
12
use Tk::BrowseEntry;
 
13
 
 
14
BEGIN {
 
15
    if (!eval q{
 
16
        use Test;
 
17
        use Tk::NumEntry;
 
18
        1;
 
19
    }) {
 
20
        print "1..0 # skip: no Test module\n";
 
21
        exit;
 
22
    }
 
23
}
 
24
 
 
25
BEGIN { plan tests => 2 }
 
26
 
 
27
if (!defined $ENV{BATCH}) { $ENV{BATCH} = 1 }
 
28
 
 
29
{
 
30
    package Tk::NumBrowseEntry;
 
31
    use base qw(Tk::BrowseEntry);
 
32
    use Tk::NumEntry;
 
33
    Construct Tk::Widget 'NumBrowseEntry';
 
34
    sub LabEntryWidget { "NumEntry" }
 
35
}
 
36
 
 
37
my $mw = my $top = tkinit;
 
38
my $ne = $mw->NumBrowseEntry(-minvalue => -10,
 
39
                             -maxvalue => +10,
 
40
                             -choices => [-6,-3,0,3,6],
 
41
                            )->pack;
 
42
ok($ne->isa('Tk::NumBrowseEntry'));
 
43
 
 
44
{
 
45
    package Tk::MyLabEntry;
 
46
    use base qw(Tk::Frame);
 
47
    Construct Tk::Widget 'MyLabEntry';
 
48
 
 
49
    sub Populate {
 
50
        my($cw, $args) = @_;
 
51
        $cw->SUPER::Populate($args);
 
52
        my $e = $cw->Component(Entry => 'entry');
 
53
        $e->pack('-expand' => 1, '-fill' => 'both');
 
54
        $cw->ConfigSpecs(DEFAULT => [$e]);
 
55
        $cw->Delegates(DEFAULT => $e);
 
56
        $cw->AddScrollbars($e) if (exists $args->{-scrollbars});
 
57
        $cw->ConfigSpecs(-background => ['SELF', 'DESCENDANTS'],
 
58
                         DEFAULT => [$e],);
 
59
    }
 
60
}
 
61
 
 
62
{
 
63
    package Tk::MyLabEntryBrowseEntry;
 
64
    use base qw(Tk::BrowseEntry);
 
65
    Construct Tk::Widget 'MyLabEntryBrowseEntry';
 
66
    sub LabEntryWidget { "MyLabEntry" }
 
67
}
 
68
 
 
69
$mw->optionAdd("*MyLabEntryBrowseEntry*Entry.background", "red");
 
70
my $le = $mw->MyLabEntryBrowseEntry(-label => "My LabEntry:")->pack;
 
71
ok($le->isa('Tk::MyLabEntryBrowseEntry'));
 
72
 
 
73
$top->Button(-text => "Ok",
 
74
             -command => sub {
 
75
                $top->destroy;
 
76
            })->pack;
 
77
$top->after(60*1000, sub { $top->destroy });
 
78
 
 
79
if (!$ENV{BATCH}) {
 
80
    MainLoop;
 
81
}
 
82
 
 
83
__END__