ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/rxvt-unicode/src/perl/selection
(Generate patch)

Comparing rxvt-unicode/src/perl/selection (file contents):
Revision 1.44 by root, Mon Nov 19 09:27:08 2007 UTC vs.
Revision 1.59 by sf-exg, Sat May 17 15:48:29 2014 UTC

1#! perl 1#! perl
2 2
3sub on_user_command { 3#:META:RESOURCE:%.pattern-0:string:first selection pattern
4 my ($self, $cmd) = @_;
5 4
6 $cmd eq "selection:rot13" 5=head1 NAME
6
7selection - more intelligent selection (enabled by default)
8
9=head1 DESCRIPTION
10
11This extension tries to be more intelligent when the user extends
12selections (double-click and further clicks). Right now, it tries to
13select words, urls and complete shell-quoted arguments, which is very
14convenient, too, if your F<ls> supports C<--quoting-style=shell>.
15
16A double-click usually selects the word under the cursor, further clicks
17will enlarge the selection.
18
19The selection works by trying to match a number of regexes and displaying
20them in increasing order of length. You can add your own regexes by
21specifying resources of the form:
22
23 URxvt.selection.pattern-0: perl-regex
24 URxvt.selection.pattern-1: perl-regex
25 ...
26
27The index number (0, 1...) must not have any holes, and each regex must
28contain at least one pair of capturing parentheses, which will be used for
29the match. For example, the following adds a regex that matches everything
30between two vertical bars:
31
32 URxvt.selection.pattern-0: \\|([^|]+)\\|
33
34Another example: Programs I use often output "absolute path: " at the
35beginning of a line when they process multiple files. The following
36pattern matches the filename (note, there is a single space at the very
37end):
38
39 URxvt.selection.pattern-0: ^(/[^:]+):\
40
41You can look at the source of the selection extension to see more
42interesting uses, such as parsing a line from beginning to end.
43
44This extension also offers following bindable keyboard commands:
45
46=over 4
47
48=item rot13
49
50Rot-13 the selection when activated. Used via keyboard trigger:
51
52 URxvt.keysym.C-M-r: perl:selection:rot13
53
54=back
55
56=cut
57
58sub on_action {
59 my ($self, $action) = @_;
60
61 $action eq "rot13"
7 and $self->selection (map { y/A-Za-z/N-ZA-Mn-za-m/; $_ } $self->selection); 62 and $self->selection (map { y/A-Za-z/N-ZA-Mn-za-m/; $_ } $self->selection);
8 63
9 () 64 ()
10} 65}
11 66
17 push @{ $self->{patterns} }, qr{\G [\Q$res\E[:space:]]* ([^\Q$res\E[:space:]]+) }x; 72 push @{ $self->{patterns} }, qr{\G [\Q$res\E[:space:]]* ([^\Q$res\E[:space:]]+) }x;
18 } 73 }
19 74
20 for (my $idx = 0; defined (my $res = $self->x_resource ("selection.pattern-$idx")); $idx++) { 75 for (my $idx = 0; defined (my $res = $self->x_resource ("selection.pattern-$idx")); $idx++) {
21 $res = $self->locale_decode ($res); 76 $res = $self->locale_decode ($res);
22 utf8::encode $res;
23 push @{ $self->{patterns} }, qr/$res/; 77 push @{ $self->{patterns} }, qr/$res/;
24 } 78 }
25 79
26 $self->{enabled} = 1; 80 $self->{enabled} = 1;
27 81
32 () 86 ()
33} 87}
34 88
35# "find interesting things"-patterns 89# "find interesting things"-patterns
36my @mark_patterns = ( 90my @mark_patterns = (
37 qr{ ([[:word:]]+) }x, 91# qr{ ([[:word:]]+) }x,
38 qr{ ([^[:space:]]+) }x, 92 qr{ ([^[:space:]]+) }x,
39 93
40 # common types of "parentheses" 94 # common types of "parentheses"
41 qr{ (?<![^[:space:]]) ` ([^‘’]+) ` (?![^[:space:]]) }x, 95 qr{ (?<![^[:space:]]) [`'] ([^`']+) [`'] (?![^[:space:]]) }x,
42 qr{ (?<![^[:space:]]) ‘ ([^‘’]+) ’ (?![^[:space:]]) }x, 96 qr{ (?<![^[:space:]]) ‘ ([^‘’]+) ’ (?![^[:space:]]) }x,
43 qr{ (?<![^[:space:]]) ` ([^`']+) ' (?![^[:space:]]) }x, 97 qr{ (?<![^[:space:]]) ([^“”]+) (?![^[:space:]]) }x,
44 98
45 qr{ (?<![^[:space:]]) ‘ ([^`']+) ’ (?![^[:space:]]) }x,
46 qr{ (?<![^[:space:]]) “ ([^`']+) ” (?![^[:space:]]) }x,
47
48 qr{ (?<![^[:space:]]) (' [^[:space:]] [^']* ') }x, 99 qr{ (?<![^[:space:]]) (' [^[:space:]] [^']* ') }x,
49 qr{ (' [^']* [^[:space:]] ') (?![^[:space:]]) }x, 100 qr{ (' [^']* [^[:space:]] ') (?![^[:space:]]) }x,
101 qr{ (?<![^[:space:]]) (` [^[:space:]] [^']* ') }x,
102 qr{ (` [^']* [^[:space:]] ') (?![^[:space:]]) }x,
50 qr{ (?<![^[:space:]]) (" [^[:space:]] [^"]* ") }x, 103 qr{ (?<![^[:space:]]) (" [^[:space:]] [^"]* ") }x,
51 qr{ (" [^"]* [^[:space:]] ") (?![^[:space:]]) }x, 104 qr{ (" [^"]* [^[:space:]] ") (?![^[:space:]]) }x,
52 105
53 qr{ \< ([^>]+) \> }x,
54 qr{ \( ([^)]+) \) }x,
55 qr{ \{ ([^}]+) \} }x, 106 qr{ \{ ([^\{\}]+) \} }x,
107 qr{ \( ([^\(\)]+) \) }x,
56 qr{ \[ ([^]]+) \] }x, 108 qr{ \[ ([^\[\]]+) \] }x,
109 qr{ \< ([^\<\>]+) \> }x,
57 110
58 # urls, just a heuristic 111 # urls, just a heuristic
59 qr{( 112 qr{(
60 (?:https?://|ftp://|news://|mailto:|file://|\bwww\.)[ab-zA-Z0-9\-\@;\/?:&=%\$_.+!*\x27(),~#]+ 113 (?:https?://|ftp://|news://|mailto:|file://|\bwww\.)[ab-zA-Z0-9\-\@;\/?:&=%\$_.+!*\x27(),~#]+
61 [ab-zA-Z0-9\-\@;\/?:&=%\$_+*()~] # exclude some trailing characters (heuristic) 114 [ab-zA-Z0-9\-\@;\/?:&=%\$_+*()~] # exclude some trailing characters (heuristic)
92 - $line->offset_of ($self->selection_beg); 145 - $line->offset_of ($self->selection_beg);
93 146
94 my @matches; 147 my @matches;
95 148
96 if ($markofs < $line->l) { 149 if ($markofs < $line->l) {
97 # convert markofs from character to UTF-8 offset space
98 {
99 my $prefix = substr $text, 0, $markofs;
100 utf8::encode $prefix;
101 $markofs = length $prefix;
102 }
103
104 # not doing matches in unicode mode helps speed
105 # enourmously here. working in utf-8 should be
106 # equivalent due to the magic of utf-8 encoding.
107 utf8::encode $text;
108 study $text; # _really_ helps, too :) 150 study $text; # _really_ helps, too :)
109 151
110 for my $regex (@mark_patterns, @{ $self->{patterns} }) { 152 for my $regex (@mark_patterns, @{ $self->{patterns} }) {
111 while ($text =~ /$regex/g) { 153 while ($text =~ /$regex/g) {
112 if ($-[1] <= $markofs and $markofs <= $+[1]) { 154 if ($-[1] <= $markofs and $markofs <= $+[1]) {
132 for (sort { $a->[1] <=> $b->[1] or $b->[0] <=> $a->[0] } @matches) { 174 for (sort { $a->[1] <=> $b->[1] or $b->[0] <=> $a->[0] } @matches) {
133 my ($ofs, $len) = @$_; 175 my ($ofs, $len) = @$_;
134 176
135 next if $len <= $curlen; 177 next if $len <= $curlen;
136 178
137 # convert back from UTF-8 offset space to character space
138 {
139 my $length = substr "$text ", $ofs, $len;
140 utf8::decode $length;
141 $len = length $length;
142 }
143 {
144 my $prefix = substr $text, 0, $ofs;
145 utf8::decode $prefix;
146 $ofs = length $prefix;
147 }
148
149 $self->selection_beg ($line->coord_of ($ofs)); 179 $self->selection_beg ($line->coord_of ($ofs));
150 $self->selection_end ($line->coord_of ($ofs + $len)); 180 $self->selection_end ($line->coord_of ($ofs + $len));
151 return 1; 181 return 1;
152 } 182 }
153 183

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines