Tcl-pTk
view release on metacpan or search on metacpan
1.09 2022-05-19
* Support ttk::treeview `cellselection` command (Tk 8.7 TIP 552)
* Workaround Tk Aqua bug f16cdb6d04 in bgerror1.t, tkHijack_bgerror1.t,
and tkHijack_bgerror3.t
* Workaround Tk Aqua bug fc5073a451 in mainloopMult.t, multMainWindow1.t,
and tkHijack_bgerror1.t
* Implement $w->Widget() method
* Improve $w->imageNames() method; fix bitmapSubClass.t and photoSubClass.t
* Fix Tcl::pTk::Widget::_addcascade() for Tk 8.7 (TIP 577)
1.08_02 2021-04-04
* Specify GitHub issues as bugtracker
* Avoid requiring sys/ioctl.ph for emulated fileevent
on BSD and macOS (RT #125662)
1.08_01 2020-07-18
* Add internal variable $Tcl::pTk::_Tile_ge_0840 to indicate whether Tile/Ttk
t/hlist.t
t/iconimage.t
t/imageLoad.t
t/itemStyle.t
t/labEntry.t
t/labEntryFacelift.t
t/labEntryParentChild.t
t/libLoad.t
t/listbox.t
t/mainloopMult.t
t/menub-cascade.t
t/menub_newMenu.t
t/menubarpath.t
t/menuitems.t
t/messageBox.t
t/moveResizeWindow.t
t/moveToplevelWindow.t
t/multMainWindow1.t
t/multMainWindow2.t
t/notebook.t
t/notebook2.t
lib/Tcl/pTk/Menu.pm view on Meta::CPAN
$wid->_process_underline(\%args);
$wid->menu->Command(%args);
},
checkbutton => sub {
shift->Checkbutton(@_);
},
radiobutton => sub {
shift->Radiobutton(@_);
},
cascade => sub {
my $wid = shift;
$wid->_addcascade(@_);
},
separator => sub {
shift->Separator(@_);
},
menu => sub {
my $wid = shift;
return $wid->interp->widget("$wid");
},
entryconfigure => sub {
lib/Tcl/pTk/Menu/Item.pm view on Meta::CPAN
Tcl::pTk::Menu->Construct( 'Button' );
Tcl::pTk::Menu->Construct( 'Command' );
#package Tk::Menu::Command;
#use base qw(Tk::Menu::Button);
#Construct Tk::Menu 'Command';
package Tcl::pTk::Menu::Cascade;
use base qw(Tcl::pTk::Menu::Item);
Tcl::pTk::Menu->Construct( 'Cascade' );
sub kind { return 'cascade' }
use Carp;
sub PreInit
{
my ($class,$menu,$minfo) = @_;
my $tearoff = delete $minfo->{-tearoff};
my $items = delete $minfo->{-menuitems};
my $widgetvar = delete $minfo->{-menuvar};
my $command = delete $minfo->{-postcommand};
my $name = delete $minfo->{'Name'};
lib/Tcl/pTk/Menu/Item.pm view on Meta::CPAN
{
$menu->configure(%args) if %args;
}
return $menu;
}
# Some convenience methods
sub separator { shift->menu->Separator(@_); }
sub command { shift->menu->Command(@_); }
sub cascade { shift->menu->Cascade(@_); }
sub checkbutton { shift->menu->Checkbutton(@_); }
sub radiobutton { shift->menu->Radiobutton(@_); }
sub pack
{
my $w = shift;
if ($^W)
{
require Carp;
Carp::carp("Cannot 'pack' $w - done automatically")
lib/Tcl/pTk/Menubutton.pm view on Meta::CPAN
$wid->_process_underline(\%args);
$wid->menu->Command(%args);
},
checkbutton => sub {
shift->menu->Checkbutton(@_);
},
radiobutton => sub {
shift->menu->Radiobutton(@_);
},
cascade => sub {
my $wid = shift;
my $menu = $wid->menu(); # get the menu
$menu->_addcascade(@_);
},
separator => sub {
shift->menu->Separator(@_);
},
menu => sub {
my $wid = shift;
return $wid->cget(-menu);
},
cget => sub {
my $wid = shift;
lib/Tcl/pTk/Menubutton.pm view on Meta::CPAN
return $wid->menu->entryconfigure(@_);
},
# entrycget just calls entrycget on the menu component
entrycget => sub{
my $wid = shift;
return $wid->menu->entrycget(@_);
},
);
my ($mnub, $mnu);
# For creating menubuttons on a already-created menu, create a cascade item
if( $self->isa('Tcl::pTk::Menu') ){
$mnu = $self;
# Get name, if defined
my $name = delete($args{-text}) || delete($args{-label});
$args{-label} = $name if( defined( $name ));
my $hash = $self->TkHash('MenuButtons'); # See if we already created this menubutton
$mnub = $hash->{$name};
if( defined($mnub) ){ # Configure existing menubutton
$mnub->configure(%args) if (%args);
}
else{ # Create new menubutton on the menu
$args{-tearoff} = 0 unless( defined($args{-tearoff}) ); # Cascade items shouldn't be tearoff, by default
$mnub = $mnu->cascade(%args, -menuitems => $mis);
$hash->{$name} = $mnub;
}
return $mnub;
}
# Not calling menubutton on a menu (Normal Case)
$mnub = $int->widget(
$self->call('menubutton', $w, -menu => "$w.m", %args),
"Tcl::pTk::Menubutton");
lib/Tcl/pTk/Text.pm view on Meta::CPAN
}
sub ViewMenuItems
{
my ($w) = @_;
my $v;
# tie $v,'Tk::Configure',$w,'-wrap';
return [
['command'=>'Goto ~Line...', -command => [$w => 'GotoLineNumberPopUp']],
['command'=>'~Which Line?', -command => [$w => 'WhatLineNumberPopUp']],
['cascade'=> 'Wrap', -tearoff => 0, -menuitems => [
[radiobutton => 'Word', -variable => \$v, -value => 'word'],
[radiobutton => 'Character', -variable => \$v, -value => 'char'],
[radiobutton => 'None', -variable => \$v, -value => 'none'],
]],
];
}
# Workaround for compatibility with Perl/Tk search()
# (used by Tk::Text Find methods), which accepts
# abbreviated flags, whereas Tcl/Tk search() does not
lib/Tcl/pTk/Widget.pm view on Meta::CPAN
my $self = shift;
# Suck out "~" which represents the char to underline
my $args = shift;
if (defined($args->{'-label'}) && $args->{'-label'} =~ /~/) {
my $und = index($args->{'-label'}, '~');
$args->{'-underline'} = $und;
$args->{'-label'} =~ s/~//;
}
};
# internal sub helper for menu
sub _addcascade {
my $mnu = shift;
my $mnup = $mnu->path;
my $int = $mnu->interp;
#print "In Add Cascade mnup = $mnup ";
# Create submenu with predefined naming convention ($mnu.m+1), so we can return it
# if the menu method is called on the menu button
my $entries = $mnu->index('end');
$entries = -1 if (!defined($entries) or $entries eq 'none');
lib/Tcl/pTk/Widget.pm view on Meta::CPAN
my %args = @_;
#print "Add Cascade args = ".join(", ", %args)."\n";
my $tearoff = delete $args{'-tearoff'};
if (defined($tearoff)) {
$smnu->configure(-tearoff => $tearoff);
}
$args{'-menu'} = $smnu;
my $mis = delete $args{'-menuitems'};
$mnu->_process_menuitems($int,$smnu,$mis);
$mnu->_process_underline(\%args);
#$int->call("$mnu",'add','cascade', %args);
$mnu->Cascade(%args);
}
# internal helper sub to process perlTk's -menuitems option
sub _process_menuitems {
my $self = shift;
my ($int,$mnu,$mis) = @_;
for (@$mis) {
if (ref) {
my $label = $_->[1];
my %a = @$_[2..$#$_];
$a{'-state'} = delete $a{state} if exists $a{state};
$a{'-label'} = $label;
my $cmd = lc($_->[0]);
if ($cmd eq 'separator') {$int->invoke($mnu->path,'add','separator');}
elsif ($cmd eq 'cascade') {
$mnu->_process_underline(\%a);
$mnu->_addcascade(%a);
}
else {
$cmd=~s/^button$/command/;
$mnu->_process_underline(\%a);
#print "calling Call ".$mnu->path." add command ".join(", ", %a)."\n";
$mnu->call($mnu->path,'add',$cmd, %a);
}
}
else {
lib/Tcl/pTk/demos/widget_lib/balloon.pl view on Meta::CPAN
# status bar widget
my $status = $top->Label(-width => 60, -relief => "sunken", -bd => 1, -anchor => 'w');
$status->pack(-side => "bottom", -fill => "y", -padx => 2, -pady => 1);
# create the widgets to be explained
my $mb = $top->Menubutton(-relief => 'raised',
-text => 'Menu button');
my $xxx = 0;
$mb->checkbutton(-label => 'checkbutton',
-variable => \$xxx);
$mb->cascade(-label => 'cascade entry');
my $menu = $mb->cget(-menu);
my $cm = $menu->Menu(-tearoff => 0);
$mb->entryconfigure('cascade entry', -menu => $cm);
$cm->command(-label => 'first');
$cm->command(-label => 'second');
$mb->separator;
$mb->command(-label => 'Close',
-command => sub {$top->destroy;});
my $b1 = $top->Button(-text => "Something Unexpected",
-command => sub {$top->destroy;});
my $b2 = $top->Button(-text => "Something Else Unexpected");
$b2->configure(-command => sub {$b2->destroy;});
lib/Tcl/pTk/demos/widget_lib/balloon.pl view on Meta::CPAN
# create the balloon widget
my $b = $top->Balloon(-statusbar => $status);
$b->attach($mb,
-msg => 'Press and hold this button to see the menu.');
$b->attach($menu,
#-state => 'status',
-balloonposition => 'mouse',
-msg => ['Use this to tear off the menu.',
'This is a checkbox entry.',
'cascade', # Cascade entry (ignored by Balloon)
'separator', # Separator: never active so no message will be displayed for this entry.
'This is a command entry - it will close this window.',
],
);
$b->attach($cm,
-msg => 'This balloon is attached to the cascade menu, not it\'s entries',
#-statusmsg => 'msg cm',
#-balloonmsg => 'cm msg.',
);
$b->attach($b1,
-balloonmsg => "Close Window",
-statusmsg => "Press this button to close this window");
$b->attach($b2,
-balloonmsg => "Self-destruct\nButton",
-statusmsg => "Press this button and it will get rid of itself");
lib/Tcl/pTk/demos/widget_lib/menus.pl view on Meta::CPAN
use warnings;
use strict;
use subs qw/menus_error/;
use vars qw/$TOP/;
sub menus {
# This demonstration script creates a window with a bunch of menus
# and cascaded menus using a menubar. A <<MenuSelect>> virtual event
# tracks the active menu item.
my ($demo) = @_;
$TOP = $MW->WidgetDemo(
-name => $demo,
-text => ['', -wraplength => '5i'],
-title => 'Menu Demonstration',
-iconname => 'menus',
);
my $ws = $TOP->windowingsystem;
my $text = ($ws eq 'classic' or $ws eq 'aqua') ?
'This window contains a menubar with cascaded menus. You can invoke entries with an accelerator by typing Command+x, where "x" is the character next to the command key symbol. The rightmost menu can be torn off into a palette by dragging out...
'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 the menus using the arrow keys. When a menu is poste...
$TOP->configure(-text => $text);
my $toplevel = $TOP->toplevel; # get $TOP's Toplevel widget reference
my $menubar = $toplevel->Menu(-type => 'menubar', -tearoff => 0);
$toplevel->configure(-menu => $menubar);
my $modifier;
if ( $ws eq 'classic' or $ws eq 'aqua') {
$modifier = 'Command';
} elsif ($Tcl::pTk::platform eq 'windows') {
$modifier = 'Control';
} else {
$modifier = 'Meta';
}
my $f = $menubar->cascade(-label => '~File', -tearoff => 0);
$f->command(-label => 'Open ...', -command => [\&menus_error, 'Open'],
-image => $toplevel->Getimage("openfile"), -compound => "left");
$f->command(-label => 'New', -command => [\&menus_error, 'New'],
-image => $toplevel->Getimage("file"), -compound => "left");
$f->command(-label => 'Save', -command => [\&menus_error, 'Save']);
$f->command(-label => 'Save As ...', -command => [\&menus_error, 'Save As']);
$f->separator;
$f->command(-label => 'Setup ...', -command => [\&menus_error, 'Setup']);
$f->command(-label => 'Print ...', -command => [\&menus_error, 'Print']);
$f->separator;
$f->command(-label => 'Quit', -command => [$TOP => 'bell']);
my $b = $menubar->cascade(-label => '~Basic', -tearoff => 0);
$b->command(-label => 'Long entry that does nothing');
my $label;
foreach $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', -tearoff => 0);
$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, [
['oil', \$OIL],
['trans', \$TRANS],
['brakes', \$BRAKES],
['lights', \$LIGHTS],
],
],
);
my $cc_menu = $cc->cget(-menu);
$cc_menu->invoke(1);
$cc_menu->invoke(3);
my $rc = $c->cascade(-label => '~Radio buttons', -tearoff => 0);
foreach $label (qw/10 14 18 24 32/) {
$rc->radiobutton(
-label => "$label point",
-variable => \$POINT_SIZE,
-value => $label,
);
}
$rc->separator;
foreach $label (qw/Roman Bold Italic/) {
lib/Tcl/pTk/demos/widget_lib/menus.pl view on Meta::CPAN
-command => [\&see_vars, $MW, [
['point size', \$POINT_SIZE],
['font style', \$FONT_STYLE],
],
],
);
my $rc_menu = $rc->cget(-menu);
$rc_menu->invoke(1);
$rc_menu->invoke(7);
my $i = $menubar->cascade(-label => '~Icons', -tearoff => 0);
$i->command(
-bitmap => '@'.Tcl::pTk->findINC('demos/images/pattern'),
-command => sub {
$TOP->messageBox(
-title => 'Bitmap Menu Entry',
-message => 'The menu entry you invoked displays a bitmap rather than a text string. Other than this, it is just like any other menu entry.',
-type => 'ok'),
},
-hidemargin => 1,
);
foreach $label (qw/info questhead error/) {
$i->command(
-bitmap => $label,
-command => sub {print "You invoked the \"$label\" bitmap\n"},
-hidemargin => 1,
);
}
$i->cget(-menu)->entryconfigure(2, -columnbreak => 1);
my $m = $menubar->cascade(-label => '~More', -tearoff => 0);
foreach $label ('An entry', 'Another entry', 'Does nothing',
'Does almost nothing', 'Make life meaningful') {
$m->command(
-label => $label,
-command => sub {print "You invoked \"$label\"\n"},
);
}
my $k = $menubar->cascade(-label => 'C~olors');
foreach $label (qw/red orange yellow green blue/) {
$k->command(
-label => $label,
-background => $label,
-command => sub {print "You invoked \"$label\"\n"},
);
}
my $status_bar;
$TOP->Label(
lib/Tcl/pTk/demos/widget_lib/menus2.pl view on Meta::CPAN
use warnings;
use strict;
use subs qw/menus_error2/;
use vars qw/$TOP/;
sub menus2 {
# This demonstration script creates a window with a bunch of menus
# and cascaded menus, but uses the unique Perl/Tk -menuitems way.
# A <<MenuSelect>> virtual event tracks the active menu item.
my ($demo) = @_;
$TOP = $MW->WidgetDemo(
-name => $demo,
-text => ['', -wraplength => '5i'],
-title => 'Menuitems Demonstration',
-iconname => 'menus2',
);
my $ws = $TOP->windowingsystem;
my $text = ($ws eq 'classic' or $ws eq 'aqua') ?
'This window contains a menubar with cascaded menus. You can invoke entries with an accelerator by typing Command+x, where "x" is the character next to the command key symbol. The rightmost menu can be torn off into a palette by dragging out...
'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 the menus using the arrow keys. When a menu is poste...
$TOP->configure(-text => $text);
my $toplevel = $TOP->toplevel; # get $TOP's Toplevel widget reference
my $menubar = $toplevel->Menu(-type => 'menubar', -tearoff => 0);
$toplevel->configure(-menu => $menubar);
my $modifier;
if ( $ws eq 'classic' or $ws eq 'aqua') {
$modifier = 'Command';
lib/Tcl/pTk/demos/widget_lib/menus2.pl view on Meta::CPAN
[Button => 'See current values', -command =>
[\&see_vars, $TOP, [
['oil', \$OIL],
['trans', \$TRANS],
['brakes', \$BRAKES],
['lights', \$LIGHTS],
],
], # end see_vars
], # end button
], # end checkbutton menuitems
], # end checkbuttons cascade
[Cascade => $menu_rb, -tearoff => 0, -menuitems =>
[
map (
[Radiobutton => "$_ point", -variable => \$POINT_SIZE,
-value => $_,
],
(qw/10 14 18 24 32/),
),
[Separator => ''],
map (
lib/Tcl/pTk/demos/widget_lib/menus2.pl view on Meta::CPAN
),
[Separator => ''],
[Button => 'See current values', -command =>
[\&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);
$menu_cb = substr $menu_cb, 1;
my $cc = $cm->entrycget($menu_cb, -menu);
$cc->invoke(1);
$cc->invoke(3);
$menu_rb = substr $menu_rb, 1;
my $cr = $cm->entrycget($menu_rb, -menu);
$cr->invoke(1);
$cr->invoke(7);
lib/Tcl/pTk/demos/widget_lib/menus2.pl view on Meta::CPAN
map (
[Button => $_,
-command =>
[sub {print "You invoked \"$_[0]\"\n"}, $_]],
('An entry', 'Another entry', 'Does nothing',
'Does almost nothing', 'Make life meaningful'),
),
],
);
my $k = $menubar->cascade(qw/-label C~olors -tearoff 1 -menuitems/ =>
[
map (
[Button => $_,
-background => $_,
-command =>
[sub {print "You invoked \"$_[0]\"\n"}, $_]],
(qw/red orange yellow green blue/),
),
],
);
lib/Tcl/pTk/demos/widtrib/Gedi.pl view on Meta::CPAN
[
\&update_indicators,
sub{$textwindow->HighlightAllPairsBracketingCursor}
]
);
$menu = $textwindow->menu;
$TOP->configure(-menu => $menu);
$help_menu = $menu->cascade(-label=>'~Help', -tearoff => 0, -menuitems => [
[Command => 'A~bout', -command => \&about_pop_up]
]);
#$TOP->minsize(30,1);
#$TOP->geometry("80x24");
while(<DATA>)
{$textwindow->insert('insert',$_);}
$textwindow->ResetUndo;
lib/Tcl/pTk/demos/widtrib/npuz.pl view on Meta::CPAN
my $mf = $MW->Frame(-bg => 'blue')->grid(-sticky => 'ew');
$mf->gridColumnconfigure(1, -weight => 1);
my $mbf = $mf->Menubutton(-text => 'File', -relief => 'raised');
$mbf->command(-label => 'New Puzzle', -command => \&new_puz);
$mbf->separator;
$mbf->command(-label => 'Quit', -command => [$MW => 'bell']);
my $mbp = $mf->Menubutton(-text => 'Prefs', -relief => 'raised');
my $pieces = 'Pieces';
$mbp->cascade(-label => $pieces);
my $mbpm = $mbp->cget(-menu);
my $mbpmp = $mbpm->Menu;
$mbp->entryconfigure($pieces, -menu => $mbpmp);
foreach (@LEVELS) {
$mbpmp->radiobutton(-label => $_,
-variable => \$PIECES,
-value => $_,
-command => \&create_puz,
);
}
t/menub-cascade.t view on Meta::CPAN
my $lmsg = "";
my $top = MainWindow->new;
# create the widgets to be explained
my $mb = $top->Menubutton(-relief => 'raised',
-text => 'Menu button')->pack;
my $xxx = 0;
$mb->checkbutton(-label => 'checkbutton',
-variable => \$xxx);
$mb->cascade(-label => 'cascade entry');
my $menu = $mb->cget(-menu);
my $cm = $menu->Menu(-tearoff => 0);
$mb->entryconfigure('cascade entry', -menu => $cm);
$cm->command(-label => 'first');
$cm->command(-label => 'second');
$mb->separator;
$mb->command(-label => 'Close',
-command => sub {$top->destroy;});
#$mb->interp->icall($mb.".m", 'add', 'cascade', -label, "cascade entry");
$top->idletasks;
(@ARGV) ? MainLoop : $top->destroy;
ok(1);
t/menuitems.t view on Meta::CPAN
my $rb = $mb->radiobutton(-label => 'radiobutton');
#print "radiobutton = $rb\n";
ok(ref($rb), $menuclass."::Radiobutton", "Radiobutton classname");
my $cm = $mb->command(-label => 'command');
#print "command = $cm\n";
ok(ref($cm), $menuclass."::Button", "Command classname");
my $cas = $mb->cascade(-label => 'cascade entry');
#print "cascasde = $cas\n";
ok(ref($cas), $menuclass."::Cascade", "Cascade classname");
my $sep = $mb->separator();
#print "cascasde = $cas\n";
ok(ref($sep), $menuclass."::Separator", "Separator classname");
# Check that cget/configure works on items
my $label = $rb->cget(-label);
#print "radiobutton label = '$label'\n";
t/menuitems.t view on Meta::CPAN
$rb = $mb->radiobutton(-label => 'radiobutton');
#print "radiobutton = $rb\n";
ok(ref($rb), $menuclass."::Radiobutton", "Radiobutton classname");
$cm = $mb->command(-label => 'command');
#print "command = $cm\n";
ok(ref($cm), $menuclass."::Button", "Command classname");
$cas = $mb->cascade(-label => 'cascade entry');
#print "cascasde = $cas\n";
ok(ref($cas), $menuclass."::Cascade", "Cascade classname");
$sep = $mb->separator();
#print "cascasde = $cas\n";
ok(ref($sep), $menuclass."::Separator", "Separator classname");
# Check that cget/configure works on items
$label = $rb->cget(-label);
#print "radiobutton label = '$label'\n";
t/ptk-compat2.t view on Meta::CPAN
[Button => '~New', -accelerator => 'Control+n'],
[Button => '~Save', -accelerator => 'Control+s'],
]
);
my $noEntries = $m->index('end');
my $type = $m->type(1);
#print "Childs = $noEntries, type = $type\n";
ok($noEntries, 1, "Number of entries in the popup");
ok($type, 'cascade', 'Type of menuitem is cascade');
my $mbmenu = $mb->menu();
#print "MB menu = $mbmenu\n";
$noEntries = $mbmenu->index('end');
my @types = map $mbmenu->type($_), (1..2);
#print "Childs = $noEntries, type = $type\n";
ok($noEntries, 2, "Number of entries in the cascade");
ok(join(", ", @types), 'command, command', 'Types of menuitem is cascade');
#print "types = ".join(", ", @types)."\n";
#$m->Post(100,100); # Posting can't be done for the automated test, because it requires clicking the menu
# to get things to continue.
$top->after(1000,sub{
$top->destroy});
MainLoop;
t/rt125058.t view on Meta::CPAN
use strict;
use Test::More tests => 1;
#use Tk; # verified for consistency with Perl/Tk
use Tcl::pTk;
my $mw = MainWindow->new;
my $menu = $mw->Menu(-tearoff => 0);
# doesn't automatically create menu for cascade
#$menu->add('cascade', -label => 'Menu...');
# *does* automatically create menu for cascade
my $cascade = $menu->Cascade(-label => 'Menu...');
pass(q(Create Cascade with '.' in -label and without -menu));
print '# $menu->type(0): ' . $menu->type(0) . "\n";
print q(# $menu->entrycget(0, '-menu')->PathName: )
. $menu->entrycget(0, '-menu')->PathName # .menu.menu_ in Perl/Tk
. "\n";
$mw->configure(-menu => $menu);
widgetTclpTk view on Meta::CPAN
nANhUgJlEBIABJIwL3K+4IcUALCHjfbItYZDSgJgkBiYPmBMAUAkkLPKs/BAyLgM
wAQwOAAY2ByCaw4QAFQSoDEePJ6DmU1xInYZTw5nOEFFdgVUelkVDTIMd3AKFGQ1
MgI2AwEmQW8APZ0gdRONAks5nhIFVVxdAAkUAS2pAVwFl7ITB4UqHb0XEQA7},
);
};
# The code below creates the main window, consisting of a menu bar
# and a text widget that explains how to use the program, plus lists
# all of the demos as hypertext items.
my $file = $menubar->cascade(qw/-label File -underline 0 -menuitems/ =>
[
[cascade => '~View', -menuitems =>
[
[command => '~widget', -command => [\&view_widget, __FILE__]],
[command => '~WidgetDemo', -command => [\&view_widget, $wd]],
], # end cascade menuitems
], # end view cascade
'',
[command => '~Quit', -command => sub{ $MW->destroy }],
]);
my $help = $menubar->cascade(qw/-label Help -underline 0 -menuitems/ =>
[
[command => '~About'],
]);
my $T = $MW->Scrolled('ROText',
-scrollbars => 'e',
-wrap => 'word',
-width => 70,
-height => 30,
-font => $FONT,
widgetTclpTk view on Meta::CPAN
'ttkpane' => '*Themed nested panes',
'ttknote' => '*Themed notebook',
);
demos 'Photos and Images', (
'photo1' => 'Transparent pixels',
'photo2' => 'Alpha channel compositing',
);
demos 'Menus and Toolbars', (
'menus' => 'Menus and cascades (sub-menus)',
'menus2' => 'As above, but using Perl/Tk -menuitems',
'menbut' => 'Menubuttons',
'ttkmenu' => '*Themed menu buttons',
'toolbar' => '*Themed toolbar',
);
demos 'Common Dialogs', (
'msgBox' => 'Message boxes',
'filebox' => 'File selection dialog',
'choosedir' => 'Directory selection dialog',
( run in 0.346 second using v1.01-cache-2.11-cpan-b32c08c6d1a )