blob: e52815e295ccbe9ecaeba6dcfd967056fed83fd1 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
|
#!/usr/bin/env perl
# Stripped down and tidied version of original URxvt "selection" script that
# just observes cutchars in a locale-aware fashion.
use strict;
use warnings;
use utf8;
use 5.006;
use Carp;
use English qw(-no_match_vars);
our $VERSION = 1.0;
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;
}
$self->{enabled} = 1;
return ();
}
sub on_sel_extend {
my ($self) = @_;
$self->{enabled}
or return ();
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 );
my @matches;
if ( $markofs < $line->l ) {
study $text; # _really_ helps, too :)
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 ];
}
}
}
}
# whole line
push @matches, [ 0, ( $line->end - $line->beg + 1 ) * $self->ncol ];
for ( sort { $a->[1] <=> $b->[1] or $b->[0] <=> $a->[0] } @matches )
{ ## no critic (ProhibitReverseSortBlock)
my ( $ofs, $len ) = @{$_};
next if $len <= $curlen;
$self->selection_beg( $line->coord_of($ofs) );
$self->selection_end( $line->coord_of( $ofs + $len ) );
return 1;
}
return ();
}
|