ext/PerlIO/Scalar/Scalar.xs

   1 #define PERL_NO_GET_CONTEXT
   2 #include "EXTERN.h"
   3 #include "perl.h"
   4 #include "XSUB.h"
   5 #ifdef PERLIO_LAYERS
   6
   7 #include "perliol.h"
   8
   9 typedef struct
  10 {
  11  struct _PerlIO base;       /* Base "class" info */
  12  SV *           var;
  13  Off_t          posn;
  14 } PerlIOScalar;
  15
  16 IV
  17 PerlIOScalar_pushed(PerlIO *f, const char *mode, SV *arg)
  18 {
  19  PerlIOScalar *b = PerlIOSelf(f,PerlIOScalar);
  20  return PerlIOBase_pushed(f,mode,arg);
  21 }
  22
  23 IV
  24 PerlIOScalar_popped(PerlIO *f)
  25 {
  26  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
  27  if (s->var)
  28   {
  29    dTHX;
  30    SvREFCNT_dec(s->var);
  31    s->var = Nullsv;
  32   }
  33  return 0;
  34 }
  35
  36 IV
  37 PerlIOScalar_close(PerlIO *f)
  38 {
  39  dTHX;
  40  IV code = PerlIOBase_close(f);
  41  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
  42  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
  43  return code;
  44 }
  45
  46 IV
  47 PerlIOScalar_fileno(PerlIO *f)
  48 {
  49  return -1;
  50 }
  51
  52 IV
  53 PerlIOScalar_seek(PerlIO *f, Off_t offset, int whence)
  54 {
  55  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
  56  switch(whence)
  57   {
  58    case 0:
  59     s->posn = offset;
  60     break;
  61    case 1:
  62     s->posn = offset + s->posn;
  63     break;
  64    case 2:
  65     s->posn = offset + SvCUR(s->var);
  66     break;
  67   }
  68  if (s->posn > SvCUR(s->var))
  69   {
  70    dTHX;
  71    (void) SvGROW(s->var,s->posn);
  72   }
  73  return 0;
  74 }
  75
  76 Off_t
  77 PerlIOScalar_tell(PerlIO *f)
  78 {
  79  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
  80  return s->posn;
  81 }
  82
  83 SSize_t
  84 PerlIOScalar_unread(PerlIO *f, const void *vbuf, Size_t count)
  85 {
  86  dTHX;
  87  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
  88  char *dst = SvGROW(s->var,s->posn+count);
  89  Move(vbuf,dst,count,char);
  90  s->posn += count;
  91  SvCUR_set(s->var,s->posn);
  92  SvPOK_on(s->var);
  93  return count;
  94 }
  95
  96 SSize_t
  97 PerlIOScalar_write(PerlIO *f, const void *vbuf, Size_t count)
  98 {
  99  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
 100   {
 101    return PerlIOScalar_unread(f,vbuf,count);
 102   }
 103  return 0;
 104 }
 105
 106 IV
 107 PerlIOScalar_fill(PerlIO *f)
 108 {
 109  return -1;
 110 }
 111
 112 IV
 113 PerlIOScalar_flush(PerlIO *f)
 114 {
 115  return 0;
 116 }
 117
 118 STDCHAR *
 119 PerlIOScalar_get_base(PerlIO *f)
 120 {
 121  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 122  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 123   {
 124    dTHX;
 125    return (STDCHAR *)SvPV_nolen(s->var);
 126   }
 127  return (STDCHAR *) Nullch;
 128 }
 129
 130 STDCHAR *
 131 PerlIOScalar_get_ptr(PerlIO *f)
 132 {
 133  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 134   {
 135    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 136    return PerlIOScalar_get_base(f)+s->posn;
 137   }
 138  return (STDCHAR *) Nullch;
 139 }
 140
 141 SSize_t
 142 PerlIOScalar_get_cnt(PerlIO *f)
 143 {
 144  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 145   {
 146    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 147    return SvCUR(s->var) - s->posn;
 148   }
 149  return 0;
 150 }
 151
 152 Size_t
 153 PerlIOScalar_bufsiz(PerlIO *f)
 154 {
 155  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 156   {
 157    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 158    return SvCUR(s->var);
 159   }
 160  return 0;
 161 }
 162
 163 void
 164 PerlIOScalar_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
 165 {
 166  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 167  s->posn = SvCUR(s->var)-cnt;
 168 }
 169
 170 PerlIO *
 171 PerlIOScalar_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
 172 {
 173  PerlIOScalar *s;
 174  if (narg > 0)
 175   {
 176    SV *ref = *args;
 177    if (SvROK(ref))
 178     {
 179      SV *var = SvRV(ref);
 180      sv_upgrade(var,SVt_PV);
 181      f = PerlIO_allocate(aTHX);
 182      s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOScalar);
 183      s->var = SvREFCNT_inc(var);
 184      s->posn = 0;
 185      PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 186      return f;
 187     }
 188   }
 189  return NULL;
 190 }
 191
 192
 193 PerlIO_funcs PerlIO_scalar = {
 194  "Scalar",
 195  sizeof(PerlIOScalar),
 196  PERLIO_K_BUFFERED,
 197  PerlIOScalar_pushed,
 198  PerlIOScalar_popped,
 199  PerlIOScalar_open,
 200  NULL,
 201  PerlIOScalar_fileno,
 202  PerlIOBase_read,
 203  PerlIOScalar_unread,
 204  PerlIOScalar_write,
 205  PerlIOScalar_seek,
 206  PerlIOScalar_tell,
 207  PerlIOScalar_close,
 208  PerlIOScalar_flush,
 209  PerlIOScalar_fill,
 210  PerlIOBase_eof,
 211  PerlIOBase_error,
 212  PerlIOBase_clearerr,
 213  PerlIOBase_setlinebuf,
 214  PerlIOScalar_get_base,
 215  PerlIOScalar_bufsiz,
 216  PerlIOScalar_get_ptr,
 217  PerlIOScalar_get_cnt,
 218  PerlIOScalar_set_ptrcnt,
 219 };
 220
 221
 222 #endif /* Layers available */
 223
 224 MODULE = PerlIO::Scalar PACKAGE = PerlIO::Scalar
 225
 226 BOOT:
 227 {
 228 #ifdef PERLIO_LAYERS
 229  PerlIO_define_layer(aTHX_ &PerlIO_scalar);
 230 #endif
 231 }
 232