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