rxvt-unicode 9.19-1 / usr / lib / urxvt / perl / selection

#! perl

#:META:X_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 following bindable keyboard commands:

=over 4

=item rot13

Rot-13 the selection when activated. Used via keyboard trigger:

   URxvt.keysym.C-M-r: perl: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_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;
   }

   ()
}