File Coverage

blib/lib/MozRepl/AnyEvent.pm
Criterion Covered Total %
statement 4 6 66.6
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 6 8 75.0


line stmt bran cond sub pod time code
1             package MozRepl::AnyEvent;
2 1     1   18315 use strict;
  1         3  
  1         28  
3 1     1   119 use AnyEvent;
  0            
  0            
4             use AnyEvent::Handle;
5             use AnyEvent::Strict;
6             use Encode qw(decode);
7             use Carp qw(croak);
8              
9             use vars qw[$VERSION];
10             $VERSION = '0.40';
11              
12             =head1 NAME
13              
14             MozRepl::AnyEvent - AnyEvent-enabled MozRepl client
15              
16             =head1 SYNOPSIS
17              
18             use MozRepl::RemoteObject;
19             $ENV{ MOZREPL_CLASS } = 'MozRepl::AnyEvent';
20             my $bridge = MozRepl::RemoteObject->install_bridge();
21              
22             This module provides a compatible API to L solely
23             for what L uses. It does not
24             provide plugin support. If you want a fully compatible
25             AnyEvent-enabled L, please consider porting L
26             to L.
27              
28             Instead of using the process environment, you can also pass
29             the backend class using the C parameter in the constructor:
30              
31             use MozRepl::RemoteObject;
32             my $bridge = MozRepl::RemoteObject->install_bridge(
33             repl_class => 'MozRepl::AnyEvent',
34             );
35              
36             The module in C will be loaded through C. If the module
37             does not load, the fatal error will propagate. No fallbacks are tried.
38              
39             =head1 METHODS
40              
41             =head2 C<< MozRepl::AnyEvent->new( %options ) >>
42              
43             Creates a new instance.
44              
45             Options
46              
47             =over 4
48              
49             =item *
50              
51             C - arrayref of log levels to enable
52              
53             Currently only C is implemented, which will dump some information.
54              
55             log => [qw[debug],
56              
57             =item *
58              
59             C - a premade L to talk to Firefox (optional)
60              
61             =item *
62              
63             C - the regex that defines the repl prompt to look for.
64              
65             Default is
66              
67             prompt => qr/^(?:\.+>\s)*(repl\d*)>\s+/m
68              
69             =back
70              
71             =cut
72              
73             sub new {
74             my ($class, %args) = @_;
75             bless {
76             hdl => undef,
77             prompt => qr/^(?:\.+>\s)*(repl\d*)>\s+/m,
78             # The execute stack is an ugly hack to enable synchronous
79             # execution within MozRepl::AnyEvent while still having
80             # at most one ->recv call outstanding.
81             # Ideally, this facility would go into AnyEvent itself.
82             execute_stack => [],
83             %args
84             } => $class;
85             };
86              
87             =head2 C<< $repl->log( $level, @info ) >>
88              
89             Prints the information to STDERR if logging is enabled
90             for the level.
91              
92             =cut
93              
94             sub log {
95             my ($self,$level,@info) = @_;
96             if ($self->{log}->{$level}) {
97             warn "[$level] $_\n" for @info;
98             };
99             };
100              
101             =head2 C<< $repl->setup_async( $options ) >>
102              
103             my $repl = MozRepl::AnyEvent->setup({
104             client => { host => 'localhost',
105             port => 4242,
106             },
107             log => ['debug'],
108             cv => $cv,
109             });
110              
111             Sets up the repl connection. See L::setup for detailed documentation.
112              
113             The optional CV will get the repl through C<< ->send() >>.
114              
115             Returns the CV to wait on that signals when setup is done.
116              
117             =cut
118              
119             sub setup_async {
120             my ($self,$options) = @_;
121             my $client = delete $options->{ client } || {};
122             $client->{port} ||= 4242;
123             $client->{host} ||= 'localhost';
124             $options->{log} ||= [];
125             my $cb = delete $options->{cv} || AnyEvent->condvar;
126            
127             $self->{log} = +{ map { $_ => 1 } @{$options->{ log }} };
128            
129             # Also enable the lower log levels
130             my @levels = qw( error warn info debug );
131             for (reverse(1..$#levels)) {
132             if ($self->{log}->{ $levels[ $_ ]}) {
133             $self->{log}->{ $levels[ $_-1 ]} = 1;
134             };
135             };
136            
137             my $hdl; $hdl = $self->{hdl} || AnyEvent::Handle->new(
138             connect => [ $client->{host}, $client->{port} ],
139             #no_delay => 1, # reduce latency, seems to have no effect
140             on_error => sub {
141             $self->log('error',$_[2]);
142             $self->{error} = $_[2];
143             $cb->send();
144             delete $self->{hdl};
145             $_[0]->destroy;
146             undef $cb;
147             undef $self;
148             },
149            
150             on_connect => sub {
151             my ($hdl,$host,$port) = @_;
152             $self->log('debug', "Connected to $host:$port");
153             $hdl->push_read( regex => $self->{prompt}, sub {
154             my ($handle, $data) = @_;
155             $data =~ /$self->{prompt}/m
156             or croak "Couldn't find REPL name in '$data'";
157             $self->{name} = $1;
158             $self->log('debug', "Repl name is '$1'");
159            
160             # Tell anybody interested that we're connected now
161             $self->log('debug', "Connected now");
162             $cb->send($self)
163             });
164             },
165             );
166            
167             # Read the welcome banner
168             $self->{hdl} = $hdl;
169            
170             $cb
171             };
172              
173             =head2 C<< $repl->setup(...) >>
174              
175             Synchronous version of C<< ->setup_async >>, provided
176             for API compatibility. This one will do a C<< ->recv >> call
177             inside.
178              
179             =cut
180              
181             sub setup {
182             my ($self,$options) = @_;
183             my $done = $self->setup_async($options);
184             my @res = $done->recv;
185             if (not @res) {
186             # reraise error
187             die $self->{error}
188             };
189             @res
190             };
191              
192             =head2 C<< $repl->repl >>
193              
194             Returns the name of the repl in Firefox.
195              
196             =cut
197              
198             sub repl { $_[0]->{name} };
199              
200              
201             =head2 C<< $repl->hdl >>
202              
203             Returns the socket handle of the repl.
204              
205             =cut
206              
207             sub hdl { $_[0]->{hdl} };
208              
209             =head2 C<< $repl->execute_async( $command, $cb ) >>
210              
211             my $cv = $repl->execute_async( '1+1' );
212             # do stuff
213             my $two = $cv->recv;
214             print "1+1 is $two\n";
215              
216             Sends a command to Firefox for execution. Returns
217             the condvar to wait for the response.
218              
219             =cut
220              
221             sub execute_async {
222             my ($self, $command, $cb) = @_;
223             $self->log( info => "Sending command", $command);
224             $cb ||= AnyEvent->condvar;
225             $self->hdl->push_write( $command );
226             $self->log(debug => "Waiting for prompt", $self->{prompt});
227              
228             # Push a log-peek
229             #$self->hdl->push_read(sub {
230             # $self->log(debug => "Received data", $_[0]->{rbuf});
231             # return $_[0]->{rbuf} =~ /repl\d*> /;
232             #});
233            
234             $self->hdl->push_read( regex => $self->{prompt},
235             timeout => 10,
236             sub {
237             $_[1] =~ s/$self->{prompt}$//;
238             #warn "<<$_[1]>>";
239             $self->log(info => "Received data", $_[1]);
240             # We could decode from UTF-8 here already,
241             # but that would mean differnt logic between
242             # MozRepl.pm and MozRepl::AnyEvent.pm
243             # $cb->(decode('UTF-8' => $_[1]));
244             $cb->($_[1]);
245             });
246             $cb
247             };
248              
249             =head2 C<< $repl->execute( ... ) >>
250              
251             Synchronous version of C<< ->execute_async >>. Internally
252             calls C<< ->recv >>. Provided for API compatibility.
253              
254             =cut
255              
256             sub execute {
257             my $self = shift;
258             my $cv = $self->execute_async( @_ );
259             if (my $cb = pop @{ $self->{execute_stack} }) {
260             # pop a callback if we have an internal callback to make
261             $cv->cb( $cb );
262             } else {
263             $cv->recv
264             };
265             };
266              
267             1;
268              
269             =head1 SEE ALSO
270              
271             L for the module defining the API
272              
273             L for AnyEvent
274              
275             =head1 REPOSITORY
276              
277             The public repository of this module is
278             L.
279              
280             =head1 AUTHOR
281              
282             Max Maischein C
283              
284             =head1 COPYRIGHT (c)
285              
286             Copyright 2009-2012 by Max Maischein C.
287              
288             =head1 LICENSE
289              
290             This module is released under the same terms as Perl itself.
291              
292             =cut