File Coverage

blib/lib/XML/XSH2/Completion.pm
Criterion Covered Total %
statement 12 212 5.6
branch 0 160 0.0
condition 0 36 0.0
subroutine 4 14 28.5
pod 0 10 0.0
total 16 432 3.7


line stmt bran cond sub pod time code
1             # $Id: Completion.pm,v 2.7 2007-05-06 19:32:12 pajas Exp $
2              
3             package XML::XSH2::Completion;
4              
5 8     8   3246 use XML::XSH2::CompletionList;
  8         21  
  8         261  
6 8     8   55 use XML::XSH2::Functions qw();
  8         21  
  8         191  
7 8     8   42 use vars qw($VERSION);
  8         14  
  8         300  
8 8     8   45 use strict;
  8         15  
  8         29582  
9              
10             $VERSION='2.2.9'; # VERSION TEMPLATE
11              
12             our @PATH_HASH;
13             our $O=qr/:[[:alnum:]]|--[-_[:alnum:]]+/; # option
14             our $F=qr/(?:\s$O)*/o; # options
15             our $M=qr/(?:^|[;}]|\s+\&?{|:\s*[-+*\/x.\%]?=)\s*/o; # possible command-start
16             our $match_sv=qr/\$([a-zA-Z0-9_]*)$/o; # scalar variable completion
17             our $match_command=qr/${M}[^\!=\s]*$/o; # command completion
18             our $match_option=qr/\s(\:[[:alnum:]]?|--[-_[:alnum:]]*)$/o; # option completion
19             our $match_func=qr/$M(?:call|undef|undefine)\s+(\S*)$/o; # function name completion
20             our $match_nodetype=qr/${M}x?(?:insert|add)\s+(\S*)$/o; # node-type completion
21             our $match_help=qr/$M(?:\?|help)\s+(\S*)$/o; # help topic completion
22             our $match_filename=qr/$M(?:\.|include|open|save)$F\s+(\S*)$|^\s*!\s*\S+\s+/o;
23             our $match_dir=qr/$M(?:lcd)\s+(\S*)$/o;
24             our $match_path_filename=qr/$M(?:system\s|exec\s)\s*\S*$|^\s*\!\s*\S*$|\s\|\s*\S*$/o;
25              
26             our $NAMECHAR = '[-_.[:alnum:]]';
27             our $NNAMECHAR = '[-:_.[:alnum:]]';
28             our $NAME = "$NAMECHAR*$NNAMECHAR*[_.[:alpha:]]";
29              
30             our $WILDCARD = '\*(?!\*|$NAME|\)|\]|\.)';
31             our $OPER = qr/(?:[,=<>\+\|]|-(?!$NAME)|(?:vid|dom|dna|ro)(?=\s*\]|\s*\)|\s*[0-9]+(?!$NNAMECHAR)|\s+{$NAMECHAR}|\s+\*))/;
32              
33              
34             # PATH-completion: system, !, exec, |,
35              
36             our @nodetypes = qw(element attribute attributes text cdata pi comment chunk entity_reference);
37              
38             sub complete_option {
39 0     0 0   my ($l)=@_;
40 0 0         if ($l=~/\s--encoding\s+$|\s:e\s+$/) {
41             }
42 0 0         if ($l=~/$M(\.|[a-zA-Z_][-a-zA-Z0-9_]*)$F\s+(:([[:alnum:]]?)|--([-_[:alnum:]]*))$/) {
43 0   0       my ($cmd,$o,$p)=($1,$2,$3||$4);
44 0           my $c = $XML::XSH2::Functions::COMMANDS{$cmd};
45 0 0 0       $c = $XML::XSH2::Functions::COMMANDS{$c} if (defined($c) and !ref($c));
46 0 0 0       if (defined($c) and defined($c->[3])) {
47 0 0         if ($o =~ /^:/) {
48 0 0         return map { ":".$_ } grep { length == 1 and /^\Q$p\E/ } keys %{$c->[3]};
  0            
  0            
  0            
49             } else {
50 0 0         return map { "--".$_ } grep { length > 1 and /^\Q$p\E/ } keys %{$c->[3]};
  0            
  0            
  0            
51             }
52             }
53             }
54 0           return ();
55             }
56              
57             sub perl_complete {
58 0     0 0   my($word,$line,$pos) = @_;
59 0           my $endpos=$pos+length($word);
60 0           cpl('perl',$word,$line,$pos,$endpos);
61             }
62              
63             sub gnu_complete {
64 0     0 0   my($text, $line, $start, $endpos) = @_;
65 0           &main::_term()->Attribs->{completion_append_character} = ' ';
66 0           my @result=cpl('gnu',$text,$line,$start,$endpos);
67             # find longest common match. Can anybody show me how to persuade
68             # T::R::Gnu to do this automatically? Seems expensive.
69 0 0         return () unless @result;
70 0           my($newtext) = $text;
71 0           for (my $i = length($text)+1;;$i++) {
72 0 0 0       last unless length($result[0]) && length($result[0]) >= $i;
73 0           my $try = substr($result[0],0,$i);
74 0           my @tries = grep {substr($_,0,$i) eq $try} @result;
  0            
75             # warn "try[$try]tries[@tries]";
76 0 0         if (@tries == @result) {
77 0           $newtext = $try;
78             } else {
79 0           last;
80             }
81             }
82 0           ($newtext,@result);
83             }
84              
85             sub complete_set_term_char {
86 0     0 0   my ($type,$char)=@_;
87 0 0         if ($type eq 'perl') {
88 0           $readline::rl_completer_terminator_character = $char;
89             } else {
90 0           &main::_term()->Attribs->{completion_append_character} = $char;
91             }
92             }
93              
94             sub complete_filename {
95 0     0 0   my ($type,$word)=@_;
96 0 0         if ($type eq 'perl') {
97 0           return eval { map { s:\@$::; $_ } readline::rl_filename_list($word); };
  0            
  0            
  0            
98             } else {
99 0           return eval { map { s:\@$::; $_ } Term::ReadLine::Gnu::XS::rl_filename_list($word) };
  0            
  0            
  0            
100             }
101             }
102              
103             sub rehash_path_hash {
104 0     0 0   my %result;
105             my $dh;
106 0 0         my $pdelim= $^O eq 'MSWin32' ? '\\' : '/';
107 0 0         my $delim=($^O eq 'MSWin32' ? ';' : ':');
108 0           my @path=grep /\S/,split($delim,$ENV{PATH});
109 0           foreach my $dir (@path) {
110 0           local *DIR;
111 0 0         if (opendir DIR, $dir) {
112 0 0         my @files=grep { -f "$dir$pdelim$_" and -x "$dir$pdelim$_" } readdir(DIR);
  0            
113 0           @result{@files}=();
114 0           closedir DIR;
115             }
116             }
117 0           @PATH_HASH=sort keys %result;
118             }
119              
120             sub complete_system_command {
121 0     0 0   my ($type,$word)=@_;
122 0 0         my $pdelim= $^O eq 'MSWin32' ? '\\' : '/';
123 0 0         if (index($word,$pdelim)>=0) {
124 0           return grep -x,complete_filename($type,$word);
125             }
126 0 0         unless (@PATH_HASH) {
127 0           rehash_path_hash();
128             }
129 0           return grep {index($_,$word)==0} @PATH_HASH;
  0            
130             }
131              
132             sub cpl {
133 0     0 0   my($type,$word,$line,$pos,$endpos) = @_;
134 0           my $part = substr($line,0,$endpos);
135 0 0         if ($part=~$match_sv) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
136 0           return map {'$'.$_} grep { index($_,$1)==0 } XML::XSH2::Functions::string_vars;
  0            
  0            
137             } elsif ($part=~$match_option) {
138 0           return complete_option($part);
139             } elsif ($part=~$match_func) {
140 0           return grep { index($_,$1)==0 } XML::XSH2::Functions::defs;
  0            
141             } elsif ($part=~$match_nodetype) {
142 0           return grep { index($_,$1)==0 } @nodetypes;
  0            
143             } elsif ($part=~$match_help) {
144 0           return grep { index($_,$1)==0 } keys %XML::XSH2::Help::HELP;
  0            
145             } elsif ($part=~$match_command) {
146 0           return grep { index($_,$word)==0 } @XML::XSH2::CompletionList::XSH_COMMANDS,
  0            
147             XML::XSH2::Functions::defs();
148             } elsif ($part=~$match_filename) {
149 0           my @result=complete_filename($type,$word);
150 0 0 0       if (@result==1 and -d $result[0]) {
151 0           complete_set_term_char($type,'');
152             } else {
153 0           complete_set_term_char($type,' ');
154             }
155 0           return @result;
156             } elsif ($part=~$match_dir) {
157 0           my @result=grep -d, complete_filename($type,$word);
158 0 0         if (@result==1) {
159 0           complete_set_term_char($type,' ');
160             } else {
161 0           complete_set_term_char($type,'');
162             }
163 0           return @result;
164             } elsif ($part=~$match_path_filename) {
165 0 0         my $subst = ($word =~ s/^(\!)//) ? '!' : '';
166 0           my @result=map { $subst.$_ } complete_system_command($type,$word);
  0            
167 0 0 0       if (@result==1 and -d $result[0]) {
168 0           complete_set_term_char($type,'');
169             } else {
170 0           complete_set_term_char($type,' ');
171             }
172 0           return @result;
173             } else {
174 0           complete_set_term_char($type,'');
175 0           return xpath_complete($line,$word,$pos);
176             }
177             }
178              
179             sub xpath_complete_str {
180 0     0 0   my $str = reverse($_[0]);
181 0           my $debug = $_[1];
182 0           my $result="";
183              
184 0 0         print "'$str'\n" if $debug;
185 0           my $localmatch;
186              
187             STEP0:
188 0 0         if ($str =~ /\G\s*[\]\)]/gsco) {
189 0 0         print "No completions after ] or )\n" if $debug;
190 0           return;
191             }
192              
193             STEP1:
194 0 0         if ( $str =~ /\G($NAMECHAR+)?(?::($NAMECHAR+))?/gsco ) {
195 0           my $name = reverse($1);
196 0           my $prefix = reverse($2);
197 0 0         if ($prefix ne "") {
198 0           $localmatch=$prefix.":".$name;
199             # my $uri = get_registered_ns($prefix);
200             # my $base='';
201             # if ($uri ne "") {
202             # $base=$prefix.':*[namespace-uri()="'.$uri.'"]';
203             # } else {
204             # $base=$prefix.':*';
205             # }
206 0 0         if ($name ne "") {
207 0           $result=$prefix.':*[starts-with(local-name(),"'.$name.'")]'.$result;
208             } else {
209 0           $result=$prefix.':*'.$result;
210             }
211             } else {
212 0           $localmatch=$name;
213 0           $result='*[namespace-uri()="" and starts-with(name(),"'.$localmatch.'")]'.$result;
214             }
215             } else {
216 0           $result='*'.$result;
217             }
218 0 0         if ($str =~ /\G\@/gsco) {
219 0           $result="@".$result;
220             }
221              
222             STEP2:
223 0 0         print "STEP2-LOCALMATCH: $localmatch\n" if $debug;
224 0 0         print "STEP2: $result\n" if $debug;
225 0 0         print "STEP2-STR: ".reverse(substr($str,pos($str)))."\n" if $debug;
226 0           while ($str =~ m/\G(::|:|\@|$NAME\$?|\/\/|\/|$WILDCARD|\)|\])/gsco) {
227 0 0         print "STEP2-MATCH: '$1'\n" if $debug;
228 0 0 0       if ($1 eq ')' or $1 eq ']') {
229             # eat ballanced upto $1
230 0 0         my @ballance=(($1 eq ')' ? '(' : '['));
231 0           $result=$1.$result;
232 0 0         print "STEP2: Ballanced $1\n" if $debug;
233 0           do {
234 0 0         $result=reverse($1).$result if $str =~ m/\G([^]["'()]+)/gsco; # skip normal characters
235 0 0         return ($result,$localmatch) unless $str =~ m/\G(.)/gsco;
236 0 0         if ($1 eq $ballance[$#ballance]) {
    0          
    0          
    0          
    0          
237 0           pop @ballance;
238             } elsif ($1 eq ')') {
239 0           push @ballance, '(';
240             } elsif ($1 eq ']') {
241 0           push @ballance, '[';
242             } elsif ($1 eq '"') {
243 0           push @ballance, '"';
244             } elsif ($1 eq "'") {
245 0           push @ballance, "'";
246             } else {
247 0           print STDERR "Error 2: lost in an expression on '$1' ";
248 0           print STDERR reverse(substr($str,pos()))."\n";
249 0           print "-> $result\n";
250 0           return undef;
251             }
252 0           $result=$1.$result;
253             } while (@ballance);
254             } else {
255 0           $result=reverse($1).$result;
256             }
257             }
258              
259             STEP3:
260 0 0         print "STEP3: $result\n" if $debug;
261 0 0         print "STEP3-STR: ".reverse(substr($str,pos($str)))."\n" if $debug;
262 0 0         if (substr($result,0,1) eq '/') {
263 0 0         if ($str =~ /\G['"]/gsco) {
    0          
264 0           return undef;
265             } elsif ($str =~ /\G(?:\s+['"]|\(|\[|$OPER)/gsco) {
266 0           return ($result,$localmatch);
267             }
268 0           return ($result,$localmatch); # uncertain!!!
269             } else {
270 0 0         return ($result,$localmatch) if ($str=~/\G\s+(?=$OPER)/gsco);
271             }
272              
273 0 0         STEP4:
274             print "STEP4: $result\n" if $debug;
275 0 0         print "STEP4-STR: ".reverse(substr($str,pos($str)))."\n" if $debug;
276 0           my @ballance;
277 0           do {
278 0           $str =~ m/\G([^]["'()]+)/gsco; # skip normal characters
279 0 0         print "STEP4-MATCH '".reverse($1)."'\n" if $debug;
280 0 0         return ($result,$localmatch) unless $str =~ m/\G(.)/gsco;
281 0 0         print "STEP4-BALLANCED '$1'\n" if $debug;
282 0 0 0       if (@ballance and $1 eq $ballance[$#ballance]) {
    0 0        
    0          
    0          
    0          
    0          
283 0           pop @ballance;
284             } elsif ($1 eq ')') {
285 0           push @ballance, '(';
286             } elsif ($1 eq ']') {
287 0           push @ballance, '[';
288             } elsif ($1 eq '"') {
289 0           push @ballance, '"';
290             } elsif ($1 eq "'") {
291 0           push @ballance, "'";
292             } elsif (not(@ballance) and $1 eq '[') {
293 0 0         print "STEP4-PRED2STEP '$1'\n" if $debug;
294 0           $result='/'.$result;
295 0           goto STEP2;
296             }
297             } while (@ballance);
298 0           goto STEP4;
299             }
300              
301             sub xpath_complete {
302 0     0 0   my ($line, $word,$pos)=@_;
303 0 0         return () unless $XML::XSH2::Functions::XPATH_COMPLETION;
304 0           my $str=XML::XSH2::Functions::toUTF8($XML::XSH2::Functions::QUERY_ENCODING,
305             substr($line,0,$pos).$word);
306 0           my ($xp,$local) = xpath_complete_str($str,0);
307             # XML::XSH2::Functions::__debug("COMPLETING $_[0] local $local as $xp\n");
308 0 0         return () if $xp eq "";
309 0           local $XML::XSH2::Functions::ERRORS;
310 0           local $XML::XSH2::Functions::WARNINGS;
311 0           my $ql= XML::XSH2::Functions::_ev_nodelist($xp);
312 0 0         return () if $@;
313              
314 0           my %names;
315 0 0         my $prefix = ($local=~/^($NAMECHAR+:)/) ? $1 : '';
316             @names{ map {
317 0           XML::XSH2::Functions::fromUTF8($XML::XSH2::Functions::QUERY_ENCODING,
  0            
318             substr(substr($str,0,
319             length($str)
320             -length($local)).
321             $prefix.$_->nodeName(),$pos))
322             } grep defined, @$ql}=();
323              
324 0           my @completions = sort { $a cmp $b } keys %names;
  0            
325             # print "completions so far: @completions\n";
326              
327 0 0 0       if (($XML::XSH2::Functions::XPATH_AXIS_COMPLETION eq 'always' or
      0        
      0        
328             $XML::XSH2::Functions::XPATH_AXIS_COMPLETION eq 'when-empty' and !@completions)
329             and $str =~ /[ \n\t\r|([=<>+-\/]([[:alpha:]][-:[:alnum:]]*)?$/ and $1 !~ /::/) {
330             # complete XML axis
331 0           my ($pre,$axpart)=($word =~ /^(.*[^-:[:alnum:]])?([[:alpha:]][-[:alnum:]:]*)/);
332             # print "\nWORD: $word\nPRE: $pre\nPART: $axpart\nSTR:$str\n";
333 0           foreach my $axis (qw(following-sibling following preceding
334             preceding-sibling
335             parent ancestor ancestor-or-self descendant self
336             descendant-or-self child attribute namespace)) {
337 0 0         if ($axis =~ /^\Q$axpart\E/) {
338 0           push @completions, "${pre}${axis}::";
339             }
340             }
341              
342 0 0         unless ($pre=~m{/$}) {
343 0           foreach my $func (qw(boolean ceiling comment concat contains count
344             document false
345             floor id lang last local-name name
346             namespace-uri node normalize-space not number
347             position processing-instruction round
348             starts-with string string-length substring
349             substring-after substring-before sum
350             text translate true),
351 0           (map { 'xsh:'.$_ } XML::XSH2::Functions::get_XPATH_extensions()),
352 0 0         map { /^(.*)\n(.*)$/s ?
353             XML::XSH2::Functions::get_registered_prefix($2).":$1" : $_
354             } keys %XML::XSH2::Functions::_func,
355             ) {
356 0 0         if ($func =~ /^\Q$axpart\E/) {
357 0           push @completions, "${pre}${func}(";
358             }
359             }
360             }
361             }
362 0           return @completions;
363             }
364              
365             1;
366              
367