#!/usr/bin/perl -w
# psh.pl --- A simple perl shell
# Last modify Time-stamp: <Ye Wenbin 2007-04-15 23:38:08>
# Version: v 0.0 2005/10/23 14:52:44
# Author: Wenbin Ye <wenbinye@163.com>
package Psh::Subs;
use Text::Wrap qw(wrap);
sub reload {
my $mod = shift;
(my $file = $mod) =~ s/::/\//g;
delete $INC{$file.".pm"};
no warnings qw(redefine);
eval("require $mod");
}
sub dump {
print Data::Dumper::Dumper(@_), "\n";
}
sub symtable {
my %module;
my %sym2type;
my %symflag = (SCALAR => '$',
ARRAY => '@',
HASH => '%',
CODE => '&',
GLOB => '*',
);
modules("main::", \%module);
foreach (keys %main::) {
next if /::$/;
foreach my $type (symtype($_)) {
push @{$sym2type{$type}}, $symflag{$type}.$_;
}
}
print "Scalars:\n", wrap('', '', join(" ", sort @{$sym2type{SCALAR}})), "\n\n";
print "Arrays:\n", wrap('', '', join(" ", sort @{$sym2type{ARRAY}})), "\n\n";
print "Hashs:\n", wrap('', '', join(" ", sort @{$sym2type{HASH}})), "\n\n";
print "Subs:\n", wrap('', '', join(" ", sort @{$sym2type{CODE}})), "\n\n";
print "Globs:\n", wrap('', '', join(" ", sort @{$sym2type{GLOB}})), "\n\n";
print "Modules:\n", wrap('', '', join(" ", sort keys %module)), "\n\n";
}
sub modules {
my ($name, $modules) = @_;
return unless $name =~ /::$/;
no strict;
my @syms = grep { $_ ne '' } keys %{$name};
my @submods = grep {/::$/} @syms;
if ($name eq 'main::') {
@submods = grep { $_ ne "main::" } @submods;
$name = '';
}
if (@submods) {
foreach (@submods) {
modules($name.$_, $modules);
}
}
# if the symbol table contain something but modules, add to module hash
if ($#syms != $#submods && $name ne '') {
$modules->{substr($name, 0, -2)}++;
}
}
sub symtype {
my $name = shift;
no strict;
if ($name =~ /::$/) { # like a module name
return;
}
my @types;
if (defined ${$name} ) {
push @types, "SCALAR";
}
if (defined @{$name} ) {
push @types, "ARRAY";
}
if (defined %{$name} ) {
push @types, "HASH";
}
if ( defined &{$name} && main->can($name) ) {
push @types, "CODE";
}
if ( defined *{$name} ) {
push @types, "GLOB";
}
return @types;
}
sub subroutinep {
my $name = shift;
if ( defined(&{"$name"}) ) {
return 1;
}
}
sub variablep {
my $name = shift;
if (scalarp($name)) {
return 1;
}
elsif (arrayp{$name}) {
return 2;
}
elsif (hashp($name)) {
return 3;
}
}
sub scalarp {
my $name = shift;
no strict;
if (defined ${"$name"}) {
return 1;
}
}
sub arrayp {
my $name = shift;
no strict;
if (defined @{"$name"}) {
return 1;
}
}
sub hashp {
my $name = shift;
no strict;
if ($name !~ /::$/ && defined %{"$name"}) {
return 1;
}
}
sub nosub {
my $pos = 0;
my $exp = \$_[0];
while ($$exp =~ /(?=\s?)sub\s+(\w+)/mg) {
$pos = pos($$exp);
# print "pos: ", $pos, "\n";
$$exp =~ s/(?=\s?)sub\s+(\w+)/*$1 = sub/;
$pos = index($$exp, '{', $pos);
# print "pos: ", $pos, "\n";
my $stack = 0;
while (1) {
if (substr($$exp, $pos, 1) eq '{') {
$stack++;
} elsif (substr ($$exp, $pos, 1) eq '}') {
$stack--;
}
if ($stack == 0 || $pos >= length($$exp)) {
last;
}
$pos++;
}
substr($$exp, $pos+1, 0, ";");
# last;
}
}
sub quit {
print "Byebye!\n";
exit;
}
sub locate_mod {
my $mod = shift;
my @mod = split /::/, $mod;
my $dir = [ @INC ];
foreach ( 0..$#mod-1 ) {
$dir = locate_file($mod[$_], undef, $dir);
}
return locate_file($mod[-1], [qw(.pm)], $dir);
}
sub locate_file {
require Regexp::Trie;
my ($name, $ext, $dirs) = @_;
my @files;
my $re;
if ( $ext ) {
$re = new Regexp::Trie;
foreach ( @$ext ) {
$re->add($_);
}
$re = $re->regexp;
} else {
$re = qr(($|\..*$));
}
$re = "^" . quotemeta($name) . $re;
$re = qr($re);
foreach my $d ( @$dirs ) {
next unless -d $d;
if ( substr($d, -1, 1) ne "/" ) {
$d .= "/";
}
opendir(DIR, $d) or die "Can't open directory $d: $!";
my @f = readdir(DIR);
push @files, map { $d . $_ } grep { /$re/ } @f;
}
return \@files;
}
sub help {
my $kw = shift;
if ( $kw =~ /::/ ) {
my $file = locate_mod($kw);
if ( @$file ) {
@ARGV = ($kw);
} else {
warn "Can't find module $kw!\n";
}
} else {
my $file = locate_mod($kw);
if ( @$file ) {
@ARGV = ($kw);
} else {
@ARGV = ("-f", $kw);
}
}
if ( my $pid = fork ) {
waitpid $pid, 0;
} else {
Pod::Perldoc->new('pagers'=>['cat'])->process;
exit;
}
}
package main;
use subs qw(dump help reload symtable);
{
no warnings qw(all);
*dump = \&Psh::Subs::dump;
*x = \&Psh::Subs::dump;
*help = \&Psh::Subs::help;
*reload = \&Psh::Subs::reload;
*symtable = \&Psh::Subs::symtable;
}
use Getopt::Long qw(:config no_ignore_case auto_help);
our $VERSION = v0.01;
our $REMOVE_MY = 0;
our $DEBUG = 0;
our $PROMPT = "perl> ";
my $start_up;
GetOptions(
'debug' => \$DEBUG,
'prompt=s' => \$PROMPT,
'remove-my' => \$REMOVE_MY,
'start-up=s' => \$start_up,
);
print "This is a simple perl shell!\n";
if ( defined $start_up && -f $start_up ) {
print "Load $start_up...\n";
require $start_up;
}
# Turn all buffering off.
select((select(STDOUT), $| = 1)[0]);
select((select(STDERR), $| = 1)[0]);
select((select(STDIN), $| = 1)[0]);
while (1) {
print $PROMPT;
my $__exp__;
my $__line__;
while (1) {
$__line__ = <STDIN>;
unless (defined($__line__)) {
Psh::Subs::quit();
}
chomp($__line__);
$__line__ =~ s/^\s*my\s// if $REMOVE_MY;
if ($__line__ =~ s/\\\s*$//) {
print "+ ";
$__exp__ .= $__line__ . "\n";
} else {
last;
}
}
$__exp__ .= $__line__ . "\n";
print "\nYou just input: $__exp__\n" if $DEBUG;
if ($__exp__ =~ /^(quit|exit|bye)$/) {
Psh::Subs::quit();
} elsif ( $__exp__ =~ /^(help\s+|\?)(.*)\s*$/ ) {
help($2);
} else {
# sub func {} => *func = sub {};
Psh::Subs::nosub($__exp__);
# while ($__exp__ =~ /(?=\s?)sub\s+(\w+)/mg) {
# }
print "Eval '$__exp__'\n" if $DEBUG;
my $res = eval($__exp__);
if ($@) {
print "Error: $@\n";
}
print "\nResult: ", $res, "\n" if defined $res;
}
}
__END__
=head1 NAME
psh.pl - A simple perl shell
=head1 SYNOPSIS
psh.pl
=head1 DESCRIPTION
psh.pl is intended to be a perl shell which is better than `perl -d`.
I use this program in emacs, and it works, but not powerful.
=head2 Predefined command
=over
=item x
A alias for C<Data::Dumper::Dumper>. for example:
perl> $foo = {'a' => 1}
Result: HASH(0x837c674)
perl> x $foo
$VAR1 = {
'a' => 1
};
=item help
Intend for replace input `perldoc` in this program. for example:
perl> help print
print FILEHANDLE LIST
print LIST
print Prints a string or a list of strings. Returns true if...
perl> help Math::Trig
NAME
Math::Trig - trigonometric functions
SYNOPSIS
...
=item reload
Reload a module again. Equal to eval "do($INC{Module.pm}". for example:
perl> require DBI
Result: 1
perl> reload "DBI"
Subroutine DBI::SQL_UDT redefined at /usr/lib/perl5/DBI.pm line 154, <STDIN> line 2.
....
=item symtable
List all variables in package main.
=item quit
=back
=head1 AUTHOR
Ye Wenbin <wenbinye@gmail.com>
=head1 SEE ALSO
=cut