use Scalar::Util;
use Imager::Color;
use Imager::Font;
+use Config;
@EXPORT_OK = qw(
init
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");
$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+");
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;
#include "regmach.h"
#include "imextdef.h"
#include "imextpltypes.h"
+#include "imperlio.h"
#include <float.h>
#if i_int_hlines_testing()
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
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
mutexwin.c
palimg.c
paste.im
+perlio.c
plug.h
PNG/impng.c
PNG/impng.h
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}) {
--- /dev/null
+#ifndef IMAGER_IMPERLIO_H
+#define IMAGER_IMPERLIO_H
+
+extern i_io_glue_t *
+im_io_new_perlio(pTHX_ PerlIO *handle);
+
+#endif
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
--- /dev/null
+/* 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;
+}
+
#!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') };
}
}
+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}) {
projects / imager.git / commitdiff