From: Robert 'phaylon' Sedlacek <r.sedlacek@shadowcat.co.uk>
Date: Tue, 17 Jul 2012 22:13:34 +0000 (+0000)
Subject: allow glob references to be transferred
X-Git-Tag: v0.002002~15
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ed5a8a8e0299184b24f57ab38dba1a392a9dc9ec;p=scpubgit%2FObject-Remote.git

allow glob references to be transferred
---

diff --git a/Changes b/Changes
index 6402a03..ac60ca9 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,4 @@
+  - allow transfer of glob references
   - allow loading of classes and packages from __DATA__
   - allow transfer of scalar references
 
diff --git a/lib/Object/Remote/Connection.pm b/lib/Object/Remote/Connection.pm
index 4d593b3..556a4c2 100644
--- a/lib/Object/Remote/Connection.pm
+++ b/lib/Object/Remote/Connection.pm
@@ -4,7 +4,10 @@ use Object::Remote::Future;
 use Object::Remote::Null;
 use Object::Remote::Handle;
 use Object::Remote::CodeContainer;
+use Object::Remote::GlobProxy;
+use Object::Remote::GlobContainer;
 use Object::Remote;
+use Symbol;
 use IO::Handle;
 use Module::Runtime qw(use_module);
 use Scalar::Util qw(weaken blessed refaddr);
@@ -86,6 +89,13 @@ sub _build__json {
       my $value = shift;
       return \$value;
     }
+  )->filter_json_single_key_object(
+    __glob_ref__ => sub {
+      my $glob_container = $self->_id_to_remote_object(@_);
+      my $handle = Symbol::gensym;
+      tie *$handle, 'Object::Remote::GlobProxy', $glob_container;
+      return $handle;
+    }
   );
 }
 
@@ -243,6 +253,10 @@ sub _deobjectify {
       return +{ __remote_code__ => $id };
     } elsif ($ref eq 'SCALAR') {
       return +{ __scalar_ref__ => $$data };
+    } elsif ($ref eq 'GLOB') {
+      return +{ __glob_ref__ => $self->_local_object_to_id(
+        Object::Remote::GlobContainer->new(handle => $data)
+      ) };
     } else {
       die "Can't collapse reftype $ref";
     }
diff --git a/lib/Object/Remote/GlobContainer.pm b/lib/Object/Remote/GlobContainer.pm
new file mode 100644
index 0000000..0ff6e19
--- /dev/null
+++ b/lib/Object/Remote/GlobContainer.pm
@@ -0,0 +1,14 @@
+package Object::Remote::GlobContainer;
+use Moo;
+use FileHandle;
+
+has _handle => (is => 'ro', required => 1, init_arg => 'handle');
+
+sub AUTOLOAD {
+  my ($self, @args) = @_;
+  (my $method) = our $AUTOLOAD =~ m{::([^:]+)$};
+  return if $method eq 'DESTROY';
+  return $self->_handle->$method(@args);
+}
+
+1;
diff --git a/lib/Object/Remote/GlobProxy.pm b/lib/Object/Remote/GlobProxy.pm
new file mode 100644
index 0000000..a246fb7
--- /dev/null
+++ b/lib/Object/Remote/GlobProxy.pm
@@ -0,0 +1,37 @@
+use strictures 1;
+
+package Object::Remote::GlobProxy;
+require Tie::Handle;
+our @ISA = qw( Tie::Handle );
+
+sub TIEHANDLE {
+  my ($class, $glob_container) = @_;
+  return bless { container => $glob_container }, $class;
+}
+
+my @_delegate = (
+  [READLINE => sub { wantarray ? $_[0]->getlines : $_[0]->getline }],
+  (map { [uc($_), lc($_)] } qw(
+    write
+    print
+    printf
+    read
+    getc
+    close
+    open
+    binmode
+    eof
+    tell
+    seek
+  )),
+);
+
+for my $delegation (@_delegate) {
+  my ($from, $to) = @$delegation;
+  no strict 'refs';
+  *{join '::', __PACKAGE__, $from} = sub {
+    $_[0]->{container}->$to(@_[1 .. $#_]);
+  };
+}
+
+1;
diff --git a/t/data/numbers.txt b/t/data/numbers.txt
new file mode 100644
index 0000000..8a1218a
--- /dev/null
+++ b/t/data/numbers.txt
@@ -0,0 +1,5 @@
+1
+2
+3
+4
+5
diff --git a/t/lib/ORTestGlobs.pm b/t/lib/ORTestGlobs.pm
new file mode 100644
index 0000000..a67eb0e
--- /dev/null
+++ b/t/lib/ORTestGlobs.pm
@@ -0,0 +1,26 @@
+package ORTestGlobs;
+use Moo;
+
+has handle => (is => 'rw');
+has valueref => (is => 'ro', default => sub {
+  my $body = '';
+  return \$body;
+});
+
+sub write { my $self = shift; print { $self->handle } @_ }
+
+sub getvalue { ${ $_[0]->valueref } }
+
+sub gethandle {
+  open my $fh, '>', $_[0]->valueref
+    or die "Unable to open in-memory file: $!\n";
+  return $fh;
+}
+
+sub getreadhandle {
+  open my $fh, '<', $_[1]
+    or die "Unable to open in-memory file: $!\n";
+  return $fh;
+}
+
+1;
diff --git a/t/transfer.t b/t/transfer.t
index d5c6a48..0ce0846 100644
--- a/t/transfer.t
+++ b/t/transfer.t
@@ -1,6 +1,7 @@
 use strictures 1;
 use Test::More;
 use Test::Fatal;
+use FindBin;
 
 $ENV{PERL5LIB} = join(
   ':', ($ENV{PERL5LIB} ? $ENV{PERL5LIB} : ()), qw(lib t/lib)
@@ -14,12 +15,45 @@ my $strB = 'bar';
 is exception {
   my $proxy = ORTestTransfer->new::on('-', value => \$strA);
   is_deeply $proxy->value, \$strA, 'correct value after construction';
-}, undef, 'no errors during construction';
+}, undef, 'scalar refs - no errors during construction';
 
 is exception {
   my $proxy = ORTestTransfer->new::on('-');
   $proxy->value(\$strB);
   is_deeply $proxy->value, \$strB, 'correct value after construction';
-}, undef, 'no errors during attribute set';
+}, undef, 'scalar refs - no errors during attribute set';
+
+my $data_file = "$FindBin::Bin/data/numbers.txt";
+
+is exception {
+  my $out = '';
+  open my $fh, '>', \$out or die "Unable to open in-memory file: $!\n";
+  my $proxy = ORTestGlobs->new::on('-', handle => $fh);
+  ok $proxy->handle, 'filehandle was set';
+  ok $proxy->write('foo'), 'write was successful';
+  is $out, 'foo', 'write reached target';
+}, undef, 'filehandles - no error during construction';
+
+is exception {
+  my $proxy = ORTestGlobs->new::on('-');
+  my $handle = $proxy->gethandle;
+  print $handle 'foo';
+  is $proxy->getvalue, 'foo', 'correct value written';
+  $handle->autoflush(1);
+}, undef, 'filehandles - no error during remote handle';
+
+is exception {
+  my $proxy = ORTestGlobs->new::on('-');
+  my $rhandle = $proxy->getreadhandle($data_file);
+  my @lines = <$rhandle>;
+  chomp @lines;
+  is_deeply \@lines, [1 .. 5], 'reading back out of the handle';
+}, undef, 'filehandles - no error during remote read';
+
+is exception {
+  my $proxy = ORTestGlobs->new::on('-');
+  my $rhandle = $proxy->getreadhandle($data_file);
+  binmode $rhandle;
+}, undef, 'filehandles - no errors during binmode';
 
 done_testing;