1package PerlConsole::Console;
2
3# This class implements all the stuff needed to communicate with
4# the console.
5# Either for displaying message in the console (error and verbose stuff)
6# or for launcing command, or even changing the console's context.
7
8# dependencies
9use strict;
10use warnings;
11use Term::ReadLine;
12use PerlConsole::Preferences;
13use PerlConsole::Commands;
14use Module::Refresh;
15use Lexical::Persistence;
16use Getopt::Long;
17use B::Keywords qw(@Functions);
18
19# These are all the built-in keywords of Perl
20my @perl_keywords = @B::Keywords::Functions;
21
22##############################################################
23# Constructor
24##############################################################
25sub new($@)
26{
27    my ($class, $version) = @_;
28
29    # the console's data structure
30    my $self = {
31        version             => $version,
32        prefs               => new PerlConsole::Preferences,
33        terminal            => new Term::ReadLine("Perl Console"),
34        lexical_environment => new Lexical::Persistence,
35        rcfile              => $ENV{HOME}.'/.perlconsolerc',
36        prompt              => "Perl> ",
37        modules             => {},
38        logs                => [],
39        errors              => [],
40    };
41    bless ($self, $class);
42
43    # set the readline history if a Gnu terminal
44    if ($self->{'terminal'}->ReadLine eq "Term::ReadLine::Gnu") {
45        $SIG{'INT'} = sub { $self->clean_exit(0) };
46        $self->{'terminal'}->ReadHistory($ENV{HOME} . "/.perlconsole_history");
47    }
48
49    # init the completion list with Perl internals...
50    $self->addCompletion([@perl_keywords]);
51
52    # ... and with PerlConsole's ones
53    $self->addCompletion([$self->{'prefs'}->getPreferences]);
54    foreach my $pref ($self->{'prefs'}->getPreferences) {
55        $self->addCompletion($self->{'prefs'}->getValidValues($pref));
56    }
57    # FIXME : we'll have to rewrite the commands stuff in a better way
58    $self->addCompletion([qw(:quit :set :help)]);
59    # the console's ready!
60    return $self;
61}
62
63# This is where we define all the options supported
64# on the command-line
65sub parse_options
66{
67    my ($self) = @_;
68    GetOptions('rcfile=s' => \$self->{rcfile});
69
70    # cleanup of the ~ shortcut for $ENV{HOME}
71    my $home = $ENV{HOME};
72    $self->{rcfile} =~ s/^~/${home}/;
73}
74
75# method for exiting properly and flushing the history
76sub clean_exit($$)
77{
78    my ($self, $status) = @_;
79    if ($self->{'terminal'}->ReadLine eq "Term::ReadLine::Gnu") {
80        $self->{'terminal'}->WriteHistory($ENV{HOME} . "/.perlconsole_history");
81    }
82    exit $status;
83}
84
85##############################################################
86# Terminal
87##############################################################
88
89sub addCompletion($$)
90{
91    my ($self, $ra_list) = @_;
92    my $attribs = $self->{'terminal'}->Attribs;
93    $attribs->{completion_entry_function} = $attribs->{list_completion_function};
94    if (! defined $attribs->{completion_word}) {
95        $attribs->{completion_word} = $ra_list;
96    }
97    else {
98        foreach my $elem (@{$ra_list}) {
99            push @{$attribs->{completion_word}}, $elem;
100        }
101    }
102}
103
104sub is_completion
105{
106    my ($self, $item) = @_;
107    my $attribs = $self->{'terminal'}->Attribs;
108    return grep /^${item}$/, @{$attribs->{completion_word}};
109}
110
111sub getInput
112{
113    my ($self) = @_;
114    return $self->{'terminal'}->readline($self->{'prompt'});
115}
116
117##############################################################
118# Communication methods
119##############################################################
120
121sub header
122{
123    my ($self) = @_;
124    $self->message("Perl Console ".$self->{'version'});
125}
126
127# add an error the error list, this is a LIFO stack, see getError.
128sub addError($$)
129{
130    my ($self, $error) = @_;
131    return unless defined $error;
132    chomp ($error);
133    push @{$self->{'errors'}}, $error;
134}
135
136# returns the last error message seen
137sub getError($)
138{
139    my ($self) = @_;
140    return $self->{'errors'}[$#{$self->{'errors'}}];
141}
142
143# clear the error messages, back to an empty list.
144sub clearErrors($)
145{
146    my ($self) = @_;
147    $self->{'errors'} = [];
148}
149
150# prints an error message, and record it to the error list
151sub error($$)
152{
153    my ($self, $string) = @_;
154    chomp $string;
155    $self->addError($string);
156    print "[!] $string\n";
157}
158
159sub message
160{
161    my ($self, $string) = @_;
162    if (! defined $string) {
163        print "undef\n";
164    }
165    else {
166        chomp $string;
167        print "$string\n";
168    }
169}
170
171# time
172sub getTime($)
173{
174    my ($self) = @_;
175    my ($sec, $min, $hour,
176        $mday, $mon, $year,
177        $wday, $yday, $isdst) = localtime(time);
178    $mon++;
179    $year += 1900;
180    $mon = sprintf("%02d", $mon);
181    $mday = sprintf("%02d", $mday);
182    return "$year-$mon-$mday $hour:$mon:$sec";
183}
184
185# push a log message on the top of the stack
186sub addLog($$)
187{
188    my ($self, $log) = @_;
189    push @{$self->{'logs'}}, "[".$self->getTime."] $log";
190}
191
192# get the last log message and remove it
193sub getLog($)
194{
195    my ($self) = @_;
196    my $log = $self->{'logs'}[$#{$self->{'logs'}}];
197    pop @{$self->{'logs'}};
198    return $log;
199}
200
201# Return the list of all unread log message and empty it
202sub getLogs
203{
204    my ($self) = @_;
205    my $logs = $self->{'logs'};
206    $self->{'logs'} = [];
207    return $logs;
208}
209
210##############################################################
211# Preferences
212##############################################################
213
214# accessors for the encapsulated preference object
215sub setPreference($$$)
216{
217    my ($self, $pref, $value) = @_;
218    my $prefs = $self->{'prefs'};
219    $self->addLog("setPreference: $pref = $value");
220    return $prefs->set($pref, $value);
221}
222
223sub getPreference($$)
224{
225    my ($self, $pref) = @_;
226    my $prefs = $self->{'prefs'};
227    my $val = $prefs->get($pref);
228    return $val;
229}
230
231# set the output and take care to load the appropriate module
232# for the output
233sub setOutput($$)
234{
235    my ($self, $output) = @_;
236    my $rh_output_modules = {
237        'yaml'   => 'YAML',
238        'dumper' => 'Data::Dumper',
239        'dump'   => 'Data::Dump',
240        'dds'    => 'Data::Dump::Streamer',
241    };
242
243    if (exists $rh_output_modules->{$output}) {
244        my $module = $rh_output_modules->{$output};
245        unless ($self->load($module)) {
246            $self->error("Unable to load module \"$module\", ".
247                "cannot use output mode \"$output\"");
248            return 0;
249        }
250    }
251
252    unless ($self->setPreference("output", $output)) {
253        $self->error("unable to set preference output to \"$output\"");
254        return 0;
255    }
256
257    return 1;
258}
259
260# this interprets a string, it calls the appropriate internal
261# function to deal with the provided string
262sub interpret($$)
263{
264    my ($self, $code) = @_;
265
266    # cleanup a bit the input string
267    chomp $code;
268    return unless length $code;
269
270    # look for the exit command.
271    $self->clean_exit(0) if $code =~ /(:quit|exit)/i;
272
273    # look for console's internal language
274    return if $self->command($code);
275
276    # look for a module to import
277    return if $self->useModule($code);
278
279    # Refresh the loaded modules in @INC that have changed
280    Module::Refresh->refresh;
281
282    # looks like it's time to evaluates some code ;)
283    $self->print_result($self->evaluate($code));
284    print "\n";
285
286    # look for something to save in the completion list
287    $self->learn($code);
288
289}
290
291# this reads and interprets the contents of an rc file (~/.perlconsolerc)
292# at startup.  It is useful for things like loading modules that we always
293# want present or setting up some default variables
294sub source_rcfile($)
295{
296    my ($self) = @_;
297    my $file = $self->{'rcfile'};
298    $self->addLog("loading rcfile: $file");
299
300    if ( -r $file) {
301        if (open(RC, "<", "$file")) {
302            while(<RC>) {
303                $self->interpret($_);
304            }
305            close RC;
306        }
307        else {
308            $self->error("unable to read rcfile $file : $!");
309        }
310    }
311    else {
312        $self->error("rcfile $file is not readable");
313    }
314}
315
316# Context methods
317
318# load a module in the console's namespace
319# also take car to import all its symbols in the complection list
320sub load($$;$)
321{
322    my ($self, $package, $tag) = @_;
323    unless (defined $self->{'tags'}{$package}) {
324        $self->{'tags'}{$package} = {};
325    }
326
327    # look for already loaded modules/tags
328    if (defined $tag) {
329        return 1 if defined $self->{'tags'}{$package}{$tag};
330    }
331    else {
332        return 1 if defined $self->{'modules'}{$package};
333    }
334
335    if (eval "require $package") {
336        if (defined $tag) {
337            foreach my $t (split /\s+/, $tag) {
338                eval { $package->import($t); };
339                if ($@) {
340                    $self->addError($@);
341                    return 0;
342                }
343                # mark the tag as loaded
344                $self->{'tags'}{$package}{$tag} = 1;
345            }
346        }
347        else {
348            eval { $package->import(); };
349            if ($@) {
350                $self->addError($@);
351                return 0;
352            }
353        }
354        # mark the module as loaded
355        $self->{'modules'}{$package} = 1;
356        return 1;
357    }
358    $self->addError($@);
359    return 0;
360}
361
362# This function takes a module as argument and loads all its namespace
363# in the completion list.
364sub addNamespace($$)
365{
366    my ($self, $module) = @_;
367    my $namespace;
368    eval '$namespace = \%'.$module.'::';
369    if ($@) {
370        $self->error($@);
371    }
372    $self->addLog("loading namespace of $module");
373
374    foreach my $token (keys %$namespace) {
375        # only put methods found that begins with a letter
376        if ($token =~ /^([a-zA-Z]\S+)$/) {
377            $self->addCompletion([$1]);
378        }
379    }
380}
381
382# This function reads the command line and looks for something that is worth
383# saving in the completion list
384sub learn($$)
385{
386    my ($self, $code) = @_;
387    my $env = $self->{lexical_environment}->get_context('_');
388    foreach my $var (keys %$env) {
389        $self->addCompletion([substr($var, 1)])
390            unless $self->is_completion(substr($var, 1));
391    }
392}
393
394
395# Thanks a lot to Devel::REPL for the Lexical::Persistence idea
396# http://chainsawblues.vox.com/library/post/writing-a-perl-repl-part-3---lexical-environments.html
397#
398# We take the code given and build a sub around it, with each variable of the
399# lexical environment declared with my's. Then, the sub built is evaluated
400# in order to get its code reference, which is returned as the "compiled"
401# code if success. If an error occured during the sub evaluation, undef is
402# returned an the error message is sent to the console.
403sub compile($$)
404{
405    my ($self, $code) = @_;
406    # first we declare each variable in the lexical env
407    my $code_begin = "";
408    foreach my $var (keys %{$self->{lexical_environment}->get_context('_')}) {
409        $code_begin .= "my $var;\n";
410    }
411    # then we prefix the user's code with those variables init and put the
412    # resulting code inside a sub
413    $code = "sub {\n$code_begin\n$code;\n};\n";
414
415    # then we evaluate the sub in order to get its ref
416    my $compiled = eval "$code";
417    if ($@) {
418        $self->error("compilation error: $@");
419        return undef;
420    }
421    return $compiled;
422}
423
424# This function takes care of evaluating the inputed code
425# in a way corresponding to the user's output choice.
426sub evaluate($$)
427{
428    my ($self, $code) = @_;
429
430    # compile the code to a coderef where each variables of the lexical
431    # environment are declared
432    $code = $self->compile($code);
433    return undef unless defined $code;
434
435    # wrap the compiled code with Lexical::Persitence
436    # in order to catch each variable in the lexenv
437    $code = $self->{lexical_environment}->wrap($code);
438    return undef unless defined $code && (ref($code) eq 'CODE');
439
440    # now evaluate the coderef pointed by the sub lexenv->wrap
441    # built for us
442    my @result = eval { &$code(); };
443
444    # an error occured?
445    if ($@) {
446        $self->error("Runtime error: $@");
447        return undef;
448    }
449    return \@result;
450}
451
452# This function is dedicated to print the result in the good way
453# It takes the resulting array of the code evaluated and converts it
454# to the wanted output
455sub print_result
456{
457    my ($self, $ra_result) = @_;
458    return unless defined $ra_result and (ref($ra_result) eq 'ARRAY');
459    my @result = @{$ra_result};
460    $self->message($self->get_output(@result));
461}
462
463
464# the outputs
465sub get_output($@)
466{
467    my ($self, @result) = @_;
468    my $output = $self->getPreference('output');
469
470    # default output is scalar
471    my $str = (@result == 1) ? $result[0] : @result;
472
473    # YAML output
474    if ($output eq 'yaml') {
475        eval '$str = YAML::Dump(@result)';
476    }
477
478    # Data::Dumper output
479    elsif ($output eq 'dumper') {
480        eval '$str = Data::Dumper::Dumper(@result)';
481    }
482
483    # Data::Dump output
484    elsif ($output eq 'dump') {
485        eval '$str = Data::Dump::dump(@result)';
486    }
487
488    # Data::Dump::Streamer output
489    elsif ($output eq 'dds') {
490        my $to_dump = (@result > 1) ? \@result : $result[0];
491        if (ref($to_dump)) {
492            eval 'my $dds = new Data::Dump::Streamer; '.
493             '$dds->Freezer(sub { return "$_[0]"; }); '.
494             '$dds->Data($to_dump); '.
495             '$str = $dds->Out;';
496        }
497        else {
498            return $to_dump;
499        }
500    }
501
502    if ($@) {
503        $self->error("Unable to get formated output: $@");
504        return "";
505    }
506    return $str;
507}
508
509# This looks for a use statement in the string and if so, try to
510# load the module in the namespance, with all tags sepcified in qw()
511# Returns 1 if the code given was about something to load, 0 else.
512sub useModule($$)
513{
514    my ($self, $code) = @_;
515    my $module;
516    my $tag;
517    if ($code =~ /use\s+(\S+)\s+qw\((.+)\)/) {
518        $module = $1;
519        $tag = $2;
520    }
521    elsif ($code =~ /use\s+(\S+)/) {
522        $module = $1;
523    }
524
525    if (defined $module) {
526        # drop the possible trailing ";"
527        $module =~ s/\s*;\s*$//;
528
529        if (!$self->load($module, $tag)) {
530            my $error = $@;
531            chomp $error;
532            $self->error($error);
533        }
534        else {
535            $self->addNamespace($module);
536        }
537        return 1;
538    }
539    return 0;
540}
541
542# this looks for internal command in the given string
543# this is used for changing the user's preference, saving the session,
544# loading a session, etc...
545# The function returns 1 if it found something to do, 0 else.
546sub command($$)
547{
548    my ($self, $code) = @_;
549    return 0 unless $code;
550
551    if (PerlConsole::Commands->isInternalCommand($code)) {
552        return PerlConsole::Commands->execute($self, $code);
553    }
554    return 0;
555}
556
557
558
559# END
5601;
561