our
$VERSION
=
'0.03'
;
sub
run {
my
$class
=
shift
;
my
$args
= {
@_
};
GetOptions(
'namespace=s'
=> \
my
@namespaces
,
'file=s'
=> \
my
@files
,
'package=s'
=> \
my
@packages
,
'help'
=> \
my
$help_wanted
,
'compgen'
=> \
my
$compgen_wanted
,
);
if
(
$help_wanted
) {
print
$class
->help_message;
exit
73;
}
my
$arg_namespaces
=
$args
->{namespaces} || [];
basename($0) =~ /^(.*)\./;
my
$name
= $1 || basename($0);
my
$prompt
=
$name
.
'@'
. hostname() .
'> '
;
my
$arg_prompt
=
$args
->{prompt} ||
sub
{
$prompt
};
my
$ctx
= Term::Shell::Pluggable::Context->new(
namespaces
=> [
@namespaces
,
@$arg_namespaces
],
prompt
=>
$arg_prompt
);
my
$a_packages
=
$args
->{packages};
foreach
my
$name
(
@packages
,
@$a_packages
) {
$ctx
->load_package(
$name
);
}
my
$a_files
=
$args
->{files};
foreach
my
$path
(
@files
,
@$a_files
) {
$ctx
->load_file(
$path
);
}
if
(
$compgen_wanted
) {
$ctx
->compgen(
@ARGV
);
exit
0;
}
if
(
scalar
@ARGV
> 0) {
my
$cmd
=
''
;
for
my
$arg
(
@ARGV
) {
$cmd
.=
' '
if
$cmd
;
if
(
$arg
=~ /\s/) {
$cmd
.=
"'$arg'"
;
}
else
{
$cmd
.=
$arg
;
}
}
$ctx
->cmd(
$cmd
);
exit
13
if
$ctx
->{last_cmd_error};
}
else
{
$ctx
->cmdloop;
}
}
sub
help_message {
<<EOF;
usage: $0 [--file=/home/joe/test.pm] [--namespace=Some::Namespace] [--package=Some::Shell] [command] [options...]
try $0 help for list of commands
EOF
}
sub
compgen {
my
$self
=
shift
;
my
(
$word
,
$line
,
$point
) =
@_
;
if
(
$line
=~ /^(\w+\s+)/) {
my
$l
=
length
$1;
$line
=
substr
$line
,
$l
;
$point
-=
$l
;
}
my
$start
=
$point
;
if
(
$word
) {
$start
=
$start
-
length
$word
;
}
else
{
$word
=
''
;
}
my
$reply
=
join
"\n"
,
$self
->rl_complete(
$word
,
$line
,
$start
);
print
$reply
.
"\n"
;
}
sub
new {
my
$class
=
shift
;
my
$args
= {
@_
};
if
(
my
$namespaces
=
$args
->{namespaces}) {
foreach
my
$search_path
(
@$namespaces
) {
$class
->search_path(
add
=>
$search_path
);
}
}
my
$self
=
$class
->SUPER::new();
$self
->{prompt} =
$args
->{prompt};
return
$self
;
}
sub
prompt_str {
shift
->{prompt}->();
}
sub
preloop {
my
$self
=
shift
;
my
$modules
=
join
', '
, @{
$self
->{modules}};
if
(
$modules
) {
}
else
{
die
"no modules\n"
;
}
my
(
undef
,
undef
,
$f
) = File::Spec->splitpath($0);
$f
=~ s/\.pl$//;
$f
=~ s/\W/_/g;
$self
->{history_path} = File::Spec->catfile(
$ENV
{HOME},
'.'
.
$f
.
'_history'
)
if
$f
;
if
(
$self
->{term}->Features->{setHistory} and
$self
->{history_path} and -r
$self
->{history_path}) {
open
my
$fh
,
'<'
,
$self
->{history_path} or
die
"can't read $self->{history_path}: $!"
;
my
@history
= <
$fh
>;
chomp
@history
;
$self
->{term}->SetHistory(
@history
);
close
$fh
;
}
}
sub
postloop {
my
$self
=
shift
;
print
"\n"
;
if
(
$self
->{term}->Features->{getHistory} and
$self
->{history_path}) {
open
my
$fh
,
'>'
,
$self
->{history_path} or
die
"can't write $self->{history_path}: $!"
;
my
$prev_line
;
foreach
my
$line
(
$self
->{term}->GetHistory()) {
next
unless
length
$line
;
next
if
$prev_line
and
$line
eq
$prev_line
;
print
$fh
"$line\n"
;
$prev_line
=
$line
;
}
close
$fh
;
}
}
sub
run {
my
$self
=
shift
;
eval
{
$self
->SUPER::run(
@_
);
};
my
$error
= $@;
if
(
$error
) {
print
STDERR
"command failed: $error"
;
$self
->{last_cmd_error} =
$error
;
}
else
{
$self
->{last_cmd_error} =
undef
;
}
}
our
@ISA
;
sub
init {
my
$self
=
shift
;
$self
->{modules} = [];
$self
->{r} = {};
for
my
$module
(
$self
->plugins) {
$self
->attach_package(
$module
);
}
}
sub
load_package {
my
$self
=
shift
;
my
(
$package_name
) =
@_
;
{
no
strict
'refs'
;
unless
(
grep
{
$_
!~ /::$/} %{
$package_name
.
'::'
}) {
no
warnings;
eval
"require $package_name"
or
die
"can't load $package_name: $@"
;
}
}
$self
->attach_package(
$package_name
);
}
sub
load_file {
my
$self
=
shift
;
my
(
$path
) =
@_
;
die
"file not found: $path"
unless
-f
$path
;
open
my
$fh
,
$path
or
die
"can't read $path: $!"
;
my
$in_pod
= 0;
{
my
$result
=
do
$path
;
if
(
my
$errror
= $@) {
warn
;
}
elsif
(not
defined
$result
) {
warn
"can't do $path: $!"
;
}
elsif
(not
$result
) {
warn
"$path returns false"
;
}
}
while
(
my
$line
= <
$fh
>) {
$in_pod
= 1
if
$line
=~ m/^=\w/;
$in_pod
= 0
if
$line
=~ /^=cut/;
next
if
(
$in_pod
||
$line
=~ /^=cut/);
next
if
$line
=~ /^\s*
if
(
$line
=~ m/^\s
*package
\s+(.*::)?(.*)\s*;/i) {
my
@up
=
split
/::/, $1
if
defined
$1;
$self
->attach_package(
join
"::"
,
@up
, $2);
}
}
close
$fh
;
}
sub
attach_package {
my
$self
=
shift
;
my
(
$package_name
,
$sub_package_name
) =
@_
;
die
'missing package name'
unless
$package_name
;
my
@t
=
split
'::'
,
$package_name
;
my
$modules
=
$self
->{modules};
push
@$modules
,
pop
@t
unless
$sub_package_name
;
{
no
strict
'refs'
;
foreach
my
$sub_name
(
keys
%{
$package_name
.
'::'
}) {
next
unless
$sub_name
=~ /^(run|help|smry|comp|
catch
|alias)_/o;
$self
->{r}->{
$sub_name
} =
$sub_package_name
||
$package_name
;
$self
->add_handlers(
$sub_name
);
}
}
{
no
strict
'refs'
;
foreach
my
$super_package_name
(@{
$package_name
.
'::ISA'
}) {
$self
->attach_package(
$super_package_name
,
$sub_package_name
||
$package_name
);
}
}
}
our
$AUTOLOAD
;
sub
AUTOLOAD {
my
$self
=
shift
;
my
@t
=
split
/::/,
$AUTOLOAD
;
my
$sub_name
=
pop
@t
;
my
$class
=
join
'::'
,
@t
;
return
unless
ref
$self
eq
$class
;
if
(
my
$package_name
=
$self
->{r}->{
$sub_name
}) {
$package_name
->
$sub_name
(
@_
);
}
else
{
return
undef
;
}
}
1;