http://qs321.pair.com?node_id=11118744


in reply to Re: Writing my first PERL/Tk megawidgit
in thread Writing my first PERL/Tk megawidgit

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()

[download]

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?

Replies are listed 'Best First'.
Re^3: Writing my first PERL/Tk megawidgit
by tybalt89 (Monsignor) on Jul 01, 2020 at 16:25 UTC 
    #!/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;

    [download]

    Demos two of them to show no interference.

[reply]
[d/l]

      Hey -- thanks. The stuff after " } # end package " made a lot of sense to me, since it is straight pTk code. You forgot the button on the bottom. BUT at this point I understand the code enough to do it myself. Whats the best way to deal with the "sub ClassInit" and "sub Populate" magic?

[reply]
Re^3: Writing my first PERL/Tk megawidgit
by Anonymous Monk on Jul 03, 2020 at 14:36 UTC

    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 {

    [download]
[reply]
[d/l]
      #!/usr/bin/perl

use strict; # https://perlmonks.org/?node_id=11118320
use warnings;
use Tk;

{ # start 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 Populate                # called to build each widget instance
  {
  my($self, $args) = @_;
  $self->SUPER::Populate($args);

  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);
  $frame->Entry(
    -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, get => $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 $selection;

my $mw = MainWindow->new;
$mw->geometry( '+900+250' );
$mw->title( 'Listbox' );

my $lb = $mw->ListBox3( -text => $header_msg,
  )->pack(-fill => 'both', -expand => 1,);
$lb->insert( 'end', @choices );

$mw->Button(-text => 'QUIT', -bg => 'red', -command => sub {
  $selection = $lb->get('active');
  $mw->destroy
  },
  )->pack(-fill => 'x');

MainLoop;

defined $selection and print "'$selection' was selected\n";

      [download]
[reply]
[d/l]

        Oops, active is different from curselection 

        #!/usr/bin/perl

use strict; # https://perlmonks.org/?node_id=11118320
use warnings;
use Tk;

{ # start 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 Populate                # called to build each widget instance
  {
  my($self, $args) = @_;
  $self->SUPER::Populate($args);

  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);
  $frame->Entry(
    -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,
    get => $lbox, curselection => $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 $selection;

my $mw = MainWindow->new;
$mw->geometry( '+900+250' );
$mw->title( 'Listbox' );

my $lb = $mw->ListBox3( -text => $header_msg,
  )->pack(-fill => 'both', -expand => 1,);
$lb->insert( 'end', @choices );

$mw->Button(-text => 'QUIT', -bg => 'red', -command => sub {
  $selection = $lb->get($lb->curselection);
  $mw->destroy
  },
  )->pack(-fill => 'x');

MainLoop;

defined $selection and print "'$selection' was selected\n";

        [download]
[reply]
[d/l]

In Section Seekers of Perl Wisdom