Tcl-pTk
view release on metacpan or search on metacpan
buildTkFacelift view on Meta::CPAN
# Sub to return the template for a substitution widget
sub subsWidget{
return <<'EOD';
############# Substitution Package for oldwidget "__OLDWIDGET__" to tile widget "__TILEWIDGET__" ####################
package Tcl::Tk::Widget::__PACKAGENAME__;
@Tcl::Tk::Widget::__PACKAGENAME__::ISA = (qw / Tcl::Tk::Derived Tcl::Tk::Widget__ISA__/);
Construct Tcl::Tk::Widget '__OLDWIDGET__';
sub Populate {
my( $cw, $args ) = @_;
$cw->SUPER::Populate( $args );
lib/Tcl/pTk.pm view on Meta::CPAN
=item Megawidgets
These are widgets that are composed of one-or-more other base widget types. Pure-perl megawidgets are supported in Tcl::pTk,
just like they are in perl/Tk. Examples of these types of widgets are ProgressBar, LabEntry, BrowseEntry, and SlideSwitch
(one of the test cases in the source distribution).
=item Derived Widgets
Derived widgets are sub-classes of existing widgets that provide some additional functions. Derived widgets are created in
Tcl::pTk using very similar syntax to perl/Tk (i.e. using the Tcl::pTk::Derived package, similar to the Tk::Derived package).
Examples of these types of widgets are Tree, TextEdit, TextUndo, ROText, and DirTree.
=back
=head1 A behind-the-scenes look at auto-wrapped widgets
All widgets in C<Tcl::pTk> are objects, and have an inheritance hierarchy that derives from the C<Tcl::pTk::Widget>
parent class. Megawidgets and derived widgets are handled very similar (if not exactly) the same as in perl/tk.
Auto-wrapped widgets (like the Entry, Button, Scrollbar, etc.) are handled differently.
lib/Tcl/pTk/Derived.pm view on Meta::CPAN
#
# Megawidget support for Tcl::pTk
package Tcl::pTk::Derived;
our ($VERSION) = ('1.11');
use Carp;
use Tcl::pTk::Configure;
use strict;
my $ENHANCED_CONFIGSPECS = 0; # disable for now
#################### Methods Originally in Tk::Derived #################
sub Subwidget
{
my $cw = shift;
my @result = ();
if (exists $cw->{SubWidget})
{
if (@_)
{
foreach my $name (@_)
{
lib/Tcl/pTk/DirTree.pm view on Meta::CPAN
#
# Derived from DirTree.tcl in Tix 4.1
#
# Chris Dean <ctdean@cogit.com>
#
# John Cerney 10/24/08: Modified for Tcl::pTk
our ($VERSION) = ('1.11');
use Tcl::pTk;
use Tcl::pTk::Derived;
use Tcl::pTk::Tree;
use Cwd;
use DirHandle;
use base qw(Tcl::pTk::Derived Tcl::pTk::Tree);
use strict;
Construct Tcl::pTk::Widget 'DirTree';
sub Populate {
my( $cw, $args ) = @_;
$cw->SUPER::Populate( $args );
lib/Tcl/pTk/Facelift.pm view on Meta::CPAN
=back
=cut
############# Substitution Package for oldwidget "Radiobutton" to tile widget "ttkRadiobutton" ####################
package Tcl::pTk::RadiobuttonttkSubs;
@Tcl::pTk::RadiobuttonttkSubs::ISA = (qw / Tcl::pTk::Derived Tcl::pTk::Widget/);
Construct Tcl::pTk::Widget 'Radiobutton';
sub Populate {
my( $cw, $args ) = @_;
$cw->SUPER::Populate( $args );
lib/Tcl/pTk/Facelift.pm view on Meta::CPAN
1;
############################################################
############# Substitution Package for oldwidget "Button" to tile widget "ttkButton" ####################
package Tcl::pTk::ButtonttkSubs;
@Tcl::pTk::ButtonttkSubs::ISA = (qw / Tcl::pTk::Derived Tcl::pTk::Widget/);
Construct Tcl::pTk::Widget 'Button';
sub Populate {
my( $cw, $args ) = @_;
$cw->SUPER::Populate( $args );
lib/Tcl/pTk/Facelift.pm view on Meta::CPAN
1;
############################################################
############# Substitution Package for oldwidget "Entry" to tile widget "ttkEntry" ####################
package Tcl::pTk::EntryttkSubs;
@Tcl::pTk::EntryttkSubs::ISA = (qw / Tcl::pTk::Derived Tcl::pTk::Widget/);
Construct Tcl::pTk::Widget 'Entry';
sub Populate {
my( $cw, $args ) = @_;
# Set foreground and background options to undef, unless defined during widget creation
# This keeps Tcl::pTk::Derived from setting these options from the options database, which is
# not needed for ttk widgets, and also makes -state => 'disabled' not look right
foreach my $option( qw/ -foreground -background /){
$args->{$option} = undef unless( defined($args->{$option} ));
}
$cw->SUPER::Populate( $args );
#### Setup options ###
lib/Tcl/pTk/Facelift.pm view on Meta::CPAN
1;
############################################################
############# Substitution Package for oldwidget "Frame" to tile widget "ttkFrame" ####################
package Tcl::pTk::FramettkSubs;
@Tcl::pTk::FramettkSubs::ISA = (qw / Tcl::pTk::Derived Tcl::pTk::Frame/);
Construct Tcl::pTk::Widget 'Frame';
sub Populate {
my( $cw, $args ) = @_;
$cw->SUPER::Populate( $args );
lib/Tcl/pTk/Facelift.pm view on Meta::CPAN
1;
############################################################
############# Substitution Package for oldwidget "Checkbutton" to tile widget "ttkCheckbutton" ####################
package Tcl::pTk::CheckbuttonttkSubs;
@Tcl::pTk::CheckbuttonttkSubs::ISA = (qw / Tcl::pTk::Derived Tcl::pTk::Widget/);
Construct Tcl::pTk::Widget 'Checkbutton';
sub Populate {
my( $cw, $args ) = @_;
$cw->SUPER::Populate( $args );
lib/Tcl/pTk/Facelift.pm view on Meta::CPAN
1;
############################################################
############# Substitution Package for oldwidget "Label" to tile widget "ttkLabel" ####################
package Tcl::pTk::LabelttkSubs;
@Tcl::pTk::LabelttkSubs::ISA = (qw / Tcl::pTk::Derived Tcl::pTk::Widget/);
Construct Tcl::pTk::Widget 'Label';
sub Populate {
my( $cw, $args ) = @_;
$cw->SUPER::Populate( $args );
lib/Tcl/pTk/Facelift.pm view on Meta::CPAN
1;
############################################################
############# Substitution Package for oldwidget "BrowseEntry" to tile widget "ttkBrowseEntry" ####################
package Tcl::pTk::BrowseEntryttkSubs;
@Tcl::pTk::BrowseEntryttkSubs::ISA = (qw / Tcl::pTk::Derived Tcl::pTk::ttkBrowseEntry/);
{
local $^W = 0; # To avoid subroutine redefined warning messages
Construct Tcl::pTk::Widget 'BrowseEntry';
}
# If we are being used in conjunction with TkHijack, we don't need a mapping for Tk::BrowseEntry
if( defined $Tcl::pTk::TkHijack::translateList){
#print STDERR "undoing translatelist\n";
lib/Tcl/pTk/Facelift.pm view on Meta::CPAN
my $obj = $self->Tcl::pTk::ttkBrowseEntry(@_);
bless $obj, "Tcl::pTk::BrowseEntryttkSubs";
return $obj;
}
############# Substitution Package for oldwidget "NoteBook" to tile widget "ttkTixNoteBook" ####################
package Tcl::pTk::NoteBookttkSubs;
@Tcl::pTk::NoteBookttkSubs::ISA = (qw / Tcl::pTk::Derived Tcl::pTk::ttkTixNoteBook/);
{
local $^W = 0; # To avoid subroutine redefined warning messages
Construct Tcl::pTk::Widget 'NoteBook';
}
# If we are being used in conjunction with TkHijack, we don't need a mapping for Tk::NoteBook
if( defined $Tcl::pTk::TkHijack::translateList){
#print STDERR "undoing translatelist\n";
lib/Tcl/pTk/Frame.pm view on Meta::CPAN
#
# Dummy Frame.pm
# Needed so 'use base('Tcl::pTk::Frame') works in megawidgets (e.g. SlideSwitch.pm)
package Tcl::pTk::Frame;
our ($VERSION) = ('1.11');
use base ('Tcl::pTk::Derived', 'Tcl::pTk::Widget');
use strict;
# 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.
use strict qw(vars);
use Carp;
#Construct Tcl::pTk::Widget 'Frame';
lib/Tcl/pTk/Image.pm view on Meta::CPAN
# 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.
package Tcl::pTk::Image;
our ($VERSION) = ('1.11');
# This module does for images what Tk::Widget does for widgets:
# provides a base class for them to inherit from.
use base qw(Tcl::pTk::Widget Tcl::pTk::Derived);
sub new
{
my $package = shift;
my $widget = shift;
$package->InitClass($widget);
my $int = $widget->interp();
$int->pkg_require('Img');
lib/Tcl/pTk/Listbox.pm view on Meta::CPAN
tie @$listvariable, 'Tcl::pTk::Listbox', $self;
@$listvariable = @listVars; # set the values after the tie
}
# Untie the currently tied listvar, if it exists
my $currentListVar;
if( !defined($listvariable) &&
defined( $currentListVar = $self->Tcl::pTk::Derived::_cget(-listvariable)) &&
tied($$currentListVar)){
untie($$currentListVar);
}
# Store listvariable in the configuration store, for retreival later
$self->Tcl::pTk::Derived::_configure(-listvariable, $listvariable);
}
return $self->SUPER::configure(%args);
}
# Overridden cget to return the -listvariable ref, if it has been setgrent
# reference it.)
sub cget {
my $self = shift;
my @args = @_;
my $option = $args[0];
if( $option eq '-listvariable'){ # return the store list variable
return $self->Tcl::pTk::Derived::_cget(-listvariable);
}
# Otherwise call the parent cget
return $self->SUPER::cget(@args);
}
# Method to enable balloons to be attached to individual items
# in a listbox by supplying an array as -msg (See the balloon.pl demo for example)
sub BalloonInfo
{
lib/Tcl/pTk/Menu.pm view on Meta::CPAN
package Tcl::pTk::Menu;
our ($VERSION) = ('1.11');
# Simple Menu package.
# This file is needed to provide the proper inheritance of Menu to
# the Wm, Derived and widget packages
#
use base qw(Tcl::pTk::Wm Tcl::pTk::Derived Tcl::pTk::Widget);
use Tcl::pTk::Widget();
use Tcl::pTk::Wm();
use Tcl::pTk::Derived();
use Tcl::pTk::Menubutton;
use Tcl::pTk::Menu::Item;
Tcl::pTk::Widget->Construct('Menu');
sub CreateArgs{
my $package = shift;
my $parent = shift;
my $args = shift;
lib/Tcl/pTk/Optionmenu.pm view on Meta::CPAN
use warnings;
use strict;
use Tcl::pTk;
require Tcl::pTk::Menubutton;
require Tcl::pTk::Menu;
use Carp;
use base qw(Tcl::pTk::Derived Tcl::pTk::Menubutton);
Construct Tcl::pTk::Widget 'Optionmenu';
sub Populate
{
my ($w,$args) = @_;
$w->SUPER::Populate($args);
$args->{-indicatoron} = 1;
my $menu = $w->menu;
$menu->configure(-tearoff => 0);
lib/Tcl/pTk/Pane.pm view on Meta::CPAN
# when we set the Tcl::pTk::Pane::ISA below
#
package Tcl::pTk::ScrollableFrame;
package Tcl::pTk::Pane;
our ($VERSION) = ('1.11');
use Tcl::pTk;
use Tcl::pTk::Widget;
use Tcl::pTk::Derived;
use Carp (qw/ croak /);
use strict;
#use base qw(Tcl::pTk::Derived Tcl::pTk::ScrollableFrame);
@Tcl::pTk::Pane::ISA = (qw/ Tcl::pTk::Derived Tcl::pTk::ScrollableFrame /);
Tcl::pTk::Widget->Construct('Pane');
# Setup binding so the scrollwheel works
sub ClassInit
{
my ($class,$mw) = @_;
$class->SUPER::ClassInit($mw);
lib/Tcl/pTk/ProgressBar.pm view on Meta::CPAN
our ($VERSION) = ('1.11');
use warnings;
use strict;
use Tcl::pTk;
use Tcl::pTk::Canvas;
#use Tk::Trace;
use Carp;
use base qw(Tcl::pTk::Derived Tcl::pTk::Canvas);
Construct Tcl::pTk::Widget 'ProgressBar';
sub ClassInit {
my ($class,$mw) = @_;
$class->SUPER::ClassInit($mw);
$mw->bind($class,'<Configure>', ['_layoutRequest',1]);
}
lib/Tcl/pTk/ROText.pm view on Meta::CPAN
# 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.
#
# Modified 2008 for inclusion into the Tcl::pTk package
package Tcl::pTk::ROText;
our ($VERSION) = ('1.11');
use base qw(Tcl::pTk::Derived Tcl::pTk::Text);
Construct Tcl::pTk::Widget 'ROText';
sub clipEvents
{
return qw[Copy];
}
sub ClassInit
{
lib/Tcl/pTk/Table.pm view on Meta::CPAN
#
package Tcl::pTk::Table;
our ($VERSION) = ('1.11');
use strict;
use Tcl::pTk::TableMatrix;
use base qw(Tcl::pTk::Derived Tcl::pTk::Frame);
Construct Tcl::pTk::Widget 'Table';
sub Populate
{
my ($t,$args) = @_;
$t->SUPER::Populate($args);
my $scrollbars = delete $args->{-scrollbars};
lib/Tcl/pTk/TableMatrix.pm view on Meta::CPAN
package Tcl::pTk::TableMatrix;
our ($VERSION) = ('1.11');
###########################################################
# Emulation of the perl/tk Tablematrix widget using Tcl::pTk
###########################################################
@Tcl::pTk::TableMatrix::ISA = (qw / Tcl::pTk::Derived Tcl::pTk::Widget/);
use strict;
use Tcl::pTk ('Ev');
use Carp;
Construct Tcl::pTk::Widget 'TableMatrix';
# Predeclare methods like 'borderMark', 'clearCache', so they don't have to be autoloaded
use Tcl::pTk::Submethods ( 'border' => [qw(dragto)],
lib/Tcl/pTk/TableMatrix/Spreadsheet.pm view on Meta::CPAN
=cut
use Carp;
use Tcl::pTk (qw/ Ev /);
use Tcl::pTk::TableMatrix;
use Tcl::pTk::Derived;
use base qw/ Tcl::pTk::Derived Tcl::pTk::TableMatrix/;
Tcl::pTk::Widget->Construct("Spreadsheet");
sub ClassInit{
my ($class,$mw) = @_;
$class->SUPER::ClassInit($mw);
lib/Tcl/pTk/TableMatrix/SpreadsheetHideRows.pm view on Meta::CPAN
In addition the standard L<Tk::TableMatrix> widget method. The following methods are implemented:
=cut
use Carp;
use Tcl::pTk;
use Tcl::pTk::TableMatrix::Spreadsheet;
use Tcl::pTk::Derived;
use base qw/ Tcl::pTk::Derived Tcl::pTk::TableMatrix::Spreadsheet/;
Tcl::pTk::Widget->Construct("SpreadsheetHideRows");
sub ClassInit{
my ($class,$mw) = @_;
$class->SUPER::ClassInit($mw);
lib/Tcl/pTk/TextUndo.pm view on Meta::CPAN
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Tcl::pTk::TextUndo;
our ($VERSION) = ('1.11');
$DoDebug = 0;
use Tcl::pTk qw (Ev);
use base qw(Tcl::pTk::Text Tcl::pTk::Derived );
Construct Tcl::pTk::Widget 'TextUndo';
sub ClassInit
{
my ($class,$mw) = @_;
$mw->bind($class,'<<Undo>>','undo');
$mw->bind($class,'<<Redo>>','redo');
return $class->SUPER::ClassInit($mw);
lib/Tcl/pTk/TkHijack.pm view on Meta::CPAN
# The aliases below will essentially translate to code to mean:
# use base(qw/ Tcl::pTk::Frame /);
# Construct Tcl::pTk::Widget 'SlideSwitch'
#
$packageAliases = {
'Tk::widgets' => 'Tcl::pTk::widgets',
'Tk::Frame' => 'Tcl::pTk::Frame',
'Tk::Toplevel' => 'Tcl::pTk::Toplevel',
'Tk::MainWindow' => 'Tcl::pTk::MainWindow',
'Tk::Widget'=> 'Tcl::pTk::Widget',
'Tk::Derived'=> 'Tcl::pTk::Derived',
'Tk::DropSite' => 'Tcl::pTk::DropSite',
'Tk::Canvas' => 'Tcl::pTk::Canvas',
'Tk::Menu'=> 'Tcl::pTk::Menu',
'Tk::TextUndo'=> 'Tcl::pTk::TextUndo',
'Tk::Text'=> 'Tcl::pTk::Text',
'Tk::Tree'=> 'Tcl::pTk::Tree',
'Tk::Clipboard'=> 'Tcl::pTk::Clipboard',
'Tk::Configure'=> 'Tcl::pTk::Configure',
'Tk::BrowseEntry'=> 'Tcl::pTk::BrowseEntry',
'Tk::Callback'=> 'Tcl::pTk::Callback',
lib/Tcl/pTk/Tree.pm view on Meta::CPAN
#
# Derived from Tree.tcl in Tix 4.1
#
# Chris Dean <ctdean@cogit.com>
#
# Converted to Tcl::pTk John Cerney
our ($VERSION) = ('1.11');
use Tcl::pTk ();
use Tcl::pTk::Derived;
use Tcl::pTk::HList;
use base qw(Tcl::pTk::Derived Tcl::pTk::HList);
use strict;
Construct Tcl::pTk::Widget 'Tree';
sub Tcl::pTk::Widget::ScrlTree { shift->Scrolled('Tree' => @_) }
sub Populate
{
lib/Tcl/pTk/Widget.pm view on Meta::CPAN
package Tcl::pTk::Widget;
our ($VERSION) = ('1.11');
use Config;
use IO::Handle;
use Class::ISA; # Used for finding the base class of a derived widget
use Tcl::pTk::Callback;
use Tcl::pTk::MegaWidget;
use Tcl::pTk::Derived;
use Tcl::pTk::Trace;
use Tcl::pTk::Frame;
use Tcl::pTk::HList;
use Tcl::pTk::Text;
use Tcl::pTk::Entry;
use Tcl::pTk::Photo;
use Tcl::pTk::Bitmap;
use Tcl::pTk::XEvent; # Limited XEvent support
use Tcl::pTk::Font;
lib/Tcl/pTk/Widget.pm view on Meta::CPAN
if( blessed($arg) && $arg->isa('Tcl::pTk::Callback')){
$cb = $arg;
}
else{
$cb = Tcl::pTk::Callback->new($arg);
}
# Store callback in the Configuration store of the widget
# This is to be compatible with perltk's method of storing subrefs as callback objects
# (as opposed to raw subrefs).
$self->Tcl::pTk::Derived::_configure($lastArg, $cb);
# Make a subref that will execute the callback
my $cbSub = sub{
my @callbackArgs = @_;
# Get rid of extra stuff from the args to be supplied for old Tcl.pm's
splice(@callbackArgs, 0, 3) if( $Tcl::VERSION < 0.98); # remove ClientData, Interp and CmdName
#print "Callback Args = '".join("', '", @callbackArgs)."'\n";
$cb->Call(@callbackArgs)
};
lib/Tcl/pTk/Widget.pm view on Meta::CPAN
$callMethod = 'call'; # need to use call, rather than invoke
}
elsif( $lastArg =~ /variable$/ ){ # Check for last arg something like -textvariable
# Store -variable options in the Configuration store of the widget
# This is to be compatible with perltk's way of being able to retieve the actual
# scalar reference
# For example, $entry->configure(-textvariable => \$text),
# $entry->cget(-textvariable) <= should return \$text
#
$self->Tcl::pTk::Derived::_configure($lastArg, $arg); # Store in config store for retrieval later
$callMethod = 'call'; # need to use call, rather than invoke
}
}
if( ref($arg) eq 'SCALAR'){ # scalar refs or code need to be turned to tcl variables, so we use call, not invoke
$callMethod = 'call';
}
$lastArg = $arg;
lib/Tcl/pTk/Widget.pm view on Meta::CPAN
}
# Return the Callback object if a -command type option is requested,
# for compatibility with perlTk
if( defined($option) && !ref($option) && ( $option =~ /^-\w+/ )){
if( $option =~ /command|cmd$/ ){ # Check the option for something like -command
# Retrieve callback from the configuration store of the widget
# This is to be compatible with perltk's method of storing subrefs as callback objects
# (as opposed to raw subrefs)
return $self->Tcl::pTk::Derived::_cget(@args);
}
if( $option =~ /variable$/) { # Check the option for something like -textvariable
# Retrieve scalar ref from the configuration store of the widget
# This is to be compatible with perltk way of being able to retrieve the scalar
# -textvariable using a cget call.
return $self->Tcl::pTk::Derived::_cget(@args);
}
}
# Return an image object, if one requested
# for compatibility with perlTk
if( defined($option) and $option eq '-image' ){
my $name = $self->call($self->path, 'cget', '-image');
if( $name){
# Turn image into an object;
my $type = $self->call('image', 'type', $name);
lib/Tcl/pTk/Widget.pm view on Meta::CPAN
}
# Check for -command args. If set, these should be callbacks
if( @return ){
foreach my $configElem (@return){
next unless ref($configElem);
next unless $configElem->[0] =~ /command|cmd$/; # Check the option for something like -command
# Replace the returned tcl command name with the stored callback
my $callback = $self->Tcl::pTk::Derived::_cget( $configElem->[0] );
$configElem->[4] = $callback;
}
}
return @return;
}
lib/Tcl/pTk/Wm.pm view on Meta::CPAN
# Adapted for use with Tcl::pTk 9-21-08
package Tcl::pTk::Wm;
our ($VERSION) = ('1.11');
use warnings;
use strict;
use base qw( Tcl::pTk::Derived );
# There are issues with this stuff now we have Tix's wm release/capture
# as toplevel-ness is now dynamic.
Direct Tcl::pTk::Submethods ('wm' => [qw(aspect attributes capture client colormapwindows command
deiconify focusmodel frame geometry group
iconbitmap iconify iconphoto iconmask iconname
iconwindow maxsize minsize overrideredirect positionfrom
release resizable sizefrom stackorder state title transient
withdraw wrapper )]);
lib/Tcl/pTk/demos/widget_lib/mega.pl view on Meta::CPAN
Functional mega-widgets look more like this:
package Tk::MyNewWidget;
# Declare base class.
use base qw/ Tk::Frame /; # Frame-based composite
or
use base qw/ Tk::Toplevel /; # Toplevel-based composite
or
use Tk:SomeWidget;
use base qw/ Tk::Derived Tk::SomeWidget /; # derived from SomeWidget
Construct Tk::Widget 'MyNewWidget'; # install MyNewWidget in pTk namespace
sub ClassInit{ # called once to initialize new class
my($class, $mw) = @_;
$class->SUPER::ClassInit($mw);
}
sub Populate { # called to build each widget instance
my($self, $args) = @_;
lib/Tcl/pTk/demos/widget_lib/mega.pl view on Meta::CPAN
# Public methods.
1; # end class MyNewWidget
# Don't forget POD documentation here!
Here's an excerpt from a Text derived mega-widget called TraceText; you can examine the complete code in another demonstration. This widget defines its content using a new -textvariable option.
package Tk::TraceText;
use base qw/Tk::Derived Tk::Text/;
Construct Tk::Widget 'TraceText';
sub Populate {
my( $self, $args ) = @_;
$self->ConfigSpecs(
-textvariable => 'METHOD', 'textVariable', 'TextVariable', undef,
);
lib/Tcl/pTk/demos/widget_lib/mega.pl view on Meta::CPAN
sub textvariable {
my ( $self, $vref ) = @_;
$self->traceVariable( $vref, 'w', [ \&tracew => $self, $vref ] );
$self->{_vref} = $vref; # store watchpoint in an instance variable
} # end textvariable
If you compare the preamble (the first three lines) with that of the Nil mega-widget, you'll note that they are virtually identical - the important difference is the addition of the Tk::Derived class that provides additional methods specifically for ...
At that point, with three lines of code, we have a completely functional mega-widget called TraceText that is identical to the standard Text widget in every way, and the key to all this is the Construct() call, which, among other duties, installs the...
Construct() also arranges for the TraceText "instantiator" to call-out to the well-known method Populate() - this is how the mega-widget author adds behavior to the new widget. Similarly, the mega-widget author can provide a ClassInit() method that i...
Tk::TraceText::Populate defines the -textvariable option and provides a private method to establish the watchpoint. In Perl/Tk, all mega-widget options are specified via a ConfigSpecs() call, named after the C structure.
Briefly, ConfigSpecs() names options and tells Perl/Tk what to do when one is specified on a configure() or cget() call. It also specifies the option's database name, class name and default value for option DB lookups. For our -textvariable option, t...
More details on mega-widget construction can be found in these man pages:
Tk::ConfigSpecs, Tk::Derived, Tk::composite, Tk::mega
end-of-instructions
} # end mega
lib/Tcl/pTk/demos/widget_lib/trace2.pl view on Meta::CPAN
# trace2.pl
use warnings;
use strict;
$Tcl::pTk::TraceText::VERSION = '1.0';
package Tcl::pTk::TraceText;
use Tcl::pTk;
use base qw/ Tcl::pTk::Derived Tcl::pTk::Text /;
Construct Tcl::pTk::Widget 'TraceText';
sub Populate {
my( $self, $args ) = @_;
$self->SUPER::Populate( $args );
$self->ConfigSpecs(
lib/Tcl/pTk/ttkBrowseEntry.pm view on Meta::CPAN
use strict;
use base qw(Tcl::pTk::Frame);
Construct Tcl::pTk::Widget 'ttkBrowseEntry';
sub Populate {
my ($cw, $args) = @_;
# Set foreground and background options to undef, unless defined during widget creation
# This keeps Tcl::pTk::Derived from setting these options from the options database, which is
# not needed for ttk widgets, and also makes -state => 'disabled' not look right
foreach my $option( qw/ -foreground -background /){
$args->{$option} = undef unless( defined($args->{$option} ));
}
# combobox widget
my $lpack = delete $args->{-labelPack};
if (not defined $lpack) {
$lpack = [-side => 'left', -anchor => 'e'];
}
lib/Tcl/pTk/ttkTixNoteBook.pm view on Meta::CPAN
use strict;
use base qw(Tcl::pTk::Frame);
Construct Tcl::pTk::Widget 'ttkTixNoteBook';
sub Populate {
my ($cw, $args) = @_;
# Set foreground and background options to undef, unless defined during widget creation
# This keeps Tcl::pTk::Derived from setting these options from the options database, which is
# not needed for ttk widgets, and also makes -state => 'disabled' not look right
foreach my $option( qw/ -foreground -background /){
$args->{$option} = undef unless( defined($args->{$option} ));
}
$cw->SUPER::Populate($args);
# Setup label options that will be ignored (setup to just be passive), because they don't
# exists in the substituted tile widget
my @ignoreOptions = ( qw/
t/emptyMenuButtonSubclass.t view on Meta::CPAN
$mw->after(3000,sub{$mw->destroy});
MainLoop;
BEGIN{
#### Empty Menubutton Subclass defined here #####
package Tcl::pTk::Menubutton2;
@Tcl::pTk::Menubutton2::ISA = (qw/ Tcl::pTk::Derived Tcl::pTk::Menubutton/);
Construct Tcl::pTk::Widget 'Menubutton2';
# Options that need to be issued at widget creation
sub CreateOptions
{
return ( qw/ -menuitems -underline -tearoff -text /);
}
t/emptyMenuSubclass.t view on Meta::CPAN
ok(1);
BEGIN{
#### Empty Menu Subclass #####
package Tcl::pTk::Menu2;
@Tcl::pTk::Menu2::ISA = (qw/ Tcl::pTk::Derived Tcl::pTk::Menu/);
Construct Tcl::pTk::Widget 'Menu2';
#### Empty Button Subclass #####
package Tcl::pTk::Button2;
@Tcl::pTk::Button2::ISA = (qw/ Tcl::pTk::Derived Tcl::pTk::Button/);
Construct Tcl::pTk::Widget 'Button2';
}
t/textSubwidget.t view on Meta::CPAN
use warnings;
use strict;
package Tcl::pTk::TextTest;
use vars qw($VERSION @ISA);
$VERSION = substr(q$Revision: 2.8 $, 10) . "";
use Tcl::pTk;
use Tcl::pTk::Derived;
use Tcl::pTk::Frame;
@ISA = qw(Tcl::pTk::Derived Tcl::pTk::Frame);
Construct Tcl::pTk::Widget 'TextTest';
sub Populate {
my ($cw, $args) = @_;
$cw->SUPER::Populate($args);
( run in 2.565 seconds using v1.01-cache-2.11-cpan-d7a12ab2c7f )