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

#! perl
use Digest::MD5 qw/md5_hex/;

my $timers = {};
my $pastebin_cmd;
my $pastebin_url;

sub on_start {
   my ($self) = @_;
   $pastebin_cmd = $self->x_resource ("selection-pastebin-cmd")
      or "scp -p % ruth:/var/www/www.ta-sa.org/files/txt/";

   $pastebin_url = $self->x_resource ("selection-pastebin-url")
      or "http://www.ta-sa.org/files/txt/";
   ();
}

sub upload_paste {
   my ($self) = @_;

   my $txt = $self->selection;
   my $filename = md5_hex ($txt) . ".txt";

   my $tmpfile = "/tmp/$filename";

   my $msg = "uploaded $filename";

   if (open my $o, ">" . $tmpfile) {
      print $o $txt;
      close $o;
   } else {
      $msg = "couldn't write $tmpfile: $!";
   }

   my $cmd = $pastebin_cmd;
   $cmd =~ s/%/$tmpfile/;

   if (system ($cmd) == 0) {

      my $url = $pastebin_url;
      $url =~ s/%/$filename/;

      $self->selection ($url);
   } else {
      $msg = "couldn't upload, '$cmd' failed";
   }

   my $ov = $timers->{ov} = $self->overlay (-1, 0, length ($msg), 1, urxvt::OVERLAY_RSTYLE, 0);
   $ov->set (0, 0, $msg);

   $timers->{t1} =
      urxvt::timer
              ->new
              ->start ((int urxvt::NOW) + 5) # make sure we update "on" the second
              ->interval (1)
              ->cb (sub { delete $timers->{ov}; delete $timers->{t1}; });
}

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

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

   $cmd eq "selection:remote-pastebin"
      and upload_paste ($self);

   ()
}

sub on_init {
   my ($self) = @_;

   for (my $idx = 0; defined (my $res = $self->x_resource ("selection.pattern-$idx")); $idx++) {
      no re 'eval'; # just to be sure
      $res = utf8::encode $self->locale_decode ($res);
      push @{ $self->{patterns} }, qr/$res/;
   }

   ()
}

# "find interetsing things"-patterns
my @mark_patterns = (
   # common types of "parentheses"
   qr{ (?<![^[:space:]]) ‘ ([^‘’]+) ’ (?![^[:space]]) }x,
   qr{ (?<![^[:space:]]) ` ([^`']+) ' (?![^[:space]]) }x,
   qr{ (?<![^[:space:]]) (" [^[:space:]] [^"]* ")                 }x,
   qr{                   (" [^"]* [^[:space:]] ") (?![^[:space]]) }x,
   qr{ \< ([^<>[:space:]]+) \> }x,
   qr{ \{ ([^{}[:space:]]+) \} }x,
   qr{ \[ ([^{}[:space:]]+) \] }x,
   qr{ \( ([^()[:space:]]+) \) }x,

   # urls, just a heuristic
   qr{(
      (?:https?|ftp|news|mailto|file)://[ab-zA-Z0-9\-\@;\/?:&=%\$_.+!*\x27(),~]+
      [ab-zA-Z0-9\-\@;\/?:&=%\$_+!*\x27()~]   # 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) = @_;

   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;

   # 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;

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

   ()
}
Revision:	1.29
Committed:	Tue Jan 17 16:22:41 2006 UTC (20 years, 8 months ago) by root
Branch:	MAIN
Changes since 1.28:	+2 -4 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.4	#! perl
2	elmex	1.27	use Digest::MD5 qw/md5_hex/;
3
4			my $timers = {};
5			my $pastebin_cmd;
6			my $pastebin_url;
7
8			sub on_start {
9			my ($self) = @_;
10	root	1.29	$pastebin_cmd = $self->x_resource ("selection-pastebin-cmd")
11	elmex	1.27	or "scp -p % ruth:/var/www/www.ta-sa.org/files/txt/";
12
13	root	1.29	$pastebin_url = $self->x_resource ("selection-pastebin-url")
14	elmex	1.27	or "http://www.ta-sa.org/files/txt/";
15			();
16			}
17
18			sub upload_paste {
19			my ($self) = @_;
20
21			my $txt = $self->selection;
22	elmex	1.28	my $filename = md5_hex ($txt) . ".txt";
23	elmex	1.27
24	elmex	1.28	my $tmpfile = "/tmp/$filename";
25	elmex	1.27
26	elmex	1.28	my $msg = "uploaded $filename";
27	elmex	1.27
28	elmex	1.28	if (open my $o, ">" . $tmpfile) {
29	elmex	1.27	print $o $txt;
30			close $o;
31			} else {
32	elmex	1.28	$msg = "couldn't write $tmpfile: $!";
33	elmex	1.27	}
34
35			my $cmd = $pastebin_cmd;
36	elmex	1.28	$cmd =~ s/%/$tmpfile/;
37
38			if (system ($cmd) == 0) {
39
40			my $url = $pastebin_url;
41			$url =~ s/%/$filename/;
42
43			$self->selection ($url);
44			} else {
45	elmex	1.27	$msg = "couldn't upload, '$cmd' failed";
46			}
47
48			my $ov = $timers->{ov} = $self->overlay (-1, 0, length ($msg), 1, urxvt::OVERLAY_RSTYLE, 0);
49			$ov->set (0, 0, $msg);
50
51			$timers->{t1} =
52			urxvt::timer
53			->new
54			->start ((int urxvt::NOW) + 5) # make sure we update "on" the second
55			->interval (1)
56			->cb (sub { delete $timers->{ov}; delete $timers->{t1}; });
57			}
58	root	1.4
59	elmex	1.1	sub on_keyboard_command {
60	root	1.7	my ($self, $cmd) = @_;
61	elmex	1.2
62			$cmd eq "selection:rot13"
63	root	1.7	and $self->selection (map { y/A-Za-z/N-ZA-Mn-za-m/; $_ } $self->selection);
64	elmex	1.3
65	elmex	1.27	$cmd eq "selection:remote-pastebin"
66			and upload_paste ($self);
67
68	elmex	1.3	()
69	elmex	1.1	}
70	root	1.5
71	root	1.23	sub on_init {
72			my ($self) = @_;
73
74			for (my $idx = 0; defined (my $res = $self->x_resource ("selection.pattern-$idx")); $idx++) {
75			no re 'eval'; # just to be sure
76	root	1.26	$res = utf8::encode $self->locale_decode ($res);
77	root	1.23	push @{ $self->{patterns} }, qr/$res/;
78			}
79
80			()
81			}
82
83	root	1.16	# "find interetsing things"-patterns
84	root	1.15	my @mark_patterns = (
85	root	1.24	# common types of "parentheses"
86	root	1.25	qr{ (?<![^[:space:]]) ‘ ([^‘’]+) ’ (?![^[:space]]) }x,
87			qr{ (?<![^[:space:]]) ` ([^`']+) ' (?![^[:space]]) }x,
88			qr{ (?<![^[:space:]]) (" [^[:space:]] [^"]* ") }x,
89			qr{ (" [^"]* [^[:space:]] ") (?![^[:space]]) }x,
90			qr{ \< ([^<>[:space:]]+) \> }x,
91			qr{ \{ ([^{}[:space:]]+) \} }x,
92			qr{ \[ ([^{}[:space:]]+) \] }x,
93			qr{ \( ([^()[:space:]]+) \) }x,
94	root	1.14
95	root	1.20	# urls, just a heuristic
96			qr{(
97			(?:https?\|ftp\|news\|mailto\|file)://[ab-zA-Z0-9\-\@;\/?:&=%\$_.+!*\x27(),~]+
98			[ab-zA-Z0-9\-\@;\/?:&=%\$_+!*\x27()~] # exclude some trailing characters (heuristic)
99			)}x,
100
101	root	1.17	# shell-like argument quoting, basically always matches
102	root	1.11	qr{\G [\ \t\|&;<>()] *(
103	root	1.9	(?:
104	root	1.11	[^\\"'\ \t\|&;<>()]+
105	root	1.9	\| \\.
106	root	1.13	\| " (?: [^\\"]+ \| \\. )* "
107	root	1.9	\| ' [^']* '
108			)+
109	root	1.14	)}x,
110	root	1.8	);
111
112	root	1.16	# "correct obvious? crap"-patterns
113	root	1.15	my @simplify_patterns = (
114			qr{^"([^\\"'\ \t\|&;<>()*?]+)"$}, # "simple" => simple
115	root	1.16	qr{^(.*)[,\-]$}, # strip off trailing , and -
116	root	1.15	);
117	root	1.14
118	root	1.6	sub on_sel_extend {
119	root	1.21	my ($self, $time) = @_;
120	root	1.8
121			my ($row, $col) = $self->selection_mark;
122			my $line = $self->line ($row);
123			my $text = $line->t;
124	root	1.20	my $markofs = $line->offset_of ($row, $col);
125			my $curlen = $line->offset_of ($self->selection_end)
126			- $line->offset_of ($self->selection_beg);
127
128			my @matches;
129	root	1.8
130	root	1.26	# not doing matches in unicode mode helps speed
131			# enourmously here. working in utf-8 should be
132			# equivalent due to the magic of utf-8 encoding.
133			utf8::encode $text;
134			study $text; # _really_ helps, too :)
135
136	root	1.23	for my $regex (@mark_patterns, @{ $self->{patterns} }) {
137	root	1.8	while ($text =~ /$regex/g) {
138	root	1.20	if ($-[1] <= $markofs and $markofs <= $+[1]) {
139	root	1.16	my $ofs = $-[1];
140	root	1.15	my $match = $1;
141
142			for my $regex (@simplify_patterns) {
143			if ($match =~ $regex) {
144			$match = $1;
145	root	1.16	$ofs += $-[1];
146	root	1.15	}
147			}
148
149	root	1.20	push @matches, [$ofs, length $match];
150	root	1.8	}
151			}
152			}
153
154	root	1.21	# whole line
155			push @matches, [0, ($line->end - $line->beg + 1) * $self->ncol];
156
157	root	1.20	for (sort { $a->[1] <=> $b->[1] or $b->[0] <=> $a->[0] } @matches) {
158			my ($ofs, $len) = @$_;
159
160			next if $len <= $curlen;
161
162			$self->selection_beg ($line->coord_of ($ofs));
163			$self->selection_end ($line->coord_of ($ofs + $len));
164			return 1;
165			}
166
167	root	1.21	()
168	root	1.5	}