diff options
Diffstat (limited to 'src/perl')
| -rw-r--r-- | src/perl/selection | 196 | ||||
| -rw-r--r-- | src/perl/selection-pastebin | 136 |
2 files changed, 332 insertions, 0 deletions
diff --git a/src/perl/selection b/src/perl/selection new file mode 100644 index 0000000..509423a --- /dev/null +++ b/src/perl/selection @@ -0,0 +1,196 @@ +#! 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_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_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; + } + + () +} diff --git a/src/perl/selection-pastebin b/src/perl/selection-pastebin new file mode 100644 index 0000000..0d433c3 --- /dev/null +++ b/src/perl/selection-pastebin @@ -0,0 +1,136 @@ +#! perl + +#:META:RESOURCE:%.cmd:string:the command to run create a new pastebin +#:META:RESOURCE:%.url:string:the url template for new pastebins + +=head1 NAME + +selection-pastebin - automatic pastebin upload + +=head1 EXAMPLES + + URxvt.keysym.C-M-e: selection-pastebin:remote-pastebin + +=head1 DESCRIPTION + +This is a little rarely useful extension that uploads the selection as +textfile to a remote site (or does other things). (The implementation is +not currently secure for use in a multiuser environment as it writes to +F</tmp> directly.). + +It listens to the C<selection-pastebin:remote-pastebin> action, which, +when activated, runs a command with C<%> replaced by the name of the +textfile. This command can be set via a resource: + + URxvt.selection-pastebin.cmd: rsync -apP % ruth:/var/www/www.ta-sa.org/files/txt/. + +And the default is likely not useful to anybody but the few people around +here :) + +The name of the textfile is the hex encoded md5 sum of the selection, so +the same content should lead to the same filename. + +After a successful upload the selection will be replaced by the text given +in the C<selection-pastebin-url> resource (again, the % is the placeholder +for the filename): + + URxvt.selection-pastebin.url: http://www.ta-sa.org/files/txt/% + +I<Note to xrdb users:> xrdb uses the C preprocessor, which might interpret +the double C</> characters as comment start. Use C<\057\057> instead, +which works regardless of whether xrdb is used to parse the resource file +or not. + +=cut + +sub upload_paste { + my ($self) = @_; + + require Digest::MD5; + + my $txt = $self->selection; + + my $filename = $txt; + utf8::encode $filename; + $filename = Digest::MD5::md5_hex ($filename) . ".txt"; + + my $tmpfile = "/tmp/$filename"; + + my $msg = "uploaded as $filename"; + + if (open my $o, ">:utf8", $tmpfile) { + chmod 0644, $tmpfile; + print $o $txt; + close $o; + } else { + $msg = "couldn't write $tmpfile: $!"; + } + + my $cmd = $self->{pastebin_cmd}; + $cmd =~ s/%/$tmpfile/; + + my $pid = $self->exec_async ($cmd); + + $self->{pw} = urxvt::pw->new->start ($pid)->cb (sub { + my (undef, $status) = @_; + + delete $self->{pw}; + + if ($status) { + $status >>= 8; + $msg = "ERROR: command returned status $status"; + } else { + my $url = $self->{pastebin_url}; + $url =~ s/%/$filename/; + + $self->selection ($url); + } + + unlink $tmpfile; + + my $ov = $self->overlay (-1, 0, $self->strwidth ($msg), 1, urxvt::OVERLAY_RSTYLE, 0); + $ov->set (0, 0, $msg); + + $self->{timer} = + urxvt::timer + ->new + ->after (5) + ->cb (sub { delete $self->{timer}; undef $ov; }); + }); +} + +sub on_start { + my ($self) = @_; + + $self->{pastebin_cmd} = $self->x_resource ("%.cmd") + || "rcp -p % ruth:/var/www/www.ta-sa.org/files/txt/"; + + $self->{pastebin_url} = $self->x_resource ("%.url") + || "http://www.ta-sa.org/files/txt/%"; + + push @{ $self->{term}{selection_popup_hook} }, sub { + ("pastebin upload" => sub { $self->upload_paste }) + }; + + () +} + +sub on_user_command { + my ($self, $cmd) = @_; + + if ($cmd eq "selection-pastebin:remote-pastebin") { + $self->upload_paste; + } + + () +} + +sub on_action { + my ($self, $action) = @_; + + $action eq "remote-pastebin" + and $self->upload_paste; + + () +} + |