support tied file handles

diff --git a/Imager.pm b/Imager.pm
index 66b99824992da09881fb533e9fa4c72eb112e9a3..bedce90986c4eaa4ca0fed516262157259626ce2 100644 (file)
--- a/Imager.pm
+++ b/Imager.pm
@@ -4210,11 +4210,43 @@ sub preload {
 }
 
 package Imager::IO;
+use IO::Seekable;
 
 sub new_fh {
   my ($class, $fh) = @_;
 
-  return $class->_new_perlio($fh);
+  if (tied(*$fh)) {
+    return $class->new_cb
+      (
+       sub {
+        local $\;
+
+        return print $fh $_[0];
+       },
+       sub {
+        my $tmp;
+        my $count = CORE::read $fh, $tmp, $_[1];
+        defined $count
+          or return undef;
+        $count
+          or return "";
+        return $tmp;
+       },
+       sub {
+        if ($_[1] != SEEK_CUR || $_[0] != 0) {
+          unless (CORE::seek $fh, $_[0], $_[1]) {
+            return -1;
+          }
+        }
+
+        return tell $fh;
+       },
+       undef,
+      );
+  }
+  else {
+    return $class->_new_perlio($fh);
+  }
 }
 
 # backward compatibility for %formats

diff --git a/t/t07iolayer.t b/t/t07iolayer.t
index e8da327440db48c0654d92f9d85f4dca84387bf6..ba0c886ddce9bb0985328fe1408591a9cf4313ff 100644 (file)
--- a/t/t07iolayer.t
+++ b/t/t07iolayer.t
@@ -1,6 +1,6 @@
 #!perl -w
 use strict;
-use Test::More tests => 261;
+use Test::More tests => 270;
 # for SEEK_SET etc, Fcntl doesn't provide these in 5.005_03
 use IO::Seekable;
 use Config;
@@ -855,6 +855,21 @@ SKIP:
   is($foo, "temore", "perlio: check it got to the scalar properly");
 }
 
+{
+  tie *FOO, "IO::Tied";
+  my $io = Imager::IO->new_fh(\*FOO);
+  ok($io, "tied: make a I/O object for a tied fh");
+  is($io->write("test"), 4, "tied: check we can write");
+  is($io->seek(2, SEEK_SET), 2, "tied: check we can seek");
+  is($io->write("more"), 4, "tied: write some more");
+  is($io->seek(0, SEEK_SET), 0, "tied: seek back to start");
+  my $data;
+  is($io->read($data, 10), 6, "tied: read everything back");
+  is($data, "temore", "tied: check we read back what we wrote");
+  is($io->close, 0, "tied: close it");
+  is(tied(*FOO)->[0], "temore", "tied: check it got to the output properly");
+}
+
 Imager->close_log;
 
 unless ($ENV{IMAGER_KEEP_FILES}) {
@@ -889,3 +904,66 @@ sub fail_read {
 sub fail_seek {
   return -1;
 }
+
+package IO::Tied;
+use base 'Tie::Handle';
+use IO::Seekable;
+
+sub TIEHANDLE {
+  return bless [ "", 0 ];
+}
+
+sub PRINT {
+  for my $entry (@_[1 .. $#_]) {
+    substr($_[0][0], $_[0][1], length $entry, $entry);
+    $_[0][1] += length $entry;
+  }
+
+  return 1;
+}
+
+sub SEEK {
+  my ($self, $offset, $whence) = @_;
+
+  my $newpos;
+  if ($whence == SEEK_SET) {
+    $newpos = $offset;
+  }
+  elsif ($whence == SEEK_CUR) {
+    $newpos = $self->[1] + $offset;
+  }
+  elsif ($whence == SEEK_END) {
+    $newpos = length($self->[0]) + $newpos;
+  }
+  else {
+    return -1;
+  }
+
+  if ($newpos < 0) {
+    return 0;
+  }
+
+  $self->[1] = $newpos;
+
+  return 1;
+}
+
+sub TELL {
+  return $_[0][1];
+}
+
+sub READ {
+  my $self = shift;
+  my $outlen = $_[1];
+  my $offset = @_ > 2 ? $_[2] : 0;
+  if ($self->[1] + $outlen > length $self->[0]) {
+    $outlen = length($self->[0]) - $self->[1];
+    $outlen <= 0
+      and return "";
+  }
+  defined $_[0] or $_[0] = "";
+  substr($_[0], $offset, $outlen) = substr($self->[0], $self->[1], $outlen);
+  $self->[1] += $outlen;
+
+  return $outlen;
+}