1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
#!/usr/bin/perl
use v5.14;
use warnings;
use Tangence::Client 0.25; # ->get_registry
use Net::Async::Tangence::Client;
use IO::Async::Loop 0.16;
use Data::Dump;
# We want to mangle the way Data::Dump prints our object proxies
# While we're at it, lets build a generic delegated printing system
{
my $_dump = \&Data::Dump::_dump;
my %dump_delegations;
no warnings 'redefine';
*Data::Dump::_dump = sub {
if( exists $dump_delegations{ref $_[0]} ) {
return $dump_delegations{ref $_[0]}->( @_ );
}
else {
return $_dump->( @_ );
}
};
sub register_dump_delegation
{
my ( $class, $cb ) = @_;
$dump_delegations{$class} = $cb;
}
}
register_dump_delegation( "Tangence::ObjectProxy" => sub {
my ( $obj ) = @_;
return "OBJPROXY( id=$obj->{id}, props=" . Data::Dump::dump($obj->{props}) . " )";
} );
my $loop = IO::Async::Loop->new();
my $URL = shift @ARGV or die "Need URL as argv[1]\n";
my $conn = Net::Async::Tangence::Client->new(
on_closed => sub {
print STDERR "Connection closed\n";
exit(0);
},
on_error => sub {
my ( $message ) = @_;
print STDERR "Error: $message\n";
$loop->loop_stop;
},
);
$loop->add( $conn );
$conn->connect_url( $URL )->get;
my $registry = $conn->get_registry->get;;
if( !@ARGV ) {
my $objshash = $registry->get_property( "objects" )->get;
foreach my $id ( sort { $a <=> $b } keys %$objshash ) {
my $desc = $objshash->{$id};
printf "%-6d: %s\n", $id, $desc;
}
}
elsif( $ARGV[0] eq "-i" ) {
shift @ARGV; # eat -i
my $objid = shift @ARGV;
my $obj = $registry->call_method( "get_by_id", $objid )->get;
print "Object is a " . $obj->classname . "\n";
my $class = $obj->class;
print "Class supports:\n";
print " method $_\n" for keys %{ $class->methods };
print " event $_\n" for keys %{ $class->events };
print " property $_\n" for keys %{ $class->properties };
}
elsif( $ARGV[0] eq "-p" ) {
shift @ARGV; # eat -p
my $objid = shift @ARGV;
my $property = shift @ARGV;
my $obj = $registry->call_method( "get_by_id", $objid )->get;
my $value = $obj->get_property( $property )->get;
print Data::Dump::dump( $value ) . "\n";
}
else {
die "Unrecognised operation $ARGV[0]\n";
}
|
