bin/e

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Cwd;
   7
   8
   9 sub check_exit_status($) {
  10         my ($cmd) = @_;
  11         if ($? & 127) {
  12                 die $cmd . ': terminated with signal ' . ($? & 127) . "\n";
  13         } elsif ($? >> 8) {
  14                 die $cmd . ': returned ' . ($? >> 8) . "\n";
  15         }
  16 }
  17
  18 sub client(@) {
  19         # I’ve been having problems with IPC::Run and couldn’t debug them.
  20         # Implementing system run with proper stdin and stdout redirection
  21         # turned out to be the fastest solution.
  22
  23         my $pid = fork();
  24         if (!defined $pid) {
  25                 die "fork: $!\n";
  26         } elsif (!$pid) {
  27                 open(STDIN, '<', '/dev/null') or die "/dev/null: $!\n";
  28                 if ($_[0] eq '-q') {
  29                         shift @_;
  30                         open(STDOUT, '>', '/dev/null') or die "/dev/null: $!\n";
  31                 }
  32                 exec 'emacsclient', @_;
  33                 die "emacsclient: $!\n";
  34         } elsif (waitpid($pid, 0) < 0) {
  35                 die "wait: $!";
  36         } else {
  37                 check_exit_status 'emacsclient';
  38         }
  39 }
  40
  41
  42 sub has_x() {
  43         defined $ENV{'DISPLAY'};
  44 }
  45
  46
  47 sub file_argument {
  48         my ($arg) = @_;
  49         if (-e $arg) {
  50                 return ($arg);
  51         }
  52
  53         # When showing diffs, git indicates old and new versions of the
  54         # file by using ‘a/’ and ‘b/’ prefixes.  Detect and strip them.
  55         if ($arg =~ m~^[ab]/(.+)$~ && -e $1) {
  56                 return ($1);
  57         }
  58
  59         # Lastly, try matching ‘«filename»:«line»:«column»:«text»’.  «filename»
  60         # and «text» may include colons and «line» and «column» are optional.
  61         # This makes the matching a bit tricky so we try various possible file
  62         # names if there are multiple colons in $arg.
  63         my @parts = split /:/, $arg, -1;
  64         for (my $i = @parts; --$i; ) {
  65                 my $filename = join ':', @parts[0..($i - 1)];
  66                 if (!-e $filename) {
  67                         next;
  68                 }
  69                 my $line = $parts[$i] // '';
  70                 my $column = $parts[$i + 1] // '';
  71                 if ($line !~ /^\d+$/) {
  72                         return ($filename);
  73                 } elsif ($column =~ /^\d+$/) {
  74                         return ("+$line:$column", $filename);
  75                 } else {
  76                         return ("+$line", $filename);
  77                 }
  78         }
  79         ($arg)
  80 }
  81
  82
  83 sub read_process {
  84         my ($cmd) = @_;
  85         open my $fd, '-|', @_ or die "$cmd : $!\n";
  86         my @lines;
  87         while (defined(my $line = <$fd>)) {
  88                 chomp $line;
  89                 push @lines, $line;
  90         }
  91         close $fd;
  92         check_exit_status($cmd);
  93         if (!@lines) {
  94                 die "$cmd: exited with an empty result\n";
  95         }
  96         @lines
  97 }
  98
  99
 100 my ($windmove, $stdin) = (0, 0);
 101 my @args;
 102
 103 if (@ARGV && $ARGV[0] eq 'e') {
 104         shift @ARGV;
 105 }
 106
 107 while (@ARGV) {
 108         my $arg = shift @ARGV;
 109         if ($arg eq '-l') {
 110                 --$windmove;
 111         } elsif ($arg eq '-r') {
 112                 ++$windmove;
 113         } elsif ($arg eq '-o') {
 114                 $windmove = 'other';
 115         } elsif ($arg =~ /^-(find|which)$/) {
 116                 push @args, read_process $1, @ARGV;
 117                 last;
 118         } elsif ($arg eq '--') {
 119                 push @args, @ARGV;
 120                 last;
 121         } elsif ($arg eq '-') {
 122                 $stdin = 1;
 123         } elsif ($arg =~ /^-./) {
 124                 die "e: unknown option: $arg\n";
 125         } else {
 126                 push @args, file_argument($arg);
 127         }
 128 }
 129
 130 if ($windmove eq 'other') {
 131         $windmove = <<ELISP
 132 (condition-case nil
 133     (windmove-right)
 134   (error (windmove-left)))
 135 ELISP
 136 } elsif ($windmove) {
 137         my $direction = $windmove < 0 ? 'left' : 'right';
 138         $windmove = <<ELISP
 139 (condition-case nil
 140     (dotimes (n (abs $windmove))
 141       (windmove-$direction))
 142   (error nil))
 143 ELISP
 144 }
 145
 146
 147 if ($stdin) {
 148         if (@args) {
 149                 die "e: reading standard input is supported if there are no other arguments\n";
 150         }
 151
 152         my $data;
 153         $data = join '', <STDIN>;
 154         $data =~ s/\\/\\\\/g;
 155         $data =~ s/"/\\"/g;
 156         $data = <<ELISP;
 157 (let ((buf (generate-new-buffer "*pipe*")))
 158   (set-buffer buf)
 159   (insert "$data")
 160   (goto-char (point-min))
 161   $windmove
 162   (switch-to-buffer buf)
 163   (x-focus-frame nil))
 164 ELISP
 165         @args = ('-e', $data);
 166         undef $windmove;
 167 } elsif (!@args) {
 168         client has_x ? '-cna' : '-a', '';
 169         exit 0;
 170 }
 171
 172
 173 if ($windmove) {
 174         client '-q', '-ne', $windmove;
 175 }
 176
 177 my @q = $stdin ? ('-q') : ();
 178 client @q, has_x ? '-na' : '-ta', '', @args;