From: Tyler Riddle Date: Tue, 25 Sep 2012 18:39:02 +0000 (-0700) Subject: add in support for tied objects, adjust a few log levels X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b51a8453354ea19e42ea2a09234b1c9d1eb8ca67;p=scpubgit%2FObject-Remote.git add in support for tied objects, adjust a few log levels --- diff --git a/lib/Object/Remote/Connection.pm b/lib/Object/Remote/Connection.pm index ad71972..661555d 100644 --- a/lib/Object/Remote/Connection.pm +++ b/lib/Object/Remote/Connection.pm @@ -7,6 +7,7 @@ use Object::Remote::CodeContainer; use Object::Remote::GlobProxy; use Object::Remote::GlobContainer; use Object::Remote::Logging qw (:log :dlog); +use Object::Remote::Tied; use Object::Remote; use Symbol; use IO::Handle; @@ -118,7 +119,19 @@ sub _build__json { tie *$handle, 'Object::Remote::GlobProxy', $glob_container; return $handle; } - ); + )->filter_json_single_key_object( + __remote_tied_hash__ => sub { + my %tied_hash; + tie %tied_hash, 'Object::Remote::Tied', $self->_id_to_remote_object(@_); + return \%tied_hash; + } + )->filter_json_single_key_object( + __remote_tied_array__ => sub { + my @tied_array; + tie @tied_array, 'Object::Remote::Tied', $self->_id_to_remote_object(@_); + return \@tied_array; + } + ); } BEGIN { @@ -135,7 +148,6 @@ sub new_from_spec { Dlog_debug { "creating a new connection from spec" }; foreach my $poss (do { our @Guess }) { if (my $conn = $poss->($spec)) { - #Dlog_debug { my $id = $conn->_id; "created connection $id for spec $_" } $spec; return $conn->maybe::start::connect; } } @@ -197,7 +209,7 @@ sub register_remote { sub send_free { my ($self, $id) = @_; - Dlog_debug { "sending request to free object '$id' for connection $_" } $self->_id; + Dlog_trace { "sending request to free object '$id' for connection $_" } $self->_id; delete $self->remote_objects_by_id->{$id}; $self->_send([ free => $id ]); } @@ -237,7 +249,9 @@ sub _send { my $serialized = $self->_serialize($to_send)."\n"; Dlog_trace { my $l = length($serialized); "serialization is completed; sending '$l' characters of serialized data to $_" } $fh; #TODO this is very risky for deadlocks unless it's set to non-blocking and then with out extra - #logic it could easily do short-writes to the remote side + #logic it could easily do short-writes to the remote side - how about taking this entire buffer + #and having the run loop send it to the file handle so this doesn't block while the sending + #is happening? my $ret = print $fh $serialized; Dlog_trace { my $r = defined $ret ? $ret : 'undef'; "print() returned $r with $_" } $fh; #TODO hrm reason print's return value was ignored? @@ -276,9 +290,19 @@ sub _deobjectify { return +{ __remote_object__ => $self->_local_object_to_id($data) }; } elsif (my $ref = ref($data)) { if ($ref eq 'HASH') { - return +{ map +($_ => $self->_deobjectify($data->{$_})), keys %$data }; + my $tied_to = tied(%$data); + if(defined($tied_to)) { + return +{__remote_tied_hash__ => $self->_local_object_to_id($tied_to)}; + } else { + return +{ map +($_ => $self->_deobjectify($data->{$_})), keys %$data }; + } } elsif ($ref eq 'ARRAY') { - return [ map $self->_deobjectify($_), @$data ]; + my $tied_to = tied(@$data); + if (defined($tied_to)) { + return +{__remote_tied_array__ => $self->_local_object_to_id($tied_to)}; + } else { + return [ map $self->_deobjectify($_), @$data ]; + } } elsif ($ref eq 'CODE') { my $id = $self->_local_object_to_id( Object::Remote::CodeContainer->new(code => $data) diff --git a/lib/Object/Remote/Handle.pm b/lib/Object/Remote/Handle.pm index 40584b5..1a20eba 100644 --- a/lib/Object/Remote/Handle.pm +++ b/lib/Object/Remote/Handle.pm @@ -32,7 +32,7 @@ sub proxy { sub BUILD { my ($self, $args) = @_; - log_debug { "constructing remote handle" }; + log_trace { "constructing remote handle" }; if ($self->id) { log_trace { "disarming free for this handle" }; $self->disarm_free; @@ -56,7 +56,7 @@ sub BUILD { sub call { my ($self, $method, @args) = @_; my $w = wantarray; - log_debug { my $def = defined $w ? 1 : 0; "call() has been invoked on a remote handle; wantarray: '$def'" }; + log_trace { my $def = defined $w ? 1 : 0; "call() has been invoked on a remote handle; wantarray: '$def'" }; $method = "start::${method}" if (caller(0)||'') eq 'start'; future { $self->connection->send(call => $self->id, $w, $method, @args) diff --git a/lib/Object/Remote/MiniLoop.pm b/lib/Object/Remote/MiniLoop.pm index 18c0b47..60b7c27 100644 --- a/lib/Object/Remote/MiniLoop.pm +++ b/lib/Object/Remote/MiniLoop.pm @@ -42,7 +42,7 @@ sub watch_io { #TODO if this works out non-blocking support #will need to be integrated in a way that #is compatible with Windows which has no - #non-blocking support + #non-blocking support - see also ::ReadChannel if (0) { Dlog_warn { "setting file handle to be non-blocking: $_" } $fh; use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK); @@ -173,7 +173,6 @@ sub loop_once { $read_count++; $read->{$fh}(); last if $Loop_Entered; -# $read->{$fh}() if $read->{$fh}; } log_trace { "Writing to all ready filehandles" }; foreach my $fh (@$writeable) { @@ -181,8 +180,8 @@ sub loop_once { $write_count++; $write->{$fh}(); last if $Loop_Entered; -# $write->{$fh}() if $write->{$fh}; } + log_trace { "Read from $read_count filehandles; wrote to $write_count filehandles" }; my $timers = $self->_timers; my $now = time(); @@ -227,7 +226,8 @@ sub want_stop { #it's own localized is_running attribute - any adjustment to the #is_running attribute outside of that future will not effect that #future so each future winds up able to call run() and stop() at -#will with out interfering with each other +#will with out interfering with each other - how about having +#run loop until the future becomes ready? sub run { my ($self) = @_; log_trace { "Run loop: run() invoked" }; diff --git a/lib/Object/Remote/ReadChannel.pm b/lib/Object/Remote/ReadChannel.pm index 2d3da40..6b27348 100644 --- a/lib/Object/Remote/ReadChannel.pm +++ b/lib/Object/Remote/ReadChannel.pm @@ -28,23 +28,10 @@ has on_line_call => (is => 'rw'); has _receive_data_buffer => (is => 'ro', default => sub { my $x = ''; \$x }); -#TODO confirmed this is the point of the hang - sysread() is invoked on a -#socket inside the controller that blocks and deadlocks the entire system. -#The remote nodes are all waiting to receive data at that point. -#Validated this behavior exists in an unmodified Object::Remote from CPAN -#by wrapping this sysread() with warns that have the pid in them and pounding -#my local machine with System::Introspector via ssh and 7 remote perl instances -#It looks like one of the futures is responding to an event regarding the ability -#to read from a socket and every once in a while an ordering issue means that -#there is no actual data to read from the socket sub _receive_data_from { my ($self, $fh) = @_; Dlog_trace { "Preparing to read data from $_" } $fh; - #use Carp qw(cluck); cluck(); my $rb = $self->_receive_data_buffer; - #TODO is there a specific reason sysread() and syswrite() aren't - #a part of ::MiniLoop? It's one spot to handle errors and other - #logic involving filehandles my $len = sysread($fh, $$rb, 32768, length($$rb)); my $err = defined($len) ? '' : ": $!"; if (defined($len) and $len > 0) { diff --git a/lib/Object/Remote/Role/Connector/PerlInterpreter.pm b/lib/Object/Remote/Role/Connector/PerlInterpreter.pm index a8d743f..810c822 100644 --- a/lib/Object/Remote/Role/Connector/PerlInterpreter.pm +++ b/lib/Object/Remote/Role/Connector/PerlInterpreter.pm @@ -13,6 +13,8 @@ use Moo::Role; with 'Object::Remote::Role::Connector'; +#TODO ugh breaks some of the stuff in System::Introspector::Util by +#screwing with status value of child BEGIN { $SIG{CHLD} = sub { my $kid; @@ -26,6 +28,7 @@ has module_sender => (is => 'lazy'); #if no child_stderr file handle is specified then stderr #of the child will be connected to stderr of the parent has stderr => ( is => 'rw', default => sub { \*STDERR } ); +#has stderr => ( is => 'rw' ); sub _build_module_sender { my ($hook) = @@ -111,7 +114,7 @@ sub _start_perl { Dlog_trace { "got $len characters of stderr data for connection" }; print $given_stderr $buf or die "could not send stderr data: $!"; } - } + } ); } @@ -132,9 +135,11 @@ sub _start_perl { # my $foreign_stdin, # @{$self->final_perl_command}, # ) or die "Failed to run perl at '$_[0]': $!"; +# +# Dlog_trace { "Connection to remote side successful; remote stdin and stdout: $_" } [ $foreign_stdin, $foreign_stdout ]; - Dlog_trace { "Connection to remote side successful; remote stdin and stdout: $_" } [ $foreign_stdin, $foreign_stdout ]; - return ($foreign_stdin, $foreign_stdout, $pid); + + return ($foreign_stdin, $foreign_stdout, $pid); } #TODO open2() forks off a child and I have not been able to locate diff --git a/lib/Object/Remote/Tied.pm b/lib/Object/Remote/Tied.pm new file mode 100644 index 0000000..af6f7fd --- /dev/null +++ b/lib/Object/Remote/Tied.pm @@ -0,0 +1,21 @@ +package Object::Remote::Tied; + +use strictures 1; + +#a proxied tied object just ties to the +#proxy object that exists on the remote +#side of the actual tied variable - when +#creating the remote tied variable the proxy +#is passed to the constructor + +sub TIEHASH { + return $_[1]; +} + +sub TIEARRAY { + return $_[1]; +} + + +1; +