line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Acme::RPC; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
Devel::Trace::trace('off') if exists $INC{'Devel/Trace.pm'}; |
4
|
|
|
|
|
|
|
|
5
|
1
|
|
|
1
|
|
29760
|
use strict; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
33
|
|
6
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
41
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
our $VERSION = '0.01'; |
9
|
|
|
|
|
|
|
|
10
|
1
|
|
|
1
|
|
5
|
use B; |
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
50
|
|
11
|
1
|
|
|
1
|
|
3
|
use B::Deparse; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
37
|
|
12
|
1
|
|
|
1
|
|
364
|
use Continuity; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
use IO::Handle; |
14
|
|
|
|
|
|
|
# use Devel::Pointer; |
15
|
|
|
|
|
|
|
use JSON; |
16
|
|
|
|
|
|
|
use Data::Dumper; |
17
|
|
|
|
|
|
|
use Devel::Caller 'caller_cv'; |
18
|
|
|
|
|
|
|
use PadWalker 'peek_sub'; |
19
|
|
|
|
|
|
|
use Scalar::Util 'blessed'; |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
my $comment = <<'EOF'; |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
Todo: |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
* Accept JSON as input too, for the parameters! |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
* When taking apart CODE, do closes_over() too, not just peek_my(). |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
* Weaken references held in %registry. |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
* Bug: Second hit with an oid= finds the server not accepting. |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
* Optionally require a password... use Acme::RPC password => whatever; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
* entersubs=1, enterpackages=1, etc args to control how far the recurse goes in building $tree. |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
* Maybe don't recurse into blessed objects, but dump them nicely upon request. |
38
|
|
|
|
|
|
|
Or maybe do recurse into them and dump their instance data. |
39
|
|
|
|
|
|
|
If $oid is passed then recurse into arrays, hashes, and object instance data. |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
* We don't dump references found inside CODE in the main view. |
42
|
|
|
|
|
|
|
But if they request a dump for that object, dump it. |
43
|
|
|
|
|
|
|
Likewise, we're not dumping arrays and hashes, but if they request a dump on it, dump it. |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
* JSON output on the default tree view too. |
46
|
|
|
|
|
|
|
We'd have to sanitize our tree... |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
* Document that people need to use Event::loop or something; an Acme module to insert calls to cede would be awesome for this |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
* Package names like foo:: should be hyperlinked too; should be able call ?oid=whatever&action=new&args=whatever on them |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
* The whole tree() recurse thing if it gets any more complicated is going to need a %seen list to avoid infinite recursion. |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
Think About: |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
* ?ref is for plain references (array, hash, scalar, code); ?obj is for objects...? |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
* ?action parameter: dump, call, set, new |
59
|
|
|
|
|
|
|
new is like call but it accepts a bare package name rather than an oid. |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
Done: |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
* The tree structure where each only leafs contain "hits" (references to things that get ?oid links made from them) |
64
|
|
|
|
|
|
|
is causing confusion and grief. |
65
|
|
|
|
|
|
|
Need a structure where for any given $node, $node->{chr(0)} is the (possible) object representing that node, |
66
|
|
|
|
|
|
|
and $node->{everything else} is the stuff under it. |
67
|
|
|
|
|
|
|
Then given a code ref, $node->{chr(0)} would be the code ref itself, and $node->{everything else} would be lexicals vars. |
68
|
|
|
|
|
|
|
Given a stash like "foo::", $node->{chr(0)} would actually be \%{'foo::'} and $node->{everything else} would be stuff in that package. |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
* Rather than only taking oids to dump/call, also take a path in the tree. |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
* lazy=1 parameter where the last $tree is re-used rather than re-computed. |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
* Should switch to our own recurse logic from Data::Dumper to support these other things. |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
* action=dump on anything; in the case of a coderef, find its source on disc or else deparse it |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
* action=call on coderefs and blessed objects, with an args parameter, or arg1, arg2, arg3, etc, and a method parameter for blessed objs. |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
* json will croak if a reference contains objects in side it somewhere. Should handle this gracefully. |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
* Offer JSON output! Not just Data::Dumper. Do this for action=dump, action=call, and the default tree view. |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
* If Devel::Leak won't give us refs... have to do an Acme::State style crawl from main::, |
85
|
|
|
|
|
|
|
but crawling into each sub and looking at its lexicals with PadWalker. |
86
|
|
|
|
|
|
|
Could make for a nice tree view. |
87
|
|
|
|
|
|
|
Would also make it easy to filter out the variables that hold refs. |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
* Maybe this should be called Acme::RPC. |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
* Actually crawl into code refs when recursing the output! |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
* Devel pointer is too much work also. Maybe we should just cache $tree and then |
94
|
|
|
|
|
|
|
walk it again when passed an oid. *sigh* Magic isn't working for me today. |
95
|
|
|
|
|
|
|
Bleah. |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
EOF |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
# our $lt; |
101
|
|
|
|
|
|
|
our $continuity; # don't lose this reference |
102
|
|
|
|
|
|
|
our @keepalive; # stuff instances of objects created over RPC in there so they don't get garbage collected before the other end can use them |
103
|
|
|
|
|
|
|
our $tree; # cached tree |
104
|
|
|
|
|
|
|
our %registry; # oid=>objectrefs |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
sub import { |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
Devel::Trace::trace('off') if exists $INC{'Devel/Trace.pm'}; |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
$continuity = Continuity->new(port => 7777, callback => sub { |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
my $request = shift; |
114
|
|
|
|
|
|
|
while(1) { |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
$SIG{PIPE} = 'IGNORE'; |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
my $action = $request->param('action') || 'dump'; |
119
|
|
|
|
|
|
|
my $output = $request->param('output'); |
120
|
|
|
|
|
|
|
my $ob; |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
$tree = tree('main::') unless $tree and $request->param('lazy'); |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
# |
125
|
|
|
|
|
|
|
# if they're referencing a specific object, find it |
126
|
|
|
|
|
|
|
# |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
if($request->param('oid')) { |
129
|
|
|
|
|
|
|
my $oid = $request->param('oid'); |
130
|
|
|
|
|
|
|
$ob = $registry{$oid}; |
131
|
|
|
|
|
|
|
$ob or do { $request->print("no object with that oid"); next; }; |
132
|
|
|
|
|
|
|
} elsif($request->param('path')) { |
133
|
|
|
|
|
|
|
my @path = split m{/}, $request->param('path'); |
134
|
|
|
|
|
|
|
my $node = $tree; |
135
|
|
|
|
|
|
|
while(@path) { |
136
|
|
|
|
|
|
|
my $step = shift @path; |
137
|
|
|
|
|
|
|
$node = $node->{$step} or do { |
138
|
|
|
|
|
|
|
$step =~ s{[^a-z0-9:_-]}{}g; |
139
|
|
|
|
|
|
|
$request->print("step ``$step'' not found in path"); |
140
|
|
|
|
|
|
|
$node = undef; |
141
|
|
|
|
|
|
|
last; |
142
|
|
|
|
|
|
|
}; |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
$node or next; |
145
|
|
|
|
|
|
|
$ob = $node->{chr(0)} or do { |
146
|
|
|
|
|
|
|
$request->print("tried to look up a path that has no object associated"); |
147
|
|
|
|
|
|
|
}; |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# |
151
|
|
|
|
|
|
|
# default view -- index of everything, up to a certain point |
152
|
|
|
|
|
|
|
# |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
if( ! $ob ) { |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
my $htmlout = sub { |
157
|
|
|
|
|
|
|
my $node = shift; |
158
|
|
|
|
|
|
|
no strict 'refs'; |
159
|
|
|
|
|
|
|
# each node now possibily contains named refs to other nodes (recurse into those), |
160
|
|
|
|
|
|
|
# and a possible single chr(0), a ref to something in the running program. |
161
|
|
|
|
|
|
|
$request->print(" |
162
|
|
|
|
|
|
|
for my $k (sort { $a cmp $b } keys %$node) { |
163
|
|
|
|
|
|
|
next if $k eq chr(0); # doesn't exist in root node and our calling instance needs to have handled it otherwise |
164
|
|
|
|
|
|
|
next if $k eq chr(1); |
165
|
|
|
|
|
|
|
if(exists $node->{$k}{chr(0)}) { |
166
|
|
|
|
|
|
|
my $addy = 0+($node->{$k}{chr(0)}); |
167
|
|
|
|
|
|
|
my $comment = $node->{$k}{chr(1)} || ''; |
168
|
|
|
|
|
|
|
$request->print(qq{$k $comment\n}); |
169
|
|
|
|
|
|
|
} else { |
170
|
|
|
|
|
|
|
$request->print(qq{$k\n}); |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
caller_cv(0)->($node->{$k}); # caller_cv(0)->($node->{$k}); |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
$request->print("\n"); |
175
|
|
|
|
|
|
|
}; |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
my $jsonout = sub { |
178
|
|
|
|
|
|
|
my $node = shift; |
179
|
|
|
|
|
|
|
my $outnode = { }; |
180
|
|
|
|
|
|
|
no strict 'refs'; |
181
|
|
|
|
|
|
|
for my $k (sort { $a cmp $b } keys %$node) { |
182
|
|
|
|
|
|
|
next if $k eq chr(0) or $k eq chr(1); |
183
|
|
|
|
|
|
|
$outnode->{$k} = caller_cv(0)->($node->{$k}); |
184
|
|
|
|
|
|
|
if(exists $node->{$k}{chr(0)}) { |
185
|
|
|
|
|
|
|
my $addy = 0+($node->{$k}{chr(0)}); |
186
|
|
|
|
|
|
|
$outnode->{$k}{oid} = $addy; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
return $outnode; |
190
|
|
|
|
|
|
|
}; |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
# XXX json support here too... feed to_json a pruned $tree? |
193
|
|
|
|
|
|
|
# if($output and $output eq 'json') |
194
|
|
|
|
|
|
|
# $request->print(eval { to_json($ob, { ascii => 1}, ) } || $@); |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
if($output and $output eq 'json') { |
197
|
|
|
|
|
|
|
# $request->print("", eval { to_json( $jsonout->($tree), { ascii => 1, pretty => 1, } ) } || $@, " " ); |
198
|
|
|
|
|
|
|
$request->print(eval { to_json( $jsonout->($tree), { ascii => 1, } ) } || $@ ); |
199
|
|
|
|
|
|
|
} else { |
200
|
|
|
|
|
|
|
$htmlout->($tree); |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
} elsif($action eq 'dump') { |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
# Devel::Trace::trace('on') if exists $INC{'Devel/Trace.pm'}; |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
if(ref($ob) eq 'CODE') { |
208
|
|
|
|
|
|
|
my $buf = B::Deparse->new()->coderef2text($ob); |
209
|
|
|
|
|
|
|
$buf =~ s{<}{\<}g; |
210
|
|
|
|
|
|
|
$request->print("$buf \n"); |
211
|
|
|
|
|
|
|
} else { |
212
|
|
|
|
|
|
|
if($output and $output eq 'json') { |
213
|
|
|
|
|
|
|
$ob = tryunref($ob, $request) or next; |
214
|
|
|
|
|
|
|
$ob = tryunobject($ob, $request) or next; |
215
|
|
|
|
|
|
|
$request->print(eval { to_json($ob, { ascii => 1, allow_unknown => 1, allow_blessed => 1, }, ) } || $@); |
216
|
|
|
|
|
|
|
} else { |
217
|
|
|
|
|
|
|
$ob = tryunref($ob, $request) or next; |
218
|
|
|
|
|
|
|
$request->print("", Data::Dumper::Dumper($ob), " \n"); |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
# Devel::Trace::trace('off') if exists $INC{'Devel/Trace.pm'}; |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
} elsif($action eq 'call') { |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
my @ret; |
227
|
|
|
|
|
|
|
my @args; |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
my $i = 0; |
230
|
|
|
|
|
|
|
while(defined $request->param("arg$i")) { |
231
|
|
|
|
|
|
|
$args[$i] = $request->param("arg$i"); |
232
|
|
|
|
|
|
|
# if($args[$i] =~ m/^\d+$/ and exists $registry{$args[$i]}) { |
233
|
|
|
|
|
|
|
# # try to find args in our %registry |
234
|
|
|
|
|
|
|
# $args[$i] = $registry{$args[$i]}; |
235
|
|
|
|
|
|
|
# } |
236
|
|
|
|
|
|
|
$i++; |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
if(ref($ob) eq 'CODE') { |
240
|
|
|
|
|
|
|
@ret = $ob->(@args); |
241
|
|
|
|
|
|
|
} elsif(blessed($ob)) { |
242
|
|
|
|
|
|
|
my $method = $request->param('method'); |
243
|
|
|
|
|
|
|
$ob->can($method) or do { $request->print("object does not define that method"); next; }; |
244
|
|
|
|
|
|
|
@ret = $ob->can($method)->($ob, @args); |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
if($output and $output eq 'json') { |
248
|
|
|
|
|
|
|
request->print(eval { to_json(\@ret, { ascii => 1}, ) } || $@); |
249
|
|
|
|
|
|
|
} else { |
250
|
|
|
|
|
|
|
my $buf = Data::Dumper::Dumper(\@ret); |
251
|
|
|
|
|
|
|
$request->print(qq{$buf \n}); |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
for my $item (@ret) { |
255
|
|
|
|
|
|
|
# add newly created items to the registry |
256
|
|
|
|
|
|
|
$registry{0+$item} = $item if ref $item; |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
} continue { |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
# warn "doing request-next"; |
264
|
|
|
|
|
|
|
$request->next; |
265
|
|
|
|
|
|
|
# warn "got next request"; |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
}); |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
sub reg ($) { |
272
|
|
|
|
|
|
|
$registry{0+$_[0]} = $_[0]; |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
sub tree { |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
# first, recurse through stashes starting with main::, then as we hit arrayrefs, hashrefs, and coderefs, |
278
|
|
|
|
|
|
|
# recurse into those. |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
# XXX reworking this a bit. each node should contain things logically under it as well as a ref to the |
281
|
|
|
|
|
|
|
# object that it logically refers to. items under it are $node{whatever}, and itself is $node{chr(0)} now. |
282
|
|
|
|
|
|
|
# so, it follows that given $node{whatever}, $node{whatever}{chr(0)} is the reference for whatever. |
283
|
|
|
|
|
|
|
# this way, all nodes are hashes with children and a seperated off reference to the target object. |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
# scalars can appear in packages, in object instance data, or in code refs. same for lots of things. |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
my $package = shift; |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
return sub { |
290
|
|
|
|
|
|
|
# recurse through stashes (happens at the topmost level) |
291
|
|
|
|
|
|
|
my $object = shift; |
292
|
|
|
|
|
|
|
my $node = { }; |
293
|
|
|
|
|
|
|
no strict 'refs'; |
294
|
|
|
|
|
|
|
if(! ref($object) and $object =~ m/::$/) { |
295
|
|
|
|
|
|
|
# I don't like how each scenario is replicated here, but each is pretty short, after the custom logic for dealing with the stash. |
296
|
|
|
|
|
|
|
my $package = $object; |
297
|
|
|
|
|
|
|
for my $k (keys %{$package}) { |
298
|
|
|
|
|
|
|
next if $k =~ m/main::$/; |
299
|
|
|
|
|
|
|
next if $k =~ m/[^\w:]/; |
300
|
|
|
|
|
|
|
if($k =~ m/::$/) { |
301
|
|
|
|
|
|
|
# found a package inside of a package |
302
|
|
|
|
|
|
|
# my $modulepath = $package.$k; |
303
|
|
|
|
|
|
|
# for($modulepath) { s{^main::}{}; s{::$}{}; s{::}{/}g; $_ .= '.pm'; } |
304
|
|
|
|
|
|
|
$node->{$k} = caller_cv(0)->($package.$k); |
305
|
|
|
|
|
|
|
reg( $node->{$k}{chr(0)} = \%{$package.$k} ); # have to do this after assinging in from the recursie call |
306
|
|
|
|
|
|
|
} elsif( *{$package.$k}{HASH} ) { |
307
|
|
|
|
|
|
|
# our or 'use vars' variable |
308
|
|
|
|
|
|
|
# don't recurse into hashes and arrays... if they want to see what's inside, they need to request a dump on it. |
309
|
|
|
|
|
|
|
reg( $node->{'%'.$k}{chr(0)} = *{$package.$k}{HASH} ); |
310
|
|
|
|
|
|
|
} elsif( *{$package.$k}{ARRAY} ) { |
311
|
|
|
|
|
|
|
# our or 'use vars' variable |
312
|
|
|
|
|
|
|
# don't recurse into hashes and arrays... if they want to see what's inside, they need to request a dump on it. |
313
|
|
|
|
|
|
|
reg( $node->{'@'.$k}{chr(0)} = *{$package.$k}{ARRAY} ); |
314
|
|
|
|
|
|
|
} elsif( *{$package.$k}{CODE} ) { |
315
|
|
|
|
|
|
|
# subroutine inside of a package, declared with sub foo { }, else *foo = sub { }, exported, or XS. |
316
|
|
|
|
|
|
|
# save coderefs but only if they aren't XS (can't serialize those) and weren't exported from elsewhere. |
317
|
|
|
|
|
|
|
my $ob = B::svref_2object(*{$package . $k}{CODE}); |
318
|
|
|
|
|
|
|
my $rootop = $ob->ROOT; |
319
|
|
|
|
|
|
|
my $stashname = $$rootop ? $ob->STASH->NAME . '::' : '(none)'; |
320
|
|
|
|
|
|
|
if($$rootop and ($stashname eq $package or 'main::'.$stashname eq $package or $stashname eq 'main::' )) { |
321
|
|
|
|
|
|
|
# when we eval something in code in main::, it comes up as being exported from main::. *sigh* |
322
|
|
|
|
|
|
|
reg( $node->{$k.'()'}{chr(0)} = *{$package . $k}{CODE} ); |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
} elsif( ref(*{$package.$k}{SCALAR}) ne 'GLOB' ) { |
325
|
|
|
|
|
|
|
# found a scalar inside of the package... create an entry for the scalar itself and if it contains a ref, recurse, I guess |
326
|
|
|
|
|
|
|
my $scalar = *{$package.$k}{SCALAR}; # this is a scalarref in the case of "our $var = 1" or other simple things |
327
|
|
|
|
|
|
|
my $scalarcontains = $$scalar; |
328
|
|
|
|
|
|
|
if(ref $scalarcontains) { |
329
|
|
|
|
|
|
|
$node->{'$'.$k} = caller_cv(0)->($scalarcontains); |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
reg( $node->{'$'.$k}{chr(0)} = $scalar ); # have to do this after assigning in from the recursive call |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
} |
334
|
|
|
|
|
|
|
# end for %{$package}, if %{$package} |
335
|
|
|
|
|
|
|
} elsif(my $class = blessed($object)) { |
336
|
|
|
|
|
|
|
# classes... instance data, methods XXX |
337
|
|
|
|
|
|
|
reg( $node->{chr(0)} = $object); # do this after any recursive call, probably replacing the chr(0) value that came back |
338
|
|
|
|
|
|
|
$node->{chr(1)} = $class; # comment |
339
|
|
|
|
|
|
|
# let's skip the instance data, for now |
340
|
|
|
|
|
|
|
# if( UNIVERSAL::isa($ob, 'HASH') ) { |
341
|
|
|
|
|
|
|
# for my $k (keys %$object) { |
342
|
|
|
|
|
|
|
# next unless ref $object->{$k}; |
343
|
|
|
|
|
|
|
# $node->{$k} = caller_cv(0)->($object->{$k}); |
344
|
|
|
|
|
|
|
# } |
345
|
|
|
|
|
|
|
# } |
346
|
|
|
|
|
|
|
my @isa = ($class, @{$class.'::ISA'}); |
347
|
|
|
|
|
|
|
for my $package (@isa) { |
348
|
|
|
|
|
|
|
for my $k (keys %{$package.'::'}) { |
349
|
|
|
|
|
|
|
next if $k =~ m/[^\w:]/; |
350
|
|
|
|
|
|
|
next if $k =~ m/^_/; |
351
|
|
|
|
|
|
|
next if exists $node->{$k}; # XXX $node->{$class}{chr(0)} could probably point to the correct stash or something |
352
|
|
|
|
|
|
|
next unless *{$package.'::'.$k}{CODE}; |
353
|
|
|
|
|
|
|
reg( $node->{$k.'()'}{chr(0)} = sub { $object->can($k)->($object, @_); } ); # XXX hackish |
354
|
|
|
|
|
|
|
# not recursing into the coderef here; if the sub is found hanging off of a stash, we'll recurse into it then. |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
} elsif(ref($object) eq 'HASH') { |
358
|
|
|
|
|
|
|
# either our parent knows our name and did $node->{whatever} = caller_cv($ref), or else they made something up for us. |
359
|
|
|
|
|
|
|
reg( $node->{chr(0)} = $object ); |
360
|
|
|
|
|
|
|
} elsif(ref($object) eq 'ARRAY') { |
361
|
|
|
|
|
|
|
reg( $node->{chr(0)} = $object ); |
362
|
|
|
|
|
|
|
} elsif(ref($object) eq 'SCALAR') { |
363
|
|
|
|
|
|
|
# a scalar... if it's not a ref, this node will get one item put in it; otherwise, it may get many. |
364
|
|
|
|
|
|
|
# each of these can put whatever they want into $node! |
365
|
|
|
|
|
|
|
# the above is a bit strange in trying to fill in child nodes as well as the node itself... it should probably be recursing. XXX |
366
|
|
|
|
|
|
|
reg( $node->{chr(0)} = $object ); |
367
|
|
|
|
|
|
|
my $scalarcontains = $$object; |
368
|
|
|
|
|
|
|
if(ref($scalarcontains) and ref($scalarcontains) ne 'SCALAR') { |
369
|
|
|
|
|
|
|
$node->{ref($scalarcontains)} = caller_cv(0)->($scalarcontains); |
370
|
|
|
|
|
|
|
} |
371
|
|
|
|
|
|
|
} elsif(ref($object) eq 'CODE') { |
372
|
|
|
|
|
|
|
# generic name for ourself -- this was found inside another code ref, in instance data, array element, or something. |
373
|
|
|
|
|
|
|
reg( $node->{chr(0)} = $object ); |
374
|
|
|
|
|
|
|
# variables inside code refs |
375
|
|
|
|
|
|
|
# walk into the sub and pick out lexical variables |
376
|
|
|
|
|
|
|
# normally only closures would contain data in their lexical variables, but with multiple |
377
|
|
|
|
|
|
|
# coroutines executing concurrently, there's the chance that a subroutine is currently |
378
|
|
|
|
|
|
|
# running, in which case it has data in its pad. if it's recursive, it might have data |
379
|
|
|
|
|
|
|
# at multiple depths too! |
380
|
|
|
|
|
|
|
my $p = peek_sub($object); |
381
|
|
|
|
|
|
|
for my $k (sort { $a cmp $b } keys %$p) { |
382
|
|
|
|
|
|
|
$node->{$k} = caller_cv(0)->($p->{$k}); # anything it contains by way of refs, which might be nothing |
383
|
|
|
|
|
|
|
reg( $node->{$k}{chr(0)} = $p->{$k} ); # have to do this after assigning in from the recursie call |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
} elsif( ! ref($object) ) { |
386
|
|
|
|
|
|
|
# XXX how could we represent constant data, as in the case of our $foo = "hi there", or instance data fields, or...? |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
return $node; |
389
|
|
|
|
|
|
|
}->('main::'); |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
sub tryunref { |
393
|
|
|
|
|
|
|
my $ob = shift; |
394
|
|
|
|
|
|
|
my $request = shift; |
395
|
|
|
|
|
|
|
for(1..4) { |
396
|
|
|
|
|
|
|
$ob = $$ob if(ref $ob) eq 'REF'; |
397
|
|
|
|
|
|
|
} |
398
|
|
|
|
|
|
|
ref($ob) eq 'REF' and do { |
399
|
|
|
|
|
|
|
$request->print("REF derefs to REF four times; probably circular"); |
400
|
|
|
|
|
|
|
return; |
401
|
|
|
|
|
|
|
}; |
402
|
|
|
|
|
|
|
return $ob; |
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
sub tryunobject { |
406
|
|
|
|
|
|
|
my $ob = shift; |
407
|
|
|
|
|
|
|
my $request = shift; |
408
|
|
|
|
|
|
|
if( blessed($ob) and UNIVERSAL::isa($ob, 'HASH') ) { |
409
|
|
|
|
|
|
|
$ob = { %$ob }; |
410
|
|
|
|
|
|
|
} elsif( blessed($ob) and UNIVERSAL::isa($ob, 'ARRAY') ) { |
411
|
|
|
|
|
|
|
$ob = [ @$ob ]; |
412
|
|
|
|
|
|
|
} elsif( blessed($ob) and UNIVERSAL::isa($ob, 'SCALAR') ) { |
413
|
|
|
|
|
|
|
$ob = \ ${$ob}; |
414
|
|
|
|
|
|
|
} elsif( blessed($ob) ) { |
415
|
|
|
|
|
|
|
$request->print("object not blessed hash, array or scalar... no logic for converting to JSON, sorry"); |
416
|
|
|
|
|
|
|
return; |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
return $ob; |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
END { $continuity->loop } |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
1; |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
=head1 NAME |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
Acme::RPC - Easy remote function and method call and more |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
=head1 SYNOPSIS |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
use Acme::RPC; |
433
|
|
|
|
|
|
|
our $test2 = t2->new(); |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
package t2; |
436
|
|
|
|
|
|
|
sub new { bless { one => 1 }, $_[0] }; |
437
|
|
|
|
|
|
|
sub add { ($_[1] + $_[2]); }' |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
Then go to: |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
http://localhost:7777/?path=%24test2/add()&action=call&arg0=10&arg1=15 |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
The C part, decoded, reads C<< $test2/add() >>. |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
=head1 DESCRIPTION |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
By my estimate, there are over 10,000 RPC modules on CPAN. Each one makes RPC more |
448
|
|
|
|
|
|
|
difficult than the one before it. They all want you to pass tokens back and forth, |
449
|
|
|
|
|
|
|
register handlers for which methods may be called, create sessions, and so. |
450
|
|
|
|
|
|
|
With L, there's only one required step: GET or POST to your method. |
451
|
|
|
|
|
|
|
And if you don't know which methods are available, L will help you find them. |
452
|
|
|
|
|
|
|
Even if they're hidden away in objects referenced from inside of closures. |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
The RPC daemon starts after the program finishes, or whe it does C<< Event::loop >>. |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
=head2 CGI Parameters |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
=over 4 |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
=item C<< / >> |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
(No parameter.) |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
=item C<< action=dump >> |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
Gives an index of packages, subroutines, variables in those subroutines, closures in those variables, and so on. |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
=item C<< output=json >> |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
Output a JavaScript datastructures (JSON) instead of Perl style L or HTML. |
471
|
|
|
|
|
|
|
The main index page otherwise prints out HTML (under the assumption that a human will be digging through it) |
472
|
|
|
|
|
|
|
and other things mostly emit L formatted text. |
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
=item C<< oid=(number) >> |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
=item C<< path=/path/to/something >> |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
There are two ways to specify or reference an object: by it's C or by the path to navigate to it from the |
479
|
|
|
|
|
|
|
main index screen. |
480
|
|
|
|
|
|
|
JSON and HTML output from the main index screen specifies the oids of each item and the paths can be derived from |
481
|
|
|
|
|
|
|
the labels in the graph. |
482
|
|
|
|
|
|
|
With no action specified, it defaults to C. |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
=item C<< action=call >> |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
Invokes a method or code ref. |
487
|
|
|
|
|
|
|
It does I invoke object references. |
488
|
|
|
|
|
|
|
Requires either C or C be specified. |
489
|
|
|
|
|
|
|
You may also set C, C, C etc GET or POST parameters to pass data into the function. |
490
|
|
|
|
|
|
|
There's currently no way to pass in an arbitrary object (see TODO below). |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
=item C<< action=method >> |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
Used with C<< method=[method name] >> and either an C<< oid=[oid] >> or C<< path=[path] >> to an |
495
|
|
|
|
|
|
|
object reference, it calls that method on that object. |
496
|
|
|
|
|
|
|
As above, takes argument data from C, C, C, etc. |
497
|
|
|
|
|
|
|
|
498
|
|
|
|
|
|
|
=item C<< lazy=1 >> |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
Avoid rebuilding the entire object graph to speed things up a bit. |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
=head2 TODO |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
C to pass in an arbitrary other object as a parameter. |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
JSON posted to the server to specify arguments. |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
JSON posted to the server to specify the entire function/method call. |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
=head2 BUGS |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
There is no security. At all. |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
A lot of this stuff hasn't been tested. At all. |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
You will leak memory like crazy. |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
Really, I wasted about three days on this, so I'm very much in a "it compiles, ship it!" mode. |
519
|
|
|
|
|
|
|
Want to see it rounded out better? Drop me some email. |
520
|
|
|
|
|
|
|
|
521
|
|
|
|
|
|
|
=head1 HISTORY |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
=over 8 |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
=item 0.01 |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
Original version; created by h2xs 1.23 with options: |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
-A -C -X -b 5.8.0 -c -n Acme::RPC |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
=back |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
=head1 SEE ALSO |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
=head1 AUTHOR |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
Scott Walters, Escott@slowass.netE |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
Copyright (C) 2009 by Scott Walters |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
This library is free software; you can redistribute it and/or modify |
544
|
|
|
|
|
|
|
it under the same terms as Perl itself, either Perl version 5.8.9 or, |
545
|
|
|
|
|
|
|
at your option, any later version of Perl 5 you may have available. |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
USE AT YOUR OWN RISK. |
548
|
|
|
|
|
|
|
|
549
|
|
|
|
|
|
|
NOT SUITABLE FOR ANY PURPOSE. |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
=cut |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
__END__ |