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