Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change
 
PerlMonks  

Perl/Tk Tk::Text <<Selection>> event

by converter (Priest)
on Apr 28, 2003 at 05:50 UTC ( #253596=snippet: print w/ replies, xml ) Need Help??

Description:

I am working on a Perl/Tk application in which I need to display information about the current Tk::Text selection in a status area. Tk::Text doesn't generate a "Selection" event, the override methods in this code generate a virtual Selection event.

The code demonstrates one way to use the <<Selection>> event.

#!/usr/bin/perl

=for comment

The Tk::_Extended_Text package provides
methods that override all of the Tk::Text
methods that change the selection in the
Tk::Text widget, adding a call to
eventGenerate() to generate a
virtual <<Selection>> event.

Bind a callback to the <<Selection>> event
and it will be called any time the
selection changes (including when the
selection is removed).

This code will also work with Tk::ROText,
since Tk::ROText is a subclass of Tk::Text.
Simply replace all references to Tk::Text
with Tk::ROText.

=cut

use warnings;
use strict;

use Tk;
use Tk::widgets qw(
    Frame
    Text
    Label
);

{
    package Tk::_Extended_Text;
    
    @Tk::_Extended_Text::ISA = 'Tk::Text';

    Tk::Widget->Construct('_Extended_Text');
    
    my $i = 0;
    
    my @lastranges;
    
    # subroutine: &selectionChanged
    # 
    # argument:   LIST of 'sel' tag ranges
    # 
    # Return TRUE if the ROText selection
    # has changed.
    #
    # Several of the Tk::Text methods generate
    # a lot of noise even when there's no
    # change to the selection, use
    # &selectionChanged to discover if the
    # selection has actually been modified.
    #
    # Call &selectionChanged with the current
    # 'sel' tag range, if the return value is
    # TRUE, the selection was changed,
    # otherwise no change.
    
    sub selectionChanged {
        my @ranges = @_;

        if (@ranges != @lastranges) {
            return 1;
        }

        # each array has same number of elements
        for (my $i = 0; $i < @ranges; $i++) {
            if ($ranges[$i] ne $lastranges[$i]) {
                return 1;
            }
        }
        
        return;
    }


    # override Tk::Text methods:
    # -----------------------------------------------
    # These overrides are simple wrappers that
    # provide a hook for generation of the
    # <<Selection>> event.
    
    sub selectAll {
        my $w = shift;
        $w->SUPER::selectAll(@_);
        $w->eventGenerate('<<Selection>>');
        @lastranges = $w->tagRanges('sel');
        return;
    }

    
    sub unselectAll {
        my $w = shift;
        $w->SUPER::unselectAll(@_);
        if (selectionChanged($w->tagRanges('sel'))) {
            $w->eventGenerate('<<Selection>>');
        }
        @lastranges = $w->tagRanges('sel');
        return;
    }

    
    sub SelectTo {
        my $w = shift;
        $w->SUPER::SelectTo(@_);
        if (selectionChanged($w->tagRanges('sel'))) {
            $w->eventGenerate('<<Selection>>');
        }
        @lastranges = $w->tagRanges('sel');
        return;
    }

    
    sub KeySelect {
        my $w = shift;
        $w->SUPER::KeySelect(@_);
        $w->eventGenerate('<<Selection>>');
        @lastranges = $w->tagRanges('sel');
        return;
    }


    sub FindAll {
        my $w = shift;
        $w->SUPER::FindAll(@_);
        if (selectionChanged($w->tagRanges('sel'))) {
            $w->eventGenerate('<<Selection>>');
        }
        @lastranges = $w->tagRanges('sel');
        return;
     }


    sub FindNext {
        my $w = shift;
        $w->SUPER::FindNext(@_);
        if (selectionChanged($w->tagRanges('sel'))) {
            $w->eventGenerate('<<Selection>>');
        }
        @lastranges = $w->tagRanges('sel');
        return;
     }
}


my $mw = MainWindow->new;

my $statbar = $mw->Frame(
    -relief => 'sunken',
)->pack(
    -fill   => 'x',
    -side   => 'bottom',
);

my $selview = $statbar->Label->pack;


##
### allocate an extended Tk::Text widget object:
##
my $t = $mw->_Extended_Text->pack;


my $i = 0;

$t->bind(
    '<<Selection>>',
    sub {
        print "<<Selection>> event $i\n";
        $i++;
        my @r = $t->tagRanges('sel');
        if (@r) {
            my $len = length $t->get(@r);
            $selview->configure(-text => "begin $r[0]  :  end $r[1]  :
+  length $len");
        }
        else {
            $selview->configure(-text => 'no selection');
        }
    },
);

$mw->bind('<Control-q>', sub { $mw->destroy });

$selview->configure(-text => 'Ctrl-q to exit.');

$mw->after(
    2500,
    sub {
        $selview->configure(
            -text => 'Select text with mouse or keyboard.',
        );
    },
);

$t->insert('end', "testing\ntesting\n1-2-3 testing");
$t->focus;

MainLoop;
Comment on Perl/Tk Tk::Text <<Selection>> event
Download Code
Re: Perl/Tk Tk::Text <<Selection>> event
by converter (Priest) on May 01, 2003 at 01:54 UTC

    After further testing I've discovered that my code misses the "event" that occurs when another application claims the selection. The only remedy I've found for this is to set the -exportselection attribute FALSE for Text, Entry and other widgets.

Re: Perl/Tk Tk::Text <<Selection>> event
by grizzley (Chaplain) on Apr 18, 2008 at 11:25 UTC

    Great! ++ for unique example of working with selections. I spent half a day searching on Google and it seemed that such example doesn't exist...

Back to Snippets Section

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: snippet [id://253596]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others taking refuge in the Monastery: (6)
As of 2014-12-28 02:11 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    Is guessing a good strategy for surviving in the IT business?





    Results (177 votes), past polls