1#!/usr/local/bin/perl -w
2#
3#   ``Wee have also Shelles, thee Lyke of whych you knowe not, wherein
4#     thee User may with thee merest Presse of thee Tabbe-Keye expande
5#     or compleat al Maner of Wordes and such-like Diversities.''
6#            - Francis Bacon, `New Atlantis' (or not).
7#
8# Convert tcsh "complete" statements to zsh "compctl" statements.
9# Runs as a filter.  Should ignore anything which isn't a "complete".
10# It expects each "complete" statement to be the first thing on a line.
11# All the examples in the tcsh manual give sensible results.
12# Author:  Peter Stephenson <pws@ibmth.df.unipi.it>
13#
14# Option:
15# -x (exact): only applies in the case of command disambiguation (is
16#    that really a word?)  If you have lines like
17#       complete '-co*' 'p/0/(compress)'
18#    (which makes co<TAB> always complete to `compress') then the
19#    resulting "compctl" statements will produce one of two behaviours:
20#    (1) By default (like tcsh), com<TAB> etc. will also complete to
21#        "compress" and nothing else.
22#    (2) With -x, com<TAB> does ordinary command completion: this is
23#        more flexible.
24#    I don't understand what the hyphen in complete does and I've ignored it.
25#
26# Notes:
27# (1) The -s option is the way to do backquote expansion.  In zsh,
28#     "compctl -s '`users`' talk" works (duplicates are removed).
29# (2) Complicated backquote completions should definitely be rewritten as
30#     shell functions (compctl's "-K func" option).  Although most of
31#     these will be translated correctly, differences in shell syntax
32#     are not handled.
33# (3) Replacement of $:n with the n'th word on the current line with
34#     backquote expansion now works; it is not necessarily the most
35#     efficient way of doing it in any given case, however.
36# (4) I have made use of zsh's more sophisticated globbing to change
37#     things like ^foo.{a,b,c,d} to ^foo.(a|b|c|d), which works better.
38#     It's just possible in some cases you may want to change it back.
39# (5) Make sure all command names with wildcards are processed together --
40#     they need to be lumped into one "compctl -C" or "compctl -D"
41#     statement for zsh.
42# (6) Group completion (complete's g flag) is not built into zsh, so
43#     you need perl to be available to generate the groups.  If this
44#     script is useful, I assume that's not a problem.
45# (7) I don't know what `completing completions' means, so the X
46#     flag to complete is not handled.
47
48# Handle options
49if (@ARGV) {
50    ($ARGV[0] eq '-x') && shift && ($opt_x = 1);
51    ($ARGV[0] =~ /^-+$/) && shift;
52}
53
54# Function names used (via magic autoincrement) when cmdline words are needed
55$funcnam = 'compfn001';
56
57# Read next word on command line
58sub getword {
59    local($word, $word2, $ret);
60    ($_) = /^\s*(.*)$/;
61    while ($_ =~ /^\S/) {
62	if (/^[\']/) {
63	    ($word, $_) = /^\'([^\']*).(.*)$/;
64	} elsif (/^[\"]/) {
65	    ($word, $_) = /^\"([^\"]*).(.*)$/;
66	    while ($word =~ /\\$/) {
67		chop($word);
68		($word2, $_) = /^([^\"]*).(.*)$/;
69		$word .= '"' . $word2;
70	    }
71	} elsif (/\S/) {
72	    ($word, $_) = /^([^\s\\\'\"\#;]*)(.*)$/;
73	    # Backslash: literal next character
74	    /^\\(.)/ && (($word .= substr($_,1,1)),
75			 ($_ = substr($_,2)));
76	    # Rest of line quoted or end of command
77	    /^[\#;]/ && ($_ = '');
78	} else {
79	    return undef;
80	}
81	length($word) && ($ret = defined($ret) ? $ret . $word : $word);
82    }
83    $ret;
84}
85
86# Interpret the x and arg in 'x/arg/type/'
87sub getpat {
88    local($pat,$arg) = @_;
89    local($ret,$i);
90    if ($pat eq 'p') {
91	$ret = "p[$arg]";
92    } elsif ($pat eq 'n' || $pat eq 'N') {
93	$let = ($arg =~ /[*?|]/) ? 'C' : 'c';
94	$num = ($pat eq 'N') ? 2 : 1;
95	$ret = "${let}[-${num},$arg]";
96    } elsif ($pat eq 'c' || $pat eq 'C') {
97	# A few tricks to get zsh to ignore up to the end of
98	# any matched pattern.
99	if (($pat eq 'c' && $arg =~ /^\*([^*?]*)$/)) {
100	    $ret = "n[-1,$1]";
101	} elsif ($arg =~ /[*?]([^*?]*)$/) {
102	    length($1) && ($ret = " n[-1,$1]");
103	    $ret = "C[0,$arg] $ret";
104	} else {
105	    $let = ($pat eq 'c') ? 's' : 'S';
106	    $ret = "${let}[$arg]";
107	}
108    }
109    $ret =~ s/'/'\\''/g;
110    $ret;
111}
112
113# Interpret the type in 'x/arg/type/'
114sub gettype {
115    local ($_) = @_;
116    local($qual,$c,$glob,$ret,$b,$m,$e,@m);
117    $c = substr($_,0,1);
118    ($c =~ /\w/) && (substr($_,1,1) eq ':') && ($glob = substr($_,2));
119# Nothing (n) can be handled by returning nothing.  (C.f. King Lear, I.i.)
120    if ($c =~ /[abcjuv]/) {
121	$ret = "-$c";
122    } elsif ($c eq 'C') {
123	if (defined($glob)) {
124	    $ret = "-W $glob -/g '*(.*)'";
125	    undef($glob);
126	} else {
127	    $ret = '-c';
128	}
129    } elsif ($c eq 'S') {
130	$ret = '-k signals';
131    } elsif ($c eq 'd') {
132	if (defined($glob)) {
133	    $qual = '-/';
134	} else {
135	    $ret = '-/';
136	}
137    } elsif ($c eq 'D') {
138	if (defined($glob)) {
139	    $ret = "-W $glob -/";
140	    undef($glob);
141	} else {
142	    $ret = '-/';
143	}
144    } elsif ($c eq 'e') {
145	$ret = '-E';
146    } elsif ($c eq 'f' && !$glob) {
147	$ret = '-f';
148    } elsif ($c eq 'F') {
149	if (defined($glob)) {
150	    $ret = "-W $glob -f";
151	    undef($glob);
152	} else {
153	    $ret = '-f';
154	}
155    } elsif ($c eq 'g') {
156	$ret = "-s '\$(perl -e '\\''while ((\$name) = getgrent)\n" .
157	    "{ print \$name, \"\\n\"; }'\\'')'";
158    } elsif ($c eq 'l') {
159	$ret = q!-k "(`limit | awk '{print $1}'`)"!;
160    } elsif ($c eq 'p') {
161        $ret = "-W $glob -f", undef($glob) if defined($glob);
162    } elsif ($c eq 's') {
163        $ret = '-p';
164    } elsif ($c eq 't') {
165	$qual = '.';
166    } elsif ($c eq 'T') {
167        if (defined($glob)) {
168            $ret = "-W $glob -g '*(.)'";
169            undef($glob);
170        } else {
171            $ret = "-g '*(.)'";
172        }
173    } elsif ($c eq 'x') {
174	$glob =~ s/'/'\\''/g;
175	$ret = "-X '$glob'";
176	undef($glob);
177    } elsif ($c eq '$') {     # '){
178	$ret = "-k " . substr($_,1);
179    } elsif ($c eq '(') {
180	s/'/'\\''/g;
181	$ret = "-k '$_'";
182    } elsif ($c eq '`') {
183	# this took some working out...
184	if (s/\$:(\d+)/$foo=$1+1,"\${word[$foo]}"/ge) {
185	    $ret = "-K $funcnam";
186	    $genfunc .= <<"HERE";
187function $funcnam {
188    local word
189    read -cA word
190    reply=($_)
191}
192HERE
193	    $funcnam++;
194	} else {
195	    s/'/'\\''/g;
196	    $ret = "-s '$_'";
197	}
198    }
199
200    # foo{bar,ba,blak,sheap} -> foo(bar|ba|blak|sheap).
201    # This saves a lot of mess, since in zsh brace expansion occurs
202    # before globbing.  I'm sorry, but I don't trust $` and $'.
203    while (defined($glob) && (($b,$m,$e) = ($glob =~ /^(.*)\{(.*)\}(.*)$/))
204	   && $m =~ /,/) {
205	@m = split(/,/, $m);
206	for ($i = 0; $i < @m; $i++) {
207	    while ($m[$i] =~ /\\$/) {
208		substr($m[$i],-1,1) = "";
209		splice(@m,$i,2,"$m[$i]\\,$m[$i+1]");
210	    }
211	}
212	$glob = $b . "(" . join('|',@m) . ")" . $e;
213    }
214
215    if ($qual) {
216	$glob || ($glob = '*');
217	$glob .= "($qual)";
218    }
219    $glob && (($glob =~ s/'/'\\''/g),($glob = "-g '$glob'"));
220
221    defined($ret) && defined($glob) && ($ret .= " $glob");
222    defined($ret) ? $ret : $glob;
223}
224
225# Quoted array separator for extended completions
226$" = " - ";
227
228while (<>) {
229    if (/^\s*complete\s/) {
230	undef(@stuff);
231	$default = '';
232	$_ = $';
233	while (/\\$/) {
234	    # Remove backslashed newlines: in principle these should become
235	    # real newlines inside quotes, but what the hell.
236	    ($_) = /^(.*)\\$/;
237	    $_ .= <>;
238	}
239	$command = &getword;
240	if ($command =~ /^-/ || $command =~ /[*?]/) {
241	    # E.g. complete -co* ...
242	    $defmatch = $command;
243	    ($defmatch =~ /^-/) && ($defmatch = substr($defmatch,1));
244	} else {
245	    undef($defmatch);
246	}
247	while (defined($word = &getword)) {
248	    # Loop over remaining arguments to "complete".
249	    $sep = substr($word,1,1);
250	    $sep =~ s/(\W)/\\$1/g;
251	    @split = split(/$sep/,$word,4);
252	    for ($i = 0; $i < 3; $i++) {
253		while ($split[$i] =~ /\\$/) {
254		    substr($split[$i],-1,1) = "";
255		    splice(@split,$i,2,"$split[$i]\\$sep$split[$i+1]");
256		}
257	    }
258	    ($pat,$arg,$type,$suffix) = @split;
259	    defined($suffix) && ($suffix =~ /^\s*$/) && undef($suffix);
260	    if (($word =~ /^n$sep\*$sep/) &&
261		 (!defined($defmatch))) {
262		 # The "complete" catch-all:  treat this as compctl\'s
263		 # default (requiring no pattern matching).
264		$default .= &gettype($type) . ' ';
265		defined($suffix) &&
266		    (defined($defsuf) ? ($defsuf .= $suffix)
267		     : ($defsuf = $suffix));
268	    } else {
269		$pat = &getpat($pat,$arg);
270		$type = &gettype($type);
271		if (defined($defmatch)) {
272		    # The command is a pattern: use either -C or -D option.
273		    if ($pat eq 'p[0]') {
274			# Command word (-C): 'p[0]' is redundant.
275			if ($defmatch eq '*') {
276			    $defcommand = $type;
277			} else {
278			    ($defmatch =~ /\*$/) && chop($defmatch);
279			    if ($opt_x) {
280				$c = ($defmatch =~ /[*?]/) ? 'C' : 'c';
281				$pat = $c . "[0,${defmatch}]";
282			    } else {
283				$pat = ($defmatch =~ /[*?]/) ?
284				    "C[0,${defmatch}]" : "S[${defmatch}]";
285			    }
286			    push(@commandword,defined($suffix) ?
287				 "'$pat' $type -S '$suffix'" : "'$pat' $type");
288			}
289		    } elsif ($pat eq "C[-1,*]") {
290			# Not command word completion, but match
291			# command word (only)
292			if ($defmatch eq "*") {
293			    # any word of any command
294			    $defaultdefault .= " $type";
295			} else {
296			    $pat = "W[0,$defmatch]";
297			    push(@defaultword,defined($suffix) ?
298				 "'$pat' $type -S '$suffix'" : "'$pat' $type");
299			}
300		    } else {
301		        # Not command word completion, but still command
302			# word with pattern
303			($defmatch eq '*') || ($pat = "W[0,$defmatch] $pat");
304			push(@defaultword,defined($suffix) ?
305			     "'$pat' $type -S '$suffix'" : "'$pat' $type");
306		    }
307		} else {
308		    # Ordinary command
309		    push(@stuff,defined($suffix) ?
310			 "'$pat' $type -S '$suffix'" : "'$pat' $type");
311		}
312	    }
313	}
314        if (!defined($defmatch)) {
315	    # Ordinary commands with no pattern
316	    print("compctl $default");
317	    defined($defsuf) && print("-S '$defsuf' ") && undef($defsuf);
318	    defined(@stuff) && print("-x @stuff -- ");
319	    print("$command\n");
320	}
321	if (defined($genfunc)) {
322	    print $genfunc;
323	    undef($genfunc);
324	}
325    }
326}
327
328(defined(@commandword) || defined($defcommand)) &&
329    print("compctl -C ",
330	  defined($defcommand) ? $defcommand : '-c',
331	  defined(@commandword) ? " -x @commandword\n" : "\n");
332
333if (defined($defaultdefault) || defined(@defaultword)) {
334    defined($defaultdefault) || ($defaultdefault = "-f");
335    print "compctl -D $defaultdefault";
336    defined(@defaultword) && print(" -x @defaultword");
337    print "\n";
338}
339
340__END__
341