File Coverage

blib/lib/Term/TUI.pm
Criterion Covered Total %
statement 18 177 10.1
branch 0 94 0.0
condition 0 26 0.0
subroutine 7 21 33.3
pod 4 4 100.0
total 29 322 9.0


line stmt bran cond sub pod time code
1             package Term::TUI;
2             # Copyright (c) 1999-2021 Sullivan Beck. All rights reserved.
3             # This program is free software; you can redistribute it and/or modify it
4             # under the same terms as Perl itself.
5              
6             ########################################################################
7             # TODO
8             ########################################################################
9              
10             # improve completion:
11             # /math
12             # ad
13             # completes correctly to add but
14             # /math/ad
15             # doesn't autocomplete.
16              
17             # add abbreviation
18              
19             # case insensitivity
20              
21             # add .. and . to valid mode strings
22              
23             # "Hr. Jochen Stenzel"
24             # alias command
25             # history file (stored last commands)
26              
27             # config file (store commands to execute)
28              
29             ########################################################################
30              
31 2     2   15888 use warnings;
  2         11  
  2         79  
32 2     2   12 use vars qw($VERSION);
  2         3  
  2         117  
33             $VERSION="1.24";
34              
35             require 5.000;
36             require Exporter;
37              
38 2     2   1039 use Term::ReadLine;
  2         5521  
  2         68  
39 2     2   1002 use Text::ParseWords;
  2         2727  
  2         231  
40             #use Text::Abbrev;
41              
42             @ISA = qw(Exporter);
43             @EXPORT = qw(TUI_Run);
44             @EXPORT_OK = qw(TUI_Script TUI_Out TUI_Version);
45             %EXPORT_TAGS = (all => [ @EXPORT, @EXPORT_OK ]);
46              
47             $| = 1;
48              
49 2     2   16 use strict "vars";
  2         4  
  2         1219  
50              
51             sub TUI_Version {
52 0     0 1   return $VERSION;
53             }
54              
55 0         0 BEGIN {
56 2     2   3196 our($term,$out);
57              
58             #
59             # Takes a program name (to be used in the prompt) and an interface
60             # description, and runs with it.
61             #
62              
63             #
64             # Interactive version.
65             #
66             sub TUI_Run {
67 0     0 1   my($program,$hashref)=@_;
68 0           my(@mode,$line,$err);
69 0           my($prompt)="$program> ";
70 0           $term=new Term::ReadLine $program;
71 0           $term->ornaments(0);
72              
73             # Command line completion
74 0           $term->Attribs->{'do_expand'}=1;
75             $term->Attribs->{'completion_entry_function'} =
76 0           $term->Attribs->{'list_completion_function'};
77              
78 0   0       $out=$term->OUT || STDOUT;
79              
80 0           my($ret)=0;
81              
82             # Command line completion
83             # The strings for completion
84 0           my(@completions) = _GetStrings(\@mode,$hashref);
85 0           $term->Attribs->{'completion_word'} = \@completions;
86              
87 0           while (defined ($line=$term->readline($prompt)) ) {
88 0           $err=_Line(\@mode,$hashref,$line);
89              
90             # Command line completion
91 0           @completions = _GetStrings(\@mode,$hashref);
92 0           $term->Attribs->{'completion_word'} = \@completions;
93              
94 0 0 0       if ($err && $err =~ /^exit\[(\d+)\]$/) {
95 0           $ret=$1;
96 0           last;
97             }
98 0 0 0       print $out $err if ($err && $err !~ /^\d+$/);
99              
100 0 0         if (@mode) {
101 0           $prompt=$program . ":" . join("/",@mode) . "> ";
102             } else {
103 0           $prompt="$program> ";
104             }
105             }
106 0           return $ret;
107             }
108              
109             #
110             # Non-interactive version.
111             #
112             sub TUI_Script {
113 0     0 1   my($hashref,$script,$sep)=@_;
114 0           $out=STDOUT;
115              
116 0 0         $sep=";" if (! $sep);
117 0           my(@cmd)=split(/$sep/,$script);
118              
119 0           my($err,$cmd,@mode);
120 0           my($ret)=0;
121 0           foreach $cmd (@cmd) {
122 0           $err=_Line(\@mode,$hashref,$cmd);
123 0 0         if ($err =~ /^exit\[(\d+)\]$/) {
124 0           $ret=$1;
125 0           last;
126             }
127 0 0         print $out $err if ($err);
128             }
129 0           return $ret;
130             }
131              
132             #
133             # Prints a message.
134             #
135             sub TUI_Out {
136 0     0 1   my($mess)=@_;
137 0           print $out $mess;
138             }
139             }
140              
141              
142             ########################################################################
143             # NOT FOR EXPORT
144             ########################################################################
145              
146             {
147             # Stuff for doing completion.
148              
149             my $i;
150             my @matches;
151              
152             sub _TUI_completion_function {
153 0     0     my($text,$state)=@_;
154 0 0         $i = ($state ? $i : 0);
155              
156 0 0         if (! $i) {
157 0 0         if ($text =~ /^\s*(\S+)\s+(\S+)$/) {
    0          
    0          
158             # MODE CMD^
159             # completes CMD
160             # MODE/CMD OPTION^
161             # no matches
162              
163             } elsif ($text =~ /^\s*(\S+)\s+$/) {
164             # MODE ^
165             # completes CMD
166             # MODE/CMD ^
167             # no matches
168              
169             } elsif ($text =~ /^\s*(\S+)$/) {
170             # MODE^
171             # MODE/CMD^
172              
173             } else {
174 0           @matches=();
175             }
176             }
177             }
178             }
179              
180             #
181             # Takes the current mode (as a list), the interface description, and
182             # the current line and acts on the line.
183             #
184             sub _Line {
185 0     0     my($moderef,$cmdref,$line)=@_;
186              
187 0           $line =~ s/\s+$//;
188 0           $line =~ s/^\s+//;
189 0 0         return if (! $line);
190              
191 0           my(@cmd)=shellwords($line);
192 0           return _Cmd($moderef,$cmdref,@cmd);
193             }
194              
195 0           BEGIN {
196 2     2   37 my(%Cmds) =
197             (
198             ".." => [ "Go up one level", "_Mode",0 ],
199             "/" => [ "Go to top level", "_Mode",1 ],
200             "help" => [ "Online help", "_Help" ],
201             "exit" => [ "Exit", "_Exit",0 ],
202             "quit" => [ "An alias for exit", "_Exit",0 ],
203             "abort" => [ "Exit without saving", "_Exit",1 ]
204             );
205 2         292 my($Moderef,$Cmdref);
206              
207             #
208             # Returns an array of strings (commands or modes) that can be
209             # entered given a mode
210             #
211             sub _GetStrings {
212 0     0     my ($moderef,$cmdref) = @_;
213 0           my @strings;
214              
215 0 0 0       if (!defined $Cmdref || ref $Cmdref ne "HASH") {
216 0           $Cmdref = $cmdref;
217             }
218 0           my $desc = _GetMode(@{$moderef});
  0            
219 0 0         if ( ref $desc eq "HASH" ) {
220 0           @strings = grep !/^\./, sort keys %$desc;
221             }
222 0           push @strings,keys %Cmds;
223 0           return @strings;
224             }
225              
226             #
227             # Takes the current mode (as a list), the interface description, and the
228             # current command (as a list) and executes the command.
229             #
230             sub _Cmd {
231 0     0     my($moderef,$cmdref,@args)=@_;
232 0           my($cmd)=shift(@args);
233 0           $Moderef=$moderef;
234 0           $Cmdref=$cmdref;
235 0           my(@mode,$desc,$mode,$help);
236              
237 0 0         if (exists $Cmds{lc $cmd}) {
238 0           $desc=$Cmds{lc $cmd};
239              
240             } else {
241 0           ($mode,@mode)=_CheckMode(\$cmd);
242              
243 0 0 0       if ($mode && $cmd) {
    0 0        
    0          
244             #
245             # MODE/CMD [ARGS]
246             # CMD [ARGS]
247             #
248 0           $desc=_CheckCmd($mode,$cmd);
249              
250             } elsif ($mode && @args) {
251             #
252             # MODE CMD [ARGS]
253             #
254 0           $cmd=shift(@args);
255 0           $desc=_CheckCmd($mode,$cmd);
256              
257             } elsif ($mode) {
258             #
259             # MODE
260             #
261 0           $desc=[ "","_Mode",2,@mode ]
262             }
263             }
264              
265 0           my(@args0);
266 0 0         if (ref $desc eq "ARRAY") {
267 0           ($help,$cmd,@args0)=@$desc;
268 0 0         if (! defined &$cmd) {
269 0           $cmd="::$cmd";
270 0 0         if (! defined &$cmd) {
271 0           return "ERROR: invalid subroutine\n";
272             }
273             }
274 0           return &$cmd(@args0,@args);
275             } else {
276 0           return "ERROR: unknown command\n";
277             }
278             }
279              
280             #
281             # Takes a mode and/or command (as a list) and determines the mode
282             # to use. Returns a description of that mode.
283             #
284             sub _CheckMode {
285 0     0     my($cmdref)=@_;
286 0           my($cmd)=$$cmdref;
287 0           my(@mode,$tmp2);
288              
289 0 0         if ($cmd =~ s,^/,,) {
290 0           @mode=split(m|/|,$cmd);
291             } else {
292 0           @mode=(@$Moderef,split(m|/|,$cmd));
293             }
294              
295 0           my($tmp)=_GetMode(@mode);
296 0 0         if ($tmp) {
297 0           $$cmdref="";
298             } else {
299 0           $tmp2=pop(@mode);
300 0           $tmp=_GetMode(@mode);
301 0 0         $$cmdref=$tmp2 if ($tmp);
302             }
303              
304 0 0         @mode=() if (! $tmp);
305 0           return ($tmp,@mode);
306             }
307              
308             #
309             # Takes a mode (as a list) and returns it's description (or "" if it's
310             # not a mode).
311             #
312             sub _GetMode {
313 0     0     my(@mode)=@_;
314 0           my($tmp)=$Cmdref;
315 0           my($mode);
316              
317 0           foreach $mode (@mode) {
318 0 0 0       if (exists $$tmp{$mode} &&
319             ref $$tmp{$mode} eq "HASH") {
320 0           $tmp=$$tmp{$mode};
321             } else {
322 0           $tmp="";
323 0           last;
324             }
325             }
326 0           $tmp;
327             }
328              
329             ##############################################
330              
331             #
332             # A command to change the mode.
333             # .. op=0
334             # / op=1
335             # MODE op=2
336             #
337             sub _Mode {
338 0     0     my($op,@mode)=@_;
339              
340 0 0         if ($op==0) {
    0          
    0          
341             # Up one level
342 0 0         if ($#$Moderef>=0) {
343 0           pop(@$Moderef);
344             } else {
345 0           return "WARNING: Invalid operation\n";
346             }
347              
348             } elsif ($op==1) {
349             # Top
350 0           @$Moderef=();
351              
352             } elsif ($op==2) {
353             # Change modes
354 0           @$Moderef=@mode;
355              
356             } else {
357 0           return "ERROR: Invalid mode operation: $op\n";
358             }
359 0           return "";
360             }
361              
362             sub _Help {
363 0     0     my($cmd,@args)=@_;
364              
365 0           my($tmp,$mode,@mode);
366              
367 0 0         ($tmp,@mode)=_CheckMode(\$cmd) if ($cmd);
368 0 0         if (! $tmp) {
369 0           @mode=@$Moderef;
370 0 0         if (@mode) {
371 0           $tmp=_GetMode(@mode);
372             } else {
373 0           $tmp=$Cmdref;
374             }
375             }
376              
377 0 0         return "IMPOSSIBLE: invalid mode\n" if (! $tmp);
378              
379 0           my($mess);
380 0 0 0       $cmd=shift(@args) if (! $cmd && @args);
381 0 0         if ($cmd) {
382             #
383             # Help on a command
384             #
385 0 0         if (exists $Cmds{$cmd}) {
    0          
386 0           $tmp=$Cmds{$cmd};
387 0           $mess=$$tmp[0];
388              
389             } elsif (exists $$tmp{$cmd}) {
390 0           $tmp=$$tmp{$cmd};
391 0 0         if (ref $tmp ne "ARRAY") {
392 0           $mess="Invalid command $cmd";
393             } else {
394 0           $mess=$$tmp[0];
395 0 0         $mess="No help available" if (! $mess);
396             }
397             } else {
398 0           $mess="Invalid command: $cmd";
399             }
400              
401             } else {
402             #
403             # Help on a mode
404             #
405 0 0         if (exists $$tmp{".HELP"}) {
406 0           $mess=$$tmp{".HELP"};
407 0           my(@gc)=sort grep /^([^.]|\.\.)/i,keys %Cmds;
408 0           my(@cmd)=sort grep /^[^.]/,keys %{ $tmp };
  0            
409 0           my(@m,@c)=();
410 0           foreach $cmd (@cmd) {
411 0 0         if (ref $$tmp{$cmd} eq "ARRAY") {
    0          
412 0           push(@c,$cmd);
413             } elsif (ref $$tmp{$cmd} eq "HASH") {
414 0           push(@m,$cmd);
415             }
416             }
417 0           $mess .= "\n\nAdditional help:\n\n";
418 0 0         $mess .= " Modes: @m\n" if (@m);
419 0           $mess .= " Cmds : @gc";
420 0 0         $mess .= "\n" if (@c);
421 0 0         $mess .= " @c" if (@c);
422              
423             } else {
424 0           $mess="No help available";
425             }
426             }
427              
428 0           return "\n$mess\n\n";
429             }
430             }
431              
432             #
433             # Takes a mode and command and return a description of the command.
434             #
435             sub _CheckCmd {
436 0     0     my($moderef,$cmd)=@_;
437             return $$moderef{$cmd}
438             if (exists $$moderef{$cmd} &&
439 0 0 0       ref $$moderef{$cmd} eq "ARRAY");
440 0           return ();
441             }
442              
443             sub _Exit {
444 0     0     my($flag)=@_;
445 0           return "exit[$flag]";
446             }
447              
448             # sub {
449             # map {lc($_)} (keys %commands, keys %aliases)
450             # };
451              
452             # $term->Attribs->{'do_expand'}=1;
453             # $term->Attribs->{'completion_entry_function'} =
454             # sub {
455             # $term->Attribs->{'line_buffer'} =~ /\s/ ?
456             # &{$term->Attribs->{'filename_completion_function'}}(@_) :
457             # &{$term->Attribs->{'list_completion_function'}}(@_)
458             # };
459             # $term->Attribs->{'completion_word'}=[(map {lc($_)} (keys %commands))];
460              
461             1;
462             # Local Variables:
463             # mode: cperl
464             # indent-tabs-mode: nil
465             # cperl-indent-level: 3
466             # cperl-continued-statement-offset: 2
467             # cperl-continued-brace-offset: 0
468             # cperl-brace-offset: 0
469             # cperl-brace-imaginary-offset: 0
470             # cperl-label-offset: -2
471             # End: