#!/usr/bin/perl -w
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
(
$#syms
!=
$#submods
&&
$name
ne
''
) {
$modules
->{
substr
(
$name
, 0, -2)}++;
}
}
sub
symtype {
my
$name
=
shift
;
no
strict;
if
(
$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
);
$$exp
=~ s/(?=\s?)
sub
\s+(\w+)/*$1 =
sub
/;
$pos
=
index
(
$$exp
,
'{'
,
$pos
);
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,
";"
);
}
}
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 {
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
;
}
}
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
;
}
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
;
}
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
{
Psh::Subs::nosub(
$__exp__
);
print
"Eval '$__exp__'\n"
if
$DEBUG
;
my
$res
=
eval
(
$__exp__
);
if
($@) {
print
"Error: $@\n"
;
}
print
"\nResult: "
,
$res
,
"\n"
if
defined
$res
;
}
}