[ViewVC] Annotation of: cvs/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 =
      (urxvt::untaint $self->x_resource ("selection-pastebin-cmd"))
      or "scp -p % ruth:/var/www/www.ta-sa.org/files/txt/";

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

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

   my $txt = $self->selection;
   my $h = md5_hex ($txt);

   my $fn = "/tmp/$h.txt";

   my $msg = "uploaded $h.txt";

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

   my $cmd = $pastebin_cmd;
   $cmd =~ s/%/$fn/;
   unless (system ($cmd) == 0) {
      $msg = "couldn't upload, '$cmd' failed";
   }

   $self->selection ($pastebin_url . "$h.txt");

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