perl-tk_804.036+git20260828+dfsg/0000775000175000017500000000000015244316526016100 5ustar georgeskgeorgeskperl-tk_804.036+git20260828+dfsg/README.ultrix0000664000175000017500000000153215151075633020305 0ustar georgeskgeorgeskFrom owner-ptk@guest.WPI.EDU Wed Apr 10 00:03:47 1996 Return-Path: From: PVHP@LNS62.LNS.CORNELL.EDU () Date: Tue, 09 Apr 1996 19:00:12 -0500 (EST) Subject: Re: Compiling Tk-b9.01 under Ultrix 4.2 To: farhad@math.ku.dk Cc: ptk@guest.WPI.EDU Message-Id: <01I3CJJC43Q08X5ACP@LNS62.LNS.CORNELL.EDU> X-Vms-To: IN%"farhad@math.ku.dk" X-Vms-Cc: IN%"ptk@guest.WPI.EDU" Content-Type: TEXT/PLAIN; CHARSET=US-ASCII Sender: owner-ptk@guest.WPI.EDU Precedence: bulk I did use MakeMaker on ultrix to build tkperl. I changed the line in Makefile.PL that reads: 'LIBS' => ["$xlib -lX11 -lpt -lsocket -lnsl -lm"], to read: 'LIBS' => ["$xlib -lX11 -lpt -lsocket -lnsl -lm -ldnet"], as we had a newer X11 in /usr/local that needed the DECnet protocol linking. This was with Tk-b11 by the way. Peter Prymmer pvhp@lns62.lns.cornell.edu perl-tk_804.036+git20260828+dfsg/README.os20000664000175000017500000000426715151075633017471 0ustar georgeskgeorgeskThere are 3 different ways to compile Tk under OS/2: for XFree86, for Open32 (this is IBM's porting level above Win32), and for PM. To compile for Open32 and PM you need additional files, available in $CPAN/ports/os2/tk/. To be safe, download all of them, and unzip the files with patches to be ready to apply. If you work with a release of Tk later than 402.001, some of the patches may be already applied, so use your best judgement. !!! You do not need to apply patches to .../os2/* files, they are already applied !!! Just ignore the patches not mentioned below. (You may want to apply one of them in reverse (-R to gnupatch) to get a source for tcl/Tk. Another one need to stay, it corrects bugs.) A lot of problems are unresolved. Please be patient. All the Tk-ish problem in tcl/tk port PLUS unability to do fileevents are Building for PM ~~~~~~~~~~~~~~~ a) Unzip both perltk_os2_pm.zip perltk_os2_common.zip inside the main Tk directory. b) Apply the patches in diff_pTk_for_os2_402 diff_mTk_for_os2_402 with gnupatch -p1 < patch-file-name |& tee 00patch or gnupatch -p1 < patch-file-name c) Do perl Makefile.PM pm make addres perl__ -Mblib basic_demo perl__ -Mblib demos/widget make install d) Do not forget you need to use perl__ to run PM programs instead of just perl! Building for Open32 ~~~~~~~~~~~~~~~~~~~ a) Unzip perltk_os2_common.zip inside the main Tk directory. b) Apply the patches in diff_pTk_for_os2_402 diff_mTk_for_os2_402 with gnupatch -p1 < patch-file-name |& tee 00patch or gnupatch -p1 < patch-file-name c) Do perl Makefile.PM open32 make addres perl__ -Mblib basic_demo perl__ -Mblib demos/widget make install d) Do not forget you need to use perl__ to run PM programs! Building for XFree86 ~~~~~~~~~~~~~~~~~~~~ a) Apply the patches in diff_pTk_for_os2_402 diff_mTk_for_os2_402 with gnupatch -p1 < patch-file-name |& tee 00patch or gnupatch -p1 < patch-file-name b) Do perl Makefile.PM x make perl -Mblib basic_demo perl -Mblib demos/widget make install Authors: ~~~~~~~ PM code for tcl/Tk: Illya Vaes, ivaes@hr.ns.nl Port to Open32, XFree86-OS/2, adaptation of PM code to Perl/Tk: Ilya Zakharevich, ilya@math.ohio-state.edu perl-tk_804.036+git20260828+dfsg/fixfunc0000664000175000017500000000011715151075633017462 0ustar georgeskgeorgeskwhile (<>) { s/__FUNCTION__\s+"\s*(.*?)"/"%s $1",__FUNCTION__/; print; } perl-tk_804.036+git20260828+dfsg/examples/0000775000175000017500000000000015151075633017714 5ustar georgeskgeorgeskperl-tk_804.036+git20260828+dfsg/examples/prop_demo0000775000175000017500000000062415151075633021630 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; sub show_props {my $w = shift; print "Props $w:\n"; foreach ($w->property("list",@_)) { print " $_:",join(',',$w->property("get",$_,@_)),"\n"; } } $top = MainWindow->new(); $top->withdraw; $top->property("set",MYPROP,AREA,32,[1,2,3,4,5]); $top->command([$0,@ARGV]); print "Command:",join(' ',@{$top->command}),"\n"; $top->idletasks; &show_props($top); perl-tk_804.036+git20260828+dfsg/examples/hlfm0000775000175000017500000000042115151075633020565 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; require Tk::Dirlist; require Tk::Menubar; my $mw = MainWindow->new; my $mb = $mw->Menubar(); my $dl = $mw->Scrolled('Dirlist',-directory => '.', -width => 40, -height => 40); $dl->pack(-expand => 1, -fill => 'both'); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/tkperldoc0000775000175000017500000000302415151075633021630 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; use Tk::ROText; use Tk::Font; use Carp; my $mw = MainWindow->new; my $mfont = $mw->Font(family => 'courier', slant => 'r', point => 140, weight => 'medium'); my $bfont = $mfont->Clone(weight => 'bold'); my $t = $mw->Scrolled('ROText',-font => $mfont, -wrap => 'none'); $t->Tag('bold',-font => $bfont); $t->Tag('underline',-underline => 1); $t->pack(-expand => 1, -fill => 'both'); # Netscape/Mosaic like paging $t->bind('',['yview','scroll',1,'page']); $t->bind('',['yview','scroll',-1,'page']); @ARGV = qw(perl) unless (@ARGV); load_doc($t,@ARGV); $mw->focusNext; MainLoop; sub load_doc { my $t = shift; open(PIPE,join(' ','perldoc',@_,'|')) || die "Cannot open pipe:$!"; $t->delete('1.0' => 'end'); $t->insert('end',''); while () { my $line = ""; my @bold = (); my @under = (); while (length($_)) { if (s/^(\n)//) { $t->insert('end',$1); $t->markSet(insert => 'end'); } elsif (s/^_\010(.)//) { $t->insert('insert',$1,['underline']); } elsif (s/^([^\010])(\010\1)+//) { $t->insert('insert',$1,['bold']); } elsif (s/^\+\010o//) { $t->insert('insert','o',['bold']); } elsif (s/^(\010+)//) { # my $offset = length($1); # $t->markSet(insert => "insert - $offset c"); } elsif (s/^(.)//) { $t->insert('insert',$1); } } } close(PIPE); } perl-tk_804.036+git20260828+dfsg/examples/classtree0000664000175000017500000000223715151075633021630 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; use Tk::widgets qw(Tree Menubar); my $mw = MainWindow->new; my $mb = $mw->Menubar; $mb->Menubutton(-text => '~File', -menuitems => [ [Button => 'E~xit', -command => ['destroy' => $mw]], ]); my $cl = $mw->Scrolled('Tree', -width => 60, -height => 40, -separator => '.',-itemtype => 'text'); # do "t/Require.t"; enter_classes($cl,'Tk::','open'); Tk::grid($cl,-sticky => 'nsew'); $mw->gridRowconfigure(0, -weight => 1); $mw->gridColumnconfigure(0, -weight => 1); MainLoop; sub enter_classes { my ($cl,$name,$mode) = @_; no strict 'refs'; if (defined(%{$name}) && $name =~ /^(.*)::$/) { my $path = $1; $path =~ s/::/./g; my ($leaf) = $path =~ /(?:^|\.)([^\.]+)$/; # print join(' ',$name,$path,$leaf),"\n"; $cl->add($path,-text => $leaf); foreach my $child (sort keys %$name) { enter_classes($cl,$name.$child,'close') if $child =~ /::$/; } foreach my $child (sort keys %$name) { if ($child !~ /::$/ && defined &{$name.$child}) { my $cp = $path.'.'.$child; $cl->add($cp,-text => $child) unless $cl->infoExists($cp); } } $cl->Activate($path,$mode); } } perl-tk_804.036+git20260828+dfsg/examples/time0000664000175000017500000000104715151075633020577 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk::Stats 'Start'; use strict; use Tk; use Tk::Stats 'useTk'; use Tk::Button; use Tk::Stats 'useButton'; Tk::Stats::stats('start'); my $mw = MainWindow->new; Tk::Stats::stats('Mw'); withdraw $mw; Tk::Stats::stats('withdraw'); $mw->bind('', \&Tk::Stats::stats ); Tk::Stats::stats('bind'); $mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack; Tk::Stats::stats('Button'); $mw->idletasks; Tk::Stats::stats('idletasks'); deiconify $mw; Tk::Stats::stats('deconify'); $mw->update; Tk::Stats::stats('update'); perl-tk_804.036+git20260828+dfsg/examples/geo_mgr0000775000175000017500000000354715151075633021272 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; { package Packer; use base qw(Tk::Frame); Construct Tk::Widget 'Packer'; sub new {my $class = shift; my $parent = shift; my $obj = $parent->Frame('-class' => Packer); $obj->{Slaves} = []; $obj->{LayoutPending} = 0; bless $obj,$class; } sub Layout { my $m = shift; $m->{LayoutPending} = 0; my $w = 0; my $h = 0; my $x = 0; my $y = 0; my $s; # find size of largest slave foreach $s (@{$m->{Slaves}}) { my $sw = $s->ReqWidth; my $sh = $s->ReqHeight; $w = $sw if ($sw > $w); $h = $sh if ($sh > $h); } # Set size and position of slaves foreach $s (@{$m->{Slaves}}) { $s->MoveResizeWindow($x,$y,$w,$h); $s->MapWindow; $y += $h; } # Now ask for enough space $m->GeometryRequest($w,$y); } sub QueueLayout { my $m = shift; $m->afterIdle(['Layout',$m]) unless ($m->{LayoutPending}++); } sub SlaveGeometryRequest { shift->QueueLayout; } sub LostSlave { my ($m,$s) = @_; @{$m->{Slaves}} = grep($_ != $s,@{$m->{Slaves}}); $m->QueueLayout; } sub Manage { my ($m,$s) = @_; $m->ManageGeometry($s); push(@{$m->{Slaves}},$s); $m->QueueLayout; } } $top = MainWindow->new(); $packer = $top->Packer(); $var = "This can grow"; $one = $top->Label('-text' => 'Label One'); $packer->Manage($one); $packer->Manage($packer->Label('-textvariable' => \$var)); $packer->Manage($packer->Label('-text' => 'A Very Long Label')); $packer->pack; $top->Button('-text' => 'Grow', '-command' => sub { $var .= " more" })->pack; $top->Button('-text' => 'Loose', '-command' => [ 'pack' , $one])->pack; $top->Button('-text' => 'Add', '-command' => [ sub { my $packer = shift; $packer->Manage($packer->Label('-text' => 'Added thing')); }, $packer ])->pack; $top->Button('-text' => 'Quit', '-command' => [ 'destroy' , $top ])->pack; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/popup0000775000175000017500000000300615151075633021004 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w # XXX Does not work. # Error message: Don't know how to handle magic of type \165 # Problem is caused by usage of -variable => $widget use Tk; $top = MainWindow->new; $p = $top->Toplevel; $p->Frame(-width => 50, -height => 30, -bg => 'blue')->pack; $p->protocol('WM_DESTROY_WINDOW' => ['withdraw',$p]); $p->withdraw; $p->overrideredirect(1); $anchor = "c"; $overanchor = "c"; $where = $top; sub Show { $p->Popup(-popanchor => $anchor, -overanchor => $overanchor, -popover => $where); $p->after(1000,['withdraw',$p]); } sub Anchor { my ($top,$label,$var) = @_; my $out = $top->Frame(-label => $label,-relief => 'ridge',-borderwidth => 3); foreach $r ([qw(nw n ne)],[qw(w c e)],[qw(sw s se)]) { my $f = $out->Frame; foreach $a (@$r) { $b = $f->Radiobutton(-text=> $a, -variable => $var, -value => $a, -command => \&Show); $b->pack(-side => 'left'); } $f->pack; } return $out; } my $w = $top->Frame; my $b = $w->Radiobutton(-text => 'Window', -variable => \$where, -value => $top, -command => \&Show); $b->pack(-side=>'left'); $w->Radiobutton(-text => 'Screen', -variable => \$where, -value => undef, -command => \&Show)->pack(-side=>'left'); $w->Radiobutton(-text => 'Cursor', -variable => \$where, -value => 'cursor', -command => \&Show)->pack(-side=>'left'); $w->pack; Anchor($top,"Self",\$anchor)->pack(-side => 'left'); Anchor($top,"Over",\$overanchor)->pack(-side => 'right'); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/bulkedit0000775000175000017500000000704715151075633021455 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; use Tk::LabEntry; use Tk::ErrorDialog; use File::Find; use ExtUtils::Manifest "/mani/"; my $containing = '/perl\b'; my $matching = '\.p[ml]$'; my $mode = 'MANIFEST'; my %filefunc = ( MANIFEST => \&manifiles, Dummy => \&dummyfiles, 'find' => \&findfiles ); sub accept_file { my ($file) = @_; return 0 unless (-w $file); my $accept = $matching && ($file =~ /$matching/); if (!$accept && $containing) { open(FILE,"<$file") || die "Cannot open $file:$!"; my $line = ; close(FILE); $accept = $line && $line =~ m#$containing#; } return $accept; } sub findfiles { my ($dir) = @_; my @files = (); die "Not a directory $dir\n", unless (-d $dir); find(sub { $File::Find::prune = 0; if (-T $_ && !/%$/) { push(@files,"$File::Find::dir/$_") if (accept_file($_)); } elsif (-d $_) { $File::Find::prune = 1 if ($_ eq 'blib'); }},$dir); return @files; } sub dummyfiles { my ($dir) = @_; my @files = (); my $file; foreach $file (map("$dir/$_",'aaaa'...'aaaz')) { push(@files,$file); } return @files; } sub manifiles { my ($dir) = @_; my @files = (); if (-d $dir && -f "$dir/MANIFEST") { my $list = maniread("$dir/MANIFEST"); my $file; foreach $file (map("$dir/$_",keys %$list)) { push(@files,$file) if (accept_file($file)); } } else { die "No $dir/MANIFEST\n"; } return @files; } sub undo { my $file; foreach $file (@_) { if (-f "$file.bak") { rename("$file.bak",$file) || die "Cannot rename $file $file.undone:$!"; } else { warn "No $file.bak\n"; } } } sub apply { my $expr = shift; if (@_) { local $^I = ".bak"; my $sub = eval "sub { $expr }"; die "$@" if ($@); my @undo = (); @ARGV = @_; my $changes = 0; while (<>) { my $line = $_; if (&$sub) { print STDERR "$ARGV:$.:$_"; $changes++ if ($line ne $_); } print; if (eof) { if ($changes) { print STDERR "$changes in $ARGV due to $expr\n"; $changes = 0; } else { print STDERR "No changes in $ARGV due to $expr\n"; push(@undo,$ARGV); } } } undo(@undo) if (@undo); } } sub populate { my ($lb,$dir) = @_; $lb->delete(0,'end'); $lb->Busy; $lb->insert('end',sort &{$filefunc{$mode}}($dir)); $lb->Unbusy; } my $mw = MainWindow->new; my $ft = $mw->Frame->pack(-fill => 'x'); my $expr = ""; my $dir = `pwd`; chomp($dir); my $ed = $mw->LabEntry(-label => 'Directory: ', -textvariable => \$dir, -width => 60)->pack(-fill => 'x'); $ed->bind('', sub { populate(shift,$dir)}); $mw->LabEntry(-label => 'Matching: ', -textvariable => \$matching, -width => 20)->pack(-fill => 'x'); $mw->LabEntry(-label => 'Containing: ', -textvariable => \$containing, -width => 20)->pack(-fill => 'x'); my $lb = $mw->Scrolled('Listbox')->pack(-fill => 'both', -expand => 1); my $ee = $mw->LabEntry(-label => 'Expression: ',-textvariable => \$expr, -width => 60)->pack(-fill => 'x'); $ft->Button(-text => 'Quit', -command => [destroy => $mw])->pack(-side => 'left'); $ft->Button(-text => 'Files', -command => sub { populate($lb,$dir)})->pack(-side => 'left'); $ft->Button(-text => 'Apply', -command => sub { apply($expr,$lb->get(0,'end')) })->pack(-side => 'left'); $ft->Button(-text => 'Undo', -command => sub { undo($lb->get(0,'end')) })->pack(-side => 'left'); $ft->Optionmenu(-options => [ keys %filefunc ], -textvariable => \$mode )->pack(-side => 'right'); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/mitem_test0000664000175000017500000000154215151075633022013 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w require 5.003; use English; use Tk; use Tk::Menu; use Tk::Menubutton; { package NoisyButton; require Tk::Menu::Item; use base 'Tk::Menu::Button'; Construct Tk::Menu 'NoisyButton'; sub PreInit { my ($class,$menu,$minfo) = @_; $minfo->{'-command'} = sub { print "$minfo->{-label} pressed.\n";}; } } # %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% $mw = MainWindow->new; $mw->title('Menuitem demo'); $MB = $mw->Menubutton(-text => 'File'); $M = $MB->Menu(-menuitems => [ [Button => 'Howdy', -command => sub{print "Howdy\n";}], [NoisyButton => 'Noisy'], [Button => 'Quit', -command => sub{exit}], ]); $MB->configure(-menu => $M); $MB->pack(-side => 'top'); MainLoop; exit; # End of Menuitem demo perl-tk_804.036+git20260828+dfsg/examples/fonthook0000664000175000017500000000165315151075633021473 0ustar georgeskgeorgeskuse Tk; use strict; binmode(STDOUT,":utf8"); $Tk::FontRank = \&Ranker; my $mw = MainWindow->new(); my $t = $mw->Scrolled(Text => -font => [fixed => 14])->pack; #$t->insert(end => "Simple ASCII\n"); #$t->update; $t->insert(end => "\x{3A3A}\n"); $t->update; #$t->insert(end => "\x{20AC}0.02 ?\n"); #$t->update; #$t->insert(end => "\x{2323}\x{2322}\n"); MainLoop unless @ARGV; sub Ranker { my ($cost,$ch,$want,$got) = @_; return $cost if $ch == 32; if ($cost == 0) { printf "U+%04x for ",$ch; print $want->family," use ",$got->Xname,"\n"; } elsif ($cost == -1) { printf "U+%04x $ch not in ",$ch; print $got->Xname,"\n"; } else { return (1 << 30) if ($got->size && $want->size != $got->size); if ($got->encoding eq 'iso10646-1') { $cost = ($cost >> 3) || 1; } printf "%08x for U+%04x ",$cost,$ch; print $want->family,' got ',$got->family,'/',$got->encoding,"\n"; } return $cost; } perl-tk_804.036+git20260828+dfsg/examples/spinbox0000775000175000017500000000070315151075633021324 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; use Tk::widgets qw(Button Spinbox); #use Carp (); #$SIG{'__DIE__'} = \&Carp::confess; print "Spinbox:$Tk::Spinbox::VERSION\n"; my $mw = MainWindow->new(); my $sb = $mw->Spinbox(-from => 1, -to => 100)->pack; #use Data::Dumper; #print Dumper([$sb->configure]); $sb = $mw->Spinbox(-values => [qw[one two three four]])->pack; $mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/dump_test0000664000175000017500000000101515151075633021640 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; my $top = MainWindow->new; my $i = $top->Photo(-file => Tk->findINC('icon.gif')); my $t = $top->Text->grid; my $l = $top->Label(-text => 'Frog'); $t->insert('end',"A Label '"); $t->windowCreate('end', -window => $l); $t->insert('end',"'\n"); $t->insert('end',"An Image '"); $t->imageCreate('end', -image => $i); $t->insert('end',"'\n"); print join(',', $t->dump('1.0', 'end')), "\n"; $t->dump(-command => \&dump, '1.0', 'end'); MainLoop; sub dump { print join(',',@_),"\n"; } __END__ perl-tk_804.036+git20260828+dfsg/examples/tkfontsel0000664000175000017500000000306015151075633021647 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; use Tk::Font; use Tk::widgets qw(BrowseEntry Text Spinbox); my %fopt = (-family => 'fixed', -weight => 'medium', -slant => 'roman', -size => 12); my $mw = MainWindow->new(); my $font = $mw->Font(%fopt); my $family = $mw->BrowseEntry(-variable => \$fopt{-family}, -options => [sort $mw->fontFamilies()], -command => [\&SetFont,$font,\%fopt]); my $size = $mw->Spinbox(-width => 3, -textvariable => \$fopt{-size}, -from => 6, -to => 72, -command => [\&SetFont,$font,\%fopt]); my $weight = $mw->Optionmenu(-width => 3, -variable => \$fopt{-weight}, -options => [qw(medium bold)], -command => [\&SetFont,$font,\%fopt]); Tk::grid($mw->Label(-text => 'Family:',-justify => 'right'), $family, $mw->Label(-text => 'Size:',-justify => 'right'), $size, $mw->Label(-text => 'Weight:',-justify => 'right'), $weight, -sticky => 'ew', ); my $text = $mw->Scrolled(Text => -font => $font, -width => 40, -height => 20)->grid(-sticky => 'nsew', -columnspan => 6); my $l = ''; for my $ch (0x20..0x7E,0xa0..0xff) { $l .= chr($ch); if (length($l) == 16) { $text->insert(end => "$l\n"); $l = ''; } } #$text->insert('end',<<"END"); #Example Text - list #\x{20ac}40 Only. #END MainLoop; sub SetFont { my ($font,$fopt) = @_; my @opt = %$fopt; print "@opt\n"; $font->configure(%$fopt); @opt = $font->actual; print "$$font @opt\n"; } perl-tk_804.036+git20260828+dfsg/examples/pixmap_test0000664000175000017500000000116115151075633022173 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; require Tk::Pixmap; my $mw = MainWindow->new; my $file = Tk->findINC("demos/images/QuitPB.xpm"); die "No file" unless defined($file); print "Loading $file\n"; my $QuitPB = $mw->Pixmap('-file' => $file); print "Pixmap is $QuitPB\n"; my $QuitPBa = $mw->Pixmap('-file' => Tk->findINC("demos/images/QuitPBa.xpm")); $mw->Label(-background => 'yellow', -image => $QuitPB)->pack; $mw->Button(-image => $QuitPB, #-activeimage => $QuitPBa, -background => 'green', -activebackground => 'green', -command => [destroy => $mw])->pack; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/tiehandle0000664000175000017500000000042615151075633021576 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; my $mw = MainWindow->new; my $t = $mw->Scrolled('Text'); $t->pack(-expand => 1, -fill => 'both'); tie *TEXT,Tk::Text,$t->Subwidget('text'); print TEXT "Hi there\n"; seek(DATA,0,0); while () { print TEXT; } MainLoop; __DATA__ perl-tk_804.036+git20260828+dfsg/examples/iconwin0000775000175000017500000000110415151075633021304 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; my $top = MainWindow->new(); # $top->CreateGenericHandler(\&handler); # $top->wmTracing(1); my $img = $top->Pixmap('-file' => Tk->findINC("demos/images/QuitPB.xpm")); # $top->iconify; $top->Icon('-image' => $img); $top->iconname("Foo"); $top->title("Mail : Trial"); #$top->after(3000, [ 'Icon', $top, '-background' => 'green' ]); $top->after(3000, [ iconify => $top ]); $top->after(6000, [ deiconify => $top ]); MainLoop(); sub handler { my ($e,$w) = @_; print $e->T,' ',($w->isa('Tk::Widget') ? $w->PathName : $w),"\n"; return 0; } perl-tk_804.036+git20260828+dfsg/examples/xlib_demo0000775000175000017500000000326215151075633021607 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use Tk::Xlib; $top = MainWindow->new(); # Check out some of Xlib stuff $screen = $top->Screen; $sw = $screen->WidthOfScreen; $sh = $screen->HeightOfScreen; $name = $top->Display->DisplayString; print "$name is [$sw,$sh] pixels\n"; sub DoKey {my $w = shift; my $e = $w->XEvent; my $msg = "key : " . $e->A; my $dpy = $w->Display; my $id = $w->WindowId; unless (defined $w->{GC}) { $w->{GC} = GC->new($dpy,$id, Foreground => 5, Font => $dpy->XLoadFont("-*-Courier-Medium-R-Normal--*-240-*-*-*-*-*-*")); } my $gc = $w->{GC}; $dpy->XDrawString($id,$gc,$e->x,$e->y,$msg); } $top->bind("",\&DoKey); $top->bind('',[\&DrawLine,1]); $top->bind('',[\&DrawLine,0]); $top->bind('',[\&DrawLine,1]); $top->bind('',[\&DrawWin,1]); $top->bind('',[\&DrawWin,0]); $top->bind('',[\&DrawWin,1]); # XXX Does not work. sub DrawLine { my $w = shift; my $draw = shift; $w->tmpLine(@{delete $w->{'tmpLine'}},6) if (exists $w->{'tmpLine'}); if ($draw) { my $e = $w->XEvent; my $x = $e->x; my $y1 = 0; my $y2 = $y1 + $w->Height; $w->{'tmpLine'} = [$x,$y1,$x,$y2]; $w->tmpLine(@{$w->{'tmpLine'}},7); } } sub DrawWin { my $w = shift; my $draw = shift; my $l = delete $w->{'tmpWin'}; if ($draw) { my $e = $w->XEvent; unless (defined $l) { $l = $w->Toplevel(-background => 'black'); $l->overrideredirect(1); } $l->MoveResizeWindow($e->X, $w->rooty, 1, $w->Height); $w->{'tmpWin'} = $l; } else { if (defined $l) { $l->destroy; } } } MainLoop(); perl-tk_804.036+git20260828+dfsg/examples/point_test0000664000175000017500000000137215151075633022032 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; my $mw = MainWindow->new; my $pick = $mw->Label(-text => 'Pick', -relief => 'raised')->pack; $mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack; $pick->bind('<1>', \&PickStart); $pick->bind('', [\&PickWin,Ev('X'),Ev('Y')]); MainLoop; sub PickStart { my $w = shift; $w->grabGlobal; $w->configure(-cursor => 'hand2', -relief => 'sunken'); } sub PickWin { my ($w,$x,$y) = @_; $w->grabRelease; $w->configure(-cursor => undef, -relief => 'raised'); my $id = $w->PointToWindow($x,$y); my $depth = 0; while ($id) { my @props = $w->property(list => $id); printf("%s%08X %s\n",' ' x $depth,$id,join(' ',@props)); $depth++; $id = $w->PointToWindow($x,$y,$id); } } perl-tk_804.036+git20260828+dfsg/examples/pipe_test0000775000175000017500000000242415151075633021640 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; require Tk::IO; my $top = MainWindow->new; my $status = "Ready for job ..."; $top->Label(-textvariable => \$status, -anchor => 'w')->pack(-side => 'bottom', -fill => 'x', -anchor => 'w'); my $t = $top->Text("-relief" => "raised", "-bd" => "2", "-setgrid" => "true"); my $s = $top->Scrollbar("-command" => ["yview",$t]); $t->configure("-yscrollcommand" => ["set",$s] ); $fh = Tk::IO->new(-linecommand => [$t,'insert','end'], -childcommand => \&Child); $cmd = 'ls -l'; $e = $top->Entry("-width" => 40,"-textvariable" => \$cmd); $e->pack("-side" => "bottom"); $b = $top->Button("-text" => "Do It", "-command" => [\&DoIt,$fh,$e]); $b->pack("-side" => "bottom"); $b = $top->Button("-text" => "Quit", "-command" => ['destroy',$top]); $b->pack("-side" => "bottom"); $b = $top->Button("-text" => "Kill", "-command" => sub { $fh->killpg(3)} ); $b->pack("-side" => "bottom"); $s->pack("-side"=>"left","-fill" => "y"); $t->pack("-side"=>"left","-expand" => "y", "-fill" => "both"); $t->bind("", sub { $t->focus }); $e->update; $e->focus; Tk::MainLoop; sub Child { my ($code,$fh) = @_; my $cmd = join(' ',$fh->command); $status = "code=$code from $cmd"; } sub DoIt {my $fh = shift; my $e = shift; $fh->exec($e->get); } perl-tk_804.036+git20260828+dfsg/examples/ventry_demo0000664000175000017500000000132015151075633022166 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; my $mw = MainWindow->new; my $text = '0123456789'; my $e = $mw->Entry(-validate => 'all', -textvariable => \$text, -vcmd => \&validate, -invcmd => sub { $mw->bell })->pack; my $l = $mw->Label(-textvariable => \$text)->pack; $mw->Button(-text => 'Set', -command => sub { $text = '0123456789' })->pack; $mw->Button(-text => 'MisSet', -command => sub { $text = 'A012345678' })->pack; $mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack; MainLoop; sub validate { my @args = @_; foreach (@args) { $_ = defined ($_) ? "'$_'" : 'undef'; } print 'validate ',join(',',@args),"\n"; return $_[0] =~ /^\d*$/; } perl-tk_804.036+git20260828+dfsg/examples/canvasps0000775000175000017500000000660215151075633021464 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; use Data::Dumper; warn "Tk$Tk::VERSION\n"; my $ps = page_sizes(); my $psize = $ARGV[0]; unless (defined $psize && exists $ps->{$psize}) { my @sizes = keys %$ps; die "@sizes\n"; } my $x = 0; my $y = 0; my $dx = $ARGV[1] || 297; my $dy = $ARGV[2] || 210; my $mw = MainWindow->new; my $c = $mw->Canvas(-width => 640, -height=>480); $c->create('rectangle',$x,$y,$x+$dx,$y+$dy); $c->create('line',$x,$y,$x+$dx,$y+$dy,-arrow => 'last'); #$c->create('rectangle',0,0,210,297); #$c->create('line',0,0,210,297,-arrow => 'last'); my %opt = ( # -pageheight => $ps->{$psize}[1].'m', # -colormode => $mode ); @opt{'-x','-y','-width','-height'} = $c->bbox('all'); $opt{'-width'} -= $opt{'-x'}; $opt{'-height'} -= $opt{'-y'}; # PS origin is normally SW so avoid deltaX, deltaY $opt{'-pageanchor'} = 'sw'; $opt{-pagey} = 0; $opt{'-rotate'} = ($opt{'-width'} > $opt{'-height'}) ? 1 : 0; if ($opt{-rotate}) { # x is bigger $opt{-pagewidth} = $ps->{$psize}[1].'m'; # and we have to shift it right to allow for rotate :-( $opt{-pagex} = $ps->{$psize}[0].'m'; } else { # y is bigger $opt{-pageheight} = $ps->{$psize}[1].'m'; $opt{-pagex} = 0; } warn Dumper(\%opt); pseudo_code($c,%opt); my $text = $c->postscript(%opt); print $text; pos($text) = 0; while ($text =~ /\n((%%BoundingBox.*|\s*\d[\s\d\.-]*(translate|rotate|scale)))/g) { warn "$1\n"; } my %page_sizes; sub page_sizes { unless (keys %page_sizes) { my @list; my ($w,$h) = (297,420); for my $size (3..5) { $page_sizes{"A$size"} = [$w,$h]; ($h,$w) = ($w,$h/2); } } return \%page_sizes; } sub Points { my $s = shift; return undef unless defined $s; $s *= 72.0/25.4 if ($s =~ s/m$//); return $s; } sub pseudo_code { my ($c,%opt) = @_; # PostScript transforms are: my $canvW = $opt{-width} || $c->width; my $canvH = $opt{-height} || $c->height; my $canvX = $opt{-x} || $c->canvasx(0); my $canvY = $opt{-y} || $c->canvasy(0); my $pageX = exists $opt{-pagex} ? Points($opt{-pagex}) : (72*4.25); my $pageY = exists $opt{-pagey} ? Points($opt{-pagey}) : (72*5.5); my $scale = 1; if ($opt{-pagewidth}) { $scale = Points($opt{-pagewidth})/$canvW; } elsif ($opt{-pageheight}) { $scale = Points($opt{-pageheight})/$canvH; } else { # $scale = (72/25.4)*ScreenMM/ScreenPixels; } my ($deltaX,$deltaY); for ($opt{-pageanchor} || 'c') { if (/w/) { $deltaX = 0 } elsif (/e/){ $deltaX = -$canvW } else { $deltaX = -$canvW/2 } if (/n/) { $deltaY = -$canvH } elsif (/s/){ $deltaY = 0 } else { $deltaY = -$canvH/2 } } warn "px=$pageX py=$pageY scale=$scale dx=$deltaX dy=$deltaY w=$canvW h=$canvH\n"; if (!$opt{-rotate}) { warn '%%'.sprintf("BoundingBox: %d %d %d %d\n", $pageX + $scale*$deltaX, $pageY + $scale*$deltaY, $pageX + $scale*($deltaX + $canvW)+1, $pageY + $scale*($deltaY + $canvH)+1); } else { warn '%%'.sprintf("BoundingBox: %d %d %d %d\n", $pageX - $scale*($deltaY + $canvH)+1, $pageY + $scale*$deltaX, $pageX - $scale*$deltaY+1, $pageY + $scale*($deltaX + $canvW)+1); } warn sprintf "translate(%g,%g)\n",$pageX,$pageY; warn "rotate(90)\n" if $opt{-rotate}; warn sprintf "scale(%g,%g)\n",$scale,$scale; warn sprintf "translate(%g,%g)\n",$deltaX-$canvX,$deltaY; } perl-tk_804.036+git20260828+dfsg/examples/fedemo0000664000175000017500000000146615151075633021105 0ustar georgeskgeorgesk#!/usr/local/bin/new/perl -w use strict; my $FILE_LOG = (@ARGV) ? shift : 'README'; use Tk; my $top = MainWindow->new; my $t = $top->Scrolled('Text')->pack(-expand => 1, -fill => 'both'); my $b = $top->Button(-text => 'Quit', -command => [destroy => $top])->pack; init_check(); MainLoop; sub init_check { # my $cmd = "/usr/bin/tail +0f $FILE_LOG"; my $cmd = "ls -l "; my $open_pid = open (TAIL, "$cmd|") || die "Can't open $cmd: $!"; select (TAIL); $| = 1; select (STDOUT); $| = 1; $top->fileevent(\*TAIL, 'readable', sub { my $line = ; if (defined $line) { $t->insert('end',$line); $top->idletasks; } else { close(TAIL); } }); } perl-tk_804.036+git20260828+dfsg/examples/embed0000664000175000017500000000142715151075633020717 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use IO::File; $ENV{'PERL5LIB'} = join(($^O eq 'MSWin32') ? ';' : ':',@INC); if (@ARGV) { open(STDOUT,">&STDERR"); my $id = shift; print "$id\n"; my $mw = MainWindow->new('-use' => oct($id)); print "id = $id, use=",$mw->cget('-use')," mw id=",$mw->id,"\n"; $mw->Label(-text => "This is process $$ using $id")->pack; $mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack; MainLoop; } else { my $mw = MainWindow->new; my $f = $mw->Frame(-borderwidth => 6, -relief => 'sunken', -container => 1)->pack; my $id = $f->id; $mw->Label(-text => "This is process $$ providing $id")->pack; $mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack; my $fh = IO::File->new("$^X $0 $id|"); MainLoop; $fh->close; } perl-tk_804.036+git20260828+dfsg/examples/after_demo0000775000175000017500000000076515151075633021757 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use strict; require Tk::Label; my $fred = 'Something'; sub toggle { use vars qw($callback); my $w = shift; my $r = $w->configure("-relief"); $w->configure("-relief" => ($r eq "raised") ? "sunken" : "raised"); $fred = reverse($fred); $callback = [\&toggle,$w] unless defined $callback; $w->after(1000,$callback); } my $top = MainWindow->new(); my $l = $top->Label('-textvariable'=> \$fred); $l->pack(); &toggle($l); $top->update(); Tk::MainLoop(); perl-tk_804.036+git20260828+dfsg/examples/hlist_demo0000775000175000017500000000224015151075633021767 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; require Tk::HList; $mw = MainWindow->new; my $hl = $mw->Scrolled('HList', -separator => '.', -width => 25, -drawbranch => 1, -selectmode => 'extended', -columns => 2, -indent => 10); $hl->configure( -command => [ sub { my $hl = shift; my $ent = shift; my $data = $hl->info('data',$ent); foreach ($hl,$ent,$data) { print ref($_) ? "ref $_\n" : "string $_\n"; } print "\n"; }, $hl ] ); $hl->pack(-expand => 1, -fill => 'both'); @list = qw(one two three); my $i = 0; foreach my $item (@list) { $hl->add($item, -itemtype => 'text', -text => $item, -data => {}); my $subitem; foreach $subitem (@list) { $hl->addchild($item, -itemtype => 'text', -text => $subitem, -data => []); } } MainLoop; perl-tk_804.036+git20260828+dfsg/examples/image_test0000775000175000017500000000211515151075633021762 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; $path = Tk->findINC("demos/images"); $top = MainWindow->new(); $bitmap = $top->Bitmap( '-file' => "$path/dir.icon", '-maskfile' => "$path/dir.mask"); $photo = $top->Photo( 'photo'); $pixmap = $top->Pixmap( 'quit' , '-file' => "$path/QuitPB.xpm"); $top->Label('-image'=> $bitmap)->pack; $top->Label('-image'=> $photo )->pack; my $f = $top->Frame->pack; $f->Button('-text' => 'PPM', '-command' => ['configure',$photo, -file => "$path/teapot.ppm" ] )->pack(-side => 'left'); $f->Button('-text' => 'GIF', '-command' => ['configure',$photo, -file => "$path/mickey.gif" ] )->pack(-side => 'left'); $f->Button('-text' => 'XBM', '-command' => ['configure',$photo, -file => "$path/face" ] )->pack(-side => 'left'); $f->Button('-text' => 'XPM', '-command' => ['configure',$photo, -file => "$path/QuitPBa.xpm" ] )->pack(-side => 'left'); $f->Button('-text' => 'Blank', '-command' => ['blank',$photo] )->pack; $top->Button('-image'=> $pixmap, '-command'=>['destroy',$top] )->pack; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/tktail0000775000175000017500000000104115151075633021126 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; use IO::File; sub readfile { my ($t,$fh) = @_; my $size = (stat($fh))[7]; my $len = $size - $t->{'posn'}; if ($len > 0) { my $buffer = ""; my $got = sysread($fh,$buffer,$len); $t->insert('end',$buffer); $t->{posn} += $got; $t->see('end'); } } my $mw = MainWindow->new; my $fh = IO::File->new("<$ARGV[0]"); my $t = $mw->Scrolled('Text',-scrollbars => 'w'); $t->pack(-expand => 1, -fill => 'both'); $t->{posn} = 0; $t->repeat(5000,sub { readfile($t,$fh) } ); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/derived_test0000775000175000017500000000201215151075633022316 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; require Tk::Text; { package Tk::Dwidget; use base qw(Tk::Frame); Construct Tk::Widget 'Dwidget'; sub Populate { my ($cw,$args) = @_; $cw->SUPER::Populate($args); my $w = $cw->Label(-text => 'A Subwidget')->pack; $cw->Advertise('label' => $w); $cw->ConfigSpecs(-foreground => [$w,'foreground','Foreground','yellow'], -background => ['METHOD','background','Background','white'] ); } sub background { # print 'background(',join(',',@_),")\n"; my $w = shift; if (@_) { $w->Subwidget('label')->configure(-background => @_); } return $w->Subwidget('label')->cget('-background'); } } my $mw = MainWindow->new; $mw->optionAdd('*Dwidget.Foreground' => 'green'); my $w = $mw->Dwidget(-bg => 'red')->pack; $w->repeat(5000,sub { my $fg = $w->cget('-fg'); my $bg = $w->cget('-bg'); $w->configure(-fg => $bg, -bg => $fg)}); $w->after(4000,sub {$w->configure(-fg => 'blue')}); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/tcolour0000664000175000017500000000063715151075633021334 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; my $mw = MainWindow->new; my $t = $mw->Text(-background => 'yellow', -width => 30, -height => 10); $t->pack(-expand => 1, -fill => 'both'); $t->insert('1.0','This is Text','Atag'); $t->tagConfigure('Atag',-background => 'green'); $mw->Button(-text => "Change Colour", -command => sub { $t->tagConfigure('Atag',-background => undef) } )->pack; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/unidemo0000664000175000017500000000763115151075633021306 0ustar georgeskgeorgeskuse blib; use Tk; use utf8; my $mw = MainWindow->new; my $t = $mw->Scrolled('Text', -font => [helvetica => 14], #-font => $font )->pack(-fill => both); my $fh; if (@ARGV) { open($fh,$ARGV[0]) || die "Cannot open $ARGV[0]:$!"; } else { $fh = \*DATA; } binmode($fh,":utf8"); while (<$fh>) { $t->insert('end',$_); } MainLoop; __DATA__ Sentences that contain all letters commonly used in a language -------------------------------------------------------------- Markus Kuhn -- 1999-08-27 This file is UTF-8 encoded. German (de) ----------- Falsches 脺ben von Xylophonmusik qu盲lt jeden gr枚脽eren Zwerg (= Wrongful practicing of xylophone music tortures every larger dwarf) Zw枚lf Boxk盲mpfer jagten Eva quer 眉ber den Sylter Deich (= Twelve boxing fighters hunted Eva across the dike of Sylt) Heiz枚lr眉cksto脽abd盲mpfung (= fuel oil recoil absorber) (jqvwxy missing, but all non-ASCII letters in one word) English (en) ------------ The quick brown fox jumps over the lazy dog Spanish (es) ------------ El ping眉ino Wenceslao hizo kil贸metros bajo exhaustiva lluvia y fr铆o, a帽oraba a su querido cachorro. (Contains every letter and every accent, but not every combination of vowel + acute.) French (fr) ----------- Portez ce vieux whisky au juge blond qui fume sur son 卯le int茅rieure, 脿 c么t茅 de l'alc么ve ovo茂de, o霉 les b没ches se consument dans l'芒tre, ce qui lui permet de penser 脿 la c忙nogen猫se de l'锚tre dont il est question dans la cause ambigu毛 entendue 脿 Mo每, dans un capharna眉m qui, pense-t-il, diminue 莽脿 et l脿 la qualit茅 de son 艙uvre. l'卯le exigu毛 O霉 l'ob猫se jury m没r F锚te l'ha茂 volap眉k, 脗ne ex a茅quo au whist, 脭tez ce v艙u d茅莽u. Le c艙ur d茅莽u mais l'芒me plut么t na茂ve, Lou每s r锚va de crapa眉ter en cano毛 au del脿 des 卯les, pr猫s du m盲lstr枚m o霉 br没lent les nov忙. Irish Gaelic (ga) ----------------- D'fhuascail 脥osa, 脷rmhac na h脫ighe Beannaithe, p贸r 脡ava agus 脕dhaimh Icelandic (is) -------------- K忙mi n媒 枚xi h茅r ykist 镁j贸fum n煤 b忙冒i v铆l og 谩drepa S忙v枚r gr茅t 谩冒an 镁v铆 煤lpan var 贸n媒t (some ASCII letters missing) Japanese (jp) ------------- Hiragana: (Iroha) 銇勩倣銇伀銇汇伕銇ㄣ仭銈娿伂銈嬨倰 銈忋亱銈堛仧銈屻仢銇ゃ伃銇倝銈 銇嗐倫銇亰銇忋倓銇俱亼銇点亾銇堛仸 銇傘仌銇嶃倖銈併伩銇椼倯銇层倐銇涖仚 Katakana: 銈ゃ儹銉忋儖銉涖儤銉 銉併儶銉屻儷銉 銉偒銉ㄣ偪銉偨 銉勩儘銉娿儵銉 銈︺儼銉庛偑銈儰銉 銈便儠銈炽偍銉 銈€偟銈儲銉°儫銈 銉便儝銉€偦銈广兂 Hebrew (iw) ----------- ? 讚讙 住拽专谉 砖讟 讘讬诐 诪讗讜讻讝讘 讜诇驻转注 诪爪讗 诇讜 讞讘专讛 讗讬讱 讛拽诇讬讟讛 Polish (pl) ----------- Pchn膮膰 w t臋 艂贸d藕 je偶a lub o艣m skrzy艅 fig Russian (ru) ------------ 袙 褔邪褖邪褏 褞谐邪 卸懈谢 斜褘 褑懈褌褉褍褋? 袛邪, 薪芯 褎邪谢褜褕懈胁褘泄 褝泻蟹械屑锌谢褟褉! (= Would a citrus live in the bushes of south? Yes, but only a fake one!) Thai (th) --------- [--------------------------|------------------------] 喙 喙喔涏箛喔權浮喔權父喔┼涪喙屶釜喔膏笖喔涏福喔班箑喔福喔脆笎喙喔ム复喔ㄠ竸喔膏笓喔勦箞喔 喔佮抚喙堗覆喔氞福喔｀笖喔侧笣喔灌竾喔副喔曕抚喙屶箑喔斷福喔编笀喔夃覆喔 喔堗竾喔澿箞喔侧笩喔编笝喔炧副喔掄笝喔侧抚喔脆笂喔侧竵喔侧福 喔涪喙堗覆喔ム箟喔侧竾喔溹弗喔侧笉喔む箙喙喔傕箞喔權竼喙堗覆喔氞傅喔戉覆喙冟竸喔 喙勦浮喙堗笘喔粪腑喙傕笚喔┼箓喔佮福喔樴箒喔娻箞喔囙笅喔编笖喔付喔斷府喔编笖喔斷箞喔 喔副喔斷腑喔犩副喔⑧箑喔浮喔粪腑喔權竵喔掂脯喔侧腑喔编笂喔屶覆喔副喔 喔涏笍喔脆笟喔编笗喔脆笡喔｀赴喔炧袱喔曕复喔佮笌喔佮赋喔笝喔斷箖喔 喔炧腹喔斷笀喔侧箖喔箟喔堗箠喔班箚 喔堗箣喔侧箚 喔權箞喔侧笩喔编竾喙喔涪 喔 [The copyright for the Thai example is owned by The Computer Association of Thailand under the Royal Patronage of His Majesty the King.] Please let me know if you find others! Special thanks to the people from all over the world who contributed these sentences. perl-tk_804.036+git20260828+dfsg/examples/taint_test0000664000175000017500000000250115151075633022013 0ustar georgeskgeorgesk#!/usr/bin/perl use strict; use Tk; use Tk::Table; use vars qw/ @Testat /; @Testat= (-3,-3,-3,-3,-3,-3); ### ATTENTION an array MUST be assigned something before it can be ### used as a '-variable' in a (Radio/Check/) Button ### NEVER use a list assign like @Testat= (list) ### since this reallocates @Testat my $MW = new MainWindow; my $Table= $MW->Table(-columns => 7, -rows => 4, -fixedrows => 1, -scrollbars => '') ->pack(-pady=> '2c'); # init Table $Table->Create(1,0,'Label',-text => ' Testat OK -> '); $Table->Create(2,0,'Label',-text => ' No Testat -> '); $Table->Create(3,0,'Label',-text => ' - UNDEF - -> '); my $Mode; my $Alab; for (my $c= 1; $c <= 6; $c++) { $Mode = ( $Testat[$c-1] >= 0 ? 'disabled' : 'normal' ); $Alab= ( $c < 6 ? "A$c" : "T" ); $Table->Create(0,$c,'Label',-text => $Alab ); $Table->Create(1,$c,'Radiobutton', -value => 1, -state => $Mode, -variable => \$Testat[$c-1] ); $Table->Create(2,$c,'Radiobutton', -value => 0, -state => $Mode, -variable => \$Testat[$c-1] ); $Table->Create(3,$c,'Radiobutton', -value => -3, -state => $Mode, -variable => \$Testat[$c-1] ); } MainLoop; perl-tk_804.036+git20260828+dfsg/examples/forward_test0000664000175000017500000000073315151075633022345 0ustar georgeskgeorgesk#!/usr/local/bin/nperl -w use strict; use Tk; my $mw = MainWindow->new; $mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack; my $fr = $mw->Frame->pack; $fr->bind('', 'Whatever'); my $lab = $fr->Label(-bg => 'Yellow', -width => 50, -height => 17)->pack; $lab->bind('',[ForwardEvent => Ev(['Parent'])]); sub Tk::Frame::Whatever { my $w = shift; print "Whatever $w ",$w->XEvent->A,"\n"; } $mw->update; $lab->focus; MainLoop; __END__ perl-tk_804.036+git20260828+dfsg/examples/nested_dialog0000775000175000017500000000077515151075633022454 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use Tk::Dialog; my $mw = MainWindow->new; my $d1 = $mw->Dialog(-text => 'First Dialog', -popover => $mw, -overanchor => 's',-popanchor => 'n'); my $d2 = $mw->Dialog(-text => 'Second Dialog', -popover => $d1, -overanchor => 'e',-popanchor => 'w'); $d1->Button(-text => 'Again',-command => [$d2,'Show'])->pack; $mw->Button(-text => 'Popup',-command => [$d1,'Show'])->pack; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/tainted0000775000175000017500000000044215151075633021272 0ustar georgeskgeorgesk#!/usr/local/bin/perl -T use Tk; print join(':',@INC),"\n"; my $command = shift; my $mw = MainWindow->new; my $b = $mw->Button(-text => 'Quit', -command => [destroy => $mw]); $b->pack; my $b = $mw->Button(-text => 'Do It', -command => sub { unlink $command } ); $b->pack; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/clip_bug0000775000175000017500000000361015151075633021426 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w # Show a Tk canvas bug: # when scrolling a canvas, clipping for embedded windows # uses the embedded windows parent, not the canvas. # # Note also that embedded windows do not behave properly # when covered by other canvas items: they stay on top. use strict; use Tk; my $display = new MainWindow; $display->minsize(100, 100); # Quit button my $quit = $display->Button(-text => 'Quit', -command => sub {exit;}); $quit->pack(); # Canvas and all my $canvas_frame = $display->Frame; $canvas_frame->pack(-expand => 'yes', -fill => 'both'); my $canvas = $canvas_frame->Canvas(-relief => 'sunken', -bd => 2); my $vscroll = $canvas_frame->Scrollbar(-command => ['yview', $canvas]); my $hscroll = $canvas_frame->Scrollbar(-command => ['xview', $canvas], -orient => 'horiz'); $canvas->configure(-xscrollcommand => ['set', $hscroll], -yscrollcommand => ['set', $vscroll]); $vscroll->pack(-side => 'right', -fill => 'y'); $hscroll->pack(-side => 'bottom', -fill => 'x'); $canvas->pack(-expand => 'yes', -fill => 'both'); $canvas->configure(-scrollregion => ['0', '0', '10c', '10c']); # Add a few items to scroll add_item($display, $canvas, 1); add_item($display, $canvas, 5); add_item($display, $canvas, 9); MainLoop; # Add a box with a check-button beside # Parameters: # - Reference to window # - Reference to canvas # - Y-pos sub add_item { my ($d, $c, $y) = @_; # This button is owned by the display, not the canvas my $button1 = $c->Checkbutton(); $c->create(('window', '1c', "$y" . 'c'), -anchor => 'w', -window => $button1); # Rectangle my $yp = $y + 2; $c->create(('rectangle', '1.2c', "$y" . 'c', '4c', "$yp" . 'c'), -fill => 'SkyBlue2'); # This button is owned by the canvas, and doesn't go wrong my $button2 = $c->Checkbutton(); $c->create(('window', '4.2c', "$y" . 'c'), -anchor => 'w', -window => $button2); } perl-tk_804.036+git20260828+dfsg/examples/two_main0000775000175000017500000000075515151075633021466 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use Tk::Xrm; use Tk::widgets qw(DirTree Button); # This does not work properly yet use strict qw(subs); use Tk::Pretty; sub top { my $name = shift; my $top = MainWindow->new(); $top->Button('-text'=>"Quit",'-command'=>['destroy',$top])->pack; $top->Button('-textvariable'=>\$name, '-command'=> [ sub { my $name = shift; print "$name\n"},$name])->pack; $top->DirTree()->pack; $top->title($name); } &top("One"); &top("Two"); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/pfm0000775000175000017500000000532215151075633020426 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use POSIX qw(getcwd); use Tk; # use Tk::ErrorDialog; use Tk::DragDrop qw(Sun); require Tk::Tiler; {package Dragable; require Tk::Label; use Tk qw(Ev); use base qw(Tk::Label); Construct Tk::Widget Dragable; sub ClassInit { my ($class,$mw) = @_; $mw->bind($class,'','Bell'); return $class; } sub LabelInfo { my $w = shift; my @config = (); my $option; foreach $option ($w->configure()) { next if (@$option == 2 || !defined $$option[4]); next if (defined $$option[3] && $$option[3] eq $$option[4]); push(@config,$$option[0],$$option[4]); } return (@config); } sub new {my $class = shift; my $parent = shift; my $obj = $parent->Label(@_,-takefocus => 1); # $obj->bind('',['DragDrop',Ev(['LabelInfo'])]); return bless $obj,$class; } } $icon_dir = Tk->findINC("demos/images"); %icons = (); sub Edit { my $w = shift; my $path = shift; if (-T $path) { fork || exec("$ENV{EDITOR} $path"); } } sub choose_icon { my $w = shift; my $name = shift; my $icon = (-d $name) ? "dir" : ($name =~ /\.([^\.]+)$/) ? $1 : "page"; if (!defined $icons{$icon}) { my $file = "$icon_dir/$icon.xpm"; if (-f "$file") { $icons{$icon} = $w->Pixmap($icon,-file=>"$file"); } else { my $file = "$icon_dir/$icon.icon"; my $mask = "$icon_dir/$icon.mask"; $file = "$icon_dir/page.icon" unless (-f $file); $mask = "$icon_dir/page.mask" unless (-f $mask); $icons{$icon} = $w->Bitmap($icon,-file=> $file,-maskfile=>$mask); } if ($icons{$icon}->width != 32) { $icons{$icon} = choose_icon($w,"page"); } } return $icons{$icon}; } sub handle_string {my ($string,$offset,$max) = @_; return $string; } sub do_dir { my $w = shift; my $dir = shift; opendir(DIR,$dir); my @files = readdir(DIR); closedir(DIR); my @windows = (); my $width = 0; my $height = 0; my @win = (); foreach (sort @files) { next if (/^\.*$/); my $path = "$dir/$_"; my $f = $w->Frame(); my $i = $f->Dragable(-image=> choose_icon($w,$path)); $i->DragDrop(-image => $i->cget('-image'),-handlers => [[-type =>'FILE_NAME',[\&handle_string,"$dir/$_"]]]); my $l = $f->Label(-text=> $_); $i->bind('','break'); $i->pack(-side=>'top'); $l->pack(-side=>'bottom',-fill=> 'x'); if (-d $path) { $w->Manage($f); } else { $i->bind('',[\&Edit,$path]); push(@win,$f); } } $w->Manage(@win); } $dir = (@ARGV) ? shift : getcwd(); $top = MainWindow->new(); $t = $top->Tiler(); $t->pack(-side=>'right',-fill=>'both',-expand=>1); $top->AddScrollbars($t); $top->configure('-scrollbars' => 'w'); do_dir($t,$dir); $t->update; $t->focus; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/font_demo0000775000175000017500000000175615151075633021625 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use Tk::X11Font; use Tk::ROText; my $mw = MainWindow->new; my $font = $mw->X11Font(space => 'm', weight => 'medium', point => 140); my $mb = $mw->Frame->pack(-fill => 'x'); my $text = $mw->ROText(-font => $font)->pack(-expand => 1, -fill => 'both'); my $bfont = $font->Clone(weight =>'bold'); my $bold = $text->Tag('bold',-font => $bfont); print "Bold is ",scalar($bfont->Name),"\n ascent=", $bfont->ascent," descent=",$bfont->descent,"\n"; $mb->Optionmenu(-text => 'Font', -underline => 0, -options => [sort $font->Name], -command => [configure => $text, '-font' ]) ->pack(-side => 'right'); $mb->Button(-text => 'Quit', -command => [destroy => $mw ])->pack(-side => 'left');; my $file = __FILE__; open(FILE,"<$file") || die "Cannot open $file:$!"; while () { $text->insert(end => $_); } $text->bind('',[$bold,'add',Ev('index' => 'sel.first'),Ev('index' => 'sel.last')]); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/local_demo0000664000175000017500000000102015151075633021726 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk qw(MainLoop *widget); use Carp; my $mw = MainWindow->new; $mw->Button(-text => 'Button_1', -command => \&callback)->pack; my $w = $mw->Button(-text => 'Button_2', -command => \&callback)->pack; $mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack; $w->after(1000,\&callback); MainLoop; sub callback { print $widget->PathName,"\n"; my $w = $Tk::widget; if (defined $w) { print "Callback for ",$w->cget('-text'),"\n"; } else { carp "No widget!"; } } perl-tk_804.036+git20260828+dfsg/examples/basic_demo0000775000175000017500000002423515151075633021735 0ustar georgeskgeorgesk#!/usr/local/bin/perl # use Memory (2440); # BEGIN { $ENV{'PERL_DL_NONLAZY'} = 1 } use Carp; $SIG{__DIE__} = \&Carp::confess; use Tk qw(exit); # use Tk::Xrm; use Tk::widgets qw(Button Label Menu Photo Optionmenu Pixmap Balloon); use Tk::widgets qw(Scrollbar Checkbutton Radiobutton Entry Message BrowseEntry Listbox); use Config; sub showbinding { my $w = shift; foreach ($w->bind()) { print "$w $_ = ",$w->bind($_),"\n"; } } sub test_back_trace { my ($w,$count) = @_; if ($count) { test_back_trace($w,$count-1); } else { $w->BackTrace("Moan"); } } sub back_trace { my @info; my $i = 0; while (@info = caller($i)) { print "$i: ",join(' ',@info),"\n"; $i++; } } sub send_test { my ($w) = @_; my $result = eval { $w->send('basic_demo',"Hi there") }; die "Send failed '$@'" if ($@); print "Send returned '$result'\n"; } sub entry { my $top = shift; my $scroll = shift; my $f = ($scroll) ? $top->Frame() : $top; my $e = $f->Entry("-relief","ridge",@_); $e->pack("-side"=>"top","-fill"=>"x","-expand"=>"yes"); $e->bind("", sub { shift->focus() }); $e->bind("", sub { shift->configure("-relief" => "sunken") }); $e->bind("", sub { shift->configure("-relief" => "ridge" ) }); if ($scroll) { my $es = $f->Scrollbar(-orient=>"horizontal","-command",["view",$e], -width => '4m'); $e->configure("-scrollcommand",["set",$es]); $es->pack("-side"=>"bottom","-fill"=>"x"); $f->pack("-side","top"); } return $e; } sub listbox { my $top = shift; my $l = $top->ScrlListbox("-selectmode"=>"extended",-label => 'Listbox',-takefocus => 1); foreach (@_) { $l->insert("end", "item" . $_); } $l->pack("-side","top","-fill","both","-expand","yes"); return $l; } sub button { return shift->Button(@_)->pack(-side => 'left'); } sub checkbutton { my $top = shift; my $b = $top->Checkbutton(@_); $b->pack(-side => 'left'); return $b; } sub radiobutton { my $top = shift; my $b = $top->Radiobutton(@_); $b->pack(-side => 'left'); return $b; } sub label { my $top = shift; my $w = $top->Label((@_) ? @_ : ('-text' => "A Label") ); $w->pack("-side"=>"bottom","-fill"=>"x"); return $w; } sub message { my $top = shift; my $w = $top->Message("-text","Press keys in blue square"); configure $w "-foreground","blue"; $w->pack("-fill"=>"x"); return $w; } sub keys {my $top = shift; my $w = $top->Frame("-width",40, "-height",40,"-relief" => "ridge", "-background" => "blue", "-border" => 7, "-takefocus" => 1); $w->bind("", "focus"); $w->bind("", NoOp); $w->bind("", sub { shift->toplevel->destroy()}); $w->bind("", sub { my $w = shift; my $e = $w->XEvent; # print "Key(",join(',',@_),")\n"; my $s = $e->s(); my $K = $e->K(); my $A = $e->A(); my $k = $e->k(); my $c = chr($k); print "press $s$K ($k) '$c' $A\n" }); $w->pack(); return $w; } sub menubar {my $top = shift; my $menu = $top->Menubar; my $file = $menu->Menubutton("-text" => "File","-underline" => 0, -bg => 'ivory', -tearoff => 0 ); $file->command("-label","Save","-command" => sub { print "Save\n" },"-underline" => 0); $file->command("-label","Delete","-command" => sub { print "Delete\n" },"-underline" => 0); $file->separator; $file->command("-label","Quit","-command" => sub { $top->destroy },"-underline" => 0); $file = $menu->Menubutton(-text => "Options", -underline => 0, -font => 'fixed'); $file->checkbutton('-label' => 'Strict ~Motif', '-variable' => 'Tk::strictMotif'); $file->separator; $file->checkbutton('-label' => 'Oil checked', '-variable' => 'main::oil'); $file->checkbutton('-label' => 'Water checked', '-variable' => \$Water); my $om = $file->cget('-menu'); $om->bind('',[ sub {my ($b,$arg,$orig) = @_; print "Hey ",join(' ',map($_->PathName,$b,$arg),$orig),"\n";}, $om, $om->PathName] ); $file->command("-label","Interps", "-underline" => 0, "-command" => sub { print 'Interps(',join(',',$file->interps),")\n" } ); $file = $menu->Menubutton(-text => "Exceptions", -underline => 0); $file->command("-label","Busy","-command" => \&MakeBusy,"-underline" => 0); $file->command("-label","Exit","-command" => sub { exit 0 },"-underline" => 0); $file->command("-label","Close","-command" => sub { close Gibberish },"-underline" => 0); $file->command("-label","Moan","-command" => [ \&test_back_trace, $menu, 3 ],"-underline" => 0); $file->command("-label","Trace","-command" => \&back_trace,"-underline" => 0); $file->command("-label","Wrong","-command" => sub { $top->configure(-gibberish => 'junk') }); $file->command("-label","Send","-command" => [\&send_test,$top] ); $menu->separator; $menu->cascade(-label => 'Other', -underline => 1, -menuitems => [[ Command => '~Busy', -command => \&MakeBusy]] ); $menu->cascade(-label => 'Help', -underline => 0, -menuitems => [[ Command => '~Versions', -command => [\&ShowVersion, $top ]]] ); return $menu; } sub entry_check { my ($i); for ($i = 0; $i < $entry->width; $i++) { my $cur = $entry->index('@'.$i); print "$i => $cur\n"; } } sub popup {my $w = shift; my $top = $w->MainWindow; $w->{Cursor} = $top->cget("-cursor"); $top->configure("-cursor"=>"watch"); $w->Popup(-popover => $top, -popanchor => 'c', -overanchor => 'c'); $w->update; $w->grab; } sub popdown { my $w = shift; my $top = $w->MainWindow; $top->configure("-cursor"=> $w->{Cursor}); $w->grab("release"); $w->withdraw; } sub dialogue {my $top = shift; my $t = $top->Toplevel("-class","Dialogue", # -screen => $ENV{'DISPLAY'} ); my $l = &label($t,@_); my $b = &button($t,"-text","OK","-command"=>[ \&popdown ,$t]); $t->wm("group",$top); $t->wm("transient",$top); $t->wm("withdraw"); $t->wm("minsize",0,0); $l->pack("-side"=> "top", "-expand" => 1, "-fill" => "both"); $b->pack("-side"=> "bottom"); $t->wm("protocol","WM_DELETE_WINDOW",[\&popdown,$t]); return $t; } $top = MainWindow->new(); $top->optionAdd($top->Name.'*Dialog*Background', 'yellow'); $Tk::_mw_ = $top; $top->bind('MainWindow','', sub { printf "Mapped %.3g Sec. after bootstrap (u=%.3g s=%.3g)\n",Tk::Time_So_Far,times; printf("%gK\n",Memory->used/1024) if (defined &Memory::used); system("/bin/ps","-o",'vsz,osz,rss,pmem,time','-p',$$) if ($^O eq 'solaris'); } ); $camel = $top->Photo(-format => 'gif', -file => Tk->findINC("Xcamel.gif")); print "camel is ",$camel->width," wide\n"; if (@ARGV) { $top->CmdLine; print "ARGV now ",join(' ',@ARGV),"\n" } sub ShowVersion {my ($top) = @_; my $d = $top->Dialog(-title => 'Versions', -popover => $top, -image => $camel, -fg => '#800000', -text => "Core Tk version : $Tk::version Tk patchLevel : $Tk::patchLevel library : $Tk::library perl/Tk Version : $Tk::VERSION\n",-justify => 'center'); $d->Show; } $fred = "Initial Text"; $oil = 1; my $bl = $top->Balloon; &menubar($top); my $bf = $top->Frame->pack(-fill => 'x'); my $bigfont = "-Adobe-Helvetica-Medium-R-Normal--*-180-*-*-*-*-*-*"; my $om = $bf->Optionmenu(-textvariable => \$option, -font => $bigfont, -options => [qw(one two three four)], -command => sub { print "Optionmenu set to: ",shift,"\n"} )->pack(-side => 'right'); my $f = $om->cget('-font'); my $ps; my $sz = $f->PostscriptFontName($ps); print "Font is $f $$f $ps ($sz)\n"; my $be = $bf->BrowseEntry(-variable => \$option )->pack(-side => 'right'); $be->insert('end',qw(one two three four)); $QuitPB = $top->Pixmap('-file' => Tk->findINC("demos/images/QuitPB.xpm")); $QuitPBa = $top->Pixmap('-file' => Tk->findINC("demos/images/QuitPBa.xpm")); my $q = &button($bf,"-image",$QuitPB, # "-activeimage",$QuitPBa, "-command", sub { $top->destroy }); $bl->attach($q, -msg => "Exit Application"); &button($bf,"-text","Push me","-command", [ sub {print "push(",join(',',@_),")\n"}, 1, Two , "iii" ]); &checkbutton($bf,"-text","oil","-variable",\$oil,-command => \&MakeBusy); &checkbutton($bf,"-text","water","-variable",main::Water); &radiobutton($bf,"-text","one","-variable",\$option,"-value"=>"one",-command => \&MakeBusy); &radiobutton($bf,"-text","two","-variable",\$option,"-value"=>"two"); &radiobutton($bf,"-text","three","-variable",\$option,"-value"=>"three"); &button($bf,"-text","State","-command", sub {print "water=$main::Water oil=$oil option=$option\n"}); &button($bf,"-text","Chop","-command", sub { chop($fred) }); $main::Water = 1; $entry = &entry($top,0,"-width","30","-textvariable",\$fred); &message($top); &keys($top); &label($top,"-bitmap"=>"info"); $l = &listbox($top,1..25); &button($top,"-bitmap",'@'.Tk->findINC("demos/images/c.icon"),"-command", [ sub { shift->SetList(<*.c>) }, $l ] ); $pic = $top->Photo("-file" => Tk->findINC("demos/images/earthris.gif")); $d = dialogue($top, "-image" => $pic ); $p = &button($top,"-text" => "popup picture", "-command" => [ \&popup , $d ]); $p = &button($top,"-text" => "bisque", "-command" => [ 'bisque', $top ]); $p = &button($top,"-text" => "Busy", "-command" => \&MakeBusy); sub MakeBusy { $top->Busy(-recurse => 1); warn "Waiting\n"; my $done = 0; $top->after(6000, sub { $done = 1; warn "Fired\n" }); Tk::DoOneEvent(0) until ($done); $top->Unbusy } # Check that we have not broken array context again... # print join(',',$top->children),"\n"; $top->Icon(-image => $camel); $top->property("set",MYPROP,AREA,32,[1,2,3,4,5]); $top->update("idletasks"); if ($^O ne 'MSWin32') { if (open(Gibberish, '<&STDIN')) { $top->fileevent(Gibberish,'readable', [sub { my ($fh) = @_; print "stdin:",scalar <$fh> },\*Gibberish]); } else { warn "Cannot open /dev/tty:$!"; } } # print "imageNames(",join(',',$top->imageNames),")\n"; # print "imageTypes(",join(',',$top->imageTypes),")\n"; Tk::MainLoop(); perl-tk_804.036+git20260828+dfsg/examples/chfont0000664000175000017500000000207315151075633021122 0ustar georgeskgeorgesk#!perl -w use strict; use Tk; use Encode qw(decode); my $face = (@ARGV) ? shift : 'fixed'; my @headers = ; my $mw = MainWindow->new; foreach my $text (@headers) { my $str = decode('MIME-Header' => $text); $mw->Label(-text => $str, -font => [$face,14])->pack; } MainLoop; __DATA__ From: =?Big5?B?qfq8dw==?= Subject:=?big5?Q?=A9_=A4b=A5=D8=BF=FD=A7=F3=B7s!!?= Subject: =?Big5?B?o7Ck+S4uLi4uLi4uLi4uLi4uLi4uLg==?= From: =?Big5?B?tW6//bdqtE2k3sC6?= Subject: =?Big5?B?rf6xeqq6uvSvuLVuv/23arRNpN7Aug==?= Subject:=?big5?Q?=A7K=B6O=A5=F4=A5=B4=A4=A4=B4=E4=AA=F8=B3~=B9q=B8=DC?= Subject:=?big5?Q? =A4u=A7@=B2=D6=A4F=A4@=A4=D1=BA=D6=A7Q=B0e=B5=B9=A7A ^0^ =A6A=A6=B8=B7P=C1=C2=BE=E3=B2z=B3o=A5=F7=B8=EA=AE=C6=AA=BA=A4H!!! ?= Subject:=?big5?Q? =A4u=A7@=B2=D6=A4F=A4@=A4=D1=BA=D6=A7Q=B0e=B5=B9=A7A ^0^ =A6A=A6=B8=B7P=C1=C2=BE=E3=B2z=B3o=A5=F7=B8=EA=AE=C6=AA=BA=A4H!!! ?= Subject:=?big5?Q? =A4u=A7@=B2=D6=A4F=A4@=A4=D1=BA=D6=A7Q=B0e=B5=B9=A7A ^0^ =A6A=A6=B8=B7P=C1=C2=BE=E3=B2z=B3o=A5=F7=B8=EA=AE=C6=AA=BA=A4H!!! ?= perl-tk_804.036+git20260828+dfsg/examples/scrolled_demo0000775000175000017500000000205515151075633022457 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use strict; @ARGV = __FILE__ unless (@ARGV); my @data = <>; my $top = MainWindow->new(); # $top->optionAdd('*Scrollbar.width' => '3.5m'); $top->Button(-text => 'Quit', -command => [destroy => $top]) ->pack(-side => 'bottom', -fill => 'x'); my $lb = $top->ScrlListbox(-scrollbars => 'rsw',-label => 'sw'); $lb->configure(-labelRelief => 'raised'); $lb->insert('end',@data); $lb->pack(-side => 'left', -expand => 1, -fill => 'both' ); $lb = $top->ScrlListbox(-scrollbars => 'rnw',-label => 'nw'); $lb->configure(-labelRelief => 'raised'); $lb->insert('end',@data); $lb->pack(-side => 'left', -expand => 1, -fill => 'both' ); $lb = $top->ScrlListbox(-scrollbars => 'rse',-label => 'se'); $lb->configure(-labelRelief => 'raised'); $lb->insert('end',@data); $lb->pack(-side => 'left', -expand => 1, -fill => 'both' ); $lb = $top->ScrlListbox(-scrollbars => 'rne',-label => 'ne'); $lb->configure(-labelRelief => 'raised'); $lb->insert('end',@data); $lb->pack(-side => 'left', -expand => 1, -fill => 'both' ); MainLoop(); perl-tk_804.036+git20260828+dfsg/examples/lentry0000775000175000017500000000125415151075633021161 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; { # This could/should go in Tk/LEntry.pm package Tk::LEntry; require Tk::Entry; use base qw(Tk::Derived Tk::Entry); Construct Tk::Widget 'LEntry'; sub Populate { my ($w,$args) = @_; $w->ConfigSpecs(-maxwidth => ['PASSIVE','maxWidth','MaxWidth',12]); } sub insert { my ($w,@args) = @_; # Do the insert as Entry does it. $w->SUPER::insert(@args); # Now see if that is 'legal' ... my $max = $w->cget('-maxwidth'); if (length($w->get) > $max) { $w->delete($max,'end'); $w->bell; } } } my $mw = MainWindow->new; my $e = $mw->LEntry(-maxwidth => 5, -width => 5); $e->pack; MainLoop; __END__ perl-tk_804.036+git20260828+dfsg/examples/fonts0000664000175000017500000000166615151075633021001 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w # XXX Dumps core!!! use strict; use Tk; use Data::Dumper; use Tk::Font; my $mw = MainWindow->new; my $b = $mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack; print 'Families : ',join(',',$b->fontFamilies),"\n"; my $f = $b->cget('-font'); my @info = $f->actual; print 'Actual : ',Dumper(\@info); $f = $mw->Font(@info); print Dumper($f); @info = $f->metrics; print 'Metrics : ',Dumper(\@info); print 'Ascent : ',$f->metrics('-ascent'),"\n"; @info = $b->fontNames; print 'Names : ',Dumper(\@info); print 'Measure : ',join(',',$f->measure("Hugo")),"\n"; my $name; my $size = $f->PostscriptFontName($name); print "$name @ $size\n"; $b->configure('-font' => $f); print $f->Pattern,"\n"; my @f = $f->configure; print 'FConfigure : ',Dumper(\@f); @f = $f->configure('-family'); print 'FConfigure (arg) : ',Dumper(\@f); @f = $b->configure('-font'); print 'Configure : ',Dumper($f,\@f); # MainLoop; perl-tk_804.036+git20260828+dfsg/examples/oddmenu_demo0000664000175000017500000000103715151075633022277 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; my $mw = MainWindow->new; my $mb = $mw->Menubutton(-text => "Strange Menu")->pack; my $menu = $mb->menu; my $lb = $menu->Scrolled('Listbox')->pack; $menu->configure(-takefocus => 1); $lb->insert('end',grep(-T $_,<*>)); $mw->Message(-text => qq( Example of (ab)use of Menu. Creates a list box as a child of Menu and packs it. Interaction is tricky. should unpost, if menu as a whole has 'focus'. ))->pack; $mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/lbformat_demo0000664000175000017500000000076515151075633022461 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; use Tk::Font; my $mw = MainWindow->new; my $font = $mw->Font(family => 'courier', point => 140, weight => 'bold', slant => 'r'); my $lb = $mw->Scrolled('Listbox', -font => $font)->pack(-expand => 1, -fill => 'both');; $mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack; opendir(DIR,".") || die "Cannot opendir '.':$!"; foreach (sort readdir(DIR)) { my $size = (stat($_))[7]; $lb->insert('end',sprintf("%6d $_",$size)); } MainLoop; perl-tk_804.036+git20260828+dfsg/examples/adj_demo0000775000175000017500000000120115151075633021376 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; require Tk::TextUndo; use Carp; $SIG{__DIE__} = \&Carp::confess; my $mw = MainWindow->new; # Uncomment next line to avoid the warning - this a test of the warning # use Tk::TextUndo; my $t1 = $mw->Scrolled('TextUndo', -wrap => 'none'); my $lb = $mw->Scrolled('Listbox'); $lb->packAdjust(-side => 'left', -fill => 'both', -delay => 1); $lb->bind('',sub { $t1->Load($lb->getSelected) }); $t1->pack(-side => 'right', -fill => 'both', -expand => 1); opendir(DIR,'.'); my $name; foreach $name (readdir(DIR)) { $lb->insert('end',$name) if (-T $name); } closedir(DIR); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/tietext0000775000175000017500000000244515151075633021335 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w # XXX Does not work: # "Can't locate object method "CLEAR" via package "Tk::Text::Contents" at tietext line 63" use Tk; {package Tk::Text::Contents; sub TIEARRAY { print "TIEARRAY(",join(',',@_),")\n"; my ($class,$text) = @_; return bless [$text],$class; } sub FETCH { # print "FETCH(",join(',',@_),")\n"; my ($obj,$key) = @_; my $text = ${$obj}[0]; $key++; return $text->get($key.".0" ,$key.".0+1 line"); } sub STORE { # print "STORE(",join(',',@_),")\n"; my ($obj,$key,$val) = @_; my $text = ${$obj}[0]; $key++; while ($text->compare($key.".0",'>','end')) { $text->insert('end',"\n"); } if ($text->compare($key.".0+1 line",'<','end')) { $text->delete($key. ".0" ,$key.".0+1 line"); } # $val .= "\n" unless ($val =~ /\n$/); chomp($val); $text->insert($key . ".0" ,$val."\n"); print "$key:$val\n"; $text->update; } sub LENGTH { my ($obj) = @_; my $text = ${$obj}[0]; print $text->index("end"),"\n"; my ($line,$col) = split(/\./,$text->index("end")); $line -= 3; return $line; } } $top = MainWindow->new; $text = $top->Text; $text->pack; tie @lines,Tk::Text::Contents,$text; @lines = <>; my $line; foreach $line (@lines) { # print "Got $_"; # $line = "New:" . $line; s/^/Added:/; } MainLoop; perl-tk_804.036+git20260828+dfsg/examples/tie_basic0000775000175000017500000002263015151075633021567 0ustar georgeskgeorgesk#!/usr/local/bin/perl # XXX Seems not to work, exits without an error message # use Memory (2440); # BEGIN { $ENV{'PERL_DL_NONLAZY'} = 1 } use Carp; $SIG{__DIE__} = sub { print "die ",shift,"\n" }; use Tk qw(exit); # use Tk::Xrm; use Tk::widgets qw(Button Label Menu Photo Optionmenu Pixmap); use Tk::widgets qw(ErrorDialog Checkbutton Radiobutton Entry Message Listbox); use Config; sub showbinding { my $w = shift; foreach ($w->bind()) { print "$w $_ = ",$w->bind($_),"\n"; } } sub test_back_trace { my ($w,$count) = @_; if ($count) { test_back_trace($w,$count-1); } else { $w->BackTrace("Moan"); } } sub back_trace { my @info; my $i = 0; while (@info = caller($i)) { print "$i: ",join(' ',@info),"\n"; $i++; } } sub send_test { my ($w) = @_; my $result = eval { $w->send('basic_demo',"Hi there") }; die "Send failed '$@'" if ($@); print "Send returned '$result'\n"; } sub entry { my $top = shift; my $scroll = shift; my $f = ($scroll) ? $top->Frame() : $top; my $e = $f->Entry("-relief","ridge",@_); $e->pack("-side"=>"top","-fill"=>"x","-expand"=>"yes"); $e->bind("", sub { shift->focus() }); $e->bind("", sub { shift->configure("-relief" => "sunken") }); $e->bind("", sub { shift->configure("-relief" => "ridge" ) }); if ($scroll) { my $es = $f->Scrollbar("-orient"=>"horizontal","-command",["view",$e]); $e->configure("-scrollcommand",["set",$es]); $es->pack("-side"=>"bottom","-fill"=>"x"); $f->pack("-side","top"); } return $e; } sub listbox { my $top = shift; my $l = $top->ScrlListbox("-selectmode"=>"extended",-label => 'Listbox'); foreach (@_) { $l->insert("end", "item" . $_); } $l->pack("-side","top","-fill","both","-expand","yes"); return $l; } sub button { return shift->Button(@_)->pack(-side => 'left'); } sub checkbutton { my $top = shift; my $b = $top->Checkbutton(@_); $b->pack(-side => 'left'); return $b; } sub radiobutton { my $top = shift; my $b = $top->Radiobutton(@_); $b->pack(-side => 'left'); return $b; } sub label { my $top = shift; my $w = $top->Label((@_) ? @_ : ('-text' => "A Label") ); $w->pack("-side"=>"bottom","-fill"=>"x"); return $w; } sub message { my $top = shift; my $w = $top->Message("-text","Press keys in blue square"); configure $w "-foreground","blue"; $w->pack("-fill"=>"x"); return $w; } sub keys {my $top = shift; my $w = $top->Frame("-width",40, "-height",40,"-relief" => "ridge", "-background" => "blue", "-border" => 7, "-takefocus" => 1); $w->bind("", "focus"); $w->bind("", NoOp); $w->bind("", sub { shift->toplevel->destroy()}); $w->bind("", sub { my $w = shift; my $e = $w->XEvent; # print "Key(",join(',',@_),")\n"; my $K = $e->K(); my $A = $e->A(); print "press $K $A\n" }); $w->pack(); return $w; } sub menubar {my $top = shift; require Tk::Menubar; my $menu = $top->Menubar; my $file = $menu->Menubutton("-text" => "File","-underline" => 0, -bg => 'ivory', -tearoff => 0 ); $file->command("-label","Save","-command" => sub { print "Save\n" },"-underline" => 0); $file->command("-label","Delete","-command" => sub { print "Delete\n" },"-underline" => 0); $file->separator; $file->command("-label","Quit","-command" => sub { $top->destroy },"-underline" => 0); $file->pack("-side" => "left"); $file = $menu->Menubutton(-text => "Options", -underline => 0, -font => 'fixed'); $file->checkbutton('-label' => 'Strict ~Motif', '-variable' => 'Tk::strictMotif'); $file->separator; $file->checkbutton('-label' => 'Oil checked', '-variable' => 'main::oil'); $file->checkbutton('-label' => 'Water checked', '-variable' => \$Water); $file->cget('-menu')->bind('',sub {print "Hey\n";}); $file->command("-label","Interps", "-underline" => 0, "-command" => sub { print 'Interps(',join(',',$file->interps),")\n" } ); $file->pack("-side" => "left"); $file = $menu->Menubutton(-text => "Exceptions", -underline => 0); $file->command("-label","Exit","-command" => sub { exit 0 },"-underline" => 0); $file->command("-label","Close","-command" => sub { close Gibberish },"-underline" => 0); $file->command("-label","Moan","-command" => [ \&test_back_trace, $file, 3 ],"-underline" => 0); $file->command("-label","Trace","-command" => \&back_trace,"-underline" => 0); $file->command("-label","Send","-command" => [\&send_test,$top] ); $file->pack("-side" => "left"); my $help = $menu->Menubutton(-text => 'Help', -underline => 0, -menuitems => [[ Command => '~Versions', -command => [\&ShowVersion, $top ]]] ); $help->pack(-side => 'right'); return $menu; } sub entry_check { my ($i); for ($i = 0; $i < $entry->width; $i++) { my $cur = $entry->index('@'.$i); print "$i => $cur\n"; } } sub popup {my $w = shift; my $top = $w->MainWindow; $w->{Cursor} = $top->cget("-cursor"); $top->configure("-cursor"=>"watch"); print "Event ",$Tk::event,"\n"; if (defined $e) { $w->wm("geometry",$e->X . "x" . $e->Y); } $w->deiconify; $w->update; $w->grab; } sub popdown { my $w = shift; my $top = $w->MainWindow; $top->configure("-cursor"=> $w->{Cursor}); $w->grab("release"); $w->withdraw; } sub dialogue {my $top = shift; my $t = $top->Toplevel("-class","Dialogue",-screen => $ENV{'DISPLAY'}); my $l = &label($t,@_); my $b = &button($t,"-text","OK","-command"=>[ \&popdown ,$t]); $t->wm("group",$top); $t->wm("transient",$top); $t->wm("withdraw"); $t->wm("minsize",0,0); $l->pack("-side"=> "top", "-expand" => 1, "-fill" => "both"); $b->pack("-side"=> "bottom"); $t->wm("protocol","WM_DELETE_WINDOW",[\&popdown,$t]); return $t; } $top = MainWindow->new(); $con = $top->Scrolled('Text', -height => 6)->pack(-side => 'bottom', -fill => 'x'); tie *STDOUT,Tk::Text,$con->Subwidget('text'); tie *STDERR,Tk::Text,$con->Subwidget('text'); $top->optionAdd($top->Name.'*Dialog*Background', 'yellow'); $Tk::_mw_ = $top; $top->bind('MainWindow','', sub { printf "Mapped %.3g Sec. after bootstrap (u=%.3g s=%.3g)\n",Tk::Time_So_Far,times; printf("%gK\n",Memory->used/1024) if (defined &Memory::used); system("/bin/ps","-o",'vsz,osz,rss,pmem,time','-p',$$) if ($^O eq 'solaris'); } ); $camel = $top->Photo('-file' => Tk->findINC("Xcamel.gif")); # print "camel is ",$camel->width," wide\n"; if (@ARGV) { $top->CmdLine; print "ARGV now ",join(' ',@ARGV),"\n" } sub ShowVersion {my ($top) = @_; my $d = $top->Dialog(-title => 'Versions', -popover => $top, -image => $camel, -text => "Core Tk version : $Tk::version Tk patchLevel : $Tk::patchLevel library : $Tk::library perl/Tk Version : $Tk::VERSION\n",-justify => 'center'); $d->Show; } $fred = "Initial Text"; $oil = 1; my $bl = $top->Balloon; &menubar($top); my $bf = $top->Frame->pack(-fill => 'x'); $bf->Optionmenu(-textvariable => \$option, -options => [qw(one two three four)], -command => sub { print "Optionmenu set to: ",shift,"\n"} )->pack(-side => 'right'); my $be = $bf->BrowseEntry(-variable => \$option )->pack(-side => 'right'); $be->insert('end',qw(one two three four)); $QuitPB = $top->Pixmap('-file' => Tk->findINC("demos/images/QuitPB.xpm")); $QuitPBa = $top->Pixmap('-file' => Tk->findINC("demos/images/QuitPBa.xpm")); my $q = &button($bf,"-image",$QuitPB,"-activeimage",$QuitPBa, "-command", sub { $top->destroy }); $bl->attach($q, -msg => "Exit Application"); &button($bf,"-text","Push me","-command", [ sub {print "push(",join(',',@_),")\n"}, 1, Two , "iii" ]); &checkbutton($bf,"-text","oil","-variable",\$oil); &checkbutton($bf,"-text","water","-variable",main::Water); &radiobutton($bf,"-text","one","-variable",\$option,"-value"=>"one"); &radiobutton($bf,"-text","two","-variable",\$option,"-value"=>"two"); &radiobutton($bf,"-text","three","-variable",\$option,"-value"=>"three"); &button($bf,"-text","State","-command", sub {print "water=$main::Water oil=$oil option=$option\n"}); &button($bf,"-text","Chop","-command", sub { chop($fred) }); $main::Water = 1; $entry = &entry($top,0,"-width","30","-textvariable",\$fred); &message($top); &keys($top); &label($top,"-bitmap"=>"info"); $l = &listbox($top,1..25); &button($top,"-bitmap",'@'.Tk->findINC("demos/images/c.icon"),"-command", [ sub { shift->SetList(<*.c>) }, $l ] ); $pic = $top->Photo("-file" => Tk->findINC("demos/images/earthris.gif")); $d = dialogue($top, "-image" => $pic ); $p = &button($top,"-text" => "popup picture", "-command" => [ \&popup , $d ]); $p = &button($top,"-text" => "bisque", "-command" => [ 'bisque', $top ]); $p = &button($top,"-text" => "Busy", "-command" => sub { $top->Busy; $top->after(5000); $top->Unbusy }); # Check that we have not broken array context again... # print join(',',$top->children),"\n"; $top->Icon(-image => $camel); $top->property("set",MYPROP,AREA,32,[1,2,3,4,5]); $top->update("idletasks"); if (open(Gibberish,"fileevent(Gibberish,'readable',[sub { my ($fh) = @_; print "stdin:",scalar <$fh> },\*Gibberish]); } else { warn "Cannot open /dev/tty:$!"; } # print "imageNames(",join(',',$top->imageNames),")\n"; # print "imageTypes(",join(',',$top->imageTypes),")\n"; Tk::MainLoop(); perl-tk_804.036+git20260828+dfsg/examples/labelpack0000775000175000017500000000053415151075633021562 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; require Tk::LabEntry; my $mw = MainWindow->new; my $canvas_total = 'Entry Text'; my $le_t_text = 'The Label'; $le = $mw->LabEntry(-textvariable =>\$canvas_total, -labelVariable => \$le_t_text, -labelPack => [-side => 'left']); $le->pack(-expand => 1, -fill => 'x'); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/animate0000664000175000017500000000120715151075633021255 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; my $mw = MainWindow->new; use strict; use Tk::widgets qw(Photo Animation); my $file = (@ARGV) ? shift : Tk->findINC('anim.gif'); my $img = $mw->Animation('-format' => 'gif',-file => $file); my $lab = $mw->Label(-image => $img); my $start = $mw->Button(-text => 'Start', -command => ['start_animation' => $img]); my $stop = $mw->Button(-text => 'Stop', -command => ['stop_animation' => $img]); my $quit = $mw->Button(-text => 'Quit', -command => [destroy => $mw]); Tk::grid($lab,'-','-',-sticky => 'nsew'); Tk::grid($start, $stop, $quit,-sticky => 'ew'); $mw->gridRowconfigure(0,-weight => 1); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/canvastile0000664000175000017500000000101615151075633021766 0ustar georgeskgeorgesk#!/usr/local/bin/perl use Tk; use Tk::widgets qw(Canvas); my $mw = MainWindow->new(); my $tile = $mw->Photo(-file =>Tk->findINC('Camel.xpm')); my $c = $mw->Canvas( -background => 'yellow', -width => 300, -height => 250, -relief => 'raised', -borderwidth => 3, # -tile => $tile, -offset => [-30,-30], )->pack; $c->createImage(30,30, -image => $tile); $c->update; $c->after(1000); $c->configure(-tile => $tile); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/linux-progbar-toy0000664000175000017500000000157615151075633023252 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use Tk::widgets qw(ProgressBar); my $mw = MainWindow->new; my $meminfo = "/proc/meminfo"; if (!-e $meminfo) { $meminfo = "/compat/linux/proc/meminfo"; if (!-e $meminfo) { die "Sorry, no /proc/meminfo or /compat/linux/proc/meminfo available"; } } my $info = `cat $meminfo`; my ($max) = $info =~ /MemTotal:\s*(\d+)/; print "Max = $max\n"; my %values; foreach my $name (qw(MemFree MemShared Buffers Cached)) { my $lab = $mw->Label(-text => $name); my $pg = $mw->ProgressBar(-fg => '#404080', '-length' => '3c', -width => '3m', -to => $max, -variable => \$values{$name}); Tk::grid($lab,$pg); } newValue(); $mw->repeat(5000,\&newValue); MainLoop; sub newValue { my $info = `cat $meminfo`; foreach my $name (keys %values) { ($values{$name}) = $info =~ /$name:\s*(\d+)/; print "$name ",$values{$name},"\n"; } } perl-tk_804.036+git20260828+dfsg/examples/tent0000775000175000017500000000050515151075633020614 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; use Tk::widgets qw(Button); #use Carp (); #$SIG{'__DIE__'} = \&Carp::confess; my $mw = MainWindow->new(); my $text = "This is 2 worth of text"; $mw->Entry(-textvariable => \$text, -width => 20)->pack; $mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/autoraise0000775000175000017500000000222615151075633021640 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w # This is the old method, nowadays one would # use # $mw->attributes(-topmost => 1) # instead. use Tk; $mw = MainWindow->new; $hello = $mw->Button(-text => 'Hello, world', -command => sub {print STDOUT "Hello, world\n"; mkTopLevel($mw);}); $hello->pack; $bye = $mw->Button(-text => 'Goodbye', -command => sub {print STDOUT "Goodbye, cruel world!\n"; exit;}); $bye->pack; MainLoop; sub unobscure { my $w = shift; my $s = shift; return unless $w == $w->toplevel; my $g = $w->grab('current'); # sorry Tk-b6 form ... would be Tk->grab('current'); return unless defined($g); print "$w $s\n"; if ($w == $g) { $g->raise($g->MainWindow) if ($s !~ /Unobscured$/); } else { $g->raise if ($s !~ /FullyObscured$/); } } sub mkTopLevel { my $main = shift; my $topLevelWin = $main->Toplevel(); # raise if obscured $topLevelWin->bind('all',"", [\&unobscure, Ev('s')]); my $cancel = $topLevelWin->Button( "-text" => "Bye", "-command" => sub { print "bye\n"; $topLevelWin->destroy; } ); $cancel->pack(-side => 'top'); grab $topLevelWin; } 1; perl-tk_804.036+git20260828+dfsg/examples/cbtest0000775000175000017500000000066015151075633021130 0ustar georgeskgeorgesk#!/usr/local/bin/perl use Tk; use Tk::Pretty; sub lots { &Tk::Pretty::PrintArgs; return (0..10); } sub one { &Tk::Pretty::PrintArgs; return "Something"; } print Pretty(Tk::Callback->new(\&lots)->Call('a'..'d')),"\n"; print Pretty(Tk::Callback->new([\&lots,'A'..'F'])->Call('a'..'d')),"\n"; print Pretty(Tk::Callback->new(\&one)->Call('a'..'d')),"\n"; print Pretty(Tk::Callback->new([\&one,'A'..'F'])->Call('a'..'d')),"\n"; perl-tk_804.036+git20260828+dfsg/examples/sockets0000664000175000017500000000357415151075633021323 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w # XXX Does not work: # "Bad arg length for Socket::pack_sockaddr_in, length is 9, should be 4" use IO::Socket; use Tk::IO; use Tk; my $mw = MainWindow->new; my $server = IO::Socket::INET->new(Listen => 5, LocalAddr => 'localhost', Proto => 'tcp'); Tk::IO::make_nonblock($server,$smode,$snew); $mw->fileevent($server, 'readable', [\&server_acceptable,$server,'r']); # $mw->fileevent($server, 'writeable', [\&server_acceptable,$server,'w']); my $port = $server->sockport; print "Port=$port\n"; my $client = IO::Socket::INET->new; $client->socket(AF_INET, SOCK_STREAM, (getprotobyname('tcp'))[2]) || warn "Cannot socket:$!"; Tk::IO::make_nonblock($client,$cmode,$cnew); $client->connect($port,'localhost') || warn "Cannot connect:$! ".($!+0); my $h = IO::Socket::INET->new; while (1) { last if accept($h,$server); warn "accept $! ".($!+0); $client->sockport; die "accept $! ".($!+0) unless ($! == 11); sleep(1); } # my $h = $server->accept or warn "accept $! ".($!+0); print 'h peer=',$h->peerport,' sock=',$h->sockport,"\n"; print 'c peer=',$client->peerport,' sock=',$client->sockport,"\n"; exit; $mw->fileevent( $client, 'writeable', [\&client_writeable,$client]); $mw->fileevent( $client, 'readable', [\&client_readable, $client]); MainLoop; sub client_readable { print 'cr(',join(',',@_),")\n"; my $data = <$client>; print "cr:$data"; $client->close; } sub client_writable { print 'cw(',join(',',@_),")\n"; my $client = shift; print $client "Hello\n"; } sub server_acceptable { print 'sa(',join(',',@_),")\n"; my $server = shift; my $h = $server->accept; $mw->fileevent($h, 'readable', [\&server_readable,$h]); print "New socket ",$h->fileno,"\n"; } sub server_readable { print 'sr(',join(',',@_),")\n"; my $h = shift; my $data = <$client>; if (defined $data) { print "cr:$data"; print $h "ACK:$data"; } else { $h->close; } } perl-tk_804.036+git20260828+dfsg/examples/bindtest0000775000175000017500000000147115151075633021461 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use Tk::Menubar; my $mw = MainWindow->new; my $mb = $mw->Menubar; $mb->Menubutton(-text => '~File', -font => 'fixed', -menuitems => [ [Button => '~Quit', -font => 'fixed', -command => [$mw,'destroy']] ]); my $f = $mw->Frame(-width => 100, -height => 100, -borderwidth => 2, -takefocus => 1, #-highlightborderwidth=> 3, # XXX Does not work (anymore?) #-highlightforeground => 'black' # XXX Does not work (anymore?) )->pack; my $qual; foreach $qual ('',qw(Meta- Shift- Control- Alt-)) { $f->bind("<${qual}KeyPress>",[ \&showit, "${qual}KeyPress" ]); } $mw->update; $f->focus; MainLoop; sub showit { my ($w,$kind) = @_; my $ev = $w->XEvent; print "$kind ",$ev->K," ",$ev->A,"\n"; } perl-tk_804.036+git20260828+dfsg/examples/scale_test0000775000175000017500000000065315151075633021774 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; $top = MainWindow->new(); $top->title("scale tests"); $f = $top->Frame(-relief => 'ridge', -borderwidth => 3); $s = $top->Scale("-orient"=>"vertical", "-length" => 280, "-from" => 0, "-to" => 250, "-tickinterval" => 50, "-command" => sub { $f->configure('-width'=> $s->get) } ); $s->pack(-side =>'left', -fill => 'y'); $f->pack(-side =>'right', -fill => 'y'); Tk::MainLoop; perl-tk_804.036+git20260828+dfsg/examples/error_prop0000775000175000017500000000060315151075633022032 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use Tk::ErrorDialog; # $SIG{__DIE__} = sub { print "die(",join(',',@_),")\n" }; sub one { shift->BackTrace("dying"); } sub two { my $w = shift; eval { one($w) }; $w->BackTrace($@) if ($@); } my $mw = MainWindow->new; my $b = $mw->Button(-text => 'Moan', -command => sub { after(1000, \&two, $mw) })->pack(-expand => 0); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/try0000775000175000017500000000044315151075633020461 0ustar georgeskgeorgeskuse blib; use Tk; my $mw = MainWindow->new; my $kind = shift; die "usage: $0 widgetclass" if !$kind; require "Tk/$kind.pm"; my $w = $mw->$kind(); if ($w->isa('Tk::Wm')) { $w->deiconify; } else { $w->pack; } $mw->update; $mw->after(1000); $mw->after(5000,[destroy => $mw]); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/ls_table0000775000175000017500000000325315151075633021432 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use Tk::Table; my $now = time; my $mw = MainWindow->new; my $t = $mw->Table(-scrollbars => 'e',-fixedrows => 1, -rows => 20); $t->pack(-expand=> 1, -fill => 'both'); $dir = (@ARGV) ? shift : '.'; opendir(DIR,$dir) || die "Cannot opendir $dir:$!"; my $r = 1; my $c = 0; my $name; foreach $name ([-text => "Mode",-anchor => 'e'], [-text => "Ln",-anchor => 'e'], [-text => "User",-anchor => 'w'], [-text => "Size",-anchor => 'e'], [-text => "Date",-anchor => 'w'], [-text => "Name",-anchor => 'w']) { $t->put(0,$c++,$t->Label(@$name,-relief => 'raised')); } $t->configure(-columns => $c) if ($c > $t->cget('-columns')); my @opt = (-relief => 'groove'); foreach $name (sort readdir(DIR)) { my $c = 0; my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = lstat("$dir/$name"); die "Cannot lstat $dir/$name:$!" unless (defined $dev); $t->put($r,$c++,$t->Label(@opt,-text => sprintf("%o",$mode),-anchor => 'e')); $t->put($r,$c++,$t->Label(@opt,-text => $nlink,-anchor => 'e')); $t->put($r,$c++,$t->Label(@opt,-text => $uid,-anchor => 'w')); $t->put($r,$c++,$t->Label(@opt,-text => $size,-anchor => 'e')); $t->put($r,$c++,$t->Label(@opt,-text => fmtdate($mtime),-anchor => 'w')); $t->put($r,$c++,$t->Label(@opt,-text => $name,-anchor => 'w')); $r++; } closedir(DIR); $t->update; $t->focus; MainLoop; sub fmtdate { my $t = shift; my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($t); my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); sprintf("%s %2d %2d:%2d", $mon[$mon], $mday,$hour,$min); } perl-tk_804.036+git20260828+dfsg/examples/font_test0000775000175000017500000000066315151075633021654 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk ; $top = MainWindow->new; chomp(@fonts = `xlsfonts`) ; $list = $top->ScrlListbox(-scrollbars => 'e', -width => 70) ; $list->pack(qw(-fill both -expand 1)) ; $list->bind('<1>' => [sub {&changeFont} ] ) ; grep ($list->insert('end',$_), @fonts) ; MainLoop ; sub changeFont { local($w) = shift ; local($fontName) ; $fontName = $w->get($w->curselection) ; $w->configure(-font => $fontName ) ; } perl-tk_804.036+git20260828+dfsg/examples/fetail0000664000175000017500000000102715151075633021103 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; my $file = (@ARGV) ? shift : 'README'; use Tk; my $top = MainWindow->new; init_check(); MainLoop; sub init_check { my $cmd = "/usr/bin/tail +0f $file"; my $open_pid = open (TAIL, "$cmd|") || die "Can't open $cmd: $!"; select (TAIL); $| = 1; select (STDOUT); $| = 1; $top->fileevent(\*TAIL, 'readable', sub { $_ = ; print "debug : $_"; }); } perl-tk_804.036+git20260828+dfsg/examples/tmenu0000664000175000017500000000056515151075633020775 0ustar georgeskgeorgesk#!perl -w use strict; use Tk; my $mw = MainWindow->new; my $menu = $mw->menu; $menu->cascade(-label => "Added",-underline => 0, -menuitems => [ [Button => 'Exit', -underline => 1, -command => [destroy => $mw]], ]); $mw->Button(-text => "Press this button to Quit\nthe Appliation", -command => [destroy => $mw])->pack; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/taint_test20000664000175000017500000000054115151075633022077 0ustar georgeskgeorgeskuse Tk (); my $mw = Tk::MainWindow->new(); my $l = $mw->Label(-text=>'see the error')->grid; if (@ARGV) { # trigger a error to see how a 'normal' error looks like $l->afterIdle([$l, 'configurex', '-text', 'no error found']); } else { # Fails with -T $l->afterIdle([$l, 'configurex', '-text', 'no error found']); } Tk::MainLoop; perl-tk_804.036+git20260828+dfsg/examples/style_test0000664000175000017500000000113515151075633022036 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use Tk::HList; use Tk::ItemStyle; $top = new MainWindow; $hl = $top->HList->pack; $redstyle = $top->ItemStyle('text', -foreground => 'red', -font => '10x20', -background => 'green'); print $redstyle,"\n"; $bluestyle = $top->ItemStyle('text', -foreground => 'blue', -background => 'white', ); $hl->add(0, -itemtype => 'text', -text => 'red', -style => $redstyle); $hl->add(1, -itemtype => 'text', -text => 'blue', -style => $bluestyle); $top->after(5000, [ configure => $redstyle, -background => 'cyan' ]); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/menubar0000775000175000017500000001235315151075633021277 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; # one way of doing menu bars that a collegue has come up with # not official in any manner yet. { package MenuBar; sub new { my $class = shift; my($parent,@args) = @_; my $me; my $f = $parent->Frame('-relief' => "raised", '-bd' => 1 ); $me = bless \$f; for($i = 0 ; $i < scalar(@args) ; $i += 2) { $me->add($args[$i],$args[$i+1],'-side' => "left"); } $f->pack('-side' => "top"); return $me; } sub add { my($me,$name,$defn,@args) = @_; my $b = ${$me}->Menubutton( '-text' => $name, '-underline' => 0 ); my $m = create_menu($b,$defn); $b->configure('-menu' => $m); $b->pack(@args); ${$me}->pack(); } sub create_menu { my($b,$defn) = @_; my $m = $b->Menu(); foreach $elem (@{$defn}) { if(ref($elem) && ref($elem) eq 'ARRAY' && defined($elem->[0])) { if(defined($elem->[1]) && ref($elem->[1]) && ref($elem->[1]) eq 'ARRAY') { $m->cascade('-label' => $elem->[0], '-menu' => create_menu($m,$elem->[1]) ); } else { my $state = (defined($elem->[2]) && $elem->[2] == 0) ? 'disabled' : 'normal'; if(defined($elem->[3]) && ref($elem->[3]) eq 'SCALAR') { $m->checkbutton('-label' => $elem->[0], '-variable' => $elem->[3], '-state' => $state ); } else { $m->command('-label' => $elem->[0], '-state' => $state ); } } } else { $m->separator; } } return $m; } } $top = MainWindow->new(); $bar = MenuBar->new($top,@menus::menu); Tk::MainLoop; #tkmainloop; exit; BEGIN { package menus; $SEPARATOR = undef; $xile = [ ["Open File...\t\tX" ,'find-file' ], ["Open File (Read Only)...\tY" ,'find-file' ], ["Open File (New Screen)..." ,'find-file-new-screen' ], ["Open Alternate File..." ,'find-alternate-file' ], $SEPARATOR, ["Include File..." ,'insert-file' ], $SEPARATOR, ["Toggle Read Only" ,'toggle-read-only' ], $SEPARATOR, ["Save Buffer" ,'save-buffer' ], ["Save Buffer As..." ,'write-file' ], ["Save Some Buffers" ,'save-some-buffers' ], ["Save Region As..." ,'write-region' ], ["Revert Buffer" ,'revert-buffer' ], $SEPARATOR, ["Print Buffer" ,'lpr-buffer' ], ["Print Region" ,'lpr-region' ], $SEPARATOR, ["Kill Buffer..." ,'kill-buffer' ], ["Exit Emacs" ,'save-buffers-kill-emacs' ] ]; $readonly = 0; $file = [ ["Open File..." ,$xile ], ["Open File (Read Only)..." ,'find-file' ], ["Open File (New Screen)..." ,'find-file-new-screen' ], ["Open Alternate File..." ,'find-alternate-file' ], $SEPARATOR, ["Include File..." ,'insert-file' ], $SEPARATOR, ["Toggle Read Only" ,'toggle-read-only' ,1,\$readonly], $SEPARATOR, ["Save Buffer" ,'save-buffer' ], ["Save Buffer As..." ,'write-file' ], ["Save Some Buffers" ,'save-some-buffers' ], ["Save Region As..." ,'write-region' ], ["Revert Buffer" ,'revert-buffer' ], $SEPARATOR, ["Print Buffer" ,'lpr-buffer' ], ["Print Region" ,'lpr-region' ], $SEPARATOR, ["Kill Buffer..." ,'kill-buffer' ], ["Exit Emacs" ,'save-buffers-kill-emacs' ] ]; $screen = [ ["New Screen" ,'x-new-screen' ,1], ["Delete Screen" ,'delete-screen' ,0], ["One Screen" ,'one-screen' ,1], $SEPARATOR, ["Split" ,'split-window-vertically' ,1], ["Un-split (Keep This)" ,'delete-other-windows' ,1], ["Un-split (Keep Others)" ,'delete-window' ,1], $SEPARATOR, ["Enlarge current window" ,'enlarge-window', ,1], ["Shrink current window" ,'shrink-window', ,1], $SEPARATOR, ["Save Configuration..." ,'window-config-to-register' ,1], ["Restore Configuration..." ,'register-to-window-config' ,1], $SEPARATOR, ["(Un)Truncate Lines" ,'hscroll-truncate-lines' ,1] ]; @menu = ( "File" => $file, "Screen" => $screen, "Another Screen" => $screen ); } perl-tk_804.036+git20260828+dfsg/examples/geom0000775000175000017500000000013515151075633020570 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; $mw = MainWindow->new(); $mw->geometry('-0-0'); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/canvas_scroll0000775000175000017500000000175615151075633022504 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; $top = MainWindow->new(); $top->wm("minsize", 10, 10); $top->wm("geometry", "100x100"); $c = $top->Canvas("-width" => 200,"-height" => 200); $s1 = $top->Scrollbar("-command" => ["yview",$c]); $s2 = $top->Scrollbar("-orient" => "horizontal", "-command" => ["xview",$c]); $c->configure("-yscrollcommand" => ["set",$s1]); $c->configure("-xscrollcommand" => ["set",$s2]); $id = $c->create("line",0,0, 0,200, 200,0, 200,200, 0,0, 200,0, 200,200, 0,200, "-width" => 4); print "Line id=$id\n"; $id = $c->create("grid",0,0, 10,10,"-width" => 1); print "Grid id=$id\n"; $c->create("grid",0,0, 50,50,"-width" => 1, -lines => 1, -dash => '.'); $c->create("grid",0,0, 100,100,"-width" => 1, -lines => 1); $c->configure("-scrollregion" => [0,0,204,204]); $s1->pack( "-side" => "left", "-fill" => "y"); $s2->pack( "-side" => "bottom", "-fill" => "x"); $c->pack("-expand" => 1, "-fill" => "both" ); Tk::MainLoop; perl-tk_804.036+git20260828+dfsg/examples/leak_test0000664000175000017500000000057015151075633021614 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use Devel::Leak; use Tk::widgets qw(Button); print STDERR "Before ",$start = Devel::Leak::NoteSV($hook),"\n"; { my $top = MainWindow->new(); my $w = $top->Button(-text => 'Quit',-command => ['destroy',$top])->pack; MainLoop; } END { print STDERR "After ",$end = Devel::Leak::CheckSV($hook),"\n"; print "Delta ",($end-$start),"\n"; } perl-tk_804.036+git20260828+dfsg/examples/grid_test0000775000175000017500000000067215151075633021633 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; my $mw = MainWindow->new; open(FILE,__FILE__); my $f = $mw->Frame->pack(-expand => 1, -fill => 'both'); my $t = $f->Text; my $y = $f->Scrollbar(-orient => 'vertical'); my $x = $f->Scrollbar(-orient => 'horizontal'); $t->grid(-row => 0, -sticky => 'nsew'); $y->grid(-row => 0, -column => 1, -sticky => 'nsew'); $x->grid(-row => 1, -sticky => 'nsew'); $t->insert('end',join('',)); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/pixels-points0000664000175000017500000000122315151075633022453 0ustar georgeskgeorgesk#!/usr/local/bin/new/perl -w use strict; use Tk; use Tk::Xlib; my $mw = MainWindow->new; $mw->scaling($ARGV[0]) if (@ARGV); my $screen = $mw->Screen; my $width = $screen->WidthOfScreen; my $widthMM = $screen->WidthMMOfScreen; my $widthIN = $widthMM/25.4; my $height = $screen->HeightOfScreen; my $heightMM = $screen->HeightMMOfScreen; my $heightIN = $heightMM/25.4; my $s = $mw->scaling; my $ws = $width/($widthMM*72/25.4); my $hs = $height/($heightMM*72/25.4); print "Width=$width WidthMM=$widthMM WidthIN=$widthIN\n"; print "Height=$height HeightMM=$heightMM HeightIN=$heightIN\n"; print "Scale=$s wScale=$ws hScale=$hs\n"; perl-tk_804.036+git20260828+dfsg/examples/ewidth_demo0000664000175000017500000000076415151075633022136 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use strict; { package Tk::LimitEntry; require Tk::Entry; @Tk::LimitEntry::ISA = qw(Tk::Entry); Construct Tk::Widget 'LimitEntry'; sub Insert { my ($w,$char) = @_; my $width = $w->cget('-width'); my $len = $w->index('end'); if ($len >= $width) { $w->bell; } else { $w->SUPER::Insert($char); } } } my $mw = MainWindow->new; my $var = ""; my $e = $mw->LimitEntry(-width => 8, -textvariable => \$var)->pack; $mw->update; $e->focus; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/al_bug0000775000175000017500000000223215151075633021072 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use Tk::Table; use Tk::Entry; sub Foo::new { return bless {} } $MAX_ITEMS = 10; $VIEWED_ITEMS = 5; $f = new Foo; # Used later for callback setup. $top = new MainWindow(); my $t = $top->Table(-scrollbars => 'e', -rows => $VIEWED_ITEMS, -columns => 3, -highlightthickness => 0, ); $t->pack(-expand => 1, -fill => 'both' ); ### Set up the entries and bindings. foreach $r (0..$MAX_ITEMS-1) { $c = 0; $tmp = ["0,$r","1,$r","2,$r"]; foreach (@$tmp) { $e = $t->Entry(-width => 5, -relief => 'sunken', -highlightthickness => 0, -borderwidth => 1, -textvariable => \$_); $t->put($r, $c++, $e); } $t->get($r, 0)->bind('' => [$f, 'recalc', $r]); $t->get($r, 1)->bind('' => [$f, 'find', $r]); } MainLoop(); exit; sub recalc { my($self, $r) = @_; print STDERR "In recalc on row $r\n"; my $w = $t->get($r,1); $w->focus() ; } sub find { my($self, $r) = @_; print STDERR "In find on row $r\n"; if (1 && $r < $MAX_ITEMS) { my $w = $t->get($r+1,0); $w->focus() ; $t->see($w); } } __END__ perl-tk_804.036+git20260828+dfsg/examples/tkpsh0000775000175000017500000000140015151075633020766 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w require 5.001; use IO::Handle; use Tk; {package WrapMain; sub new { my $class = shift; my $mw = $::mw; $mw->configure(@_) if @_; @MainWindow::ISA = 'Tk::MainWindow'; return $mw; } } @MainWindow::ISA = 'WrapMain'; $mw = $top = Tk::MainWindow->new; $mw->title('tkpsh'); $top->iconname('tkpsh'); if (@ARGV) { local @Tk::EXPORT; do $ARGV[0]; } autoflush STDOUT 1; $mw->fileevent(STDIN,'readable',\&doline); sub doline { my $line = ; if (!defined $line) { $mw->fileevent(STDIN,'readable',''); $mw->destroy; } else { if ($line =~ /^p\s(.*)$/) { $line = "print $1, \"!\\n\";"; } eval $line; print "$@\n" if $@; print "tkpsh> "; } } print "tkpsh> "; MainLoop; print "\n"; perl-tk_804.036+git20260828+dfsg/examples/disbutton0000664000175000017500000000116615151075633021656 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w package StickyButton; use Tk; require Tk::Widget; require Tk::Button; use base qw(Tk::Button); Construct Tk::Widget 'StickyButton'; sub invoke { my $w = shift; my $state = $w->cget('-state'); $w->configure('-state' => 'disabled'); $w->update; $w->Callback('-command'); $w->configure('-state' => $state); } package main; use Tk; my $mw = MainWindow->new; my $b = $mw->StickyButton(-text => 'Sticky', -command => \&Slow)->pack; MainLoop; sub Slow { local $| = 1; print "Invoked..."; my $var = 0; $mw->after(5000,sub { $var = 1 }); $mw->waitVariable(\$var); print " done\n"; } __END__ perl-tk_804.036+git20260828+dfsg/examples/tiny0000775000175000017500000000044415151075633020627 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; use Tk::widgets qw(Button); #use Carp (); #$SIG{'__DIE__'} = \&Carp::confess; my $mw = MainWindow->new(); $mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack; $mw->Button(-text => 'Exit', -command => sub { exit } )->pack; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/inline_bitmap0000664000175000017500000000135715151075633022457 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; my $mw = MainWindow->new; my $bits = pack("b8"x5, "........", "...11...", "..1111..", ".111111.", "........"); $mw->DefineBitmap('increment' => 8,5, $bits); # And of course, decrement is the reverse of increment :-) $mw->DefineBitmap('decrement' => 8,5, scalar reverse $bits); my $value = 1000; my $up = $mw->Button(-bitmap => 'increment', -pady => 0, -command => sub { $value++ } ); my $dn = $mw->Button(-bitmap => 'decrement', -pady => 0, -command => sub { $value-- } ); my $en = $mw->Entry(-textvariable => \$value, -justify => 'right', -width => 6); my $qu = $mw->Button(-text => 'Quit', -command => [destroy => $mw]); Tk::grid($en,$up); Tk::grid('^',$dn); Tk::grid($qu,'-'); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/tixwm_demo0000775000175000017500000000061115151075633022014 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w # XXX Does not work anymore: # "can't pack ".dialog": it's a top-level window" use Tk; use Tk::Dialog; my $mw = MainWindow->new; my $b = $mw->Button(-text => 'A button', -command => sub { print "A button\n"}); my $t = $mw->Dialog(-title => 'A Dialog', -text => 'A dialog has text'); $t->withdraw; $t->idletasks; $t->wmCapture; $t->pack; $b->wmRelease; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/ptknews0000775000175000017500000002027415151075633021342 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; use Data::Dumper; use Tk::ErrorDialog; require Tk::Text; require Mail::Internet; require Net::NNTP; package News::Group; use Carp; my %groups = (); my @subscribed = (); sub new { my $class = shift; my $obj; if (@_ == 1) { local $_ = shift; my ($group,$state,$read) = /^([\w+.-]+)([:!])\s*(.*)$/; my @read = (); my %hash = (name => $group, subscribed => ($state eq ':'), Read => \@read); if (defined $read) { foreach (split(/,/,$read)) { if (/^\d+$/) { push(@read,[$_,$_]); } else { my ($start,$end) = split(/-/,$_); push(@read,[$start,$end]); } } $obj = bless \%hash,$class; } } else { my %args = @_; $obj = bless \%args,$class; } $groups{$obj->name} = $obj; if ($obj->subscribed) { push(@subscribed,$obj); } } sub subscribed { my $self = shift; if (ref($self)) { $self->{subscribed} = shift if (@_); return $self->{subscribed}; } else { return @subscribed; } } sub read { my $self = shift; if (@_) { my $art = shift; croak "No article" unless (defined $art); if (@_) { my $state = shift; croak "No state" unless (defined $state); my $i; for ($i=0; $i < @{$self->{Read}}; $i++) { my ($low,$high) = @{$self->{Read}[$i]}; croak "$low > $high" unless ($low <= $high); if ($art >= $low && $art <= $high) { return if ($state); # already in the list if ($art == $low) { # At bottom of range if ($art == $high) { # whole of range - remove entry splice(@{$self->{Read}},$i,1); return; } # move range up $self->{Read}[$i][0] = $art+1; return; } elsif ($art == $high) { # move range down $self->{Read}[$i][1] = $art-1; return; } # otherwise split the range into two splice(@{$self->{Read}},$i,1,[$low,$art-1],[$art+1,$high]); return; } if ($state) { if ($art == ($high+1)) { # Just off the top end if (($i+1) < @{$self->{Read}} && $art == ($self->{Read}[$i+1][0]-1)) { # filled in hole between two ranges $art = $self->{Read}[$i+1][1]; # new top is end of higher range splice(@{$self->{Read}},$i+1); # loose upper range } $self->{Read}[$i][1] = $art; # set new upper end return; } if ($art == ($low-1)) { # special case hole should be handled above $self->{Read}[$i][0] = $art; # set new lower end return; } if ($art < $low) { # read something in a hole - add new degenerate range splice(@{$self->{Read}},$i,1,[$art,$art],$self->{Read}[$i]); return; } } } if ($state) { # read something off the end push(@{$self->{Read}},[$art,$art]) } } else { my $range; foreach $range (@{$self->{Read}}) { return 1 if ($art >= $range->[0] && $art <= $range->[1]); } return 0; } } else { my $range; my $str = ""; my @range = @{$self->{Read}}; while (@range) { my $range = shift(@range); if ($range->[0] == $range->[1]) { $str .= $range->[0]; } else { $str .= $range->[0] . '-' . $range->[1]; } $str .= ',' if (@range); } return $str; } } sub ReadRC { my $class = shift; my $path = "$ENV{'HOME'}/.Newsrc"; if (open(RC,"<$path")) { local $/ = "\n"; while () { $class->new($_); } close(RC); } else { warn "Cannot open $path:$!"; } } sub WriteRC { my ($self,$fh) = @_; print $fh $self->name,(($self->subscribed) ? ':' : '!'),' ',$self->read,"\n"; } sub SaveRC { my $class = shift; my $path = "$ENV{'HOME'}/.Newsrc"; unlink("$path.bak"); link($path,"$path.bak"); if (open(RC,">$path.new")) { my $group; foreach $group ($class->subscribed) { $group->WriteRC(\*RC); } foreach $group (values %groups) { $group->WriteRC(\*RC) unless ($group->subscribed); } close(RC); rename("$path.new",$path) || warn "Cannot rename $path.new to $path:$!"; system('ned',$path); } else { warn "Cannot open $path.new:$!"; } } sub name { shift->{name} } sub find { my ($class,$name) = @_; return $groups{$name}; } package main; use Getopt::Long; my %opt; GetOptions(\%opt, "server=s") or die "usage: $0 [-server host]"; my $mw = MainWindow->new; my $news = Net::NNTP->new($opt{server}) or die "Can't connect to news server, please specify -server"; my $group = 'comp.lang.perl.tk'; sub SetGroup { my ($lb,$group) = @_; $lb->{Group} = News::Group->find($group); my ($count,$start,$end,$name) = $news->group($group); $lb->delete(0,'end'); $lb->Busy; while ($start <= $end) { unless ($lb->{Group}->read($start)) { my $head = $news->head($start); if ($head) { my $mail = Mail::Internet->new($head); my @info = (sprintf("%6d",$start)); push(@info,scalar $mail->get('Subject')); push(@info,scalar $mail->get('Date')); push(@info,scalar $mail->get('From')); $lb->insert('end',join(' ',@info)); } } $start++; } $lb->Unbusy; $lb->focus; } my $n = 0; sub Reply { my ($text) = @_; my @lines = split(/\n/,$text->get('1.0','end')); foreach (@lines) { $_ .= "\n"; s/^Message-ID:/Message-Id:/ }; my $mail = Mail::Internet->new(\@lines); $mail->remove_sig; $mail->tidy_body; my $id = $mail->get('Message-Id'); my $groups = $mail->get('Newsgroups'); my $refs = $mail->get('References'); my $reply = $mail->reply(": "); $reply->add(Newsgroups => $groups); $reply->add(References => $refs); $reply->add(References => $id); $reply->combine('References'); $reply->delete('Cc'); $n++; my $path = "/tmp/reply.$$.$n"; open(TMP,">$path") || die "Cannot open $path:$!"; $reply->print(\*TMP); close(TMP); system($ENV{'EDITOR'}.' '.$path.' &'); } sub Catchup { my ($lb,$sel,$state) = @_; my $group = $lb->{Group}; die "No group" unless (defined $group); my ($art) = ($sel =~ /^\s*(\d+)/); $lb->{Group}->read($art,$state); } sub GetArticle { my ($lb,$text,$sel) = @_; my $group = $lb->{Group}; die "No group" unless (defined $group); my ($art) = ($sel =~ /^\s*(\d+)/); die "No arg in '$sel'" unless (defined $art); my $data = $news->article($art); $text->delete('1.0','end'); $text->Busy; my $header = 1; foreach (@$data) { if ($header && /^([^:]+):/) { $text->insert('end',$_,$1); } else { $text->insert('end',$_); } $header = 0 if ($header && /^\s*$/); } $text->Unbusy; $text->focusNext; die "No arg in '$sel'" unless (defined $art); $lb->{Group}->read($art,1); } my $menubar = $mw->Frame->pack(-fill => 'x'); my $mb = $menubar->Menubutton(-text => 'File', -underline => 0)->pack(-side => 'left'); $mb->command(-label => 'Save', -underline => 0, -command => sub { $mb->Busy; News::Group->SaveRC; $mb->Unbusy } ); $mb->command(-label => 'Quit', -underline => 0, -command => [ destroy => $mw ]); my $text = $mw->Scrolled('Text', -scrollbars => 'osow',-wrap => 'none'); $mb->command(-label => 'Reply', -underline => 0, -command => [ \&Reply, $text ]); my $list = $mw->Scrolled('Listbox',-scrollbars => 'osow'); $list->pack(-fill => 'both', -expand => 'y'); $list->bind('<1>','focus'); News::Group->ReadRC; my $sel = $menubar->Optionmenu(-options => [ map($_->name,News::Group->subscribed)]); $sel->configure(-command => [\&SetGroup,$list->Subwidget('listbox')]); $sel->pack(-side => 'right'); $text->pack(-fill => 'both', -expand => 'y'); eval { $text->tag('configure','Subject',-foreground => 'blue') }; $text->tag('configure','From',-underline => 1); $list->bind('',[\&GetArticle,$text,Ev(['getSelected'])]); $list->bind('',[\&GetArticle,$text,Ev(['get','active'])]); $list->bind('',[\&Catchup,Ev(['get','active']),1]); $list->bind('',[\&Catchup,Ev(['get','active']),0]); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/tlist_demo0000664000175000017500000000131515151075633022002 0ustar georgeskgeorgesk use strict; use Tk (); use Tk::TList; my $mw = Tk::MainWindow->new(); my $num = 150; $mw->Label(-text=>"\nA TList with $num widgets\n")->pack; my ($tl, $orient); $mw->Checkbutton(-command => sub{ $tl->configure(-orient=> $orient) }, -onvalue => 'horizontal', -offvalue => 'vertical', -variable => \$orient, -text => "horizontal Orientation", )->pack; $tl = $mw->Scrolled('TList', -scrollbars => 'osow'); my $sw = $tl->Subwidget('scrolled'); $tl->pack(-expand=>'yes',-fill=>'both'); my $l; foreach (1 .. $num) { $tl->insert('end', -itemtype => 'window', -window=> $sw->Button(-text=>"**$_**") ); } Tk::MainLoop; __END__ perl-tk_804.036+git20260828+dfsg/examples/icon0000664000175000017500000000024515151075633020570 0ustar georgeskgeorgesk#!/tools/local/perl -w use Tk; my $mw = MainWindow->new; my $image = $mw->Photo('-file' => Tk->findINC("icon.gif")); $mw->iconimage($image); $mw->iconify; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/sillymenu0000775000175000017500000000172715151075633021672 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; use Data::Dumper; my $mw = MainWindow->new; my $menu = $mw->Menu; for my $i (1..24) { my $sm = $menu->cascade(-label => "Button$i"); $sm->command(-label => 'Quit', -command => \&lrw); } my $h = $menu->cascade(-label => "Help"); $h->command(-label => 'Quit', -command => [destroy => $mw]); $mw->configure(-menu => $menu); $mw->Scrolled('Text')->pack(-fill => 'both', -expand => 1); $mw->Button(-text => 'Quit', -command => [destroy => $mw])->pack; MainLoop; sub lrw { my $menu = $mw->Menu; my $h = $menu->cascade(-label => "Help"); $h->command(-label => 'Quit', -command => [destroy => $mw]); for my $i (1..5) { my $sm = $menu->cascade(-label => "Left$i"); $sm->command(-label => 'Quit', -command => [destroy => $mw]); } $menu->separator; for my $i (1..5) { my $sm = $menu->cascade(-label => "Right$i"); $sm->command(-label => 'Quit', -command => [destroy => $mw]); } $mw->configure(-menu => $menu); } perl-tk_804.036+git20260828+dfsg/examples/hlist_bg0000664000175000017500000000244515151075633021437 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; require Tk::HList; $mw = MainWindow->new; my $hl = $mw->Scrolled('HList', -separator => '.', -width => 25, -drawbranch => 1, -selectmode => 'extended', -indent => 10, # -bg=>'green' ); #my $hl = $mw->HList(-separator => '.', # -width => 25, # -drawbranch => 1, # -selectmode => 'extended', # -indent => 10, -bg=>'green'); print "reconfigure\n"; $hl->configure(-bg=>'red'); # none of these seem to work $hl->configure(-background=>'yellow'); $hl->configure( -command => \&PrintLine, -browsecmd => \&PrintBug); $hl->pack(-expand => 1, -fill => 'both'); @list = qw(one two three); foreach $item (@list) { $hl->add($item,-itemtype => 'text', -text => $item, -data => {}); my $subitem; foreach $subitem (@list) { $hl->addchild($item,-itemtype => 'text', -text => $subitem, -data => []); } } MainLoop; sub PrintLine { my $row = shift; my $data = $hl->info('data',$row); foreach ($hl,$row,$data) { print ref($_) ? "ref $_\n" : "string $_\n"; } print "\n"; } sub PrintBug { print "Browsecmd callback executed\n"; } __END__ perl-tk_804.036+git20260828+dfsg/examples/gridbug0000664000175000017500000000273415151075633021270 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use Carp; $top = MainWindow->new(); $top->title("STest23289 test"); $SIG{'__DIE__'} = \&confess; # interface generated by SpecTcl version 1.0 from STest21872.ui # Experimental pTk version using the gridbag geometry manager sub STest23289_ui { my($root) = @_; # $root->grid; # stolen from npuz but does not help here my($text_1) = $root->Text ( -background => '#d9d9d9', -cursor => undef, -foreground => 'Black', -height => '1', -highlightbackground => '#d9d9d9', -width => '1' ); my($listbox_1) = $root->Listbox ( -background => '#d9d9d9', -foreground => 'Black', -height => '0', -highlightbackground => '#d9d9d9', -width => '0' ); my($message_1) = $root->Message ( -background => '#d9d9d9', -foreground => 'Black', -highlightbackground => '#d9d9d9', -text => 'message' ); # Geometry management $text_1->grid( -in => $root, -column => '2', -row => '1', -sticky => 'nesw' ); $listbox_1->grid( -in => $root, -column => '1', -row => '2', -sticky => 'nesw' ); $message_1->grid( -in => $root, -column => '2', -row => '3' ); # Resize behavior management $root->gridRowconfigure(1, -weight => 0, -minsize => 30); $root->gridRowconfigure(2, -weight => 0, -minsize => 30); $root->gridRowconfigure(3, -weight => 0, -minsize => 30); $root->gridColumnconfigure(1, -weight => 0, -minsize => 30); $root->gridColumnconfigure(2, -weight => 0, -minsize => 30); } STest23289_ui $top; Tk::MainLoop; perl-tk_804.036+git20260828+dfsg/examples/table_demo0000775000175000017500000000261215151075633021736 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use Tk::Table; sub Compass { my ($top,$var) = @_; my $out = $top->Table(-relief => 'ridge',-borderwidth => 3,-scrollbars => 'c'); my $i = 0; foreach $r ([qw(nw n ne)],[qw(w c e)],[qw(sw s se)]) { my $j = 0; foreach $a (@$r) { $b = $out->Create($i,$j++,'Radiobutton',-text=> $a, -variable => $var, -value => $a, -anchor => 'w'); } $i++; } return $out; } my $mw = MainWindow->new; my $t = $mw->Table(-columns => 6, -rows => 8, -fixedrows => 1, -scrollbars => 'se'); $t->pack(-expand=> 1, -fill => 'both'); sub Pressed { my ($t,$i,$j) = @_; my $l = $t->Label(-text => "Pressed $i,$j",-relief => 'sunken'); my $old = $t->put($i,$j,$l); $old->destroy if ($old); } my $i; foreach $i (0..9) { my $j; foreach $j (0..9) { my $l = $t->Button(-text => "Entry $i,$j", -command => [\&Pressed,$t,$i,$j]); $t->put($i,$j,$l); } } my $sb; my $rl; my $cl; tie $sb,Tk::Configure,$t,'-scrollbars'; tie $rl,Tk::Configure,$t,'-fixedcolumns'; tie $cl,Tk::Configure,$t,'-fixedrows'; Compass($mw,\$sb)->pack(-side => 'bottom'); $mw->Checkbutton(-text => 'Row labels', -variable => \$rl, -onvalue => 1, -offvalue => 0) ->pack(-side => 'left'); $mw->Checkbutton(-text => 'Column labels', -variable => \$cl, -onvalue => 1,-offvalue => 0) ->pack(-side => 'right'); $t->focus; $t->update; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/cursor_demo0000775000175000017500000000241415151075633022164 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; my $mw = MainWindow->new; my @names = ( "X_cursor", "arrow", "based_arrow_down", "based_arrow_up", "boat", "bogosity", "bottom_left_corner", "bottom_right_corner", "bottom_side", "bottom_tee", "box_spiral", "center_ptr", "circle", "clock", "coffee_mug", "cross", "cross_reverse", "crosshair", "diamond_cross", "dot", "dotbox", "double_arrow", "draft_large", "draft_small", "draped_box", "exchange", "fleur", "gobbler", "gumby", "hand1", "hand2", "heart", "icon", "iron_cross", "left_ptr", "left_side", "left_tee", "leftbutton", "ll_angle", "lr_angle", "man", "middlebutton", "mouse", "pencil", "pirate", "plus", "question_arrow", "right_ptr", "right_side", "right_tee", "rightbutton", "rtl_logo", "sailboat", "sb_down_arrow", "sb_h_double_arrow", "sb_left_arrow", "sb_right_arrow", "sb_up_arrow", "sb_v_double_arrow", "shuttle", "sizing", "spider", "spraycan", "star", "target", "tcross", "top_left_arrow", "top_left_corner", "top_right_corner", "top_side", "top_tee", "trek", "ul_angle", "umbrella", "ur_angle", "watch", "xterm"); my $lb = $mw->Scrolled('Listbox')->pack; $lb->insert('end',@names); $lb->bind('',['configure',-cursor,Ev(['getSelected'])]); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/grid_adj0000664000175000017500000000156515151075633021411 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; require Tk::TextUndo; require Tk::Adjuster; require Tk::Listbox; use Carp; $SIG{__DIE__} = \&Carp::confess; my $mw = MainWindow->new; # Uncomment next line to avoid the warning - this a test of the warning # use Tk::TextUndo; my $t1 = $mw->Scrolled('TextUndo', -wrap => 'none'); my $lb = $mw->Scrolled('Listbox'); my $aj = $mw->Adjuster(-widget => $lb, -side => 'left', -delay => 1); $lb->grid(-column => 0, -row => 0, -sticky => 'nsew'); $aj->grid(-column => 1, -row => 0, -sticky => 'nsew'); $t1->grid(-column => 2, -row => 0, -sticky => 'nsew'); $mw->gridColumnconfigure(2, -weight => 1); $lb->bind('',sub { $t1->Load($lb->getSelected) }); # $mw->idletasks; # $mw->gridPropagate(0); opendir(DIR,'.'); my $name; foreach $name (readdir(DIR)) { $lb->insert('end',$name) if (-T $name); } closedir(DIR); MainLoop; perl-tk_804.036+git20260828+dfsg/examples/iconimg0000775000175000017500000000130115151075633021262 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; my $top = MainWindow->new(); $top->title("Mail : Trial"); my $i64 = $top->Photo(-width => 64, -height => 64, -gamma => 2, '-file' => Tk->findINC("Xcamel.gif")); my $i32 = $top->Photo(-width => 32, -height => 32); $i32->copy($i64,-subsample => 2,2); my $i16 = $top->Photo(-width => 16, -height => 16); $i16->copy($i64,-subsample => 4,4); my $w = $i64->width; my $h = $i64->height; $top->Button(-bitmap => 'Tk', -command => sub { $top->withdraw; $top->iconbitmap('Tk'); $top->deiconify})->pack; foreach my $img ($i64,$i32,$i16) { $top->Button(-image => $img, -command => sub { $top->withdraw; $top->iconimage($img); $top->deiconify})->pack; } MainLoop(); perl-tk_804.036+git20260828+dfsg/examples/mcHL0000664000175000017500000000133015151075633020457 0ustar georgeskgeorgeskuse Tk; use Tk::widgets qw(HList); my $mw = MainWindow->new(); # print "'",join("'\n'",$mw->fontFamilies),"'\n"; my $hl = $mw->HList(-columns => 3, -header => 1, -font => 'times -36' )->pack(-fill => 'both', -expand => 1); my $f = $hl->cget('-font'); print '"',join('","',$mw->fontActual($f)),"\"\n"; $hl->headerCreate(0,-text => "one\x{800}\x{fffd}"); $hl->headerCreate(1,-text => 'two'); $hl->columnWidth(1,-char => 5); $hl->headerCreate(2,-text => 'three'); for (my $i = 0; $i < 10; $i++) { $hl->add($i, -itemtype => 'text', -text => "Item$i\x{20ac}"); $hl->itemCreate($i,1, -text => chr(ord('a')+$i)."$i" x 12); $hl->itemCreate($i,2, -text => "c2$i" x 12); } MainLoop; perl-tk_804.036+git20260828+dfsg/examples/canvas_ps0000775000175000017500000000443115151075633021621 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; %Tk::FontMap = (); sub Tk::Font { my ($w,%args) = @_; $args{'family'} = 'times' unless (exists $args{'family'}); $args{'weight'} = 'medium' unless (exists $args{'weight'}); $args{'slant'} = 'r' unless (exists $args{'slant'}); $args{'size'} = 140 unless (exists $args{'size'}); $args{'spacing'} = '*' unless (exists $args{'spacing'}); $args{'foundry'} = '*' unless (exists $args{'foundry'}); $args{'slant'} = substr($args{'slant'},0,1); my $name = "-$args{'foundry'}-$args{'family'}-$args{'weight'}-$args{'slant'}-*-*-*-$args{'size'}-*-*-$args{'spacing'}-*-iso8859-1"; unless (exists $Tk::FontMap{$name}) { my $fam = "\u\L$args{'family'}"; my $w = "\u\L$args{'weight'}"; my $sz = $args{'size'}/10; my $sl = "\L$args{'slant'}"; my $an = ""; $w .= "Italic" if ($sl eq 'i'); $w .= "Oblique" if ($sl eq 'o'); $Tk::FontMap{$name} = [ "$fam-$w", $sz ]; print "$fam-$w","\n"; } return $name; } %colormap = (); sub plot { my ($c) = @_; my $ps = $c->postscript('-x' => 0, '-y' => 0, -width => $c->Width, -height => $c->Height, -fontmap => \%Tk::FontMap, -colormap => \%colormap); open(PS,">$0.ps") || die "Cannot open $0.ps:$!"; print PS $ps,"\n"; close(PS); } $top = MainWindow->new(); $c = $top->Canvas(); $c->pack(-expand => 1, -fill => 'both'); $b = $top->Button(-text => 'Quit', -command => [ 'destroy', $top ]); $b->pack; $b = $top->Button(-text => 'Plot', -command => [ \&plot, $c ]); $b->pack; $f1 = $c->Font(family => 'courier', weight => 'bold', size => 120); $c->create('text', 20, 20, -font => $f1, -anchor => 'nw', -fill => 'red', -justify => 'left', -text => 'This is a piece of "courier" Text'); $colormap{'red'} = '0.2 setgray'; $f2 = $c->Font(family => 'times', slant => 'italic', weight => 'bold', size => 140); $c->create('text', 20, 80, -font => $f2, -anchor => 'nw', -fill => 'green', -justify => 'left', -text => 'This is a piece of "times" Text'); $c->create('text', 20, 120, -font => $c->Font(family => 'times', weight => 'bold', size => 240), -anchor => 'nw', -justify => 'left', -text => 'This is a piece of "times" Text'); $colormap{'green'} = '0.5 setgray'; MainLoop; perl-tk_804.036+git20260828+dfsg/examples/text_demo0000775000175000017500000000673515151075633021645 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; require Tk::Text; my $top = MainWindow->new; $top->option('add','*Text.background'=>'white'); my $t = $top->Scrolled('Text',"-relief" => "raised", "-bd" => "2", "-setgrid" => "true"); my $m = $t->Menu(); $m->add("command", "-label" => "Open", "-underline" => 0, "-command" => \&sayopen); $m->add("command", "-label" => "Close", "-underline" => 0, "-command" => \&sayclose); $m->add("separator"); $m->add("command", "-label" => "Selection", "-underline" => 0, "-command" => \&showsel); $m->add("separator"); $m->add("command", "-label" => "Exit", "-underline" => 1, "-command" => \&doexit); $t->pack(-expand => 1, "-fill" => "both"); $t->tag("configure", "underline","-underline","on"); $t->tag("configure", "hideable", -elide => 0, -foreground => 'blue'); $t->insert("0.0", "This window is a text widget. It displays one or more lines of text and allows you to edit the text. Here is a summary of the things you can do to a text widget:",'hideable'); $t->insert(end => " 1. Insert text. Press mouse button 1 to set the insertion cursor, then type text. What you type will be added to the widget. You can backspace over what you've typed using either the backspace key, the delete key, or Control+h. 2. Resize the window. This widget has been configured with the \"setGrid\" option on, so that if you resize the window it will always resize to an even number of characters high and wide. Also, if you make the window narrow you can see that long lines automatically wrap around onto additional lines so that all the information is always visible. 3. Scanning. Press mouse button 2 in the text window and drag up or down. This will drag the text at high speed to allow you to scan its contents. 4. Select. Press mouse button 1 and drag to select a range of characters. Once you've released the button, you can adjust the selection by pressing button 1 with the shift key down. This will reset the end of the selection nearest the mouse cursor and you can drag that end of the selection by dragging the mouse before releasing the mouse button. You can double-click to select whole words, or triple-click to select whole lines. 5. Delete. To delete text, select the characters you'd like to delete and type Control+d. 6. Copy the selection. To copy the selection either from this window or from any other window or application, select what you want, click button 1 to set the insertion cursor, then type Control+v to copy the selection to the point of the insertion cursor. You can also bind commands to tags. Like press button 3 for menu "); &insertwtag($t,"here","underline"); $t->tag("bind","underline","<3>", [sub { shift; shift->Post(@_)},$m,Ev(X),Ev(Y)] ); $t->bind("", sub { $t->focus }); $t->Subwidget('text')->OnDestroy(sub { print "Destroyed!\n"; print $t->get('1.0','end') }); $t->tag("bind", "hideable","<2>", sub { $t->tagConfigure(hideable => -elide => 1, -foreground => 'pink')} ); Tk::MainLoop; sub insertwtag { local($w,$text,$tag) = @_; my $start = $w->index("insert"); print "start=$start\n"; $w->insert("insert",$text); $w->tag("add",$tag,$start,"insert"); } sub sayopen { print "Open something\n" } sub sayclose { print "Close something\n" } sub showsel { my @info = $t->tagRanges('sel'); if (@info) { print "start=$info[0] end=$info[1]\n" } } sub doexit { die "'die' no longer exits" } perl-tk_804.036+git20260828+dfsg/examples/destroy_test0000775000175000017500000000064115151075633022373 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; require Tk::Pretty ; $top = MainWindow->new(); $label = $top->Label("-text" => "Something" ); $label->bind('' , sub { printf "RIP %s\n", shift->PathName }); $top->bind('' , sub { printf "top RIP %s\n", shift->PathName }); $label->pack; $quit = $top->Button("-text" => "Quit", "-command" => ["destroy",$top]); $quit->pack; $top->update(); Tk::MainLoop(); perl-tk_804.036+git20260828+dfsg/examples/dialog_test0000664000175000017500000000110715151075633022134 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; my $mw = MainWindow->new; my $dialog = $mw->Dialog(-text => 'Hello There'); warn <Button(-text => "\u$meth", -command => [$meth => $dialog])->pack(-side => 'left'); } $| = 1; select STDERR; $| = 1; select STDOUT; # $^D = 8; MainLoop;perl-tk_804.036+git20260828+dfsg/examples/dnd_demo0000775000175000017500000003772415151075633021430 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w # # Demo code to exhibit features of dynamic construction and destruction of # local (within app.) Drag and Drop sources and sinks. Written for and tested # with Perl v5.004_01 and Tk version 400.202, on a DEC Alpha (OSI) platform. # # Drag and drop is only possible after the 'New' button has been used, and # DropSites cease to respond once they've been filled. After the 'Save' button # is used, dragging from the listbox is no longer possible. # # Pod documentation appended is a draft outline for the official documentation, # and is almost certainly neither complete nor correct. Comments/suggestions # for improvements welcomed. # # John Attwood (ja1@sanger.ac.uk), May '98 # use Tk; use Tk::Table; use Tk::DragDrop; use Tk::DropSite; use strict; my ($ButtonClr, $ListClr, $DfltClr) = ("SkyBlue1", "LightSkyBlue2", "#d9d9d9"); my ($rows, $marker_repeat) = (9, 4); my $font3 = '-*-fixed-*-*-*-*-*-140-*-*-*-*-*-*'; my ($rdgel_ref, $user_id, $session_id, $source, @clones, @enzymes, @reqs, @lbls, @drops, $method); my $changed = 0; # # Create a main window with a listbox, a table and some buttons # my $w = MainWindow->new(); $w->title("Drag and Drop demo"); $w->iconname("DnD demo"); my $w_buttons = $w->Frame; $w->Label(-text => "The radiobuttons control the contents of the drag window " . "(choice must be made before pressing New).") ->pack(-side => 'bottom'); $w->Label(-text => "Use New to set up DnD, then drag rows from listbox to blue " . "DropSites in the Table. Use Save to inhibit further " . "Drag/Dropping.") ->pack(-side => 'bottom'); my $tf = $w->Frame->pack(-side => 'right'); my $table = $tf->Table(-rows => 10, -columns => 3, -scrollbars => '', -fixedrows => 1, -fixedcolumns => 1, -takefocus => 1, ); $table->pack(-side => 'bottom', -fill => 'both'); my $geltitle = $tf->Label(-relief => 'raised')->pack(-side => 'top', -fill => 'x'); $w_buttons->pack(qw(-side bottom -fill x -pady 0.5m)); $w_buttons->Button( -background => $ButtonClr, -text => 'Quit', -command => [\&Done], )->pack(qw(-side right -expand 1)); my $save_btn = $w_buttons->Button( -background => $ButtonClr, -text => 'Save', -command => [\&SaveGel], -state => 'disabled' )->pack(qw(-side right -expand 1)); $method = 'variable'; $w_buttons->Button(-background => $ButtonClr, -text => "New", -command => \&NewGel)->pack(-side => 'right'); my $bf = $w_buttons->Frame->pack(-side => 'left'); $bf->Radiobutton(-text => 'Image', -value => 'image', -variable => \$method)->pack(-side => 'top', -anchor => 'nw'); $bf->Radiobutton(-text => 'Text', -value => 'text', -variable => \$method)->pack(-side => 'top', -anchor => 'nw'); $bf->Radiobutton(-text => 'Variable', -value => 'variable', -variable => \$method)->pack(-side => 'top', -anchor => 'nw'); my $aw = $w->Frame->pack(qw(-side bottom)); $aw->Label(-text => "Requests Outstanding")->pack(-side => 'top', -fill => 'x'); my $lb = $aw->Listbox(-height => 10, -width => 62, -background => $DfltClr, -font => $font3); $lb->pack(-side => 'left', -fill => 'y'); my $awsb = $aw->Scrollbar(-command => [$lb => 'yview']); $awsb->pack(-side => 'right', -fill => 'y'); $lb->configure(-yscrollcommand => [$awsb => 'set']); # # Make the listbox a Drag and Drop source, but disable this for now by # binding -startcommand to a routine which does nothing but return true # (indicating that it has handled the Drag initialisation itself) # # The last 3 parameters to the DragDrop invocation are (mutually exclusive) # alternatives, the commented-out versions allow fixed text or a fixed image # to be displayed in the Drag window, whilst defining a -startcommand callback # allows us to choose the text on the fly and show visually exactly what is # being dragged. # $source = $lb->DragDrop(-event => '', -sitetypes => [qw(Local)], -handlers => [[\&send_string], [-type => 'FILE_NAME', \&send_file]], -startcommand => [\&DragInhibit], # -image => $image, #use an image, not text # -text => "this is it", #fixed text string ); # # Generate a bitmap for use with Drag and Drop. # my $image = $w->Bitmap('win', # -file => 'win.xbm' -data => "#define win.xbm_width 16 #define win.xbm_height 16 static char win.xbm_bits[] = { 0xff, 0xff, 0x0d, 0xb0, 0xff, 0xff, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0x01, 0x80, 0xff, 0xff}; "); # # Populate the table and listbox # BuildTable(); Fill_lb(); # # Let the user interact # MainLoop(); ###################################################################### # # End of main program, start of subroutines # # # # Put some data into the listbox so that it can be dragged and dropped # sub Fill_lb { my @data = ( "W08A5 HindIII 01-JAN-98 ja1 Re-requested 19070", "Ab113C11 BamHI 01-JAN-98 ja1 Re-requested 18399", "Ab113C11 EcoRI 01-JAN-98 ja1 Re-requested 18400", "Ab113C11 HindIII 01-JAN-98 ja1 Re-requested 18401", "cP91H8 EcoRI 01-JAN-98 ja1 Re-requested 18535", "cP91H8 HindIII 01-JAN-98 ja1 Re-requested 18536" ); $lb->delete('0','end'); $lb->insert('end',@data); } # # Populate the rows and columns of the table. Inactive (marker) rows just have # a label; remainder have a label (which will become a dropsite) plus two # readonly text-entry fields to display the dropped data # sub BuildTable { my ($row); $table->put(0, 1, $table->Label(-text => "Clone", -relief => 'raised', -width => 15)); $table->put(0, 2, $table->Label(-text => "Enzyme", -relief => 'raised', -width => 15)); foreach $row (1..$rows) { if (($row - 1) % $marker_repeat == 0) { my $lbl = $table->Label(-text => "Marker", -relief => 'sunken', -width => 15); $table->put($rows - $row + 1,0,$lbl); } else { my $lbl = $table->Label(-text => "Lane $row", -relief => 'sunken', ); $lbls[$row] = $lbl; $table->put($rows - $row + 1,0,$lbl); my $centry = $table->Entry(-width => 15, -textvariable => \$clones[$row], -state => 'disabled'); $table->put($rows - $row + 1,1,$centry); my $dentry = $table->Entry(-width => 15, -textvariable => \$enzymes[$row], -state => 'disabled'); $table->put($rows - $row + 1,2,$dentry); } } } # # Make active Dropsites respond (by changing their relief) when dragged object # passes over them # sub SiteEntry { my ($lbl, $entry, @data) = @_; $lbl->configure(-relief => $entry == 1 ? 'raised' : 'sunken'); } # # This handler would be invoked if our drop handler specified FILE_NAME as # the data type. Not used here, but included for illustration. # sub send_file { my ($offset,$max) = @_; return __FILE__; } # # get current selection from listbox and return it to dropsite # sub send_string { my ($offset,$max) = @_; my ($lb_sel) = $lb->curselection; my ($req) = $lb->get($lb_sel); return $req; } # # Handle a drop - get dragged text, break into components and place in arrays # to be displayed in table, delete source from listbox, kill the dropsite and # make its colour revert to default. # sub Dropit { my ($row,$seln) = @_; print "$row $seln\n"; my ($rdreq) = $lb->SelectionGet('-selection'=>$seln,'STRING'); print "$rdreq\n"; my ($clone, $enz) = split " ", $rdreq; $clones[$row] = $clone; $enzymes[$row] = $enz; my ($lb_sel) = $lb->curselection; $lb->delete($lb_sel); $lb->selectionSet($lb_sel); $reqs[$row] = $rdreq; $drops[$row]->delete; $lbls[$row]->configure(-bg => $DfltClr); $changed = 1; } # # Empty the table contents # sub cleargel { my ($title) = @_; my $i; foreach $i (0..$rows) { $clones[$i] = $enzymes[$i] = ""; } $geltitle->configure(-text => "Gel: $title"); $changed = 0; } # Activate the DragDrop source by redefining -startcommand to something # useful and which returns 0 to indicate that the StartDrag process hasn't # been handled and should be managed by the object's own code. # Make all labels in active table rows into dropsites, colouring them blue. # sub NewGel { my $i; cleargel("Untitled"); print "$method\n"; if ($method eq 'variable') { $source->configure(-startcommand => [\&DragSetup, $lb]); $source->configure(-image => undef); } elsif ($method eq 'text') { $source->configure(-text => "Dragging"); $source->configure(-image => undef); $source->configure(-startcommand => \&DragOK); } else { $source->configure(-image => 'win'); $source->configure(-startcommand => \&DragOK); } $lb->configure(-background => $ListClr); foreach $i (1..$rows) { if (($i - 1) % $marker_repeat > 0) { $lbls[$i]->configure(-background => $ButtonClr); $drops[$i] = $lbls[$i]->DropSite(-droptypes => [qw(Local)], -dropcommand => [\&Dropit,$i], -entercommand => [\&SiteEntry, $lbls[$i]], ); } } $save_btn->configure(-state => 'normal'); Fill_lb(); } # # Stop the listbox being a DnD source # Kill off any active dropsites and turn everything grey again # sub SaveGel { my $gel = "newgel2"; my ($statement, $sth, $lane); cleargel(""); $save_btn->configure(-state => 'disabled'); $source->configure(-startcommand => [\&DragInhibit]); $lb->configure(-background => $DfltClr); foreach $lane (1..$rows) { if (($lane - 1) % $marker_repeat > 0) { $drops[$lane]->delete; $lbls[$lane]->configure(-bg => $DfltClr); } } Fill_lb(); } # # Disable Dragging by pretending that we've handled the initialisation # of the drag window ourselves # sub DragInhibit { return 1; } # # Enable dragging by asking the DragDrop object to initialise it for us # sub DragOK { return 0; } # # Make the drag window show the text of what's being transferred # # Caution advised here in case we turn out to be dragging 2K of text! # # Returns 0 to indicate that the drag initialisation still needs to be # handled by the source object. sub DragSetup { my ($lb) = @_; my ($lb_sel) = $lb->curselection; my ($row) = $lb->get($lb_sel); my ($clone, $enzyme) = split " ", $row; my $text = sprintf "%s/%s", $clone, $enzyme; $source->configure(-text => $text); return 0; } # # Clean up and quit # sub Done { exit 0; } END { } __END__ =head1 NAME DragDrop - create and manipulate widgets whose selections can be dragged and dropped DropSite - create and manipulate DropSites for Dragged selections =head1 SYNOPSIS use Tk::DragDrop; use Tk::DropSite; $source = $widget->DragDrop(-event => '', -sitetypes => ['Local'], -handlers => [[\&callback], [-type => 'TYPENAME', \&callback]], ); $drop = $widget->DropSite(-droptypes => ['Local'], -dropcommand => [\&Dropit,?params?], ); =head1 DESCRIPTION B This is unofficial documentation, believed to be correct but neither complete not definitive. B B implements drag-and-drop for Tk apps. It should work on any platform for local (within one application) droptypes, but only the Sun interface is defined for global (interapplication) droptypes. User can drag objects with the mouse (Button-1 by default) from DragDrop sources, and drop them on DropSites. By default, pressing any key during the Drag operation will abort it. There is support for different types of information transfer (eg STRING, ATOM, INTEGER - see Tk::Selection and/or the X Inter-Client Communication Conventions Manual (ICCCM) for details) and also user-defined types (eg FILE_NAME in the example code below) via user-defined handlers. Local (intra-application) transfer is via the X Selection mechanism. Global (interapplication) transfer uses the Sun protocols defined in the Tk::DragDrop::Sunconstant module. =head2 Example Code use Tk; use Tk::DragDrop; use Tk::DropSite; @data = ('One','Two','Three', 'Four'); $w = MainWindow->new(); $lb = $w->Listbox->pack; $lb->insert('end', @data); $lab = $w->Label(-text => "Drop here!")->pack; $source = $lb->DragDrop(-event => '', -sitetypes => [qw(Local)], -handlers => [[\&send_string], [-type => 'FILE_NAME', \&send_file]]); $drop = $lab->DropSite(-droptypes => [qw(Local)], -dropcommand => [\&Dropit, $lb], -entercommand => [\&SiteEntry, $lab], ); MainLoop(); sub send_file { my ($offset,$max) = @_; return __FILE__; } sub send_string { my ($offset,$max) = @_; my ($lb_sel) = $lb->curselection; my ($req) = $lb->get($lb_sel); return $req; } sub Dropit { my ($lb,$seln) = @_; my ($req) = $lb->SelectionGet('-selection'=>$seln,'STRING'); print "$req\n"; } sub SiteEntry { my ($w, $entry, @data) = @_; $w->configure(-relief => $entry == 1 ? 'raised' : 'sunken'); } =head1 CONFIGURATION The non-standard options recognised by B are as follows:- =over 4 =item B<-event> The event which will initiate dragging. =item B<-sitetypes> Whether the applications served by this source will be local ('local'), global ('Sun') or both (I). =item B<-handlers> Handler routines for each supported type of data to be transferred =item B<-image> Optionally a (bitmap) image to display instead of text when an item is being dragged. =item B<-startcommand> Optionally a callback invoked before dragging is initiated. Subroutine (which is called without any parameters) must return 0 if Drag is to be allowed, otherwise the event will be ignored. Defaults to I. =item B<-predropcommand> Optionally a callback invoked before dropping occurs. Subroutine (which will be called with the source application ID string and the dropsite widget as parameters) must return 0 if Drop is allowed, otherwise no handler is called. Defaults to I. =item B<-postdropcommand> Optionally a callback invoked after dropping occurs. Subroutine will be called with the source application ID string and need not return any specific value. Defaults to I. =item B<-cursor> Optionally the cursor to use whilst dragging. Defaults to 'hand2' =item B<-text> Optionally some fixed text to display in the drag window. Defaults to the classname of the parent widget. =back The non-standard options recognised by B are as follows:- =over 4 =item B<-droptypes> Whether items will be dropped from local ('local'), global ('Sun') or both (I) applications =item B<-dropcommand> Callback subroutine to invoke when something is dropped here =item B<-entercommand> Optionally, callback routine to invoke whenever dragged object enters or leaves the DropSite. Defaults to I. =back =head1 METHODS B supports the following methods:- B supports the following methods:- =over 4 =item B<-delete> Remove this object from the list of registered DropSites =back =head1 DEFAULT BINDINGS =over 4 When the window representing the dragged object is mapped, the Mapped method is called (class binding). Any button motion invokes the Drag method (class binding). Any button release invokes the Drop method (class binding). Any keypress whilst dragging invokes the Done method, aborting the drag (class binding). Button 1 invokes the StartDrag method (instance binding). =back =head1 BUGS There is currently no way a DragDrop source can remove an event binding once it has been installed (however this can be done manually by removing the binding from the parent widget). Destroying a DragDrop source doesn't remove the binding from the parent widget, causing Tk to complain if the bound callback is later invoked. DropSites can't be within a scrolling Table (this is a Table bug, not a DragDrop one). =head1 AUTHORS B nik@tiuk.ti.com : Original module code B ja1@sanger.ac.uk : This demo and draft pod docs =cut perl-tk_804.036+git20260828+dfsg/examples/unicode0000664000175000017500000000753415151075633021276 0ustar georgeskgeorgesk#!/tools/local/perl -w use strict; use Tk; use Unicode::UCD qw(charinfo charblock); use Tk::widgets qw(TixGrid ItemStyle Font); use Carp; #$SIG{__WARN__} = \&Carp::confess; eval { require Unicode::Unihan }; my $unihan; my %info = %{charinfo(ord(' '))}; if (defined $Unicode::Unihan::VERSION) { $unihan = Unicode::Unihan->new; $info{Definition} = ''; } my $mw = MainWindow->new; my $page = 0; my $pagehex = '0x00'; my $tp = $mw->Frame->pack(-fill => 'x'); my $l = $tp->Label(-text => 'Page:',-justify => 'right',-anchor => 'e'); my $s = $tp->Spinbox(-width => 4, -to => 255, -from => 0, -format => "%3.0f", -textvariable => \$page,-justify => 'left'); my $h = $tp->Label(-width => 4, -textvariable => \$pagehex, -justify => 'left'); Tk::grid($l,$s,$h,-sticky => 'ew'); $s->configure(-command =>\&set_page); my $uf = $mw->fontCreate(-family => 'lucida sans', -size => 16); my $lf = $mw->fontCreate(-family => 'courier', -size => 12); print join(' ',$mw->fontActual($uf)),"\n"; my $grid = $mw->Scrolled( TixGrid => -width => 17, -height => 17, -scrollbars => 'w', -browsecmd => \&browse, -formatcmd => \&doFormat, -leftmargin => 1, -topmargin => 1, -selectunit => 'cell', -itemtype => 'text') ->pack(-fill => 'both', -expand => 1); my $bt = $mw->Frame->pack(-fill => 'x'); my @foot; my $row = 0; my $col = 0; foreach my $key (sort keys %info) { my $l = $bt->Label(-text => $key, -justify => 'right', -anchor => 'e'); my $v = $bt->Label(-textvariable => \$info{$key}, -justify => 'left', -anchor => 'w'); Tk::grid($l,-row =>$row,-column => $col,-sticky => 'w'); Tk::grid($v,-row =>$row,-column => $col+1,-sticky => 'ew'); $bt->gridColumnconfigure($col+1,-weight => 1); $col += 2; if ($col >= 6) { $row++; $col = 0; } } my $header = $grid->ItemStyle('text', -font => $lf); my $uni = $grid->ItemStyle('text', -font => $uf, -justify => 'center'); $grid->sizeRow('default',-size => 'auto',-pad0 => 0, -pad1 => 0); $grid->sizeColumn('default',-size => 'auto',-pad0 => 0, -pad1 => 0); for my $i (0x0..0xf) { $grid->set($i+1,0,-itemtype => 'text', -style => $header, -text => sprintf("0x%04X",$i)); } my @page; $row = 1; for (my $base = 0; $base < 0x10000; $base += 16) { $grid->set(0,$row++,-itemtype => 'text', -style => $header, -text => sprintf("0x%04X",$base)); } $mw->update; $mw->packPropagate(0); MainLoop; sub fill_row { my ($row) = @_; my $base = ($row-1) << 4; my $seen = 0; my $block = charblock($base); return 0 if !defined($block) || $block =~ /Surrogate/i; for my $i (0x0..0xf) { my $u = $base + $i; my $info = charinfo($u); if (keys(%$info)) { $seen++; my $c = chr($u); $grid->set($i+1,$row,-style => $uni, -text => $c); } } if ($seen) { if (!defined($block)) { warn "$base has no block but saw $seen\n"; } } return $seen; } my @filled; sub doFormat { my ($area,$x1,$y1,$x2,$y2) = @_; if ($area =~ /([xys])_margin/) { # s = The top corner, x = left margin, y = top margin ? my $rel = ($1 eq 's') ? 'flat' : 'sunken'; $grid->formatBorder($x1,$y1,$x2,$y2,-relief => $rel, -bd => 2); } elsif ($area eq 'main') { for my $row ($y1..$y2) { unless ($filled[$row]++) { fill_row($row); } } $grid->formatGrid($x1,$y1,$x2,$y2,-relief => 'raised', -bd => 2); } else { print "format @_\n"; } } sub browse { my ($row,$col) = @_; my $c = eval { $grid->entrycget($row,$col,'-text') }; if (defined $c) { my $u = ord($c); my $h = charinfo($u); foreach my $k (keys %$h) { $info{$k} = $h->{$k}; } $info{Definition} = $unihan->Definition($c) if $unihan; } } sub set_page { my ($e) = @_; $pagehex = sprintf("0x%02X",$page); $grid->see(0,($page << 4)+1); } perl-tk_804.036+git20260828+dfsg/examples/olduni0000664000175000017500000000335615151075633021140 0ustar georgeskgeorgesk#!/tools/local/perl -w use strict; use Tk; my $mw = MainWindow->new; my @but; my @tab; use Carp; #$SIG{__WARN__} = \&Carp::confess; my $page = 0; my $pagehex = '0x00'; my $l = $mw->Label(-text => 'Page:',-justify => 'right',-anchor => 'e'); my $s = $mw->Spinbox(-width => 4, -to => 255, -from => 0, -format => "%3.0f", -textvariable => \$page,-justify => 'left'); my $h = $mw->Label(-width => 4, -textvariable => \$pagehex, -justify => 'left'); Tk::grid($l,$s,$h); $s->configure(-command =>\&set_page); my $uf = $mw->fontCreate(-family => 'lucida sans', -size => 16); my $lf = $mw->fontCreate(-family => 'courier', -size => 12); print join(' ',$mw->fontActual($uf)),"\n"; my @h; my @lab; push @h,$mw->Label(-text => ''); for my $i (0x0..0xf) { my $l = $mw->Label(-text => sprintf("0x%04X",$i), -font => $lf, -justify => 'c', -anchor => 'c', -relief => 'ridge'); push(@h,$l); } Tk::grid(@h,-sticky => 'nsew'); for my $i (0x00..0xff) { my $s = chr($i); my $b = $mw->Button(-text => $s, -font => $uf, -justify => 'c', -anchor => 'c'); push(@but,$b); push(@tab,$b); if ($i % 16 == 15) { my $l = $mw->Label(-text => sprintf("0x%03X",$i & 0xF0), -font => $lf, -justify => 'c', -relief => 'ridge'); push(@lab,$l); Tk::grid($l,splice(@but,0,16),-sticky => 'nsew'); } } set_page($s); $mw->update; $mw->gridPropagate(0); MainLoop; sub set_page { my ($e) = @_; $pagehex = sprintf("0x%02X",$page); for my $i (0..0xf) { $lab[$i]->configure(-text => sprintf("0x%04X",($page<<8)+($i<<4))); } for my $i (0x00..0xFF) { my $b = $tab[$i]; my $u = ($page<<8) | $i; my $c = chr($u); my $s = $c; # "$c\n".sprintf("%02X",$i); # die "bug $i" unless utf8::valid($s); $b->configure(-text => $s); } } perl-tk_804.036+git20260828+dfsg/examples/after_leak0000775000175000017500000000124315151075633021737 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use Devel::Leak; $count = 0; sub flash_widget { my($w, $option, $val1, $val2, $interval) = @_; $w->configure($option => $val1); $w->after($interval, [\&flash_widget, $w, $option, $val2, $val1, $interval] ); $count++; } # end flash_widget $mw = MainWindow->new; $b = $mw->Button(-text => 'Flash', -bg => 'azure'); $b->pack; flash_widget $b, -background, 'azure', 'yellow', 40; $mw->update; print STDERR "Before ",$start = Devel::Leak::NoteSV($hook),"\n"; $count = 0; #MainLoop; while ($count < 100) { Tk::DoOneEvent(0); } print STDERR "After ",$end = Devel::Leak::CheckSV($hook),"\n"; print "Average ",($end-$start)/$count,"\n"; perl-tk_804.036+git20260828+dfsg/examples/iso8859-10000664000175000017500000000055015151075633021125 0ustar georgeskgeorgeskuse Tk; use Test; #use utf8; plan tests => (0x100-0xa0)*2; my $mw = MainWindow->new; my @but; for my $i (0xa0..0xff) { my $s = chr($i); push(@but,$mw->Button(-text => $s)); my $x = $but[-1]->cget('-text'); ok(ord($x),$i,"Number not equal"); ok($x,$s,"Text not equal"); if ($i % 16 == 15) { Tk::grid(splice(@but,0,16)); } } MainLoop; perl-tk_804.036+git20260828+dfsg/examples/motif_hack0000664000175000017500000000077115151075633021750 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Data::Dumper; use strict; use Tk; my $mw = MainWindow->new; my @info = $mw->property('get','_MOTIF_DRAG_WINDOW','root'); if (@info == 2 && $info[0] eq 'WINDOW') { my $dw = $info[1]; my @list = $mw->property('list',$dw); my $name; foreach $name (@list) { my $val = $mw->property('get',$name,$dw); print "$name length is ",length($val),"\n"; my @val = map(sprintf("%02X",$_),unpack('C*',$val)); print join(' ',@val),"\n"; print "\n"; } } perl-tk_804.036+git20260828+dfsg/examples/lsfonts0000775000175000017500000000023315151075633021330 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use Tk::Xlib; my $mw = MainWindow->new; foreach ($mw->Display->XListFonts('-*-Times-*',32768)) { print "$_\n"; } perl-tk_804.036+git20260828+dfsg/examples/popup_menu0000775000175000017500000000261415151075633022034 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use strict; use Tk; my $top = MainWindow->new; my $p = $top->Menu(-menuitems => [ '------', [Button => 'Quit', -command => ['destroy' => $top]], '------' ]); my $anchor = "c"; my $overanchor = "c"; my $where = $top; sub Show { $p->Popup(-popanchor => $anchor, -overanchor => $overanchor, -popover => $where); } sub Anchor { my ($top,$label,$var) = @_; my $out = $top->Frame(-label => $label,-relief => 'ridge',-borderwidth => 3); my $r; foreach $r ([qw(nw n ne)],[qw(w c e)],[qw(sw s se)]) { my $f = $out->Frame; foreach $a (@$r) { $b = $f->Radiobutton(-text=> $a, -variable => $var, -value => $a, -command => \&Show); $b->pack(-side => 'left'); } $f->pack; } return $out; } my $w = $top->Frame; my $b = $w->Radiobutton(-text => 'Window', -variable => \$where, -value => $top, -command => \&Show); $b->pack(-side=>'left'); $w->Radiobutton(-text => 'Screen', -variable => \$where, -value => undef, -command => \&Show)->pack(-side=>'left'); $w->Radiobutton(-text => 'Cursor', -variable => \$where, -value => 'cursor', -command => \&Show)->pack(-side=>'left'); $w->pack; Anchor($top,"Self",\$anchor)->pack(-side => 'left'); Anchor($top,"Over",\$overanchor)->pack(-side => 'right'); MainLoop; perl-tk_804.036+git20260828+dfsg/Funcs.doc0000664000175000017500000001245615151075633017653 0ustar georgeskgeorgeskFrom michael@santafe.edu Fri Mar 3 07:06:55 1995 Return-Path: Date: Fri, 3 Mar 95 00:03:19 MST From: michael@santafe.edu (Michael I Angerman) Message-Id: <9503030703.AA00785@sfi.santafe.edu> To: nTk@franz.ww.tu-berlin.de Cc: Nick.Ing-Simmons@tiuk.ti.com Cc: perl5-porters@africa.nicoh.com Cc: john@wpi.edu Cc: michael@santafe.edu Subject: Documentation on tkGlue.c P-From: michael@santafe.edu (Michael I Angerman) This is a complete listing of all the functions found in tkGlue.c as of version Tk-a13.tar.gz tkGlue.c is a very important file in the Tk distribution and so I thought I would begin to document this file since currently there are very few comments. I think one should consider possibly breaking up tkGlue.c into several files possibly based on the organization below. Any way, this documentation may be valuable to someone who has never looked at tkGlue.c before and wants to get an initial idea of what functions are located in this file. Enjoy perusing, Michael I Angerman The Santa Fe Institute 1399 Hyde Park Road Santa Fe, New Mexico 87501 michael@santafe.edu 505-984-8800 <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Cut Here >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Functions Based on Tcl ---------------------- Tcl_AddErrorInfo(interp, message) Tcl_AppendArg(interp, arg) Tcl_AppendElement(interp, string) Tcl_AppendResult(interp, va_alist) Tcl_ArgResult(interp, sv) Tcl_CallWhenDeleted(interp, proc, clientData) Tcl_CallbackResult(interp, sv) Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) Tcl_DeleteInterp(interp) Tcl_DoubleResults(interp, count, append, va_alist) Tcl_GetBoolean(interp, sv, boolPtr) Tcl_GetDouble(interp, sv, doublePtr) Tcl_GetInt(interp, sv, intPtr) Tcl_GetOpenFile(interp, string, doWrite, checkUsage, filePtr) Tcl_GetResult(interp) Tcl_GetVar(interp, varName, flags) Tcl_GetVar2(interp, sv, part2, flags) Tcl_IntResults(interp, count, append, va_alist) Tcl_Merge(argc, args) Tcl_Panic(char *fmt,...) Tcl_PosixError(interp) Tcl_RegExpCompile(interp, string) Tcl_RegExpExec(interp, re, string, start) Tcl_RegExpRange(re, index, startPtr, endPtr) Tcl_ResetResult(interp) Tcl_SetResult(interp, string, freeProc) Tcl_SetVar(interp, varName, newValue, flags) Tcl_SetVar2(interp, sv, part2, newValue, flags) Tcl_SprintfResult(Tcl_Interp * interp, char *fmt,...) Tcl_SprintfResult(interp, fmt, va_alist) Tcl_TildeSubst(interp, name, bufferPtr) Tcl_TraceVar(interp, varName, flags, proc, clientData) Tcl_TraceVar2(interp, sv, part2, flags, tkproc, clientData) Tcl_UntraceVar(interp, varName, flags, proc, clientData) Tcl_UntraceVar2(interp, sv, part2, flags, tkproc, clientData) Functions Based on Tk --------------------- Tk_AppendImage(interp, name) Tk_AppendWidget(interp, tkwin) Tk_BackgroundError(interp) Tk_ChangeScreen(interp, dispName, screenIndex) Tk_CreateImage(interp, cmdName, proc, clientData, deleteProc, typePtr) Tk_CreateWidget(interp, tkwin, proc, clientData, deleteProc) Tk_DeleteWidget(interp, tkwin) Tk_ImageResult(interp, name) Tk_MainWindow(interp) Tk_WidgetResult(interp, tkwin) Functions Based on Lang ----------------------- LangAllocVec(n) LangBadFile(fd) LangCallbackArg(sv) LangCatArg(out, sv, refs) LangClientMessage(interp, tkwin, event) LangCloseHandler(interp, arg, f, proc) LangCmpCallback(a, b) LangCopyArg(sv) LangCopyCallback(sv) LangDeadWindow(interp, tkwin) LangDoCallback(interp, sv, result, argc, va_alist) LangEval(interp, cmd, global) LangEventCallback(interp, sv, event, keySym) LangEventHook(flags) LangExit(value) LangFindVar(interp, tkwin, name) LangFreeArg(sv, freeProc) LangFreeCallback(sv) LangFreeVar(sv) LangFreeVec(count, p) LangMakeCallback(sv) LangMergeString(argc, args) LangMethodCall(interp, sv, method, result, argc, va_alist) LangNull(sv) LangPrint(sv) LangRestoreResult(interp, old) LangSaveResult(interp) LangSaveVar(interp,sv,vp,type) LangSetArg(sp, arg) LangSetDefault(sp, s) LangSetDouble(sp, v) LangSetImage(interp, argp, name) LangSetInt(sp, v) LangSetString(sp, s) LangSetSv(sp, arg) LangSetWidget(interp, argp, tkwin) LangString(sv) LangStringMatch(string, match) LangVarArg(sv) Lang_GetErrorCode(interp) Lang_GetErrorInfo(interp) Lang_SetErrorCode(interp, code) Lang_SplitList(interp, sv, argcPtr, argvPtr, freeProc) Other Function Definitions -------------------------- CopyAv(dst, src) FindAv(interp, who, create, key) FindHv(interp, who, create, key) InterpHv(interp) NameFromCv(cv) ResultAv(interp, who, create) Blessed(package, sv) Boot_Glue CallCallback(sv, flags) Call_Tk(info, items, args) Check_Eval(interp) Decrement(SV * sv, char *who) DumpStack _((void)) Dump_vec(who, count, data) EnterSubCommands(package, va_alist) EnterWidgetMethods(package, va_alist) EventToSv(ix,obj) GetWindow(sv) HandleBgErrors(clientData) ImageRef(interp, path) Increment(SV * sv, char *who) MakeReference(sv) Perl_GeomLostSlave(clientData,tkwin) Perl_GeomRequest(clientData,tkwin) Perl_Trace(ix, sv) PushCallbackArgs(interp, svp ,obj) PushVarArgs(ap,argc) SelGetProc(clientData,interp,portion,numItems,format,type,tkwin) TkToMainWindow(tkwin) TkToWidget(tkwin,pinterp) WidgetRef(interp, path) WindowCommand(sv, hv_ptr) XS(BindClientMessage) XS(DoWhenIdle) XS(FreeAbstract) XS(ManageGeometry) XS(SelectionGet) XS(XEventInfo) XS(XStoBind) XS(XStoSubCmd) XS(XStoTk) XS(XStoWidget) do_watch(void) handle_generic(clientData, eventPtr) handle_idle(clientData) SetTclResult(interp,count) perl-tk_804.036+git20260828+dfsg/Changes0000664000175000017500000006626415151075633017407 0ustar georgeskgeorgeskTk-804.036 release (2021-02-14) ------------------ This is basically the same like Tk-804.035_501. Tk-804.035_501 release (2021-02-07) ---------------------- Fixes Compiles again with Strawberry Perl 5.32.x (RT #133260) (H.Merijn Brand) Fix double free in validatecommand (RT #102648) (fvogel) myConfig: add ability to define HAVE_INTTYPES_H (Christopher Chavez) Smaller build improvements and typo corrections (Ed J., Christopher Chavez) Prevent some compiler warnings (Christopher Chavez) Documentation Several smaller Pod fixes (Christopher Chavez, asb-capfan) Tests Introduce CI testing with github actions Tk-804.035 release (2020-03-28) ------------------ This is basically the same like Tk-804.034_501. Tk-804.034_501 release (2020-03-19) ---------------------- Fixes Add dummy rules for newer EUMM (RT #124910) Try harder to find libpng on FreeBSD Tk-804.034_500 release (2020-02-23) ---------------------- Fixes Compiles again with perl 5.31.x (see also github pull request #61 and https://github.com/Perl/perl5/issues/17024 by Karl Williamson). Now ppport.h is included in the distribution. Switch to X's locale handling if needed (Karl Williamson) Don't use buttons 4 and 5 on non-X11 platforms (Christopher Chavez) Fix corner case in XPM handling (/* in colors section) Spelling/grammar fixes in comments and code (Christopher Chavez) Improved demo script photo1.pl (Christopher Chavez) Documentation Smaller Pod fixes (Slaven Rezic, Christopher Chavez) Tests travis-ci fixes Tk-804.034 release (2017-08-26) ------------------ This is basically the same like Tk-804.033_500. Tk-804.033_500 release (2017-08-20) ---------------------- Fixes Fix aborts on OS X Sierra, introduced by latest clang/llvm strcpy/strncpy (RT #121631, github pull request #28 by Mark Aufflick) No special xOKp handling in Perl_Value (RT #121528) Add freetype2 path on MacOSX / XQuartz to inc search paths (github pull request #21 by Christoph Lamprecht) Fix Tk::NoteBook's FindMenu (Martin Jacobs) Documentation Add Tk::getSaveFile Pod file (see also github pull request #19) Fix documentation about scrollbars (github pull request #18 by asb-cpan) Add openSUSE instructions to README.linux (github pull request #25 by Tux) Add documentation notes about "make -j" Tests New test for Tk::NoteBook. t/Trace.t is using now Test::More travis-ci improvements Introduce CI testing on appveyor Tk-804.033 release (2015-02-21) ------------------ Tests New t/pod.t test (github pull request #16) Tk-804.032_501 release (2015-01-31) ---------------------- Fixes Teach perl/Tk where OS X Yosemite Xquartz puts the X11 files (github pull request #12) Pushstack experiment to workaround crashes with perl 5.20.x and XFT=0 (RT #96543) Tk::Text: don't insert ctrl and meta key presses (github issue #9) Fix memory leak in canvas text item handling with XFT=1 (RT #100211) Use public version of Perl_utf8_hop (RT #100878) FixBuggyUTF8String is not called anymore for new perls Improvements Use Cwd::getcwd() instead of Cwd::cwd() (performance improvement) Tests t/font.t does not fail with only one font family installed (RT #99411) unicode.t - update textwidget before examining new state (RT #100153) Compatibility with old Test::More versions without note() and isa_ok class check Workaround for core dumps in some fork-using tests (RT #100399) Workaround for more timing problems in wm-tcl.h Tk-804.032_500 release (2014-11-06) ---------------------- Fixes Freetype header files may now be in /usr/include/freetype2/freetype.h in newer freetype installations (e.g. Debian/jessie). https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=740207 Tk::MainWindow::Create without args used to segfault. Fix X11 discovery on non-x86_64 platforms (RT #95590). Fix new sprintf warning with perl 5.21.x. Workaround behaviour change in ExtUtils::MakeMaker 6.99_10 (PERL value is now quoted), which caused build failures (RT #100044). Tests Fix race condition in t/errordialog.t t/create.t uses Test::More Remove useless hostname and getlogin retrieval in t/fileevent.t (RT #98889). Use pipe instead of stdin in t/fileevent2.t (RT #98891). Fix font-related issues with t/entry.t (RT #98831). Documentation New Pod ErrorDialog.pod (github pull request #6). Tk-804.032 release (2014-01-26) ------------------ This is basically the same like Tk-804.031_503. Tk-804.031_503 release (2013-12-07) ---------------------- Fixes Regain compatibility for perl < 5.8.9 (SvIV_nomg is not available with earlier perls). Tests wm-time.t more robust against GNOME Shell slowness. Tk-804.031_502 release (2013-12-01) ---------------------- Fixes Enable libpng configure for all Solaris architectures. Documentation Update INSTALL, README-ActiveState.txt, and README-Strawberry.txt documents. Tk-804.031_501 release (2013-11-18) ---------------------- Fixes Fix gamma setting for PNG images (was only broken in 804.031_500). Fix clang compilation error (was only broken in 804.031_500). Tests Some tests are now more robust. Tk-804.031_500 release (2013-11-17) ---------------------- Fixes RT# 88210: fix compilation for perl 5.19.0+ ("undef bool"). RT# 90077: floating number issue with -textvariable variables. RT# 89621: avoid segfaults during global destruction (by Gisle Aas). RT# 87016: compatibility for libpng 1.6.x. RT# 86988: use cflags/libs information from pkg-config zlib. RT# 89261: split Tk/ColorEditor.pm into three .pm files. RT# 71718: fix compilation issue with 64bit Strawberry Perl (Tk_Cursor). Fail gracefully if no font could be allocated. ptksh: storing the history works now also under Windows. Better handling if libpng's configure fails. Documentation Changes to README.linux (dependency requirements, fontconfig) and README.cygwin. Document special Tk::Table behavior regarding -takefocus => 0. Tests New test files (eventGenerate.t, sv.t) and new test cases (eventGenerate in optmenu.t). More test tweaks (e.g. skip some tests if the required fixed font is unavailable, see with_fixed_font in TkTest.pm, workaround some fvwm2 problems in wm-tcl.t, protect from haning wm-time.t). checked_test_harness() skips testing if no font could be allocated. No test request user positioning windows anymore (for old window managers like twm). Configuration file for travis-ci. Tk-804.031 release (2013-05-25) ---------- This is basically the same like Tk-804.030_502. Tk-804.030_502 release (2013-05-21) ---------------------- Fixes The CopSTASH_set fix did not work in 804.030_501 because of a missing file in the tarball. Now fixed. Tk::MakeDepend parses gcc's inc search list now and does not rely anymore on $Config{usrinc}. This helps when include files are partially in "multiarch" subdirectories (e.g. in Debian/sid) or when $Config{usrinc} is incorrect (e.g. in ActivePerl+gcc builds). RT #85407 and http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=708624 Helping Debian's build process by skipping the quilt state directory http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=708635 Improving build process for ActivePerl+gcc (RT #74036); see also README-ActiveState.txt. Use pkg-config for determining libpng cflags and libs. Tk-804.030_501 release (2013-05-18) ---------------------- Fixes Should compile again with older perls: SvNV_nomg is not available with perls older than 5.13.2, and CopSTASH_set(..., NULL) is not possible with threaded 5.16.x and older. Tk-804.030_500 release (2013-05-18) ---------------------- Incompatible changes The Tk::Text::Contents() method does not return an extra newline anymore (RT #83124). The version number of Tk::Text was incremented to 4.029 and may be used to detect the change. Fixes RT #78824: fixed compilation under threaded bleadperl (5.17.x) Fix for internal magic handling, needed for perl 5.17.2 and newer. Fixed myConfig issue with perl 5.17.x. SvUPGRADE() is no longer an expression since perl 5.17.7. Off-by-one error in Tk::Table::clear method (problem spotted by David Overeem). Tests RT #75347: skip unicode.t under some circumstances (e.g. problematic locales on Windows systems) RT #82664: fixed mismatched test count in entry.t Fixed Subwidget call in dirtree.t test. A couple of new test cases, conversions to Test::More... Documentation RT #79381: mention Tkx and Tcl::Tk Fixed return value for wrapper() in Tk::Wm Pod. Moved Tk::DragDrop Pods. "Tk::" prefix was missing in a number of Pods (original problem report by Fabien Dupont). Code cleanup Removed some unused static functions from tkGlue.c Simplified utf8 repair code in Tcl_GetStringFromObj. Tk-804.030 release (2011-10-20) ------------------ This is basically the same like Tk-804.029_502. Tk-804.029_502 release (2011-10-17) ---------------------- Fixes RT #71718: windres call needs the --use-temp-file on some Windows systems RT #70429: show correct file name if image loading failed. Also systematically searched and fixed other bad uses of Tcl_AppendResult. RT #70243: provide inuse method for Tk::Image Fixed a possible segfault when using canvas' select clear method. Tk-804.029_501 release (2011-10-14) ---------------------- Fixes Use standard libpng configure for all amd64 and x86_64 variants. Support gridRemove method. https://rt.cpan.org/Ticket/Display.html?id=65900 Tk-804.029_500 release (2011-06-13) ---------------------- Fixes Fixed compilation with newer X11 version (conflicting types for 'XKeycodeToKeysym') http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=613188 Use standard libpng configure for some 64 bit variants of OpenBSD, amd64-freebsd, x86_64-linux, MacOSX 10.6.4 and newer. Fixed Strawberry 64bit builds. Changed handling of "underscore" character. https://rt.cpan.org/Ticket/Display.html?id=66205 Tk::ProgressBar::configure calls now go through ConfigChanged https://rt.cpan.org/Ticket/Display.html?id=63775 Fixed Tk::FBox::ResolveFile with defaultextension when directory contains dots https://rt.cpan.org/Ticket/Display.html?id=55146 New features BalloonInfo for HList Implementation by Christoph Lamprecht, documentation by Slaven Rezic https://rt.cpan.org/Ticket/Display.html?id=55887 Perl/Tk is now available at github. Improved "all widgets at a glance" demo. Tests Another attempt on skipping tests if no DISPLAY is available. Converted fork.t and progbar.t to Test::More Documentation Fixed SYNOPSIS section in Tk::Text Pod Tk-804.029 release (2010-05-27) ------------------ This is basically the same like Tk-804.028_503. Tests after.t is a TODO test on Windows. Tk-804.028_503 release (2010-05-13) ---------------------- Fixes Tk::Text documentation mentioned -reverse where it should be -backwards. Also allow -forwards/-backwards to be abbreviated in FindNext call. https://rt.cpan.org/Ticket/Display.html?id=51552 Added WRITE method for tied Text widgets. https://rt.cpan.org/Ticket/Display.html?id=45818 Fixed display of Unicode characters in Windows toplevel menus. https://rt.cpan.org/Ticket/Display.html?id=50681 No special LDDLFLAGS handling on MacOSX systems, which probably caused an unusable Tk module (i.e. bus errors) http://rt.cpan.org/Public/Bug/Display.html?id=39593 Fixes Strawberry Perl builds (probably was broken on all 64bit systems) Informal patch by Eduard Wulff Tests A missing rgb.txt is no more an error in the Tk::ColorEditor tests, as rgb.txt may be missing completely in some X11 installations. Documentation Fixed minor typo in ProgressBar documentation https://rt.cpan.org/Ticket/Display.html?id=39182 Documented that -width and -height do not work with NoteBook widgets https://rt.cpan.org/Ticket/Display.html?id=52609 Tk-804.028_502 release (2010-01-30) ---------------------- Fixes Support for perl 5.11.2 and later (UTF8_MAXLEN_UCLC is not available anymore) http://rt.cpan.org/Public/Bug/Display.html?id=53465 Use 'configure' for building libpng under IRIX64 http://rt.cpan.org/Ticket/Display.html?id=40820 PNG did not build under AIX and IRIC64, unchecked fix http://rt.cpan.org/Ticket/Display.html?id=40064 http://rt.cpan.org/Ticket/Display.html?id=40820 Workaround for a perl bug (?) when using "eq" under a Japanese locale under Windows (sample fail report: http://www.nntp.perl.org/group/perl.cpan.testers/2008/11/msg2550386.html) Tk did not support more than 32 fds on 64bit machines http://rt.cpan.org/Ticket/Display.html?id=41158 Tk::Trace fix to make Tk::Gauge work http://rt.cpan.org/Ticket/Display.html?id=41069 Fixed some regular expression-related and other errors, patch by Alexander Krasnorutsky, see http://rt.cpan.org/Public/Bug/Display.html?id=41068 Workaround for SvREADONLY issue with 5.8.x http://rt.cpan.org/Public/Bug/Display.html?id=41436 Another possible rgb.txt location, by h.m.brand Fix for attaching balloons to items of scrolled widgets http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=246363 Fixed XIM event filtering. Fixed compilation with newer gcc http://rt.cpan.org/Ticket/Display.html?id=49499 RecolorTree was broken since Tk-804.027_501 if called separately. Reported and patched by Michael Parker http://rt.cpan.org/Public/Bug/Display.html?id=49515 Control-X/Y/C now also works if Caps Lock is active http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=205895 Copy/paste operations between KDE and Perl/Tk applications on 64bit system did not work, patch by Petr Pajas Canvas grids: -color was documented, but only -fill was implemented. In future both is supported. http://rt.cpan.org/Ticket/Display.html?id=47132 Patch for mingw-w64 gcc compiler, supplied by kmx http://rt.cpan.org/Public/Bug/Display.html?id=53467 Documentation Documentation on "Perl/Tk and Unicode" Fixed cget/delete confusion in Entry.pod http://rt.cpan.org/Public/Bug/Display.html?id=50253 Tk-804.028_501 release (2008-11-04) ---------------------- Fixes File permissions of the tarball seemed to be problematic under Windows Vista and Strawberry Perl 5.10.0.3, causing aborted builds. This is hopefully fixed now. Changed cygwin default to x11 (native MSWin32 port still does not work). New There's now an "examples" directory containing some useful scripts previously been elsewhere in the distribution. Documentation Documented ROText key bindings. New README for Strawberry Perl. Tests Prevent Event mini tests to be run when the rest of Tk is not tested, to avoid insignificant PASSes at cpantesters. More tests marked as TODO or SKIP. Tk-804.028_500 release (2008-10-01) ---------------------- Fixes Security fix for GIF reader (CVE-2006-4484, report and patch by Anicka Bernathova) Make sure Tk::MsgBox is not displayed before calling Show() Solved problems with fileevent on 64bit architectures (this also fixes a problem with POE) Makefile.PL updates (auto-creation of META.yml, added LICENSE, exit cleanly if prereqs are missing --- this is for cpan testers) Fixed typo in Tk::FBox http://rt.cpan.org/Public/Bug/Display.html?id=31989 Added different location of rgb.txt on Mac OS X 10.5.1 systems Fixed a makedepend issue, reported by marek.rouchal A BusyRecurse issue [rt.cpan.org #32858] Fixed Tk::ColorEditor problem with OpenBSD (another rgb.txt location) clipboardGet was documented, but did not work (note that clipboard("get") always worked) Tk::After::Cancelled needs also a dummy cancel() method Fixed event handling for newer X servers http://rt.cpan.org/Public/Bug/Display.html?id=38746 Permission issue [rt.cpan.org #39038] Support for changed regexp-related functions and structures in perl 5.11.x. Fix for: Tk::FileSelect fails to select file with "'" in file name (with new fileselect.t tests) http://rt.cpan.org/Public/Bug/Display.html?id=39096 Fixed movement of cursor on insertations in Tk::TextUndo http://rt.cpan.org/Public/Bug/Display.html?id=34513 Tk::Test fix for: skips lines when arrowing down in a window not exactly sized to a text http://rt.cpan.org/Public/Bug/Display.html?id=39343 ErrorDialog fix for Windows (dialog was never displayed) http://rt.cpan.org/Public/Bug/Display.html?id=39417 Use 'configure' for building libpng under Solaris. Tests Tests for signal handling (testing LangAsyncCheck introduced earlier) Various skips and $TODOs for broken (?) window managers and slow connections (for example -xscrollcommand-related, floating-point precision-related, signal availability and many more ...) Tk-804.028 release (2007-12-18) ------------------ Tests Fixed some test problems. Tk-804.027_502 release (2007-12-04) ---------------------- New features Merged with CPAN version of Tk::Tree Tk::Animation now reads delay and disposal information from GIF file (experimental, may change, needs an installed Image::Info) Fixes Make sure canvas methods are really accessible in OnDestroy. This fixes problems in the CPAN module Tk::LCD. Some path-related problems fixed with Tk::DirTree. Solved some Tk::ColorEditor issues (missing rgb.txt, multiple chooseColor invocations) Fixed some build problems under Windows. Fixed possible memory corruption (http://rt.cpan.org/Ticket/Display.html?id=24542) Dash patches by Wolfgang Laun (http://rt.cpan.org/Ticket/Display.html?id=11083) hpux ia64 should now compile. Tk::FBox: workaround for segfaults under threaded perl. Fixed possible performance problem when using Tk::Balloon and AutoLoader 5.63 is installed. Documentation Documented missing page_widget method in Tk::NoteBook. Tests Disabled more failing wm tests (notably on kwin). Tk-804.027_501 release (2007-09-22) ---------------------- Compiles and passes tests on FreeBSD 6.2 (amd64) + perl5.8.8 FreeBSD 6.2 (amd64) + perl5.10.0 patch 31894 FreeBSD 6.1 (i386) + perl5.8.8 Linux (Debian) + perl5.8.8 At some earlier point, there were success reports for the following configurations: * Solaris 8 (Sparc), gcc-4.0.3, perl-5.8.8 with freetype-2.2.1, expat-2.0.0, libXft-2.1.11, fontconfig-2.4.1, libXrender-0.9.2, renderproto-0.9.2, zlib-1.2.3, libjpeg-6b, libpng-1.2.14 * RedHat Enterprise Linux 3.0 update 8 (i686), gcc-4.0.3, perl-5.8.8 with freetype-2.2.1, expat-2.0.0, libXft-2.1.11, fontconfig-2.4.1, libXrender-0.9.2, renderproto-0.9.2, zlib-1.2.3, libjpeg-6b, libpng-1.2.14 * Windows, VC++ 6.0, perl-5.9.5 New features Implemented -overrelief,-repeatinterval,-repeatdelay for Tk::Button. Additional item in the "widget" demonstration showing all Tk widgets. Added BalloonInfo to NoteBook. ptked: Encoding menu now with radiobuttons, also added some popular encodings to menu. Fixes Fix for not working 'hide entry' in HList. HList: fixed errors with disabled entries and a entry named 0. Various warning fixes. Enable compiling of PNG-related files with Sun compiler. Fixed setPalette and RecolorTree. Make sure waitVariable exits if a waiting dialog is destroyed. Again compiles under bleadperl. Various fixes for 64bit platforms (e.g. property method, libpng building). Fixed situation when resizing a mainwindow containing a PNG image crashed Tk Tcl/Tk bug 979239 fixed by George Peter Staplin, brought to Perl/Tk by Franck Aniere. Adapt path for getOpen/SaveFile's -initialfile and -initialdir to the OS (patch provided by Roland Minner). Fixed not working -dynamicgeometry in Tk::NoteBook. Fixed zlib compilation problem under Windows (unistd.h does not exist there). Reported by esskar. Fixed configure problems on mixed 32/64 bit architectures, patch by Steve Lidie. Documentation Documented the Widget() method Widget.pod: resorted methods alphabetically Documented Tk::DialogBox::Exit Tests New test script for Button widget, yet uncomplete (t/button-tcl.t) New HList tests for show/hide font.t is more robust if unexpected fonts are used. The complete log of changes can be get using svn log https://svn.perl.org/modules/Tk/trunk Tk-804.027_500 release (2007-02-11) ---------------------- Compiles and passes tests on FreeBSD 6.1 + perl5.8.8 + fontconfig 2.3.2 FreeBSD 6.1 + bleadperl + fontconfig 2.3.2 Linux (Debian) + perl5.8.8 Windows 2000 + Strawberry Perl 5.8.8 alpha 2 Mac OS X 10.4 Solaris 10 + perl5.8.4 At some earlier point, there were successful builds with cygwin 1.5.x + perl5.8.7 + fontconfig (X11 build only) Solaris 8 Linux (RedHat 8.0) + perl5.8.0 New features The undocumented method font('subfonts') returns now more diagnostics. Library upgrades: libpng from 1.2.5 to 1.2.12 zlib from 1.1.4 to 1.2.3 It's possible to use binary (and not anymore base64 encoded) -data for GIF files. New -cancel_button option for Tk::DialogBox Fixes gedi accepts now X11 command line options. Encode.pm is specified as a PREREQ_PM. Fixed slow listbox itemconfigure. Fixed array return of Tk::Text::get method. Fixed Tk::BrowseEntry problem with -label* options, see http://perlmonks.org/?node_id=590170 Introduced LangAsyncCheck, which fixes http://rt.cpan.org/Ticket/Display.html?id=23879 Fixed http://bugs.activestate.com/show_bug.cgi?id=40231 (missing default button indicator on win32 for Tk::DialogBox widgets) Fixed http://bugs.activestate.com/show_bug.cgi?id=40217 (wm close window button does not call the default button) Fixed non-working Balloon attachments to individual menu items, see http://board.perl-community.de/cgi-bin/ikonboard/ikonboard.cgi?act=ST;f=3;t=665 As a side effect, there is now a new method Tk::Menu::MasterMenu for getting the master menu of a cloned menu. Adjuster now works in DialogBoxes, see http://groups.google.de/group/comp.lang.perl.tk/browse_frm/thread/5366757a4c6cd844/8ff9d1745d2b75b8 Fixed memory leak in after* callbacks, see http://rt.perl.org/rt3/Ticket/Display.html?id=41130 Fixed Tk:: FBox to treat special files like sockets, pipes as files, not as directories. Fixed -at/-before/-after problem with Tk::HList. Workaround for 'selection conversion left too many bytes unconverted' aborts. Documentation New Pod for Tk::MsgBox. Created a CAVEATS section in Tk::Image for the FAQ about memory leaks and images. Added missing L<...> links. Some minor Pod fixes. Tests Make sure that tests won't be run if no X11 is running to prevent unnecessary cpantesters reports. New test for Text widget (t/text.t) New test for scripts (t/exefiles.t) New test for Tk::Adjuster (t/adjuster.t) More Tk::FBox tests (e.g. chooseDirectory ...) Tests are now more robust if another application has the global grab (see catch_grabs in TkTest.pm). Tk-804.027-p4.patch.gz (2006-11-26) ---------------------- Compiles and passes tests on FreeBSD 6.1 + perl5.8.8 + fontconfig 2.3.2 FreeBSD 6.1 + bleadperl + fontconfig 2.3.2 Linux Debian + perl5.8.8 + fontconfig 2.4.1 Solaris 8 + gcc-4.0.3 + perl-5.8.8 + fontconfig-2.4.1 (with two test errors in font.t) I also had success with compiling under recent cygwin using the x11 libraries a few days earlier. Fixes XFT works now with recent fontconfig, no core dumps anymore. Fix for segfault in t/regexp.t with perl 5.9.x. See also http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-02/msg00748.html for a similar issue. Workaround for core dumps when using -font=>undef. Fixed wrong usage of $#{@...} which does not work anymore in bleadperl. Fixed Tk::Text movements wordstart and wordend in unicode content. Better handling of undef in BrowseEntry widgets. Bug reported by Puetz Kevin A. A couple of compilation warning fixes. Tests Continued text.t conversion. More tests in font.t. Fixed failing tests if no windows manager (under X11) is running. Fixed some false test failures in listbox.t (font detection was wrong). Disabled fork.t and fileevent.t on cygwin (same like MSWin32). Tk-804.027-p3.patch.gz (2006-11-20) ---------------------- Compiles and passes tests on FreeBSD 6.1 + perl5.8.8 + xorg 6.9.x + various window managers (fvwm2, twm, metacity ...) Linux RedHat 8.0 + perl5.8.0 (one test failure in leak.t) Linux RedHat 8.0 + perl5.8.7 MSWin32 + Strawberry Perl (5.8.8) There are some test failures with bleedperl, most of them Tie::Watch-related, which will be fixed in a next version of the patch. Incompatible changes Return values of some Tk::Wm methods (e.g. aspect, wmGrid, iconposition, resizable ...) were changed from returning tclish lists (e.g. "1 2 3 4") to perlish lists (1,2,3,4). I believe the return values of these methods are rarely used. Tk::Wm::wmTracing needs argument for setting on/off, without argument just return the current value. New features The newest tkUnixWm.c from Tcl/Tk is now in the Perl/Tk code. This adds (experimental?) support for wm attributes -topmost, -zoomed, -fullscreen and other _NET_WM features (iconphoto) under Unix/X11. Tk::Wm::stackorder was missing in Perl/Tk. widget demonstration has a Ctrl-Q key binding. ptksh: x is an alias for d (like in the perl debugger). ptksh: use bold font for prompt. Tk::Text: pasting selection with middle mouse sets cursor position now. This is consistent with behaviour in other toolkits. Tk::Widget: translated UnderlineAmpersand etc. functions. Tk::MsgBox: again in Tk, completely new translation from the Tcl/Tk original. Looks nicer and behaves better than messageBox through Tk::DialogBox. Fixes Fixed crashes of Perl/Tk applications when Gtk/Gnome applications were started. See http://rt.cpan.org/Ticket/Display.html?id=16053 ptksh is not slow anymore when popping up history. ptksh: use fixed font for text area. Tk::FBox may handle paths with high-bit set. Image and bitmap filenames with high-bit set work now. See http://groups.google.com/group/comp.lang.perl.tk/msg/865b56226af23f7c Minor Tk::TextList fixes, but still most tests fail. Fixed some menu problems, see http://rt.cpan.org/Public/Bug/Display.html?id=15677, http://rt.cpan.org/Ticket/Display.html?id=6166 Title of tearoff menus now set correctly. ptked may be started without initial filename. gedi works again. Fixed some core dumps. Tk::Listbox insert/delete does not leak memory anymore (well, not that much). See http://rt.cpan.org/Ticket/Display.html?id=12466 Building on RedHat systems works now, see http://rt.cpan.org/Ticket/Display.html?id=6708 Tk::NoteBook fix for pages method, see http://rt.cpan.org/Ticket/Display.html?id=8567 Tk::Canvas fix for -state => hidden issue, see http://rt.cpan.org/Ticket/Display.html?id=4677 Documentation Tk::Widget::Walk is now documented. Corrected installation path for Tk::Menu::Item. Fixed invalid Pod syntax. Tests Converted some tests from Test to Test::More Enable unicode tests where possible. Make all tests working with XFT=1. New tests, converted from the Tcl counterparts: canvas.t, wm-tcl.t, text.t (latter not completed yet) 00wmcheck.t: show user's window manager before starting tests. (Almost) no test should request user positioning windows (for old window managers like twm). Some wm-dependent tests were marked as TODO tests. ---------------------------------------------------------------------- Within each 'release' time advances down the file, but most recent release is at the top. Change.log is generated from perforce database, it is therefore complete, but short on detail. Changes in Tk804.023 First public release of version based on Unicode aware core tk. Historical changes in Tk800 branch to be reinstated here later. perl-tk_804.036+git20260828+dfsg/Extensions/0000775000175000017500000000000015151075633020235 5ustar georgeskgeorgeskperl-tk_804.036+git20260828+dfsg/Extensions/ImageBack/0000775000175000017500000000000015151075633022040 5ustar georgeskgeorgeskperl-tk_804.036+git20260828+dfsg/Extensions/ImageBack/Makefile.PL0000664000175000017500000000017715151075633024017 0ustar georgeskgeorgesk use Tk::MMutil; Tk::MMutil::TkExtMakefile( 'XS_VERSION' => $Tk::Config::VERSION, # 'dynamic_ptk' => 1 ); perl-tk_804.036+git20260828+dfsg/Extensions/ImageBack/background0000775000175000017500000000040615151075633024105 0ustar georgeskgeorgesk#!/usr/local/bin/perl -w use Tk; use Tk::ImageBack; use Tk::Photo; my $mw = MainWindow->new; my $image = $mw->Photo('back', -file => Tk->findINC('icon.gif')); my $t = $mw->Frame(-width => '4i', -height => '2i')->pack; $t->ImageBackground('back'); MainLoop; perl-tk_804.036+git20260828+dfsg/Extensions/ImageBack/ImageBack.pm0000664000175000017500000000041115151075633024175 0ustar georgeskgeorgeskpackage # hide from CPAN indexer Tk::ImageBack; require DynaLoader; use vars qw($VERSION); $VERSION = '4.005'; # $Id: //depot/Tkutf8/Extensions/ImageBack/ImageBack.pm#4 $ use Tk qw($XS_VERSION); use base qw(DynaLoader); bootstrap Tk::ImageBack; 1; __END__ perl-tk_804.036+git20260828+dfsg/Extensions/ImageBack/MANIFEST.SKIP0000664000175000017500000000006715151075633023741 0ustar georgeskgeorgesk\bblib/ %$ \.(o|bs|bak|old)$ ImageBack\.c$ \bMakefile$ perl-tk_804.036+git20260828+dfsg/Extensions/ImageBack/README0000664000175000017500000000052115151075633022716 0ustar georgeskgeorgeskA pretty pointless extension which makes ->ImageBackground method available. As nearly all Tk widgets draw in off-screen Pixmap about only use is for bits of Frames not obscured by sub-windows. (I had hoped to use it for HTML3's background attribute...) It serves as an example of how an Extension can be built after Tk is installed. perl-tk_804.036+git20260828+dfsg/Extensions/ImageBack/ImageBack.xs0000664000175000017500000000345715151075633024230 0ustar georgeskgeorgesk/* Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. */ #define PERL_NO_GET_CONTEXT #include #include #include #include #include #include #include #include #include DECLARE_VTABLES; static void Tk_ImageBackground _((Tk_Window win, char *imageString)); static void ButtonImageProc _((ClientData clientData, int x, int y, int width, int height, int imgWidth, int imgHeight)); static void BackgroundImageProc(clientData, x, y, width, height, imgWidth, imgHeight) ClientData clientData; /* Pointer to widget record. */ int x, y; /* Upper left pixel (within image) * that must be redisplayed. */ int width, height; /* Dimensions of area to redisplay * (may be <= 0). */ int imgWidth, imgHeight; /* New dimensions of image. */ { } static void Tk_ImageBackground(tkwin, imageString) Tk_Window tkwin; char *imageString; { Display *dpy = Tk_Display(tkwin); Tcl_Interp *interp = ((TkWindow*) tkwin)->mainPtr->interp; Tk_Image image = Tk_GetImage(interp, tkwin, imageString, BackgroundImageProc, (ClientData) tkwin); int width, height; Pixmap pixmap; Tk_SizeOfImage(image, &width, &height); Tk_MakeWindowExist(tkwin); pixmap = Tk_GetPixmap(dpy, Tk_WindowId(tkwin), width, height, Tk_Depth(tkwin)); Tk_RedrawImage(image, 0, 0, width, height, pixmap, 0, 0); Tk_SetWindowBackgroundPixmap(tkwin, pixmap); Tk_FreePixmap(dpy, pixmap); Tk_FreeImage(image); } MODULE = Tk::ImageBack PACKAGE = Tk PREFIX = Tk_ PROTOTYPES: DISABLE void Tk_ImageBackground(tkwin, imageString) Tk_Window tkwin char * imageString BOOT: { IMPORT_VTABLES; } perl-tk_804.036+git20260828+dfsg/Extensions/ImageBack/MANIFEST0000664000175000017500000000013315151075633023166 0ustar georgeskgeorgeskImageBack.d ImageBack.pm ImageBack.xs MANIFEST MANIFEST.SKIP Makefile.PL README background perl-tk_804.036+git20260828+dfsg/Entry/0000775000175000017500000000000015151075633017177 5ustar georgeskgeorgeskperl-tk_804.036+git20260828+dfsg/Entry/Makefile.PL0000664000175000017500000000012015151075633021142 0ustar georgeskgeorgesk use Tk::MMutil; Tk::MMutil::TkExtMakefile( 'dynamic_ptk' => 1 ); perl-tk_804.036+git20260828+dfsg/Entry/Entry.pm0000664000175000017500000003707615151075633020653 0ustar georgeskgeorgeskpackage Tk::Entry; # Converted from entry.tcl -- # # This file defines the default bindings for Tk entry widgets. # # @(#) entry.tcl 1.22 94/12/17 16:05:14 # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. # This program is free software; you can redistribute it and/or use vars qw($VERSION); use strict; $VERSION = '4.018'; # sprintf '4.%03d',q$Revision: #17 $ =~ /#(\d+)/; # modify it under the same terms as Perl itself, subject # to additional disclaimer in license.terms due to partial # derivation from Tk4.0 sources. use Tk::Widget (); use Tk::Clipboard (); use base qw(Tk::Clipboard Tk::Widget); import Tk qw(Ev $XS_VERSION); Construct Tk::Widget 'Entry'; bootstrap Tk::Entry; sub Tk_cmd { \&Tk::entry } Tk::Methods('bbox','delete','get','icursor','index','insert','scan', 'selection','validate','xview'); use Tk::Submethods ( 'selection' => [qw(clear range adjust present to from)], 'xview' => [qw(moveto scroll)], ); sub wordstart {my ($w,$pos) = @_; my $string = $w->get; $pos = $w->index('insert')-1 unless(defined $pos); $string = substr($string,0,$pos); $string =~ s/\S*$//; length $string; } sub wordend {my ($w,$pos) = @_; my $string = $w->get; my $anc = length $string; $pos = $w->index('insert') unless(defined $pos); $string = substr($string,$pos); $string =~ s/^(?:((?=\s)\s*|(?=\S)\S*))//x; $anc - length($string); } sub deltainsert { my ($w,$d) = @_; return $w->index('insert')+$d; } # # Bind -- # This procedure is invoked the first time the mouse enters an # entry widget or an entry widget receives the input focus. It creates # all of the class bindings for entries. # # Arguments: # event - Indicates which event caused the procedure to be invoked # (Enter or FocusIn). It is used so that we can carry out # the functions of that event in addition to setting up # bindings. sub ClassInit { my ($class,$mw) = @_; $class->SUPER::ClassInit($mw); # <>, <> and <> defined in Tk::Clipboard $mw->bind($class,'<>' => sub { my $w = shift; $w->delete("sel.first", "sel.last"); }); $mw->bind($class,'<>' => [sub { my($w, $x) = @_; # XXX logic in Tcl/Tk version screwed up? if (!$Tk::strictMotif && !$Tk::mouseMoved) { $w->Paste($x); } }, Ev('x')]); # Standard Motif bindings: # The binding is different from the Tcl/Tk version: $mw->bind($class,'','selectionClear'); $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]); $mw->bind($class,'',['Button1Release',Ev('x'),Ev('y')]); $mw->bind($class,'',['Motion',Ev('x'),Ev('y')]); $mw->bind($class,'',['MouseSelect',Ev('x'),'word','sel.first']); $mw->bind($class,'',['MouseSelect',Ev('x'),'word']); $mw->bind($class,'',['MouseSelect',Ev('x'),'line',0]); $mw->bind($class,'',['MouseSelect',Ev('x'),'line']); $mw->bind($class,'','Shift_1'); $mw->bind($class,'',['AutoScan',Ev('x')]); $mw->bind($class,'','CancelRepeat'); $mw->bind($class,'','Control_1'); $mw->bind($class,'', ['SetCursor',Ev('deltainsert',-1)]); $mw->bind($class,'',['SetCursor',Ev('deltainsert',1)]); $mw->bind($class,'',['KeySelect',Ev('deltainsert',-1)]); $mw->bind($class,'',['KeySelect',Ev('deltainsert',1)]); $mw->bind($class,'',['SetCursor',Ev(['wordstart'])]); $mw->bind($class,'',['SetCursor',Ev(['wordend'])]); $mw->bind($class,'',['KeySelect',Ev(['wordstart'])]); $mw->bind($class,'',['KeySelect',Ev(['wordend'])]); $mw->bind($class,'',['SetCursor',0]); $mw->bind($class,'',['KeySelect',0]); $mw->bind($class,'',['SetCursor','end']); $mw->bind($class,'',['KeySelect','end']); $mw->bind($class,'','Delete'); $mw->bind($class,'','Backspace'); $mw->bind($class,'',['selectionFrom','insert']); $mw->bind($class,'