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

#! perl

sub on_user_command {
   my ($self, $cmd) = @_;

   $cmd eq "selection: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);
      utf8::encode $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) {
      # convert markofs from character to UTF-8 offset space
      {
         my $prefix = substr $text, 0, $markofs;
         utf8::encode $prefix;
         $markofs = length $prefix;
      }

      # not doing matches in unicode mode helps speed
      # enourmously here. working in utf-8 should be
      # equivalent due to the magic of utf-8 encoding.
      utf8::encode $text;
      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;

      # convert back from UTF-8 offset space to character space
      {
         my $length = substr "$text ", $ofs, $len;
         utf8::decode $length;
         $len = length $length;
      }
      {
         my $prefix = substr $text, 0, $ofs;
         utf8::decode $prefix;
         $ofs = length $prefix;
      }

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

   ()
}
Revision:	1.52
Committed:	Sat Dec 26 10:50:46 2009 UTC (14 years, 5 months ago) by root
Branch:	MAIN
CVS Tags:	before_dynamic_fontidx, rel-9_10, dynamic_fontidx, rel-9_09, rel-9_07
Changes since 1.51:	+2 -1 lines
Log Message:	* empty log message *
#	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			utf8::encode $res;
23	root	1.23	push @{ $self->{patterns} }, qr/$res/;
24			}
25
26	root	1.37	$self->{enabled} = 1;
27
28			push @{ $self->{term}{option_popup_hook} }, sub {
29			("new selection" => $self->{enabled}, sub { $self->{enabled} = shift })
30			};
31
32	root	1.23	()
33			}
34
35	root	1.34	# "find interesting things"-patterns
36	root	1.15	my @mark_patterns = (
37	root	1.49	# qr{ ([[:word:]]+) }x,
38	root	1.42	qr{ ([^[:space:]]+) }x,
39
40	root	1.24	# common types of "parentheses"
41	root	1.50	qr{ (?<![^[:space:]]) [`'] ([^`']+) [`'] (?![^[:space:]]) }x,
42	root	1.48	qr{ (?<![^[:space:]]) ‘ ([^‘’]+) ’ (?![^[:space:]]) }x,
43			qr{ (?<![^[:space:]]) “ ([^“”]+) ” (?![^[:space:]]) }x,
44	root	1.43
45	root	1.47	qr{ (?<![^[:space:]]) (' [^[:space:]] [^']* ') }x,
46	root	1.43	qr{ (' [^']* [^[:space:]] ') (?![^[:space:]]) }x,
47	root	1.52	qr{ (?<![^[:space:]]) (` [^[:space:]] [^']* ') }x,
48			qr{ (` [^']* [^[:space:]] ') (?![^[:space:]]) }x,
49	root	1.47	qr{ (?<![^[:space:]]) (" [^[:space:]] [^"]* ") }x,
50	root	1.42	qr{ (" [^"]* [^[:space:]] ") (?![^[:space:]]) }x,
51	root	1.43
52	root	1.48	qr{ \{ ([^\{\}]+) \} }x,
53			qr{ \( ([^\(\)]+) \) }x,
54			qr{ \[ ([^\[\]]+) \] }x,
55			qr{ \< ([^\<\>]+) \> }x,
56	root	1.14
57	root	1.20	# urls, just a heuristic
58			qr{(
59	root	1.40	(?:https?://\|ftp://\|news://\|mailto:\|file://\|\bwww\.)[ab-zA-Z0-9\-\@;\/?:&=%\$_.+!*\x27(),~#]+
60			[ab-zA-Z0-9\-\@;\/?:&=%\$_+*()~] # exclude some trailing characters (heuristic)
61	root	1.20	)}x,
62
63	root	1.17	# shell-like argument quoting, basically always matches
64	root	1.34	qr{\G [\ \t\|&;<>()]* (
65	root	1.9	(?:
66	root	1.11	[^\\"'\ \t\|&;<>()]+
67	root	1.9	\| \\.
68	root	1.13	\| " (?: [^\\"]+ \| \\. )* "
69	root	1.9	\| ' [^']* '
70			)+
71	root	1.14	)}x,
72	root	1.8	);
73
74	root	1.16	# "correct obvious? crap"-patterns
75	root	1.15	my @simplify_patterns = (
76			qr{^"([^\\"'\ \t\|&;<>()*?]+)"$}, # "simple" => simple
77	root	1.16	qr{^(.*)[,\-]$}, # strip off trailing , and -
78	root	1.15	);
79	root	1.14
80	root	1.6	sub on_sel_extend {
81	root	1.21	my ($self, $time) = @_;
82	root	1.8
83	root	1.37	$self->{enabled}
84			or return;
85
86	root	1.8	my ($row, $col) = $self->selection_mark;
87			my $line = $self->line ($row);
88			my $text = $line->t;
89	root	1.20	my $markofs = $line->offset_of ($row, $col);
90			my $curlen = $line->offset_of ($self->selection_end)
91			- $line->offset_of ($self->selection_beg);
92
93			my @matches;
94	root	1.8
95	root	1.32	if ($markofs < $line->l) {
96	root	1.41	# convert markofs from character to UTF-8 offset space
97	root	1.32	{
98			my $prefix = substr $text, 0, $markofs;
99			utf8::encode $prefix;
100			$markofs = length $prefix;
101			}
102
103			# not doing matches in unicode mode helps speed
104			# enourmously here. working in utf-8 should be
105			# equivalent due to the magic of utf-8 encoding.
106			utf8::encode $text;
107			study $text; # _really_ helps, too :)
108
109			for my $regex (@mark_patterns, @{ $self->{patterns} }) {
110			while ($text =~ /$regex/g) {
111			if ($-[1] <= $markofs and $markofs <= $+[1]) {
112			my $ofs = $-[1];
113			my $match = $1;
114
115			for my $regex (@simplify_patterns) {
116			if ($match =~ $regex) {
117			$match = $1;
118			$ofs += $-[1];
119			}
120	root	1.15	}
121	root	1.32
122			push @matches, [$ofs, length $match];
123	root	1.15	}
124	root	1.8	}
125			}
126			}
127
128	root	1.21	# whole line
129			push @matches, [0, ($line->end - $line->beg + 1) * $self->ncol];
130
131	root	1.20	for (sort { $a->[1] <=> $b->[1] or $b->[0] <=> $a->[0] } @matches) {
132			my ($ofs, $len) = @$_;
133
134			next if $len <= $curlen;
135
136	root	1.32	# convert back from UTF-8 offset space to character space
137			{
138	root	1.33	my $length = substr "$text ", $ofs, $len;
139	root	1.32	utf8::decode $length;
140			$len = length $length;
141			}
142			{
143			my $prefix = substr $text, 0, $ofs;
144			utf8::decode $prefix;
145			$ofs = length $prefix;
146			}
147
148	root	1.20	$self->selection_beg ($line->coord_of ($ofs));
149			$self->selection_end ($line->coord_of ($ofs + $len));
150			return 1;
151			}
152
153	root	1.21	()
154	root	1.5	}