| Subject: | Tcl::pTk::TFrame is missing |
[This was originally reported at Google Code on 2012-12-12: https://code.google.com/archive/p/perl-tcl-ptk/issues/1. Google had since anonymized reporter names, but I figured out who the original reporter was from https://web.archive.org/web/20160810165657/https://code.google.com/p/perl-tcl-ptk/issues/detail?id=1. The JSON file I recovered the original markup from is attached. —CAC]
What steps will reproduce the problem?
- install Tcl::pTk
- try to run a script using Tk::TFrame
What is the expected output? What do you see instead? I would like to see a Tcl::pTk::TFrame widget on CPAN
What version of the product are you using? On what operating system? Tcl::pTk 0.85 with perl 5.14.2 on Windows 7 x64
Please provide any additional information below. Hi!
There is no Tcl::pTk::TFrame module on CPAN. This is one of the derived widgets in Perl/TK and I would like to have it for Tcl::pTk as well.
I tried to write it on my own by looking at the other replacements for derived widgets, however I get an error with the DoWhenIdle method.
DoWhenIdle seems to add an event to IDLE_EVENTS. "These are low-priority callbacks executed only after all events of the previous types have been processed. The most common idle events are those that redraw widgets and refresh the display. You can queue idle callbacks using DoWhenIdle."
And I don't know how to do this in Tcl::pTk.
Please find below my attempt:
package Tcl::pTk::TFrame;
###########################################################
# Emulation of the perl/tk TFrame widget using Tcl::pTk
###########################################################
use 5.014002;
use strict;
use warnings;
use Tcl::pTk ('Ev');
use Carp;
our $VERSION = '0.01';
our @ISA = qw(Tcl::pTk::Derived Tcl::pTk::Frame);
Construct Tcl::pTk::Widget 'TFrame';
=head1 NAME
Tcl::pTk::TFrame - Perl extension for blah blah blah
=head1 SYNOPSIS
use Tcl::pTk::TFrame;
$frame1 = $parent->TFrame(
-label => [ -text => 'Title' ],
-borderwidth => 2,
-relief => 'groove',
);
# or simply
$frame2 = $parent->TFrame(
-label => 'Title'
);
$frame1->pack;
$frame2->pack;
=head1 DESCRIPTION
Tcl::pTk::TFrame provides a frame but with a title which overlaps the border by half of it's height.
=head1 METHODS
=head2 ClassInit($class, $mw)
=cut
sub ClassInit {
my ($class,$mw) = @_;
$class->SUPER::ClassInit($mw);
$mw->bind($class,'<Configure>',['layoutRequest']);
$mw->bind($class,'<FocusIn>', 'NoOp');
return $class;
} # /ClassInit
sub Populate {
my($self,$args) = @_;
$self->SUPER::Populate($args);
# Does not work: Can't set -highlightthickness to `0' for .ttkframe02: unknown option "-highlightthickness"
#$self->configure(-borderwidth => 0, -highlightthickness => 0);
my $border = $self->Component(Frame => "border");
my @label = (
-padx => 4,
-pady => 2,
-borderwidth => 2,
-relief => 'flat'
);
if (exists $args->{'-label'}) {
if (not ref $args->{'-label'}) {
$args->{'-label'} = [ -text => $args->{'-label'} ];
}
push @label, @{$args->{'-label'}};
}
my $label = $self->Component(Label => "label", @label);
my $container = $self->Component(Frame => "container", -borderwidth => 0);
$self->DoWhenIdle(['Manage',$self]);
$self->Default("container" => $container);
$self->ConfigSpecs(
-label => [ 'METHOD', undef, undef, undef],
-relief => [$border,'relief','Relief','groove'],
-borderwidth => [$border,'borderwidth','Borderwidth',2],
-ipadx => [PASSIVE => undef, undef, 0],
-ipady => [PASSIVE => undef, undef, 0],
);
return $self;
} # /Populate
sub label {
my $frame = shift;
my $v = shift || [];
my $l = $frame->Subwidget('label');
$l->configure(@$v);
}
sub layoutRequest {
my($f) = @_;
$f->DoWhenIdle(['adjustLayout',$f]) unless $f->{'layout_pending'};
$f->{'layout_pending'} = 1;
}
sub SlaveGeometryRequest {
my ($m,$s) = @_;
$m->DoWhenIdle(['_SlaveGeometryRequest',$m]) unless $m->{'geom_pending'};
$m->{'geom_pending'} = 1;
}
sub Manage {
my $f = shift;
my $l = $f->Subwidget('label');
my $c = $f->Subwidget('container');
my $b = $f->Subwidget('border');
$f->ManageGeometry($l);
$l->MapWindow;
$f->ManageGeometry($c);
$c->MapWindow;
$f->ManageGeometry($b);
$b->MapWindow;
SlaveGeometryRequest($f,$l);
}
sub _SlaveGeometryRequest {
my $f = shift;
my $l = $f->Subwidget('label');
my $c = $f->Subwidget('container');
my $b = $f->Subwidget('border');
$f->{'geom_pending'} = 0;
my $px = $f->{Configure}{'-ipadx'} || 0;
my $py = $f->{Configure}{'-ipady'} || 0;
my $bw = $b->cget('-borderwidth')*2;
my $w = $c->ReqWidth + $bw + $px*2;
my $w2 = $l->ReqWidth + 20 + $bw;
my $h = $bw + $l->ReqHeight + $c->ReqHeight #+ $f->cget('-borderwidth')*2
+ $py*2;
$f->GeometryRequest($w > $w2 ? $w : $w2,$h);
}
sub adjustLayout {
my $frame = shift;
my $label = $frame->Subwidget('label');
my $container = $frame->Subwidget('container');
my $border = $frame->Subwidget('border');
$frame->{'layout_pending'} = 0;
my $rh = $label->ReqHeight;
my $px = $frame->{Configure}{'-ipadx'} || 0;
my $bw = $frame->{Configure}{'-borderwidth'} || 0;
my $py = $frame->{Configure}{'-ipady'} || 0;
my $W = $frame->Width;
my $H = $frame->Height;
$border->MoveResizeWindow(0,int($rh/2),$W,$H-int($rh/2));
$container->MoveResizeWindow(
$px+$bw,$rh + $py, $W - (($px+$bw) * 2), $H - $rh -$bw - ($px * 2));
$label->MoveResizeWindow(10,0,$label->ReqWidth,$label->ReqHeight);
}
sub grid {
my $w = shift;
$w = $w->Subwidget('container')
if (@_ && $_[0] =~ /^(?: bbox
|columnconfigure
|location
|propagate
|rowconfigure
|size
|slaves)$/x);
$w->SUPER::grid(@_);
}
sub slave {
my $w = shift;
$w->Subwidget('container');
}
sub pack {
my $w = shift;
$w = $w->Subwidget('container')
if (@_ && $_[0] =~ /^(?:propagate|slaves)$/x);
$w->SUPER::pack(@_);
}
=head1 SEE ALSO
L<Tk::TFrame>
=head1 AUTHOR
A. U. Thor, E<lt>a.u.thor@a.galaxy.far.far.awayE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2012 by A. U. Thor
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.14.2 or,
at your option, any later version of Perl 5 you may have available.
=cut
1; # / Tcl::pTk::TFrame
| Subject: | issue-1.json |
{"id":1,"status":"New","summary":"Tcl::pTk::TFrame is missing","labels":["Type-Defect","Priority-Medium"],"stars":0,"commentCount":1,"comments":[{"id":0,"commenterId":-5970956808934350519,"content":"\u003cb\u003eWhat steps will reproduce the problem?\u003c/b\u003e\n1. install Tcl::pTk\r\n2. try to run a script using Tk::TFrame\r\n\r\n\u003cb\u003eWhat is the expected output? What do you see instead?\u003c/b\u003e\nI would like to see a Tcl::pTk::TFrame widget on CPAN\r\n\r\n\u003cb\u003eWhat version of the product are you using? On what operating system?\u003c/b\u003e\nTcl::pTk 0.85 with perl 5.14.2 on Windows 7 x64\r\n\r\n\u003cb\u003ePlease provide any additional information below.\u003c/b\u003e\nHi!\r\n\r\nThere is no Tcl::pTk::TFrame module on CPAN. This is one of the derived widgets in Perl/TK and I would like to have it for Tcl::pTk as well. \r\n\r\nI tried to write it on my own by looking at the other replacements for derived widgets, however I get an error with the DoWhenIdle method.\r\n\r\nDoWhenIdle seems to add an event to IDLE_EVENTS.\r\n\u0026quot;These are low-priority callbacks executed only after all events of the previous types have been processed. The most common idle events are those that redraw widgets and refresh the display. You can queue idle callbacks using DoWhenIdle.\u0026quot;\r\n\r\nAnd I don\u0027t know how to do this in Tcl::pTk.\r\n\r\nPlease find below my attempt:\r\n\r\n[code]\r\npackage Tcl::pTk::TFrame;\r\n\r\n###########################################################\r\n# Emulation of the perl/tk TFrame widget using Tcl::pTk\r\n###########################################################\r\n\r\nuse 5.014002;\r\nuse strict;\r\nuse warnings;\r\nuse Tcl::pTk (\u0027Ev\u0027);\r\nuse Carp;\r\n\r\nour $VERSION \u003d \u00270.01\u0027;\r\nour @ISA \u003d qw(Tcl::pTk::Derived Tcl::pTk::Frame);\r\n\r\nConstruct Tcl::pTk::Widget \u0027TFrame\u0027;\r\n\r\n\u003dhead1 NAME\r\n\r\nTcl::pTk::TFrame - Perl extension for blah blah blah\r\n\r\n\u003dhead1 SYNOPSIS\r\n\r\n use Tcl::pTk::TFrame;\r\n $frame1 \u003d $parent-\u0026gt;TFrame(\r\n \t-label \u003d\u0026gt; [ -text \u003d\u0026gt; \u0027Title\u0027 ],\r\n \t-borderwidth \u003d\u0026gt; 2,\r\n \t-relief \u003d\u0026gt; \u0027groove\u0027,\r\n );\r\n \r\n # or simply\r\n $frame2 \u003d $parent-\u0026gt;TFrame(\r\n\t-label \u003d\u0026gt; \u0027Title\u0027\r\n );\r\n \r\n $frame1-\u0026gt;pack;\r\n $frame2-\u0026gt;pack;\r\n\r\n\u003dhead1 DESCRIPTION\r\n\r\nTcl::pTk::TFrame provides a frame but with a title which overlaps the border by half of it\u0027s height.\r\n\r\n\u003dhead1 METHODS\r\n\r\n\u003dhead2 ClassInit($class, $mw)\r\n\r\n\u003dcut\r\n\r\nsub ClassInit {\r\n\tmy ($class,$mw) \u003d @_;\r\n\t\r\n\t$class-\u0026gt;SUPER::ClassInit($mw);\r\n\t\r\n\t$mw-\u0026gt;bind($class,\u0027\u0026lt;Configure\u0026gt;\u0027,[\u0027layoutRequest\u0027]);\r\n $mw-\u0026gt;bind($class,\u0027\u0026lt;FocusIn\u0026gt;\u0027, \u0027NoOp\u0027);\r\n return $class;\r\n} # /ClassInit\r\n\r\n\r\n\r\n\r\nsub Populate {\r\n my($self,$args) \u003d @_;\r\n $self-\u0026gt;SUPER::Populate($args);\r\n \r\n\t# Does not work: Can\u0027t set -highlightthickness to `0\u0027 for .ttkframe02: unknown option \u0026quot;-highlightthickness\u0026quot;\r\n #$self-\u0026gt;configure(-borderwidth \u003d\u0026gt; 0, -highlightthickness \u003d\u0026gt; 0);\r\n\r\n my $border \u003d $self-\u0026gt;Component(Frame \u003d\u0026gt; \u0026quot;border\u0026quot;);\r\n\r\n my @label \u003d (\r\n\t\t-padx\t\t\t\u003d\u0026gt; 4,\r\n\t\t-pady\t\t\t\u003d\u0026gt; 2,\r\n\t\t-borderwidth\t\u003d\u0026gt; 2,\r\n\t\t-relief\t\t\t\u003d\u0026gt; \u0027flat\u0027\r\n );\r\n\r\n if (exists $args-\u0026gt;{\u0027-label\u0027}) {\r\n\t\tif (not ref $args-\u0026gt;{\u0027-label\u0027}) {\r\n\t\t\t$args-\u0026gt;{\u0027-label\u0027} \u003d [ -text \u003d\u0026gt; $args-\u0026gt;{\u0027-label\u0027} ];\r\n\t\t}\r\n\t\tpush @label, @{$args-\u0026gt;{\u0027-label\u0027}};\r\n }\r\n\r\n my $label \u003d $self-\u0026gt;Component(Label \u003d\u0026gt; \u0026quot;label\u0026quot;, @label);\r\n\r\n my $container \u003d $self-\u0026gt;Component(Frame \u003d\u0026gt; \u0026quot;container\u0026quot;, -borderwidth \u003d\u0026gt; 0);\r\n\r\n\r\n $self-\u0026gt;DoWhenIdle([\u0027Manage\u0027,$self]);\r\n\r\n $self-\u0026gt;Default(\u0026quot;container\u0026quot; \u003d\u0026gt; $container);\r\n\r\n $self-\u0026gt;ConfigSpecs(\r\n\t\t-label \u003d\u0026gt; [ \u0027METHOD\u0027, undef, undef, undef],\r\n\t\t-relief \u003d\u0026gt; [$border,\u0027relief\u0027,\u0027Relief\u0027,\u0027groove\u0027],\r\n\t\t-borderwidth \u003d\u0026gt; [$border,\u0027borderwidth\u0027,\u0027Borderwidth\u0027,2],\r\n\t\t-ipadx \u003d\u0026gt; [PASSIVE \u003d\u0026gt; undef, undef, 0],\r\n\t\t-ipady \u003d\u0026gt; [PASSIVE \u003d\u0026gt; undef, undef, 0],\r\n );\r\n\r\n return $self;\r\n} # /Populate\r\n\r\n\r\n\r\n\r\nsub label {\r\n my $frame \u003d shift;\r\n my $v \u003d shift || [];\r\n my $l \u003d $frame-\u0026gt;Subwidget(\u0027label\u0027);\r\n\r\n $l-\u0026gt;configure(@$v);\r\n}\r\n\r\nsub layoutRequest {\r\n my($f) \u003d @_;\r\n $f-\u0026gt;DoWhenIdle([\u0027adjustLayout\u0027,$f]) unless $f-\u0026gt;{\u0027layout_pending\u0027};\r\n $f-\u0026gt;{\u0027layout_pending\u0027} \u003d 1;\r\n}\r\n\r\nsub SlaveGeometryRequest {\r\n my ($m,$s) \u003d @_;\r\n $m-\u0026gt;DoWhenIdle([\u0027_SlaveGeometryRequest\u0027,$m]) unless $m-\u0026gt;{\u0027geom_pending\u0027};\r\n $m-\u0026gt;{\u0027geom_pending\u0027} \u003d 1;\r\n}\r\n\r\nsub Manage {\r\n my $f \u003d shift;\r\n my $l \u003d $f-\u0026gt;Subwidget(\u0027label\u0027);\r\n my $c \u003d $f-\u0026gt;Subwidget(\u0027container\u0027);\r\n my $b \u003d $f-\u0026gt;Subwidget(\u0027border\u0027);\r\n\r\n $f-\u0026gt;ManageGeometry($l);\r\n $l-\u0026gt;MapWindow;\r\n $f-\u0026gt;ManageGeometry($c);\r\n $c-\u0026gt;MapWindow;\r\n $f-\u0026gt;ManageGeometry($b);\r\n $b-\u0026gt;MapWindow;\r\n SlaveGeometryRequest($f,$l);\r\n}\r\n\r\nsub _SlaveGeometryRequest {\r\n my $f \u003d shift;\r\n my $l \u003d $f-\u0026gt;Subwidget(\u0027label\u0027);\r\n my $c \u003d $f-\u0026gt;Subwidget(\u0027container\u0027);\r\n my $b \u003d $f-\u0026gt;Subwidget(\u0027border\u0027);\r\n\r\n $f-\u0026gt;{\u0027geom_pending\u0027} \u003d 0;\r\n\r\n my $px \u003d $f-\u0026gt;{Configure}{\u0027-ipadx\u0027} || 0;\r\n my $py \u003d $f-\u0026gt;{Configure}{\u0027-ipady\u0027} || 0;\r\n\r\n my $bw \u003d $b-\u0026gt;cget(\u0027-borderwidth\u0027)*2;\r\n my $w \u003d $c-\u0026gt;ReqWidth + $bw + $px*2;\r\n my $w2 \u003d $l-\u0026gt;ReqWidth + 20 + $bw;\r\n my $h \u003d $bw + $l-\u0026gt;ReqHeight + $c-\u0026gt;ReqHeight #+ $f-\u0026gt;cget(\u0027-borderwidth\u0027)*2\r\n\t\t+ $py*2;\r\n\r\n $f-\u0026gt;GeometryRequest($w \u0026gt; $w2 ? $w : $w2,$h);\r\n}\r\n\r\nsub adjustLayout {\r\n my $frame \u003d shift;\r\n my $label \u003d $frame-\u0026gt;Subwidget(\u0027label\u0027);\r\n my $container \u003d $frame-\u0026gt;Subwidget(\u0027container\u0027);\r\n my $border \u003d $frame-\u0026gt;Subwidget(\u0027border\u0027);\r\n\r\n $frame-\u0026gt;{\u0027layout_pending\u0027} \u003d 0;\r\n my $rh \u003d $label-\u0026gt;ReqHeight;\r\n\r\n my $px \u003d $frame-\u0026gt;{Configure}{\u0027-ipadx\u0027} || 0;\r\n my $bw \u003d $frame-\u0026gt;{Configure}{\u0027-borderwidth\u0027} || 0;\r\n my $py \u003d $frame-\u0026gt;{Configure}{\u0027-ipady\u0027} || 0;\r\n my $W \u003d $frame-\u0026gt;Width;\r\n my $H \u003d $frame-\u0026gt;Height;\r\n\r\n $border-\u0026gt;MoveResizeWindow(0,int($rh/2),$W,$H-int($rh/2));\r\n\r\n $container-\u0026gt;MoveResizeWindow(\r\n\t$px+$bw,$rh + $py, $W - (($px+$bw) * 2), $H - $rh -$bw - ($px * 2));\r\n\r\n $label-\u0026gt;MoveResizeWindow(10,0,$label-\u0026gt;ReqWidth,$label-\u0026gt;ReqHeight);\r\n}\r\n\r\nsub grid {\r\n my $w \u003d shift;\r\n $w \u003d $w-\u0026gt;Subwidget(\u0027container\u0027)\r\n\tif (@_ \u0026amp;\u0026amp; $_[0] \u003d~ /^(?: bbox\r\n\t\t\t\t|columnconfigure\r\n\t\t\t\t|location\r\n\t\t\t\t|propagate\r\n\t\t\t\t|rowconfigure\r\n\t\t\t\t|size\r\n\t\t\t\t|slaves)$/x);\r\n $w-\u0026gt;SUPER::grid(@_);\r\n}\r\n\r\nsub slave {\r\n my $w \u003d shift;\r\n $w-\u0026gt;Subwidget(\u0027container\u0027);\r\n}\r\n\r\nsub pack {\r\n my $w \u003d shift;\r\n $w \u003d $w-\u0026gt;Subwidget(\u0027container\u0027)\r\n\tif (@_ \u0026amp;\u0026amp; $_[0] \u003d~ /^(?:propagate|slaves)$/x);\r\n $w-\u0026gt;SUPER::pack(@_);\r\n}\r\n\r\n\r\n\r\n\r\n\u003dhead1 SEE ALSO\r\n\r\nL\u0026lt;Tk::TFrame\u0026gt;\r\n\r\n\u003dhead1 AUTHOR\r\n\r\nA. U. Thor, E\u0026lt;lt\u0026gt;a.u.thor@a.galaxy.far.far.awayE\u0026lt;gt\u0026gt;\r\n\r\n\u003dhead1 COPYRIGHT AND LICENSE\r\n\r\nCopyright (C) 2012 by A. U. Thor\r\n\r\nThis library is free software; you can redistribute it and/or modify\r\nit under the same terms as Perl itself, either Perl version 5.14.2 or,\r\nat your option, any later version of Perl 5 you may have available.\r\n\r\n\r\n\u003dcut\r\n\r\n1; # / Tcl::pTk::TFrame\r\n[/code]","timestamp":1355303877,"attachments":[]}]}