File Coverage

blib/lib/Metabrik/Core/Shell.pm
Criterion Covered Total %
statement 18 723 2.4
branch 0 274 0.0
condition 0 222 0.0
subroutine 6 56 10.7
pod 40 40 100.0
total 64 1315 4.8


line stmt bran cond sub pod time code
1             #
2             # $Id: Shell.pm,v a38b58d4db2f 2019/03/13 10:00:56 gomor $
3             #
4             # core::shell Brik
5             #
6             package Metabrik::Core::Shell;
7 1     1   750 use strict;
  1         2  
  1         29  
8 1     1   5 use warnings;
  1         2  
  1         50  
9              
10             # Breaking.Feature.Fix
11             our $VERSION = '1.40';
12             our $FIX = '0';
13              
14 1     1   5 use base qw(Term::Shell Metabrik);
  1         3  
  1         668  
15              
16 1     1   12957 use IO::All;
  1         12254  
  1         11  
17              
18             sub brik_properties {
19             return {
20 0     0 1   revision => '$Revision: a38b58d4db2f $',
21             tags => [ qw(main core) ],
22             attributes => {
23             echo => [ qw(0|1) ],
24             help_show_base_attributes => [ qw(0|1) ],
25             help_show_base_commands => [ qw(0|1) ],
26             help_show_base_all => [ qw(0|1) ], # Both Attributes and Commands
27             help_show_inherited_attributes => [ qw(0|1) ],
28             help_show_inherited_commands => [ qw(0|1) ],
29             help_show_inherited_all => [ qw(0|1) ], # Both Attributes and Commands
30             help_show_all => [ qw(0|1) ], # Both Attributes and Commands for base and inherited
31             comp_show_base_attributes => [ qw(0|1) ],
32             comp_show_base_commands => [ qw(0|1) ],
33             comp_show_base_all => [ qw(0|1) ],
34             comp_show_inherited_attributes => [ qw(0|1) ],
35             comp_show_inherited_commands => [ qw(0|1) ],
36             comp_show_inherited_all => [ qw(0|1) ], # Both Attributes and Commands
37             comp_show_all => [ qw(0|1) ], # Both Attributes and Commands for base and inherited
38             show_base_attributes => [ qw(0|1) ],
39             show_base_commands => [ qw(0|1) ],
40             show_base_all => [ qw(0|1) ],
41             show_inherited_attributes => [ qw(0|1) ],
42             show_inherited_commands => [ qw(0|1) ],
43             show_inherited_all => [ qw(0|1) ],
44             show_all => [ qw(0|1) ], # Both Attributes and Commands for base and inherited
45             aliases_completion => [ qw(0|1) ], # Complete aliases to show original Command
46             ps1 => [ qw(prompt) ],
47             capture_mode => [ qw(0|1) ],
48             # These are used by Term::Shell
49             #path_home => [ qw(directory) ],
50             #path_cwd => [ qw(directory) ],
51             #prompt => [ qw(string) ],
52             #_aliases => [ qw(INTERNAL) ],
53             #_executables => [ qw(INTERNAL) ],
54             },
55             attributes_default => {
56             echo => 1,
57             help_show_base_attributes => 0,
58             help_show_base_commands => 0,
59             help_show_base_all => 0,
60             help_show_inherited_attributes => 0,
61             help_show_inherited_commands => 0,
62             help_show_inherited_all => 0,
63             help_show_all => 0,
64             comp_show_base_attributes => 0,
65             comp_show_base_commands => 0,
66             comp_show_base_all => 0,
67             comp_show_inherited_attributes => 0,
68             comp_show_inherited_commands => 0,
69             comp_show_inherited_all => 0,
70             comp_show_all => 0,
71             show_base_attributes => 0,
72             show_base_commands => 0,
73             show_base_all => 0,
74             show_inherited_attributes => 0,
75             show_inherited_commands => 0,
76             show_inherited_all => 0,
77             show_all => 0,
78             aliases_completion => 0,
79             #capture_mode => 1,
80             capture_mode => 0, # Do not capture by default.
81             # It makes users uncertain of what is happening
82             # when executing any external command.
83             },
84             commands => {
85             splash => [ ],
86             pwd => [ ],
87             full_pwd => [ ],
88             get_available_help => [ ],
89             get_help_attributes => [ qw(Brik) ],
90             get_help_commands => [ qw(Brik) ],
91             get_comp_attributes => [ qw(Brik) ],
92             get_comp_commands => [ qw(Brik) ],
93             # Term::Shell stuff
94             cmd => [ qw(Cmd) ],
95             cmdloop => [ ],
96             run_use => [ qw(Brik) ],
97             run_help => [ qw(Brik) ],
98             run_set => [ qw(Brik Attribute Value) ],
99             run_get => [ qw(Brik) ],
100             run_run => [ qw(Brik Command) ],
101             run_alias => [ qw(alias Cmd) ],
102             run_cd => [ qw(directory) ],
103             run_code => [ qw(Code) ],
104             run_exit => [ ],
105             },
106             require_modules => {
107             'Data::Dump' => [ qw(dump) ],
108             'File::HomeDir' => [ ],
109             'Cwd' => [ ],
110             'PPI' => [ ],
111             },
112             };
113             }
114              
115             sub new {
116             # Call Term::Shell new()
117 0     0 1   my $self = shift->SUPER::new(@_);
118              
119             # Call Metabrik new()
120 0           $self->Metabrik::new(@_);
121              
122             # We have to set of default_attributes again normally called by Brik::new():
123             # Otherwise default attributes are not set properly because of Perl inheritance scheme
124 0           $self->brik_set_default_attributes;
125              
126             # Now write Term::Shell default values we gave, like context, global, log, ...
127 0           my %h = @_;
128 0           for my $k (keys %h) {
129 0           $self->{$k} = $h{$k};
130             }
131              
132 0           return $self;
133             }
134              
135             sub brik_init {
136 0     0 1   my $self = shift;
137              
138             # Allow user to break out of multiline mode or run Commands
139             # Note: Gnu readline() is blocking SIGs, we have to hit enter so
140             # Ctrl+C is executed.
141             $SIG{INT} = sub {
142 0 0   0     $self->log->debug("SIGINT: captured for pid[$$] ".
143             ($$ == $self->global->pid ? '(main process)' : '')
144             );
145 0           $self->_update_prompt;
146 0 0         if ($self->global->exit_on_sigint) {
147 0           $self->run_exit;
148             }
149 0           return 1;
150 0           };
151              
152             # Gather executable files from PATH
153 0   0       my @path = split(':', ($ENV{PATH} || ''));
154 0           my %executables = ();
155 0           for my $path (@path) {
156 0           my @files = ();
157 0           eval {
158 0           @files = io($path)->all_files;
159             };
160 0 0         if ($@) {
161 0           chomp($@);
162 0           $self->log->debug("brik_init: $path: all_files: $@");
163 0           next;
164             };
165 0           for my $file (@files) {
166 0 0         if ($file->is_executable) {
167 0           my $filename = $file->filename;
168 0           $executables{$filename}++;
169              
170             # Without a handler, we would not be able to autoload the run Command
171 0           $self->add_handler("run_$filename");
172             }
173             }
174             }
175              
176 0           $self->{_executables} = \%executables;
177              
178 0           return $self->SUPER::brik_init(@_);
179             }
180              
181             sub splash {
182 0     0 1   my $self = shift;
183              
184             # No context, no splash screen cause nothing to show.
185 0 0         if (! defined($self->context)) {
186 0           return 1;
187             }
188              
189 0           my $con = $self->context;
190              
191 0           my $version = $con->run('core::global', 'brik_version');
192              
193 0           my $available_count = keys %{$con->available};
  0            
194 0           my $used_count = keys %{$con->used};
  0            
195              
196             # ASCII art courtesy: http://patorjk.com/software/taag/#p=testall&f=Graffiti&t=MetabriK
197 0           print<
198              
199             ███▄ ▄███▓▓█████▄▄▄█████▓ ▄▄▄ ▄▄▄▄ ██▀███ ██▓ ██ ▄█▀
200             ▓██▒▀█▀ ██▒▓█ ▀▓ ██▒ ▓▒▒████▄ ▓█████▄ ▓██ ▒ ██▒▓██▒ ██▄█▒
201             ▓██ ▓██░▒███ ▒ ▓██░ ▒░▒██ ▀█▄ ▒██▒ ▄██▓██ ░▄█ ▒▒██▒▓███▄░
202             ▒██ ▒██ ▒▓█ ▄░ ▓██▓ ░ ░██▄▄▄▄██ ▒██░█▀ ▒██▀▀█▄ ░██░▓██ █▄
203             ▒██▒ ░██▒░▒████▒ ▒██▒ ░ ▓█ ▓██▒░▓█ ▀█▓░██▓ ▒██▒░██░▒██▒ █▄
204             ░ ▒░ ░ ░░░ ▒░ ░ ▒ ░░ ▒▒ ▓▒█░░▒▓███▀▒░ ▒▓ ░▒▓░░▓ ▒ ▒▒ ▓▒
205             ░ ░ ░ ░ ░ ░ ░ ▒ ▒▒ ░▒░▒ ░ ░▒ ░ ▒░ ▒ ░░ ░▒ ▒░
206             ░ ░ ░ ░ ░ ▒ ░ ░ ░░ ░ ▒ ░░ ░░ ░
207             ░ ░ ░ ░ ░ ░ ░ ░ ░ ░
208            
209              
210             --[ Welcome to Metabrik - Knowledge is in your head, Detail is in the code ]--
211             --[ Briks available: $available_count ]--
212             --[ Briks used: $used_count ]--
213             --[ Version $version ]--
214              
215             There is a Brik for that.
216              
217             EOF
218             ;
219              
220 0           return 1;
221             }
222              
223             sub pwd {
224 0     0 1   my $self = shift;
225              
226 0           return $self->{path_cwd};
227             }
228              
229             sub full_pwd {
230 0     0 1   my $self = shift;
231              
232 0           my $global = $self->global;
233              
234 0           my $pwd = $self->pwd;
235 0           my $homedir = $global->homedir;
236              
237 0           $pwd =~ s{^~}{$homedir};
238              
239 0           return $pwd;
240             }
241              
242             sub get_available_help {
243 0     0 1   my $self = shift;
244              
245 0 0         if (! defined($self->context)) {
246 0           return $self->log->error("get_available_help: no core::context Brik");
247             }
248              
249 0           my @used = sort { $a cmp $b } keys %{$self->context->used};
  0            
  0            
250 0           my @aliases = sort { $a cmp $b } keys %{$self->{_aliases}};
  0            
  0            
251 0           my @commands = sort { $a cmp $b } keys %{$self->brik_commands};
  0            
  0            
252              
253             # Skip class functions
254 0           @commands = grep (!/^brik_/, @commands);
255              
256             # Remove leading run_ string
257 0           for (@aliases, @commands) {
258 0           s/^run_//;
259             }
260              
261 0           return { briks => \@used, aliases => \@aliases, commands => \@commands };
262             }
263              
264             #
265             # Term::Shell stuff
266             #
267             our $AUTOLOAD;
268              
269             sub AUTOLOAD {
270 0     0     my $self = shift;
271 0           my (@args) = @_;
272              
273             #$self->log->debug("autoload[$AUTOLOAD]");
274              
275 0 0         if ($AUTOLOAD !~ /^Metabrik::Core::Shell::run_/) {
276 0           return 1;
277             }
278              
279 0           (my $command = $AUTOLOAD) =~ s/^Metabrik::Core::Shell:://;
280              
281             #$self->log->debug("AUTOLOAD: command[$command] args[@args]");
282              
283             #my $aliases = $self->_aliases;
284 0           my $aliases = $self->{_aliases};
285 0 0         if (exists($aliases->{$command})) {
286 0           my $cmd = $aliases->{$command};
287 0           return $self->cmd(join(' ', $cmd, @args));
288             }
289              
290 0 0         if (! defined($self->context)) {
291 0           return $self->log->error("AUTOLOAD: no core::context Brik");
292             }
293              
294 0           my $context = $self->context;
295              
296 0 0         if ($context->is_used('shell::command')) {
297 0 0         my $sc_command = $self->capture_mode ? 'capture' : 'system';
298 0           (my $exec = $command) =~ s/^run_//;
299 0           my $executables = $self->{_executables};
300 0 0         if (exists($executables->{$exec})) {
301 0           my $cmd = "run shell::command $sc_command $exec";
302 0           return $self->cmd(join(' ', $cmd, @args));
303             }
304             }
305             else {
306 0           $self->log->verbose("AUTOLOAD: Brik [shell::command] not loaded, skipping");
307             }
308              
309 0           return 1;
310             }
311              
312             #sub _word_may_be_brik {
313             # my $self = shift;
314             # my ($word) = @_;
315             #
316             # my $context = $self->context;
317             # my $used = $context->used;
318             #
319             # for (keys %$used) {
320             # return $used if /^$word/;
321             # }
322             #
323             # return 0;
324             #}
325              
326             # We overwrite inherited Term::Shell rl_complete() sub to have control
327             sub rl_complete {
328 0     0 1   my $self = shift;
329 0           my ($word, $line, $start) = @_;
330              
331 0           my @comp = ();
332              
333             # If it's a command, complete 'run_'.
334             # For that, command must not be blank and not start with '/'.
335 0 0 0       if (($start == 0 || substr($line, 0, $start) =~ /^\s*$/)
      0        
336             && ($word !~ m{/})) {
337 0           $self->log->debug("rl_complete: word[$word] start[$start] line[$line]");
338 0           @comp = $self->complete('', $word, $line, $start);
339              
340 0           $self->log->debug("rl_complete: comp[@comp]");
341              
342             # XXX: broken feature since Term::ReadLine::Gnu 1.27
343             # If we found something and it's an alias, we complete with the original command
344             #if (defined($comp[0]) && $self->comp_aliases && exists($self->{_aliases}{"run_".$comp[0]})) {
345             #$self->log->debug("rl_complete: original[".$self->{_aliases}{"run_$comp[0]"}."]");
346              
347             #my @words = split(/\s+/, $self->{_aliases}{"run_$comp[0]"});
348             #if (exists($self->{_aliases}{"run_$words[0]"})) {
349             #@comp = $self->{_aliases}{"run_".$words[0]};
350             #}
351             #else {
352             #@comp = $self->{_aliases}{"run_$comp[0]"};
353             #}
354             #}
355             ## Or maybe it's a Brik, and we want to prefix it automagically with 'run' Command
356             #elsif (my $available = $self->_word_may_be_brik($word)) {
357             #for (keys %$available) {
358             #push @comp, "run $_" if /^$word/;
359             #}
360             #}
361             }
362             # If it's a subcommand, send it to any custom completion function for the
363             # function:
364             else {
365 0           my $command = ($self->line_parsed($line))[0];
366 0           $self->log->debug("rl_complete: send to custom completion");
367 0           @comp = $self->complete($command, $word, $line, $start);
368             }
369              
370 0           $self->log->debug("rl_complete: return comp[@comp] count[".scalar(@comp)."]");
371              
372 0           return @comp;
373             }
374              
375             # Converts Windows path
376             sub _convert_path {
377 0     0     my ($path) = @_;
378              
379 0           $path =~ s/\\/\//g;
380              
381 0           return $path;
382             }
383              
384             #
385             # Term::Shell::main stuff
386             #
387 1     1   1826 use Cwd;
  1         2  
  1         86  
388 1     1   546 use File::HomeDir;
  1         5684  
  1         7684  
389              
390             sub _update_path_home {
391 0     0     my $self = shift;
392              
393             #$self->path_home(_convert_path(home()));
394 0   0       $self->{path_home} = _convert_path(File::HomeDir->my_home || '/tmp');
395              
396 0           return 1;
397             }
398              
399             sub _update_path_cwd {
400 0     0     my $self = shift;
401              
402 0   0       my $cwd = _convert_path(Cwd::getcwd() || '/tmp');
403             #$self->log->debug("cwd [$cwd]");
404             #my $home = $self->path_home;
405 0   0       my $home = $self->{path_home} || '/tmp';
406             #$self->log->debug("home [$home]");
407 0           $cwd =~ s/^$home/~/;
408              
409             #$self->path_cwd($cwd);
410 0           $self->{path_cwd} = $cwd;
411              
412 0           return 1;
413             }
414              
415             sub _update_prompt {
416 0     0     my $self = shift;
417 0           my ($prompt) = @_;
418              
419 0 0         if (defined($prompt)) {
420             #$self->prompt($prompt);
421 0           $self->{prompt} = $prompt;
422             }
423             else {
424 0           my $ps1 = $self->ps1;
425             #my $cwd = $self->path_cwd;
426 0           my $cwd = $self->{path_cwd};
427              
428 0 0         my $prompt = defined($ps1) ? "$ps1:$cwd> " : "Meta:$cwd> ";
429              
430 0 0         if ($^O =~ /win32/i) {
    0          
431 0           $prompt =~ s/> /\$ /;
432             }
433             elsif ($< == 0) {
434 0           $prompt =~ s/> /# /;
435             }
436              
437             #$self->prompt($prompt);
438 0           $self->{prompt} = $prompt;
439             }
440              
441 0           return 1;
442             }
443              
444             sub init {
445 0     0 1   my $self = shift;
446              
447 0           $|++;
448              
449 0           $self->_update_path_home;
450 0           $self->_update_path_cwd;
451 0           $self->_update_prompt;
452              
453             # Default: 'us,ue,md,me', see `man 5 termcap' and Term::Cap
454             # See also Term::ReadLine LoadTermCap() and ornaments() subs.
455 0           $self->term->ornaments('md,me');
456              
457             # Force Commands to be entered entirely to avoid ambiguity.
458             # Example: type 'my' will result in excuting Perl code, and not 'mymeta-cpanfile'.
459 0           $self->{API}{match_uniq} = 0;
460              
461 0           return $self;
462             }
463              
464             sub prompt_str {
465 0     0 1   my $self = shift;
466              
467             #return $self->prompt;
468 0           return $self->{prompt};
469             }
470              
471             sub cmd_is_complete {
472 0     0 1   my $self = shift;
473 0           my ($lines) = @_;
474              
475 0           my $string = join("\n", @$lines);
476              
477 0           my $document = PPI::Document->new(\$string);
478 0 0         if (! $document) {
479 0           return $self->log->error("cmd_is_complete: cannot parse Perl string");
480             }
481              
482             # Courtesy of Perl::Shell complete() function
483             my $r = $document->find_any(sub {
484 0 0   0     $_[1]->isa('PPI::Structure') and ! $_[1]->finish
485 0           });
486              
487 0 0         return $r ? 0 : 1;
488             }
489              
490             sub cmd_to_code {
491 0     0 1   my $self = shift;
492 0           my ($line) = @_;
493              
494             # Example: a run Command converted to Perl Code:
495             # 'run shell::command system "echo $_"';
496             # $SHE->cmd("run shell::command system \"echo $_\"");
497              
498 0           $self->log->debug("cmd_to_code: before: [$line]");
499 0 0         if ($line =~ /^\s*'\s*((?:use|set|get|run)\s.*?)\s*'\s*;?\s*$/) {
500             # We have to escape " chars
501 0           (my $new = $1) =~ s{"}{\\"}g;
502             # We have to escape $ variables too so they are completed
503 0           $new =~ s{\$}{\\\$}g;
504 0           $self->log->debug("cmd_to_code: new: [$new]");
505 0           $line = '$SHE->cmd("'.$new.'");';
506             }
507 0           $self->log->debug("cmd_to_code: after: [$line]");
508              
509 0           return $line;
510             }
511              
512             sub cmd {
513 0     0 1   my $self = shift;
514 0           my ($cmd) = @_;
515              
516             # If there is a command like `exit 1', we exit and return the code number
517 0 0         if ($cmd =~ m{^\s*exit(?:\s+(\d+))}) {
518 0           $self->log->verbose("cmd: exiting [$cmd]");
519 0           $self->run_exit;
520 0           exit($1);
521             }
522              
523 0           return $self->SUPER::cmd($cmd);
524             }
525              
526             sub process_line {
527 0     0 1   my $self = shift;
528 0           my ($line, $lines) = @_;
529              
530 0           $self->log->debug("process_line: [$line]");
531              
532             # Skip comments
533 0 0         if ($line =~ /^\s*#/) {
534 0           return 0;
535             }
536             # Skip blank lines
537 0 0         if ($line =~ /^\s*$/) {
538 0           return 0;
539             }
540              
541 0           push @$lines, $line;
542              
543             # If a closure is open, we are in multiline mode
544 0 0         if (! $self->cmd_is_complete($lines)) {
545             # If it looks like a Metabrik command, we rewrite it to a Perl code string
546             # This is to support 'run ' within multiline.
547 0           $lines->[-1] = $self->cmd_to_code($line);
548 0           $self->_update_prompt('.. ');
549 0           return 1;
550             }
551              
552 0           $self->log->debug("process_line: lines[@$lines]");
553              
554 0           my $cmd = join('', @$lines);
555              
556 0           $self->cmd($cmd);
557              
558 0           $self->_update_prompt;
559              
560 0           return 0;
561             }
562              
563             sub cmdloop {
564 0     0 1   my $self = shift;
565 0           my ($lines) = @_;
566              
567 0           my @lines = ();
568              
569             # User provided lines to execute (script)
570 0 0         if (defined($lines)) {
571 0           for my $line (@$lines) {
572 0 0         if ($self->process_line($line, \@lines)) {
573 0           next; # We are in multiline mode
574             }
575             else {
576 0           @lines = (); # Command is complete, we ran it and now reset line buffer.
577             }
578              
579 0 0         last if $self->{stop};
580             }
581             }
582             # Or we are in interactive mode (shell)
583             else {
584 0           $self->{stop} = 0;
585 0           $self->preloop;
586              
587 0           while (defined(my $line = $self->readline($self->prompt_str))) {
588 0 0         if ($self->process_line($line, \@lines)) {
589 0           next; # We are in multiline mode
590             }
591             else {
592 0           @lines = (); # Command is complete, we ran it and now reset line buffer.
593             }
594              
595 0 0         last if $self->{stop};
596             }
597              
598 0           $self->run_exit;
599              
600 0           return $self->postloop;
601             }
602              
603 0           return 1;
604             }
605              
606             #
607             # Term::Shell::run stuff
608             #
609             sub run_exit {
610 0     0 1   my $self = shift;
611              
612 0           my $context = $self->context;
613              
614 0 0         if ($context->is_used('shell::history')) {
615 0           $context->run('shell::history', 'write');
616             }
617              
618             # Global clean-up
619 0           $context->brik_fini;
620              
621 0           return $self->stoploop;
622             }
623              
624             sub comp_exit {
625 0     0 1   my $self = shift;
626              
627 0           $self->log->debug("comp_exit: true");
628              
629 0           return ();
630             }
631              
632             sub run_alias {
633 0     0 1   my $self = shift;
634 0           my ($alias, @cmd) = @_;
635              
636             #my $aliases = $self->_aliases;
637 0           my $aliases = $self->{_aliases};
638              
639 0 0 0       if (! defined($alias)) {
    0          
640 0           for my $this (sort { $a cmp $b } keys %$aliases) {
  0            
641 0           ($alias = $this) =~ s/^run_//;
642 0           printf("alias %-10s \"%s\"\n", $alias, $aliases->{$this});
643             }
644              
645 0           return 1;
646             }
647             elsif (length($alias) && @cmd == 0) {
648 0           $alias =~ s/^run_//;
649 0 0         if (exists($aliases->{"run_$alias"})) {
650 0           printf("alias %-10s \"%s\"\n", $alias, $aliases->{"run_$alias"});
651             }
652             else {
653 0           $self->log->info("alias: no alias by that name [$alias]");
654             }
655              
656 0           return 1;
657             }
658              
659 0           $aliases->{"run_$alias"} = join(' ', @cmd);
660             #$self->_aliases($aliases);
661 0           $self->{_aliases} = $aliases;
662              
663 0           $self->add_handler("run_$alias");
664              
665 0           return 1;
666             }
667              
668             sub comp_alias {
669 0     0 1   my $self = shift;
670              
671 0           $self->log->debug("comp_alias: true");
672              
673 0           return ();
674             }
675              
676             sub run_cd {
677 0     0 1   my $self = shift;
678 0           my ($dir, @args) = @_;
679              
680 0 0         if (defined($dir)) {
681 0 0         if ($dir =~ m{^~}) {
682             #$dir = $self->path_home;
683 0           $dir =~ s{^~}{$self->{path_home}};
684             }
685 0 0         if (! -d $dir) {
686 0           return $self->log->error("cd: directory [$dir] does not exist");
687             }
688 0 0         chdir($dir)
689             or return $self->log->error("cd: chdir failed for directory [$dir]: $!");
690 0           $self->_update_path_cwd;
691             }
692             else {
693             #chdir($self->path_home);
694             chdir($self->{path_home})
695 0 0         or return $self->log->error("cd: chdir failed for directory [$dir]: $!");
696 0           $self->_update_path_cwd;
697             }
698              
699 0           $self->_update_prompt;
700              
701 0           return 1;
702             }
703              
704             sub comp_cd {
705 0     0 1   my $self = shift;
706 0           my ($word, $line, $start) = @_;
707              
708 0           $self->log->debug("comp_cd: true");
709              
710 0           return $self->catch_comp_sub($word, $start, $line);
711             }
712              
713             sub run_code {
714 0     0 1   my $self = shift;
715              
716 0           my $context = $self->context;
717              
718 0           my $line = $self->line;
719 0           $line =~ s/^code\s+//;
720              
721 0 0         if (! length($line)) {
722 0           return $self->log->info('code ');
723             }
724              
725 0           $self->log->debug("run_code: code[$line]");
726              
727 0           my $r;
728 0           eval {
729             # So we can interrupt the do($line) execution
730             local $SIG{INT} = sub {
731 0     0     $self->log->debug("run_code: SIG received");
732 0 0         if ($self->global->exit_on_sigint) {
733 0           $self->log->debug("run_code: exiting");
734 0           $self->run_exit;
735             }
736 0           die("interrupted by user\n");
737 0           };
738 0           $r = $context->do($line);
739             };
740 0 0         if (! defined($r)) {
741 0           return $self->log->error("run_code: unable to execute Code [$line]");
742             }
743              
744 0 0         if ($self->echo) {
745 0           $self->page(Data::Dump::dump($r)."\n");
746             }
747              
748 0           return $r;
749             }
750              
751             sub comp_code {
752 0     0 1   my $self = shift;
753 0           my ($word, $line, $start) = @_;
754              
755 0           $self->log->debug("comp_code: true");
756              
757 0           return $self->catch_comp_sub($word, $start, $line);
758             }
759              
760             sub run_use {
761 0     0 1   my $self = shift;
762 0           my ($brik, @args) = @_;
763              
764 0           my $context = $self->context;
765              
766 0 0         if (! defined($brik)) {
767 0           return $self->log->info('use ');
768             }
769              
770 0           my $r;
771             # If Brik starts with a minuscule, we want to use Brik in Metabrik sens.
772             # Otherwise, it is a use command in the Perl sens.
773 0 0 0       if ($brik =~ /^[a-z]/ && $brik =~ /::/) {
774 0 0         $r = $context->use($brik) or return;
775 0 0         if ($r) {
776 0           $self->log->verbose("use: Brik [$brik] success");
777             }
778             }
779             else {
780 0           return $self->run_code($brik, @args);
781             }
782              
783 0           return $r;
784             }
785              
786             sub comp_use {
787 0     0 1   my $self = shift;
788 0           my ($word, $line, $start) = @_;
789              
790 0           $self->log->debug("comp_use: true");
791              
792 0           my $context = $self->context;
793              
794 0           my @words = $self->line_parsed($line);
795 0           my $count = scalar(@words);
796              
797 0           $self->log->debug("word[$word] line[$line] start[$start] count[$count]");
798              
799 0           my @comp = ();
800              
801             # We want to find available Briks by using completion
802 0 0 0       if (($count == 1)
      0        
803             || ($count == 2 && length($word) > 0)) {
804 0           my $available = $context->available;
805 0 0 0       if ($self->log->level > 2 && ! defined($available)) {
806 0           $self->log->debug("\ncomp_use: can't fetch available Briks");
807 0           return ();
808             }
809              
810 0           for my $a (keys %$available) {
811 0 0         push @comp, $a if $a =~ /^$word/;
812             }
813             }
814              
815 0           return @comp;
816             }
817              
818             sub get_help_attributes {
819 0     0 1   my $self = shift;
820 0           my ($brik) = @_;
821              
822 0 0         if (! defined($brik)) {
823 0           return $self->log->error($self->brik_help_run('get_help_attributes'));
824             }
825              
826 0           my $context = $self->context;
827              
828 0 0         if (! $context->is_used($brik)) {
829 0           return {};
830             }
831              
832 0           my $used = $context->used;
833              
834 0           my $attributes = $used->{$brik}->brik_own_attributes;
835              
836 0           my $base_attributes = {};
837 0 0 0       if ($self->help_show_base_attributes || $self->help_show_base_all
      0        
      0        
      0        
      0        
838             || $self->show_base_attributes || $self->show_base_all
839             || $self->help_show_all || $self->show_all) {
840 0           $base_attributes = $used->{$brik}->brik_base_attributes;
841             }
842              
843 0           my $inherited_attributes = {};
844 0 0 0       if ($self->help_show_inherited_attributes || $self->help_show_inherited_all
      0        
      0        
      0        
      0        
845             || $self->show_inherited_attributes || $self->show_inherited_all
846             || $self->help_show_all || $self->show_all) {
847 0           $inherited_attributes = $used->{$brik}->brik_inherited_attributes;
848             }
849              
850 0           for my $attribute (keys %$base_attributes) {
851 0           $attributes->{$attribute} = $base_attributes->{$attribute};
852             }
853              
854 0           for my $attribute (keys %$inherited_attributes) {
855 0           $attributes->{$attribute} = $inherited_attributes->{$attribute};
856             }
857              
858 0           return $attributes;
859             }
860              
861             sub get_help_commands {
862 0     0 1   my $self = shift;
863 0           my ($brik) = @_;
864              
865 0 0         if (! defined($brik)) {
866 0           return $self->log->error($self->brik_help_run('get_help_commands'));
867             }
868              
869 0           my $context = $self->context;
870              
871 0 0         if (! $context->is_used($brik)) {
872 0           return {};
873             }
874              
875 0           my $used = $context->used;
876              
877 0           my $commands = $used->{$brik}->brik_own_commands;
878              
879 0           my $base_commands = {};
880 0 0 0       if ($self->help_show_base_commands || $self->help_show_base_all
      0        
      0        
      0        
      0        
881             || $self->show_base_commands || $self->show_base_all
882             || $self->help_show_all || $self->show_all) {
883 0           $base_commands = $used->{$brik}->brik_base_commands;
884             }
885              
886 0           my $inherited_commands = {};
887 0 0 0       if ($self->help_show_inherited_commands || $self->help_show_inherited_all
      0        
      0        
      0        
      0        
888             || $self->show_inherited_commands || $self->show_inherited_all
889             || $self->help_show_all || $self->show_all) {
890 0           $inherited_commands = $used->{$brik}->brik_inherited_commands;
891             }
892              
893 0           for my $command (keys %$base_commands) {
894 0           $commands->{$command} = $base_commands->{$command};
895             }
896              
897 0           for my $command (keys %$inherited_commands) {
898 0           $commands->{$command} = $inherited_commands->{$command};
899             }
900              
901 0           return $commands;
902             }
903              
904             sub get_comp_attributes {
905 0     0 1   my $self = shift;
906 0           my ($brik) = @_;
907              
908 0 0         if (! defined($brik)) {
909 0           return $self->log->error($self->brik_help_run('get_comp_attributes'));
910             }
911              
912 0           my $context = $self->context;
913              
914 0 0         if (! $context->is_used($brik)) {
915 0           return {};
916             }
917              
918 0           my $used = $context->used;
919              
920 0           my $attributes = $used->{$brik}->brik_own_attributes;
921              
922 0           my $base_attributes = {};
923 0 0 0       if ($self->comp_show_base_attributes || $self->comp_show_base_all
      0        
      0        
      0        
      0        
924             || $self->show_base_attributes || $self->show_base_all
925             || $self->comp_show_all || $self->show_all) {
926 0           $base_attributes = $used->{$brik}->brik_base_attributes;
927             }
928              
929 0           my $inherited_attributes = {};
930 0 0 0       if ($self->comp_show_inherited_attributes || $self->comp_show_inherited_all
      0        
      0        
      0        
      0        
931             || $self->show_inherited_attributes || $self->show_inherited_all
932             || $self->comp_show_all || $self->show_all) {
933 0           $inherited_attributes = $used->{$brik}->brik_inherited_attributes;
934             }
935              
936 0           for my $attribute (keys %$base_attributes) {
937 0           $attributes->{$attribute} = $base_attributes->{$attribute};
938             }
939              
940 0           for my $attribute (keys %$inherited_attributes) {
941 0           $attributes->{$attribute} = $inherited_attributes->{$attribute};
942             }
943              
944 0           return $attributes;
945             }
946              
947             sub get_comp_commands {
948 0     0 1   my $self = shift;
949 0           my ($brik) = @_;
950              
951 0 0         if (! defined($brik)) {
952 0           return $self->log->error($self->brik_help_run('get_comp_commands'));
953             }
954              
955 0           my $context = $self->context;
956              
957 0 0         if (! $context->is_used($brik)) {
958 0           return {};
959             }
960              
961 0           my $used = $context->used;
962              
963 0           my $commands = $used->{$brik}->brik_own_commands;
964              
965 0           my $base_commands = {};
966 0 0 0       if ($self->comp_show_base_commands || $self->comp_show_base_all
      0        
      0        
      0        
      0        
967             || $self->show_base_commands || $self->show_base_all
968             || $self->comp_show_all || $self->show_all) {
969 0           $base_commands = $used->{$brik}->brik_base_commands;
970             }
971              
972 0           my $inherited_commands = {};
973 0 0 0       if ($self->comp_show_inherited_commands || $self->comp_show_inherited_all
      0        
      0        
      0        
      0        
974             || $self->show_inherited_commands || $self->show_inherited_all
975             || $self->comp_show_all || $self->show_all) {
976 0           $inherited_commands = $used->{$brik}->brik_inherited_commands;
977             }
978              
979 0           for my $command (keys %$base_commands) {
980 0           $commands->{$command} = $base_commands->{$command};
981             }
982              
983 0           for my $command (keys %$inherited_commands) {
984 0           $commands->{$command} = $inherited_commands->{$command};
985             }
986              
987 0           return $commands;
988             }
989              
990             sub run_help {
991 0     0 1   my $self = shift;
992 0           my ($arg1, $arg2) = @_;
993              
994 0           my $context = $self->context;
995              
996 0           my $help = $self->get_available_help;
997 0           my %aliases = map { $_ => 1 } @{$help->{aliases}};
  0            
  0            
998 0           my %briks = map { $_ => 1 } @{$help->{briks}};
  0            
  0            
999 0           my %commands = map { $_ => 1 } @{$help->{commands}};
  0            
  0            
1000              
1001             # Print the list of available Briks, Aliases, Commands
1002 0 0         if (! defined($arg1)) {
    0          
1003 0           $self->log->info("For more help, print help :");
1004 0           $self->log->info(" ");
1005              
1006 0           for my $this (sort { $a cmp $b } @{$help->{briks}}) {
  0            
  0            
1007 0           $self->log->info(" $this - Brik");
1008             }
1009              
1010 0           for my $this (sort { $a cmp $b } @{$help->{aliases}}) {
  0            
  0            
1011 0           $self->log->info(" $this - Alias");
1012             }
1013              
1014 0           for my $this (sort { $a cmp $b } @{$help->{commands}}) {
  0            
  0            
1015 0           $self->log->info(" $this - Command");
1016             }
1017              
1018 0           return 1;
1019             }
1020             elsif (! defined($arg2)) {
1021             # Help for a Brik
1022 0 0         if ($context->is_used($arg1)) {
    0          
    0          
1023 0           my $used_brik = $context->used->{$arg1};
1024              
1025 0           my $attributes = $self->get_help_attributes($arg1);
1026 0           my $commands = $self->get_help_commands($arg1);
1027              
1028 0           for my $attribute (sort { $a cmp $b } keys %$attributes) {
  0            
1029 0           my $help = "set $arg1 ".$used_brik->brik_help_set($attribute);
1030 0 0         $self->log->info($help) if defined($help);
1031             }
1032              
1033 0           for my $command (sort { $a cmp $b } keys %$commands) {
  0            
1034 0           my $help = "run $arg1 ".$used_brik->brik_help_run($command);
1035 0 0         $self->log->info($help) if defined($help);
1036             }
1037             }
1038             # Help for a Command
1039             elsif (exists($commands{$arg1})) {
1040 0           for my $this (sort { $a cmp $b } keys %commands) {
  0            
1041 0           return $self->log->info("$arg1 - core::shell Command, see 'help core::shell $arg1'");
1042             }
1043             }
1044             # Help for an Alias
1045             elsif (exists($aliases{$arg1})) {
1046 0           return $self->log->info("$arg1 - no help for Aliases");
1047             }
1048             else {
1049 0           return $self->log->info("Command [$arg1] not found");
1050             }
1051             }
1052             # Both arg1 and arg2 are defined
1053             else {
1054 0 0         if (exists($briks{$arg1})) {
1055 0           my $used_brik = $context->used->{$arg1};
1056              
1057 0           my $attributes = $used_brik->brik_attributes;
1058 0           my $commands = $used_brik->brik_commands;
1059              
1060 0           my $base_attributes = $used_brik->brik_base_attributes;
1061 0           my $base_commands = $used_brik->brik_base_commands;
1062              
1063 0           my $help;
1064 0 0 0       if (exists($attributes->{$arg2}) || exists($base_attributes->{$arg2})) {
    0 0        
1065 0           $help = $used_brik->brik_help_set($arg2);
1066             }
1067             elsif (exists($commands->{$arg2}) || exists($base_commands->{$arg2})) {
1068 0           $help = $used_brik->brik_help_run($arg2);
1069             }
1070             else {
1071 0           $help = "Attribute or Command [$arg2] not found for Brik [$arg1]";
1072             }
1073              
1074 0           return $self->log->info($help);
1075             }
1076             else {
1077 0           return $self->log->info("Command [$arg1] not found");
1078             }
1079             }
1080              
1081 0           return 1;
1082             }
1083              
1084             sub comp_help {
1085 0     0 1   my $self = shift;
1086 0           my ($word, $line, $start) = @_;
1087              
1088 0           $self->log->debug("comp_help: true");
1089              
1090 0           my @words = $self->line_parsed($line);
1091 0           my $count = scalar(@words);
1092              
1093 0           $self->log->debug("word[$word] line[$line] start[$start] count[$count]");
1094              
1095 0           my @comp = ();
1096              
1097             # We want to find help for used Briks/Aliases/Commands by using completion
1098 0 0 0       if ($count == 1 || ($count == 2 && length($word) > 0)) {
      0        
1099 0           my $help = $self->get_available_help;
1100             # No need to complete aliases, there is no help
1101             #for my $a (@{$help->{briks}}, @{$help->{aliases}}, @{$help->{commands}}) {
1102 0           for my $a (@{$help->{briks}}, @{$help->{commands}}) {
  0            
  0            
1103 0 0         next unless length($a);
1104 0 0         push @comp, $a if $a =~ /^$word/;
1105             }
1106             }
1107             # We want to complete entered Command and Attributes
1108             else {
1109 0           push @comp, $self->comp_run(@_);
1110 0           push @comp, $self->comp_set(@_);
1111 0           return @comp;
1112             }
1113              
1114 0           return @comp;
1115             }
1116              
1117             sub run_set {
1118 0     0 1   my $self = shift;
1119 0           my ($brik, $attribute, $value) = @_;
1120              
1121 0           my $context = $self->context;
1122              
1123 0 0 0       if (! defined($brik) || ! defined($attribute) || ! defined($value)) {
      0        
1124 0           return $self->log->info("set ");
1125             }
1126              
1127 0           my $r = $context->set($brik, $attribute, $value);
1128 0 0         if (! defined($r)) {
1129 0           return $self->log->error("set: unable to set Attribute [$attribute] for Brik [$brik]");
1130             }
1131              
1132 0           return $r;
1133             }
1134              
1135             sub comp_set {
1136 0     0 1   my $self = shift;
1137 0           my ($word, $line, $start) = @_;
1138              
1139 0           $self->log->debug("comp_set: true");
1140              
1141 0           my $context = $self->context;
1142              
1143             # Completion is for used Briks only
1144 0           my $used = $context->used;
1145 0 0         if (! defined($used)) {
1146 0           $self->log->debug("comp_set: can't fetch used Briks");
1147 0           return ();
1148             }
1149              
1150 0           my @words = $self->line_parsed($line);
1151 0           my $count = scalar(@words);
1152              
1153 0           $self->log->debug("word[$word] line[$line] start[$start] count[$count]");
1154              
1155 0 0         my $brik = defined($words[1]) ? $words[1] : undef;
1156              
1157 0           my @comp = ();
1158              
1159             # We want completion for used Briks
1160 0 0 0       if (($count == 1)
    0 0        
    0 0        
      0        
1161             || ($count == 2 && length($word) > 0)) {
1162 0           for my $a (keys %$used) {
1163 0 0         push @comp, $a if $a =~ /^$word/;
1164             }
1165             }
1166             # We fetch Brik Attributes
1167             elsif ($count == 2 && length($word) == 0) {
1168 0 0 0       if ($self->log->level > 2 && ! exists($used->{$brik})) {
1169 0           $self->log->debug("comp_set: Brik [$brik] not used");
1170 0           return ();
1171             }
1172              
1173 0           my $attributes = $self->get_comp_attributes($brik);
1174              
1175 0           for my $attribute (keys %$attributes) {
1176 0           push @comp, $attribute;
1177             }
1178             }
1179             # We want to complete entered Attribute
1180             elsif ($count == 3 && length($word) > 0) {
1181 0 0 0       if ($self->log->level > 2 && ! exists($used->{$brik})) {
1182 0           $self->log->debug("comp_set: Brik [$brik] not used");
1183 0           return ();
1184             }
1185              
1186 0           my $attributes = $self->get_comp_attributes($brik);
1187              
1188 0           for my $attribute (keys %$attributes) {
1189 0 0         if ($attribute =~ /^$word/) {
1190 0           push @comp, $attribute;
1191             }
1192             }
1193             }
1194             # Else, default completion method on remaining word
1195             else {
1196 0           return $self->catch_comp_sub($word, $start, $line);
1197             }
1198              
1199 0           return @comp;
1200             }
1201              
1202             sub run_get {
1203 0     0 1   my $self = shift;
1204 0           my ($brik, $attribute) = @_;
1205              
1206 0           my $context = $self->context;
1207              
1208             # get is called without args, we display everything
1209 0 0 0       if (! defined($brik)) {
    0 0        
    0          
1210 0 0         my $used = $context->used or return;
1211              
1212 0           for my $brik (sort { $a cmp $b } keys %$used) {
  0            
1213 0           my $attributes = $self->get_help_attributes($brik);
1214              
1215 0           for my $attribute (sort { $a cmp $b } keys %$attributes) {
  0            
1216 0           $self->log->info("$brik $attribute ".$context->get($brik, $attribute));
1217             }
1218             }
1219             }
1220             # get is called with only a Brik as an arg, we show its Attributes
1221             elsif (defined($brik) && ! defined($attribute)) {
1222 0 0         my $used = $context->used or return;
1223              
1224 0 0         if (! exists($used->{$brik})) {
1225 0           return $self->log->error("get: Brik [$brik] not used");
1226             }
1227              
1228 0           my $attributes = $self->get_help_attributes($brik);
1229              
1230 0           for my $attribute (sort { $a cmp $b } keys %$attributes) {
  0            
1231 0           $self->log->info("$brik $attribute ".$context->get($brik, $attribute));
1232             }
1233             }
1234             # get is called with is a Brik and an Attribute
1235             elsif (defined($brik) && defined($attribute)) {
1236 0 0         my $used = $context->used or return;
1237              
1238 0 0         if (! exists($used->{$brik})) {
1239 0           return $self->log->error("get: Brik [$brik] not used");
1240             }
1241              
1242 0 0         if (! $used->{$brik}->brik_has_attribute($attribute)) {
1243 0           return $self->log->error("get: Attribute [$attribute] does not exist for Brik [$brik]");
1244             }
1245              
1246 0           $self->log->info("$brik $attribute ".$context->get($brik, $attribute));
1247             }
1248              
1249 0           return 1;
1250             }
1251              
1252             sub comp_get {
1253 0     0 1   my $self = shift;
1254              
1255 0           $self->log->debug("comp_get: true");
1256              
1257 0           return $self->comp_set(@_);
1258             }
1259              
1260             sub run_run {
1261 0     0 1   my $self = shift;
1262 0           my ($brik, $command, @args) = @_;
1263              
1264 0           my $context = $self->context;
1265              
1266 0 0 0       if (! defined($brik) || ! defined($command)) {
1267 0           return $self->log->info("run [ .. ]");
1268             }
1269              
1270 0           my $r;
1271             {
1272 0           local $SIG{INT} = sub {
1273 0     0     $self->log->debug("run_run: SIG received");
1274 0 0         if ($self->global->exit_on_sigint) {
1275 0           $self->log->debug("run_run: exiting");
1276 0           $self->run_exit;
1277             }
1278 0           die("interrupted by user\n");
1279 0           };
1280              
1281 0 0         if ($self->log->level > 2) {
1282 0           my ($module, $file, $line) = caller();
1283 0           $self->log->debug("run_run: called by module [$module] from [$file] line[$line]");
1284             }
1285              
1286             # Hack for Term::Shell: we have to convert its exec function to our execute Command
1287 0           my ($module) = caller();
1288 0 0 0       if ($module eq 'Term::Shell' && $command eq 'exec') {
1289 0           $command = 'execute';
1290             }
1291              
1292 0           $r = $context->run($brik, $command, @args);
1293 0 0         if (! defined($r)) {
1294 0           return $self->log->error("run: unable to execute Command [$command] for Brik [$brik]");
1295             }
1296             }
1297              
1298 0 0         if ($self->echo) {
1299 0           $self->page(Data::Dump::dump($r)."\n");
1300             }
1301              
1302 0           return $r;
1303             }
1304              
1305             sub comp_run {
1306 0     0 1   my $self = shift;
1307 0           my ($word, $line, $start) = @_;
1308              
1309 0           $self->log->debug("comp_run: true");
1310              
1311 0           my $context = $self->context;
1312              
1313 0           my @words = $self->line_parsed($line);
1314 0           my $count = scalar(@words);
1315 0           my $last = $words[-1];
1316              
1317 0           $self->log->debug("comp_run: words[@words] | word[$word] line[$line] ".
1318             "start[$start] | last[$last]");
1319              
1320             # Completion is for used Briks only
1321 0           my $used = $context->used;
1322 0 0         if (! defined($used)) {
1323 0           $self->log->debug("comp_run: can't fetch used Briks");
1324 0           return ();
1325             }
1326              
1327 0 0         my $brik = defined($words[1]) ? $words[1] : undef;
1328              
1329 0           my @comp = ();
1330              
1331             # We want completion for used Briks
1332 0 0 0       if (($count == 1)
    0 0        
    0 0        
      0        
1333             || ($count == 2 && length($word) > 0)) {
1334 0           for my $a (keys %$used) {
1335 0 0         push @comp, $a if $a =~ /^$word/;
1336             }
1337             }
1338             # We fetch Brik Commands
1339             elsif ($count == 2 && length($word) == 0) {
1340 0 0         if ($self->log->level > 2) {
1341 0 0         if (! exists($used->{$brik})) {
1342 0           $self->log->debug("comp_run: Brik [$brik] not used");
1343 0           return ();
1344             }
1345             }
1346              
1347 0           my $commands = $self->get_comp_commands($brik);
1348              
1349 0           for my $command (keys %$commands) {
1350 0           push @comp, $command;
1351             }
1352             }
1353             # We want to complete entered Command and Attributes
1354             elsif ($count == 3 && length($word) > 0) {
1355 0 0         if ($self->log->level > 2) {
1356 0 0         if (! exists($used->{$brik})) {
1357 0           $self->log->debug("comp_run: Brik [$brik] not used");
1358 0           return ();
1359             }
1360             }
1361              
1362 0           my $commands = $self->get_comp_commands($brik);
1363              
1364 0           for my $command (keys %$commands) {
1365 0 0         if ($command =~ /^$word/) {
1366 0           push @comp, $command;
1367             }
1368             }
1369             }
1370             # Else, default completion method on remaining word
1371             else {
1372 0           return $self->catch_comp_sub($word, $start, $line);
1373             }
1374              
1375 0           return @comp;
1376             }
1377              
1378             #
1379             # Term::Shell::catch stuff
1380             #
1381             sub catch_run {
1382 0     0 1   my $self = shift;
1383 0           my (@args) = @_;
1384              
1385 0           my $context = $self->context;
1386              
1387 0           $self->log->debug("catch_run: args [@args]");
1388              
1389             # If it starts with a '/', we really want to 'run shell::command system'
1390 0 0         if ($context->is_used('shell::command')) {
1391 0 0         my $sc_command = $self->capture_mode ? 'capture' : 'system';
1392 0 0 0       if (defined($args[0]) && $args[0] =~ m{^\s*/}) {
1393 0           my $cmd = "run shell::command $sc_command";
1394 0           return $self->cmd(join(' ', $cmd, @args));
1395             }
1396             }
1397              
1398             # Default to execute Perl commands
1399 0           return $self->run_code(@args);
1400             }
1401              
1402             # Taken from file::find Brik, to make core::shell independant from it.
1403             sub _file_find {
1404 0     0     my $self = shift;
1405 0           my ($path) = @_;
1406              
1407 0           my @dirs = ();
1408 0           my @files = ();
1409              
1410 0           my $dirpattern = '.*';
1411 0           my $filepattern = '.*';
1412              
1413             # Handle finding of directories
1414 0           my @tmp_dirs = ();
1415 0           eval {
1416 0           @tmp_dirs = io($path)->all_dirs;
1417             };
1418 0 0         if ($@) {
1419 0 0         if ($self->log->level > 2) {
1420 0           chomp($@);
1421 0           $self->log->debug("all: $path: dirs: $@");
1422             }
1423 0           return { directories => [], files => [] };
1424             }
1425 0           for my $this (@tmp_dirs) {
1426 0 0         if ($this =~ /$dirpattern/) {
1427 0           push @dirs, "$this/";
1428             }
1429             }
1430              
1431             # Handle finding of files
1432 0           my @tmp_files = ();
1433 0           eval {
1434 0           @tmp_files = io($path)->all_files;
1435             };
1436 0 0         if ($@) {
1437 0 0         if ($self->log->level > 2) {
1438 0           chomp($@);
1439 0           $self->log->debug("all: $path: files: $@");
1440             }
1441 0           return { directories => [], files => [] };
1442             }
1443 0           for my $this (@tmp_files) {
1444 0 0         if ($this =~ /$filepattern/) {
1445 0           push @files, "$this";
1446             }
1447             }
1448              
1449 0           @dirs = map { s/^\.\///; $_ } @dirs; # Remove leading dot slash
  0            
  0            
1450 0           @files = map { s/^\.\///; $_ } @files; # Remove leading dot slash
  0            
  0            
1451              
1452             return {
1453 0           directories => \@dirs,
1454             files => \@files,
1455             };
1456             }
1457              
1458             # 1. $word - The word the user is trying to complete.
1459             # 2. $line - The line as typed by the user so far.
1460             # 3. $start - The offset into $line where $word starts.
1461             sub catch_comp_sub {
1462 0     0 1   my $self = shift;
1463             # Strange, we had to reverse order for $start and $line only for catch_comp() method.
1464 0           my ($word, $start, $line) = @_;
1465              
1466 0           $self->log->debug("catch_comp_sub: true");
1467              
1468 0           my $context = $self->context;
1469              
1470 0           my $attribs = $self->term->Attribs;
1471 0           $attribs->{completion_suppress_append} = 1;
1472              
1473 0           my @words = $self->line_parsed($line);
1474 0           my $count = scalar(@words);
1475 0           my $last = $words[-1];
1476              
1477 0           $self->log->debug("catch_comp_sub: words[@words] | word[$word] line[$line] start[$start] | last[$last]");
1478              
1479             # Be default, we will read the current directory
1480 0 0         if (! length($word)) {
1481 0           $word = '.';
1482             }
1483              
1484 0           $self->log->debug("catch_comp_sub: DEFAULT: words[@words] | word[$word] line[$line] start[$start] | last[$last]");
1485              
1486 0           my @comp = ();
1487              
1488             # We don't use $word here, because the $ is stripped. We have to use $word[-1]
1489             # We also check against $line, if we have a trailing space, the word was complete.
1490 0 0 0       if ($last =~ /^\$/ && $line !~ /\s+$/) {
1491 0           my $variables = $context->variables;
1492              
1493 0           for my $this (@$variables) {
1494 0           $this =~ s/^\$//;
1495 0           $self->log->debug("variable[$this] start[$start]");
1496 0 0         if ($this =~ /^$word/) {
1497 0           push @comp, $this;
1498             }
1499             }
1500             }
1501             else {
1502 0           my $path = '.';
1503              
1504             #my $home = $self->path_home;
1505 0           my $home = $self->{path_home};
1506 0           $word =~ s/^~/$home/;
1507              
1508 0 0         if ($word =~ /^(.*)\/.*$/) {
1509 0   0       $path = $1 || '/';
1510             }
1511              
1512 0           $self->log->debug("path[$path]");
1513              
1514 0           my $found = $self->_file_find($path);
1515              
1516 0           for my $this (@{$found->{files}}, @{$found->{directories}}) {
  0            
  0            
1517 0           $self->log->debug("check[$this]");
1518 0 0         if ($this =~ /^$word/) {
1519 0           push @comp, $this;
1520             }
1521             }
1522             }
1523              
1524             # If there are some whitespace, we put between quotes
1525 0           for (@comp) {
1526 0 0         if (m{\s+}) {
1527 0           s/^/"/;
1528 0           s/$/"/;
1529             }
1530             }
1531              
1532 0           return @comp;
1533             }
1534              
1535             # 1. $word - The word the user is trying to complete.
1536             # 2. $line - The line as typed by the user so far.
1537             # 3. $start - The offset into $line where $word starts.
1538             # The true default completion method for Term::Shell when no comp_* matched.
1539             # Ugly, we should merge with comp_catch_sub().
1540             # Bug from Term::Shell: $start is not an offset in that case.
1541             sub catch_comp {
1542 0     0 1   my $self = shift;
1543             # Strange, we had to reverse order for $start and $line only for catch_comp() method.
1544 0           my ($word, $start, $line) = @_;
1545              
1546 0           $self->log->debug("catch_comp: true");
1547              
1548 0           my $context = $self->context;
1549              
1550 0           my $attribs = $self->term->Attribs;
1551 0           $attribs->{completion_suppress_append} = 1;
1552              
1553 0           my @words = $self->line_parsed($line);
1554 0           my $count = scalar(@words);
1555 0           my $last = $words[-1];
1556              
1557 0           $self->log->debug("catch_comp: words[@words] | word[$word] line[$line] start[$start] | last[$last]");
1558              
1559             # Be default, we will read the current directory
1560 0 0         if (! length($start)) {
1561 0           $start = '.';
1562             }
1563              
1564 0           $self->log->debug("catch_comp: DEFAULT: words[@words] | word[$word] line[$line] start[$start] | last[$last]");
1565              
1566 0           my @comp = ();
1567              
1568             # We don't use $start here, because the $ is stripped. We have to use $word[-1]
1569             # We also check against $line, if we have a trailing space, the word was complete.
1570 0 0 0       if ($last =~ /^\$/ && $line !~ /\s+$/) {
1571 0           my $variables = $context->variables;
1572              
1573 0           for my $this (@$variables) {
1574 0           $this =~ s/^\$//;
1575 0           $self->log->debug("variable[$this] start[$start]");
1576 0 0         if ($this =~ /^$start/) {
1577 0           push @comp, $this;
1578             }
1579             }
1580             }
1581             # XXX: broken feature since Term::ReadLine::Gnu 1.27
1582             # If we just finished completing an alias, we return the full command
1583             #elsif (exists($self->{_aliases}{"run_$last"})) {
1584             #push @comp, $self->{_aliases}{"run_$last"};
1585             #}
1586             # Otherwise, we complete relative filenames
1587             else {
1588 0           my $path = '.';
1589              
1590             #my $home = $self->path_home;
1591 0           my $home = $self->{path_home};
1592 0           $start =~ s/^~/$home/;
1593              
1594 0 0         if ($start =~ /^(.*)\/.*$/) {
1595 0   0       $path = $1 || '/';
1596             }
1597 0           $self->log->debug("path[$path]");
1598              
1599 0           my $found = $self->_file_find($path);
1600              
1601 0           for my $this (@{$found->{files}}, @{$found->{directories}}) {
  0            
  0            
1602 0           $self->log->debug("check[$this]");
1603 0 0         if ($this =~ /^$start/) {
1604 0           push @comp, $this;
1605             }
1606             }
1607             }
1608              
1609             # If there are some whitespace, we put between quotes
1610 0           for (@comp) {
1611 0 0         if (m{\s+}) {
1612 0           s/^/"/;
1613 0           s/$/"/;
1614             }
1615             }
1616              
1617 0           $self->log->debug("catch_comp: possible [@comp]");
1618              
1619 0           return @comp;
1620             }
1621              
1622             1;
1623              
1624             __END__