File Coverage

blib/lib/Metabrik/Core/Context.pm
Criterion Covered Total %
statement 12 449 2.6
branch 0 148 0.0
condition 0 53 0.0
subroutine 4 43 9.3
pod 25 25 100.0
total 41 718 5.7


line stmt bran cond sub pod time code
1             #
2             # $Id$
3             #
4             package Metabrik::Core::Context;
5 1     1   767 use strict;
  1         2  
  1         31  
6 1     1   6 use warnings;
  1         2  
  1         56  
7              
8             # Breaking.Feature.Fix
9             our $VERSION = '1.41';
10             our $FIX = '0';
11              
12 1     1   6 use base qw(Metabrik);
  1         3  
  1         1518  
13              
14             sub brik_properties {
15             return {
16 0     0 1   revision => '$Revision$',
17             tags => [ qw(main core) ],
18             attributes => {
19             _lp => [ qw(INTERNAL) ],
20             },
21             commands => {
22             new_brik_run => [ qw(Brik Command Args) ],
23             use => [ qw(Brik) ],
24             set => [ qw(Brik Attribute Value) ],
25             get => [ qw(Brik Attribute) ],
26             run => [ qw(Brik Command) ],
27             do => [ qw(Code) ],
28             call => [ qw(Code) ],
29             variables => [ ],
30             find_available => [ ],
31             update_available => [ ],
32             available => [ ],
33             is_available => [ qw(Brik) ],
34             used => [ ],
35             get_used => [ qw(Brik) ],
36             is_used => [ qw(Brik) ],
37             not_used => [ ],
38             is_not_used => [ qw(Brik) ],
39             status => [ ],
40             reuse => [ ],
41             save_state => [ qw(Brik) ],
42             restore_state => [ qw(Brik) ],
43             },
44             require_modules => {
45             'Data::Dump' => [ qw(dump) ],
46             'File::Find' => [ ],
47             'Lexical::Persistence' => [ ],
48             'Module::Reload' => [ ],
49             'Metabrik::Core::Global' => [ ],
50             'Metabrik::Core::Log' => [ ],
51             'Metabrik::Core::Shell' => [ ],
52             },
53             };
54             }
55              
56             # Only used to avoid compile-time errors
57             my $CON;
58             my $SHE;
59             my $LOG;
60             my $GLO;
61              
62             sub new {
63 0     0 1   my $self = shift->SUPER::new(
64             @_,
65             );
66              
67 0           eval {
68 0           my $lp = Lexical::Persistence->new;
69 0           $lp->set_context(_ => {
70             '$CON' => 'undef',
71             '$SHE' => 'undef',
72             '$LOG' => 'undef',
73             '$GLO' => 'undef',
74             '$USE' => 'undef',
75             '$SET' => 'undef',
76             '$GET' => 'undef',
77             '$RUN' => 'undef',
78             '$ERR' => 'undef',
79             '$MSG' => 'undef',
80             '$REF' => 'undef',
81             });
82             $lp->call(sub {
83 0     0     my %args = @_;
84              
85 0           $CON = $args{self};
86              
87             $CON->{used} = {
88 0           'core::context' => $CON,
89             'core::global' => Metabrik::Core::Global->new,
90             'core::log' => Metabrik::Core::Log->new,
91             'core::shell' => Metabrik::Core::Shell->new,
92             };
93 0           $CON->{available} = { };
94 0           $CON->{set} = { };
95              
96 0           $CON->{log} = $CON->{used}->{'core::log'};
97 0           $CON->{global} = $CON->{used}->{'core::global'};
98 0           $CON->{shell} = $CON->{used}->{'core::shell'};
99 0           $CON->{context} = $CON->{used}->{'core::context'};
100              
101 0           $SHE = $CON->{shell};
102 0           $LOG = $CON->{log};
103 0           $GLO = $CON->{global};
104              
105             # When new() was done, some Attributes were empty. We fix that here.
106 0           for (qw(core::context core::global core::shell core::log)) {
107 0           $CON->{used}->{$_}->{context} = $CON;
108 0           $CON->{used}->{$_}->{log} = $CON->{log};
109 0           $CON->{used}->{$_}->{global} = $CON->{global};
110 0           $CON->{used}->{$_}->{shell} = $CON->{shell};
111             }
112              
113 0           my $ERR = 0;
114              
115 0           return 1;
116 0           }, self => $self);
117 0           $self->_lp($lp);
118             };
119 0 0         if ($@) {
120 0           chomp($@);
121 0           die("[F] core::context: new: unable to create context: $@\n");
122             }
123              
124 0           return $self->brik_preinit;
125             }
126              
127             sub new_brik_run {
128 0     0 1   my $self = shift;
129 0           my ($brik, $command, @args) = @_;
130              
131 0 0         my $con = Metabrik::Core::Context->new or return;
132             # We have to init because some Briks like brik::tool will search context information
133             # like available Briks, for instance.
134 0 0         $con->brik_init or return;
135              
136 0 0         $con->use($brik) or return;
137 0 0         my $data = $con->run($brik, $command, @args) or return;
138 0           $con->brik_fini;
139              
140             # Compatibility with file::dump Brik
141 0           print Data::Dump::dump($data)."\n";
142              
143 0           return $con;
144             }
145              
146             sub brik_init {
147 0     0 1   my $self = shift;
148              
149 0           my $r = $self->update_available;
150 0 0         if (! defined($r)) {
151 0           return $self->log->error("brik_init: unable to init Brik [core::context]: ".
152             "update_available failed"
153             );
154             }
155              
156 0           return $self->SUPER::brik_init(@_);
157             }
158              
159             sub do {
160 0     0 1   my $self = shift;
161 0           my ($code) = @_;
162              
163 0 0         if (! defined($code)) {
164 0           return $self->log->error($self->brik_help_run('do'));
165             }
166              
167 0           my $lp = $self->_lp;
168              
169 0           my $res;
170 0           eval {
171 0           $res = $lp->do($code);
172             };
173 0 0         if ($@) {
174 0           chomp($@);
175 0           return $self->log->error("do: $@");
176             }
177              
178 0 0         $self->log->debug("do: returned[".(defined($res) ? $res : 'undef')."]");
179              
180 0 0         return defined($res) ? $res : 'undef';
181             }
182              
183             sub call {
184 0     0 1   my $self = shift;
185 0           my ($subref, %args) = @_;
186              
187 0 0         if (! defined($subref)) {
188 0           return $self->log->error($self->brik_help_run('call'));
189             }
190              
191 0           my $lp = $self->_lp;
192              
193 0           my $res;
194 0           eval {
195 0           $res = $lp->call($subref, %args);
196             };
197 0 0         if ($@) {
198 0           chomp($@);
199 0           my @list = caller();
200 0           my $file = $list[1];
201 0           my $line = $list[2];
202 0 0         if ($self->log->level > 2) {
203 0           return $self->log->debug("call: $@ (source file [$file] at line [$line])");
204             }
205 0           return $self->log->error("call: $@");
206             }
207              
208 0           return $res;
209             }
210              
211             sub variables {
212 0     0 1   my $self = shift;
213              
214             my $res = $self->call(sub {
215 0     0     my @__ctx_variables = ();
216              
217 0           for my $__ctx_variable (keys %{$CON->_lp->{context}->{_}}) {
  0            
218 0 0         next if $__ctx_variable !~ /^\$/;
219 0 0         next if $__ctx_variable =~ /^\$_/;
220              
221 0           push @__ctx_variables, $__ctx_variable;
222             }
223              
224 0           return \@__ctx_variables;
225 0           });
226              
227 0           return $res;
228             }
229              
230             # Extracted from file::find Brik
231             sub _file_find {
232 0     0     my $self = shift;
233 0           my ($path_list) = @_;
234              
235             # With these patterns, we include baseclass Briks like Metabrik/Baseclass.pm
236 0           my $dirpattern = 'Metabrik';
237 0           my $filepattern = '.pm$';
238              
239             # Escape if we are searching for a directory hierarchy
240 0           $dirpattern =~ s/\//\\\//g;
241              
242 0           my $dir_regex = qr/$dirpattern/;
243 0           my $file_regex = qr/$filepattern/;
244 0           my $dot_regex = qr/^\.$/;
245 0           my $dot2_regex = qr/^\.\.$/;
246              
247 0           my @files = ();
248              
249             my $sub = sub {
250 0     0     my $dir = $File::Find::dir;
251 0           my $file = $_;
252             # Skip dot and double dot directories
253 0 0 0       if ($file =~ $dot_regex || $file =~ $dot2_regex) {
    0 0        
254             }
255             elsif ($dir =~ $dir_regex && $file =~ $file_regex) {
256 0           push @files, "$dir/$file";
257             }
258 0           };
259              
260             {
261 1     1   10 no warnings;
  1         3  
  1         4184  
  0            
262 0           File::Find::find($sub, @$path_list);
263             };
264              
265 0           my %uniq_files = map { $_ => 1 } @files;
  0            
266 0           @files = map { s/^\.\///; $_ } @files; # Remove leading dot slash
  0            
  0            
267 0           @files = sort { $a cmp $b } keys %uniq_files;
  0            
268              
269 0           return \@files;
270             }
271              
272             sub find_available {
273 0     0 1   my $self = shift;
274              
275             # Read from @INC, exclude current directory
276 0           my @path_list = ();
277 0           for (@INC) {
278 0 0         next if /^\.$/;
279 0           push @path_list, $_;
280             }
281              
282 0           my $found = $self->_file_find(\@path_list);
283              
284 0           my %available = ();
285 0           for my $this (@$found) {
286 0           my $brik = $this;
287 0           $brik =~ s{/}{::}g;
288 0           $brik =~ s/^.*::Metabrik::(.*?)$/$1/;
289 0           $brik =~ s/.pm$//;
290 0 0         if (length($brik)) {
291 0           my $module = "Metabrik::$brik";
292 0           $brik = lc($brik);
293 0           $available{$brik} = $module;
294             }
295             }
296              
297 0           return \%available;
298             }
299              
300             sub update_available {
301 0     0 1   my $self = shift;
302              
303 0           my $h = $self->find_available;
304              
305             my $r = $self->call(sub {
306 0     0     my %args = @_;
307              
308 0           my $__ctx_available = $args{available};
309              
310 0           for my $__ctx_this (keys %$__ctx_available) {
311 0           eval("require ".$__ctx_available->{$__ctx_this});
312             }
313              
314 0           return $CON->{available} = $args{available};
315 0           }, available => $h);
316              
317 0           return $r;
318             }
319              
320             sub use {
321 0     0 1   my $self = shift;
322 0           my ($brik) = @_;
323              
324 0 0         if (! defined($brik)) {
325 0           return $self->log->error($self->brik_help_run('use'));
326             }
327              
328             my $r = $self->call(sub {
329 0     0     my %args = @_;
330              
331 0           my $__ctx_brik = $args{brik};
332              
333 0           my $ERR = 0;
334 0           my $USE = 'undef';
335              
336 0           my $__ctx_brik_repository = '';
337 0           my $__ctx_brik_category = '';
338 0           my $__ctx_brik_module = '';
339              
340 0 0         if ($__ctx_brik =~ /^[a-z0-9]+::[a-z0-9]+$/) {
    0          
341 0           ($__ctx_brik_category, $__ctx_brik_module) = split('::', $__ctx_brik);
342             }
343             elsif ($__ctx_brik =~ /^[a-z0-9]+::[a-z0-9]+::[a-z0-9]+$/) {
344 0           ($__ctx_brik_repository, $__ctx_brik_category, $__ctx_brik_module) = split('::', $__ctx_brik);
345             }
346             else {
347 0           $ERR = 1;
348 0           my $MSG = "use: invalid format for Brik [$__ctx_brik]";
349 0           die("$MSG\n");
350             }
351              
352 0           $CON->log->debug("repository[$__ctx_brik_repository]");
353 0           $CON->log->debug("category[$__ctx_brik_category]");
354 0           $CON->log->debug("module[$__ctx_brik_module]");
355              
356 0           $__ctx_brik_repository = ucfirst($__ctx_brik_repository);
357 0           $__ctx_brik_category = ucfirst($__ctx_brik_category);
358 0           $__ctx_brik_module = ucfirst($__ctx_brik_module);
359              
360 0 0         my $__ctx_module = 'Metabrik::'.(length($__ctx_brik_repository)
361             ? $__ctx_brik_repository.'::'
362             : '').$__ctx_brik_category.'::'.$__ctx_brik_module;
363              
364 0           $CON->log->debug("module2[$__ctx_brik_module]");
365              
366 0 0         if ($CON->is_used($__ctx_brik)) {
367 0           $ERR = 1;
368 0           my $MSG = "use: Brik [$__ctx_brik] already used";
369 0           die("$MSG\n");
370             }
371              
372 0           eval("require $__ctx_module;");
373 0 0         if ($@) {
374 0           chomp($@);
375 0           $ERR = 1;
376 0           my $MSG = "use: unable to use Brik [$__ctx_brik]: $@";
377 0           die("$MSG\n");
378             }
379              
380 0           $USE = $__ctx_brik;
381              
382             my $__ctx_new = $__ctx_module->new(
383             context => $CON,
384             global => $CON->{global},
385             shell => $CON->{shell},
386             log => $CON->{log},
387 0           );
388             #$__ctx_new->brik_init; # No init now. We wait first run() to let set() actions
389 0 0         if (! defined($__ctx_new)) {
390 0           $ERR = 1;
391 0           my $MSG = "use: unable to use Brik [$__ctx_brik]";
392 0           die("$MSG\n");
393             }
394              
395 0           return $CON->{used}->{$__ctx_brik} = $__ctx_new;
396 0           }, brik => $brik);
397              
398 0           return $r;
399             }
400              
401             sub reuse {
402 0     0 1   my $self = shift;
403              
404 0           my %stat = ();
405 0           my @reloaded = ();
406             # Taken from Module::Reload
407 0           for my $entry (map { [ $_, $INC{$_} ] } keys %INC) {
  0            
408 0           my ($module, $file) = @$entry;
409              
410             # Some entries don't have a file (XS related)
411 0 0         next unless defined($file);
412              
413 0 0         if ($file eq $INC{"Module/Reload.pm"}) {
414 0           next; # Too confusing
415             }
416              
417 0           local $^W = 0; # Disable 'use warnings';
418 0           my $mtime = (stat $file)[9];
419 0 0         if (! defined($stat{$file})) {
420 0           $stat{$file} = $^T;
421             }
422              
423 0 0         next unless defined($mtime);
424              
425 0 0         if ($mtime > $stat{$file}) {
426 0           delete $INC{$module};
427 0           eval {
428 0     0     $SIG{__WARN__} = sub {};
429 0           require $module;
430             };
431 0 0         if ($@) {
432 0           chomp($@);
433 0 0         if ($self->log->level > 2) {
434 0           $self->log->debug("reuse: reloading module [$module] failed: [$@]");
435             }
436             else {
437 0           $self->log->error("reuse: reloading module [$module] failed");
438             }
439             }
440             else {
441 0           push @reloaded, $module;
442             }
443             }
444 0           $stat{$file} = $mtime;
445             }
446              
447 0           for (@reloaded) {
448 0           $self->log->info("reuse: module [$_] successfully reloaded");
449             }
450              
451 0           return 1;
452             }
453              
454             sub available {
455 0     0 1   my $self = shift;
456              
457             my $r = $self->call(sub {
458 0     0     return $CON->{available};
459 0           });
460              
461 0           return $r;
462             }
463              
464             sub is_available {
465 0     0 1   my $self = shift;
466 0           my ($brik) = @_;
467              
468 0 0         if (! defined($brik)) {
469 0           return $self->log->error($self->brik_help_run('is_available'));
470             }
471              
472 0           my $available = $self->available;
473 0 0         if (exists($available->{$brik})) {
474 0           return 1;
475             }
476              
477 0           return 0;
478             }
479              
480             sub used {
481 0     0 1   my $self = shift;
482              
483             my $r = $self->call(sub {
484 0     0     return $CON->{used};
485 0           });
486              
487 0           return $r;
488             }
489              
490             sub get_used {
491 0     0 1   my $self = shift;
492 0           my ($brik) = @_;
493              
494 0 0         if (! defined($brik)) {
495 0           return $self->log->error($self->brik_help_run('get_used'));
496             }
497              
498 0           my $used = $self->used;
499              
500 0           my $get = $used->{$brik};
501 0 0         if (! defined($get)) {
502 0           return $self->log->error("get_used: Brik [$brik] not used");
503             }
504              
505 0           return $get;
506             }
507              
508             sub is_used {
509 0     0 1   my $self = shift;
510 0           my ($brik) = @_;
511              
512 0 0         if (! defined($brik)) {
513 0           return $self->log->error($self->brik_help_run('is_used'));
514             }
515              
516 0           my $used = $self->used;
517 0 0         if (exists($used->{$brik})) {
518 0           return 1;
519             }
520              
521 0           return 0;
522             }
523              
524             sub not_used {
525 0     0 1   my $self = shift;
526              
527 0           my $status = $self->status;
528              
529 0           my $r = {};
530 0           my @not_used = @{$status->{not_used}};
  0            
531 0           for my $this (@not_used) {
532 0           my @toks = split('::', $this);
533              
534 0           my $repository = '';
535 0           my $category = '';
536 0           my $name = '';
537              
538             # Only baseclass Brik is considered
539 0 0         if (@toks == 1) {
    0          
    0          
540 0           $category = $this;
541             }
542             # No repository defined
543             elsif (@toks == 2) {
544 0           ($category, $name) = $this =~ /^(.*?)::(.*)/;
545             }
546             elsif (@toks > 2) {
547 0           ($repository, $category, $name) = $this =~ /^(.*?)::(.*?)::(.*)/;
548             }
549              
550 0           my $class = 'Metabrik::';
551 0 0         if (length($repository)) {
552 0           $class .= ucfirst($repository).'::';
553             }
554 0           $class .= ucfirst($category).'::';
555 0           $class .= ucfirst($name);
556              
557 0           $class =~ s{::$}{};
558              
559 0           $r->{$this} = $class;
560             }
561              
562 0           return $r;
563             }
564              
565             sub is_not_used {
566 0     0 1   my $self = shift;
567 0           my ($brik) = @_;
568              
569 0 0         if (! defined($brik)) {
570 0           return $self->log->error($self->brik_help_run('is_not_used'));
571             }
572              
573 0           my $used = $self->not_used;
574 0 0         if (exists($used->{$brik})) {
575 0           return 1;
576             }
577              
578 0           return 0;
579             }
580              
581             sub status {
582 0     0 1   my $self = shift;
583              
584 0           my $available = $self->available;
585 0           my $used = $self->used;
586              
587 0           my @used = ();
588 0           my @not_used = ();
589              
590 0           for my $k (sort { $a cmp $b } keys %$available) {
  0            
591 0 0         exists($used->{$k}) ? push @used, $k : push @not_used, $k;
592             }
593              
594             return {
595 0           used => \@used,
596             not_used => \@not_used,
597             };
598             }
599              
600             sub set {
601 0     0 1   my $self = shift;
602 0           my ($brik, $attribute, $value) = @_;
603              
604 0 0 0       if (! defined($brik) || ! defined($attribute) || ! defined($value)) {
      0        
605 0           return $self->log->error($self->brik_help_run('set'));
606             }
607              
608             my $r = $self->call(sub {
609 0     0     my %args = @_;
610              
611 0           my $__ctx_brik = $args{brik};
612 0           my $__ctx_attribute = $args{attribute};
613 0           my $__ctx_value = $args{value};
614              
615 0           my $ERR = 0;
616              
617 0 0         if (! $CON->is_used($__ctx_brik)) {
618 0           $ERR = 1;
619 0           my $MSG = "set: Brik [$__ctx_brik] not used";
620 0           die("$MSG\n");
621             }
622              
623 0 0         if (! $CON->used->{$__ctx_brik}->brik_has_attribute($__ctx_attribute)) {
624 0           $ERR = 1;
625 0           my $MSG = "set: Brik [$__ctx_brik] has no Attribute [$__ctx_attribute]";
626 0           die("$MSG\n");
627             }
628              
629             # Support variable lookups like '$array' as an Argument
630             # Example: set $Arg
631 0 0 0       if ($__ctx_value =~ /^\$\w+/ || $__ctx_value =~ /^\@\$\w+/
    0 0        
      0        
      0        
      0        
632             || $__ctx_value =~ /^\@\w+/ || $__ctx_value =~ /^\%\$\w+/
633             || $__ctx_value =~ /^\%\w+/) {
634 0           eval {
635 0           $__ctx_value = $CON->_lp->do($__ctx_value);
636             };
637 0 0         if ($@) {
638 0           chomp($@);
639 0           $ERR = 1;
640 0           my $MSG = "set: Brik [$__ctx_brik] has invalid Argument [$__ctx_value]";
641 0           die("$MSG\n");
642             }
643             }
644             # Support passing ARRAYs or HASHs or Perl code as an Argument
645             # Example: set "[ qw(a b c) ]"
646             elsif ($__ctx_value =~ /^\[.*\]$/ || $__ctx_value =~ /^\{.*\}$/) {
647 0           eval {
648 0           $__ctx_value = $CON->_lp->do($__ctx_value);
649             };
650 0 0         if ($@) {
651 0           chomp($@);
652 0           $ERR = 1;
653 0           my $MSG = "set: Brik [$__ctx_brik] has invalid Argument [$__ctx_value]";
654 0           die("$MSG\n");
655             }
656             }
657              
658 0           $CON->{used}->{$__ctx_brik}->$__ctx_attribute($__ctx_value);
659              
660 0           my $SET = $CON->{set}->{$__ctx_brik}->{$__ctx_attribute} = $__ctx_value;
661              
662 0           my $REF = \$SET;
663              
664 0           return $SET;
665 0           }, brik => $brik, attribute => $attribute, value => $value);
666              
667 0           return $r;
668             }
669              
670             sub get {
671 0     0 1   my $self = shift;
672 0           my ($brik, $attribute) = @_;
673              
674 0 0 0       if (! defined($brik) || ! defined($attribute)) {
675 0           return $self->log->error($self->brik_help_run('get'));
676             }
677              
678             my $r = $self->call(sub {
679 0     0     my %args = @_;
680              
681 0           my $__ctx_brik = $args{brik};
682 0           my $__ctx_attribute = $args{attribute};
683              
684 0           my $ERR = 0;
685              
686 0 0         if (! $CON->is_used($__ctx_brik)) {
687 0           $ERR = 1;
688 0           my $MSG = "get: Brik [$__ctx_brik] not used";
689 0           die("$MSG\n");
690             }
691              
692 0 0         if (! $CON->used->{$__ctx_brik}->brik_has_attribute($__ctx_attribute)) {
693 0           $ERR = 1;
694 0           my $MSG = "get: Brik [$__ctx_brik] has no Attribute [$__ctx_attribute]";
695 0           die("$MSG\n");
696             }
697              
698 0 0         if (! defined($CON->{used}->{$__ctx_brik}->$__ctx_attribute)) {
699 0           return my $GET = 'undef';
700             }
701              
702 0           my $GET = $CON->{used}->{$__ctx_brik}->$__ctx_attribute;
703              
704 0           my $REF = \$GET;
705              
706 0           return $GET;
707 0           }, brik => $brik, attribute => $attribute);
708              
709 0           return $r;
710             }
711              
712             sub run {
713 0     0 1   my $self = shift;
714 0           my ($brik, $command, @args) = @_;
715              
716 0 0 0       if (! defined($brik) || ! defined($command)) {
717 0           return $self->log->error($self->brik_help_run('run'));
718             }
719              
720 0 0         if ($self->log->level > 2) {
721 0           my ($module, $file, $line) = caller();
722 0           $self->log->debug("run: called by module [$module] from [$file] line[$line]");
723             }
724              
725             my $r = $self->call(sub {
726 0     0     my %args = @_;
727              
728 0           my $__ctx_brik = $args{brik};
729 0           my $__ctx_command = $args{command};
730 0           my @__ctx_args = @{$args{args}};
  0            
731              
732 0           my $ERR = 0;
733              
734 0 0         if (! $CON->is_used($__ctx_brik)) {
735 0           $ERR = 1;
736 0           my $MSG = "run: Brik [$__ctx_brik] not used";
737 0           die("$MSG\n");
738             }
739              
740 0 0         if (! $CON->used->{$__ctx_brik}->brik_has_command($__ctx_command)) {
741 0           $ERR = 1;
742 0           my $MSG = "run: Brik [$__ctx_brik] has no Command [$__ctx_command]";
743 0           die("$MSG\n");
744             }
745              
746 0           my $__ctx_run = $CON->{used}->{$__ctx_brik};
747              
748             # Will brik_init() only if not already done
749             # And only for Brik's Commands, not base class Commands
750 0 0 0       if (! $__ctx_run->init_done && $__ctx_command !~ /^brik_/) {
751 0 0         if (! $__ctx_run->brik_init) {
752 0           $ERR = 1;
753 0           my $MSG = "run: Brik [$__ctx_brik] init failed";
754 0           die("$MSG\n");
755             }
756             }
757              
758 0           for (@__ctx_args) {
759             # Support variable lookups like '$array' as an Argument
760             # Example: run $Arg1 Arg2
761 0 0 0       if (/^\$\w+/ || /^\@\$\w+/ || /^\@\w+/ || /^\%\$\w+/ || /^\%\w+/) {
    0 0        
      0        
      0        
      0        
762 0           eval {
763 0           $_ = $CON->_lp->do($_);
764             };
765 0 0         if ($@) {
766 0           chomp($@);
767 0           $ERR = 1;
768 0           my $MSG = "run: Brik [$__ctx_brik] has invalid Argument [$_]";
769 0           die("$MSG\n");
770             }
771             }
772             # Support passing ARRAYs or HASHs or Perl code as an Argument
773             # Example: run "[ qw(a b c) ]"
774             elsif (/^\[.*\]$/ || /^\{.*\}$/) {
775 0           eval {
776 0           $_ = $CON->_lp->do($_);
777             };
778 0 0         if ($@) {
779 0           chomp($@);
780 0           $ERR = 1;
781 0           my $MSG = "run: Brik [$__ctx_brik] has invalid Argument [$_]";
782 0           die("$MSG\n");
783             }
784             }
785             }
786              
787 0           my $RUN;
788 0           my $__ctx_return = $__ctx_run->$__ctx_command(@__ctx_args);
789 0 0         if (! defined($__ctx_return)) {
790 0           $ERR = 1;
791 0           return;
792             }
793              
794 0           $RUN = $__ctx_return;
795              
796 0           my $REF = \$RUN;
797              
798 0           return $RUN;
799 0           }, brik => $brik, command => $command, args => \@args);
800              
801 0           return $r;
802             }
803              
804             sub save_state {
805 0     0 1   my $self = shift;
806 0           my ($brik) = @_;
807              
808 0 0         if (! defined($brik)) {
809 0           return $self->log->error($self->brik_help_run('save_state'));
810             }
811              
812             my $r = $self->call(sub {
813 0     0     my %args = @_;
814              
815 0           my $__ctx_brik = $args{brik};
816              
817 0           my $ERR = 0;
818              
819 0 0         if (! $CON->is_used($__ctx_brik)) {
820 0           $ERR = 1;
821 0           my $MSG = "save_state: Brik [$__ctx_brik] not used";
822 0           die("$MSG\n");
823             }
824              
825 0           my $__ctx_state;
826 0   0       my $__ctx_attributes = $CON->{used}->{$__ctx_brik}->brik_attributes || {};
827 0           for my $__ctx_this (keys %$__ctx_attributes) {
828 0           $__ctx_state->{$__ctx_this} = $CON->{used}->{$__ctx_brik}->$__ctx_this;
829             }
830 0           $CON->{used}->{$__ctx_brik}->{"__ctx_state"} = $__ctx_state;
831              
832 0           return 1;
833 0           }, brik => $brik);
834              
835 0           return $r;
836             }
837              
838             sub restore_state {
839 0     0 1   my $self = shift;
840 0           my ($brik) = @_;
841              
842 0 0         if (! defined($brik)) {
843 0           return $self->log->error($self->brik_help_run('restore_state'));
844             }
845              
846             my $r = $self->call(sub {
847 0     0     my %args = @_;
848              
849 0           my $__ctx_brik = $args{brik};
850              
851 0           my $ERR = 0;
852              
853 0 0         if (! $CON->is_used($__ctx_brik)) {
854 0           $ERR = 1;
855 0           my $MSG = "restore_state: Brik [$__ctx_brik] not used";
856 0           die("$MSG\n");
857             }
858              
859 0           my $__ctx_state = $CON->{used}->{$__ctx_brik}->{"__ctx_state"};
860 0 0         if (defined($__ctx_state)) {
861 0           for my $__ctx_this (keys %$__ctx_state) {
862 0           $CON->{used}->{$__ctx_brik}->$__ctx_this($__ctx_state->{$__ctx_this});
863             }
864             }
865              
866 0           return 1;
867 0           }, brik => $brik);
868              
869 0           return $r;
870             }
871              
872             sub brik_fini {
873 0     0 1   my $self = shift;
874              
875 0           my $used = $self->used;
876 0           for my $brik (keys %$used) {
877 0 0         next if $brik eq 'core::context'; # Avoid recursive loop
878 0           $used->{$brik}->brik_fini;
879             }
880              
881 0           return 1;
882             }
883              
884             1;
885              
886             __END__