← Back to branch summary

~ubuntu-branches/ubuntu/maverick/perl-tk/maverick

« back to all changes in this revision

Viewing changes to basic_demo

  • Committer: Bazaar Package Importer
  • Author(s): Colin Tuckley
  • Date: 2010-05-30 09:19:40 UTC
  • mfrom: (1.1.4 upstream)
  • Revision ID: james.westby@ubuntu.com-20100530091940-wbmq9bloo92t9m6x
Tags: 1:804.029-1
http://bugs.debian.org/578814
* New Upstream Release (Closes: #578814).
* Added debian/watch file.

Show diffs side-by-side

added added

removed removed

Lines of Context:
basic_demo
1
 
#!/usr/local/bin/perl
2
 
 
3
 
# use Memory (2440);
4
 
 
5
 
# BEGIN { $ENV{'PERL_DL_NONLAZY'} = 1 }
6
 
 
7
 
use Carp;
8
 
 
9
 
$SIG{__DIE__} = \&Carp::confess;
10
 
 
11
 
 
12
 
use Tk qw(exit);
13
 
# use Tk::Xrm;
14
 
 
15
 
use Tk::widgets qw(Button Label Menu Photo Optionmenu Pixmap Balloon);
16
 
use Tk::widgets qw(Scrollbar Checkbutton Radiobutton Entry
17
 
                   Message BrowseEntry Listbox);
18
 
 
19
 
 
20
 
use Config;
21
 
 
22
 
sub showbinding
23
 
{
24
 
 my $w = shift;
25
 
 foreach ($w->bind())
26
 
  {
27
 
   print "$w $_ = ",$w->bind($_),"\n";
28
 
  }
29
 
}
30
 
 
31
 
sub test_back_trace
32
 
{
33
 
 my ($w,$count) = @_;
34
 
 if ($count)
35
 
  {
36
 
   test_back_trace($w,$count-1);
37
 
  }
38
 
 else
39
 
  {
40
 
   $w->BackTrace("Moan");
41
 
  }
42
 
}
43
 
 
44
 
sub back_trace
45
 
{
46
 
 my @info;
47
 
 my $i = 0;
48
 
 while (@info = caller($i))
49
 
  {
50
 
   print "$i: ",join(' ',@info),"\n";
51
 
   $i++;
52
 
  }
53
 
}
54
 
 
55
 
sub send_test
56
 
{
57
 
 my ($w) = @_;
58
 
 my $result = eval { $w->send('basic_demo',"Hi there") };
59
 
 die "Send failed '$@'" if ($@);
60
 
 print "Send returned '$result'\n";
61
 
}
62
 
 
63
 
sub entry
64
 
{
65
 
 my $top = shift;
66
 
 my $scroll = shift;
67
 
 my $f  = ($scroll) ? $top->Frame() : $top;
68
 
 my $e  = $f->Entry("-relief","ridge",@_);
69
 
 $e->pack("-side"=>"top","-fill"=>"x","-expand"=>"yes");
70
 
 $e->bind("<Any-Enter>", sub { shift->focus() });
71
 
 $e->bind("<Any-FocusIn>",  sub { shift->configure("-relief" => "sunken") });
72
 
 $e->bind("<Any-FocusOut>", sub { shift->configure("-relief" => "ridge" ) });
73
 
 if ($scroll)
74
 
  {
75
 
   my $es = $f->Scrollbar(-orient=>"horizontal","-command",["view",$e], -width => '4m');
76
 
   $e->configure("-scrollcommand",["set",$es]);
77
 
   $es->pack("-side"=>"bottom","-fill"=>"x");
78
 
   $f->pack("-side","top");
79
 
  }
80
 
 return $e;
81
 
}
82
 
 
83
 
sub listbox
84
 
{
85
 
 my $top = shift;
86
 
 my $l = $top->ScrlListbox("-selectmode"=>"extended",-label => 'Listbox',-takefocus => 1);
87
 
 foreach (@_)
88
 
  {
89
 
   $l->insert("end", "item" . $_);
90
 
  }
91
 
 $l->pack("-side","top","-fill","both","-expand","yes");
92
 
 return $l;
93
 
}
94
 
 
95
 
sub button
96
 
{
97
 
 return shift->Button(@_)->pack(-side => 'left');
98
 
}
99
 
 
100
 
sub checkbutton
101
 
{
102
 
 my $top = shift;
103
 
 my $b = $top->Checkbutton(@_);
104
 
 $b->pack(-side => 'left');
105
 
 return $b;
106
 
}
107
 
 
108
 
sub radiobutton
109
 
{
110
 
 my $top = shift;
111
 
 my $b = $top->Radiobutton(@_);
112
 
 $b->pack(-side => 'left');
113
 
 return $b;
114
 
}
115
 
 
116
 
sub label
117
 
{
118
 
 my $top = shift;
119
 
 my $w = $top->Label((@_) ? @_ : ('-text' => "A Label") );
120
 
 $w->pack("-side"=>"bottom","-fill"=>"x");
121
 
 return $w;
122
 
}
123
 
 
124
 
sub message
125
 
{
126
 
 my $top = shift;
127
 
 my $w = $top->Message("-text","Press keys in blue square");
128
 
 configure $w "-foreground","blue";
129
 
 $w->pack("-fill"=>"x");
130
 
 return $w;
131
 
}
132
 
 
133
 
sub keys
134
 
{my $top = shift;
135
 
 my $w = $top->Frame("-width",40, "-height",40,"-relief" => "ridge",
136
 
                     "-background" => "blue", "-border" => 7,
137
 
                     "-takefocus" => 1);
138
 
 $w->bind("<Enter>", "focus");
139
 
 $w->bind("<FocusIn>", NoOp);
140
 
 $w->bind("<Any-Escape>",  sub { shift->toplevel->destroy()});
141
 
 $w->bind("<Any-KeyPress>",
142
 
      sub { my $w = shift;
143
 
            my $e = $w->XEvent;
144
 
            # print "Key(",join(',',@_),")\n";
145
 
            my $s = $e->s();
146
 
            my $K = $e->K();
147
 
            my $A = $e->A();
148
 
            my $k = $e->k();
149
 
            my $c = chr($k);
150
 
            print "press $s$K ($k) '$c' $A\n"
151
 
          });
152
 
 $w->pack();
153
 
 return $w;
154
 
}
155
 
 
156
 
sub menubar
157
 
{my $top  = shift;
158
 
 my $menu = $top->Menubar;
159
 
 my $file = $menu->Menubutton("-text" => "File","-underline" => 0, -bg => 'ivory',
160
 
            -tearoff => 0
161
 
           );
162
 
 $file->command("-label","Save","-command" => sub { print "Save\n" },"-underline" => 0);
163
 
 $file->command("-label","Delete","-command" => sub { print "Delete\n" },"-underline" => 0);
164
 
 $file->separator;
165
 
 $file->command("-label","Quit","-command" => sub { $top->destroy },"-underline" => 0);
166
 
 
167
 
 $file = $menu->Menubutton(-text => "Options", -underline => 0, -font => 'fixed');
168
 
 
169
 
 $file->checkbutton('-label' => 'Strict ~Motif', '-variable' => 'Tk::strictMotif');
170
 
 
171
 
 $file->separator;
172
 
 $file->checkbutton('-label' => 'Oil checked', '-variable' => 'main::oil');
173
 
 $file->checkbutton('-label' => 'Water checked', '-variable' => \$Water);
174
 
 my $om = $file->cget('-menu');
175
 
 $om->bind('<ButtonRelease-1>',[ sub {my ($b,$arg,$orig) = @_; print "Hey ",join(' ',map($_->PathName,$b,$arg),$orig),"\n";}, $om, $om->PathName] );
176
 
 $file->command("-label","Interps", "-underline" => 0,
177
 
   "-command"  =>  sub { print 'Interps(',join(',',$file->interps),")\n" } );
178
 
 
179
 
 $file = $menu->Menubutton(-text => "Exceptions",  -underline => 0);
180
 
 
181
 
 $file->command("-label","Busy","-command"  => \&MakeBusy,"-underline" => 0);
182
 
 $file->command("-label","Exit","-command"  => sub { exit 0 },"-underline" => 0);
183
 
 $file->command("-label","Close","-command" => sub { close Gibberish },"-underline" => 0);
184
 
 $file->command("-label","Moan","-command"  => [ \&test_back_trace, $menu, 3 ],"-underline" => 0);
185
 
 $file->command("-label","Trace","-command" => \&back_trace,"-underline" => 0);
186
 
 $file->command("-label","Wrong","-command" => sub { $top->configure(-gibberish => 'junk') });
187
 
 $file->command("-label","Send","-command"  => [\&send_test,$top] );
188
 
 
189
 
 $menu->separator;
190
 
 
191
 
 $menu->cascade(-label => 'Other', -underline => 1,
192
 
                              -menuitems => [[ Command => '~Busy',
193
 
                               -command => \&MakeBusy]]
194
 
                             );
195
 
 
196
 
 
197
 
 $menu->cascade(-label => 'Help', -underline => 0,
198
 
                              -menuitems => [[ Command => '~Versions', -command => [\&ShowVersion, $top ]]]
199
 
                             );
200
 
 return $menu;
201
 
}
202
 
 
203
 
sub entry_check
204
 
{
205
 
 my ($i);
206
 
 for ($i = 0; $i < $entry->width; $i++)
207
 
  {
208
 
   my $cur = $entry->index('@'.$i);
209
 
   print "$i => $cur\n";
210
 
  }
211
 
}
212
 
 
213
 
sub popup
214
 
{my $w = shift;
215
 
 my $top = $w->MainWindow;
216
 
 $w->{Cursor} = $top->cget("-cursor");
217
 
 $top->configure("-cursor"=>"watch");
218
 
 $w->Popup(-popover => $top, -popanchor => 'c', -overanchor => 'c');
219
 
 $w->update;
220
 
 $w->grab;
221
 
}
222
 
 
223
 
sub popdown
224
 
{
225
 
 my $w = shift;
226
 
 my $top = $w->MainWindow;
227
 
 $top->configure("-cursor"=> $w->{Cursor});
228
 
 $w->grab("release");
229
 
 $w->withdraw;
230
 
}
231
 
 
232
 
 
233
 
sub dialogue
234
 
{my $top = shift;
235
 
 my $t = $top->Toplevel("-class","Dialogue",
236
 
               # -screen => $ENV{'DISPLAY'}
237
 
               );
238
 
 my $l = &label($t,@_);
239
 
 my $b = &button($t,"-text","OK","-command"=>[ \&popdown ,$t]);
240
 
 $t->wm("group",$top);
241
 
 $t->wm("transient",$top);
242
 
 $t->wm("withdraw");
243
 
 $t->wm("minsize",0,0);
244
 
 $l->pack("-side"=> "top", "-expand" => 1, "-fill" => "both");
245
 
 $b->pack("-side"=> "bottom");
246
 
 $t->wm("protocol","WM_DELETE_WINDOW",[\&popdown,$t]);
247
 
 return $t;
248
 
}
249
 
 
250
 
$top = MainWindow->new();
251
 
 
252
 
$top->optionAdd($top->Name.'*Dialog*Background', 'yellow');
253
 
 
254
 
$Tk::_mw_ = $top;
255
 
 
256
 
$top->bind('MainWindow','<Map>',
257
 
            sub {
258
 
                 printf "Mapped %.3g Sec. after bootstrap (u=%.3g s=%.3g)\n",Tk::Time_So_Far,times;
259
 
                 printf("%gK\n",Memory->used/1024) if (defined &Memory::used);
260
 
                 system("/bin/ps","-o",'vsz,osz,rss,pmem,time','-p',$$) if ($^O eq 'solaris');
261
 
                }
262
 
          );
263
 
 
264
 
$camel   = $top->Photo(-format => 'gif', -file => Tk->findINC("Xcamel.gif"));
265
 
 
266
 
 
267
 
print "camel is ",$camel->width," wide\n";
268
 
 
269
 
if (@ARGV)
270
 
 {
271
 
  $top->CmdLine;
272
 
  print "ARGV now ",join(' ',@ARGV),"\n"
273
 
 }
274
 
 
275
 
sub ShowVersion
276
 
{my ($top) = @_;
277
 
 my $d = $top->Dialog(-title => 'Versions',
278
 
                      -popover => $top,
279
 
                      -image => $camel,
280
 
                      -fg  => '#800000',
281
 
                      -text =>
282
 
"Core Tk version : $Tk::version
283
 
Tk patchLevel : $Tk::patchLevel
284
 
library : $Tk::library
285
 
perl/Tk Version : $Tk::VERSION\n",-justify => 'center');
286
 
 $d->Show;
287
 
}
288
 
 
289
 
 
290
 
$fred = "Initial Text";
291
 
$oil  = 1;
292
 
my $bl = $top->Balloon;
293
 
 
294
 
&menubar($top);
295
 
 
296
 
my $bf = $top->Frame->pack(-fill => 'x');
297
 
 
298
 
my $bigfont = "-Adobe-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*";
299
 
 
300
 
my $om = $bf->Optionmenu(-textvariable => \$option, -font => $bigfont,
301
 
                 -options => [qw(one two three four)],
302
 
                 -command => sub { print "Optionmenu set to: ",shift,"\n"}
303
 
                )->pack(-side => 'right');
304
 
 
305
 
my $f = $om->cget('-font');
306
 
my $ps;
307
 
my $sz = $f->PostscriptFontName($ps);
308
 
print "Font is $f $$f $ps ($sz)\n";
309
 
 
310
 
my $be = $bf->BrowseEntry(-variable => \$option )->pack(-side => 'right');
311
 
$be->insert('end',qw(one two three four));
312
 
 
313
 
$QuitPB  = $top->Pixmap('-file' => Tk->findINC("demos/images/QuitPB.xpm"));
314
 
$QuitPBa = $top->Pixmap('-file' => Tk->findINC("demos/images/QuitPBa.xpm"));
315
 
 
316
 
my $q = &button($bf,"-image",$QuitPB,
317
 
                # "-activeimage",$QuitPBa,
318
 
                "-command", sub { $top->destroy });
319
 
$bl->attach($q, -msg => "Exit Application");
320
 
 
321
 
&button($bf,"-text","Push me","-command",
322
 
         [ sub {print "push(",join(',',@_),")\n"}, 1, Two , "iii" ]);
323
 
&checkbutton($bf,"-text","oil","-variable",\$oil,-command => \&MakeBusy);
324
 
&checkbutton($bf,"-text","water","-variable",main::Water);
325
 
&radiobutton($bf,"-text","one","-variable",\$option,"-value"=>"one",-command => \&MakeBusy);
326
 
&radiobutton($bf,"-text","two","-variable",\$option,"-value"=>"two");
327
 
&radiobutton($bf,"-text","three","-variable",\$option,"-value"=>"three");
328
 
&button($bf,"-text","State","-command",
329
 
         sub {print "water=$main::Water oil=$oil option=$option\n"});
330
 
&button($bf,"-text","Chop","-command", sub { chop($fred) });
331
 
 
332
 
$main::Water = 1;
333
 
 
334
 
 
335
 
$entry = &entry($top,0,"-width","30","-textvariable",\$fred);
336
 
&message($top);
337
 
&keys($top);
338
 
&label($top,"-bitmap"=>"info");
339
 
 
340
 
 
341
 
$l = &listbox($top,1..25);
342
 
&button($top,"-bitmap",'@'.Tk->findINC("demos/images/c.icon"),"-command", [ sub { shift->SetList(<*.c>) }, $l ] );
343
 
 
344
 
$pic = $top->Photo("-file" => Tk->findINC("demos/images/earthris.gif"));
345
 
 
346
 
$d = dialogue($top, "-image" => $pic );
347
 
 
348
 
$p = &button($top,"-text" => "popup picture", "-command" => [ \&popup , $d ]);
349
 
$p = &button($top,"-text" => "bisque", "-command" => [ 'bisque', $top ]);
350
 
$p = &button($top,"-text" => "Busy",  "-command" => \&MakeBusy);
351
 
 
352
 
sub MakeBusy
353
 
{
354
 
 $top->Busy(-recurse => 1);
355
 
 warn "Waiting\n";
356
 
 my $done = 0;
357
 
 $top->after(6000, sub { $done = 1; warn "Fired\n" });
358
 
 Tk::DoOneEvent(0) until ($done);
359
 
 $top->Unbusy
360
 
}
361
 
 
362
 
# Check that we have not broken array context again...
363
 
 
364
 
# print join(',',$top->children),"\n";
365
 
 
366
 
$top->Icon(-image => $camel);
367
 
 
368
 
$top->property("set",MYPROP,AREA,32,[1,2,3,4,5]);
369
 
 
370
 
$top->update("idletasks");
371
 
 
372
 
if ($^O ne 'MSWin32')
373
 
 {
374
 
  if (open(Gibberish, '<&STDIN'))
375
 
   {
376
 
    $top->fileevent(Gibberish,'readable',
377
 
        [sub { my ($fh) = @_; print "stdin:",scalar <$fh> },\*Gibberish]);
378
 
   }
379
 
  else
380
 
   {
381
 
    warn "Cannot open /dev/tty:$!";
382
 
   }
383
 
 }
384
 
 
385
 
# print "imageNames(",join(',',$top->imageNames),")\n";
386
 
# print "imageTypes(",join(',',$top->imageTypes),")\n";
387
 
 
388
 
Tk::MainLoop();
389
 
 
390