http://www.perlmonks.org?node_id=11118320

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 }

Replies are listed 'Best First'.
Re: Writing my first PERL/Tk megawidgit
by tybalt89 (Prior) on Jun 21, 2020 at 18:30 UTC

    And here's a ListBox2 with three subwidgets.

    #!/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...

      FIRST: here is the perl code/widget that I made which works:

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

        #!/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.

        I have the MEGAWIDGET displayed in my program. It is floating in the middle of a large text window -- called with 'DialogBox' and 'Show' . How do I get the data out of the Listbox (which is inside the MEGAWIDGET), so I can operate on it? This is my program-code -- as far as I have got:

        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 {
Re: Writing my first PERL/Tk megawidgit
by tybalt89 (Prior) on Jun 21, 2020 at 15:16 UTC
Re: Writing my first PERL/Tk megawidgit
by kcott (Bishop) on Jun 22, 2020 at 03: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"}'

    — Ken

Re: Writing my first PERL/Tk megawidgit (perltkintro)
by Anonymous Monk on Jun 21, 2020 at 14:59 UTC