ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/rxvt-unicode/src/perl/selection
Revision: 1.53
Committed: Sun Mar 13 17:07:36 2011 UTC (13 years, 3 months ago) by sf-exg
Branch: MAIN
CVS Tags: rel-9_14, rel-9_11, rel-9_12, rxvt-unicode-rel-9_15
Changes since 1.52: +0 -24 lines
Log Message:
Match character-wise rather than byte-wise in selection extension.

File Contents

# User Rev Content
1 root 1.4 #! perl
2    
3 root 1.36 sub on_user_command {
4 root 1.7 my ($self, $cmd) = @_;
5 elmex 1.2
6     $cmd eq "selection:rot13"
7 root 1.7 and $self->selection (map { y/A-Za-z/N-ZA-Mn-za-m/; $_ } $self->selection);
8 elmex 1.3
9     ()
10 elmex 1.1 }
11 root 1.5
12 root 1.23 sub on_init {
13     my ($self) = @_;
14    
15 root 1.35 if (defined (my $res = $self->resource ("cutchars"))) {
16     $res = $self->locale_decode ($res);
17     push @{ $self->{patterns} }, qr{\G [\Q$res\E[:space:]]* ([^\Q$res\E[:space:]]+) }x;
18     }
19    
20 root 1.23 for (my $idx = 0; defined (my $res = $self->x_resource ("selection.pattern-$idx")); $idx++) {
21 root 1.31 $res = $self->locale_decode ($res);
22 root 1.23 push @{ $self->{patterns} }, qr/$res/;
23     }
24    
25 root 1.37 $self->{enabled} = 1;
26    
27     push @{ $self->{term}{option_popup_hook} }, sub {
28     ("new selection" => $self->{enabled}, sub { $self->{enabled} = shift })
29     };
30    
31 root 1.23 ()
32     }
33    
34 root 1.34 # "find interesting things"-patterns
35 root 1.15 my @mark_patterns = (
36 root 1.49 # qr{ ([[:word:]]+) }x,
37 root 1.42 qr{ ([^[:space:]]+) }x,
38    
39 root 1.24 # common types of "parentheses"
40 root 1.50 qr{ (?<![^[:space:]]) [`'] ([^`']+) [`'] (?![^[:space:]]) }x,
41 root 1.48 qr{ (?<![^[:space:]]) ‘ ([^‘’]+) ’ (?![^[:space:]]) }x,
42     qr{ (?<![^[:space:]]) “ ([^“”]+) ” (?![^[:space:]]) }x,
43 root 1.43
44 root 1.47 qr{ (?<![^[:space:]]) (' [^[:space:]] [^']* ') }x,
45 root 1.43 qr{ (' [^']* [^[:space:]] ') (?![^[:space:]]) }x,
46 root 1.52 qr{ (?<![^[:space:]]) (` [^[:space:]] [^']* ') }x,
47     qr{ (` [^']* [^[:space:]] ') (?![^[:space:]]) }x,
48 root 1.47 qr{ (?<![^[:space:]]) (" [^[:space:]] [^"]* ") }x,
49 root 1.42 qr{ (" [^"]* [^[:space:]] ") (?![^[:space:]]) }x,
50 root 1.43
51 root 1.48 qr{ \{ ([^\{\}]+) \} }x,
52     qr{ \( ([^\(\)]+) \) }x,
53     qr{ \[ ([^\[\]]+) \] }x,
54     qr{ \< ([^\<\>]+) \> }x,
55 root 1.14
56 root 1.20 # urls, just a heuristic
57     qr{(
58 root 1.40 (?:https?://|ftp://|news://|mailto:|file://|\bwww\.)[ab-zA-Z0-9\-\@;\/?:&=%\$_.+!*\x27(),~#]+
59     [ab-zA-Z0-9\-\@;\/?:&=%\$_+*()~] # exclude some trailing characters (heuristic)
60 root 1.20 )}x,
61    
62 root 1.17 # shell-like argument quoting, basically always matches
63 root 1.34 qr{\G [\ \t|&;<>()]* (
64 root 1.9 (?:
65 root 1.11 [^\\"'\ \t|&;<>()]+
66 root 1.9 | \\.
67 root 1.13 | " (?: [^\\"]+ | \\. )* "
68 root 1.9 | ' [^']* '
69     )+
70 root 1.14 )}x,
71 root 1.8 );
72    
73 root 1.16 # "correct obvious? crap"-patterns
74 root 1.15 my @simplify_patterns = (
75     qr{^"([^\\"'\ \t|&;<>()*?]+)"$}, # "simple" => simple
76 root 1.16 qr{^(.*)[,\-]$}, # strip off trailing , and -
77 root 1.15 );
78 root 1.14
79 root 1.6 sub on_sel_extend {
80 root 1.21 my ($self, $time) = @_;
81 root 1.8
82 root 1.37 $self->{enabled}
83     or return;
84    
85 root 1.8 my ($row, $col) = $self->selection_mark;
86     my $line = $self->line ($row);
87     my $text = $line->t;
88 root 1.20 my $markofs = $line->offset_of ($row, $col);
89     my $curlen = $line->offset_of ($self->selection_end)
90     - $line->offset_of ($self->selection_beg);
91    
92     my @matches;
93 root 1.8
94 root 1.32 if ($markofs < $line->l) {
95     study $text; # _really_ helps, too :)
96    
97     for my $regex (@mark_patterns, @{ $self->{patterns} }) {
98     while ($text =~ /$regex/g) {
99     if ($-[1] <= $markofs and $markofs <= $+[1]) {
100     my $ofs = $-[1];
101     my $match = $1;
102    
103     for my $regex (@simplify_patterns) {
104     if ($match =~ $regex) {
105     $match = $1;
106     $ofs += $-[1];
107     }
108 root 1.15 }
109 root 1.32
110     push @matches, [$ofs, length $match];
111 root 1.15 }
112 root 1.8 }
113     }
114     }
115    
116 root 1.21 # whole line
117     push @matches, [0, ($line->end - $line->beg + 1) * $self->ncol];
118    
119 root 1.20 for (sort { $a->[1] <=> $b->[1] or $b->[0] <=> $a->[0] } @matches) {
120     my ($ofs, $len) = @$_;
121    
122     next if $len <= $curlen;
123    
124     $self->selection_beg ($line->coord_of ($ofs));
125     $self->selection_end ($line->coord_of ($ofs + $len));
126     return 1;
127     }
128    
129 root 1.21 ()
130 root 1.5 }