From: Tyler Riddle <t.riddle@shadowcat.co.uk>
Date: Tue, 25 Sep 2012 18:39:02 +0000 (-0700)
Subject: add in support for tied objects, adjust a few log levels
X-Git-Tag: v0.003001_01~109
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=scpubgit%2FObject-Remote.git;a=commitdiff_plain;h=7790ca36241acfa9379cb2b89b68c9f4b0da2371

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 d338a21..bfd9996 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;
@@ -122,7 +123,19 @@ sub _build__json {
     __local_object__ => sub {
       $self->local_objects_by_id->{$_[0]}
     }
-  );
+  )->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 {
@@ -139,7 +152,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;
     }
   }
@@ -201,7 +213,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 ]);
 }
@@ -241,7 +253,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?
@@ -287,9 +301,19 @@ sub _deobjectify {
     }
   } 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;
+