Commit | Line | Data |
e958cbc6 |
1 | package Devel::REPL::Plugin::Turtles; |
e22aa835 |
2 | use Devel::REPL::Plugin; |
3 | |
4 | use Scalar::Util qw(reftype); |
5 | |
6 | use MooseX::AttributeHelpers; |
7 | |
48ddfeae |
8 | use namespace::clean -except => [ 'meta' ]; |
e958cbc6 |
9 | |
e22aa835 |
10 | has default_command_prefix => ( |
11 | isa => "RegexpRef", |
12 | is => "rw", |
13 | default => sub { qr/\#/ }, |
14 | ); |
15 | |
16 | has turtles_matchers => ( |
17 | metaclass => "Collection::Array", |
18 | isa => "ArrayRef[RegexpRef|CodeRef]", |
19 | is => "rw", |
4ea2c254 |
20 | lazy => 1, |
e22aa835 |
21 | default => sub { my $prefix = shift->default_command_prefix; [qr/^ $prefix (\w+) \s* (.*) /x] }, |
22 | provides => { |
23 | unshift => "add_turtles_matcher", |
24 | }, |
25 | ); |
26 | |
27 | around 'formatted_eval' => sub { |
0cbfa921 |
28 | my $next = shift; |
e22aa835 |
29 | my ($self, $line, @args) = @_; |
0cbfa921 |
30 | |
e22aa835 |
31 | if ( my ( $command, @rest ) = $self->match_turtles($line) ) { |
0cbfa921 |
32 | my $method = "command_$command"; |
e22aa835 |
33 | my $expr_method = "expr_$method"; |
0cbfa921 |
34 | |
e22aa835 |
35 | if ( my $expr_code = $self->can($expr_method) ) { |
36 | if ( my $read_more = $self->can("continue_reading_if_necessary") ) { |
37 | push @rest, $self->$read_more(pop @rest); |
38 | } |
39 | $self->$expr_code($next, @rest); |
40 | } elsif ( my $cmd_code = $self->can($method) ) { |
41 | return $self->$cmd_code($next, @rest); |
0cbfa921 |
42 | } else { |
e22aa835 |
43 | unless ( $line =~ /^\s*#/ ) { # special case for comments |
44 | return $self->format($self->error_return("REPL Error", "Command '$command' does not exist")); |
45 | } |
e958cbc6 |
46 | } |
e22aa835 |
47 | } else { |
48 | return $self->$next($line, @args); |
0cbfa921 |
49 | } |
e958cbc6 |
50 | }; |
51 | |
e22aa835 |
52 | sub match_turtles { |
53 | my ( $self, $line ) = @_; |
54 | |
55 | foreach my $thingy ( @{ $self->turtles_matchers } ) { |
56 | if ( reftype $thingy eq 'CODE' ) { |
57 | if ( my @res = $self->$thingy($line) ) { |
58 | return @res; |
59 | } |
60 | } else { |
61 | if ( my @res = ( $line =~ $thingy ) ) { |
62 | return @res; |
63 | } |
64 | } |
65 | } |
66 | |
67 | return; |
68 | } |
69 | |
48ddfeae |
70 | 1; |
cfd1094b |
71 | |
72 | __END__ |
73 | |
74 | =head1 NAME |
75 | |
76 | Devel::REPL::Plugin::Turtles - Generic command creation using a read hook |
77 | |
78 | =cut |
79 | |