File Coverage

blib/lib/Tcl/pTk.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package Tcl::pTk;

our ($VERSION) = ('0.90');

use strict;
use Tcl;
use Exporter ('import');
use Scalar::Util (qw /blessed/); # Used only for it's blessed function
use AutoLoader; # Used for autoloading the Error routine
use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS $platform @cleanup_refs $cleanup_queue_maxsize $cleanupPending);

# Wait till we have 100 things to delete before we do cleanup
$cleanup_queue_maxsize = 50;

# Set the platform global variable, based on the OS we are running under
BEGIN{
 if($^O eq 'cygwin')
  {
   $platform = 'MSWin32'
  }
 else
  {
   $platform = ($^O eq 'MSWin32') ? $^O : 'unix';
  }
};


use Tcl::pTk::Widget;
use Tcl::pTk::MainWindow;
use Tcl::pTk::DialogBox;
use Tcl::pTk::Dialog;
use Tcl::pTk::LabEntry;
use Tcl::pTk::ROText;
use Tcl::pTk::Listbox;
use Tcl::pTk::Balloon;
use Tcl::pTk::Menu;
use Tcl::pTk::Menubutton;
use Tcl::pTk::Optionmenu;
use Tcl::pTk::Canvas;
use Tcl::pTk::Font;


# Tcl::pTk::libary variable: Translation from perl/tk Tk.pm
{($Tcl::pTk::library) = __FILE__ =~ /^(.*)\.pm$/;}
$Tcl::pTk::library = Tk->findINC('.') unless (defined($Tcl::pTk::library) && -d $Tcl::pTk::library);


# Global vars used by this package

our ( %W, $Wint, $Wpath, $Wdata, $DEBUG, $inMainLoop );


# For debugging, we use Sub::Name to name anonymous subs, this makes tracing the program
#   much easier (using perl -d:DProf or other tools)
$DEBUG =0 unless defined($DEBUG);
if($DEBUG){
        require Sub::Name;
        import Sub::Name;
}


@Tcl::pTk::ISA = qw(Tcl);


sub WIDGET_CLEANUP() {1}

$Tcl::pTk::DEBUG ||= 0;

sub _DEBUG {
    # Allow for optional debug level and message to be passed in.
    # If level is passed in, return true only if debugging is at
    # that level.
    # If message is passed in, output that message if the level
    # is appropriate (with any extra args passed to output).
    my $lvl = shift;
    return $Tcl::pTk::DEBUG unless defined $lvl;
    my $msg = shift;
    if (defined($msg) && ($Tcl::pTk::DEBUG >= $lvl)) { print STDERR $msg, @_; }
    return ($Tcl::pTk::DEBUG >= $lvl);
}


=head1 NAME

Tcl::pTk - Interface to Tcl/Tk with Perl/Tk compatible sytax

=head1 SYNOPSIS

B

    use Tcl::pTk;

    my $mw = MainWindow->new();
    my $lab = $mw->Label(-text => "Hello world")->pack;
    my $btn = $mw->Button(-text => "test", -command => sub {
        $lab->configure(-text=>"[". $lab->cget('-text')."]");
    })->pack;
    MainLoop;

Or B

    use Tcl::pTk;
    my $int = new Tcl::pTk;
    $int->Eval(<<'EOS');
    # pure-tcl code to create widgets (e.g. generated by some GUI builder)
    entry .e
    button .inc -text {increment by Perl}
    pack .e .inc
    EOS
    my $btn = $int->widget('.inc'); # get .inc button into play
    my $e = $int->widget('.e');     # get .e entry into play
    $e->configure(-textvariable=>\(my $var='aaa'));
    $btn->configure(-command=>sub{$var++});
    $int->MainLoop;

=head1 DESCRIPTION

C interfaces perl to an existing Tcl/Tk
installation on your computer. It has fully perl/tk (See L) compatible syntax for running existing
perl/tk scripts, as well as direct-tcl syntax for using any other Tcl/Tk features.

Using this module an interpreter object is created, which
then provides access to all the installed Tcl libraries (Tk, Tix,
BWidgets, BLT, etc) and existing features (for example native-looking
widgets using the C package).

B

=over

=item *

Perl/Tk compatible syntax.

=item *

Pure perl megawidgets work just like in perl/tk. See the test case t/slideMegaWidget.t in the source distribution
for a simple example.

=item *

All the perl/tk widget demos work with minimal changes. Typically the only changes needed are just changing the "Use Tk;"
to "Use Tcl::pTk" at the top of the file. See the I demo script included in the source distribution to run the demos.

=item *

Built-in local drag-drop support, compatible with perl/tk drag-drop coding syntax.

=item *

L package supplied which enables Tcl::pTk to be used with existing Tk Scripts.

=item *

Similar interface approach to Tcl/Tk that other dynamic languages use (e.g. ruby, python). Because of this approach,
upgrades to Tcl/Tk shouldn't require much coding changes (if any) in L.

=item *

L package supplied, which provides a quick way of using the new better-looking Tile/ttk widgets in existing code.

=item *

TableMatrix (spreadsheet/grid Tktable widget, built to emulate the perl/tk L interface ) built into the package
(as long as you have the Tktable Tcl/Tk extension installed).

=item *

Extensive test suite.

=item *

Compatible with Tcl/Tk 8.4+

=back

=head2 Examples

There are many examples in the I script (This is very simlar to the I demo installed with
perl/tk). After installing the L package, type I on the command line to run.

The test cases in the I directory of the source distribution also is a good source of code examples.

=head1 Relation to the L Package

This package (L) is similar (and much of the code is derived from) the L package,
maintained by Vadim Konovalov. However it differs from the L package in some important ways:

=over 1

=item * L

Emphasis is on 100% compatibility with existing perl/tk syntax.

For developers with a perl/Tk background and an existing perl/Tk codebase to support.
For perl/Tk developers looking to take
advantage of the look/feel updates in Tcl/Tk 8.5 and above.

=item * L

Emphasis is on a lightweight interface to Tcl/Tk with syntax similar to (but not exactly like) perl/tk.

For developers with some perl/Tk background, writing new code,
but no existing perl/Tk codebase to support.

=back

=head1 Basic Usage/Operation

=head2 Creating a Tcl interpreter for Tk

Before you start using widgets, an interpreter (at least one) should be
created, which will manage all things in Tcl. Creating an interpreter is created automatically
my the call to the C (or C) methods, but can also be created explicitly.

B
For perl/tk syntax, the interpreter is created for you when you create the mainwindow.

   use Tcl::pTk;

   my $mw = MainWindow->new(); # Create Tcl::pTk interpreter and returns mainwindow widget
   my $int = $mw->interp;      # Get the intepreter that was created in the MainWindow call

B

   use Tcl::pTk;

   my $int = new Tcl::pTk;

Optionally a DISPLAY argument can be specified: C.
This creates a Tcl interpreter object $int, and creates a main toplevel
window. The window is created on display DISPLAY (defaulting to the display
named in the DISPLAY environment variable)

=head2 Entering the main event loop

B

  MainLoop;  # Exact same syntax used as perl/Tk

B

  $inst->MainLoop;

=head2 Creating and using widgets

Two different approaches are used to manipulate widgets (or to manipulate any Tcl objects that
act similarly to widgets).

=over

=item *

Perl/Tk compatible-syntax approach. i.e. C<< $widget->method >> syntax.

=item *

Direct access using Eval-ed Tcl code. (e.g. using the C<< Eval >> Tcl::pTk method)

=back

The first way to manipulate widgets is identical to the perl/Tk calling conventions,
the second one uses Tcl syntax. Both ways are interchangeable in that a widget
created with one way can be used the another way. This interchangability enables
use of Tcl-code created elsewhere (e.g. by some WYSIWYG IDE).

Usually Perl programs operate with Tcl::pTk via perl/Tk syntax, so users have no
need to deal with the Tcl language directly. Only some basic understanding of
Tcl/Tk widgets is needed.


=head3 Tcl/Tk syntax

In order to get better understanding on usage of Tcl/Tk widgets from within
Perl, a bit of Tcl/Tk knowledge is needed, so we'll start from 2nd approach,
with Tcl's Eval (C<< $int->Eval('...') >>) and then smoothly move to first
approach with perl/Tk syntax.

=over

=item * The Tcl Interpreter

The Tcl interpreter is used to process Tcl/Tk widgets; within C you
create it with C, and given any widget object, you can retreive it by the
C<< $widget->interp >> method. ( Within pure Tcl/Tk the interpreter already exists,
you don't need to create it explicitly. )

=item * The Widget Path

The Widget path is a string starting with a dot and consisting of several
names separated by dots. These names are individual widget-names that comprise
a widget's hierarchy. As an example, if there exists a frame with a path
C<.fram>, and you want to create a button on it and name it C, then
you should specify name C<.fram.butt>. Widget paths are also refered in
other miscellaneous widget operations, like geometry management.

At any time a widget's path can be retreived with C<< $widget->path; >>
within C.

=item * The Widget Path as a Tcl/Tk command

When a widget is created in Tcl/Tk, a special command is created that is the name of the
widget's path. For example, a button created in a frame has a path and command-name C<.fr.b>. This
command also has subcommands which manipulate the widget. That is why
C<< $int->Eval('.fr.b configure -text {new text}'); >> makes sense.
Note that using perl/tk syntax C<< $button->configure(-text=>'new text'); >> does exactly the same thing,
if C<$button> corresponds to C<.fr.b> widget.


=back


The C statement not only creates the C package, but also creates the
C package, which is responsible for widgets. Each widget ( an object
blessed to C, or any of its subclasses )
behaves in such a way that its method will result in calling it's path on the
interpreter.

=head3 Perl/Tk syntax

C fully supports perl/Tk widget syntax of the L package, which has been used for many years. This means that any C widget
has a number of methods like C, C, C, C and so
on, and invoking those methods will create an appropriate child widget.
C will generate an unique path-name for a newly created widget.

To demonstrate this concept, the perl/Tk syntax:

    my $label = $frame->Label(-text => "Hello world");

executes the command

    $int->call("label", ".l", "-text", "Hello world");

and this command similar to

    $int->Eval("label .l -text {Hello world}");

This way Tcl::pTk widget commands are translated to Tcl syntax and directed to
the Tcl interpreter. This translation that occurs from perl/Tk syntax to Tcl calls is why the two approaches for
dealing with widgets are interchangeable.

The newly created widget C<$label> will be blessed to package C
which is isa-C (i.e. C is a subclass of C).


=head1 Categories of Tcl::pTk Widgets

C Widgets fall into the following basic categories, based on how they are implemented in the C package.

=over 1

=item Direct auto-wrapped widgets

These types of widgets (for example the Entry, Button, Scrollbar, and Label widgets) have no special code written for them
in C. Their creation and method calls (e.g. C<$button->configure(-text => 'ButtonText')> ) are handled
by the wrapping code in the base Tcl::pTk::Widget package.

=item Auto-wrapped widgets, with compatibility code

These types of widgets are similar to the Direct auto-wraped widgets, but have additional code written to be completely
compatibile with the perl/Tk syntax. Examples of this type of widget are the Text, Frame, Menu, and Menubutton widgets.

=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 are objects, and have an inheritance hierarchy that derives from the C
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.
The object system for these types of widgets is dynamic. Classes and/or methods are created when they are
first used or needed.

The following describes how methods are called for the two different categories of auto-wrapped widgets

=over 1

=item Direct auto-wrapped widget example

Here is an example of a Entry widget, a direct auto-wrapped widget:

  my $entry = $mw->Entry->pack;          # Create an entry widget and pack it
  $entry->insert('end', -text=>'text');  # Insert some text into the Entry
  my $entryText = $entry->get();         # Get the entry's text

Internally, the following mechanics come into play:
The I method creates an I widget (known as C in the Tcl/Tk environment).
When this creation method is invoked the first time, a package
C is created, which sets up the class hierarchy for any
further Entry widgets. The newly-created C class is be
a direct subclass of C.

The second code line above calls the C method of the C<$entry> object.
When invoked first time, a method (i.e. subref) C is
created in package C, which will end-up calling
calling the C method on the Tcl/Tk interpreter (i.e.
C<$entry->interp()->invoke($entry, 'insert', -text, 'text')

The first time C is called, the C method does not exist, so AUTOLOAD
comes into play and creates the method. The second time C is called, the already-created
method is called directly (i.e. not created again), thus saving execution time.

=item Auto-wrapped widgets, with compatibility code

Here is an example of a Text widget, which is an auto-wrapped widget with extra
code added for compatibility with the perl/tk Text widget.

  my $text = $mw->Text->pack;            # Create an text widget and pack it
  $text->insert('end', -text=>'text');   # Insert some text into the Text
  @names = $text->markNames;             # Get a list of the marks set in the
                                         #  Text widget

Internally, following mechanics come into play:
The I method creates an I widget (known as C in Tcl/Tk environment).
Because a C package already exists, a new package is not created
at runtime like the case above.

The second code line above calls the C of the C<$text> object of type
C. This C method is already defined in the C package,
so it is called directly.

The third code line above calls the C method on the C<$text> object. This method
is not defined in the C package, so the first time when C is called,
AUTOLOAD in the L package comes into play and creates the method.
The second time C is called, the already-created
method is called directly (i.e. not created again), thus saving execution time.

=back

=head2 Description of an auto-wrapped method call

Suppose C<$widget> isa C, its path is C<.path>, and method
C invoked on it with a list of parameters, C<@parameters>:

  $widget->method(@parameters);

In this case all C<@parameters> will be preprocessed by performing the following actions:

=over

=item 1.

For each variable reference, a Tcl variable will be created and tied to it, so changes in the perl variable
will be reflected in the Tcl variable, and changes in the Tcl variable will show up in the perl variable.

=item 2.

For each perl code-reference, a Tcl command will be created that calls this perl code-ref.

=item 3.

Each array reference will considered a callback, and proper actions will be taken.

=back

After processing of C<@parameters>, the Tcl/Tk interpreter will be requested to
perform following operation:

=over

=item if C<$method> is all lowercase (e.g. C), C

C<.path method parameter1 parameter2> I<....>

=item if C<$method> contains exactly one capital letter inside the method name (e.g. C), C

C<.path method submethod parameter1 parameter2> I<....>

=item if C<$method> contains several capital letter inside the method name, C

C<.path method submeth subsubmeth parameter1 parameter2> I<....>

=back

=head2 Fast method invocation for auto-wrapped widgets

If you are sure that preprocessing of C<@parameters> in a method call aren't required
(i.e. no parameters are Perl references to scalars, subroutines or arrays), then
the preprocessing step described above can be skipped by calling the method with
an underscore C<_> prepended to the name. (e.g call C<$text->_markNames()>, instead of
C<$text->markNames()>). Calling the method this way means you are using an internal
method that executes faster, but normally you should use a "public" (i.e. non-underscore) method, which includes all preprocessing.

Example:

   # Can't use the faster method-call here, because \$var must be
   # preprocessed for Tcl/Tk:
   $button->configure(-textvariable=>\$var);

   # Faster version of insert method for the "Text" widget
   $text->_insert('end','text to insert','tag');

   # This line does exactly same thing as previous line:
   $text->_insertEnd('text to insert','tag');

When doing many inserts to a text widget, the faster version can help speed things up.


=head1 Using any Tcl/Tk feature from Tcl::pTk

In addition to the standard widgets (e.g. Entry, Button, Menu, etc), the C module
lets you use any other widget from the Tcl/Tk widget library. This can be done with either
Tcl syntax (via the C method), or with regular perl/tk syntax.

To interface to a new Tcl/Tk widget using perl/tk syntax, a C method call
is made on an already-created widget, or on the C interpreter object itself.

Syntax is

 # Calling Declare on a widget object:
 $widget->Declare('perlTk_widget_method_name','tcl/tk-widget_method_name',
    @options);

or, exactly the same,

 # Calling Declare on a the Tcl::pTk Interpreter object:
 $interp->Declare('perlTk_widget_method_name','tcl/tk-widget_method_name',
    @options);

Options are:

  -require => 'tcl-package-name'
  -prefix => 'some-prefix'

The I<-require> option specifies the new Tcl/Tk widget requires a Tcl package to be loaded with a name
of 'tcl-package-name';

The I<-prefix> option used to specify the prefix of the autogenerated widget path-name. This option is
normally used when the Tcl/Tk widget name contains non-alphabetic characters (e.g. ':'). If not specified, the
prefix will be generated from the package-name.

A typical example of using the C method:

  $mw->Declare('BLTNoteBook','blt::tabnotebook',-require=>'BLT',-prefix=>'bltnbook');

After this call, C will create a widget creation method for this new package to make it an
auto-wrapped widget (See the definition of auto-wrapped widgets above).

This means

 my $tab = $mw->BLTNoteBook;

will create blt::tabnotebook widget. Effectively, this is equavalent to the following
Tcl/Tk code:

  package require BLT # but invoked only once
  blt::tabnotebook .bltnbook1

After the above example code, the variable C<$tab> is a  B that behaves in
the usual way, for example:

  $tab->insert('end', -text=>'text');
  $tab->tabConfigure(0, -window=>$tab->Label(-text=>'text of label'));

These two lines are the Tcl/Tk equivalent of:

  .bltnbook1 insert end -text {text}
  .bltnbook1 tab configure 0 -window [label .bltnbook1.lab1 -text {text of label}]

You can also intermix the perl/tk and Tcl/Tk syntax like this:

  $interp->Eval('package require BLT;blt::tabnotebook .bltnbook1');
  $tab = $interp->widget('.bltnbook1');
  $tab->tabConfigure(0, -window=>$tab->Label(-text=>'text of label'));

=head1 How to read Tcl/Tk widget docs when using in C

For the documentation of standard perl/tk widgets (like Button, Entry, Menu, etc), you can refer
to the the perl/tk docs L (We may move a copy of the perl/tk docs to Tcl::pTk in the future). For non-standard
widgets (like the BLTNotebook widget example above) you have to use the Tcl docs on the widget for the widget documentation. (Most Tcl/Tk
docs can be found at http://www.tcl.tk/ )

When reading Tcl/Tk widget documentation about widgets, you can apply the following guidelines to determine how
to use the widget in C using perl/tk syntax.

Suppose the Tcl/Tk docs say:

  pathName method-name optional-parameters
     (some description)

This means the widget has a has method C and you can
invoke it in C like

  $widget->method-name(optional-parameters);

The C<$widget> variable in C is like the I in the Tcl/Tk docs.

Sometimes the Tcl/Tk method-name consists of two words (verb1 verb2). In this
case there are two equivalent ways to invoke it, C< $widget->verb1('verb2',...); > or
C< $widget->verb1Verb2(...)>;

Widget options are used just like they are shown in the Tcl/Tk docs. There is no special translation needed
for the widget options described in the Tcl/Tk docs for use in C.

=head1 Miscellaneous methods

=head2 C<< $int->widget( path, widget-type ) >>

When widgets are created in C they are stored internally and can and can be retreived
by the C method, which takes widget path as first parameter, and optionally
the widget type (such as Button, or Text etc.). For Example:

    # this will retrieve widget, and then call configure on it
    widget(".fram.butt")->configure(-text=>"new text");

    # this will retrieve widget as Button (Tcl::pTk::Button object)
    my $button = widget(".fram.butt", 'Button');

    # same but retrieved widget considered as general widget, without
    # specifying its type. This will make it a generic Tcl::pTk::Widget object
    my $button = widget(".fram.butt");

Please note that this method will return to you a widget object even if it was
not created within C. A check is not performed to see if a
widget with given path name exists. This enables the use of widgets created elsewhere
in Tcl/Tk to be treated like C widgets.

=head2 C

If you need to associate any data with particular widget, you can do this with
C method of either interpreter or widget object itself. This method
returns same anonymous hash and it should be used to hold any keys/values pairs.

Examples:

  $interp->widget_data('.fram1.label2')->{var} = 'value';
  $label->widget_data()->{var} = 'value';

B

Use of this method has largely been superceded by the perl/tk-compatible C widget method.



=head2 C<< $widget->tooltip("text") >>

Any widget accepts the C method, accepting any text as parameter, which
will be used as floating help text explaining the widget. The widget itself
is returned, so to provide convenient way of chaining:

  $mw->Button(-text=>"button 1")->tooltip("This is a button, m-kay")->pack;
  $mw->Entry(-textvariable=>\my $e)->tooltip("enter the text here, m-kay")->pack;

The C method uses the C package, which is a part of C within
Tcl/Tk, so be sure you have that Tcl/Tk package installed.

Note: The perl/tk-compatible B widget is also available for installing tool-tips on widgets
and widget-elements.


=head1 Terminology

In the documentation and comments for this package, I, I, I, I, and I are used. These terms have the
following meanings in the context of this package.

=over 1

=item perl/Tk

The traditional perl interface to the Tk GUI libraries. i.e the perl package occupying the L namespace on CPAN.

=item Tcl/Tk

The Tcl/Tk package with tcl-code and associated libraries (e.g. Tcl.so or Tcl.dll and associated tcl-code). See http://www.tcl.tk/

=item Tcl::pTk

This package, which provides a perl interface into the Tcl/Tk GUI libraries.

=item Tcl.pm

The L perl package, which provides a simple interface from perl to Tcl/Tk. L interpreter objects are subclassed
from the L package.

=item Tcl

The I programming language.

=back


=head1 BUGS

Currently work is in progress, and some features could change in future
versions.

=head1 AUTHORS

=over

=item Malcolm Beattie.

=item Vadim Konovalov, [e-mail] 19 May 2003.

=item Jeff Hobbs, jeffh _a_ activestate com, February 2004.

=item Gisle Aas, gisle _a_ activestate . com, 14 Apr 2004.

=item John Cerney, john.cerney _a_ gmail . com, 29 Sep 2009.

=back

=head1 COPYRIGHT

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

See http://www.perl.com/perl/misc/Artistic.html

=cut

my @misc = qw( after destroy focus grab lower option place raise
              image font
	      selection tk grid tkwait update winfo wm);
my @perlTk = qw( MainWindow MainLoop DoOneEvent tkinit update Ev Exists);

# Flags for supplying to DoOneEvent
my @eventFlags = qw(DONT_WAIT WINDOW_EVENTS  FILE_EVENTS
                                  TIMER_EVENTS IDLE_EVENTS ALL_EVENTS);

@EXPORT    = (@perlTk, @eventFlags);
@EXPORT_OK = (@misc );
%EXPORT_TAGS = (widgets => [], misc => \@misc, perlTk => \@perlTk,
                eventtypes => [@eventFlags],
                );

## TODO -- module's private $tkinterp should go away!
my $tkinterp = undef;		# this gets defined when "new" is done

# Hash to keep track of all created widgets and related instance data
# Tcl::pTk will maintain PATH (Tk widget pathname) and INT (Tcl interp)
# and the user can create other info.
%W = (
    INT => {},   # Hash of mainwindowID or pathname => Tcl::pTk Interpreter Reference
    PATH => {},  # Hash of pathname  => pathname (or mainwindow id)
    RPATH => {}, # Hash of pathname  => widget reference
    DATA => {},  # Hash of widget data (used by the widget_data methods)
);
# few shortcuts for %W to be faster
$Wint = $W{INT};
$Wpath = $W{PATH};
$Wdata = $W{DATA};



# hash to keep track on preloaded Tcl/Tk modules, such as Tix, BWidget
my %preloaded_tk; # (interpreter independent thing. is this right?)

#
sub new {
    my ($class, $display) = @_;
    Carp::croak 'Usage: $interp = new Tcl::pTk([$display])'
	if @_ > 1;
    my @argv;
    if (defined($display)) {
	push(@argv, -display => $display);
    } else {
	$display = $ENV{DISPLAY} || '';
    }
    my $i = new Tcl;
    bless $i, $class;
    $i->SetVar2("env", "DISPLAY", $display, Tcl::GLOBAL_ONLY);
    $i->SetVar("argv", [@argv], Tcl::GLOBAL_ONLY);
    $i->SetVar("tcl_interactive", 0, Tcl::GLOBAL_ONLY);
    $i->SUPER::Init();
    $i->pkg_require('Tk', $i->GetVar('tcl_version'));

    my $mwid = $i->invoke('winfo','id','.');
    $W{PATH}->{$mwid} = '.';
    $W{INT}->{$mwid} = $i;
    $W{mainwindow}->{"$i"} = bless({ winID => $mwid }, 'Tcl::pTk::MainWindow');

    # When mainwindow goes away, delete entry from the $W{mainwindow} global hash:
    $i->call('trace', 'add', 'command', '.', 'delete',
	 sub { delete $W{mainwindow}{"$i"} }
    );
    $i->ResetResult();

    $Tcl::pTk::TK_VERSION = $i->GetVar("tk_version");
    # Only do this for DEBUG() ?
    $Tk::VERSION = $Tcl::pTk::TK_VERSION;
    $Tk::VERSION =~ s/^(\d)\.(\d)/${1}0$2/;
    unless (defined $tkinterp) {
	# first call, create command-helper in TCL to trace widget destruction
	$i->CreateCommand("::perl::w_del", \&widget_deletion_watcher);

	# Create command-helper in TCL to perform the actual widget cleanup
        #   (deferred in a afterIdle call )
	$i->CreateCommand("::perl::w_cleanup", \&widget_cleanup);
    }
    $tkinterp = $i;

    # Create background error handling method that is similar to the way perltk does it
    $tkinterp->CreateCommand('bgerror', \&Tcl::pTk::bgerror);

    return $i;
}

sub mainwindow {
    # this is a window with path '.'
    my $interp = shift;


    return $W{mainwindow}->{"$interp"};
}
sub tkinit {
    my $interp = Tcl::pTk->new(@_);
    $interp->mainwindow;
}

sub MainWindow {
    my $interp = Tcl::pTk->new(@_);

    # Load Tile Widgets, if the tcl version is > 8.5
    my $patchlevel = $interp->icall('info', 'patchlevel');
    my (@patchElems) = split('\.', $patchlevel);
    my $versionNumber = $patchElems[0] + $patchElems[1]/1000 + $patchElems[2]/100e3; # convert version to number
    if( $versionNumber >= 8.005 ){
            require Tcl::pTk::Tile;
            Tcl::pTk::Tile::_declareTileWidgets($interp);
    }

    # Load palette commands, so $interp->invoke can be used with them later, for speed.
    $interp->call('auto_load', 'tk_setPalette');


    # Declare auto-widgets, so subclasses of auto-created widgets will work correctly.
    Tcl::pTk::Widget::declareAutoWidget($interp);


    $interp->mainwindow;
}


## Front-End for fileevent that can be called using Tcl::pTk->fileevent, instead of the normal
#   $widget->filevent syntax. This is provided for compatibility with perl/tk
#
sub fileevent{
    my $firstArg = shift;
    my $int = ( ref($firstArg) ? $firstArg : $tkinterp ); # Get default interp, unless supplied
    my $mw  = $int->mainwindow();          # Get the mainwindow for this interpreter

    # Call the normal fileevent
    $mw->fileevent(@_);
}

sub MainLoop {
    # This perl-based mainloop differs from Tk_MainLoop in that it
    # relies on the traced deletion of '.' instead of using the
    # Tk_GetNumMainWindows C API.
    # This could optionally be implemented with 'vwait' on a specially
    # named variable that gets set when '.' is destroyed.
    unless ($inMainLoop){     # Don't recursivly enter into a mainloop
        local $inMainLoop = 1;
    	my $int = (ref $_[0]?shift:$tkinterp);
    	my $mainwindow = $W{mainwindow};
    	while ( %$mainwindow ) {  # Keep calling DoOneEvent until all mainwindows go away
		$int->DoOneEvent(0);
    	}
    }
}

# timeofday function for compatibility with Tk::timeofday
sub timeofday {
    # This perl-based mainloop differs from Tk_MainLoop in that it
    # relies on the traced deletion of '.' instead of using the
    # Tk_GetNumMainWindows C API.
    # This could optionally be implemented with 'vwait' on a specially
    # named variable that gets set when '.' is destroyed.
    my $int = (ref $_[0]?shift:$tkinterp);
    my $t = $int->invoke("clock", "microseconds");
    $t = $t/1e6;
}


# DoOneEvent for compatibility with perl/tk
sub DoOneEvent{
    my $int = (ref $_[0]?shift:$tkinterp);
    my $flags = shift;
    $int->Tcl::DoOneEvent($flags);
}

# After wrapper for compatibility with perl/tk (So that Tcl::pTk->after(delay) calls work
sub after{
    my $int = shift;
    $int = (ref($int) ? $int : $tkinterp ); # if interpreter not supplied use $tkinterp
    my $ms = shift;
    my $callback = shift;

    $ms = int($ms) if( $ms =~ /\d/ ); # Make into an integer to keep tk from complaining

    if( defined($callback)){
            # Turn into callback, if not one already
            unless( blessed($callback) and $callback->isa('Tcl::pTk::Callback')){
                    $callback = Tcl::pTk::Callback->new($callback);
            }

            my $sub = sub{ $callback->Call()};
            #print "Tcl::pTk::after: setting after on $sub\n";
            my $ret = $int->call('after', $ms, $sub );
            return $int->declare_widget($ret);
    }
    else{ # No Callback defined, just do a sleep
            return $int->call('after', $ms );
    }

    return($int->call('after', $ms));
}


# create_widget Method
#   This is used as a front-end to the declare_widget method, so that -command  and -variable configuration
#    options supplied at widget-creation will be properly stored as Tcl::pTk::Callback objects (for perltk
#    compatibility).
#   This is done by issuing the -command or -variable type option after widget creation, where the callback object can be
#    stored with the widget
sub create_widget{
    my $int      = shift; # Interperter
    my $parent   = shift; # Parent widget
    my $id       = shift; # unique id for the new widget
    my $ttktype  = shift; # Name of widget, in tcl/tk
    my $widget_class = shift || 'Tcl::pTk::Widget';

    my @args = @_;

    my @filteredArgs;   # args, filtered of any -command type options
    my @commandOptions; # any command options needed to be issued after widget creation.

    # Go thru each arg and look for callback (i.e -command ) args
    my $lastArg;
    foreach my $arg(@args){

            if( defined($lastArg) && !ref($lastArg) && ( $lastArg =~ /^-\w+/ ) ){
                    if(  $lastArg =~ /command|cmd$/ && defined($arg) ) {  # Check for last arg something like -command

                            #print "Found command arg $lastArg => $arg\n";

                            # Save this option for issuing after widget creation
                            push @commandOptions, $lastArg, $arg;

                            # Remove the lastArg from the current arg queue, since we will be handling
                            #  it using @commandOptions
                            pop @filteredArgs;

                            $lastArg = undef;
                            next;
                    }
                    if(  $lastArg =~ /variable$/ ){  # Check for last arg something like -textvariable
                            # Save this option for issuing after widget creation
                            push @commandOptions, $lastArg, $arg;

                            # Remove the lastArg from the current arg queue, since we will be handling
                            #  it using @commandOptions
                            pop @filteredArgs;

                            $lastArg = undef;
                            next;
                    }

            }

            $lastArg = $arg;

            push @filteredArgs, $arg;
    }

    # Make the normal declare_widget call
    my $widget = $int->declare_widget($parent->call($ttktype, $id, @filteredArgs), $widget_class);

    # Make configure call for any left-over commands
    $widget->configure(@commandOptions) if(@commandOptions);

    return $widget;
}


#
# declare_widget, method of interpreter object
# args:
#   - a path of existing Tcl/Tk widget to declare its existance in Tcl::pTk
#   - (optionally) package name where this widget will be declared, default
#     is 'Tcl::pTk::Widget', but could be 'Tcl::pTk::somewidget'
sub declare_widget {
    my $int = shift;
    my $path = shift;
    my $widget_class = shift || 'Tcl::pTk::Widget';
    # JH: This is all SOOO wrong, but works for the simple case.
    # Issues that need to be addressed:
    #  1. You can create multiple interpreters, each containing identical
    #     pathnames.  This var should be better scoped.
    #	  VK: mostly resolved, such interpreters with pathnames allowed now
    #  2. There is NO cleanup going on.  We should somehow detect widget
    #     destruction (trace add command delete ... in 8.4) and interp
    #     destruction to clean up package variables.
    #my $id = $path=~/^\./ ? $int->invoke('winfo','id',$path) : $path;
    $int->invoke('trace', 'add', 'command', $path, 'delete', "::perl::w_del $path")
        if ( WIDGET_CLEANUP && $path !~ /\#/); # don't trace for widgets like 'after#0'
    my $id = $path;
    my $w = bless({ winID => $id}, $widget_class);
    Carp::confess("id is not found\n") if( !defined($id));
    $Wpath->{$id} = $path; # widget pathname
    $Wint->{$id}  = $int; # Tcl interpreter
    $W{RPATH}->{$path} = $w;


    return $w;
}

sub widget_deletion_watcher {
    my (undef,$int,undef,$path) = @_;
    #print  STDERR "[D:$path]\n";

    # Call the _OnDestroy method on the widget to perform cleanup on it
    my $w = $W{RPATH}->{$path};
    #print STDERR "Calling _Destroyed on $w, Ind = ".$Idelete++."\n";
    $w->_Destroyed();

    $int->delete_widget_refs($path);

    delete $W{RPATH}->{$path};
}

###############################################
#  Overriden delet_ref
#  Instead of immediately deleting a scalar or code ref in Tcl-land,
#   queue the ref to be deleted in an after-idle call.
#   This is done, rather than deleting immediately, because an immediate delete
#   before a widget is completely destroyed can causes Tcl-crashes.
sub delete_ref {
    my $interp = shift;
    my $rname = shift;
    my $ref = $interp->return_ref($rname);
    push @cleanup_refs, $rname;

    # Create an after-idle call to delete refs, if the cleanup queue is bigger
    #   than the threshold
    if( !$cleanupPending and scalar(@cleanup_refs) > $cleanup_queue_maxsize ){
            #print STDERR "Calling after idle cleanup on ".join(", ", @cleanup_refs)."\n";
            $cleanupPending = 1; # Setup flag so we don't call the after idle multiple times
            $interp->call('after', 'idle', "::perl::w_cleanup");
    }
    return $ref;
}


# Sub to cleanup any que-ed commands and variables in
#  @cleanup_refs. This usually called from an after-idle procedure
sub widget_cleanup {
    my (undef,$int,undef,$path) = @_;

    my @deleteList = @cleanup_refs;

    # Go thru each list and delete
    foreach my $rname(@deleteList){
            #print  "Widget_Cleanup deleting $rname\n";

            $int->SUPER::delete_ref($rname);
    }

    # Zero-out cleanup_refs
    @cleanup_refs = ();
    $cleanupPending = 0; # Reset cleanup flag for next time

}

# widget_data return anonymous hash that could be used to hold any
# user-specific data
sub widget_data {
    my $int = shift;
    my $path = shift;
    $Wdata->{$path} ||= {};
    return $Wdata->{$path};
}

# subroutine awidget used to create [a]ny [widget]. Nothing complicated here,
# mainly needed for keeping track of this new widget and blessing it to right
# package
sub awidget {
    my $int = (ref $_[0]?shift:$tkinterp);
    my $wclass = shift;
    # Following is a suboptimal way of autoloading, there should exist a way
    # to Improve it.
    my $sub = sub {
        my $int = (ref $_[0]?shift:$tkinterp);
        my ($path) = $int->call($wclass, @_);
        return $int->declare_widget($path);
    };
    unless ($wclass=~/^\w+$/) {
	die "widget name '$wclass' contains not allowed characters";
    }
    # create appropriate method ...
    no strict 'refs';
    *{"Tcl::pTk::$wclass"} = $sub;
    # ... and call it (if required)
    if ($#_>-1) {
	return $sub->($int,@_);
    }
}
sub widget($@) {
    my $int = (ref $_[0]?shift:$tkinterp);
    my $wpath = shift;
    my $wtype = shift || 'Tcl::pTk::Widget';
    if (exists $W{RPATH}->{$wpath}) {
        return $W{RPATH}->{$wpath};
    }
    unless ($wtype=~/^(?:Tcl::pTk)/) {
	Tcl::pTk::Widget::create_widget_package($wtype);
	$wtype = "Tcl::pTk::$wtype";
    }
    #if ($wtype eq 'Tcl::pTk::Widget') {
    #	require Carp;
    #	Carp::cluck("using \"widget\" without widget type is strongly discouraged");
    #}
    # We could ask Tcl about it by invoking
    # my @res = $int->Eval("winfo exists $wpath");
    # but we don't do it, as long as we allow any widget paths to
    # be used by user.
    my $w = $int->declare_widget($wpath,$wtype);
    return $w;
}

sub Exists {
    my $wid = shift;
    return 0 unless defined($wid);
    if (blessed($wid) && $wid->isa('Tcl::pTk::Widget') ) {
        my $wp = $wid->path;
        my $interp = $wid->interp;
        return 0 unless( defined $interp); # Takes care of some issues during global destruction
        return $interp->icall('winfo','exists',$wp);
    }
    return eval{$tkinterp->icall('winfo','exists',$wid)};
}

sub widgets {
    \%W;
}

sub pkg_require {
    # Do Tcl package require with optional version, cache result.
    my $int = shift;
    my $pkg = shift;
    my $ver = shift;

    my $id = "$int$pkg"; # to made interpreter-wise, do stringification of $int

    return $preloaded_tk{$id} if $preloaded_tk{$id};

    my @args = ("package", "require", $pkg);
    push(@args, $ver) if defined($ver);
    eval { $preloaded_tk{$id} = $int->icall(@args); };
    if ($@) {
	# Don't cache failures, as the package may become available by
	# changing auto_path and such.
	return;
    }
    return $preloaded_tk{$id};
}

sub need_tk {
    # DEPRECATED: Use pkg_require and call instead.
    my $int = shift;
    my $pkg = shift;
    my $cmd = shift || '';
    warn "DEPRECATED CALL: need_tk($pkg, $cmd), use pkg_require\n";
    if ($pkg eq 'ptk-Table') {
        require Tcl::pTk::Table;
    }
    else {
	# Only require the actual package once
	my $ver = $int->pkg_require($pkg);
	return 0 if !defined($ver);
	$int->Eval($cmd) if $cmd;
    }
    return 1;
}



# subroutine findINC copied from perlTk/Tk.pm
sub findINC {
    my $file = join('/',@_);                 # Normal location
    my $fileImage = join('/', $_[0], 'images', $_[1]); # alternate location in the 'images' directory
    my $dir;
    $file  =~ s,::,/,g;
    $fileImage  =~ s,::,/,g;
    foreach $dir (@INC) {
	my $path;

        # check for normal location and 'images' location of the file
	return $path if (-e ($path = "$dir/$file") );
	return $path if (-e ($path = "$dir/$fileImage") );

    }
    return undef;
}



# sub Declare is just a dispatcher into Tcl::pTk::Widget method
sub Declare {
    Tcl::pTk::Widget::Declare(undef,@_[1..$#_]);
}


#
# AUTOLOAD method for Tcl::pTk interpreter object, which will bring into
# existance interpreter methods
sub AUTOLOAD {
    my $int = shift;
    my ($method,$package) = $Tcl::pTk::AUTOLOAD;

    # If this is the Tcl::pTk::Error routine,
    #   Call the standard Autoloader::AUTOLOAD to
    #   load our Error routine that has been autosplit to a separate file
    #   (i.e. appears after the _END_).
	#   Autoloading the Error routine keeps from getting subroutine redefined warnings
	#   when the user supplies their own Error routine or Tcl::pTk::ErrorDialog is used.
    if( $method =~ /Tcl::pTk::Error/ ){
        if( defined( $Tcl::pTk::TkHijack::translateList ) ){
                #print "TkHijack is loaded\n";
                # If TkHijack is loaded and the user has define their own
                #    Tk::Error, call that:
                if( defined(&Tk::Error)){
                        #print "Tk::Error has been defined\n";
                        *Tcl::pTk::Error = \&Tk::Error;
                        return $int->Tcl::pTk::Error(@_);

                }
        }
        $AutoLoader::AUTOLOAD = $method;
        unshift @_, $int; # Put arg back on stack like AUTOLOAD expects it
        goto &AutoLoader::AUTOLOAD;
    }

    # Normal handling follows
    my $method0;
    for ($method) {
	s/^(Tcl::pTk::)//
	    or Carp::confess "weird inheritance ($method)";
	$package = $1;
        $method0 = $method;
	s/(?
	s/(?
    }

    # if someone calls $interp->_method(...) then it is considered as faster
    # version of method, similar to calling $interp->method(...) but via
    # 'invoke' instead of 'call', thus faster
    my $fast = '';
    $method =~ s/^_// and do {
	$fast='_';
	if (exists $::Tcl::pTk::{$method}) {
	    no strict 'refs';
	    *{"::Tcl::pTk::_$method"} = *{"::Tcl::pTk::$method"};
	    return $int->$method(@_);
	}
    };

    # search for right corresponding Tcl/Tk method, and create it afterwards
    # (so no consequent AUTOLOAD will happen)

    # Check to see if it is a camelCase method.  If so, split it apart.
    # code below will always create subroutine that calls a method.
    # This could be changed to create only known methods and generate error
    # if method is, for example, misspelled.
    # so following check will be like
    #    if (exists $knows_method_names{$method}) {...}
    my $sub;
    if ($method =~ /^([a-z]+)([A-Z][a-z]+)$/) {
        my ($meth, $submeth) = ($1, lcfirst($2));
	# break into $method $submethod and call
	$sub = $fast ? sub {
	    my $int = shift;
	    $int->invoke($meth, $submeth, @_);
	} : sub {
	    my $int = shift;
	    $int->call($meth, $submeth, @_);
	};
    }
    else {
	# Default case, call as method of $int
	$sub = $fast ? sub {
	    my $int = shift;
	    $int->invoke($method, @_);
	} : sub {
	    my $int = shift;
	    $int->call($method, @_);
	};
    }
    no strict 'refs';
    *{"$package$fast$method0"} = $sub;
    Sub::Name::subname("$package$fast$method0", $sub) if( $Tcl::pTk::DEBUG);
    return $sub->($int,@_);
}

# Sub to support the "Ev('x'), Ev('y'), etc" syntax that perltk uses to supply event information
#   to bind callbacks. This sub-name is exported with the other perltk subs (like MainLoop, etc).
sub Ev {
    my @events = @_;
    return bless \@events, "Tcl::pTk::Ev";
}

# Tcl::pTk::break, used to break out of event bindings (i.e. don't process anymore bind subs after break is called).
#   This is handled by the wrapper tcl code setup in Tcl::pTk::bind
sub break
{
 # Check to see if we are being called from Tcl::pTk::Callback, if so, then this is a valid 'break' call
 #   and we will die with _TK_BREAK_
 my @callInfo;
 my $index = 0;
 my $callback;  # Flag = 1 if this is a callback
 while (@callInfo = caller($index)){
         #print STDERR "Break Caller = ".join(", ", @callInfo)."\n";
         if( $callInfo[3] eq 'Tcl::pTk::Callback::BindCall'){
                 $callback = 1;
         }
         $index++;
 }

 die "_TK_BREAK_\n" if($callback);

}

# Wrappers for the Event Flag subs in Tcl (for compatiblity with perl/tk code
sub DONT_WAIT{ Tcl::DONT_WAIT()};
sub WINDOW_EVENTS{ Tcl::WINDOW_EVENTS()};
sub FILE_EVENTS{ Tcl::FILE_EVENTS()};
sub TIMER_EVENTS{ Tcl::TIMER_EVENTS()};
sub IDLE_EVENTS{ Tcl::IDLE_EVENTS()};
sub ALL_EVENTS{ Tcl::ALL_EVENTS()};

# Wrappers for the Tk color functions (for compatibility with perl/tk
sub NORMAL_BG{
        if($^O eq 'cygwin' || $^O =~ /win32/ ){
                return 'systembuttonface';
        }
        elsif( $^O =~ /darwin/i ){ # MacOS
                return 'systemWindowBody';
        }
        else{ # Must be unix
                return '#d9d9d9';
        }
}

sub ACTIVE_BG{
        if($^O eq 'cygwin' || $^O =~ /win32/ ){
                return 'systembuttonface';
        }
        elsif( $^O =~ /darwin/i ){ # MacOS
                return 'systemButtonFacePressed';
        }
        else{ # Must be unix
                return '#ececec';
        }
}

sub SELECT_BG{
        if($^O eq 'cygwin' || $^O =~ /win32/ ){
                return 'SystemHighlight';
        }
        elsif( $^O =~ /darwin/i ){ # MacOS
                return 'systemHighlightSecondary';
        }
        else{ # Must be unix
                return '#c3c3c3';
        }
}

# Background error routine that calls Tcl::pTk::Error, similar to perltk calling Tk::Error
#  Upon Tcl interp creation, this routine is created in Tcl (called the special name bgerror) so that this Tcl::pTk:;bgerror
#   will be called for background errors
sub bgerror{
                my ($what,$obj, $sub, $message) =  @_;

                # Note: what is undefined, $obj is the current interp, sub is the name of the Tcl error handler (e.g. bgerror)
                #
                #print "what = $what, obj = $obj, sub = $sub, message = $message\n";
                # Variables for creating a "sanitized" stack trace
                #  (i.e. stack trace that won't include a lot of Tcl::pTk internal info)


                my $mw;  # Mainwindow of the current interpreter
                $mw = $obj->mainwindow if( ref( $obj ));


                my ($stackMessage, $shortLocation, $errorInfo);
                local $Carp::Internal{'Tcl::pTk::Callback'} = 1;
                local $Carp::Internal{'Tcl::pTk::Widget'} = 1;
                local $Carp::Internal{'Tcl'} = 1;
                $stackMessage = Carp::longmess();
                $shortLocation = Carp::shortmess();
                $errorInfo = $obj->Eval('set ::errorInfo');

                # For compatibility with perl/tk, build the error message and stack info as an array
                my @stack = ("Stack Trace:", split(/\n/, $stackMessage) );
                my $errorMess = $errorInfo . "\n\n Error Started$shortLocation\n";
                $mw->Tcl::pTk::Error( $errorMess, @stack); # Call Tcl::pTk::Error like Tk::Error would get called
}

1;

__END__