blob: 90b13960843bfc1aef848386554ffa5639a92487 (
plain) (
tree)
|
|
# Tom Ryder's choice of selection behaviours for urxvt, butchered from included
# URxvt extension scripts.
# Force me to write this properly
use strict;
use warnings;
use utf8;
# Require at least this version of Perl
use 5.006;
# Use plain-English variable names
use English qw(-no_match_vars);
# Set version of this extension
our $VERSION = 1.0;
# On creation, read all of cutchars into a list of regex-quoted patterns
sub on_init {
my ($self) = @_;
if ( defined( my $res = $self->resource('cutchars') ) ) {
$res = $self->locale_decode($res);
push @{ $self->{patterns} },
qr{\G [\Q$res\E[:space:]]* ([^\Q$res\E[:space:]]+) }msx;
}
return ();
}
# Handle multiple-clicking selection extension
sub on_sel_extend {
my ($self) = @_;
# Get attributes of the current selection
my ( $row, $col ) = $self->selection_mark;
my $line = $self->line($row);
my $text = $line->t;
my $markofs = $line->offset_of( $row, $col );
my $curlen =
$line->offset_of( $self->selection_end ) -
$line->offset_of( $self->selection_beg );
# Find all the possible matches
my @matches;
if ( $markofs < $line->l ) {
# `perldoc -f study` says this does nothing useful anymore since
# version 5.16
study $text;
for my $regex ( @{ $self->{patterns} } ) {
while ( $text =~ m{$regex}gmsx ) {
if ( $LAST_MATCH_START[1] <= $markofs
and $markofs <= $LAST_MATCH_END[1] )
{
my $ofs = $LAST_MATCH_START[1];
my $match = $1;
push @matches, [ $ofs, length $match ];
}
}
}
}
# If no more clever patterns matched, just snarf the whole line
push @matches, [ 0, ( $line->end - $line->beg + 1 ) * $self->ncol ];
# Iterate over the matches to choose the shortest one
MATCH:
for (
sort { ## no critic (ProhibitReverseSortBlock)
$a->[1] <=> $b->[1]
or $b->[0] <=> $a->[0]
} @matches
)
{
my ( $ofs, $len ) = @{$_};
next MATCH if $len <= $curlen;
$self->selection_beg( $line->coord_of($ofs) );
$self->selection_end( $line->coord_of( $ofs + $len ) );
return 1;
}
# Done
return ();
}
# Copy selections to CLIPBOARD as well as PRIMARY.
sub on_sel_grab {
my ( $self, $time ) = @_;
$self->selection( $self->selection, 1 );
$self->selection_grab( $time, 1 );
return ();
}
|