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

Tcl-Tk documentation Contained in the Tcl-Tk distribution.

Index

Code Index:

NAME

Top

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

SYNOPSIS

Top

    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;

DESCRIPTION

Top

The 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 tile).

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;

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: 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 MainWindow and tkinit methods, and main window object is returned in this case:

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

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 Tcl::Tk::MainLoop or Tcl::Tk->MainLoop if you prefer. You can even do simply MainLoop if you import it from Tcl::Tk in the use statement.

Creating and using widgets

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

* access with a special widget accessing syntax of kind $widget->method;
* random access with Eval

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 ($int->Eval('...')) and then smoothly move to 1st, approach with perl/Tk syntax.

Tcl/Tk syntax

* interpreter

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

* 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 .fram and you want to create a button on it and name it butt then you should specify name .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 $widget->path; within Tcl::Tk.

* 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, .fr.b is Tk's command and this command has subcommands, those will help manipulating widget. That is why $int->Eval('.fr.b configure -text {new text}'); makes sence. Note that $button->configure(-text=>'new text'); does exactly that, provided a fact $button corresponds to .fr.b widget.

use Tcl::Tk; not only creates Tcl::Tk package, but also it creates Tcl::Tk::Widget package, responsible for widgets. Each widget (object blessed to 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.

Perl/Tk syntax

Tcl::Tk::Widget package within Tcl::Tk module fully aware of perl/Tk widget syntax, which has long usage. This means that any Tcl::Tk widget has a number of methods like Button, Frame, Text, Canvas and so on, and invoking those methods will create appropriate child widget. 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 $label will be blessed to package Tcl::Tk::Widget::Label which is isa-Tcl::Tk::Widget

OO explanations of Widget-s of Tcl::Tk

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 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 text in Tcl/Tk environment). When this creation method invoked first time, a package 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 Tcl::Tk::Widget.

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

At first time when insert is called, this method does not exist, so AUTOLOAD comes to play and creates such a method. Second time 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 insert method of Tcl::Tk::Widget::Listbox will mean completely different behaviour.

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

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

  $widget->method(@parameters);

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

1.

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

2.

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

3.

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

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

if $method is all lowercase, m/^[a-z]$/

.path method parameter1 parameter2 ....

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

.path method submethod parameter1 parameter2 ....

if $method contains several capital letter inside name, methodSubmethSubsubmeth

.path method submeth subsubmeth parameter1 parameter2 ....

faster way of invoking methods on widgets

In case it is guaranteed that preprocessing of @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, _. 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.

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'));

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 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 $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, $widget->verb1('verb2',...); or it $widget->verb1Verb2(...); - those are identical.

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

$int->widget( path, widget-type ) method

When widgets are created they are stored internally and could be retreived by 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 $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 Tcl::Tk::Exists($widget) subroutine. It queries Tcl/Tk for existance of said widget.

widget_data method

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

Non-widget Tk commands

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

Miscellaneous methods

$widget->tooltip("text") method

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

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

$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');

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

Points of special care

Top

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!

BUGS

Top

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

AUTHORS

Top

Malcolm Beattie.
Vadim Konovalov, vadim_tcltk@vkonovalov.ru 19 May 2003.
Jeff Hobbs, jeffh _a_ activestate com, February 2004.
Gisle Aas, gisle _a_ activestate . com, 14 Apr 2004.

COPYRIGHT

Top

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

Tcl-Tk documentation Contained in the Tcl-Tk distribution. 
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 = '1.04';

sub WIDGET_CLEANUP() {0}


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) = @_;
    if (@_ > 2) {
        require Carp;
        Carp::croak('Usage: $interp = new Tcl::Tk([$display])');
    }
    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{MWID}->{'.'} = $mwid;
    my $_mainwindow = \$mwid;
    bless($_mainwindow, 'Tcl::Tk::Widget::MainWindow');
    $W{mainwindow}->{"$i"} = $_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]";
}

# 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);
}

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

# 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='_';
	$method0 =~ s/^_//;
	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, @_);
	};
    } 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;
	# break into $method $submethod and call
	$sub = $fast ? sub {
	    my $int = shift;
	    $int->invoke($meth, @submethods, @_);
	} : sub {
	    my $int = shift;
	    $int->call($meth, @submethods, @_);
	};
    } 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};

# first, a special sub that will serve to override some of common widget
# methods, such as raise, lower, etc
# (because Canvas's, BWNoteBook widget raise means different thing, etc

# bypass_widget_sub:
# given a widget method name and widget class, create subroutine with this
# name in that widget's package, so that method of same name in 
# Tcl::Tk::Widget package will not be called
#
# in other words, most widget methods work this way:
#   $widget->method
# transformed as
#   .widget method
# but there are several exclusions, where 
#   $widget->method
# transformed as
#   method .widget
#
# our goal is to suppress such exclusions for some widget methods
#
# in perfect world, this subroutine would not be needed.
# in our world, perl/Tk compatibility takes us back, where geometry
# methods became widget methods, and thus occupied name
#
# e.g. $widget->raise is a geometry method for all widgets, but
# BWNoteBook has method with this name
#
# so 
#   raise .widget
# versus
#   .widget raise
#
# canvas and text have similar problem
#
sub bypass_widget_sub {
    my ($method, $widget_class) = @_;
    my $sub = sub {
	my $self = shift;
	$self->interp->call($self->path, $method, @_);
    };
    my $_sub = sub {
	my $self = shift;
	$self->interp->icall($self->path, $method, @_);
    };
    {
	no strict 'refs';
	*{"::Tcl::Tk::Widget::$widget_class\::$method"} = $sub;
	*{"::Tcl::Tk::Widget::$widget_class\::_$method"} = $_sub;
    }
}

# common for all widgets methods

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->pkg_require('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,@_);
}

# 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, 'Toplevel');
}
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,'Widget');
}

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($_,'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,'Widget');
}

# 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;
    for 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};
    }
    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++;
    return "$wp.$type$gwcnt";
}

# perlTk<->Tcl::Tk mapping in form [widget, wprefix, ?package?, ?{method=>widget_class}?, ?[by_passed_method1, by_passed_method2, ...]?]
# These will be looked up 1st in AUTOLOAD
my %ptk2tcltk = (
     Button      => ['button', 'btn',],
     Checkbutton => ['checkbutton', 'cb',],
     Canvas      => ['canvas', 'can', undef, undef, [qw[raise lower]]],
     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'],
     ScrollableFrame => ['ScrollableFrame', 'sfr', 'BWidget',
			{getframe => 'Frame'}],
     ScrolledWindow => ['ScrolledWindow', 'sw', 'BWidget'],

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

     BWNoteBook  => ['NoteBook', 'bwnb', 'BWidget', 
			{getframe => 'Frame'}, 
			   # i.e. getframe returns 'Frame' widget
		        ['raise']
		    ],

     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'],
);

# hash to track widget methods returning widgets, so we'll assign
# widget path of returned by Tk into that widget, so it will be
# bblessed into proper Tcl::Tk::xxxx package.
my %methods_returning_widgets = ( );
# NoteBook => {getframe=>'Frame'}

sub widget_method_returns_widget {
    my ($wtype, $method, $wtype2) = @_;
    $methods_returning_widgets{$wtype}->{$method} = $wtype2;
}

# 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?

    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', 
	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 %args = @_;
    my $smnu = delete $args{'-menu'};
    if (!defined($smnu)) {
        $smnu = $mnu->Menu;
    }
    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);
    $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", "Tcl::Tk::Widget::Menu");
	},
	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", "Tcl::Tk::Widget::Menu");
	},
	cget => sub {
	    my $wid = shift;
	    my $int = $wid->interp;
	    if ($_[0] eq "-menu") {
		return $int->widget("$wid", "Tcl::Tk::Widget::Menu");
	    } 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
    HList => 'tixHList', # for tix HList
);

# 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
my %_om_ref_track; # dirty hack, but fortunately never used
sub Optionmenu {
    my $self = shift; # this will be a parent widget for newer Optionmenu
    my $int = $self->interp;
    my %args = @_;

    if ($int->invoke(qw(info proc optionmenu)) eq '') {
	$int->Eval(<<'EOS'); # create proper Optionmenu megawidget with snit
package require snit
::snit::widgetadaptor optionmenu {
    option -variable -default dummy
    option -textvariable -default dummy
    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} {
	#$self configurevariable -textvariable option(-variable);
	menubutton $win -textvariable option(-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} {
	#puts "cgetvariable... $opt;$perlvar"
	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 $_om_ref_track{$self->path};
	        } 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;
    if ($args{-variable}) {
	$_om_ref_track{$w} = $args{-variable};
    }
    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'},
			];
    $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"}->();
	    }
	}
	# 2011-01-11 
	# if this widget has known widget returning methods, initiate them here
	my $known_w_meths = $ptk2tcltk{$widgetname}->[3];
	if ($known_w_meths) {
	    for (keys %$known_w_meths) {
		widget_method_returns_widget($widgetname,$_,$known_w_meths->{$_});
	    }
	}
	# if this widget has methods to bypass, use it
	my $bypass_meths = $ptk2tcltk{$widgetname}->[4];
	if ($bypass_meths) {
	    for (@$bypass_meths) {
		bypass_widget_sub($_, $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
# '" #syntax calm down
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";
	# 2011-01-11 if we know that this method returns a widget of said type
	if (exists $methods_returning_widgets{$widgetname}->{$widgetmethod}) {
	    # ? should we correctly process context here?
	    # no, because all we must to do is to return widget
	    my $sub1 = sub {
		my $int = $_[0]->interp;
		my $w = &$sub;
		return $int->widget($w,$methods_returning_widgets{$widgetname}->{$widgetmethod});
	    };
	    *{"${package}::$widgetmethod"} = $sub1;
	    *{"${package}::_$widgetmethod"} = $sub1;
	} else {
	    *{"${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 tagRanges tagPrevrange tagNextrange
    formInfo formSlaves
    curselection
    windowNames
);
sub AUTOLOAD {
    my $w = shift;
    my ($method,$package,$wtype) = ($Tcl::Tk::Widget::AUTOLOAD,undef,undef);
    for ($method) {
	s/^(Tcl::Tk::Widget::((MainWindow|$ptk_w_names)::)?)//
	    or die "weird inheritance ($method)";
        ($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, @_));
	    };
	}
    }
    if (exists $methods_returning_widgets{$wtype}->{$method}) {
	my $sub0 = $sub;
	my $sub1 = sub {
	    my $int = $_[0]->interp;
	    my $w = &$sub0;
	    return $int->widget($w,$methods_returning_widgets{$wtype}->{$method});
	};
	$sub = $sub1;
    }
    {
	# 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;