use PerlIO_* calls to read/write if supplied a fh
authorTony Cook <tony@develop-help.com>
Fri, 11 Jan 2013 12:27:39 +0000 (23:27 +1100)
committerTony Cook <tony@develop-help.com>
Sat, 12 Jan 2013 04:03:11 +0000 (15:03 +1100)
Imager.pm
Imager.xs
MANIFEST
Makefile.PL
imperlio.h [new file with mode: 0644]
lib/Imager/IO.pod
perlio.c [new file with mode: 0644]
t/t07iolayer.t

index 5390f2b..66b9982 100644 (file)
--- a/Imager.pm
+++ b/Imager.pm
@@ -6,6 +6,7 @@ use IO::File;
 use Scalar::Util;
 use Imager::Color;
 use Imager::Font;
+use Config;
 
 @EXPORT_OK = qw(
                init
@@ -1350,12 +1351,11 @@ sub _get_reader_io {
     return io_new_fd($input->{fd});
   }
   elsif ($input->{fh}) {
-    my $fd = fileno($input->{fh});
-    unless (defined $fd) {
+    unless (Scalar::Util::openhandle($input->{fh})) {
       $self->_set_error("Handle in fh option not opened");
       return;
     }
-    return io_new_fd($fd);
+    return Imager::IO->new_fh($input->{fh});
   }
   elsif ($input->{file}) {
     my $file = IO::File->new($input->{file}, "r");
@@ -1405,17 +1405,11 @@ sub _get_writer_io {
     $io = io_new_fd($input->{fd});
   }
   elsif ($input->{fh}) {
-    my $fd = fileno($input->{fh});
-    unless (defined $fd) {
+    unless (Scalar::Util::openhandle($input->{fh})) {
       $self->_set_error("Handle in fh option not opened");
       return;
     }
-    # flush it
-    my $oldfh = select($input->{fh});
-    # flush anything that's buffered, and make sure anything else is flushed
-    $| = 1;
-    select($oldfh);
-    $io = io_new_fd($fd);
+    $io = Imager::IO->new_fh($input->{fh});
   }
   elsif ($input->{file}) {
     my $fh = new IO::File($input->{file},"w+");
@@ -4215,6 +4209,14 @@ sub preload {
   eval { require Imager::Font::T1 };
 }
 
+package Imager::IO;
+
+sub new_fh {
+  my ($class, $fh) = @_;
+
+  return $class->_new_perlio($fh);
+}
+
 # backward compatibility for %formats
 package Imager::FORMATS;
 use strict;
index 2750520..07b2b3e 100644 (file)
--- a/Imager.xs
+++ b/Imager.xs
@@ -21,6 +21,7 @@ extern "C" {
 #include "regmach.h"
 #include "imextdef.h"
 #include "imextpltypes.h"
+#include "imperlio.h"
 #include <float.h>
 
 #if i_int_hlines_testing()
@@ -1165,6 +1166,14 @@ io_new_bufchain(class)
     OUTPUT:
         RETVAL
 
+Imager::IO
+io__new_perlio(class, io)
+       PerlIO *io
+  CODE:
+        RETVAL = im_io_new_perlio(aTHX_ io);
+  OUTPUT:
+       RETVAL
+
 SV *
 io_slurp(class, ig)
         Imager::IO     ig
index 85f0d9a..576d171 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -146,6 +146,7 @@ imgdouble.c                 Implements double/sample images
 imio.h
 immacros.h
 imperl.h
+imperlio.h
 imrender.h                     Buffer rending engine function declarations
 inc/Devel/CheckLib.pm          David Cantrell's Devel::CheckLib
 io.c
@@ -225,6 +226,7 @@ mutexpthr.c
 mutexwin.c
 palimg.c
 paste.im
+perlio.c
 plug.h
 PNG/impng.c
 PNG/impng.h
index 3d3cffa..39a0278 100644 (file)
@@ -167,7 +167,8 @@ my @objs = qw(Imager.o context.o draw.o polygon.o image.o io.o iolayer.o
               regmach.o trans2.o quant.o error.o convert.o
               map.o tags.o palimg.o maskimg.o img8.o img16.o rotate.o
               bmp.o tga.o color.o fills.o imgdouble.o limits.o hlines.o
-              imext.o scale.o rubthru.o render.o paste.o compose.o flip.o);
+              imext.o scale.o rubthru.o render.o paste.o compose.o flip.o
+             perlio.o);
 
 if ($Config{useithreads}) {
   if ($Config{i_pthread}) {
diff --git a/imperlio.h b/imperlio.h
new file mode 100644 (file)
index 0000000..a83e87e
--- /dev/null
@@ -0,0 +1,7 @@
+#ifndef IMAGER_IMPERLIO_H
+#define IMAGER_IMPERLIO_H
+
+extern i_io_glue_t *
+im_io_new_perlio(pTHX_ PerlIO *handle);
+
+#endif
index 2dae013..b0e96a7 100644 (file)
@@ -50,6 +50,10 @@ Create a new I/O layer based on callbacks.  See
 L<Imager::Files/"I/O Callbacks"> for details on the behavior of 
 the callbacks.
 
+=item new_fh($fh)
+
+Create a new I/O layer based on a perl file handle.
+
 =item new_bufchain()
 
 Create a new C<bufchain> based I/O layer.  This accumulates the file
diff --git a/perlio.c b/perlio.c
new file mode 100644 (file)
index 0000000..dd3e5dd
--- /dev/null
+++ b/perlio.c
@@ -0,0 +1,133 @@
+/* perlio.c - Imager's interface to PerlIO
+
+ */
+#define IMAGER_NO_CONTEXT
+#include "imager.h"
+#include "EXTERN.h"
+#include "perl.h"
+#include "imperlio.h"
+
+
+static ssize_t
+perlio_reader(void *handle, void *buf, size_t count);
+static ssize_t
+perlio_writer(void *handle, const void *buf, size_t count);
+static off_t
+perlio_seeker(void *handle, off_t offset, int whence);
+static int
+perlio_closer(void *handle);
+static void
+perlio_destroy(void *handle);
+static const char *my_strerror(int err);
+
+typedef struct {
+  PerlIO *handle;
+  pIMCTX;
+#ifdef USE_PERLIO
+  tTHX my_perl;
+#endif
+} im_perlio;
+
+#define dIMCTXperlio(state) dIMCTXctx(state->aIMCTX)
+
+/*
+=item im_io_new_perlio(PerlIO *)
+
+Create a new perl I/O object that reads/writes/seeks on a PerlIO
+handle.
+
+The close() handle flushes output but does not close the handle.
+
+=cut
+*/
+
+i_io_glue_t *
+im_io_new_perlio(pTHX_ PerlIO *handle) {
+  im_perlio *state = mymalloc(sizeof(im_perlio));
+  dIMCTX;
+
+  state->handle = handle;
+#ifdef USE_PERLIO
+  state->aTHX = aTHX;
+#endif
+  state->aIMCTX = aIMCTX;
+
+  return io_new_cb(state, perlio_reader, perlio_writer,
+                  perlio_seeker, perlio_closer, perlio_destroy);
+}
+
+static ssize_t
+perlio_reader(void *ctx, void *buf, size_t count) {
+  im_perlio *state = ctx;
+  dTHXa(state->my_perl);
+  dIMCTXperlio(state);
+
+  ssize_t result = PerlIO_read(state->handle, buf, count);
+  if (result == 0 && PerlIO_error(state->handle)) {
+    im_push_errorf(aIMCTX, errno, "read() failure (%s)", my_strerror(errno));
+    return -1;
+  }
+
+  return result;
+}
+
+static ssize_t
+perlio_writer(void *ctx, const void *buf, size_t count) {
+  im_perlio *state = ctx;
+  dTHXa(state->my_perl);
+  dIMCTXperlio(state);
+  ssize_t result;
+
+  result = PerlIO_write(state->handle, buf, count);
+
+  if (result == 0) {
+    im_push_errorf(aIMCTX, errno, "write() failure (%s)", my_strerror(errno));
+  }
+
+  return result;
+}
+
+static off_t
+perlio_seeker(void *ctx, off_t offset, int whence) {
+  im_perlio *state = ctx;
+  dTHXa(state->my_perl);
+  dIMCTXperlio(state);
+
+  if (whence != SEEK_CUR || offset != 0) {
+    if (PerlIO_seek(state->handle, offset, whence) < 0) {
+      im_push_errorf(aIMCTX, errno, "seek() failure (%s)", my_strerror(errno));
+      return -1;
+    }
+  }
+
+  return PerlIO_tell(state->handle);
+}
+
+static int
+perlio_closer(void *ctx) {
+  im_perlio *state = ctx;
+  dTHXa(state->my_perl);
+  dIMCTXperlio(state);
+
+  if (PerlIO_flush(state->handle) < 0) {
+    im_push_errorf(aIMCTX, errno, "flush() failure (%s)", my_strerror(errno));
+    return -1;
+  }
+  return 0;
+}
+
+static void
+perlio_destroy(void *ctx) {
+  myfree(ctx);
+}
+
+static
+const char *my_strerror(int err) {
+  const char *result = strerror(err);
+  
+  if (!result)
+    result = "Unknown error";
+  
+  return result;
+}
+
index 4474897..e8da327 100644 (file)
@@ -1,8 +1,9 @@
 #!perl -w
 use strict;
-use Test::More tests => 252;
+use Test::More tests => 261;
 # for SEEK_SET etc, Fcntl doesn't provide these in 5.005_03
 use IO::Seekable;
+use Config;
 
 BEGIN { use_ok(Imager => ':all') };
 
@@ -834,6 +835,26 @@ SKIP:
   }
 }
 
+SKIP:
+{
+  $Config{useperlio}
+    or skip "PerlIO::scalar requires perlio", 9;
+
+  my $foo;
+  open my $fh, "+<", \$foo;
+  my $io = Imager::IO->_new_perlio($fh);
+  ok($io, "perlio: make a I/O object for a perl scalar fh");
+  is($io->write("test"), 4, "perlio: check we can write");
+  is($io->seek(2, SEEK_SET), 2, "perlio: check we can seek");
+  is($io->write("more"), 4, "perlio: write some more");
+  is($io->seek(0, SEEK_SET), 0, "perlio: seek back to start");
+  my $data;
+  is($io->read($data, 10), 6, "perlio: read everything back");
+  is($data, "temore", "perlio: check we read back what we wrote");
+  is($io->close, 0, "perlio: close it");
+  is($foo, "temore", "perlio: check it got to the scalar properly");
+}
+
 Imager->close_log;
 
 unless ($ENV{IMAGER_KEEP_FILES}) {