Anonymous Monk has asked for the wisdom of the Perl Monks concerning the following question:
This is my first attempt at writing a megawidgit in PERL. I have not been programming for 10yrs. I cant find any concise examples showing what must be in the module, and where the perl subroutines must go. Here is my code.
It runs -- but it only hangs. I assume the widget is not being displayed, and its waiting for to choose something...
package Tk::ListBox;
unshift (@INC , "/usr/pkg/lib/perl5/site_perl/5.30.0/x86_64-netbsd
+-thread-multi/Tk");
unshift (@INC , "/usr/pkg/lib/perl5/vendor_perl/5.30.0/Cache/Memca
+ched");
unshift (@INC , "/usr/pkg/lib/perl5/site_perl/5.30.0/Cache");
# Declare base class.
use base qw/ Tk::Frame /; # Frame-based composite
use Tk::Widget; # or
use base qw/ Tk::Toplevel /; # Toplevel-based composite
# or (Not a TopLevel wid
+get)
# use base qw/ Tk::Scrolled /;
# use base qw/ Tk::Listbox /;
use Tk::Listbox;
use Tk::Button;
use Tk::Entry;
# use base qw/ Tk::Derived Tk::SomeWidget /; # derived from SomeWid
+get
# ## If it is a "composite widget", then its not "deri
+ved"
Construct Tk::Widget 'ListBox2'; # install MyNewWidget in pTk name
+space
sub ClassInit
{ # called once to initialize new class
my($class, $mw) = @_;
$class->SUPER::ClassInit($mw);
}
sub Populate { # called to build each widget instanc
+e
my($self, $args) = @_;
$self->SUPER::Populate($args);
my $o = $self -> ListBox2 -> pack();
$self->Advertise( 'listbox' => $o ); # advertise subwid
+gets
$self->Callback(); # invoke -command callbacks
$self->Component(); # define a subwidget component
$self->ConfigSpecs(); # define cget() / configure() options
$self->Delegates(); # how methods are delegated to subwid
+gets
$self->Subwidget(); # map a subwidget name to subwidget r
+eference
}
Re: Writing my first PERL/Tk megawidgit
by tybalt89 (Monsignor) on Jun 21, 2020 at 22:30 UTC
|
#!/usr/bin/perl
use strict; # https://perlmonks.org/?node_id=11118320
use warnings;
use Tk;
{ # for package
package Tk::ListBox2;
use base qw/ Tk::Frame /; # Frame-based composite
Construct Tk::Widget 'ListBox2'; # install MyNewWidget in pTk namespac
+e
sub ClassInit # called once to initialize new class
{
my($class, $mw) = @_;
$class->SUPER::ClassInit($mw);
}
sub Populate # called to build each widget instance
{
my($self, $args) = @_;
$self->SUPER::Populate($args);
my $outer = $self->Frame()->pack(-fill=> 'both', -expand=> 1);
$outer->Label(-text => 'A ListBox2', -fg => 'blue')->pack;
my $inner = $outer->Listbox()->pack(-fill=> 'both', -expand=> 1);
$outer->Label(-text => 'End of ListBox2', -fg => 'blue')->pack;
$self->ConfigSpecs( DEFAULT => [$inner] );
$self->Delegates(
Construct => $inner,
insert => $inner,
);
}
} # end package
my $mw = MainWindow->new;
my $lb = $mw->ListBox2()->pack(-fill => 'both', -expand => 1);
$lb->insert( 'end', 1 .. 10 );
MainLoop;
since I wasn't sure exactly what you were trying to do...
| [reply] [Watch: Dir/Any] [d/l] |
|
#! /usr/pkg/bin/perl
use warnings;
# use diagnostics;
use Tk;
use Tk::Entry;
unshift (@INC , "/usr/pkg/lib/perl5/site_perl/5.30.0/x86_64-netbsd
+-thread-multi/Tk");
unshift (@INC , "/usr/pkg/lib/perl5/vendor_perl/5.30.0/Cache/Memca
+ched");
unshift (@INC , "/usr/pkg/lib/perl5/site_perl/5.30.0/Cache");
$mw = MainWindow -> new();
$mw -> title ("Listbox");
@choices = qw /alpha beta charlie delta echo foxtrot hotel india juli
+et kilo lima motel nancy oscar papa quebec radio sierra tango uniform
+ victor whiskey xray yankee zulu oin gloin beorn gandalf elrond eowyn
+/;
$header_msg = "ENTER a KEY name: ";
my ($search , $oldsearch);
##--------------------------------------------------------------------
+------------##
&listbox1 (@choices , $header_msg ); ##WORKS!! Make sure the $msg is
+ last element
##--------------------------------------------------------------------
+------------##
MainLoop;
sub listbox1
{
my(@choices , $header_msg );
$header_msg = pop (@_) ;
@choices = @_ ;
my $dialog = $mw -> Label (-text => $header_msg ) -> pack( -side =
+> "top" );
$dialog = $mw -> Entry (-textvariable => \$search,
+
) -> pack (
-side => "top" ,
-fill => "x"
);
$dialog -> bind ( "<KeyPress>" , [\&do_search , Ev ("K" )] );
# $mw = $dialog -> Show(); #HMMMMMM... WORKED; so Show() is unnee
+ded?
##############
$lb = $mw -> Scrolled ("Listbox" , -scrollbars => "se" ,
-height => 20 ,
-selectforeground => 'orange'
+,
-selectbackground => 'steelbl
+ue4' ,
) -> pack(-side => "top") ;
$lb -> insert ( "end" , sort @choices );
### MAKE '@choices' the list of $keys
my $f = $mw -> Frame( ) -> pack(-side => 'bottom' , -fill => "x"
+ ) ;
$f -> Button ( -text => "QUIT" ,
-background => 'red',
# -relief => 'sunken'
-command => sub { ( $mw -> destroy() ) if Tk::E
+xists( $mw ); }
) -> pack (-side => 'bottom' , -fill => "x" );
$lb -> bind( '<Double-1>' , \&get_choice );
} ## CLOSE listbox1()
##################
sub get_choice
{
my $mychoice = $lb -> get( 'active');
print "\$mychoice = : $mychoice\n\n ";
}
sub do_search
{
my ($entry , $key) = @_;
return if ( $key =~ /backspace/ );
return if ( $oldsearch eq $search );
my @list = $lb -> get(0 , "end");
foreach ( 0 .. $#list )
{
if ($list [$_] =~ /^$search/ )
{
$lb -> see($_);
$lb -> selectionClear( 0 , "end" );
$lb -> selectionSet ($_);
last;
}
}
$oldsearch = $search;
} ## CLOSE do_search()
WHAT I like about it is it sticks the vars in a listbox with a slider.
It also searches. Type in the first letter(s) and it takes you to the matching string.
I can see uses elsewhere for such a thing. In this case it is for choosing hash-keys so I can
delete Cache::Cache entries/elements
I am curious: Why isnt there a megawidget repository somewhere?
| [reply] [Watch: Dir/Any] [d/l] |
|
#!/usr/bin/perl
use strict; # https://perlmonks.org/?node_id=11118320
use warnings;
use Tk;
{ # for package
package Tk::ListBox3;
use List::Util qw( first );
use base qw/ Tk::Frame /; # Frame-based composite
Construct Tk::Widget 'ListBox3'; # install MyNewWidget in pTk namespac
+e
sub ClassInit # called once to initialize new class
{
my($class, $mw) = @_;
$class->SUPER::ClassInit($mw);
}
sub Populate # called to build each widget instance
{
my($self, $args) = @_;
$self->SUPER::Populate($args);
my $search = '';
my $frame = $self->Frame(
-borderwidth => 5, -relief => 'ridge',
)->pack(-fill=> 'both', -expand=> 1);
my $label = $frame->Label( -fg => 'blue', -font => 30,
)->pack(-fill => 'x');
my $lbox = $frame->Scrolled(Listbox => -scrollbars => 'se',
-height => 20,
-selectforeground => 'orange',
-selectbackground => 'steelblue4',
-exportselection => 0,
)->pack(-side => 'bottom', -fill => 'both', -expand=> 1);
my $entry = $frame->Entry(-textvariable => \$search,
-validate => 'key', -validatecommand => sub
{
my ($want) = @_;
length $want or return 1;
my @list = $lbox->get(0 , "end");
my $item = first { $list[$_] =~ /^\Q$want\E/ } 0 .. $#list;
defined $item or return 0;
$lbox->selectionClear( 0 , "end" );
$lbox->selectionSet($item);
$lbox->see($item);
1 # to allow
},
)->pack(-fill => 'x');
$self->ConfigSpecs( DEFAULT => [$lbox], text => [$label] );
$self->Delegates( Construct => $lbox, insert => $lbox );
}
} # end package
my @choices = sort qw /alpha beta charlie delta echo foxtrot hotel ind
+ia juliet
kilo lima motel nancy oscar papa quebec radio sierra tango uniform v
+ictor
whiskey xray yankee zulu oin gloin beorn gandalf elr ond eowyn/;
my $header_msg = "ENTER a KEY name: ";
my $mw = MainWindow->new;
$mw->geometry( '+900+250' );
$mw->title( 'Listbox' );
my $lb = $mw->ListBox3( -text => $header_msg,
)->pack(-fill => 'both', -expand => 1, -side => 'left');
$lb->insert( 'end', @choices );
my $lb2 = $mw->ListBox3( -text => $header_msg,
)->pack(-fill => 'both', -expand => 1, -side => 'left');
$lb2->insert( 'end', @choices );
MainLoop;
Demos two of them to show no interference.
| [reply] [Watch: Dir/Any] [d/l] |
|
|
my $header_msg = "Get what fr
+om MemCache?" ;
******** BEGIN DialogBox ******** my $dialog = $top -> DialogBo
+x (
+ -title => ' ',
+ -buttons => []
+ );
my $lb = $dialog -> ListBox3(
+ -text => $header_msg,
)
+ -> pack(-side => 'top' );
+
$lb -> insert( 'end' ,
+ @cache_list );
$dialog -> Button (
-t
+ext => "Abort" ,
-b
+g => 'red' ,
-c
+ommand => sub { ( $dialog -> destroy() ) if Tk::Exists( $dialog ) ; }
)->
+pack ( -side => 'bottom' , -fill => 'x' );
$lb -> bind ( '<Doubl
+e-3>' , sub {
+ my $mychoice = $lb -> get( 'active');
+ print "\$mychoice = : $mychoice\n\n ";
+ }
);
******** SHOW 'DialogBox ******** $top = $dialog -> Show
+();
+
# $lb -> bind('<Double-
+3>' , \&get_choice);
$lb -> bind ( '<Doubl
+e-3>' , sub {
| [reply] [Watch: Dir/Any] [d/l] |
|
|
|
Re: Writing my first PERL/Tk megawidgit
by tybalt89 (Monsignor) on Jun 21, 2020 at 19:16 UTC
|
| [reply] [Watch: Dir/Any] |
Re: Writing my first PERL/Tk megawidgit
by kcott (Archbishop) on Jun 22, 2020 at 07:34 UTC
|
"I cant find any concise examples showing what must be in the module, and where the perl subroutines must go."
Run the "Perl/Tk Widget Demonstration".
In case you don't know, that's just widget from the command line;
I usually run it in the background to free up the console (i.e. widget &).
Near the bottom, you'll find "Sample Perl Mega-Widgets".
Also see the Tk documentation.
The "Derived Widgets" section would be a good place to start.
In addition to those published sources of information, you can look at source code on your own computer.
You can find the location of the modules by querying %INC.
Here's how you'd find Tk.pm itself:
$ perl -E 'use Tk; say $INC{"Tk.pm"}'
For the mega-widget Tk::Balloon:
$ perl -E 'use Tk::Balloon; say $INC{"Tk/Balloon.pm"}'
| [reply] [Watch: Dir/Any] [d/l] [select] |
Re: Writing my first PERL/Tk megawidgit (perltkintro)
by Anonymous Monk on Jun 21, 2020 at 18:59 UTC
|
package Tk::ListBox;
unshift (@INC ,
Manipulating @INC is for .pl files (use lib '/mylibs';) and not for megawidgets
Tk::ListBox name is already taken ;)
The best way to create a megawidget? First start by creating a regular Tk program , convert into megawidget later ;)
http://web.archive.org/web/20050207003229/http://www.perltk.org/articles/Custom_Widgets.htm, Re^5: pp with gui (tk tutorial links) | [reply] [Watch: Dir/Any] [d/l] [select] |
|
|