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__ |