File Coverage

blib/lib/Acme/RPC.pm
Criterion Covered Total %
statement 13 15 86.6
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 20 90.0


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("
    \n");
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__