perlio.c

   1 /* perlio.c - Imager's interface to PerlIO
   2
   3  */
   4 #define IMAGER_NO_CONTEXT
   5 #include "imager.h"
   6 #include "EXTERN.h"
   7 #include "perl.h"
   8 #include "imperlio.h"
   9
  10
  11 static ssize_t
  12 perlio_reader(void *handle, void *buf, size_t count);
  13 static ssize_t
  14 perlio_writer(void *handle, const void *buf, size_t count);
  15 static off_t
  16 perlio_seeker(void *handle, off_t offset, int whence);
  17 static int
  18 perlio_closer(void *handle);
  19 static void
  20 perlio_destroy(void *handle);
  21 /* my_strerror is defined since perl 5.21.x */
  22 #undef my_strerror
  23 static const char *my_strerror(pTHX_ int err);
  24
  25 #ifndef tTHX
  26 #define tTHX PerlInterpreter *
  27 #endif
  28
  29 typedef struct {
  30   PerlIO *handle;
  31   pIMCTX;
  32 #ifdef MULTIPLICITY
  33   tTHX my_perl;
  34 #endif
  35 } im_perlio;
  36
  37 #define dIMCTXperlio(state) dIMCTXctx(state->aIMCTX)
  38
  39 /*
  40 =item im_io_new_perlio(PerlIO *)
  41
  42 Create a new perl I/O object that reads/writes/seeks on a PerlIO
  43 handle.
  44
  45 The close() handle flushes output but does not close the handle.
  46
  47 =cut
  48 */
  49
  50 i_io_glue_t *
  51 im_io_new_perlio(pTHX_ PerlIO *handle) {
  52   im_perlio *state = mymalloc(sizeof(im_perlio));
  53   dIMCTX;
  54
  55   state->handle = handle;
  56 #ifdef MULTIPLICITY
  57   state->aTHX = aTHX;
  58 #endif
  59   state->aIMCTX = aIMCTX;
  60
  61   return io_new_cb(state, perlio_reader, perlio_writer,
  62                    perlio_seeker, perlio_closer, perlio_destroy);
  63 }
  64
  65 static ssize_t
  66 perlio_reader(void *ctx, void *buf, size_t count) {
  67   im_perlio *state = ctx;
  68   dTHXa(state->my_perl);
  69   dIMCTXperlio(state);
  70
  71   ssize_t result = PerlIO_read(state->handle, buf, count);
  72   if (result == 0 && PerlIO_error(state->handle)) {
  73     im_push_errorf(aIMCTX, errno, "read() failure (%s)", my_strerror(aTHX_ errno));
  74     return -1;
  75   }
  76
  77   return result;
  78 }
  79
  80 static ssize_t
  81 perlio_writer(void *ctx, const void *buf, size_t count) {
  82   im_perlio *state = ctx;
  83   dTHXa(state->my_perl);
  84   dIMCTXperlio(state);
  85   ssize_t result;
  86
  87   result = PerlIO_write(state->handle, buf, count);
  88
  89   if (result == 0) {
  90     im_push_errorf(aIMCTX, errno, "write() failure (%s)", my_strerror(aTHX_ errno));
  91   }
  92
  93   return result;
  94 }
  95
  96 static off_t
  97 perlio_seeker(void *ctx, off_t offset, int whence) {
  98   im_perlio *state = ctx;
  99   dTHXa(state->my_perl);
 100   dIMCTXperlio(state);
 101
 102   if (whence != SEEK_CUR || offset != 0) {
 103     if (PerlIO_seek(state->handle, offset, whence) < 0) {
 104       im_push_errorf(aIMCTX, errno, "seek() failure (%s)", my_strerror(aTHX_ errno));
 105       return -1;
 106     }
 107   }
 108
 109   return PerlIO_tell(state->handle);
 110 }
 111
 112 static int
 113 perlio_closer(void *ctx) {
 114   im_perlio *state = ctx;
 115   dTHXa(state->my_perl);
 116   dIMCTXperlio(state);
 117
 118   if (PerlIO_flush(state->handle) < 0) {
 119     im_push_errorf(aIMCTX, errno, "flush() failure (%s)", my_strerror(aTHX_ errno));
 120     return -1;
 121   }
 122   return 0;
 123 }
 124
 125 static void
 126 perlio_destroy(void *ctx) {
 127   myfree(ctx);
 128 }
 129
 130 static
 131 const char *my_strerror(pTHX_ int err) {
 132   const char *result = strerror(err);
 133
 134   if (!result)
 135     result = "Unknown error";
 136
 137   return result;
 138 }
 139