package Tcl::Tk;

use strict;
use Tcl;
use Exporter ('import');
use vars qw(@EXPORT_OK %EXPORT_TAGS);

@Tcl::Tk::ISA = qw(Tcl);
$Tcl::Tk::VERSION = '0.97';

sub WIDGET_CLEANUP() {0}

$Tcl::Tk::DEBUG ||= 0;
sub DEBUG() {0}
sub Tcl::Tk::Widget::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::Tk::DEBUG unless defined $lvl;
    my $msg = shift;
    if (defined($msg) && ($Tcl::Tk::DEBUG >= $lvl)) { print STDERR $msg, @_; }
    return ($Tcl::Tk::DEBUG >= $lvl);
}

if (DEBUG()) {
    # The gestapo throws warnings whenever Perl/Tk modules are requested.
    # It also hijacks such requests and returns an empty module in its
    # place.
    unshift @INC, \&tk_gestapo;
}

=head1 NAME

Tcl::Tk - Extension module for Perl giving access to Tk via the Tcl extension

=head1 SYNOPSIS

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

Or    

    use Tcl::Tk;
    my $int = new Tcl::Tk;
    $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

The C<Tcl::Tk> module provides access to the Tk library within Tcl/Tk
installation. By using this module an interpreter object created, which
then gain access to entire variety of installed Tcl libraries (Tk, Tix,
BWidgets, BLT, etc) and existing features (for example natively looking
widgets using C<tile>).

=head2 Access to the Tcl and Tcl::Tk extensions

To get access to the Tcl and Tcl::Tk extensions, put the command near
the top of your program.

    use Tcl::Tk;

=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.

To create a Tcl interpreter initialised for Tk, use

    my $int = new Tcl::Tk;

Optionally DISPLAY argument could be specified: C<my $int = new Tcl::Tk(":5");>.
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)

The Tcl/Tk interpreter is created automatically by the call to C<MainWindow> and
C<tkinit> methods, and main window object is returned in this case:

  use Tcl::Tk;
  my $mw = Tcl::Tk::MainWindow;
  my $int = $mw->interp;

=head2 Entering the main event loop

The Perl method call

    $int->MainLoop;

on the Tcl::Tk interpreter object enters the Tk event loop. You can
instead do C<Tcl::Tk::MainLoop> or C<Tcl::Tk-E<gt>MainLoop> if you prefer.
You can even do simply C<MainLoop> if you import it from Tcl::Tk in
the C<use> statement.

=head2 Creating and using widgets

Two different approaches are used to manipulate widgets (or, more commonly,
to manipulate any Tcl objects behaving similarly)

=over

=item * access with a special widget accessing syntax of kind C<< $widget->method; >>

=item * random access with C<< Eval >>

=back

First way to manipulate widgets is identical to perl/Tk calling conventions,
second one deploys Tcl syntax. Both ways are very interchangeable in that
sence, a widget created with one way could be used by another way.

Usually Perl programs operate with Tcl/Tk via perl/Tk syntax, so user have no
need to deal with Tcl language directly, only some basic understanding of
widget is needed.

A possibility to use both approaches interchangeably gives an opportunity to
use Tcl code created elsewhere (some WYSIWIG IDE or such).

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 1st,
approach with perl/Tk syntax.

=head4 Tcl/Tk syntax

=over

=item * interpreter

Tcl interpreter is used to process Tcl/Tk widgets; within C<Tcl::Tk> you
create it with C<new>, and, given any widget object, you can retreive it by
C<< $widget->interp >> method. Within pure Tcl/Tk it is already exist.

=item * widget path

Widget path is a string starting with a dot and consisting of several
names separated by dots. These names are widget names that comprise
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<butt> then
you should specify name C<.fram.butt>. Widget paths are refered in
miscellaneous widget operations, and geometry management is one of them.

At any time widget's path could be retreived with C<< $widget->path; >>
within C<Tcl::Tk>.

=item * widget as Tcl/Tk command

when widget is created, a special command is created within Tk, the name of
this command is widget's path. That said, C<.fr.b> is Tk's command and this
command has subcommands, those will help manipulating widget. That is why
C<< $int->Eval('.fr.b configure -text {new text}'); >> makes sence.
Note that C<< $button->configure(-text=>'new text'); >> does exactly that,
provided a fact C<$button> corresponds to C<.fr.b> widget.

=back

C<use Tcl::Tk;> not only creates C<Tcl::Tk> package, but also it creates
C<Tcl::Tk::Widget> package, responsible for widgets. Each widget (object
blessed to C<Tcl::Tk::Widget>, or other widgets in ISA-relationship)
behaves in such a way that its method will result in calling it's path on
interpreter.

=head4 Perl/Tk syntax

C<Tcl::Tk::Widget> package within C<Tcl::Tk> module fully aware of perl/Tk
widget syntax, which has long usage. This means that any C<Tcl::Tk> widget
has a number of methods like C<Button>, C<Frame>, C<Text>, C<Canvas> and so
on, and invoking those methods will create appropriate child widget.
C<Tcl::Tk> module will generate an unique name of newly created widget.

To demonstrate this concept:

    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::Tk widget commands are translated to Tcl syntax and directed to
Tcl interpreter; understanding this helps in idea, why two approaches with
dealing with widgets are interchangeable.

Newly created widget C<$label> will be blessed to package C<Tcl::Tk::Widget::Label>
which is isa-C<Tcl::Tk::Widget>

=head3 OO explanations of Widget-s of Tcl::Tk

C<Tcl::Tk> widgets use object-oriented approach, which means a quite concrete
object hierarchy presents. Interesting point about this object system - 
it is very dynamic. Initially no widgets objects and no widget classes present,
but they immediately appear at the time when they needed.

So they virtually exist, but come into actual existance dynamically. This
dynamic approach allows same usage of widget library without any mention from
within C<Tcl::Tk> module at all.

Let us look into following few lines of code:

  my $text = $mw->Text->pack;
  $text->insert('end', -text=>'text');
  $text->windowCreate('end', -window=>$text->Label(-text=>'text of label'));

Internally, following mechanics comes into play.
Text method creates Text widget (known as C<text> in Tcl/Tk environment). 
When this creation method invoked first time, a package 
C<Tcl::Tk::Widget::Text> is created, which will be OO presentation of all
further Text-s widgets. All such widgets will be blessed to that package
and will be in ISA-relationship with C<Tcl::Tk::Widget>.

Second line calls method C<insert> of C<$text> object of type
C<Tcl::Tk::Widget::Text>. When invoked first time, a method C<insert> is 
created in package C<Tcl::Tk::Widget::Text>, with destiny to call
C<invoke> method of our widget in Tcl/Tk world.

At first time when C<insert> is called, this method does not exist, so AUTOLOAD
comes to play and creates such a method. Second time C<insert> called already
existing subroutine will be invoked, thus saving execution time.

As long as widgets of different type 'live' in different packages, they do not
intermix, so C<insert> method of C<Tcl::Tk::Widget::Listbox> will mean
completely different behaviour.

=head3 explanations how Widget-s of Tcl::Tk methods correspond to Tcl/Tk

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

  $widget->method(@parameters);

In this case as a first step all C<@parameters> will be preprocessed, during
this preprocessing following actions are performed:

=over

=item 1.

for each variable reference its Tcl variable will be created and tied to it

=item 2.

for each code reference its Tcl command will be created and tied to it

=item 3.

each array reference considered as callback, and proper actions will be taken

=back

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

=over

=item if C<$method> is all lowercase, C<m/^[a-z]$/>

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

=item if C<$method> contains exactly one capital letter inside name, C<m/^[a-z]+[A-Z][a-z]+$/>

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

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

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

=head4 faster way of invoking methods on widgets

In case it is guaranteed that preprocessing of C<@parameters> are not required
(in case no parameters are Perl references to scalar, subroutine or array), then
preprocessing step described above could be skipped.

To achieve that, prepend method name with underscore, C<_>. Mnemonically it means
you are using some internal method that executes faster, but normally you use
"public" method, which includes all preprocessing.

Example:

   # at following line faster method is incorrect, as \$var must be
   # preprocessed for Tcl/Tk:
   $button->configure(-textvariable=>\$var);

   # faster version of insert method of "Text" widget is perfectly possible
   $text->_insert('end','text to insert','tag');
   # following line does exactly same thing as previous line:
   $text->_insertEnd('text to insert','tag');

When doing many inserts to text widget, faster version could fasten execution.

=back

=head2 using any Tcl/Tk feature with Tcl::Tk module

Tcl::Tk module allows using any widget from Tcl/Tk widget library with either
Tcl syntax (via Eval), or with regular Perl syntax.

In order to provide perlTk syntax to any Tcl/Tk widget, only single call
should be made, namely 'Declare' method. This is a method of any widget in
Tcl::Tk::Widget package, and also exactly the same method of Tcl::Tk
interpreter object

Syntax is

 $widget->Declare('perlTk_widget_method_name','tcl/tk-widget_method_name',
    @options);

or, exactly the same,
 
 $interp->Declare('perlTk_widget_method_name','tcl/tk-widget_method_name',
    @options);
 
Options are:

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

'-require' option specifies that said widget requires a Tcl package with a name
of 'tcl-package-name';
'-prefix' option used to specify a part of autogenerated widget name, usually
used when Tcl widget name contain non-alphabet characters (e.g. ':') so
to keep autogenerated names syntaxically correct.

A typical example of such invocation is:

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

After such a call Tcl::Tk module will take a knowledge about tabnotebook widget
from within BLT package and create proper widget creation method for it with a 
name BLTNoteBook. This means following statement:

 my $tab = $mw->BLTNoteBook;

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

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

Also, Perl variable $tab will contain ordinary Tcl/Tk widget that behaves in
usual way, for example:

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

These two lines are Tcl/Tk equivalent of:

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

Given all previously said, you can also write intermixing both approaches:

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

=head3 using documentation of Tcl/Tk widgets for applying within Tcl::Tk module

As a general rule, you need to consult TCL man pages to realize how to
use a widget, and after that invoke perl command that creates it properly.
When reading Tcl/Tk documentation about widgets, quite simple transformation is
needed to apply to Tcl::Tk module.

Suppose it says:

  pathName method-name optional-parameters
     (some description)
     
you should understand, that widget in question has method C<method-name> and you could
invoke it as

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

$widget is that widget with pathName, created with perl/Tk syntax, or fetched by
C<< $int->widget >> method.

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

Widget options are same within Tcl::Tk and Tcl/Tk.

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

When widgets are created they are stored internally and could be retreived
by C<widget()>, which takes widget path as first parameter, and optionally
widget type (such as Button, or Text etc.). 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::Tk::Widget::Button object)
    my $button = widget(".fram.butt", 'Button');
    
    # same but retrieved widget considered as general widget, without
    # concrete specifying its type (Tcl::Tk::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 this module, and check will not be performed whether a 
widget with given path exists, despite of fact that checking for existence of
a widget is an easy task (invoking C<< $interp->Eval("info commands $path"); >>
will do this). Instead, you will receive perl object that will try to operate
with widget that has given path even if such path do not exists. In case it do
not actually exist, you will receive an error from Tcl/Tk.

To check if a widget with a given path exists use C<Tcl::Tk::Exists($widget)>
subroutine. It queries Tcl/Tk for existance of said widget.

=head3 C<widget_data> method

If you need to associate any data with particular widget, you can do this with 
C<widget_data> 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';

=head2 Non-widget Tk commands

Many non-widget Tk commands are also available within Tcl::Tk module, such
as C<focus>, C<wm>, C<winfo> and so on. If some of them not present directly,
you can always use C<< $int->Eval('...') >> approach.

=head2 Miscellaneous methods

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

Any widget accepts C<tooltip> 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;

C<tooltip> method uses C<tooltip> package, which is a part of C<tklib> within
Tcl/Tk, so be sure you have it installed.

=head3 C<< $int->create_rotext() >> method

This method creates "rotext" type of widget within Tcl/Tk, which then could be
used for example as

  $int->Eval('rotext .ro1');

=head3 C<< $int->create_scrolled_widget("widgetname") >> method

This method creates "scrolled" type of widget for a given widget type within
Tcl/Tk. For example:

  $int->create_scrolled_widget("canvas");
  $int->Eval('scrolled_canvas .scanv');

This way you can even create a perl/Tk-style widget to be initially scrollable:

  $int->create_scrolled_widget("text"); # introduce scrolled_text in Tcl/Tk
  $int->Declare('SText','scrolled_text'); # bind scrolled_text to Tcl::Tk as SText
  # now use SText instead of Scrolled('Text',...) everywhere in program
  $int->mainwindow->SText->pack(-fill=>'both');

The scrolling is taken from snit (scrodgets), and the resulting widget have
both scrolled options/methods and widget's options/methods.
  
=head1 Points of special care

=over

=item list context and scalar context

When widget method returns some result, this result becomes transformed
according to the context, either list or scalar context. Sometimes this
transformation is right, but sometimes its not. Unfortunately there are many
cases, when Tcl/Tk returns a string, and this string become broken into words,
because the function call is placed in list context.

In such cases concatenate such call with empty string to force right behaviour:

  use Tcl::Tk;
  my $mw = Tcl::Tk::tkinit;
  my $int = $mw->interp;
  my $but = $mw->Button(-text=>'1 2  3')->pack;
  print "[", $but->cget('-text'), "] wrong - widget method returns 3 values!\n";
  print "[", "".$but->cget('-text'), "] CORRECT - 1 value in scalar context\n";
  $int->MainLoop;

Actually, the example above will work correctly, because currently list of
function names having list results are maintained. But please contact developers
if you find misbehaving widget method!

=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, vadim_tcltk@vkonovalov.ru 19 May 2003.

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

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

=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(MainLoop after destroy focus grab lower option place raise
              image font
	      selection tk grid tkwait update winfo wm);
my @perlTk = qw(MainLoop MainWindow tkinit update);

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

## 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::Tk will maintain PATH (Tk widget pathname) and INT (Tcl interp)
# and the user can create other info.
my %W = (
    INT => {},
    PATH => {},
    RPATH => {},
    DATA => {},
    MWID => {},
);
# few shortcuts for %W to be faster
my $Wint = $W{INT};
my $Wpath = $W{PATH};
my $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::Tk([$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'));
    # $i->update; # WinCE helper. TODO - remove from RELEASE
    my $mwid = $i->invoke('winfo','id','.');
    $W{PATH}->{$mwid} = '.';
    $W{INT}->{$mwid} = $i;
    $W{MWID}->{'.'} = $mwid;
    my $_mainwindow = \$mwid;
    $W{mainwindow}->{"$i"} = $_mainwindow;
    bless($_mainwindow, 'Tcl::Tk::Widget::MainWindow');
    $i->call('trace', 'add', 'command', '.', 'delete',
	 sub { for (keys %W) {$W{$_}->{$mwid} = undef; }});
    $i->ResetResult();
    $Tcl::Tk::TK_VERSION = $i->GetVar("tk_version");
    # Only do this for DEBUG() ?
    $Tk::VERSION = $Tcl::Tk::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);
    }
    $tkinterp = $i;
    return $i;
}

sub mainwindow {
    # this is a window with path '.'
    my $interp = shift;
    return $W{mainwindow}->{"$interp"};
}
sub tkinit {
    my $interp = Tcl::Tk->new(@_);
    $interp->mainwindow;
}
sub MainWindow {
    my $interp = Tcl::Tk->new(@_);
    $interp->mainwindow;
}

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.
    my $int = (ref $_[0]?shift:$tkinterp);
    my $mwid = $W{MWID}->{'.'};
    while (defined $Wpath->{$mwid}) {
	$int->DoOneEvent(0);
    }
}

#
# declare_widget, method of interpreter object
# args:
#   - a path of existing Tcl/Tk widget to declare its existance in Tcl::Tk
#   - (optionally) package name where this widget will be declared, default
#     is 'Tcl::Tk::Widget', but could be 'Tcl::Tk::Widget::somewidget'
sub declare_widget {
    my $int = shift;
    my $path = shift;
    my $widget_class = shift || 'Tcl::Tk::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;
    my $id = $path;
    my $w = bless(\$id, $widget_class);
    $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]";
    $int->delete_widget_refs($path);
}

# 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::Tk::$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::Tk::Widget';
    if (exists $W{RPATH}->{$wpath}) {
        return $W{RPATH}->{$wpath};
    }
    unless ($wtype=~/^(?:Tcl::Tk::Widget)/) {
	Tcl::Tk::Widget::create_widget_package($wtype);
	$wtype = "Tcl::Tk::Widget::$wtype";
    }
    if ($wtype eq 'Tcl::Tk::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 (ref($wid)=~/^Tcl::Tk::Widget\b/) {
        my $wp = $wid->path;
        return $wid->interp->icall('winfo','exists',$wp);
    }
    return $tkinterp->icall('winfo','exists',$wid);
}
# do this only when tk_gestapo on?
# In normal case Tcl::Tk::Exists should be used.
#*{Tk::Exists} = \&Tcl::Tk::Exists;

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::Tk::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;
}

sub tk_gestapo {
    # When placed first on the INC path, this will allow us to hijack
    # any requests for 'use Tk' and any Tk::* modules and replace them
    # with our own stuff.
    my ($coderef, $module) = @_;  # $coderef is to myself
    return undef unless $module =~ m!^Tk(/|\.pm$)!;

    my ($package, $callerfile, $callerline) = caller;

    my $fakefile;
    open(my $fh, '<', \$fakefile) || die "oops";

    $module =~ s!/!::!g;
    $module =~ s/\.pm$//;
    $fakefile = <<EOS;
package $module;
warn "### $callerfile:$callerline not really loading $module ###";
sub foo { 1; }
1;
EOS
    return $fh;
}

# subroutine findINC copied from perlTk/Tk.pm
sub findINC {
    my $file = join('/',@_);
    my $dir;
    $file  =~ s,::,/,g;
    foreach $dir (@INC) {
	my $path;
	return $path if (-e ($path = "$dir/$file"));
    }
    return undef;
}

# subroutine create_rotext just executes some simple code to introduce
# 'rotext' widget to Tcl/Tk
sub create_rotext {
    my $int = shift;
    $int->Eval(<<'EOS');
# got 'rotext' code from http://mini.net/tcl/3963 and modified a bit
# (insertion cursor unchanged, unlike was proposed by author of original code)
if {[info proc rotext]==""} {

package require snit

::snit::widgetadaptor rotext {

   constructor {args} {
       installhull using text

       # Apply an options passed at creation time.
       $self configurelist $args
   }

   # Disable the insert and delete methods, to make this readonly.
   method insert {args} {}
   method delete {args} {}

   # Enable ins and del as synonyms, so the program can insert and delete.
   delegate method ins to hull as insert
   delegate method del to hull as delete

   # Pass all other methods and options to the real text widget, so
   # that the remaining behavior is as expected.
   delegate method * to hull
   delegate option * to hull
}
}
EOS
}

sub create_scrolled_widget {
    my $int = shift;
    my $lwtype = shift;
    $int->Eval(<<"EOS");
if {[info proc scrolled_$lwtype]==""} {

package require widget::scrolledwindow

::snit::widgetadaptor scrolled_$lwtype {
    component widg

    constructor {args} {
	installhull using widget::scrolledwindow
        install widg using $lwtype \$win.w
	\$win setwidget \$win.w

        # Apply an options passed at creation time.
        \$self configurelist \$args
    }

    # Pass methods and options to proper widgets
    delegate option -scrollbar to hull
    delegate option -auto to hull
    delegate option -sides to hull
    delegate option -size to hull
    delegate option -ipad to hull
    delegate method setwidget to hull
    delegate method C-size to hull
    delegate method C-ipad to hull
    delegate option * to widg except {-scrollbars}
    delegate method * to widg except {setwidget C-size C-ipad bind}

    method bind_path {} {return \$win.w}
    ## method "bind" should call "bind \$win.w \$args
    method bind {args} {
        # (why not works "bind \$win.w \$args" ??)
        bind \$win.w [lindex \$args 0] [lindex \$args 1]
    }
    method Subwidget {name} { return \$win.w }
}
}
EOS
}

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

#
# AUTOLOAD method for Tcl::Tk interpreter object, which will bring into
# existance interpreter methods
sub AUTOLOAD {
    my $int = shift;
    my ($method,$package) = $Tcl::Tk::AUTOLOAD;
    my $method0;
    for ($method) {
	s/^(Tcl::Tk::)//
	    or die "weird inheritance ($method)";
	$package = $1;
        $method0 = $method;
	s/(?<!_)__(?!_)/::/g;
	s/(?<!_)___(?!_)/_/g;
    }
 
    # 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::Tk::{$method}) {
	    no strict 'refs';
	    *{"::Tcl::Tk::_$method"} = *{"::Tcl::Tk::$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;
    return $sub->($int,@_);
}

## ------------------------------------------------------------------------
## Widget package, responsible for all Tcl/Tk widgets and any other widgets
## Widgets are blessed to this package or to its sub-packages
## such as Tcl:Tk::Widget::Button, which ISA-Tcl::Tk::Widget
##

package Tcl::Tk::Widget;

use overload
    '""' => \&path,
    'eq' => sub {my $self = shift; return $self->path eq shift},
    'ne' => sub {my $self = shift; return $self->path ne shift};

sub iconimage {
    # this should set the wm iconimage/iconbitmap with an image
    warn "NYI: iconimage";
};

sub path {
    return $Wpath->{${$_[0]}};
}
# returns interpreter that is associated with widget
sub interp {
    unless (exists $Wint->{${$_[0]}}) {
	print caller;
	die "do not exist: ",${$_[0]};
    }
    return $Wint->{${$_[0]}};
}
# returns (and optionally creates) data hash assotiated with widget
sub widget_data {
    my $self = shift;
    return ($Wdata->{$self->path} || ($Wdata->{$self->path}={}));
}

# few convenience methods
sub tooltip {
    my $self = shift;
    my $ttext = shift;
    $self->interp->packageRequire('tooltip');
    $self->interp->call("tooltip::tooltip",$self,$ttext);
    $self;
}

#
# few geometry methods here
sub pack {
    my $self = shift;
    $self->interp->call("pack",$self,@_);
    $self;
}
sub grid {
    my $self = shift;
    $self->interp->call("grid",$self,@_);
    $self;
}
sub gridSlaves {
    # grid slaves returns widget names, so map them to their objects
    my $self = shift;
    my $int  = $self->interp;
    my @wids = $int->call("grid","slaves",$self,@_);
    map($int->widget($_), @wids);
}
sub place {
    my $self = shift;
    $self->interp->call("place",$self,@_);
    $self;
}
sub lower {
    my $self = shift;
    $self->interp->call("lower",$self,@_);
    $self;
}
sub raise {
    my $self = shift;
    my $wp = $self->path;
    $self->interp->call('raise',$wp,@_);
}

# helper sub _bind_widget_helper inserts into subroutine callback
# widget as parameter
sub _bind_widget_helper {
    my $self = shift;
    my $sub = shift;
    if (ref($sub) eq 'ARRAY') {
	if ($#$sub>0) {
	    if (ref($sub->[1]) eq 'Tcl::Ev') {
		$sub = [$sub->[0],$sub->[1],$self,@$sub[2..$#$sub]];
	    }
	    else {
		$sub = [$sub->[0],$self,@$sub[1..$#$sub]];
	    }
	}
	else {
	    $sub = [$sub->[0], $self];
	}
	return $sub;
    }
    else {
	return sub{$sub->($self,@_)};
    }
}
sub bind_path { # this is overridden in scrolled widgets
    return shift->path;
}
sub bind {
    my $self = shift;
    if ($_[0] =~ /^</) {
	# A sequence was specified - assume path from widget instance
	$self->interp->call("bind",$self->bind_path,@_);
    } else {
	# Not a sequence as first arg - don't assume path
	$self->interp->call("bind",@_);
    }
}
sub tag {
    my ($self,$verb,$tag, @rest) = @_;
    if ($verb eq 'bind') {
	return $self->tagBind($tag,@rest);
    }
    $self->interp->call($self, 'tag', $verb, $tag, @rest);
}
sub tagBind {
    my $self = shift;
    if ($#_==3 and ref($_[2]) eq 'REF') {
        my ($tag, $seq, $ref, $sub) = @_;
        $sub = $self->_bind_widget_helper($sub);
        return $self->interp->call($self,'tag','bind',$tag,$seq,$ref,$sub);
    }
    my ($tag, $seq, $sub) = @_;
    # 'text'
    # following code needs only to insert widget as a first argument to 
    # subroutine
    $sub = $self->_bind_widget_helper($sub);
    $self->interp->call($self, 'tag', 'bind', $tag, $seq, $sub);
}

sub form {
    my $self = shift;
    my $int = $self->interp;
    $int->pkg_require("Tix");
    my @arg = @_;
    for (@arg) {
	if (ref && ref eq 'ARRAY') {
	    $_ = join ' ', map {
		  (ref && (ref =~ /^Tcl::Tk::Widget\b/))?
		    $_->path  # in this case there is form geometry relative
		              # to widget; substitute its path
		  :$_} @$_;
	    s/^& /&/;
	}
    }
    $int->call("tixForm",$self,@arg);
    $self;
}

# TODO -- these methods could be AUTOLOADed
sub focus {
    my $self = shift;
    my $wp = $self->path;
    $self->interp->call('focus',$wp,@_);
}
sub destroy {
    my $self = shift;
    my $int = $self->interp;
    my $wp = $self->path;
    $int->call('destroy',$wp,@_);
    $int->delete_widget_refs($wp);
}

# for compatibility (TODO -- more methods could be AUTOLOADed)
sub GeometryRequest {
    my $self = shift;
    my $wp = $self->path;
    my ($width,$height) = @_;
    $self->interp->call('wm','geometry',$wp,"=${width}x$height");
}
sub OnDestroy {
    my $self = shift;
    my $wp = $self->path;
    $self->interp->call('bind','<Destroy>',$wp,@_);
}
sub grab {
    my $self = shift;
    my $wp = $self->path;
    $self->interp->call('grab',$wp,@_);
}
sub grabRelease {
    my $self = shift;
    my $wp = $self->path;
    $self->interp->call('grab','release',$wp,@_);
}
sub packAdjust {
    # old name, becomes pack configure
    my $self = shift;
    my $wp = $self->path;
    $self->interp->call('pack','configure',$wp,@_);
}
sub optionGet {
    my $self = shift;
    my $wp = $self->path;
    $self->interp->call('option','get',$wp,@_);
}

sub update {
    my $self = shift;
    $self->interp->update;
}
sub ItemStyle {
    my $self = shift;
    my $styl = shift;
    my $wp   = $self->path;
    my $int  = $self->interp;
    $int->pkg_require('Tix');
    my %args = @_;
    $args{'-refwindow'} = $wp unless exists $args{'-refwindow'};
    $int->call('tixDisplayStyle', $styl, %args);
}
sub getOpenFile {
    my $self = shift;
    my %args = @_;
    $args{'-parent'} = $self->path unless defined $args{'-parent'};
    $self->interp->call('tk_getOpenFile', %args);
}
sub getSaveFile {
    my $self = shift;
    my %args = @_;
    $args{'-parent'} = $self->path unless defined $args{'-parent'};
    $self->interp->call('tk_getSaveFile', %args);
}
sub chooseDirectory {
    my $self = shift;
    my %args = @_;
    $args{'-parent'} = $self->path unless defined $args{'-parent'};
    $self->interp->call('tk_chooseDirectory', %args);
}
sub messageBox {
    my $self = shift;
    my %args = @_;
    $args{'-parent'} = $self->path unless defined $args{'-parent'};
    # messageBox should handle pTk's "YesNo" and return "Yes" in
    # addition to Tk's standard all-lc in/out.
    #$args{'-type'} = lc $args{'-type'} if defined $args{'-type'};
    $self->interp->call('tk_messageBox', %args);
}

# TODO all Busy subs
sub Busy {
    my $self = shift;
    print STDERR "Busy = TODO\n";
    $self;
}
sub Unbusy {
    my $self = shift;
    print STDERR "Unbusy = TODO\n";
    $self;
}

# subroutine Darken copied from perlTk/Widget.pm
# tkDarken --
# Given a color name, computes a new color value that darkens (or
# brightens) the given color by a given percent.
#
# Arguments:
# color - Name of starting color.
# perecent - Integer telling how much to brighten or darken as a
# percent: 50 means darken by 50%, 110 means brighten
# by 10%.
sub Darken {
    my ($w,$color,$percent) = @_;
    my @l = $w->rgb($color);
    my $red = $l[0]/256;
    my $green = $l[1]/256;
    my $blue = $l[2]/256;
    $red = int($red*$percent/100);
    $red = 255 if ($red > 255);
    $green = int($green*$percent/100);
    $green = 255 if ($green > 255);
    $blue = int($blue*$percent/100);
    $blue = 255 if ($blue > 255);
    sprintf('#%02x%02x%02x',$red,$green,$blue);
}

sub PathName {
    my $wid = shift;
    return $wid->path;
}
sub Exists {
    my $wid = shift;
    my $wp = $wid->path;
    return $wid->interp->icall('winfo','exists',$wp);
}
sub toplevel {
    my $wid = shift;
    my $int = $wid->interp;
    my $tlp = $int->icall('winfo','toplevel',$wid->path);
    if ($tlp eq '.') {return $int->mainwindow}
    return $int->widget($tlp);
}
sub parent {
    my $wid = shift;
    my $int = $wid->interp;
    my $res = $int->icall('winfo','parent',$wid->path);
    if ($res eq '') {return ''}
    if ($res eq '.') {return $int->mainwindow}
    return $int->widget($res);
}

sub bell {
    my $self = shift;
    my $int = $self->interp;
    my $ret = $int->call('bell', @_);
}

sub children {
    my $self = shift;
    my $int  = $self->interp;
    my @wids = $int->call('winfo', 'children', $self->path, @_);
    # winfo children returns widget paths, so map them to objects
    return map ($int->widget($_), @wids);
}
sub Subwidget {
    my $self = shift;
    my $name = shift;
    my $int  = $self->interp;
    my $subwid = $int->call($self->path, 'Subwidget', $name);
    return $int->widget($subwid);
}

# although this is not the case, we'll think of object returned by 'after'
# as a widget.
sub after {
    my $self = shift;
    my $int = $self->interp;
    my $ret = $int->call('after', @_);
    return $int->declare_widget($ret);
}
sub cancel {
    my $self = shift;
    return $self->interp->call('after','cancel',$self);
}

#
# Getimage compatability routine
#

my %image_formats =
    (
     xpm => 'photo',
     gif => 'photo',
     ppm => 'photo',
     xbm => 'bitmap'
     );

sub Getimage {
    my $self = shift;
    my $name = shift;
    my $images;

    return $images->{$name} if $images->{$name};

    my $int = $self->interp;
    foreach my $ext (keys %image_formats) {
	my $path;
	foreach my $dir (@INC) {
	    $path = "$dir/Tk/$name.$ext";
	    last if -f $path;
	}
	next unless -f $path;
	# Found image $path
	if ($ext eq "xpm") {
	    $int->pkg_require('img::xpm');
	}
	my @args = ('image', 'create', $image_formats{$ext}, -file => $path);
	if ($image_formats{$ext} ne "bitmap") {
	    push @args, -format => $ext;
	}
	$images->{$name} = $int->call(@args);
	return $images->{$name};
    }

    # Try built-in bitmaps from Tix
    #$images->{$name} = $w->Pixmap( -id => $name );
    #return $images->{$name};
    _DEBUG(1, "Getimage: MISSING IMAGE $name\n") if DEBUG;
    return;
}

#
# some class methods to provide same syntax as perlTk do
# In this case all widget names are generated automatically.
#

# global widget counter, only for autogenerated widget names.
my $gwcnt = '01'; 

sub w_uniq {
    my ($self, $type) = @_;
    # create unique widget id with path "$self.$type<uniqid>"
    # assume produced names are unique (without checking for already generated
    # names) since $gwcnt incremented *each* call to w_uniq
    # Issues to resolve:
    #  - widgets created in Tcl could (rarely!) have same hence conflicting
    #    name, should detect such cases
    #  - could be reasonable to respect user's -name option, for compatibility
    if (!defined($type)) {
	my ($package, $callerfile, $callerline) = caller;
	warn "$callerfile:$callerline called w_uniq(@_)";
	$type = "unk";
    }
    my $wp = $self->path;
    # Ensure that we don't end up with '..btn01' as a widget name
    $wp = '' if $wp eq '.';
    $gwcnt++;
    Tcl::_current_refs_widget("$wp.$type$gwcnt");
    return "$wp.$type$gwcnt";
}

# perlTk<->Tcl::Tk mapping in form [widget, wprefix, ?package?]
# These will be looked up 1st in AUTOLOAD
my %ptk2tcltk =
    (
     Button      => ['button', 'btn',],
     Checkbutton => ['checkbutton', 'cb',],
     Canvas      => ['canvas', 'can',],
     Entry       => ['entry', 'ent',],
     Frame       => ['frame', 'f',],
     LabelFrame  => ['labelframe', 'lf',],
     Labelframe  => ['labelframe', 'lf',],
     #LabFrame    => ['labelframe', 'lf',],
     Label       => ['label', 'lbl',],
     Listbox     => ['listbox', 'lb',],
     Message     => ['message', 'msg',],
     Menu        => ['menu', 'mnu',],
     Menubutton  => ['menubutton', 'mbtn',],
     Panedwindow => ['panedwindow', 'pw',],
     Bitmap	 => ['image', 'bmp',],
     Photo	 => ['image', 'pht',],
     Radiobutton => ['radiobutton', 'rb',],
     ROText	 => ['text', 'rotext','snit'],
     Text        => ['text', 'text',],
     Scrollbar   => ['scrollbar','sb',],
     Scale       => ['scale','scl',],
     TextUndo    => ['text', 'utext',],
     Toplevel    => ['toplevel', 'top',],

     Table       => ['table', 'tbl', 'Tktable'],

     Separator   => ['Separator', 'sep', 'BWidget'],

     BrowseEntry => ['ComboBox', 'combo', 'BWidget'],
     ComboBox    => ['ComboBox', 'combo', 'BWidget'],
     ListBox     => ['ListBox', 'lb', 'BWidget'],
     BWTree      => ['Tree', 'bwtree', 'BWidget'],

     TileNoteBook => ['tile::notebook', 'tnb', 'tile'],

     Treectrl    => ['treectrl', 'treectrl', 'treectrl'],
     Spinbox     => ['spinbox', 'spn',],

     Balloon     => ['tixBalloon', 'bl', 'Tix'],
     DirTree     => ['tixDirTree', 'dirtr', 'Tix'],
     HList       => ['tixHList', 'hlist', 'Tix'],
     TList       => ['tixTList', 'tlist', 'Tix'],
     NoteBook    => ['tixNoteBook', 'nb', 'Tix'],
     );

# Mapping of pTk camelCase names to Tcl commands.
# These do not require the actual widget name.
# These will be looked up 2nd in AUTOLOAD
# $w->mapCommand(...) => @qwargs ...
my %ptk2tcltk_mapper =
    (
     "optionAdd"        => [ qw(option add) ],
     "font"             => [ qw(font) ],
     "fontCreate"       => [ qw(font create) ],
     "fontNames"        => [ qw(font names) ],
     "waitVariable"     => [ qw(vwait) ], # was tkwait variable
     "idletasks"        => [ qw(update idletasks) ],
     );

# wm or winfo subroutines, to be checked 4th in AUTOLOAD
# $w->wmcommand(...) => wm|winfo wmcommand $w ...
my %ptk2tcltk_wm =
    (
     "deiconify"     => 'wm',
     "geometry"      => 'wm', # note 'winfo geometry' isn't included
     "group"         => 'wm',
     "iconify"       => 'wm',
     "iconname"      => 'wm',
     "minsize"       => 'wm',
     "maxsize"       => 'wm',
     "protocol"      => 'wm',
     "resizable"     => 'wm',
     "stackorder"    => 'wm',
     "state"         => 'wm',
     "title"         => 'wm',
     "transient"     => 'wm',
     "withdraw"      => 'wm',
     ( 
	 # list of widget pTk methods mapped to 'winfo' Tcl/Tk methods
	 # following lines result in pairs  'method' => 'winfo'
	 map {$_=>'winfo'} qw(
	     atom atomname
	     cells children class colormapfull containing
	     depth
	     fpixels
	     height
	     id interps ismapped
	     manager
	     name
	     pathname pixels pointerx pointery
	     reqheight reqwidth  rgb  rootx rooty
	     screen screencells screendepth screenvisual
	     screenheight screenwidth screenmmheight screenmmwidth server
	     viewable visual visualid visualsavailable vrootheight vrootwidth
	     vrootx vrooty
	     width
	     x y
         ),
     )
     );

my $ptk_w_names = join '|', sort keys %ptk2tcltk;


#  create_ptk_widget_sub creates subroutine similar to following:
#sub Button {
#  my $self = shift; # this will be a parent widget for newer button
#  my $int = $self->interp;
#  my $w    = w_uniq($self, "btn");
#  # create 'button' widget with a unique path
#  return $int->button($w,@_);
#}
my %replace_options =
    (
     tixHList   => {separator=>'-separator'},
     ComboBox   => {-choices=>'-values'},
     table      => {-columns=>'-cols'},
     toplevel   => {-title=>sub{shift->title(@_)},OnDestroy=>sub{},-overanchor=>undef},
     labelframe => {-label=>'-text', -labelside => undef},
     );
my %pure_perl_tk = (); # hash to keep track of pure-perl widgets

sub create_ptk_widget_sub {
    my ($interp,$wtype,$fast) = @_;
    my ($ttktype,$wpref,$tpkg,$tcmd) = @{$ptk2tcltk{$wtype}};
    $wpref ||= lcfirst $wtype;

    $interp->pkg_require($tpkg) if $tpkg; # should be moved into widget creation sub?
    $interp->Eval($tcmd)        if $tcmd; # should be moved into widget creation sub? 

    if (exists $replace_options{$ttktype}) {
	return sub {
	    my $self = shift; # this will be a parent widget for newer widget
	    my $int = $self->interp;
	    my $w    = w_uniq($self, $wpref); # create uniq pref's widget id
	    my %args = @_;
	    my @code_todo;
	    for (keys %{$replace_options{$ttktype}}) {
		if (defined($replace_options{$ttktype}->{$_})) {
		    if (exists $args{$_}) {
		        if (ref($replace_options{$ttktype}->{$_}) eq 'CODE') {
			    push @code_todo, [$replace_options{$ttktype}->{$_}, delete $args{$_}];
			}
			else {
			    $args{$replace_options{$ttktype}->{$_}} =
			        delete $args{$_};
			}
		    }
		} else {
		    delete $args{$_} if exists $args{$_};
		}
	    }
	    my $wid = $int->declare_widget($int->call($ttktype,$w,%args), "Tcl::Tk::Widget::$wtype");
	    $_->[0]->($wid,$_->[1]) for @code_todo;
	    return $wid;
	};
    }
    return $fast ? sub {
	my $self = shift; # this will be a parent widget for newer widget
	my $int  = $self->interp;
        my $w    = w_uniq($self, $wpref); # create uniq pref's widget id
	my $wid  = $int->declare_widget($int->invoke($ttktype,$w,@_), "Tcl::Tk::Widget::$wtype");
	return $wid;
    } : sub {
	my $self = shift; # this will be a parent widget for newer widget
	my $int  = $self->interp;
        my $w    = w_uniq($self, $wpref); # create uniq pref's widget id
	my $wid  = $int->declare_widget($int->call($ttktype,$w,@_), "Tcl::Tk::Widget::$wtype");
	return $wid;
    };
}

sub LabFrame {
    my $self = shift; # this will be a parent widget for newer labframe
    my $int  = $self->interp;
    my $w    = w_uniq($self, "lf"); # create uniq pref's widget id
    my $ttktype = "labelframe";
    my %args = @_;
    for (keys %{$replace_options{$ttktype}}) {
	if (defined($replace_options{$ttktype}->{$_})) {
	    $args{$replace_options{$ttktype}->{$_}} =
		delete $args{$_} if exists $args{$_};
	} else {
	    delete $args{$_} if exists $args{$_};
	}
    }
    create_widget_package('LabFrame');
    my $lf = $int->declare_widget($int->call($ttktype, $w, %args), "Tcl::Tk::Widget::LabFrame");
    create_method_in_widget_package('LabFrame',
	Subwidget => sub {
	    my $lf = shift;
	    warn "LabFrame $lf ignoring Subwidget(@_)\n";
	    return $lf;
	},
    );
    return $lf;
}

# interpreter method, prepare_ROText, will do preparation for ROText widget
# (namespace, methods in it, etc)
sub Tcl::Tk::prepare_ROText {
    my $int = shift; # interpreter
    if (create_widget_package('ROText')) {
	$int->create_rotext;

	create_method_in_widget_package('ROText',
	    insert => sub {
		my $wid = shift;
		$wid->interp->call($wid, 'ins', @_);
	    },
	    delete => sub {
		my $wid = shift;
		$wid->interp->call($wid, 'del', @_);
	    }
	);
    }
}
# ROText implementation
sub ROText {
    # Read-only text
    my $self = shift; # this will be a parent widget for newer ROText
    my $int  = $self->interp;
    $int->prepare_ROText;
    my $w    = w_uniq($self, "rotext"); # create uniq pref's widget id
    my $text = $int->declare_widget($int->call('rotext', $w, @_), "Tcl::Tk::Widget::ROText");
    return $text;
}

# Text
sub _prepare_ptk_Text {
    require Tcl::Tk::Widget::Text; # get more Text p/Tk compat methods
}
# ROText
sub _prepare_ptk_ROText {
    require Tcl::Tk::Widget::Text; # get more Text p/Tk compat methods
}

# Balloon
sub _prepare_ptk_Balloon {
    require Tcl::Tk::Widget::Balloon;
}

# Listbox
sub _prepare_ptk_Listbox {
    create_method_in_widget_package ('Listbox', 
	bind => sub {
	    my $self = shift;
	    if ($#_=1 && ref($_[1]) =~ /^(?:ARRAY|CODE)$/) {
		my ($seq, $sub) = @_;
		$sub = $self->_bind_widget_helper($sub);
		$self->interp->call('bind',$self->bind_path,$seq,$sub);
	    }
	    else {
		$self->interp->call('bind',$self->bind_path,@_);
	    }
	}
    );
}

# Canvas
sub _prepare_ptk_Canvas {
    create_method_in_widget_package ('Canvas', 
	raise => sub {
	    my $self = shift;
	    my $wp = $self->path;
	    $self->interp->call($wp,'raise',@_);
	},
	lower => sub {
	    my $self = shift;
	    my $wp = $self->path;
	    $self->interp->call($wp,'lower',@_);
	},
	bind => sub {
	    my $self = shift;
	    if ($#_==2) {
		my ($tag, $seq, $sub) = @_;
		$sub = $self->_bind_widget_helper($sub);
		$self->interp->call($self->bind_path,'bind',$tag,$seq,$sub);
	    }
	    elsif ($#_==1 && ref($_[1]) =~ /^(?:ARRAY|CODE)$/) {
		my ($seq, $sub) = @_;
		$sub = $self->_bind_widget_helper($sub);
		$self->interp->call($self->bind_path,'bind',$seq,$sub);
	    }
	    else {
		$self->interp->call($self->bind_path,'bind',@_);
	    }
	},
	CanvasBind => sub {
	    my $self = shift;
	    my $item = shift;
	    $self->bind($item,@_);
	},
	CanvasFocus => sub {
	    my $self = shift;
	    $self->interp->call($self->path,'focus',@_);
	},
    );
}

# menu compatibility
sub _process_menuitems;
sub _process_underline {
    # 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;
    my $smnu = $mnu->Menu; # return unique widget id
    my %args = @_;
    my $tearoff = delete $args{'-tearoff'};
    if (defined($tearoff)) {
        $smnu->configure(-tearoff => $tearoff);
    }
    $args{'-menu'} = $smnu;
    my $mis = delete $args{'-menuitems'};
    _process_menuitems($int,$smnu,$mis);
    _process_underline(\%args);
    #$int->call("$mnu",'add','cascade', %args);
    $mnu->add('cascade',%args);
    return $smnu;
}
# internal helper sub to process perlTk's -menuitmes option
sub _process_menuitems {
    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') {
		_process_underline(\%a);
	        _addcascade($mnu, %a);
	    }
	    else {
		$cmd=~s/^button$/command/;
		_process_underline(\%a);
	        $int->call($mnu->path,'add',$cmd, %a);
	    }
	}
	else {
	    if ($_ eq '-' or $_ eq '') {
		$int->invoke($mnu->path,'add','separator');
	    }
	    else {
		die "in menubutton: '$_' not implemented";
	    }
	}
    }
}
sub Menubutton {
    my $self = shift; # this will be a parent widget for newer menubutton
    my $int = $self->interp;
    my $w    = w_uniq($self, "mb"); # create uniq pref's widget id
    my %args = @_;
    my $mcnt = '01';
    my $mis = delete $args{'-menuitems'};
    my $tearoff = delete $args{'-tearoff'};
    $args{'-state'} = delete $args{state} if exists $args{state};

    create_widget_package('Menu');
    create_widget_package('Menubutton');
    create_method_in_widget_package('Menubutton',
	command=>sub {
	    my $wid = shift;
	    my $int = $wid->interp;
	    my %args = @_;
	    _process_underline(\%args);
	    $int->call("$wid.m",'add','command',%args);
	},
	checkbutton => sub {
	    my $wid = shift;
	    my $int = $wid->interp;
	    $int->call("$wid.m",'add','checkbutton',@_);
	},
	radiobutton => sub {
	    my $wid = shift;
	    my $int = $wid->interp;
	    $int->call("$wid.m",'add','radiobutton',@_);
	},
	separator => sub {
	    my $wid = shift;
	    my $int = $wid->interp;
	    $int->call("$wid.m",'add','separator',@_);
	},
	menu => sub {
	    my $wid = shift;
	    my $int = $wid->interp;
	    return $int->widget("$wid.m");
	},
	cget => sub {
	    my $wid = shift;
	    my $int = $wid->interp;
	    if ($_[0] eq "-menu") {
		return $int->widget($int->invoke("$wid",'cget','-menu'));
	    } else {
		die "Finish cget implementation for Menubutton";
	    }
	});
    my $mnub = $int->widget(
	$int->call('menubutton', $w, -menu => "$w.m", %args),
		"Tcl::Tk::Widget::Menubutton");
    my $mnu = $int->widget($int->call('menu',"$w.m"), "Tcl::Tk::Widget::Menu");
    _process_menuitems($int,$mnu,$mis);
    if (defined($tearoff)) {
        $mnu->configure(-tearoff => $tearoff);
    }
    return $mnub;
}
sub Menu {
    my $self = shift; # this will be a parent widget for newer menu
    my $int  = $self->interp;
    my $w    = w_uniq($self, "menu"); # return unique widget id
    my %args = @_;

    my $mis         = delete $args{'-menuitems'};
    $args{'-state'} = delete $args{state} if exists $args{state};

    create_widget_package('Menu');
    create_method_in_widget_package('Menu',
	command => sub {
	    my $wid = shift;
	    my $int = $wid->interp;
	    my %args = @_;
	    _process_underline(\%args);
	    $int->call("$wid",'add','command',%args);
	},
	checkbutton => sub {
	    my $wid = shift;
	    my $int = $wid->interp;
	    $int->call("$wid",'add','checkbutton',@_);
	},
	radiobutton => sub {
	    my $wid = shift;
	    my $int = $wid->interp;
	    $int->call("$wid",'add','radiobutton',@_);
	},
	cascade => sub {
	    my $wid = shift;
	    _addcascade($wid, @_);
	},
	separator => sub {
	    my $wid = shift;
	    my $int = $wid->interp;
	    $int->call("$wid",'add','separator',@_);
	},
	menu => sub {
	    my $wid = shift;
	    my $int = $wid->interp;
	    return $int->widget("$wid");
	},
	cget => sub {
	    my $wid = shift;
	    my $int = $wid->interp;
	    if ($_[0] eq "-menu") {
		return $int->widget("$wid");
	    } else {
		die "Finish cget implementation for Menu";
	    }
	},
	entryconfigure => sub {
	    my $wid = shift;
	    my $int = $wid->interp;
	    my $label = shift;
	    $label =~ s/~//;
	    $int->call("$wid", 'entryconfigure', $label, @_);
	},
    );
    my $mnu = $int->widget($int->call('menu', $w, %args), "Tcl::Tk::Widget::Menu");
    _process_menuitems($int,$mnu,$mis);
    return $mnu;
}

sub NoteBook {
    my $self = shift; # this will be a parent widget for newer notebook
    my $int = $self->interp;
    my $w    = w_uniq($self, "nb"); # return unique widget id
    $int->pkg_require('Tix');
    my %args = @_;
    delete $args{'-tabpady'};
    delete $args{'-inactivebackground'};
    create_widget_package('NoteBook');
    my $bw = $int->declare_widget($int->call('tixNoteBook', $w, %args), "Tcl::Tk::Widget::NoteBook");
    create_method_in_widget_package('NoteBook',
	add=>sub {
	    my $bw = shift;
	    my $int = $bw->interp;
	    my $wp = $int->call($bw,'add',@_);
	    my $ww = $int->declare_widget($wp);
	    return $ww;
	},
    );
    return $bw;
}
sub DialogBox {
    # pTk DialogBox compat sub
    # XXX: This is not complete, needs to handle additional options
    my $self = shift; # this will be a parent widget for newer DialogBox
    my $int  = $self->interp;
    my $wn    = w_uniq($self, "dlgbox"); # return unique widget id
    my %args = @_;
    my $dlg  = $int->declare_widget($int->call('toplevel', $wn,
					       -class => "Dialog"));
    $dlg->withdraw();
    $dlg->title($args{'-title'} || "Dialog Box");
    my $topparent = $int->call('winfo', 'toplevel', $self);
    $dlg->transient($topparent);
    $dlg->group($topparent);
    my $bot  = $dlg->Frame();
    $bot->pack(-side => "bottom", -fill => "x", -expand => 0);
    my $btn;
    my $defbtn;
    foreach (reverse @{$args{'-buttons'}}) {
	$btn = $bot->Button(-text => $_,
			    -command => ['set', '::tk::Priv(button)', "$_"]);
	if ($args{'-default_button'} && $_ eq $args{'-default_button'}) {
	    $defbtn = $btn;
	    $btn->configure(-default => "active");
	    # Add <Return> binding to invoke the default button
	    $dlg->bind('<Return>', ["$btn", "invoke"]);
	}
	if ($^O eq "MSWin32") {
	    # should be done only on Tk >= 8.4
	    $btn->configure(-width => "-11");
	}
	$btn->pack(-side => "right", -padx => 4, -pady => 5);
    }
    # We need to create instance methods for dialogs to handle their
    # perl-side instance variables -popover and -default_button
    $dlg->widget_data->{'-popover'} = $args{'-popover'} || "cursor";
    $dlg->widget_data->{'-default'} = $defbtn;
    # Add Escape and Destroy bindings to trigger vwait
    # XXX Remove special hash items as well
    $dlg->bind('<Destroy>', 'set ::tk::Priv(button) {}');
    $dlg->bind('<Escape>', 'set ::tk::Priv(button) {}');
    my $wtype = 'DialogBox';
    create_widget_package($wtype);
    create_method_in_widget_package($wtype,
	add => sub {
	    my $wid = shift;
	    my $int = $wid->interp;
	    my $wtype = shift;
	    my %args  = @_;
	    my $subw;
	    {
		no strict 'refs';
		$subw = &{"Tcl::Tk::Widget::$wtype"}($wid, %args);
	    }
	    $subw->pack(-side => "top", -fill => "x", -expand => 1);
	    return $subw;
	},
	Show => sub {
	    my $wid = shift;
	    my $int = $wid->interp;
	    my $grabtype = shift;
	    # Grab pertinent instance data
	    my $defbtn  = $wid->widget_data->{'-default'};
	    my $popover = $wid->widget_data->{'-popover'};

	    # ::tk::PlaceWindow is Tk 8.4+
	    if ($popover eq "cursor") {
		$int->call('::tk::PlaceWindow', $wid, 'pointer', 'center');
	    } elsif (Tcl::Tk::Exists($popover)) {
		$int->call('::tk::PlaceWindow', $wid, 'widget', $popover);
	    } else {
		$int->call('::tk::PlaceWindow', $wid);
	    }
	    $int->grab($wid);
	    $int->focus($defbtn) if $defbtn;
	    $int->call('vwait', '::tk::Priv(button)');
	    my $val = $int->GetVar2('::tk::Priv', 'button');
	    eval {
		# Window may have been destroyed
		$int->call('grab', 'release', $wid);
		$int->call('wm', 'withdraw', $wid);
	    };
	    return $val;
	},
	Hide => sub {
	    # This will trigger grab release and withdraw
	    $int->SetVar2('::tk::Priv', 'button', '');
	},
    );
    return bless $dlg, "Tcl::Tk::Widget::$wtype";
}
sub Dialog {DialogBox(@_)}
sub Photo {
    my $self = shift; # this will be a parent widget for newer Photo
    my $int = $self->interp;
    my $w    = w_uniq($self, "pht"); # return unique widget id
    # XXX Do we really want to require all of 'Img' here?  Perhaps the
    # XXX requirement on Img should be pushed to the user level, or only
    # XXX require those formats that Perl/Tk auto-supported (jpeg, ???)
    # VK how differents format should be differentiated? TBD
    #$int->pkg_require('Img');
    create_widget_package('Photo');
    my $bw = $int->declare_widget($int->call('image','create', 'photo', @_),
         "Tcl::Tk::Widget::Photo");
    return $bw;
}
sub Bitmap {
    my $self = shift; # this will be a parent widget for newer Bitmap
    my $int = $self->interp;
    my $w    = w_uniq($self, "bmp"); # return unique widget id
    create_widget_package('Bitmap');
    my $bw = $int->declare_widget($int->call('image','create', 'bitmap', @_),
	"Tcl::Tk::Widget::Bitmap");
    return $bw;
}

my %subwidget_options =
    (
     Tree => [
	 '-columns', '-drawbranch', '-gap', '-header', '-height',
	 '-indent', '-indicator', '-indicatorcmd', '-itemtype',
	 '-padx', '-pady', '-sizecmd', '-separator', '-width',
     ],
     );
sub Tree {
    my $self = shift; # this will be a parent widget for newer tree
    my $int = $self->interp;
    my $w    = w_uniq($self, "tree"); # return unique widget id
    $int->pkg_require('Tix');
    my %args = @_;
    my %sub_args;
    foreach (@{$subwidget_options{'Tree'}}) {
	$sub_args{$_} = delete $args{$_} if exists $args{$_};
    }
    # The hlist options must be passed in -options are creation time
    # as a Tcl list.  Build a Perl array that will be auto-converted
    # to a Tcl list in 'call'.
    my @opts;
    foreach my $opt (keys %sub_args) {
	my $cname = $opt;
	$cname =~ s/^-//;
	push @opts, "hlist.$cname", $sub_args{$opt};
    }
    $args{'-options'} = \@opts;
    create_widget_package('Tree');
    my $tree = $int->declare_widget($int->call('tixTree', $w, %args),
    	"Tcl::Tk::Widget::Tree");
    return $tree;
}

# ----------------------------------------------------------------------------
#   Scrolled implementation.
# unless found in following table, lc(type) will be used to map scrolled type
my %scrolled_map = (
    ListBox=>'ListBox', # for BWidget's ListBox
    Listbox => 'listbox', # for ordinary listbox
);

# Scrolled is implemented via snit
sub Scrolled {
    my $self = shift; # this will be a parent widget for newer Scrolled
    my $int = $self->interp;
    my $wtype = shift; # what type of scrolled widget
    die "wrong 'scrolled' type $wtype" unless $wtype =~ /^\w+$/;
    my $lwtype = $scrolled_map{$wtype} || lc($wtype);
    my %args = @_;

    # some widgets do their own scrolling... exclusions, exclusions.
    if ($wtype eq 'Tree') {
	$args{'-scrollbar'} = "auto";
	return Tree($self, %args);
    }
    if ($wtype eq 'ROText') {
	$int->prepare_ROText; # make sure Tcl/tk basis rotext exists
    }

    delete $args{'-scrollbar'};
    delete $args{'-scrollbars'};
    #warn 'TODO $args{-scrollbar} = "es";';

    $int->create_scrolled_widget($lwtype);
    create_widget_package($wtype);

    create_method_in_widget_package ($wtype,
	Subwidget => sub {
	    my $self = shift;
	    my $name = shift;
	    my $int  = $self->interp;
	    my $subwid = $int->call($self->path, 'Subwidget', $name);
	    return $int->widget($subwid,$wtype);
	},
	bind_path => sub {
	    my $self = shift;
	    return $self->interp->invoke($self->path, "bind_path");
	},
    );
	
    my $w  = w_uniq($self, "scrw"); # return unique widget id
    my $scrw = $int->declare_widget($int->call("scrolled_$lwtype", $w, %args), "Tcl::Tk::Widget::$wtype");
    return $scrw;
}
# end-of-scrolled
# ----------------------------------------------------------------------------


# substitute Tk's "tk_optionMenu" for this
sub Optionmenu_obsolete {
    my $self = shift; # this will be a parent widget for newer Optionmenu
    my $int = $self->interp;

    # translate parameters
    my %args = @_;

    my $w  = w_uniq($self, "om"); # return unique widget id
    my $vref = \do{my $r};
    $vref = delete $args{'-variable'} if exists $args{'-variable'};
    my $options = delete $args{'-options'} if exists $args{'-options'};
    my $replopt = {};
    for (@$options) {
	if (ref) {
	    # anon array [lab=>val]
	    $replopt->{$_->[0]} = $_->[1];
	    $_ = $_->[0];
	}
    }
    my $mnu = $int->call('tk_optionMenu', $w, $vref, @$options);
    $mnu = $int->declare_widget($mnu);
    $w = $int->declare_widget($w);
    my $mmw;
    $mmw = new Tcl::Tk::Widget::MultipleWidget (
        $int,
        $w, ['&','-','*','-variable'=>\$vref,
	    '-textvariable'=>sub {
		my ($w,$optnam,$optval) = @_;
		if (exists $mmw->{_replopt}->{$$vref}) {
		    return \$mmw->{_replopt}->{$$vref};
		}
		return $vref;
	    },
	    '-menu'=> \$mnu,
	    '-options'=>sub {
		print STDERR "***options: {@_}\n";
		my ($w,$optnam,$optval) = @_;
		for (@$optval) {
		    $w->add('command',$_);
		}
	    },
         ],
	 $mnu, ['&entrycget',],
    );
    $mmw->{_replopt} = $replopt if defined $replopt;
    #for (keys %args) {$mmw->configure($_=>$args{$_})}
    return $mmw;
}

sub Optionmenu {
    my $self = shift; # this will be a parent widget for newer Optionmenu
    my $int = $self->interp;
    my %args = @_;

    if ($int->_infoProc('optionmenu') eq '') {
	$int->Eval(<<'EOS'); # create proper Optionmenu megawidget with snit
package require snit
::snit::widgetadaptor optionmenu {
    option -variable
    option -textvariable
    option -options -configuremethod configureoptions
    option -menu -cgetmethod cgetmenu
    option -variable -cgetmethod cgetvariable -configuremethod configurevariable
    variable perlvar
    variable menu
    delegate option * to hull
    delegate method * to hull
    constructor {args} {
	array set pargs $args
	menubutton $win -textvariable $pargs(-variable) -indicatoron 1 -menu $win.menu \
		-relief raised -bd 2 -highlightthickness 2 -anchor c \
		-direction flush
	menu $win.menu -tearoff 0
	set menu $win.menu
        installhull $win
        # Apply an options passed at creation time.
	$self configurelist $args
    }
    method configurevariable {opt val} {
	#puts "configurevariable... $opt=$val;"
	# TODO following line write better
	set perlvar $val
	set "var$win" [eval "return $$val"]
    }
    method cgetvariable {opt} {
	return $perlvar
    }
    method cgetmenu {args} {return $menu}
    method configureoptions {opt vals} {
	# this configure method is rather bogus TODO
	foreach item $vals {
	    $menu add radiobutton -label [lindex $item 0] -value [lindex $item 1] -variable $perlvar
	}
    }
}
EOS
	create_widget_package("Optionmenu");
	create_method_in_widget_package ('Optionmenu',
	    cget => sub {
	        my ($self,$opt) = @_;
	        my $oo = $self->interp->invoke($self->path,"cget",$opt);
	        if ($opt eq "-variable") {
	            return $self->interp->return_ref($oo);
	        } elsif ($opt eq "-menu") {
	            return $self->interp->widget($oo,"Menu");
	        }
	        return $oo;
	    }
	);
    }
    my $w  = w_uniq($self, "om"); # return unique widget id
    ## linearize -options (move this to Tcl area!)
    my @ao = @{ $args{'-options'} || [] };
    for (@ao) {
        $_ = [$_, $_] unless ref;
    }
    $args{'-options'} = \@ao;
    my $ow = $int->declare_widget($int->call("optionmenu", $w, %args), "Tcl::Tk::Widget::Optionmenu");
    return $ow;
}

# TODO -- document clearly how to use this subroutine
sub Declare {
    my $w       = shift;
    my $wtype   = shift;
    my $ttktype = shift;
    my %args    = @_;

    # Allow overriding of existing widgets.
    # XXX This should still die if we have created any single instance
    # XXX of this widget already.
    #die "$wtype already created\n" if defined $ptk2tcltk{$wtype};
    if (!exists $args{'-prefix'}) {
	$args{'-prefix'} ||= lcfirst $ttktype;
	$args{'-prefix'} =~ s/\W+//g;
    }
    $wtype = quotemeta($wtype); # to prevent chars corrupting regexp
    $ptk2tcltk{$wtype} = [$ttktype, $args{'-prefix'}, $args{'-require'},
			  $args{'-command'}];
    $ptk_w_names .= "|$wtype";
}

# here we create Widget package, used for both standard cases like
# 'Button', 'Label', and so on, and for all other widgets like Baloon
# returns 1 if actually package created, i.e. called first time
# TODO : document better and provide as public way of doing things?
my %created_w_packages; # (may be look in global stash %:: ?)
sub create_widget_package {
    my $widgetname = shift;
    unless (exists $created_w_packages{$widgetname}) {
	$created_w_packages{$widgetname} = {};
	die "not allowed widg name $widgetname" unless $widgetname=~/^\w+$/;
	{
	    no strict 'refs';
	    # create Widget package itself;
	    # internally, this is just creating few essential subs in widget's package
	    # method subs will be created later automatically when needed:
	    #
	    @{"Tcl::Tk::Widget::${widgetname}::ISA"} = qw(Tcl::Tk::Widget);
	    *{"Tcl::Tk::Widget::${widgetname}::DESTROY"} = sub {}; # (AUTOLOAD protection)
	    eval "
	    sub Tcl::Tk::Widget::${widgetname}::AUTOLOAD {
	        \$Tcl::Tk::Widget::AUTOLOAD = \${Tcl::Tk::Widget::${widgetname}::AUTOLOAD};
	        return &Tcl::Tk::Widget::AUTOLOAD;
	    }
	    ";
	    # if there exists sub _prepare_ptk_XXXXXX then call it
	    if (exists ${"Tcl::Tk::Widget::"}{"_prepare_ptk_$widgetname"}) {
		${"Tcl::Tk::Widget::"}{"_prepare_ptk_$widgetname"}->();
	    }
	}
	# Add this widget class to ptk_w_names so the AUTOLOADer properly
	# identifies it for creating class methods
	#$widgetname = quotemeta($widgetname); # (no need to prevent chars corrupting regexp)
	$ptk_w_names .= "|$widgetname";
	return 1;
    }
    return 0;
}
# this subroutine creates a method in widget's package
sub create_method_in_widget_package {
    my $widgetname = shift;
    create_widget_package($widgetname);
    while ($#_>0) {
	my $widgetmethod = shift;
	my $sub = shift;
	next if exists $created_w_packages{$widgetname}->{$widgetmethod};
	$created_w_packages{$widgetname}->{$widgetmethod}++;
	no strict 'refs';
	my $package = "Tcl::Tk::Widget::$widgetname";
	*{"${package}::$widgetmethod"} = $sub;
	*{"${package}::_$widgetmethod"} = $sub;
    }
}

sub DESTROY {}			# do not let AUTOLOAD catch this method

#
# Let Tcl/Tk process required method via AUTOLOAD mechanism
#

# %lists hash holds names of methods returning *list* of values
# (all methods not listed here are expected to return single value)
my %lists = map {$_=>1} qw(
    bbox configure dlineinfo dump
    markNames tagBind
    windowNames
    formInfo formSlaves
);
sub AUTOLOAD {
    my $w = shift;
    my ($method,$package,$wtype) = ($Tcl::Tk::Widget::AUTOLOAD,undef,undef);
    for ($method) {
	s/^(Tcl::Tk::Widget::((MainWindow|$ptk_w_names)::)?)//
	    or die "weird inheritance ($method)";
        ($package,$wtype) = ($1,$3);
	s/(?<!_)__(?!_)/::/g;
	s/(?<!_)___(?!_)/_/g;
    }
    my $super;
    $method =~ s/^SUPER::// and $super=1; # super-method of child class?

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

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

    # Precedence ordering is important

    # 1. Check to see if it is a known widget method
    if (exists $ptk2tcltk{$method}) {
	create_widget_package($method);
	my $sub = create_ptk_widget_sub($w->interp,$method,$fast);
	no strict 'refs';
	*{"$package$fast$method"} = $sub;
	return $sub->($w,@_);
    }
    # 2. Check to see if it is a known mappable sub (widget unused)
    if (exists $ptk2tcltk_mapper{$method}) {
	my $sub = $fast ? sub {
	    my $self = shift;
	    $self->interp->invoke(@{$ptk2tcltk_mapper{$method}},@_);
	} : sub {
	    my $self = shift;
	    $self->interp->call(@{$ptk2tcltk_mapper{$method}},@_);
	};
	no strict 'refs';
	*{"$package$fast$method"} = $sub;
	return $sub->($w,@_);
    }
    # 3. Check to see if it is a known 'wm' command
    # XXX: What about toplevel vs. inner widget checking?
    if (exists $ptk2tcltk_wm{$method}) {
	my $sub = $fast ? sub {
	    my $self = shift;
	    $self->interp->invoke($ptk2tcltk_wm{$method}, $method, $self->path, @_);
	} : sub {
	    my $self = shift;
	    $self->interp->call($ptk2tcltk_wm{$method}, $method, $self->path, @_);
	};
	no strict 'refs';
	*{"$package$fast$method"} = $sub;
	return $sub->($w,@_);
    }
    # 4. 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));
	if ($meth eq "grid" || $meth eq "pack") {
	    # grid/pack commands reorder $wp in the call.
	    $sub = $fast ? sub {
		my $w = shift;
		$w->interp->invoke($meth, $submeth, $w->path, @_);
	    } : sub {
		my $w = shift;
		$w->interp->call($meth, $submeth, $w->path, @_);
	    };
	} elsif ($meth eq "after") {
	    # after commands don't include $wp in the call
	    $sub = $fast ? sub {
		my $w = shift;
		scalar($w->interp->invoke($meth, $submeth, @_));
	    } : sub {
		my $w = shift;
		scalar($w->interp->call($meth, $submeth, @_));
	    };
	} else {
	    # Default camel-case, break into $wp $method $submethod and call
	    # if method was created with 'create_method_in_widget_package' it should
	    # be called instead...
	    if (exists $created_w_packages{$wtype}->{$meth}) {
		$sub = sub {
		    my $w = shift;
		    $w->$meth($submeth,@_);
		};
	    } else {
		# ... otherwise ordinary camel case invocation
		if (exists $lists{$method}) {
		    $sub = $fast ? sub {
			my $w = shift;
			$w->interp->invoke($w->path, $meth, $submeth, @_);
		    } : sub {
			my $w = shift;
			$w->interp->call($w->path, $meth, $submeth, @_);
		    };
		} else {
		    $sub = $fast ? sub {
			my $w = shift;
			scalar($w->interp->invoke($w->path, $meth, $submeth, @_));
		    } : sub {
			my $w = shift;
			scalar($w->interp->call($w->path, $meth, $submeth, @_));
		    };
		}
	    }
	}
    }
    elsif ($method =~ /^([a-z]+)([A-Z][A-Za-z]+)$/) {
	# even more camelCaseMethod
        my ($meth, $submeth) = ($1, $2);
	my @submethods = map{lcfirst($_)} $submeth=~/([A-Z][a-z]+)/g;
	# Default camel-case, break into $wp $method $submethod and call
	# if method was created with 'create_method_in_widget_package' it should
	# be called instead...
	if (exists $created_w_packages{$wtype}->{$meth}) {
	    $sub = sub {
	        my $w = shift;
	        $w->$meth(@submethods,@_);
	    };
	} else {
	    # ... otherwise ordinary camel case invocation
	    if (exists $lists{$method}) {
	        $sub = $fast ? sub {
	    	my $w = shift;
	    	$w->interp->invoke($w->path, $meth, @submethods, @_);
	        } : sub {
	    	my $w = shift;
	    	$w->interp->call($w->path, $meth, @submethods, @_);
	        };
	    } else {
	        $sub = $fast ? sub {
	    	my $w = shift;
	    	scalar($w->interp->invoke($w->path, $meth, @submethods, @_));
	        } : sub {
	    	my $w = shift;
	    	scalar($w->interp->call($w->path, $meth, @submethods, @_));
	        };
	    }
	}
    }
    else {
	# Default case, call as submethod of $wp
	if (exists $lists{$method}) {
	    $sub = $fast ? sub {
		my $w = shift;
		$w->interp->invoke($w, $method, @_);
	    } : sub {
		my $w = shift;
		$w->interp->call($w, $method, @_);
	    };
	} else {
	    $sub = $fast ? sub {
		my $w = shift;
		scalar($w->interp->invoke($w, $method, @_));
	    } : sub {
		my $w = shift;
		scalar($w->interp->call($w, $method, @_));
	    };
	}
    }
    {
	# create method $method in package $package
	no strict 'refs';
	*{"$package$fast$method"} = $sub unless $super;
    }
    # call freshly-created method (next time it will not go through AUTOLOAD)
    return $sub->($w,@_);
}

package Tcl::Tk::Widget::MainWindow;

@Tcl::Tk::Widget::MainWindow::ISA = qw(Tcl::Tk::Widget);

sub DESTROY {}			# do not let AUTOLOAD catch this method

sub AUTOLOAD {
    $Tcl::Tk::Widget::AUTOLOAD = $Tcl::Tk::Widget::MainWindow::AUTOLOAD;
    return &Tcl::Tk::Widget::AUTOLOAD;
}

sub path {'.'}

# subroutine for compatibility with perlTk
my $invcnt=0;
sub new {
    my $self = shift;
    if ($invcnt==0) {
        $invcnt++;
        return $self;
    }
    return $self->Toplevel(@_);
}

# provide -title option for 'configure', for perlTk compatibility
sub configure {
    my $self = shift;
    my %args = @_;
    if (exists $args{'-title'}) {
	$self->interp->invoke('wm','title',$self->path,$args{'-title'});
	delete $args{'-title'};
    }
    if (scalar keys %args > 0) {
	# following line should call configure on base class, Tcl::Tk::Widget
	# for some reason, AUTOLOAD sub receives 'SUPER::' within AUTOLOAD
	$self->SUPER::configure(%args);
    }
}
sub cget {
    my $self = shift;
    my $opt = shift;
    if ($opt eq '-title') {
	return $self->interp->invoke('wm','title',$self->path);
    }
    return $self->SUPER::cget($opt);
}

1;