File Coverage

blib/lib/Circle/RootObj.pm
Criterion Covered Total %
statement 72 295 24.4
branch 0 66 0.0
condition 1 9 11.1
subroutine 24 52 46.1
pod n/a
total 97 422 22.9


line stmt bran cond sub pod time code
1             # You may distribute under the terms of the GNU General Public License
2             #
3             # (C) Paul Evans, 2008-2014 -- leonerd@leonerd.org.uk
4              
5             package Circle::RootObj;
6              
7 4     4   21 use strict;
  4         7  
  4         166  
8 4     4   20 use warnings;
  4         8  
  4         165  
9 4     4   21 use base qw( Tangence::Object Circle::WindowItem );
  4         6  
  4         1798  
10              
11 4     4   1947 use Class::Method::Modifiers;
  4         4913  
  4         254  
12              
13 4     4   23 use Carp;
  4         6  
  4         196  
14 4     4   1757 use YAML (); # 'Dump' and 'Load' are a bit generic; we'll call by FQN
  4         28679  
  4         103  
15              
16 4     4   1808 use Circle::Rule::Store;
  4         10  
  4         173  
17             require Circle::GlobalRules;
18              
19 4     4   23 use Circle::CommandInvocation;
  4         6  
  4         260  
20              
21 4         45 use Module::Pluggable sub_name => "net_types",
22             search_path => [ "Circle::Net" ],
23             only => qr/^Circle::Net::\w+$/, # Not inner ones
24 4     4   2703 force_search_all_paths => 1;
  4         34978  
25              
26             {
27             foreach my $class ( net_types ) {
28             ( my $file = "$class.pm" ) =~ s{::}{/}g;
29             require $file;
30             }
31             }
32              
33 4     4   540 use Data::Dump;
  4         7  
  4         344  
34              
35 4   33 4   21 use constant CIRCLERC => $ENV{CIRCLERC} || "$ENV{HOME}/.circlerc";
  4         8  
  4         3451  
36              
37             sub _nettype2class
38             {
39 0     0     my ( $type ) = @_;
40              
41 0           foreach ( __PACKAGE__->net_types ) {
42 0           my $thistype = eval { $_->NETTYPE };
  0            
43 0 0 0       if( defined $thistype and $thistype eq $type ) {
44 0           return $_;
45             }
46             }
47              
48 0           return undef;
49             }
50              
51             sub new
52             {
53 0     0     my $class = shift;
54 0           my %args = @_;
55              
56 0 0         my $loop = delete $args{loop} or croak "Need a loop";
57              
58 0           my $self = $class->SUPER::new( %args );
59              
60 0           $self->{loop} = $loop;
61              
62 0           my $rulestore = $self->{rulestore} = Circle::Rule::Store->new();
63 0           Circle::GlobalRules::register( $rulestore );
64              
65 0           my $file = CIRCLERC;
66 0 0         if( -r $file ) {
67 0           my $config = YAML::LoadFile( $file );
68 0           $self->load_configuration( $config );
69             }
70              
71 0           return $self;
72             }
73              
74             sub add_network
75             {
76 0     0     my $self = shift;
77 0           my ( $class, $name ) = @_;
78              
79 0           my $loop = $self->{loop};
80              
81             # Late-loading to support out-of-tree classes so they don't have to declare
82             # in the .tan file
83 0           eval { Tangence::Class->for_perlname( $class ) } or
84 0 0 0       eval { $class->DECLARE_TANGENCE } or
  0            
85             croak "Unknown Tangence::Class for '$class' and can't lazy-load it";
86              
87 0           my $registry = $self->{registry};
88 0           my $newnet = $registry->construct(
89             $class,
90             tag => $name,
91             root => $self,
92             loop => $loop,
93             );
94              
95             $newnet->subscribe_event( destroy => sub {
96 0     0     my ( $newnet ) = @_;
97 0           $self->broadcast_sessions( "delete_item", $newnet );
98 0           $self->del_prop_networks( $name );
99 0           } );
100              
101 0           $self->fire_event( "network_added", $newnet );
102 0           $self->add_prop_networks( $name => $newnet );
103              
104 0           $self->broadcast_sessions( "new_item", $newnet );
105              
106 0           return $newnet;
107             }
108              
109             sub del_network
110             {
111 0     0     my $self = shift;
112 0           my ( $network ) = @_;
113              
114 0           $network->destroy;
115             }
116              
117             use Circle::Collection
118             name => 'networks',
119             storage => {
120             list => sub {
121 0         0 my $self = shift;
122 0         0 my $networks = $self->get_prop_networks;
123 0         0 return map { { name => $_, type => $networks->{$_}->NETTYPE } } sort keys %$networks;
  0         0  
124             },
125              
126             get => sub {
127 0         0 my $self = shift;
128 0         0 my ( $name ) = @_;
129 0 0       0 my $network = $self->get_prop_networks->{$name} or return undef;
130 0         0 return { name => $name, type => $network->NETTYPE };
131             },
132              
133             add => sub {
134 0         0 my $self = shift;
135 0         0 my ( $name, $item ) = @_;
136              
137 0         0 my $class = _nettype2class( $item->{type} );
138              
139 0 0       0 defined $class or die "unrecognised network type '$item->{type}'\n";
140              
141 0         0 $self->add_network( $class, $name );
142             },
143              
144             del => sub {
145 0         0 my $self = shift;
146 0         0 my ( $name ) = @_;
147 0 0       0 my $network = $self->get_prop_networks->{$name} or return;
148              
149 0 0       0 $network->connected and die "still connected\n";
150              
151 0         0 $self->del_network( $network );
152             },
153             },
154             attrs => [
155             name => {},
156             type => { nomod => 1, default => "irc" },
157             ],
158             config => {
159             type => "hash",
160             load => sub {
161 0         0 my $self = shift;
162 0         0 my ( $name, $ynode ) = @_;
163 0         0 $self->get_prop_networks->{$name}->load_configuration( $ynode );
164             },
165             store => sub {
166 0         0 my $self = shift;
167 0         0 my ( $name, $ynode ) = @_;
168 0         0 $self->get_prop_networks->{$name}->store_configuration( $ynode );
169             },
170             },
171 4     4   1960 ;
  4         10  
  4         78  
172              
173             our %sessions;
174              
175             sub add_session
176             {
177 0     0     my $self = shift;
178 0           my ( $identity, $type ) = @_;
179              
180 0           eval "require $type";
181 0 0         die $@ if $@;
182              
183 0           my $registry = $self->{registry};
184              
185 0           my $session = $registry->construct(
186             $type,
187             root => $self,
188             identity => $identity,
189             );
190              
191 0           return $sessions{$identity} = $session;
192             }
193              
194             sub method_get_session
195             {
196 0     0     my $self = shift;
197 0           my ( $ctx, $opts ) = @_;
198              
199 0           my $identity = $ctx->stream->identity;
200              
201 0 0         return $sessions{$identity} if exists $sessions{$identity};
202            
203 0           my $type = _session_type( $opts );
204              
205 0 0         defined $type or die "Cannot identify a session type\n";
206              
207 0           return $self->add_session( $identity, $type );
208             }
209              
210             sub broadcast_sessions
211             {
212 0     0     my $self = shift;
213 0           my ( $method, @args ) = @_;
214              
215 0           foreach my $session ( values %sessions ) {
216 0 0         $session->$method( @args ) if $session->can( $method );
217             }
218             }
219              
220             sub invoke_session
221             {
222 0     0     my $self = shift;
223 0           my ( $conn, $method, @args ) = @_;
224              
225 0           my $session = $sessions{$conn->identity};
226 0 0         return unless $session;
227              
228 0 0         $session->$method( @args ) if $session->can( $method );
229             }
230              
231             sub _session_type
232             {
233 0     0     my ( $opts ) = @_;
234 0           my %opts = map { $_ => 1 } @$opts;
  0            
235              
236 0 0         if( $opts{tabs} ) {
237 0           delete $opts{tabs};
238 0           require Circle::Session::Tabbed;
239 0           return Circle::Session::Tabbed::_session_type( \%opts );
240             }
241              
242 0           print STDERR "Need Session for options\n";
243 0           print STDERR " ".join( "|", sort keys %opts )."\n";
244              
245 0           return undef;
246             }
247              
248             use Circle::Collection
249             name => 'sessions',
250             storage => {
251             list => sub {
252 0         0 map { my $class = ref $sessions{$_}; $class =~ s/^Circle::Session:://;
  0         0  
  0         0  
253 0         0 { name => $_, type => $class } } sort keys %sessions;
254             },
255             },
256 4         38 attrs => [
257             name => {},
258             type => { nomod => 1 },
259             ],
260             commands => {
261             # Disable add modify del
262             add => undef, mod => undef, del => undef,
263             },
264             config => 0,
265 4     4   2922 ;
  4         4  
266              
267             sub command_session
268             : Command_description("Manage the current session")
269       0     {
270 4     4   18 }
  4         6  
  4         13  
271              
272             sub command_session_info
273             : Command_description("Show information about the session")
274             : Command_subof('session')
275             : Command_default()
276             {
277 0     0   0 my $self = shift;
278 0         0 my ( $cinv ) = @_;
279              
280 0         0 my $identity = $cinv->connection->identity;
281 0 0       0 my $session = defined $identity ? $sessions{$identity} : undef;
282              
283 0 0       0 unless( defined $session ) {
284 0         0 $cinv->responderr( "Cannot find a session for this identity" );
285 0         0 return;
286             }
287              
288 0         0 ( my $type = ref $session ) =~ s/^Circle::Session:://;
289              
290 0         0 $cinv->respond_table(
291             [
292             [ Type => $type ],
293             [ Identity => $identity ],
294             [ Items => scalar $session->items ],
295             ],
296             colsep => ": ",
297             );
298              
299 0         0 return;
300 4     4   1092 }
  4         5  
  4         23  
301              
302             sub command_session_clonefrom
303             : Command_description("Clone items from another session")
304             : Command_subof('session')
305             : Command_arg('name')
306             {
307 0     0   0 my $self = shift;
308 0         0 my ( $name, $cinv ) = @_;
309              
310 0         0 my $identity = $cinv->connection->identity;
311              
312 0 0       0 my $destsession = defined $identity ? $sessions{$identity} : undef or
    0          
313             return $cinv->responderr( "Cannot find a session for this identity" );
314              
315 0 0       0 my $srcsession = $sessions{$name} or
316             return $cinv->responderr( "Cannot find a session called '$name'" );
317              
318 0 0       0 eval { $destsession->clonefrom( $srcsession ); 1 } or
  0         0  
  0         0  
319             return $cinv->responderr( "Cannot clone $name into $identity - $@" );
320              
321 0         0 return;
322 4     4   1243 }
  4         5  
  4         19  
323              
324             sub command_eval
325             : Command_description("Evaluate a perl expression")
326             : Command_arg('expr', eatall => 1)
327             {
328 0     0   0 my $self = shift;
329 0         0 my ( $expr, $cinv ) = @_;
330              
331 0         0 my $connection = $cinv->connection;
332              
333 0         0 my $identity = $connection->identity;
334 0 0       0 my $session = defined $identity ? $sessions{$identity} : undef;
335              
336 0         0 my %pad = (
337             ROOT => $self,
338             CONN => $connection,
339             ITEM => $cinv->invocant,
340             SESSION => $session,
341             );
342              
343 0         0 my $result = do {
344             local $SIG{__WARN__} = sub {
345 0     0   0 my $msg = $_[0];
346 0         0 $msg =~ s/ at \(eval \d+\) line \d+\.$//;
347 0         0 chomp $msg;
348 0         0 $cinv->respondwarn( $msg, level => 2 );
349 0         0 };
350              
351 0         0 eval join( "", map { "my \$$_ = \$pad{$_}; " } keys %pad ) . "$expr";
  0         0  
352             };
353              
354 0 0       0 if( $@ ) {
355 0         0 my $err = $@; chomp $err;
  0         0  
356 0         0 $cinv->responderr( "Died: $err" );
357             }
358             else {
359 0         0 my @lines;
360              
361             my $timedout;
362 0     0   0 local $SIG{ALRM} = sub { $timedout = 1; die };
  0         0  
  0         0  
363 0         0 eval {
364 0         0 alarm(5);
365 0         0 @lines = split m/\n/, Data::Dump::dump($result);
366 0         0 alarm(0);
367             };
368              
369 0 0       0 if( $timedout ) {
370 0         0 $cinv->responderr( "Failed - took too long to render results. Try something more specific" );
371 0         0 return;
372             }
373              
374 0 0       0 if( @lines > 20 ) {
375 0         0 @lines = ( @lines[0..18], "...", $lines[-1] );
376             }
377              
378 0 0       0 if( @lines == 1 ) {
379 0         0 $cinv->respond( "Result: $lines[0]" );
380             }
381             else {
382 0         0 $cinv->respond( "Result:" );
383 0         0 $cinv->respond( " $_" ) for @lines;
384             }
385             }
386              
387 0         0 return;
388 4     4   2256 }
  4         7  
  4         15  
389              
390             sub command_rerequire
391             : Command_description("Rerequire a perl module")
392             : Command_arg('module')
393             {
394 0     0   0 my $self = shift;
395 0         0 my ( $module, $cinv ) = @_;
396              
397             # This might be a module name Foo::Bar or a filename Foo/Bar.pm
398 0         0 my $filename;
399              
400 0 0       0 if( $module =~ m/::/ ) {
    0          
401 0         0 ( $filename = $module ) =~ s{::}{/}g;
402 0         0 $filename .= ".pm";
403             }
404             elsif( $module =~ m/^(.*)\.pm$/ ) {
405 0         0 $filename = $module;
406 0         0 ( $module = $1 ) =~ s{/}{::}g;
407             }
408             else {
409 0         0 return $cinv->responderr( "Unable to recognise if $module is a module name or a file name" );
410             }
411              
412 0 0       0 if( !exists $INC{$filename} ) {
413 0         0 return $cinv->responderr( "Module $module in file $filename isn't loaded" );
414             }
415              
416             {
417 0         0 local $SIG{__WARN__} = sub {
418 0     0   0 my $msg = $_[0];
419 0         0 $msg =~ s/ at \(eval \d+\) line \d+\.$//;
420 0         0 chomp $msg;
421 0         0 $cinv->respondwarn( $msg, level => 2 );
422 0         0 };
423              
424 4     4   1359 no warnings 'redefine';
  4         13  
  4         480  
425              
426 0         0 delete $INC{$filename};
427 0         0 eval { require $filename };
  0         0  
428             }
429              
430 0 0       0 if( $@ ) {
431 0         0 my $err = $@; chomp $err;
  0         0  
432 0         0 $cinv->responderr( "Died: $err" );
433             }
434             else {
435 0         0 $cinv->respond( "Reloaded $module from $filename" );
436             }
437              
438 0         0 return;
439 4     4   21 }
  4         4  
  4         14  
440              
441             sub commandable_parent
442             {
443 0     0     my $self = shift;
444 0           my ( $cinv ) = @_;
445              
446 0           return $sessions{$cinv->connection->identity};
447             }
448              
449             sub enumerate_items
450             {
451 0     0     my $self = shift;
452 0           my $networks = $self->get_prop_networks;
453 0           return { map { $_->enumerable_name => $_ } values %$networks };
  0            
454             }
455              
456             sub enumerable_name
457             {
458 0     0     return "";
459             }
460              
461             sub parent
462             {
463 0     0     return undef;
464             }
465              
466             sub command_delay
467             : Command_description("Run command after some delay")
468             : Command_arg('seconds')
469             : Command_arg('command', eatall => 1)
470             {
471 0     0   0 my $self = shift;
472 0         0 my ( $seconds, $text, $cinv ) = @_;
473              
474             # TODO: A CommandInvocant subclass that somehow prefixes its output so we
475             # know it's delayed output from earlier, so as not to confuse
476 0         0 my $subinv = $cinv->nest( $text );
477              
478 0 0       0 my $cmdname = $subinv->peek_token or
479             return $cinv->responderr( "No command given" );
480              
481 0         0 my $loop = $self->{loop};
482              
483             my $id = $loop->enqueue_timer(
484             delay => $seconds,
485             code => sub {
486 0     0   0 eval {
487 0         0 $subinv->invocant->do_command( $subinv );
488             };
489 0 0       0 if( $@ ) {
490 0         0 my $err = $@; chomp $err;
  0         0  
491 0         0 $cinv->responderr( "Delayed command $cmdname failed - $err" );
492             }
493             },
494 0         0 );
495              
496             # TODO: Store ID, allow list, cancel, etc...
497              
498 0         0 return;
499 4     4   1529 }
  4         5  
  4         19  
500              
501             ###
502             # Configuration management
503             ###
504              
505             sub command_config
506             : Command_description("Save configuration or change details about it")
507       0     {
508             # The body doesn't matter as it never gets run
509 4     4   578 }
  4         5  
  4         15  
510              
511             sub command_config_show
512             : Command_description("Show the configuration that would be saved")
513             : Command_subof('config')
514             : Command_default()
515             {
516 0     0   0 my $self = shift;
517 0         0 my ( $cinv ) = @_;
518              
519             # Since we're only showing config, only fetch it for the invocant
520 0         0 my $obj = $cinv->invocant;
521              
522 0 0       0 unless( $obj->can( "get_configuration" ) ) {
523 0         0 $cinv->respond( "No configuration" );
524 0         0 return;
525             }
526              
527 0         0 my $config = YAML::Dump( $obj->get_configuration );
528              
529 0         0 $cinv->respond( $_ ) for split m/\n/, $config;
530 0         0 return;
531 4     4   944 }
  4         7  
  4         14  
532              
533             sub command_config_save
534             : Command_description("Save configuration to disk")
535             : Command_subof('config')
536             {
537 0     0   0 my $self = shift;
538 0         0 my ( $cinv ) = @_;
539              
540 0         0 my $file = CIRCLERC;
541 0         0 YAML::DumpFile( $file, $self->get_configuration );
542              
543 0         0 $cinv->respond( "Configuration written to $file" );
544 0         0 return;
545 4     4   798 }
  4         8  
  4         14  
546              
547             sub command_config_reload
548             : Command_description("Reload configuration from disk")
549             : Command_subof('config')
550             {
551 0     0     my $self = shift;
552 0           my ( $cinv ) = @_;
553              
554 0           my $file = CIRCLERC;
555 0           $self->load_configuration( YAML::LoadFile( $file ) );
556              
557 0           $cinv->respond( "Configuration loaded from $file" );
558 0           return;
559 4     4   810 }
  4         5  
  4         14  
560              
561             # For Configurable role
562             after load_configuration => sub {
563             my $self = shift;
564             my ( $ynode ) = @_;
565              
566             if( my $sessions_ynode = $ynode->{sessions} ) {
567             foreach my $sessionname ( keys %$sessions_ynode ) {
568             my $sessionnode = $sessions_ynode->{$sessionname};
569             my $type = $sessionnode->{type};
570              
571             my $session = $self->add_session( $sessionname, "Circle::Session::$type" );
572             $session->load_configuration( $sessionnode );
573             }
574             }
575             };
576              
577             after store_configuration => sub {
578             my $self = shift;
579             my ( $ynode ) = @_;
580              
581             my $sessions_ynode = $ynode->{sessions} ||= YAML::Node->new({});
582             %$sessions_ynode = ();
583              
584             foreach my $identity ( keys %sessions ) {
585             my $session = $sessions{$identity};
586              
587             my $sessionnode = $session->get_configuration;
588             $sessions_ynode->{$identity} = $sessionnode;
589              
590             unless( $sessionnode->{type} ) { # exists doesn't quite play ball
591             # Ensure it's first
592             unshift @{ tied(%$sessionnode)->keys }, 'type'; # I am going to hell for this
593             ( $sessionnode->{type} ) = (ref $session) =~ m/^Circle::Session::(.*)$/;
594             }
595             }
596             };
597              
598             0x55AA;