[ViewVC] Annotation of: cvs/rxvt-unicode/src/perl/selection

#! perl

#:META:RESOURCE:%.pattern-0:string:first selection pattern

=head1 NAME

selection - more intelligent selection (enabled by default)

=head1 DESCRIPTION

This extension tries to be more intelligent when the user extends
selections (double-click and further clicks). Right now, it tries to
select words, urls and complete shell-quoted arguments, which is very
convenient, too, if your F<ls> supports C<--quoting-style=shell>.

A double-click usually selects the word under the cursor, further clicks
will enlarge the selection.

The selection works by trying to match a number of regexes and displaying
them in increasing order of length. You can add your own regexes by
specifying resources of the form:

   URxvt.selection.pattern-0: perl-regex
   URxvt.selection.pattern-1: perl-regex
   ...

The index number (0, 1...) must not have any holes, and each regex must
contain at least one pair of capturing parentheses, which will be used for
the match. For example, the following adds a regex that matches everything
between two vertical bars:

   URxvt.selection.pattern-0: \\|([^|]+)\\|

Another example: Programs I use often output "absolute path: " at the
beginning of a line when they process multiple files. The following
pattern matches the filename (note, there is a single space at the very
end):

   URxvt.selection.pattern-0: ^(/[^:]+):\ 

You can look at the source of the selection extension to see more
interesting uses, such as parsing a line from beginning to end.

This extension also offers the following actions:

=over 4

=item rot13

Rot-13 the selection when activated.

Example:

   URxvt.keysym.C-M-r: selection:rot13

=back

=cut

sub on_action {
   my ($self, $action) = @_;

   $action eq "rot13"
      and $self->selection (map { y/A-Za-z/N-ZA-Mn-za-m/; $_ } $self->selection);

   ()
}

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:]]+) }x;
   }

   for (my $idx = 0; defined (my $res = $self->x_resource ("selection.pattern-$idx")); $idx++) {
      $res = $self->locale_decode ($res);
      push @{ $self->{patterns} }, qr/$res/;
   }

   $self->{enabled} = 1;

   push @{ $self->{term}{option_popup_hook} }, sub {
      ("new selection" => $self->{enabled}, sub { $self->{enabled} = shift })
   };

   ()
}

# "find interesting things"-patterns
my @mark_patterns = (
#   qr{ ([[:word:]]+) }x,
   qr{ ([^[:space:]]+) }x,

   # common types of "parentheses"
   qr{ (?<![^[:space:]])  [`'] ([^`']+)  [`'] (?![^[:space:]]) }x,
   qr{ (?<![^[:space:]])  ‘ ([^‘’]+)  ’ (?![^[:space:]]) }x,
   qr{ (?<![^[:space:]])  “ ([^“”]+)  ” (?![^[:space:]]) }x,

   qr{ (?<![^[:space:]]) (' [^[:space:]] [^']* ')                  }x,
   qr{                   (' [^']* [^[:space:]] ') (?![^[:space:]]) }x,
   qr{ (?<![^[:space:]]) (` [^[:space:]] [^']* ')                  }x,
   qr{                   (` [^']* [^[:space:]] ') (?![^[:space:]]) }x,
   qr{ (?<![^[:space:]]) (" [^[:space:]] [^"]* ")                  }x,
   qr{                   (" [^"]* [^[:space:]] ") (?![^[:space:]]) }x,

   qr{ \{ ([^\{\}]+) \} }x,
   qr{ \( ([^\(\)]+) \) }x,
   qr{ \[ ([^\[\]]+) \] }x,
   qr{ \< ([^\<\>]+) \> }x,

   # urls, just a heuristic
   qr{(
      (?:https?://|ftp://|news://|mailto:|file://|\bwww\.)[ab-zA-Z0-9\-\@;\/?:&=%\$_.+!*\x27(),~#]+
      [ab-zA-Z0-9\-\@;\/?:&=%\$_+*()~]   # exclude some trailing characters (heuristic)
   )}x,

   # shell-like argument quoting, basically always matches
   qr{\G [\ \t|&;<>()]* (
      (?:
         [^\\"'\ \t|&;<>()]+
         | \\.
         | " (?: [^\\"]+ | \\. )* "
         | ' [^']* '
      )+
   )}x,
);

# "correct obvious? crap"-patterns
my @simplify_patterns = (
   qr{^"([^\\"'\ \t|&;<>()*?]+)"$}, # "simple" => simple
   qr{^(.*)[,\-]$},                 # strip off trailing , and -
);

sub on_sel_extend {
   my ($self, $time) = @_;

   $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 (@mark_patterns, @{ $self->{patterns} }) {
         while ($text =~ /$regex/g) {
            if ($-[1] <= $markofs and $markofs <= $+[1]) {
               my $ofs = $-[1];
               my $match = $1;

               for my $regex (@simplify_patterns) {
                  if ($match =~ $regex) {
                     $match = $1;
                     $ofs += $-[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) {
      my ($ofs, $len) = @$_;

      next if $len <= $curlen;

      $self->selection_beg ($line->coord_of ($ofs));
      $self->selection_end ($line->coord_of ($ofs + $len));
      return 1;
   }

   ()
}
Revision:	1.60
Committed:	Sat May 31 08:33:47 2014 UTC (9 years, 11 months ago) by sf-exg
Branch:	MAIN
Changes since 1.59:	+5 -3 lines
Log Message:	Doc fixes.
#	User	Rev	Content
1	root	1.4	#! perl
2
3	root	1.58	#:META:RESOURCE:%.pattern-0:string:first selection pattern
4	root	1.54
5	root	1.55	=head1 NAME
6
7	root	1.56	selection - more intelligent selection (enabled by default)
8	root	1.55
9			=head1 DESCRIPTION
10
11			This extension tries to be more intelligent when the user extends
12			selections (double-click and further clicks). Right now, it tries to
13			select words, urls and complete shell-quoted arguments, which is very
14			convenient, too, if your F<ls> supports C<--quoting-style=shell>.
15
16			A double-click usually selects the word under the cursor, further clicks
17			will enlarge the selection.
18
19			The selection works by trying to match a number of regexes and displaying
20			them in increasing order of length. You can add your own regexes by
21			specifying resources of the form:
22
23			URxvt.selection.pattern-0: perl-regex
24			URxvt.selection.pattern-1: perl-regex
25			...
26
27			The index number (0, 1...) must not have any holes, and each regex must
28			contain at least one pair of capturing parentheses, which will be used for
29			the match. For example, the following adds a regex that matches everything
30			between two vertical bars:
31
32			URxvt.selection.pattern-0: \\\|([^\|]+)\\\|
33
34			Another example: Programs I use often output "absolute path: " at the
35			beginning of a line when they process multiple files. The following
36			pattern matches the filename (note, there is a single space at the very
37			end):
38
39			URxvt.selection.pattern-0: ^(/[^:]+):\
40
41			You can look at the source of the selection extension to see more
42			interesting uses, such as parsing a line from beginning to end.
43
44	sf-exg	1.60	This extension also offers the following actions:
45	root	1.55
46			=over 4
47
48			=item rot13
49
50	sf-exg	1.60	Rot-13 the selection when activated.
51	root	1.55
52	sf-exg	1.60	Example:
53
54			URxvt.keysym.C-M-r: selection:rot13
55	root	1.55
56			=back
57
58			=cut
59
60	sf-exg	1.59	sub on_action {
61			my ($self, $action) = @_;
62	elmex	1.2
63	sf-exg	1.59	$action eq "rot13"
64	root	1.7	and $self->selection (map { y/A-Za-z/N-ZA-Mn-za-m/; $_ } $self->selection);
65	elmex	1.3
66			()
67	elmex	1.1	}
68	root	1.5
69	root	1.23	sub on_init {
70			my ($self) = @_;
71
72	root	1.35	if (defined (my $res = $self->resource ("cutchars"))) {
73			$res = $self->locale_decode ($res);
74			push @{ $self->{patterns} }, qr{\G [\Q$res\E[:space:]]* ([^\Q$res\E[:space:]]+) }x;
75			}
76
77	root	1.23	for (my $idx = 0; defined (my $res = $self->x_resource ("selection.pattern-$idx")); $idx++) {
78	root	1.31	$res = $self->locale_decode ($res);
79	root	1.23	push @{ $self->{patterns} }, qr/$res/;
80			}
81
82	root	1.37	$self->{enabled} = 1;
83
84			push @{ $self->{term}{option_popup_hook} }, sub {
85			("new selection" => $self->{enabled}, sub { $self->{enabled} = shift })
86			};
87
88	root	1.23	()
89			}
90
91	root	1.34	# "find interesting things"-patterns
92	root	1.15	my @mark_patterns = (
93	root	1.49	# qr{ ([[:word:]]+) }x,
94	root	1.42	qr{ ([^[:space:]]+) }x,
95
96	root	1.24	# common types of "parentheses"
97	root	1.50	qr{ (?<![^[:space:]]) [`'] ([^`']+) [`'] (?![^[:space:]]) }x,
98	root	1.48	qr{ (?<![^[:space:]]) ‘ ([^‘’]+) ’ (?![^[:space:]]) }x,
99			qr{ (?<![^[:space:]]) “ ([^“”]+) ” (?![^[:space:]]) }x,
100	root	1.43
101	root	1.47	qr{ (?<![^[:space:]]) (' [^[:space:]] [^']* ') }x,
102	root	1.43	qr{ (' [^']* [^[:space:]] ') (?![^[:space:]]) }x,
103	root	1.52	qr{ (?<![^[:space:]]) (` [^[:space:]] [^']* ') }x,
104			qr{ (` [^']* [^[:space:]] ') (?![^[:space:]]) }x,
105	root	1.47	qr{ (?<![^[:space:]]) (" [^[:space:]] [^"]* ") }x,
106	root	1.42	qr{ (" [^"]* [^[:space:]] ") (?![^[:space:]]) }x,
107	root	1.43
108	root	1.48	qr{ \{ ([^\{\}]+) \} }x,
109			qr{ \( ([^\(\)]+) \) }x,
110			qr{ \[ ([^\[\]]+) \] }x,
111			qr{ \< ([^\<\>]+) \> }x,
112	root	1.14
113	root	1.20	# urls, just a heuristic
114			qr{(
115	root	1.40	(?:https?://\|ftp://\|news://\|mailto:\|file://\|\bwww\.)[ab-zA-Z0-9\-\@;\/?:&=%\$_.+!*\x27(),~#]+
116			[ab-zA-Z0-9\-\@;\/?:&=%\$_+*()~] # exclude some trailing characters (heuristic)
117	root	1.20	)}x,
118
119	root	1.17	# shell-like argument quoting, basically always matches
120	root	1.34	qr{\G [\ \t\|&;<>()]* (
121	root	1.9	(?:
122	root	1.11	[^\\"'\ \t\|&;<>()]+
123	root	1.9	\| \\.
124	root	1.13	\| " (?: [^\\"]+ \| \\. )* "
125	root	1.9	\| ' [^']* '
126			)+
127	root	1.14	)}x,
128	root	1.8	);
129
130	root	1.16	# "correct obvious? crap"-patterns
131	root	1.15	my @simplify_patterns = (
132			qr{^"([^\\"'\ \t\|&;<>()*?]+)"$}, # "simple" => simple
133	root	1.16	qr{^(.*)[,\-]$}, # strip off trailing , and -
134	root	1.15	);
135	root	1.14
136	root	1.6	sub on_sel_extend {
137	root	1.21	my ($self, $time) = @_;
138	root	1.8
139	root	1.37	$self->{enabled}
140			or return;
141
142	root	1.8	my ($row, $col) = $self->selection_mark;
143			my $line = $self->line ($row);
144			my $text = $line->t;
145	root	1.20	my $markofs = $line->offset_of ($row, $col);
146			my $curlen = $line->offset_of ($self->selection_end)
147			- $line->offset_of ($self->selection_beg);
148
149			my @matches;
150	root	1.8
151	root	1.32	if ($markofs < $line->l) {
152			study $text; # _really_ helps, too :)
153
154			for my $regex (@mark_patterns, @{ $self->{patterns} }) {
155			while ($text =~ /$regex/g) {
156			if ($-[1] <= $markofs and $markofs <= $+[1]) {
157			my $ofs = $-[1];
158			my $match = $1;
159
160			for my $regex (@simplify_patterns) {
161			if ($match =~ $regex) {
162			$match = $1;
163			$ofs += $-[1];
164			}
165	root	1.15	}
166	root	1.32
167			push @matches, [$ofs, length $match];
168	root	1.15	}
169	root	1.8	}
170			}
171			}
172
173	root	1.21	# whole line
174			push @matches, [0, ($line->end - $line->beg + 1) * $self->ncol];
175
176	root	1.20	for (sort { $a->[1] <=> $b->[1] or $b->[0] <=> $a->[0] } @matches) {
177			my ($ofs, $len) = @$_;
178
179			next if $len <= $curlen;
180
181			$self->selection_beg ($line->coord_of ($ofs));
182			$self->selection_end ($line->coord_of ($ofs + $len));
183			return 1;
184			}
185
186	root	1.21	()
187	root	1.5	}