line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package App::PerlShell; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
######################################################## |
4
|
|
|
|
|
|
|
# AUTHOR = Michael Vincent |
5
|
|
|
|
|
|
|
# www.VinsWorld.com |
6
|
|
|
|
|
|
|
######################################################## |
7
|
|
|
|
|
|
|
|
8
|
1
|
|
|
1
|
|
79175
|
use strict; |
|
1
|
|
|
|
|
12
|
|
|
1
|
|
|
|
|
35
|
|
9
|
1
|
|
|
1
|
|
6
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
31
|
|
10
|
1
|
|
|
1
|
|
5
|
use Carp; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
102
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
our $VERSION = "1.08"; |
13
|
|
|
|
|
|
|
|
14
|
1
|
|
|
1
|
|
8
|
use Cwd; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
84
|
|
15
|
1
|
|
|
1
|
|
609
|
use Term::ReadLine; |
|
1
|
|
|
|
|
3149
|
|
|
1
|
|
|
|
|
42
|
|
16
|
1
|
|
|
1
|
|
761
|
use Data::Dumper; |
|
1
|
|
|
|
|
7869
|
|
|
1
|
|
|
|
|
176
|
|
17
|
|
|
|
|
|
|
$Data::Dumper::Sortkeys = 1; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
my $HAVE_LexPersist = 0; |
20
|
1
|
|
|
1
|
|
239
|
eval "use Lexical::Persistence 1.01 ()"; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
21
|
|
|
|
|
|
|
if ( !$@ ) { |
22
|
|
|
|
|
|
|
eval "use App::PerlShell::LexPersist"; |
23
|
|
|
|
|
|
|
$HAVE_LexPersist = 1; |
24
|
|
|
|
|
|
|
} |
25
|
|
|
|
|
|
|
my $HAVE_ModRefresh = 0; |
26
|
1
|
|
|
1
|
|
178
|
eval "use Module::Refresh"; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
if ( !$@ ) { |
28
|
|
|
|
|
|
|
eval "use App::PerlShell::ModRefresh"; |
29
|
|
|
|
|
|
|
$HAVE_ModRefresh = 1; |
30
|
|
|
|
|
|
|
} |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
my %COMMANDS_INT = ( |
33
|
|
|
|
|
|
|
debug => 'print command', |
34
|
|
|
|
|
|
|
exit => 'exit shell' |
35
|
|
|
|
|
|
|
); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
my %COMMANDS = ( |
38
|
|
|
|
|
|
|
cd => 'change directory', |
39
|
|
|
|
|
|
|
cls => 'clear screen', |
40
|
|
|
|
|
|
|
clear => 'clear screen', |
41
|
|
|
|
|
|
|
commands => 'print available "commands" (sub)', |
42
|
|
|
|
|
|
|
dir => 'directory listing', |
43
|
|
|
|
|
|
|
dumper => 'use Data::Dumper to display variable', |
44
|
|
|
|
|
|
|
help => 'shell help - print this', |
45
|
|
|
|
|
|
|
ls => 'directory listing', |
46
|
|
|
|
|
|
|
modules => 'list used modules', |
47
|
|
|
|
|
|
|
perldoc => 'perldoc for current package', |
48
|
|
|
|
|
|
|
pwd => 'print working directory', |
49
|
|
|
|
|
|
|
session => 'start / stop logging session', |
50
|
|
|
|
|
|
|
variables => 'list defined variables' |
51
|
|
|
|
|
|
|
); |
52
|
|
|
|
|
|
|
|
53
|
1
|
|
|
1
|
|
11
|
use Exporter; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
729
|
|
54
|
|
|
|
|
|
|
our @EXPORT = sort ( keys ( %COMMANDS ) ); |
55
|
|
|
|
|
|
|
our @ISA = qw ( Exporter ); |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
sub _shellCommands { |
58
|
0
|
|
|
0
|
|
|
return ( %COMMANDS, %COMMANDS_INT ); |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
sub new { |
62
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
63
|
0
|
|
0
|
|
|
|
my $class = ref($self) || $self; |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
# Default parameters |
66
|
|
|
|
|
|
|
my %params = ( |
67
|
|
|
|
|
|
|
homedir => ( $^O eq "MSWin32" ) ? $ENV{USERPROFILE} : $ENV{HOME}, |
68
|
0
|
0
|
|
|
|
|
package => __PACKAGE__, |
69
|
|
|
|
|
|
|
prompt => 'Perl> ' |
70
|
|
|
|
|
|
|
); |
71
|
|
|
|
|
|
|
|
72
|
0
|
|
|
|
|
|
my $lex = 0; |
73
|
0
|
0
|
|
|
|
|
if ( @_ == 1 ) { |
74
|
0
|
|
|
|
|
|
croak("Insufficient number of args - @_"); |
75
|
|
|
|
|
|
|
} else { |
76
|
0
|
|
|
|
|
|
my %cfg = @_; |
77
|
0
|
|
|
|
|
|
for ( keys(%cfg) ) { |
78
|
0
|
0
|
|
|
|
|
if (/^-?homedir$/i) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
79
|
0
|
0
|
|
|
|
|
if ( -d $cfg{$_} ) { |
80
|
0
|
|
|
|
|
|
$params{homedir} = $cfg{$_}; |
81
|
|
|
|
|
|
|
} else { |
82
|
0
|
|
|
|
|
|
croak("Cannot find directory `$cfg{$_}'"); |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
} elsif (/^-?execute$/i) { |
85
|
0
|
|
|
|
|
|
$params{execute} = $cfg{$_}; |
86
|
|
|
|
|
|
|
} elsif (/^-?lex(?:ical)?$/i) { |
87
|
0
|
|
|
|
|
|
$lex = 1; |
88
|
|
|
|
|
|
|
} elsif (/^-?package$/i) { |
89
|
0
|
|
|
|
|
|
$params{package} = $cfg{$_}; |
90
|
|
|
|
|
|
|
} elsif (/^-?prompt$/i) { |
91
|
0
|
|
|
|
|
|
$params{prompt} = $cfg{$_}; |
92
|
|
|
|
|
|
|
} elsif (/^-?session$/i) { |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
# assign, will test open in run() |
95
|
0
|
|
|
|
|
|
$params{session} = $cfg{$_}; |
96
|
|
|
|
|
|
|
} elsif (/^-?skipvars$/i) { |
97
|
0
|
0
|
|
|
|
|
if ( ref $cfg{$_} eq 'ARRAY' ) { |
98
|
0
|
|
|
|
|
|
$params{skipvars} = $cfg{$_}; |
99
|
|
|
|
|
|
|
} else { |
100
|
0
|
|
|
|
|
|
croak("Not array reference `$cfg{$_}'"); |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
} else { |
103
|
0
|
|
|
|
|
|
croak("Unknown parameter `$_' => `$cfg{$_}'"); |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
|
108
|
0
|
0
|
|
|
|
|
if ($lex) { |
109
|
0
|
0
|
|
|
|
|
if ($HAVE_LexPersist) { |
110
|
|
|
|
|
|
|
$params{shellLexEnv} |
111
|
0
|
|
|
|
|
|
= App::PerlShell::LexPersist->new( $params{package} ); |
112
|
|
|
|
|
|
|
} else { |
113
|
0
|
|
|
|
|
|
croak( |
114
|
|
|
|
|
|
|
"-lexical specified, `Lexical::Persistence' required but not found" |
115
|
|
|
|
|
|
|
); |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
} else { |
118
|
0
|
|
|
|
|
|
$ENV{PERLSHELL_PACKAGE} = $params{package}; |
119
|
|
|
|
|
|
|
} |
120
|
0
|
|
|
|
|
|
$ENV{PERLSHELL_HOME} = $params{homedir}; |
121
|
0
|
|
|
|
|
|
$ENV{PERLSHELL_PROMPT} = $params{prompt}; |
122
|
0
|
0
|
|
|
|
|
if ( defined $params{skipvars} ) { |
123
|
0
|
|
|
|
|
|
$ENV{PERLSHELL_SKIPVARS} = join ';', @{$params{skipvars}}; |
|
0
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
# clean up object |
127
|
0
|
|
|
|
|
|
delete $params{homedir}; |
128
|
0
|
|
|
|
|
|
delete $params{package}; |
129
|
0
|
|
|
|
|
|
delete $params{prompt}; |
130
|
0
|
|
|
|
|
|
delete $params{skipvars}; |
131
|
0
|
|
|
|
|
|
return bless \%params, $class; |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
sub run { |
135
|
0
|
|
|
0
|
1
|
|
my $App_PerlShell_Shell = shift; |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
# handle session if requested |
138
|
0
|
0
|
|
|
|
|
if ( defined $App_PerlShell_Shell->{session} ) { |
139
|
0
|
0
|
|
|
|
|
if ( not defined session( $App_PerlShell_Shell->{session} ) ) { |
140
|
0
|
|
|
|
|
|
croak( |
141
|
|
|
|
|
|
|
"Cannot open session file `$App_PerlShell_Shell->{session}'"); |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
0
|
0
|
|
|
|
|
if ( exists $App_PerlShell_Shell->{shellLexEnv} ) { |
146
|
|
|
|
|
|
|
$App_PerlShell_Shell->{shell} |
147
|
0
|
|
|
|
|
|
= $App_PerlShell_Shell->{shellLexEnv}->get_package(); |
148
|
|
|
|
|
|
|
} else { |
149
|
0
|
|
|
|
|
|
$App_PerlShell_Shell->{shell} = $ENV{PERLSHELL_PACKAGE}; |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
$App_PerlShell_Shell->{shell} |
152
|
0
|
|
|
|
|
|
= Term::ReadLine->new( $App_PerlShell_Shell->{shell} ); |
153
|
0
|
|
|
|
|
|
$App_PerlShell_Shell->{shell}->ornaments(0); |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
#'use strict' is not used to allow "$p=" instead of "my $p=" at the prompt |
156
|
1
|
|
|
1
|
|
9
|
no strict 'vars'; |
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
1518
|
|
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
# will always exeucte without readline first time through (do ... while) |
159
|
0
|
|
|
|
|
|
while (1) { |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
# do ... while loop won't support next and last |
162
|
|
|
|
|
|
|
# First check then clear {execute} to autopopulate |
163
|
|
|
|
|
|
|
# $App_PerlShell_Shell->{shellCmdLine} |
164
|
|
|
|
|
|
|
# otherwise, just do the readline. |
165
|
|
|
|
|
|
|
|
166
|
0
|
0
|
|
|
|
|
if ( defined $App_PerlShell_Shell->{execute} ) { |
167
|
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdLine} |
168
|
0
|
|
|
|
|
|
= $App_PerlShell_Shell->{execute}; |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
# clear - it will never happen again |
171
|
0
|
|
|
|
|
|
delete $App_PerlShell_Shell->{execute}; |
172
|
|
|
|
|
|
|
} else { |
173
|
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdLine} |
174
|
|
|
|
|
|
|
.= $App_PerlShell_Shell->{shell}->readline( |
175
|
|
|
|
|
|
|
( defined $App_PerlShell_Shell->{shellCmdLine} ) |
176
|
|
|
|
|
|
|
? 'More? ' |
177
|
|
|
|
|
|
|
: $ENV{PERLSHELL_PROMPT} |
178
|
0
|
0
|
|
|
|
|
); |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
0
|
|
|
|
|
|
chomp $App_PerlShell_Shell->{shellCmdLine}; |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
# nothing |
184
|
0
|
0
|
|
|
|
|
if ( $App_PerlShell_Shell->{shellCmdLine} =~ /^\s*$/ ) { |
185
|
0
|
|
|
|
|
|
undef $App_PerlShell_Shell->{shellCmdLine}; |
186
|
0
|
|
|
|
|
|
next; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
# exit |
190
|
0
|
0
|
|
|
|
|
if ( $App_PerlShell_Shell->{shellCmdLine} =~ /^\s*exit\s*(;)?\s*$/ ) { |
191
|
0
|
0
|
|
|
|
|
if ( not defined $1 ) { |
192
|
0
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdLine} .= ';'; |
193
|
|
|
|
|
|
|
} |
194
|
0
|
|
|
|
|
|
last; |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
# debug multiline |
198
|
0
|
0
|
|
|
|
|
if ( $App_PerlShell_Shell->{shellCmdLine} =~ /\ndebug$/ ) { |
199
|
0
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdLine} =~ s/debug$//; |
200
|
0
|
|
|
|
|
|
print Dumper $App_PerlShell_Shell; |
201
|
0
|
|
|
|
|
|
next; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
# variables if in -lexical |
205
|
0
|
0
|
|
|
|
|
if ( exists $App_PerlShell_Shell->{shellLexEnv} ) { |
206
|
0
|
0
|
|
|
|
|
if ( $App_PerlShell_Shell->{shellCmdLine} |
207
|
|
|
|
|
|
|
=~ /^\s*variables\s*;\s*$/ ) { |
208
|
0
|
|
|
|
|
|
for my $var ( |
209
|
|
|
|
|
|
|
sort( keys( |
210
|
|
|
|
|
|
|
%{ $App_PerlShell_Shell->{shellLexEnv} |
211
|
0
|
|
|
|
|
|
->get_context('_') |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
) ) |
214
|
|
|
|
|
|
|
) { |
215
|
0
|
|
|
|
|
|
print "$var\n"; |
216
|
|
|
|
|
|
|
} |
217
|
0
|
|
|
|
|
|
undef $App_PerlShell_Shell->{shellCmdLine}; |
218
|
0
|
|
|
|
|
|
next; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
# Complete statement |
223
|
0
|
|
|
|
|
|
%{$App_PerlShell_Shell->{shellCmdComplete}} = ( |
|
0
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
'parenthesis' => 0, |
225
|
|
|
|
|
|
|
'bracket' => 0, |
226
|
|
|
|
|
|
|
'brace' => 0 |
227
|
|
|
|
|
|
|
); |
228
|
0
|
0
|
|
|
|
|
if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\(/g ) ) { |
229
|
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdComplete}->{parenthesis} |
230
|
0
|
|
|
|
|
|
+= scalar(@c); |
231
|
|
|
|
|
|
|
} |
232
|
0
|
0
|
|
|
|
|
if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\)/g ) ) { |
233
|
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdComplete}->{parenthesis} |
234
|
0
|
|
|
|
|
|
-= scalar(@c); |
235
|
|
|
|
|
|
|
} |
236
|
0
|
0
|
|
|
|
|
if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\[/g ) ) { |
237
|
0
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdComplete}->{bracket} += scalar(@c); |
238
|
|
|
|
|
|
|
} |
239
|
0
|
0
|
|
|
|
|
if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\]/g ) ) { |
240
|
0
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdComplete}->{bracket} -= scalar(@c); |
241
|
|
|
|
|
|
|
} |
242
|
0
|
0
|
|
|
|
|
if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\{/g ) ) { |
243
|
0
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdComplete}->{brace} += scalar(@c); |
244
|
|
|
|
|
|
|
} |
245
|
0
|
0
|
|
|
|
|
if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\}/g ) ) { |
246
|
0
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdComplete}->{brace} -= scalar(@c); |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
|
249
|
0
|
0
|
0
|
|
|
|
if ( ( $App_PerlShell_Shell->{shellCmdLine} =~ /,\s*$/ ) |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
250
|
|
|
|
|
|
|
or ( $App_PerlShell_Shell->{shellCmdComplete}->{parenthesis} != 0 ) |
251
|
|
|
|
|
|
|
or ( $App_PerlShell_Shell->{shellCmdComplete}->{bracket} != 0 ) |
252
|
|
|
|
|
|
|
or ( $App_PerlShell_Shell->{shellCmdComplete}->{brace} != 0 ) |
253
|
|
|
|
|
|
|
) { |
254
|
0
|
0
|
|
|
|
|
if ( $App_PerlShell_Shell->{shellCmdLine} !~ /\n;$/ ) { |
255
|
0
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdLine} .= "\n"; |
256
|
0
|
|
|
|
|
|
next; |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
# if all groupings are closed |
261
|
0
|
0
|
0
|
|
|
|
if ( ( $App_PerlShell_Shell->{shellCmdComplete}->{parenthesis} == 0 ) |
|
|
|
0
|
|
|
|
|
262
|
|
|
|
|
|
|
and ( $App_PerlShell_Shell->{shellCmdComplete}->{bracket} == 0 ) |
263
|
|
|
|
|
|
|
and ( $App_PerlShell_Shell->{shellCmdComplete}->{brace} == 0 ) |
264
|
|
|
|
|
|
|
) { |
265
|
|
|
|
|
|
|
# valid endings are ; or } |
266
|
0
|
0
|
|
|
|
|
if ( $App_PerlShell_Shell->{shellCmdLine} !~ /(;|\})\s*$/ ) { |
267
|
|
|
|
|
|
|
# unless PERLSHELL_SEMIOFF, we can add it and continue |
268
|
0
|
0
|
|
|
|
|
if ( $ENV{PERLSHELL_SEMIOFF} ) { |
269
|
0
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdLine} .= ";"; |
270
|
|
|
|
|
|
|
} else { |
271
|
0
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdLine} .= "\n"; |
272
|
0
|
|
|
|
|
|
next; |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
# import subs if not default package |
278
|
|
|
|
|
|
|
# use redundant code in the if block so no variables are |
279
|
|
|
|
|
|
|
# created at top level in case we're not using LexPersist |
280
|
0
|
0
|
|
|
|
|
if ( exists $App_PerlShell_Shell->{shellLexEnv} ) { |
281
|
0
|
0
|
|
|
|
|
if ( $App_PerlShell_Shell->{shellLexEnv}->get_package() ne |
282
|
|
|
|
|
|
|
__PACKAGE__ ) { |
283
|
0
|
|
|
|
|
|
my $sp = $App_PerlShell_Shell->{shellLexEnv}->get_package(); |
284
|
0
|
|
|
|
|
|
my $p = __PACKAGE__; |
285
|
0
|
|
|
|
|
|
eval "package $sp; $p->import;"; |
286
|
0
|
0
|
|
|
|
|
if ($HAVE_ModRefresh) { |
287
|
0
|
|
|
|
|
|
App::PerlShell::ModRefresh->refresh($sp); |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
# execute |
292
|
0
|
|
|
|
|
|
eval { |
293
|
|
|
|
|
|
|
$App_PerlShell_Shell->{shellLexEnv} |
294
|
0
|
|
|
|
|
|
->do( $App_PerlShell_Shell->{shellCmdLine} ); |
295
|
|
|
|
|
|
|
}; |
296
|
|
|
|
|
|
|
} else { |
297
|
0
|
0
|
|
|
|
|
if ( $ENV{PERLSHELL_PACKAGE} ne __PACKAGE__ ) { |
298
|
0
|
|
|
|
|
|
my $sp = $ENV{PERLSHELL_PACKAGE}; |
299
|
0
|
|
|
|
|
|
my $p = __PACKAGE__; |
300
|
0
|
|
|
|
|
|
eval "package $sp; $p->import;"; |
301
|
0
|
0
|
|
|
|
|
if ($HAVE_ModRefresh) { |
302
|
0
|
|
|
|
|
|
App::PerlShell::ModRefresh->refresh($sp); |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdLine} |
306
|
|
|
|
|
|
|
= "package " |
307
|
|
|
|
|
|
|
. $ENV{PERLSHELL_PACKAGE} . ";\n" |
308
|
|
|
|
|
|
|
. $App_PerlShell_Shell->{shellCmdLine} |
309
|
0
|
|
|
|
|
|
. "\nBEGIN {\$ENV{PERLSHELL_PACKAGE} = __PACKAGE__}"; |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
# execute |
312
|
0
|
|
|
|
|
|
eval $App_PerlShell_Shell->{shellCmdLine}; |
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
# error from execute? |
316
|
0
|
0
|
|
|
|
|
warn $@ if ($@); |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
# logging if requested and no error |
319
|
0
|
0
|
0
|
|
|
|
if ( defined( $ENV{PERLSHELL_SESSION} ) and !$@ ) { |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
# don't log session start command |
322
|
0
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdLine} =~ s/\s*session\s*.*//; |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
# clean up command if we added stuff while not in -lex mode |
325
|
0
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdLine} =~ s/^package .*;\n//; |
326
|
|
|
|
|
|
|
$App_PerlShell_Shell->{shellCmdLine} |
327
|
0
|
|
|
|
|
|
=~ s/(?:\n)?BEGIN \{\$ENV\{PERLSHELL_PACKAGE\} = __PACKAGE__\}//; |
328
|
|
|
|
|
|
|
|
329
|
0
|
|
|
|
|
|
open( my $OUT, '>>', $ENV{PERLSHELL_SESSION} ); |
330
|
|
|
|
|
|
|
print $OUT "$App_PerlShell_Shell->{shellCmdLine}\n" |
331
|
0
|
0
|
|
|
|
|
if ( $App_PerlShell_Shell->{shellCmdLine} ne '' ); |
332
|
0
|
|
|
|
|
|
close $OUT; |
333
|
|
|
|
|
|
|
} |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
# reset to normal before next input |
336
|
|
|
|
|
|
|
$App_PerlShell_Shell->{shellLastCmd} |
337
|
0
|
|
|
|
|
|
= $App_PerlShell_Shell->{shellCmdLine}; |
338
|
0
|
|
|
|
|
|
undef $App_PerlShell_Shell->{shellCmdLine}; |
339
|
0
|
|
|
|
|
|
print "\n"; |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
######################################################## |
344
|
|
|
|
|
|
|
# commands |
345
|
|
|
|
|
|
|
######################################################## |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
sub cd { |
348
|
0
|
|
|
0
|
1
|
|
my ($arg) = @_; |
349
|
|
|
|
|
|
|
|
350
|
0
|
|
|
|
|
|
my $ret = getcwd; |
351
|
0
|
0
|
|
|
|
|
if ( not defined $arg ) { |
352
|
0
|
|
|
|
|
|
chdir $ENV{PERLSHELL_HOME}; |
353
|
|
|
|
|
|
|
} else { |
354
|
0
|
0
|
|
|
|
|
if ( -e $arg ) { |
355
|
0
|
|
|
|
|
|
chdir $arg; |
356
|
|
|
|
|
|
|
} else { |
357
|
0
|
|
|
|
|
|
print "Cannot find directory `$arg'\n"; |
358
|
|
|
|
|
|
|
} |
359
|
|
|
|
|
|
|
} |
360
|
0
|
0
|
|
|
|
|
if ( defined wantarray ) { |
361
|
0
|
|
|
|
|
|
return $ret; |
362
|
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
sub cls { |
366
|
0
|
|
|
0
|
1
|
|
return clear(); |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
sub clear { |
370
|
0
|
0
|
|
0
|
1
|
|
if ( $^O eq "MSWin32" ) { |
371
|
0
|
|
|
|
|
|
system('cls'); |
372
|
|
|
|
|
|
|
} else { |
373
|
0
|
|
|
|
|
|
system('clear'); |
374
|
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
sub commands { |
378
|
0
|
|
|
0
|
1
|
|
my ($arg) = @_; |
379
|
|
|
|
|
|
|
|
380
|
0
|
|
|
|
|
|
my @rets; |
381
|
0
|
|
|
|
|
|
my $retType = wantarray; |
382
|
|
|
|
|
|
|
|
383
|
0
|
|
|
|
|
|
my $stash = $ENV{PERLSHELL_PACKAGE} . '::'; |
384
|
|
|
|
|
|
|
|
385
|
1
|
|
|
1
|
|
10
|
no strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
358
|
|
386
|
|
|
|
|
|
|
|
387
|
0
|
|
|
|
|
|
my $regex = qr/^.*$/; |
388
|
0
|
0
|
|
|
|
|
if ( defined($arg) ) { |
389
|
0
|
|
|
|
|
|
$regex = qr/$arg/; |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
|
392
|
0
|
|
|
|
|
|
for my $name ( sort( keys( %{$stash} ) ) ) { |
|
0
|
|
|
|
|
|
|
393
|
0
|
0
|
|
|
|
|
next if ( $name =~ /^_/ ); |
394
|
|
|
|
|
|
|
|
395
|
0
|
|
|
|
|
|
my $sub = *{"${stash}${name}"}{CODE}; |
|
0
|
|
|
|
|
|
|
396
|
0
|
0
|
|
|
|
|
next unless defined $sub; |
397
|
|
|
|
|
|
|
|
398
|
0
|
|
|
|
|
|
my $proto = prototype($sub); |
399
|
0
|
0
|
0
|
|
|
|
next if defined $proto and length($proto) == 0; |
400
|
|
|
|
|
|
|
|
401
|
0
|
0
|
|
|
|
|
if ( $name =~ /$regex/ ) { |
402
|
0
|
|
|
|
|
|
push @rets, $name; |
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
|
|
406
|
0
|
0
|
|
|
|
|
if ( not defined $retType ) { |
|
|
0
|
|
|
|
|
|
407
|
0
|
|
|
|
|
|
for (@rets) { |
408
|
0
|
|
|
|
|
|
print "$_\n"; |
409
|
|
|
|
|
|
|
} |
410
|
|
|
|
|
|
|
} elsif ($retType) { |
411
|
0
|
|
|
|
|
|
return @rets; |
412
|
|
|
|
|
|
|
} else { |
413
|
0
|
|
|
|
|
|
return \@rets; |
414
|
|
|
|
|
|
|
} |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
sub dumper { |
418
|
0
|
|
|
0
|
1
|
|
my (@dump) = @_; |
419
|
|
|
|
|
|
|
|
420
|
1
|
|
|
1
|
|
8
|
use Data::Dumper; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
1293
|
|
421
|
0
|
|
|
|
|
|
$Data::Dumper::Sortkeys = 1; |
422
|
0
|
|
|
|
|
|
print Dumper @dump; |
423
|
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
sub help { |
426
|
0
|
|
|
0
|
1
|
|
my %cmds = _shellCommands(); |
427
|
0
|
|
|
|
|
|
for my $h ( sort( keys(%cmds) ) ) { |
428
|
0
|
|
|
|
|
|
printf "%-15s %s\n", $h, $cmds{$h}; |
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
} |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
sub dir { |
433
|
0
|
|
|
0
|
1
|
|
return ls(@_); |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
sub ls { |
437
|
0
|
|
|
0
|
1
|
|
my (@args) = @_; |
438
|
|
|
|
|
|
|
|
439
|
0
|
|
|
|
|
|
my $dircmd = 'ls'; |
440
|
0
|
0
|
|
|
|
|
if ( $^O eq "MSWin32" ) { |
441
|
0
|
|
|
|
|
|
$dircmd = 'dir'; |
442
|
|
|
|
|
|
|
} |
443
|
|
|
|
|
|
|
|
444
|
0
|
|
|
|
|
|
my @allArgs; |
445
|
0
|
|
|
|
|
|
for my $arg ( @args ) { |
446
|
0
|
|
|
|
|
|
my @temp = split /\s+/, $arg; |
447
|
0
|
|
|
|
|
|
push @allArgs, @temp; |
448
|
|
|
|
|
|
|
} |
449
|
0
|
|
|
|
|
|
@args = @allArgs; |
450
|
|
|
|
|
|
|
|
451
|
0
|
|
|
|
|
|
my @ret; |
452
|
0
|
|
|
|
|
|
my $retType = wantarray; |
453
|
0
|
0
|
|
|
|
|
if ( not defined $retType ) { |
454
|
0
|
|
|
|
|
|
system( $dircmd, @args ); |
455
|
|
|
|
|
|
|
} else { |
456
|
0
|
|
|
|
|
|
@ret = `$dircmd @args`; |
457
|
0
|
0
|
|
|
|
|
if ($retType) { |
458
|
0
|
|
|
|
|
|
return @ret; |
459
|
|
|
|
|
|
|
} else { |
460
|
0
|
|
|
|
|
|
return \@ret; |
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
} |
463
|
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
sub modules { |
466
|
0
|
|
|
0
|
1
|
|
my ($arg) = @_; |
467
|
|
|
|
|
|
|
|
468
|
0
|
|
|
|
|
|
my %rets; |
469
|
0
|
|
|
|
|
|
my $retType = wantarray; |
470
|
|
|
|
|
|
|
|
471
|
0
|
|
|
|
|
|
my $FOUND = 0; |
472
|
0
|
|
|
|
|
|
for my $module ( sort( keys(%INC) ) ) { |
473
|
0
|
|
|
|
|
|
my $path = $INC{$module}; |
474
|
0
|
|
|
|
|
|
$module =~ s/\//::/g; |
475
|
0
|
|
|
|
|
|
$module =~ s/\.pm$//; |
476
|
|
|
|
|
|
|
|
477
|
0
|
0
|
|
|
|
|
if ( defined $arg ) { |
478
|
0
|
0
|
|
|
|
|
if ( $module =~ /$arg/ ) { |
479
|
0
|
|
|
|
|
|
$rets{$module} = $path; |
480
|
0
|
|
|
|
|
|
$FOUND = 1; |
481
|
|
|
|
|
|
|
} |
482
|
|
|
|
|
|
|
} else { |
483
|
0
|
|
|
|
|
|
$rets{$module} = $path; |
484
|
0
|
|
|
|
|
|
$FOUND = 1; |
485
|
|
|
|
|
|
|
} |
486
|
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
|
|
488
|
0
|
0
|
|
|
|
|
if ( !$FOUND ) { |
489
|
0
|
0
|
|
|
|
|
printf "Module(s) not found%s", |
490
|
|
|
|
|
|
|
( defined $arg ) ? " - `$arg'\n" : "\n"; |
491
|
|
|
|
|
|
|
} |
492
|
|
|
|
|
|
|
|
493
|
0
|
0
|
|
|
|
|
if ( not defined $retType ) { |
|
|
0
|
|
|
|
|
|
494
|
0
|
|
|
|
|
|
for my $module ( sort( keys(%rets) ) ) { |
495
|
|
|
|
|
|
|
printf "$module %s\n", |
496
|
0
|
0
|
|
|
|
|
( defined $rets{$module} ) ? $rets{$module} : "[NOT LOADED]"; |
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
} elsif ($retType) { |
499
|
0
|
|
|
|
|
|
return %rets; |
500
|
|
|
|
|
|
|
} else { |
501
|
0
|
|
|
|
|
|
return \%rets; |
502
|
|
|
|
|
|
|
} |
503
|
|
|
|
|
|
|
} |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
sub perldoc { |
506
|
0
|
|
|
0
|
1
|
|
my (@args) = @_; |
507
|
|
|
|
|
|
|
|
508
|
0
|
0
|
|
|
|
|
if ( $#args == -1 ) { |
509
|
0
|
|
|
|
|
|
push @args, $ENV{PERLSHELL_PACKAGE}; |
510
|
|
|
|
|
|
|
} |
511
|
|
|
|
|
|
|
|
512
|
0
|
|
|
|
|
|
my @allArgs; |
513
|
0
|
|
|
|
|
|
for my $arg ( @args ) { |
514
|
0
|
|
|
|
|
|
my @temp = split /\s+/, $arg; |
515
|
0
|
|
|
|
|
|
push @allArgs, @temp; |
516
|
|
|
|
|
|
|
} |
517
|
0
|
|
|
|
|
|
@args = @allArgs; |
518
|
|
|
|
|
|
|
|
519
|
0
|
0
|
|
|
|
|
if ( $args[0] =~ /^::/ ) { |
520
|
0
|
|
|
|
|
|
$args[0] = $ENV{PERLSHELL_PACKAGE} . $args[0]; |
521
|
|
|
|
|
|
|
} |
522
|
|
|
|
|
|
|
|
523
|
0
|
|
|
|
|
|
system( "perldoc", @args ); |
524
|
|
|
|
|
|
|
} |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
sub pwd { |
527
|
0
|
0
|
|
0
|
1
|
|
if ( not defined wantarray ) { |
528
|
0
|
|
|
|
|
|
print getcwd; |
529
|
|
|
|
|
|
|
} else { |
530
|
0
|
|
|
|
|
|
return getcwd; |
531
|
|
|
|
|
|
|
} |
532
|
|
|
|
|
|
|
} |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
sub session { |
535
|
0
|
|
|
0
|
1
|
|
my ($arg) = @_; |
536
|
|
|
|
|
|
|
|
537
|
0
|
0
|
|
|
|
|
if ( not defined $arg ) { |
538
|
0
|
0
|
|
|
|
|
if ( defined $ENV{PERLSHELL_SESSION} ) { |
539
|
0
|
0
|
|
|
|
|
if ( not defined wantarray ) { |
540
|
0
|
|
|
|
|
|
print $ENV{PERLSHELL_SESSION} . "\n"; |
541
|
|
|
|
|
|
|
} |
542
|
0
|
|
|
|
|
|
return $ENV{PERLSHELL_SESSION}; |
543
|
|
|
|
|
|
|
} else { |
544
|
0
|
0
|
|
|
|
|
if ( not defined wantarray ) { |
545
|
0
|
|
|
|
|
|
print "No current session file\n"; |
546
|
|
|
|
|
|
|
} |
547
|
0
|
|
|
|
|
|
return undef; |
548
|
|
|
|
|
|
|
} |
549
|
|
|
|
|
|
|
} |
550
|
|
|
|
|
|
|
|
551
|
0
|
0
|
|
|
|
|
if ( $arg eq ":close" ) { |
552
|
0
|
0
|
|
|
|
|
if ( defined $ENV{PERLSHELL_SESSION} ) { |
553
|
0
|
0
|
|
|
|
|
if ( not defined wantarray ) { |
554
|
0
|
|
|
|
|
|
print "$ENV{PERLSHELL_SESSION} closed\n"; |
555
|
|
|
|
|
|
|
} |
556
|
0
|
|
|
|
|
|
$ENV{PERLSHELL_SESSION} = undef; |
557
|
0
|
|
|
|
|
|
return; |
558
|
|
|
|
|
|
|
} else { |
559
|
0
|
0
|
|
|
|
|
if ( not defined wantarray ) { |
560
|
0
|
|
|
|
|
|
print "No current session file\n"; |
561
|
|
|
|
|
|
|
} |
562
|
0
|
|
|
|
|
|
return undef; |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
} |
565
|
|
|
|
|
|
|
|
566
|
0
|
0
|
|
|
|
|
if ( not defined $ENV{PERLSHELL_SESSION} ) { |
567
|
0
|
0
|
|
|
|
|
if ( -e $arg ) { |
568
|
0
|
0
|
|
|
|
|
if ( not defined wantarray ) { |
569
|
0
|
|
|
|
|
|
print "File `$arg' exists - will append\n"; |
570
|
|
|
|
|
|
|
} |
571
|
|
|
|
|
|
|
} |
572
|
|
|
|
|
|
|
|
573
|
0
|
0
|
|
|
|
|
if ( open( my $fh, '>>', $arg ) ) { |
574
|
0
|
|
|
|
|
|
close $fh; |
575
|
0
|
|
|
|
|
|
$ENV{PERLSHELL_SESSION} = $arg; |
576
|
0
|
0
|
|
|
|
|
if ( not defined wantarray ) { |
577
|
0
|
|
|
|
|
|
print $ENV{PERLSHELL_SESSION} . "\n"; |
578
|
|
|
|
|
|
|
} |
579
|
0
|
|
|
|
|
|
return $ENV{PERLSHELL_SESSION}; |
580
|
|
|
|
|
|
|
} else { |
581
|
0
|
0
|
|
|
|
|
if ( not defined wantarray ) { |
582
|
0
|
|
|
|
|
|
print "Cannot open file `$arg' for writing\n"; |
583
|
|
|
|
|
|
|
} |
584
|
0
|
|
|
|
|
|
return undef; |
585
|
|
|
|
|
|
|
} |
586
|
|
|
|
|
|
|
} else { |
587
|
0
|
0
|
|
|
|
|
if ( not defined wantarray ) { |
588
|
0
|
|
|
|
|
|
print "Session file already open - `$ENV{PERLSHELL_SESSION}'\n"; |
589
|
|
|
|
|
|
|
} |
590
|
0
|
|
|
|
|
|
return; |
591
|
|
|
|
|
|
|
} |
592
|
|
|
|
|
|
|
} |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
sub variables { |
595
|
|
|
|
|
|
|
|
596
|
0
|
|
|
0
|
1
|
|
my %SKIP = ( |
597
|
|
|
|
|
|
|
'$VERSION' => 1, |
598
|
|
|
|
|
|
|
'@ISA' => 1, |
599
|
|
|
|
|
|
|
'@EXPORT' => 1 |
600
|
|
|
|
|
|
|
); |
601
|
|
|
|
|
|
|
|
602
|
0
|
0
|
|
|
|
|
if ( !exists $ENV{PERLSHELL_PACKAGE} ) { |
603
|
0
|
|
|
|
|
|
print "In -lexical mode, try again on line by iteslf\n"; |
604
|
0
|
|
|
|
|
|
return; |
605
|
|
|
|
|
|
|
} |
606
|
|
|
|
|
|
|
|
607
|
0
|
0
|
|
|
|
|
if ( defined $ENV{PERLSHELL_SKIPVARS} ) { |
608
|
0
|
|
|
|
|
|
for ( split /;/, $ENV{PERLSHELL_SKIPVARS} ) { |
609
|
0
|
|
|
|
|
|
$SKIP{"$_"} = 1; |
610
|
|
|
|
|
|
|
} |
611
|
|
|
|
|
|
|
} |
612
|
|
|
|
|
|
|
|
613
|
0
|
|
|
|
|
|
my @rets; |
614
|
0
|
|
|
|
|
|
my $retType = wantarray; |
615
|
|
|
|
|
|
|
|
616
|
1
|
|
|
1
|
|
11
|
no strict 'refs'; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
305
|
|
617
|
0
|
|
|
|
|
|
for my $var ( sort( keys( %{$ENV{PERLSHELL_PACKAGE} . '::'} ) ) ) { |
|
0
|
|
|
|
|
|
|
618
|
0
|
0
|
0
|
|
|
|
if ( defined( ${$ENV{PERLSHELL_PACKAGE} . "::$var"} ) |
|
0
|
0
|
0
|
|
|
|
|
|
|
0
|
0
|
|
|
|
|
619
|
|
|
|
|
|
|
and not defined( $SKIP{'$' . $var} ) ) { |
620
|
0
|
|
|
|
|
|
push @rets, "\$$var"; |
621
|
0
|
|
|
|
|
|
} elsif ( @{$ENV{PERLSHELL_PACKAGE} . "::$var"} |
622
|
|
|
|
|
|
|
and not defined( $SKIP{'@' . $var} ) ) { |
623
|
0
|
|
|
|
|
|
push @rets, "\@$var"; |
624
|
0
|
|
|
|
|
|
} elsif ( %{$ENV{PERLSHELL_PACKAGE} . "::$var"} |
625
|
|
|
|
|
|
|
and not defined( $SKIP{'%' . $var} ) ) { |
626
|
0
|
|
|
|
|
|
push @rets, "\%$var"; |
627
|
|
|
|
|
|
|
} |
628
|
|
|
|
|
|
|
} |
629
|
|
|
|
|
|
|
|
630
|
0
|
0
|
|
|
|
|
if ( not defined $retType ) { |
|
|
0
|
|
|
|
|
|
631
|
0
|
|
|
|
|
|
for (@rets) { |
632
|
0
|
|
|
|
|
|
print "$_\n"; |
633
|
|
|
|
|
|
|
} |
634
|
|
|
|
|
|
|
} elsif ($retType) { |
635
|
0
|
|
|
|
|
|
return @rets; |
636
|
|
|
|
|
|
|
} else { |
637
|
0
|
|
|
|
|
|
return \@rets; |
638
|
|
|
|
|
|
|
} |
639
|
|
|
|
|
|
|
} |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
1; |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
__END__ |