Tcl-Tk
view release on metacpan or search on metacpan
- fix lost file Tcl/Tk/Widget/Text.pm borrowed from perlTk
- actually make CPAN indexer happy
0.94 09-may-2007
- Separator widget
- check for snit package
0.92 17-oct-2006
- robust implementation of creation of widgets package
- Scrolled improvement - now wrapped widget could be dealt directly
- 'bind' now much better
0.91 16-oct-2006
- starting from 0.90 snit is a requirement
- Scrolled reimplementation
- awkward Tcl::Tk::Widget::MultipleWidget gone away
- Optionmenu better implementation
- Declare(...) is now also interpreter method
0.90 25-aug-2006
- ROText better implementation
- pannedwindow => panedwindow (Jeff Hobbs)
- DEBUG now off by default
- Meta.yml
- README
- perlTk compatibility:
* Listbox/perlTk => listbox
* Tcl::Tk::Exists (Tk::Exists)
* 'Darken' widget method (borrowed from Widget.pm/perlTk)
* 'timer' behaves like widget
* replaced options now could be subroutine ref
* canvas bind
* Photo
* Menu, Menubutton much more capable now
* few others (wm, winfo, ...)
0.74 21-mar-2004, Vadim Konovalov
- accept many changes from Jeff Hobbs, TCL guru and lead developer:
* pannedwindow
* menu widget
* many cleanup of code
- accept changes from Slaven Rezic, wishlist 5656 from rt.cpan.org,
tk-demos/images/flagup.bmp
tk-demos/images/gray25.bmp
tk-demos/images/letters.bmp
tk-demos/images/noletter.bmp
tk-demos/images/pattern.bmp
tk-demos/images/tcllogo.gif
tk-demos/images/teapot.ppm
tk-demos/widget
tk-demos/widget_lib/arrows.pl
tk-demos/widget_lib/Ball.pm
tk-demos/widget_lib/bind.pl
tk-demos/widget_lib/bitmaps.pl
tk-demos/widget_lib/bounce.pl
tk-demos/widget_lib/button.pl
tk-demos/widget_lib/check.pl
tk-demos/widget_lib/clrpick.pl
tk-demos/widget_lib/colors.pl
tk-demos/widget_lib/cscroll.pl
tk-demos/widget_lib/ctext.pl
tk-demos/widget_lib/dialog1.pl
tk-demos/widget_lib/dialog2.pl
tk-demos/widget_lib/mkLabel.pl
tk-demos/widget_lib/mkListbox.pl
tk-demos/widget_lib/mkListbox2.pl
tk-demos/widget_lib/mkListbox3.pl
tk-demos/widget_lib/mkPlot.pl
tk-demos/widget_lib/mkPuzzle.pl
tk-demos/widget_lib/mkRadio.pl
tk-demos/widget_lib/mkRuler.pl
tk-demos/widget_lib/mkScroll.pl
tk-demos/widget_lib/mkStyles.pl
tk-demos/widget_lib/mkTextBind.pl
tk-demos/widget_lib/mkTextWind.pl
tk-demos/widget_lib/mkTxtSearch.pl
tk-demos/widget_lib/mkVScale.pl
tk-demos/widget_lib/msgBox.pl
tk-demos/widget_lib/plot.pl
tk-demos/widget_lib/puzzle.pl
tk-demos/widget_lib/radio.pl
tk-demos/widget_lib/ruler.pl
tk-demos/widget_lib/sayings.pl
tk-demos/widget_lib/search.pl
NAME
Tcl::Tk extension module for Perl5
DESCRIPTION
The Tcl::Tk extension (not to be confused with the "native" perl5 Perl/Tk
extension) provides a raw but complete interface to the whole of Tk via the Tcl
extension.
Tcl::Tk is pure-perl, with all binary bindings offloaded to Tcl perl module.
Tcl::Tk has full support for perl/Tk syntax. This does not mean 100%
compatibility though. perl/Tk syntax is taken, but it is not followed when it
is not tcl/tk compatible. Do not expect full perl/tk compatibility, just use
the same syntax.
This approach allows you to intermix tcl/tk and perl/tk code, for example you
can use pure-tcl to create entire GUI and then use perl/Tk syntax to access
individual widgets. This also allows you to design GUI with any tcl/tk GUI
designer.
demos/activex.pl view on Meta::CPAN
# This file demonstrates the Calendar control being
# integrated within a Tk widget
#####################################################
use strict;
use Tcl::Tk qw(:widgets);
my $interp = new Tcl::Tk;
# in case we want to do some debugging
$interp->bind('.', '<F2>', 'console show');
my $t = text(".t", -height=>1, -width=>20,-font => "-*-Arial Unicode MS--R---*-350-*-*-*-*-*-*")->pack;
$t->insert("end", "thishishis\x{5678}\x{265c}\x{265d}\x{265e}\x{2345}\x{2346}\x{2347}");
# optcl load happens here
$interp->Eval('package require optcl');
my $cd = '***';
label(".cd", -bd=>1, -relief=>'sunken', -textvariable=>\$cd)
->pack(qw/-side bottom -fill x/);
demos/wcolors.pl view on Meta::CPAN
my $mw = Tcl::Tk::MainWindow->new();
my $frtop = $mw->Frame->pack(-side=>'top', -expand=>1, -fill=>'x');
my $t = $mw->Scrolled(qw/Text -relief sunken -borderwidth 2 -scrollbars osoe/
)->pack(-expand=>1, -fill=>'both');
my $color = 'White';
my $e = $frtop->Entry(-textvariable=>\$color)->pack(-side=>'left');
sub try_color {
print STDERR "$color\n";
$t->configure(-bg=>$color);
}
$e->bind('<Return>',\&try_color);
$frtop->Button(-text=>'try color',-command=>\&try_color)
->pack(-side=>'left');
for (@colors) {
$t->windowCreate('end',-window=>$mw->Frame(-bg=>$_,-width=>'5c',-height=>'1c'));
$t->windowCreate('end',-window=>$mw->Button(-bg=>$_,-text=>$_,
-command=> "$t configure -bg $_; puts $_"
));
$t->_insertEnd("$_\n");
}
lib/Tcl/Fallback/scrollw.pm view on Meta::CPAN
# -size -default 0 ; scrollbar -width (not recommended to change)
# -ipad -default {0 0} ; represents internal {x y} padding between
# ; scrollbar and given widget
# All other options to frame
#
# Methods
# $path getframe => $frame
# $path setwidget $widget => $widget
# All other methods to frame
#
# Bindings
# NONE
#
if 0 {
# Samples
package require widget::scrolledwindow
#set sw [widget::scrolledwindow .sw -scrollbar vertical]
#set text [text .sw.text -wrap word]
#$sw setwidget $text
#pack $sw -fill both -expand 1
lib/Tcl/Fallback/scrollw.pm view on Meta::CPAN
-orient horizontal -takefocus 0
install vscroll using scrollbar $win.vscroll \
-orient vertical -takefocus 0
# in case the scrollbar has been overridden ...
catch {$hscroll configure -highlightthickness 0}
catch {$vscroll configure -highlightthickness 0}
}
set hsb(bar) $hscroll
set vsb(bar) $vscroll
bind $win <Configure> [mymethod _realize $win]
grid columnconfigure $win 1 -weight 1
grid rowconfigure $win 1 -weight 1
set pending [after idle [mymethod _setdata]]
$self configurelist $args
}
destructor {
after cancel $pending
lib/Tcl/Fallback/scrollw.pm view on Meta::CPAN
grid $sb(bar) -column $sb(col) -row $sb(row) \
-sticky $sb(sticky) -padx $sb(padx) -pady $sb(pady)
} else {
grid remove $sb(bar)
}
}
}
method _realize {w} {
if {$w eq $win} {
bind $win <Configure> {}
set realized 1
}
}
}
package provide widget::scrolledwindow 1.2.1
EOS
lib/Tcl/Fallback/snit1.pm view on Meta::CPAN
}
# Execute the type's constructor, and verify that it
# has a hull.
set errcode [catch {
RT.ConstructInstance $type $selfns $name $args
::snit::RT.Component $type $selfns hull
# Prepare to call the object's destructor when the
# <Destroy> event is received. Use a Snit-specific bindtag
# so that the widget name's tag is unencumbered.
bind Snit$type$name <Destroy> [::snit::Expand {
::snit::RT.DestroyObject %TYPE% %NS% %W
} %TYPE% $type %NS% $selfns]
# Insert the bindtag into the list of bindtags right
# after the widget name.
set taglist [bindtags $name]
set ndx [lsearch -exact $taglist $name]
incr ndx
bindtags $name [linsert $taglist $ndx Snit$type$name]
} result]
if {$errcode} {
global errorInfo
global errorCode
set theInfo $errorInfo
set theCode $errorCode
::snit::RT.DestroyObject $type $selfns $name
error "Error in constructor: $result" $theInfo $theCode
lib/Tcl/Fallback/snit1.pm view on Meta::CPAN
# If it is a widget, get the hull component's name, and rename
# it back to the widget name
# Next, delete the hull component's instance command,
# if there is one.
if {$Snit_info(isWidget)} {
set hullcmd [::snit::RT.Component $type $selfns hull]
catch {rename $instance ""}
# Clear the bind event
bind Snit$type$win <Destroy> ""
if {[llength [info commands $hullcmd]]} {
# FIRST, rename the hull back to its original name.
# If the hull is itself a megawidget, it will have its
# own cleanup to do, and it might not do it properly
# if it doesn't have the right name.
rename $hullcmd ::$instance
# NEXT, destroy it.
destroy $instance
lib/Tcl/Tk.pm view on Meta::CPAN
This method creates "scrolled" type of widget for a given widget type within
Tcl/Tk. For example:
$int->create_scrolled_widget("canvas");
$int->Eval('scrolled_canvas .scanv');
This way you can even create a perl/Tk-style widget to be initially scrollable:
$int->create_scrolled_widget("text"); # introduce scrolled_text in Tcl/Tk
$int->Declare('SText','scrolled_text'); # bind scrolled_text to Tcl::Tk as SText
# now use SText instead of Scrolled('Text',...) everywhere in program
$int->mainwindow->SText->pack(-fill=>'both');
The scrolling is taken from snit (scrodgets), and the resulting widget have
both scrolled options/methods and widget's options/methods.
=head1 Points of special care
=over
lib/Tcl/Tk.pm view on Meta::CPAN
# Pass methods and options to proper widgets
delegate option -scrollbar to hull
delegate option -auto to hull
delegate option -sides to hull
delegate option -size to hull
delegate option -ipad to hull
delegate method setwidget to hull
delegate method C-size to hull
delegate method C-ipad to hull
delegate option * to widg except {-scrollbars}
delegate method * to widg except {setwidget C-size C-ipad bind}
method bind_path {} {return \$win.w}
## method "bind" should call "bind \$win.w \$args
method bind {args} {
# (why not works "bind \$win.w \$args" ??)
bind \$win.w [lindex \$args 0] [lindex \$args 1]
}
method Subwidget {name} { return \$win.w }
}
}
EOS
}
# sub Declare is just a dispatcher into Tcl::Tk::Widget method
sub Declare {
Tcl::Tk::Widget::Declare(undef,@_[1..$#_]);
lib/Tcl/Tk.pm view on Meta::CPAN
my $self = shift;
$self->interp->call("lower",$self,@_);
$self;
}
sub raise {
my $self = shift;
my $wp = $self->path;
$self->interp->call('raise',$wp,@_);
}
# helper sub _bind_widget_helper inserts into subroutine callback
# widget as parameter
sub _bind_widget_helper {
my $self = shift;
my $sub = shift;
if (ref($sub) eq 'ARRAY') {
if ($#$sub>0) {
if (ref($sub->[1]) eq 'Tcl::Ev') {
$sub = [$sub->[0],$sub->[1],$self,@$sub[2..$#$sub]];
}
else {
$sub = [$sub->[0],$self,@$sub[1..$#$sub]];
}
}
else {
$sub = [$sub->[0], $self];
}
return $sub;
}
else {
return sub{$sub->($self,@_)};
}
}
sub bind_path { # this is overridden in scrolled widgets
return shift->path;
}
sub bind {
my $self = shift;
if ($_[0] =~ /^</) {
# A sequence was specified - assume path from widget instance
$self->interp->call("bind",$self->bind_path,@_);
} else {
# Not a sequence as first arg - don't assume path
$self->interp->call("bind",@_);
}
}
sub tag {
my ($self,$verb,$tag, @rest) = @_;
if ($verb eq 'bind') {
return $self->tagBind($tag,@rest);
}
$self->interp->call($self, 'tag', $verb, $tag, @rest);
}
sub tagBind {
my $self = shift;
if ($#_==3 and ref($_[2]) eq 'REF') {
my ($tag, $seq, $ref, $sub) = @_;
$sub = $self->_bind_widget_helper($sub);
return $self->interp->call($self,'tag','bind',$tag,$seq,$ref,$sub);
}
my ($tag, $seq, $sub) = @_;
# 'text'
# following code needs only to insert widget as a first argument to
# subroutine
$sub = $self->_bind_widget_helper($sub);
$self->interp->call($self, 'tag', 'bind', $tag, $seq, $sub);
}
sub form {
my $self = shift;
my $int = $self->interp;
$int->pkg_require("Tix");
my @arg = @_;
for (@arg) {
if (ref && ref eq 'ARRAY') {
$_ = join ' ', map {
lib/Tcl/Tk.pm view on Meta::CPAN
# for compatibility (TODO -- more methods could be AUTOLOADed)
sub GeometryRequest {
my $self = shift;
my $wp = $self->path;
my ($width,$height) = @_;
$self->interp->call('wm','geometry',$wp,"=${width}x$height");
}
sub OnDestroy {
my $self = shift;
my $wp = $self->path;
$self->interp->call('bind','<Destroy>',$wp,@_);
}
sub grab {
my $self = shift;
my $wp = $self->path;
$self->interp->call('grab',$wp,@_);
}
sub grabRelease {
my $self = shift;
my $wp = $self->path;
$self->interp->call('grab','release',$wp,@_);
lib/Tcl/Tk.pm view on Meta::CPAN
}
# Balloon
sub _prepare_ptk_Balloon {
require Tcl::Tk::Widget::Balloon;
}
# Listbox
sub _prepare_ptk_Listbox {
create_method_in_widget_package ('Listbox',
bind => sub {
my $self = shift;
if ($#_=1 && ref($_[1]) =~ /^(?:ARRAY|CODE)$/) {
my ($seq, $sub) = @_;
$sub = $self->_bind_widget_helper($sub);
$self->interp->call('bind',$self->bind_path,$seq,$sub);
}
else {
$self->interp->call('bind',$self->bind_path,@_);
}
}
);
}
# Canvas
sub _prepare_ptk_Canvas {
create_method_in_widget_package ('Canvas',
bind => sub {
my $self = shift;
if ($#_==2) {
my ($tag, $seq, $sub) = @_;
$sub = $self->_bind_widget_helper($sub);
$self->interp->call($self->bind_path,'bind',$tag,$seq,$sub);
}
elsif ($#_==1 && ref($_[1]) =~ /^(?:ARRAY|CODE)$/) {
my ($seq, $sub) = @_;
$sub = $self->_bind_widget_helper($sub);
$self->interp->call($self->bind_path,'bind',$seq,$sub);
}
else {
$self->interp->call($self->bind_path,'bind',@_);
}
},
CanvasBind => sub {
my $self = shift;
my $item = shift;
$self->bind($item,@_);
},
CanvasFocus => sub {
my $self = shift;
$self->interp->call($self->path,'focus',@_);
},
);
}
# menu compatibility
sub _process_menuitems;
lib/Tcl/Tk.pm view on Meta::CPAN
my $bot = $dlg->Frame();
$bot->pack(-side => "bottom", -fill => "x", -expand => 0);
my $btn;
my $defbtn;
foreach (reverse @{$args{'-buttons'}}) {
$btn = $bot->Button(-text => $_,
-command => ['set', '::tk::Priv(button)', "$_"]);
if ($args{'-default_button'} && $_ eq $args{'-default_button'}) {
$defbtn = $btn;
$btn->configure(-default => "active");
# Add <Return> binding to invoke the default button
$dlg->bind('<Return>', ["$btn", "invoke"]);
}
if ($^O eq "MSWin32") {
# should be done only on Tk >= 8.4
$btn->configure(-width => "-11");
}
$btn->pack(-side => "right", -padx => 4, -pady => 5);
}
# We need to create instance methods for dialogs to handle their
# perl-side instance variables -popover and -default_button
$dlg->widget_data->{'-popover'} = $args{'-popover'} || "cursor";
$dlg->widget_data->{'-default'} = $defbtn;
# Add Escape and Destroy bindings to trigger vwait
# XXX Remove special hash items as well
$dlg->bind('<Destroy>', 'set ::tk::Priv(button) {}');
$dlg->bind('<Escape>', 'set ::tk::Priv(button) {}');
my $wtype = 'DialogBox';
create_widget_package($wtype);
create_method_in_widget_package($wtype,
add => sub {
my $wid = shift;
my $int = $wid->interp;
my $wtype = shift;
my %args = @_;
my $subw;
{
lib/Tcl/Tk.pm view on Meta::CPAN
create_widget_package($wtype);
create_method_in_widget_package ($wtype,
Subwidget => sub {
my $self = shift;
my $name = shift;
my $int = $self->interp;
my $subwid = $int->call($self->path, 'Subwidget', $name);
return $int->widget($subwid,$wtype);
},
bind_path => sub {
my $self = shift;
return $self->interp->invoke($self->path, "bind_path");
},
);
my $w = w_uniq($self, "scrw"); # return unique widget id
my $scrw = $int->declare_widget($int->call("scrolled_$lwtype", $w, %args), "Tcl::Tk::Widget::$wtype");
return $scrw;
}
# end-of-scrolled
# ----------------------------------------------------------------------------
lib/Tcl/Tk.pm view on Meta::CPAN
sub DESTROY {} # do not let AUTOLOAD catch this method
#
# Let Tcl/Tk process required method via AUTOLOAD mechanism
#
# %lists hash holds names of methods returning *list* of values
# (all methods not listed here are expected to return single value)
my %lists = map {$_=>1} qw(
bbox configure dlineinfo dump
markNames tagBind tagRanges tagPrevrange tagNextrange
formInfo formSlaves
curselection
windowNames
);
sub AUTOLOAD {
my $w = shift;
my ($method,$package,$wtype) = ($Tcl::Tk::Widget::AUTOLOAD,undef,undef);
for ($method) {
s/^(Tcl::Tk::Widget::((MainWindow|$ptk_w_names)::)?)//
or die "weird inheritance ($method)";
lib/Tcl/Tk/Widget/Balloon.pm view on Meta::CPAN
my $msg = delete $args{-msg};
$msg ||= delete $args{-balloonmsg};
$$msg = '*****';
$int->call($bw->path.'.f2.message','configure',-textvariable=>$msg);
delete $args{$_} for qw(-postcommand -motioncommand -balloonposition); # TODO!
for (qw(-initwait)) {
if (exists $args{$_}) {
$bw->configure($_,delete $args{$_});
}
}
$int->call($bw,'bind',$w,%args);
}
sub detach {
my $bw = shift;
my $w = shift;
my $int = $bw->interp;
$int->call($bw,'unbind',$w,@_);
}
sub DESTROY {} # do not let AUTOLOAD catch this method
sub AUTOLOAD {
print STDERR "<<@_>>\n" if $Tcl::Tk::DEBUG > 2;
$Tcl::Tk::Widget::AUTOLOAD = $Tcl::Tk::Widget::Balloon::AUTOLOAD;
return &Tcl::Tk::Widget::AUTOLOAD;
}
lib/Tcl/Tk/Widget/Text.pm view on Meta::CPAN
-command => sub {$w->FindAndReplaceAll
($mode,$case,$find_entry->get(),$replace_entry->get());} )
->pack(-side => 'left');
}
my $button_cancel = $pop->Button(-text=>'Cancel',
-command => sub {$pop->destroy()} )
->pack(-side => 'left');
$find_entry->bind("<Return>" => [$button_find, 'invoke']);
$find_entry->bind("<Escape>" => [$button_cancel, 'invoke']);
$find_entry->bind("<Return>" => [$button_find, 'invoke']);
$find_entry->bind("<Escape>" => [$button_cancel, 'invoke']);
$pop->resizable('yes','no');
return $pop;
}
Tcl::Tk::Widget::create_method_in_widget_package (
'ROText',
unselectAll => \&unselectAll,
t/ptk-compat.t view on Meta::CPAN
[Button => '~Open ...', -accelerator => 'Control+o'],
[Button => '~New', -accelerator => 'Control+n'],
[Button => '~Save', -accelerator => 'Control+s'],
[Cascade => '~PerlTk manuals', -tearoff=>0, -menuitems =>
[
[Button => '~Overview', ],
[Button => '~Standard options', ],
[Button => 'Option ~handling', ],
[Button => 'Tk ~variables', ],
[Button => '~Grab manipulation', ],
[Button => '~Binding', ],
[Button => 'Bind ~tags', ],
[Button => '~Callbacks', ],
[Button => '~Events', ],
]
],
[Button => 'Save ~As ...', ],
[Separator => ''],
[Button => '~Properties ...', ],
[Separator => ''],
[Button => '~Quit', -accelerator => 'ESC', -command=>sub {print "Quit\n"}],
])->pack(-side=>'left');
t/ptk-compat.t view on Meta::CPAN
my $menu = $mw->Menu(-menuitems=> [
[Button => '~Open ...', -accelerator => 'Control+o'],
[Button => '~New', -accelerator => 'Control+n'],
[Button => '~Save', -accelerator => 'Control+s'],
[Cascade => '~PerlTk manuals', -tearoff=>0, -menuitems => [
[Button => '~Overview', ],
[Button => '~Standard options', ],
[Button => 'Option ~handling', ],
[Button => 'Tk ~variables', ],
[Button => '~Grab manipulation', ],
[Button => '~Binding', ],
[Button => 'Bind ~tags', ],
[Button => '~Callbacks', ],
[Button => '~Events', ],
]
],
[Button => 'Save ~As ...', ],
[Separator => ''],
[Button => '~Properties ...', ],
[Separator => ''],
[Button => '~Quit', -accelerator => 'ESC', -command=>sub {print "Quit\n"}],
]);
tk-demos/widget view on Meta::CPAN
-setgrid => 1,
)->grid(qw/-sticky nsew/);
$MW->gridRowconfigure( 0, -weight => 1); # allow expansion in both ...
$MW->gridColumnconfigure(0, -weight => 1); # ... X and Y dimensions
my $STATUS_VAR;
my $status = $MW->Label(-textvariable => \$STATUS_VAR, qw/-anchor w/);
$status->grid(qw/-sticky ew/);
# Create a bunch of tags to use in the text widget, such as those for
# section titles and demo descriptions. Also define the bindings for
# tags.
$T->tagConfigure(qw/title -font -*-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*/);
$T->tagConfigure(qw/demo -lmargin1 1c -lmargin2 1c -foreground blue/);
if ($MW->depth == 1) {
$T->tagConfigure(qw/hot -background black -foreground white/);
$T->tagConfigure(qw/visited -lmargin1 1c -lmargin2 1c -underline 1/);
} else {
$T->tagConfigure(qw/hot -relief raised -borderwidth 1 -foreground red/);
$T->tagConfigure(qw/visited -lmargin1 1c -lmargin2 1c -foreground/ =>
'#303080');
}
$T->tagBind(qw/demo <ButtonRelease-1>/ => \&invoke);
my $last_line = '';
$T->tagBind(qw/demo <Enter>/ => [sub {
my($x, $y) = (shift,shift);
my($text, $sv) = @_;
#my $e = $text->XEvent;
#my($x, $y) = ($e->x, $e->y);
$last_line = $text->index("\@$x,$y linestart");
$text->tagAdd('hot', $last_line, "$last_line lineend");
$text->configure(qw/-cursor hand2/);
show_stat $sv, $text, $text->index('current');
}, Tcl::Ev('%x','%y'), \$STATUS_VAR]
);
$T->tagBind(qw/demo <Leave>/ => [sub {
my($text, $sv) = @_;
$text->tagRemove(qw/hot 1.0 end/);
$text->configure(qw/-cursor xterm/);
$$sv = '';
}, \$STATUS_VAR]
);
$T->tagBind(qw/demo <Motion>/ => [sub {
my($x, $y) = (shift,shift);
my($text, $sv) = @_;
#my $e = $text->XEvent;
#my($x, $y) = ($e->x, $e->y);
my $new_line = $text->index("\@$x,$y linestart");
if ($new_line ne $last_line) {
$text->tagRemove(qw/hot 1.0 end/);
$last_line = $new_line;
$text->tagAdd('hot', $last_line, "$last_line lineend");
}
tk-demos/widget view on Meta::CPAN
[qw/demo demo-sayings/]);
$T->insert('end', "\n", '', "Entries\n", 'title');
$T->insert('end', "1. Without scrollbars.\n", [qw/demo demo-entry1/]);
$T->insert('end', "2. With scrollbars.\n", [qw/demo demo-entry2/]);
$T->insert('end', "3. Simple Rolodex-like form.\n", [qw/demo demo-form/]);
$T->insert('end', "\n", '', "Text\n", 'title');
$T->insert('end', "1. Basic editable text.\n", [qw/demo demo-texts/]);
$T->insert('end', "2. Text display styles.\n", [qw/demo demo-style/]);
$T->insert('end', "3. Hypertext (tag bindings).\n", [qw/demo demo-bind/]);
$T->insert('end', "4. A text widget with embedded windows.\n",
[qw/demo demo-twind/]);
$T->insert('end', "5. A search tool built with a text widget.\n",
[qw/demo demo-search/]);
$T->insert('end', "\n", '', "Canvases\n", 'title');
$T->insert('end', "1. The canvas item types.\n", [qw/demo demo-items/]);
$T->insert('end', "2. A simple 2-D plot.\n", [qw/demo demo-plot/]);
$T->insert('end', "3. Text items in canvases.\n", [qw/demo demo-ctext/]);
$T->insert('end', "4. An editor for arrowheads on canvas lines.\n",
tk-demos/widget_lib/Ball.pm view on Meta::CPAN
-velocity => [6.0, 9.0],
);
sub new { # Ball object constructor
# Create a new Ball object, which just happens to be a Canvas item.
# Fill-in values for defaulted parameters, create the oval item, and
# store object-specific information in the ball's hash.
#
# Finally, update the class global %BALLS hash, indexed by a hashed canvas
# reference, with the new ball. Note the special Tk::bind statement that
# removes a canvas from the %BALLS hash when the canvas is destroyed, thus
# keeping %BALLS trimmed and preventing a very slow memory leak.
my($class, $canvas, %args) = @_;
my @missing_args = grep ! defined $args{$_}, keys %DEFAULTS;
@args{@missing_args} = @DEFAULTS{@missing_args};
my($color, $size, $pos, $vel) = @args{-color, -size, -position, -velocity};
my $ball = $canvas->create('oval',
($pos->[0] - ($size/2.0)), ($pos->[1] - ($size/2.0)),
($pos->[0] + ($size/2.0)), ($pos->[1] + ($size/2.0)),
-fill => $color,
);
$canvas->Tk::bind(
'<Destroy>' => sub {delete $BALLS{Ball->get_canvas_hash($canvas)}}
);
my $ball_obj = {'canvas_ID' => $ball,
'canvas' => $canvas,
'color' => $color,
'size' => $size,
'pos' => [@$pos],
'vel' => [@$vel],
};
tk-demos/widget_lib/arrows.pl view on Meta::CPAN
} else {
$ainfo{bigLineStyle} = [
-fill => 'black',
-stipple => '@'.Tk->findINC('demos/images/grey.25'),
];
$ainfo{boxStyle} = [-fill => undef, qw/-outline black -width 1/];
$ainfo{activeStyle} = [qw/-fill black -outline black -width 1/];
}
arrow_setup $c, \%ainfo;
# Bindings to highlight the 3 tiny resize boxes.
foreach ([qw/<Enter> activeStyle/], [qw/<Leave> boxStyle/]) {
$c->bind('box', $_->[0] =>[
sub {
my($c, $style) = @_;
$c->itemconfigure('current', @{$ainfo{$style}})
}, $_->[1]],
);
}
$c->bind(qw/box <B1-Enter>/ => undef);
$c->bind(qw/box <B1-Leave>/ => undef);
# Bindings that select one of the 3 tiny resize boxes' "move code".
for my $n (1,2,3) {
$c->bind("box${n}", '<1>' =>
sub {$ainfo{move_sub} = \&{"arrow_move${n}"}}
);
}
# Bindings to move a resize box and redraw the arrow.
$c->bind('box', '<B1-Motion>' =>
[sub {&{$ainfo{move_sub}}(shift,shift,$c, \%ainfo)},Tcl::Ev('%x','%y')]
);
$c->bind('<Any-ButtonRelease-1>' => [\&arrow_setup, \%ainfo]);
} # end arrows
sub arrow_err {
my($c) = @_;
my $i = $c->create(qw/text .6i .1i -anchor n -text/ => "Range error!");
$c->after(4000, sub { $c->delete($i) });
tk-demos/widget_lib/bind.pl view on Meta::CPAN
# bind.pl
use vars qw/$TOP/;
sub bind {
# Create a top-level window that illustrates how you can bind Perl
# commands to regions of text in a text widget.
my($demo) = @_;
$TOP = $MW->WidgetDemo(
-name => $demo,
-text =>'',
-title => 'Text Demonstration - Tag Bindings',
-iconname => 'bind',
);
my $t = $TOP->Scrolled(qw/Text -setgrid true -width 60 -height 24
-scrollbars e -wrap word/, -font => $FONT);
$t->pack(qw/-expand yes -fill both/);
# Set up display styles
my(@bold, @normal);
if ($TOP->depth > 1) {
tk-demos/widget_lib/bind.pl view on Meta::CPAN
$t->insert('end', "\n\n");
$t->insert('end', '3. Anchoring and justification modes for text items.', 'd3');
$t->insert('end', "\n\n");
$t->insert('end', '4. An editor for arrow-head shapes for line items.', 'd4');
$t->insert('end', "\n\n");
$t->insert('end', '5. A ruler with facilities for editing tab stops.', 'd5');
$t->insert('end', "\n\n");
$t->insert('end', '6. A grid that demonstrates how canvases can be scrolled.', 'd6');
foreach my $tag (qw(d1 d2 d3 d4 d5 d6)) {
$t->tag('bind', $tag, '<Any-Enter>' =>
sub {shift->tag('configure', $tag, @bold)}
);
$t->tag('bind', $tag, '<Any-Leave>' =>
sub {shift->tag('configure', $tag, @normal)}
);
}
$t->tag(qw/bind d1 <1>/ => sub {&items('items')});
$t->tag(qw/bind d2 <1>/ => sub {&plot('plot')});
$t->tag(qw/bind d3 <1>/ => sub {&ctext('ctext')});
$t->tag(qw/bind d4 <1>/ => sub {&arrows('arrows')});
$t->tag(qw/bind d5 <1>/ => sub {&ruler('ruler')});
$t->tag(qw/bind d6 <1>/ => sub {&cscroll('cscroll')});
$t->mark(qw/set insert 0.0/);
} # end bind
1;
tk-demos/widget_lib/bounce.pl view on Meta::CPAN
$bounce_speed = $drawarea->Scale(
-orient => 'vert',
-showvalue => 0,
-width => 10,
-from => 100,
-to => 0,
-borderwidth => 1,
);
$bounce_speed->pack(-side => 'left', -fill => 'y');
$bounce_speed->bind('<Enter>' => sub {
ClearMsg; ShowMsg('Adjust slider for ball speed');
});
$bounce_speed->bind('<Leave>' => \&ClearMsg);
$bounce_speed->set(50);
my $w_buttons = $TOP->Frame;
$w_buttons->pack(qw(-side bottom -expand y -fill x -pady 2m));
my $w_dismiss = $w_buttons->Button(
-text => 'Dismiss',
-command => $quit_code,
);
$w_dismiss->pack(qw(-side left -expand 1));
my $w_see = $w_buttons->Button(
tk-demos/widget_lib/bounce.pl view on Meta::CPAN
foreach my $mb_list (@{$mb_list_ref}) {
$mb->command(
-label => $mb_list->[0],
-command => $mb_list->[1] ,
-underline => $mb_list->[2],
-background => 'DarkGreen',
-foreground => 'White',
);
}
$mb->pack(-side => 'left');
$TOP->bind($mb, '<Enter>' => sub {ClearMsg; ShowMsg($mb_msg)});
$TOP->bind($mb, '<Leave>' => \&ClearMsg);
push @menu_button_list, $mb;
return $mb;
} # end mkmb
sub SimStart {
if (not $bounce_running) {
$bounce_running = 1;
tk-demos/widget_lib/colors.pl view on Meta::CPAN
-name => $demo,
-text => 'A listbox containing several color names is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. If you double-click button 1 on ...
-title => 'Listbox Demonstration (colors)',
-iconname => 'colors',
);
my $list = $TOP->Scrolled(qw/Listbox -width 20 -height 16 -setgrid 1
-scrollbars e/);
$list->pack(qw/-side left -fill y/);
$list->bind('<Double-1>' =>
sub {
$list->interp->call('tk_setPalette', $list->get('active'));
},
);
$list->insert(0, qw/gray60 gray70 gray80 gray85 gray90
gray95 snow1 snow2 snow3 snow4 seashell1 seashell2 seashell3 seashell4
AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 AntiqueWhite4 bisque1
bisque2 bisque3 bisque4 PeachPuff1 PeachPuff2 PeachPuff3 PeachPuff4
NavajoWhite1 NavajoWhite2 NavajoWhite3 NavajoWhite4 LemonChiffon1
tk-demos/widget_lib/cscroll.pl view on Meta::CPAN
sprintf("%dc", $x+2), sprintf("%dc", $y+2),
-outline => 'black', -fill => $bg, -tags => 'rect');
$c->create('text', sprintf("%dc", $x+1), sprintf("%dc", $y+1),
-text => "$i,$j", -anchor => 'center', -tags => 'text');
$j++;
$y += 3;
} # whilend
} # forend
my $old_fill = '';
$c->bind('all', '<Any-Enter>' => [\&cscroll_enter, \$old_fill]);
$c->bind('all', '<Any-Leave>' => [\&cscroll_leave, \$old_fill]);
$c->bind('all', '<1>' => \&cscroll_button);
$c->CanvasBind('<2>' => [sub {
my ($x,$y) = (shift, shift);
my ($c) = @_;
#my $e = $c->XEvent;
$c->scan('mark', $x, $y);
},Tcl::Ev('%x','%y')]);
$c->CanvasBind('<B2-Motion>' => [sub {
my ($x,$y) = (shift, shift);
my ($c) = @_;
#my $e = $c->XEvent;
$c->scan('dragto', $x, $y);
},Tcl::Ev('%x','%y')]);
} # end cscroll
sub cscroll_button {
tk-demos/widget_lib/ctext.pl view on Meta::CPAN
use vars qw/$TOP/;
sub ctext {
# Create a window containing a canvas displaying a text string and
# allowing the string to be edited and re-anchored.
my($demo) = @_;
$TOP = $MW->WidgetDemo(
-name => $demo,
-text => ['This window displays a string of text to demonstrate the text facilities of canvas widgets. You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification. The text...
1. You can point, click, and type.
2. You can also select with button 1.
3. You can copy the selection to the mouse position with button 2.
4. Backspace and Control+h delete the selection if there is one;
otherwise they delete the character just before the insertion cursor.
5. Delete deletes the selection if there is one; otherwise it deletes
the character just after the insertion cursor.', qw/-wraplength 5i/],
-title => 'Canvas Text Demonstration',
-iconname => 'ctext',
);
my $c = $TOP->Canvas(qw/-relief flat -bd 0 -width 500 -height 350/);
$c->pack(qw/-side top -expand yes -fill both/);
$c->create(qw/rectangle 245 195 255 205 -outline black -fill red/);
# First, create the text item and give it bindings so it can be edited.
$c->addtag(qw/text withtag/,
$c->create('text', 250, 200,
-text => 'This is just a string of text to demonstrate the text facilities of canvas widgets. Bindings have been defined to support editing (see above)."',
qw/-width 440 -anchor n -justify left
-font -*-Helvetica-Medium-R-Normal--*-240-*-*-*-*-*-*/
),
);
$c->bind(qw/text <1>/ => \&ctext_press);
$c->bind(qw/text <B1-Motion>/ => \&ctext_move);
$c->bind(qw/text <Shift-1>/ => sub {
my($c) = @_;
my $e = $c->XEvent;
my($x, $y) = ($e->x, $e->y);
$c->select(qw/adjust current/, "\@$x,$y");
});
$c->bind(qw/text <Shift-B1-Motion>/ => \&ctext_move);
$c->bind(qw/text <KeyPress>/ => sub {
my($c) = @_;
my $e = $c->XEvent;
my $A = $e->A;
$c->insert(qw/text insert/, "$A");
});
$c->bind(qw/text <Return>/ => sub {
my($c) = @_;
$c->insert(qw/text insert/, "\\n");
});
$c->bind(qw/text <Control-h>/ => \&ctext_bs);
$c->bind(qw/text <BackSpace>/ => \&ctext_bs);
$c->bind(qw/text <Delete>/ => sub {
my($c) = @_;
eval {local $SIG{__DIE__}; $c->dchars(qw/text sel.first sel.last/)};
$c->dchars('text', 'insert');
});
$c->bind(qw/text <2>/ => sub {
my($c) = @_;
my $e = $c->XEvent;
$c->insert('text', $e->xy, $MW->SelectionGet);
});
# Next, create some items that allow the text's anchor position to
# be edited.
my($x, $y, $color) = (50, 50, 'LightSkyBlue1');
ctext_configure $c, $x, $y, -anchor => 'se', $color;
ctext_configure $c, $x+30, $y, -anchor => 's', $color;
ctext_configure $c, $x+60, $y, -anchor => 'sw', $color;
ctext_configure $c, $x, $y+30, -anchor => 'e', $color;
ctext_configure $c, $x+30, $y+30, -anchor => 'center', $color;
ctext_configure $c, $x+60, $y+30, -anchor => 'w', $color;
ctext_configure $c, $x, $y+60, -anchor => 'ne', $color;
ctext_configure $c, $x+30, $y+60, -anchor => 'n', $color;
ctext_configure $c, $x+60, $y+60, -anchor => 'nw', $color;
my $item = $c->create('rectangle', $x+40, $y+40, $x+50, $y+50,
qw/-outline black -fill red/);
$c->bind($item, '<1>' => sub {
shift->itemconfigure(qw/text -anchor center/);
});
$c->create('text', $x+45, $y-5, -text => 'Text Position', qw/-anchor s
-font -*-times-medium-r-normal--*-240-*-*-*-*-*-*
-fill brown/);
# Lastly, create some items that allow the text's justification
# to be changed.
$x = 350; $y = 50; $color = 'SeaGreen2';
ctext_configure $c, $x, $y, -justify => 'left', $color;
ctext_configure $c, $x+30, $y, -justify => 'center', $color;
ctext_configure $c, $x+60, $y, -justify => 'right', $color;
$c->create('text', $x+45, $y-5, qw/-text Justification -anchor s
-font -*-times-medium-r-normal--*-240-*-*-*-*-*-*
-fill brown/);
my $config_fill = '';
$c->bind(qw/config <Enter>/ => [\&ctext_enter, \$config_fill]);
$c->bind(qw/config <Leave>/ =>
sub {$c->itemconfigure('current', -fill => $config_fill)}
);
} # end ctext
sub ctext_bs {
my($c) = @_;
eval {local $SIG{__DIE__}; $c->dchars(qw/text sel.first sel.last/)};
tk-demos/widget_lib/ctext.pl view on Meta::CPAN
$c->dchars('text', $char) if $char >= 0;
} # end ctext_bs
sub ctext_configure {
my($w, $x, $y, $option, $value, $color) = @_;
my $item = $w->create('rectangle', $x, $y, $x+30, $y+30,
-outline => 'black', -fill => $color, -width => 1);
$w->bind($item, '<1>',
sub {$w->itemconfigure('text', $option => $value)}
);
$w->addtag(qw/config withtag/, $item);
} # end ctext_configure
sub ctext_enter {
my($w, $config_fill) = @_;
tk-demos/widget_lib/entry1.pl view on Meta::CPAN
use vars qw/$TOP/;
sub entry1 {
# Create a top-level window that displays a bunch of entries.
my($demo) = @_;
$TOP = $MW->WidgetDemo(
-name => $demo,
-text => ['Three different entries are displayed below. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h de...
-title => 'Entry Demonstration (no scrollbars)',
-iconname => 'entry1',
);
my(@relief) = qw/-relief sunken/;
my(@pl) = qw/-side top -padx 10 -pady 5 -fill x/;
my $e1 = $TOP->Entry(@relief)->pack(@pl);
my $e2 = $TOP->Entry(@relief)->pack(@pl);
my $e3 = $TOP->Entry(@relief)->pack(@pl);
tk-demos/widget_lib/entry2.pl view on Meta::CPAN
use vars qw/$TOP/;
sub entry2 {
# Create a top-level window that displays a bunch of entries with
# scrollbars.
my($demo) = @_;
$TOP = $MW->WidgetDemo(
-name => $demo,
-text => ['Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For ex...
-title => 'Entry Demonstration (with scrollbars)',
-iconname => 'entry2',
);
my(@pl) = qw/-side top -fill x/;
my(@scrolled_attributes) = qw/Entry -relief sunken -scrollbars s/;
my(@spacer_attributes) = qw/-width 20 -height 10/;
my $e1 = $TOP->Scrolled(@scrolled_attributes)->pack(@pl);
my $spacer1 = $TOP->Frame(@spacer_attributes)->pack(@pl);
tk-demos/widget_lib/floor.pl view on Meta::CPAN
$cinfo{offices} = 'Black';
$cinfo{active} = 'black';
}
my %floor_labels = ();
my %floor_items = ();
my $active_floor = 0;
floor_display $c->Subwidget('canvas'), 3, \%floor_labels, \%floor_items,
\%cinfo, \$active_floor, $c_entry;
# Set up event bindings for canvas.
for my $floor_number (1..3) {
$c->bind("floor${floor_number}", '<1>' =>
[\&floor_display, $floor_number, \%floor_labels, \%floor_items,
\%cinfo, \$active_floor, $c_entry],
);
}
$c->bind('room', '<Enter>' => sub {
my($c) = @_;
my $id = $c->find('withtag' => 'current');
$floor::current_room = $floor_labels{$c->find('withtag','current')}
if defined $id;
$c->idletasks;
});
$c->bind('room', '<Leave>' => sub {$floor::current_room = ''});
$c->bind('<2>' => \\'xy', sub {
my ($x,$y) = (shift,shift);
my($c) = @_;
#my $e = $c->XEvent;
$c->scan('mark', $x, $y);
});
$c->bind('<B2-Motion>' => \\'xy', sub {
my ($x,$y) = (shift,shift);
my($c) = @_;
#my $e = $c->XEvent;
$c->scan('dragto', $x, $y);
});
$c->bind('<Enter>', => [sub {shift; shift->focus}, $c_entry]);
tie $floor::current_room, 'floor', $c->Subwidget('canvas'), \%floor_items,
\%cinfo;
} # floor
sub floor_display {
# The following procedure recreates the floorplan display in the
# canvas given by "w". The floor given by "active" (1, 2, or 3) is
# displayed on top, with office structure visible. (Used as a callback
tk-demos/widget_lib/form.pl view on Meta::CPAN
my $f = $TOP->Frame->pack(-fill => 'both');
my $row = 0;
foreach ('Name:', 'Address:', '', '', 'Phone:') {
my $e = $f->Entry(qw/-relief sunken -width 40/);
my $l = $f->Label(-text => $_, -anchor => 'e', -justify => 'right');
$l->grid(-row => $row, -column => 0, -sticky => 'e');
$e->grid(-row => $row++, -column => 1,-sticky => 'ew');
$f->gridRowconfigure(1,-weight => 1);
$e->focus if $_ eq 'Name:';
}
$TOP->bind('<Return>' => [$TOP => 'destroy']);
} # end form
1;
tk-demos/widget_lib/image2.pl view on Meta::CPAN
# and image side by side so they fit within an SVGA screen.
$frog0->pack;
$frog->pack(qw/-side left/);
my $toad = $frog0->Frame;
$toad->pack(qw/-side right/);
$file_label->pack(@pl);
$f->pack(@pl);
my $f_list = $f->Listbox(-width => 20, -height => 10);
$dir_name->bind('<Return>' => [\&image2_load_dir, $f_list, \$demo_img]);
my $f_scroll = $f->Scrollbar(-command => [$f_list => 'yview']);
$f_list->configure(-yscrollcommand => [$f_scroll => 'set']);
@pl = qw/-side left -fill y -expand 1/;
$f_list->pack(@pl);
$f_scroll->pack(@pl);
$f_list->insert(0, qw(earth.gif earthris.gif mickey.gif teapot.ppm));
my $image2a = $TOP->Photo;
$f_list->bind('<Double-1>' => [\&image2_load_image, Tcl::Ev('%x','%y'), $image2a, \$demo_img]);
my $image_label = $toad->Label(-text => 'Image:');
my $image = $toad->Label(-image => $image2a);
@pl = qw/-side top -anchor w/;
$image_label->pack(@pl);
$image->pack(@pl);
} # end image2
sub image2_load_dir {
tk-demos/widget_lib/items.pl view on Meta::CPAN
$c->createWindow(qw/21c 21c/, -window => $c_entry,
qw/-anchor nw -tags item/);
my $c_scale = $c->Scale(qw/-from 0 -to 100 -length 6c -sliderlength .4c
-width .5c -tickinterval 0/);
$c->createWindow(qw/28.5c 17.5c/, -window => $c_scale,
qw/-anchor n -tags item/);
$c->createText(qw/21c 17.9c -text Button: -anchor sw/);
$c->createText(qw/21c 20.9c -text Entry: -anchor sw/);
$c->createText(qw/28.5c 17.4c -text Scale: -anchor s/);
# Set up event bindings for canvas.
$c->bind('item', '<Any-Enter>' => [\&items_enter, \%iinfo]);
$c->bind('item', '<Any-Leave>' => [\&items_leave, \%iinfo]);
# Get real canvas widget reference to apply bind() commands to: the
# Canvas widget is a subwidget of the Scrolled composite widget. To
# reference the X event structure, either use the XEvent() method or
# read the specially localized variable $Tk::event. We'll use XEvent
# first, and the variable from then on.
$c->bind('<<Copy>>',sub { print "Do Copy\n" });
$c->CanvasBind('<1>' => [sub {
my ($x,$y) = (shift, shift);
my($c) = @_;
items_start_drag $c, $x, $y, \%iinfo;
},Tcl::Ev('%x','%y')]);
$c->CanvasBind('<B1-Motion>' =>
[sub {my ($x,$y) = (shift, shift);items_drag shift, $x, $y, \%iinfo},Tcl::Ev('%x','%y')]);
$c->CanvasBind('<2>' =>
[sub {my ($x,$y) = (shift, shift);shift->scan('mark', $x, $y)},Tcl::Ev('%x','%y')]);
$c->CanvasBind('<B2-Motion>' =>
[sub {my ($x,$y) = (shift, shift);shift->scan('dragto', $x, $y)},Tcl::Ev('%x','%y')]);
$c->CanvasBind('<3>' =>
[sub {my ($x,$y) = (shift, shift);items_mark shift, $x, $y, \%iinfo},Tcl::Ev('%x','%y')]);
$c->CanvasBind('<B3-Motion>' =>
[sub {my ($x,$y) = (shift, shift);items_stroke shift, $x, $y, \%iinfo},Tcl::Ev('%x','%y')]);
$c->CanvasBind('<Control-f>' => [sub {
#my ($x,$y) = (shift, shift);
my($c, $iinfo) = @_;
#my $e = $c->XEvent;
items_under_area $c, $iinfo;
}, Tcl::Ev('%x','%y'), \%iinfo]);
$c->CanvasBind('<Any-Enter>' => sub {$_[0]->CanvasFocus});
} # end items
# Utility procedures for highlighting the item under the pointer:
sub items_button_press {
# Procedure that's invoked when the button embedded in the canvas
# is invoked.
tk-demos/widget_lib/menus.pl view on Meta::CPAN
my $b = $menubar->cascade(-label => '~Basic', -tearoff => 0);
$b->command(-label => 'Long entry that does nothing');
foreach my $label (qw/A B C D E F/) {
$b->command(
-label => "Print letter \"$label\"",
-underline => 14,
-accelerator => "$modifier+$label",
-command => sub {print "$label\n"},
);
$TOP->bind("<$modifier-${label}>" => sub {print "$label\n"});
}
my $c = $menubar->cascade(-label => '~Cascades', -tearoff => 0);
$c->command(
-label => 'Print hello',
-command => sub {print "Hello\n"},
-accelerator => "$modifier+H",
-underline => 6,
);
$TOP->bind("<$modifier-h>" => sub {print "Hello\n"});
$c->command(
-label => 'Print goodbye',
-command => sub {print "Goodbye\n"},
-accelerator => "$modifier+G",
-underline => 6,
);
$TOP->bind("<$modifier-g>" => sub {print "Goodbye\n"});
my $cc = $c->cascade(-label => '~Check buttons');
$cc->checkbutton(-label => 'Oil checked', -variable => \$OIL);
$cc->checkbutton(-label => 'Transmission checked', -variable => \$TRANS);
$cc->checkbutton(-label => 'Brakes checked', -variable => \$BRAKES);
$cc->checkbutton(-label => 'Lights checked', -variable => \$LIGHTS);
$cc->separator;
$cc->command(
-label => 'See current values',
-command => [\&see_vars, $MW, [
tk-demos/widget_lib/menus.pl view on Meta::CPAN
-command => sub {print "You invoked \"$label\"\n"},
);
}
$TOP->Label(qw/-wraplength 4.5i -justify left -text/ => 'This window contains a menubar with cascaded menus. You can post a menu from the keyboard by typing Alt+x, where "x" is the character underlined on the menu. You can then traverse among t...
my $status_bar = ' ';
$TOP->Label(qw/-relief sunken -borderwidth 1 -anchor w/,
-font => 'Helvetica 10', -textvariable => \$status_bar)->
pack(qw/-padx 2 -pady 2 -expand yes -fill both/);
$menubar->bind('<<MenuSelect>>' => \\'W', sub {
my $label = undef;
my $w = Tcl::Tk::widget(pop); # $Tk::event->W;
eval {
$label = $w->entrycget('active', -label);
};
if ($@) {$label = " "}
$status_bar = $label;
$TOP->idletasks;
});
tk-demos/widget_lib/menus2.pl view on Meta::CPAN
[\&see_vars, $TOP, [
['point size', \$POINT_SIZE],
['font style', \$FONT_STYLE],
],
], # end see_vars
], # end button
], # end radiobutton menuitems
], # end radiobuttons cascade
]);
$TOP->bind('<Control-a>' => sub {print "Hello\n"});
$TOP->bind('<Control-b>' => sub {print "Goodbye\n"});
# Fetch the Cascades menu, and from that get the checkbutton and
# radiobutton cascade menus and invoke a few menu items.
my $cm = $c->cget(-menu);
my @cm = $c->cget(-menu);
$menu_cb = substr $menu_cb, 1;
my $cc = Tcl::Tk::widget($cm->entrycget($menu_cb, -menu));
$cc->invoke(1);
$cc->invoke(3);
tk-demos/widget_lib/mkArrow.pl view on Meta::CPAN
if ($mkArrow->depth > 1) {
$demoArrowInfo{'bigLineStyle'} = [-fill => 'SkyBlue1'];
$demoArrowInfo{'boxStyle'} = [-fill => undef, -outline => 'black', -width => 1];
$demoArrowInfo{'activeStyle'} = [-fill => 'red', -outline => 'black', -width => 1];
} else {
$demoArrowInfo{'bigLineStyle'} = [-fill => 'black', -stipple => '@'.Tk->findINC('demos/images/grey.25')];
$demoArrowInfo{'boxStyle'} = [-fill => "", -outline => 'black', -width => 1];
$demoArrowInfo{'activeStyle'} = [-fill => 'black', -outline => 'black', -width => 1];
}
arrowSetup $c;
$c->bind('box', '<Enter>' => [sub {
my($c, @args) = @_;
$c->itemconfigure(@args);
}, 'current', @{$demoArrowInfo{'activeStyle'}}]);
$c->bind('box', '<Leave>' => [sub {
my($c, @args) = @_;
$c->itemconfigure(@args);
}, 'current', @{$demoArrowInfo{'boxStyle'}}]);
$c->bind('box', '<B1-Enter>' => undef);
$c->bind('box', '<B1-Leave>' => undef);
$c->bind('box1', '<1>' => sub {
$demo_arrowInfo{'motionProc'} = \&arrowMove1;
});
$c->bind('box2', '<1>' => sub {
$demo_arrowInfo{'motionProc'} = \&arrowMove2;
});
$c->bind('box3', '<1>', sub {
$demo_arrowInfo{'motionProc'} = \&arrowMove3;
});
$c->bind('box', '<B1-Motion>' => sub {
&{$demo_arrowInfo{'motionProc'}}(@_);
});
$c->Tk::bind('<Any-ButtonRelease-1>', sub {arrowSetup(@_)});
} # end mkArrow
1;
tk-demos/widget_lib/mkCanvText.pl view on Meta::CPAN
my $c = $w->Canvas(-relief => 'flat', -bd => 0, -width => '500', -height => '400');
my $w_ok = $w->Button(-text => 'OK', -width => 8, -command => ['destroy', $w]);
$w_msg->pack(-side => 'top', -fill => 'both');
$c->pack(-side => 'top', -expand => 'yes', -fill => 'both');
$w_ok->pack(-side => 'bottom', -pady => '5', -anchor => 'center');
$font = '-Adobe-helvetica-medium-r-normal--*-240-*-*-*-*-*-*';
$c->create(qw(rectangle 245 195 255 205 -outline black -fill red));
# First, create the text item and give it bindings so it can be edited.
$c->addtag('text', 'withtag', $c->create('text', 250, 200, -text => 'This is just a string of text to demonstrate the ' .
'text facilities of canvas widgets. You can point, click, and type. You can ' .
'also select and then delete with Control-d.', -width => 440, -anchor => 'n',
-font => $font, -justify => 'left'));
$c->bind('text', '<1>' => sub {textB1Press(@_)});
$c->bind('text', '<B1-Motion>' => sub {textB1Move(@_)});
$c->bind('text', '<Shift-1>' => sub {
my($c) = @_;
my $e = $c->XEvent;
my($x, $y) = ($e->x, $e->y);
$c->select('adjust', 'current', "\@$x,$y");
});
$c->bind('text', '<Shift-B1-Motion>' => sub {textB1Move(@_)});
$c->bind('text', '<KeyPress>' => sub {
my($c) = @_;
my $e = $c->XEvent;
my $A = $e->A;
$c->insert('text', 'insert', "$A");
});
$c->bind('text', '<Shift-KeyPress>' => sub {
my($c) = @_;
my $e = $c->XEvent;
my $A = $e->A;
$c->insert('text', 'insert', "$A");
});
$c->bind('text', '<Return>' => sub {
my($c) = @_;
my $e = $c->XEvent;
$c->insert('text', 'insert', "\\n");
});
$c->bind('text', '<Control-h>' => sub {textBs(@_)});
$c->bind('text', '<Delete>' => sub {textBs(@_)});
$c->bind('text', '<Control-d>' => sub {
my($c, $e) = @_;
my $e = $c->XEvent;
$c->dchars('text', 'sel.first', 'sel.last');
});
$c->bind('text', '<Control-v>' => sub {
my($c, $e) = @_;
my $e = $c->XEvent;
$c->insert('text', 'insert', Tk::selection('get'));
});
# Next, create some items that allow the text's anchor position to be edited.
my($x, $y, $color) = (50, 50, 'LightSkyBlue1');
mkTextConfig $c, $x, $y, -anchor => 'se', $color;
mkTextConfig $c, $x+30, $y, -anchor => 's', $color;
mkTextConfig $c, $x+60, $y, -anchor => 'sw', $color;
mkTextConfig $c, $x, $y+30, -anchor => 'e', $color;
mkTextConfig $c, $x+30, $y+30, -anchor => 'center', $color;
mkTextConfig $c, $x+60, $y+30, -anchor => 'w', $color;
mkTextConfig $c, $x, $y+60, -anchor => 'ne', $color;
mkTextConfig $c, $x+30, $y+60, -anchor => 'n', $color;
mkTextConfig $c, $x+60, $y+60, -anchor => 'nw', $color;
my $item = $c->create('rectangle', $x+40, $y+40, $x+50, $y+50, -outline => 'black', -fill => 'red');
$c->bind($item, '<1>' => sub {
my($c, $e) = @_;
my $e = $c->XEvent;
$c->itemconfigure('text', -anchor => 'center');
});
$c->create('text', $x+45, $y-5, -text => 'Text Position', -anchor => 's',
-font => '-Adobe-times-medium-r-normal--*-240-*-*-*-*-*-*', -fill => 'brown');
# Lastly, create some items that allow the text's justification to be changed.
$x = 350; $y = 50; $color = 'SeaGreen2';
mkTextConfig $c, $x, $y, -justify => 'left', $color;
mkTextConfig $c, $x+30, $y, -justify => 'center', $color;
mkTextConfig $c, $x+60, $y, -justify => 'right', $color;
$c->create('text', $x+45, $y-5, -text => 'Justification', -anchor => 's',
-font => '-Adobe-times-medium-r-normal--*-240-*-*-*-*-*-*', -fill => 'brown');
$c->bind('config', '<Enter>' => sub {textEnter(@_)});
$c->bind('config', '<Leave>' => sub {
my($c, $e) = @_;
my $e = $c->XEvent;
$c->itemconfigure('current', -fill => $mkCanvText::textConfigFill);
});
} # end mkCanvText
sub mkTextConfig {
my($w, $x, $y, $option, $value, $color) = @_;
my $item = $w->create('rectangle', $x, $y, $x+30, $y+30, -outline => 'black', -fill => $color, -width => 1);
$w->bind($item, '<1>', [sub {
my($w, $option, $value, $e) = @_;
my $e = $w->XEvent;
$w->itemconfigure('text', $option => $value);
}, $option, $value]);
$w->addtag('config', 'withtag', $item);
} # end mkTextConfig
$mkCanvText::textConfigFill = 'purple';
tk-demos/widget_lib/mkFloor.pl view on Meta::CPAN
$mkFloor::colors{'bg2'} = 'white';
$mkFloor::colors{'outline2'} = 'black';
$mkFloor::colors{'bg3'} = 'white';
$mkFloor::colors{'outline3'} = 'black';
$mkFloor::colors{'offices'} = 'Black';
$mkFloor::colors{'active'} = 'black';
}
$mkFloor::activeFloor = 0;
floorDisplay $c, 3;
# Set up event bindings for canvas.
$c->bind('floor1', '<1>' => [sub {floorDisplay(@_)}, 1]);
$c->bind('floor2', '<1>' => [sub {floorDisplay(@_)}, 2]);
$c->bind('floor3', '<1>' => [sub {floorDisplay(@_)}, 3]);
$c->bind('room', '<Enter>' => [sub {
my($c, @args) = @_;
my $id = $c->find('withtag' => 'current');
$mkFloor::currentRoom = $mkFloor::floorLabels{$c->find('withtag', 'current')} if defined $id;
$c->idletasks;
}]);
$c->bind('room', '<Leave>' => sub {$mkFloor::currentRoom = ''});
$c->Tk::bind('<2>' => sub {
my($c) = @_;
my $e = $c->XEvent;
$c->scan('mark', $e->x, $e->y);
});
$c->Tk::bind('<B2-Motion>' => sub {
my($c) = @_;
my $e = $c->XEvent;
$c->scan('dragto', $e->x, $e->y);
});
# $c->Tk::bind('<Destroy>' => sub {undef $mkFloor::currentRoom});
$c->Tk::bind('<Enter>', => [sub {shift; shift->focus}, $mkFloor::c_entry]);
tie($mkFloor::currentRoom, 'mkFloor', $mkFloor::currentRoom, $c); # trace currentRoom
} # end mkFloor
sub floorDisplay {
# The following procedure recreates the floorplan display in the canvas given by "w". The floor given by "active"
# (1, 2, or 3) is displayed on top, with office structure visible. (Used as a callback and a normal function.)
( run in 0.692 second using v1.01-cache-2.11-cpan-1c8d708658b )