Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
PerlMonks  

Writing my first PERL/Tk megawidgit

by Anonymous Monk
on Jun 21, 2020 at 18:23 UTC ( [id://11118320]=perlquestion: print w/replies, xml ) Need Help??

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 (Monsignor) on Jun 21, 2020 at 22: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 (Monsignor) on Jun 21, 2020 at 19:16 UTC
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"}'

    — Ken

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

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlquestion [id://11118320]
Front-paged by Corion
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others having a coffee break in the Monastery: (6)
As of 2024-03-28 09:55 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found