pure-perl pTk widgets support in Tcl::Tk

[Konovalov, Vadim]

Dear all,

it appears that pure-perl pTk widgets support in Tcl::Tk is quite possible,
when trying Tix megawidgets, like in perlTk.

Following program works (not fully though)

use Tcl::Tk;
my $mw = Tcl::Tk::tkinit;
$mw->Declare('ToolBar','*perlTk/ToolBar');
my $tb = $mw->ToolBar(qw/-movable 1 -side top -indicatorcolor blue/);

$tb->ToolButton  (-text  => 'Button', -tip   => 'tool tip', -command => sub
{ print "hi\n" });
$tb->ToolLabel   (-text  => 'A Label');
$tb->Label       (-text  => 'Another Label');
$tb->ToolButton(-image   => 'navback22',         -tip     => 'back',
-command => \&back);
$tb->ToolButton(-image   => 'navforward22', -tip     => 'forward', -command
=> \&forward);
$tb->separator;
$tb->ToolButton(-image   => 'navhome22', -tip     => 'home', -command =>
\&home);
$tb->ToolButton(-image   => 'actreload22', -tip     => 'reload', -command =>
\&reload);

Tcl::Tk::MainLoop;



Support is not ready yet, its too early to think using it.
But it may be well included into next CPAN release of Tcl::Tk.

required:
 - Tix
 - pTk.pm file at http://vkonovalov.ru/tcltk-misc/pTk.pm.html
 - patch below

--- E:\perl584\site\lib\Tcl\Tk.pm       Tue Sep 27 15:50:18 2005
+++ H:\move\pe\Tcl\Tk.pm        Mon Oct 10 02:37:58 2005
@@ -479,6 +479,7 @@
 
 ## TODO -- module's private $tkinterp should go away!
 my $tkinterp = undef;          # this gets defined when "new" is done
+sub tkinterp{$tkinterp}
 
 # Hash to keep track of all created widgets and related instance data
 # Tcl::Tk will maintain PATH (Tk widget pathname) and INT (Tcl interp)
@@ -1579,11 +1580,17 @@
     if ($ttktype =~ s/^\*perlTk\///) {
        # should create pure-perlTk widget and bind it to Tcl variable so
that
        # anytime a method invoked it will be redirected to Perl
+       require 'Tcl/pTk.pm'; # load our pure-perlTk support
+       require "Tk/$ttktype.pm"; # this will 'use' perl/Tk
        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
-         die "pure-perlTk widgets are not implemented";
+           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 = [EMAIL PROTECTED];
+           my $ptkwid = Tcl::pTk::new_widget($self,$ttktype,$w,$args);
+           my $wid  = $int->declare_widget($int->call($ttktype,$w,%$args),
"Tcl::Tk::Widget::$wtype");
+           $ptkwid->bind_tcltk_widget($wid);
+           return $ptkwid;
        };
     }
     if (exists $replace_options{$ttktype}) {
@@ -2167,7 +2174,7 @@
     # XXX of this widget already.
     #die "$wtype already created\n" if defined $ptk2tcltk{$wtype};
     if (!exists $args{'-prefix'}) {
-       $args{'-prefix'} ||= lcfirst $ttktype;
+       $args{'-prefix'} = lcfirst $ttktype;
        $args{'-prefix'} =~ s/\W+//g;
     }
     $wtype = quotemeta($wtype); # to prevent chars corrupting regexp
@@ -2342,10 +2349,10 @@
        _DEBUG(2, "AUTOCREATE $package$method $method (@_)\n") if DEBUG;
        $sub = $fast ? sub {
            my $w = shift;
-           $w->interp->invoke($w, $method, @_);
+           $w->interp->invoke($w->path, $method, @_);
        } : sub {
            my $w = shift;
-           $w->interp->call($w, $method, @_);
+           $w->interp->call($w->path, $method, @_);
        };
     }
     _DEBUG(2, "creating ($package)$method (@_)\n") if DEBUG;

Best regards,
Vadim.