Commit | Line | Data |
afe61f9c |
1 | package Devel::REPL; |
2 | |
3 | use Term::ReadLine; |
4 | use Moose; |
48ddfeae |
5 | use namespace::clean -except => [ 'meta' ]; |
089a0c4e |
6 | use 5.008001; # backwards compat, doesn't warn like 5.8.1 |
59aedffc |
7 | |
6edfdc07 |
8 | our $VERSION = '1.002001'; # 1.2.1 |
afe61f9c |
9 | |
10 | with 'MooseX::Object::Pluggable'; |
11 | |
e22aa835 |
12 | use Devel::REPL::Error; |
13 | |
afe61f9c |
14 | has 'term' => ( |
15 | is => 'rw', required => 1, |
16 | default => sub { Term::ReadLine->new('Perl REPL') } |
17 | ); |
18 | |
19 | has 'prompt' => ( |
20 | is => 'rw', required => 1, |
21 | default => sub { '$ ' } |
22 | ); |
23 | |
24 | has 'out_fh' => ( |
25 | is => 'rw', required => 1, lazy => 1, |
26 | default => sub { shift->term->OUT || \*STDOUT; } |
27 | ); |
28 | |
29 | sub run { |
30 | my ($self) = @_; |
e22aa835 |
31 | while ($self->run_once_safely) { |
afe61f9c |
32 | # keep looping |
33 | } |
34 | } |
35 | |
e22aa835 |
36 | sub run_once_safely { |
37 | my ($self, @args) = @_; |
38 | |
39 | my $ret = eval { $self->run_once(@args) }; |
40 | |
41 | if ($@) { |
42 | my $error = $@; |
43 | eval { $self->print("Error! - $error\n"); }; |
44 | return 1; |
45 | } else { |
46 | return $ret; |
47 | } |
48 | } |
49 | |
afe61f9c |
50 | sub run_once { |
51 | my ($self) = @_; |
e22aa835 |
52 | |
afe61f9c |
53 | my $line = $self->read; |
54 | return unless defined($line); # undefined value == EOF |
e22aa835 |
55 | |
56 | my @ret = $self->formatted_eval($line); |
57 | |
58 | $self->print(@ret); |
59 | |
afe61f9c |
60 | return 1; |
61 | } |
62 | |
e22aa835 |
63 | sub formatted_eval { |
64 | my ( $self, @args ) = @_; |
65 | |
66 | my @ret = $self->eval(@args); |
67 | |
68 | return $self->format(@ret); |
69 | } |
70 | |
71 | sub format { |
72 | my ( $self, @stuff ) = @_; |
73 | |
c3bbf326 |
74 | if ( $self->is_error($stuff[0]) ) { |
e22aa835 |
75 | return $self->format_error(@stuff); |
76 | } else { |
77 | return $self->format_result(@stuff); |
78 | } |
79 | } |
80 | |
81 | sub format_result { |
82 | my ( $self, @stuff ) = @_; |
83 | |
84 | return @stuff; |
85 | } |
86 | |
87 | sub format_error { |
88 | my ( $self, $error ) = @_; |
89 | return $error->stringify; |
90 | } |
91 | |
c3bbf326 |
92 | sub is_error { |
93 | my ( $self, $thingy ) = @_; |
94 | blessed($thingy) and $thingy->isa("Devel::REPL::Error"); |
95 | } |
96 | |
afe61f9c |
97 | sub read { |
98 | my ($self) = @_; |
99 | return $self->term->readline($self->prompt); |
100 | } |
101 | |
911a1c24 |
102 | sub eval { |
103 | my ($self, $line) = @_; |
c3bbf326 |
104 | my $compiled = $self->compile($line); |
105 | return $compiled unless defined($compiled) and not $self->is_error($compiled); |
106 | return $self->execute($compiled); |
911a1c24 |
107 | } |
108 | |
109 | sub compile { |
e22aa835 |
110 | my ( $_REPL, @args ) = @_; |
111 | my $compiled = eval $_REPL->wrap_as_sub(@args); |
c3bbf326 |
112 | return $_REPL->error_return("Compile error", $@) if $@; |
911a1c24 |
113 | return $compiled; |
114 | } |
115 | |
116 | sub wrap_as_sub { |
e22aa835 |
117 | my ($self, $line, %args) = @_; |
118 | return qq!sub {\n!. ( $args{no_mangling} ? $line : $self->mangle_line($line) ).qq!\n}\n!; |
911a1c24 |
119 | } |
120 | |
121 | sub mangle_line { |
122 | my ($self, $line) = @_; |
123 | return $line; |
124 | } |
125 | |
afe61f9c |
126 | sub execute { |
48ddfeae |
127 | my ($self, $to_exec, @args) = @_; |
128 | my @ret = eval { $to_exec->(@args) }; |
129 | return $self->error_return("Runtime error", $@) if $@; |
afe61f9c |
130 | return @ret; |
131 | } |
132 | |
911a1c24 |
133 | sub error_return { |
134 | my ($self, $type, $error) = @_; |
e22aa835 |
135 | return Devel::REPL::Error->new( type => $type, message => $error ); |
911a1c24 |
136 | } |
137 | |
afe61f9c |
138 | sub print { |
139 | my ($self, @ret) = @_; |
140 | my $fh = $self->out_fh; |
59aedffc |
141 | no warnings 'uninitialized'; |
afe61f9c |
142 | print $fh "@ret"; |
a66625d6 |
143 | print $fh "\n" if $self->term->ReadLine =~ /Gnu/; |
afe61f9c |
144 | } |
145 | |
59aedffc |
146 | =head1 NAME |
147 | |
148 | Devel::REPL - a modern perl interactive shell |
149 | |
150 | =head1 SYNOPSIS |
151 | |
152 | my $repl = Devel::REPL->new; |
153 | $repl->load_plugin($_) for qw(History LexEnv); |
154 | $repl->run |
155 | |
156 | Alternatively, use the 're.pl' script installed with the distribution |
157 | |
950232b2 |
158 | system$ re.pl |
159 | |
59aedffc |
160 | =head1 AUTHOR |
161 | |
162 | Matt S Trout - mst (at) shadowcatsystems.co.uk (L<http://www.shadowcatsystems.co.uk/>) |
163 | |
c1d5d500 |
164 | =head1 CONTRIBUTORS |
165 | |
166 | =over 4 |
167 | |
168 | =item Stevan Little - stevan (at) iinteractive.com |
169 | |
170 | =item Alexis Sukrieh - sukria+perl (at) sukria.net |
171 | |
172 | =item epitaph |
173 | |
174 | =item mgrimes - mgrimes (at) cpan dot org |
175 | |
176 | =item Shawn M Moore - sartak (at) gmail.com |
177 | |
178 | =back |
179 | |
59aedffc |
180 | =head1 LICENSE |
181 | |
182 | This library is free software under the same terms as perl itself |
183 | |
184 | =cut |
185 | |
afe61f9c |
186 | 1; |