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  dTHX;
  20  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
  21  /* If called (normally) via open() then arg is ref to scalar we are
  22     using, otherwise arg (from binmode presumably) is either NULL
  23     or the _name_ of the scalar
  24   */
  25  if  (arg)
  26   {
  27    if (SvROK(arg))
  28     {
  29      s->var = SvREFCNT_inc(SvRV(arg));
  30     }
  31    else
  32     {
  33      s->var = SvREFCNT_inc(perl_get_sv(SvPV_nolen(arg),GV_ADD|GV_ADDMULTI));
  34     }
  35   }
  36  else
  37   {
  38    s->var = newSVpvn("",0);
  39   }
  40  sv_upgrade(s->var,SVt_PV);
  41  s->posn = 0;
  42  return PerlIOBase_pushed(f,mode,Nullsv);
  43 }
  44
  45 IV
  46 PerlIOScalar_popped(PerlIO *f)
  47 {
  48  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
  49  if (s->var)
  50   {
  51    dTHX;
  52    SvREFCNT_dec(s->var);
  53    s->var = Nullsv;
  54   }
  55  return 0;
  56 }
  57
  58 IV
  59 PerlIOScalar_close(PerlIO *f)
  60 {
  61  dTHX;
  62  IV code = PerlIOBase_close(f);
  63  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
  64  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
  65  return code;
  66 }
  67
  68 IV
  69 PerlIOScalar_fileno(PerlIO *f)
  70 {
  71  return -1;
  72 }
  73
  74 IV
  75 PerlIOScalar_seek(PerlIO *f, Off_t offset, int whence)
  76 {
  77  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
  78  switch(whence)
  79   {
  80    case 0:
  81     s->posn = offset;
  82     break;
  83    case 1:
  84     s->posn = offset + s->posn;
  85     break;
  86    case 2:
  87     s->posn = offset + SvCUR(s->var);
  88     break;
  89   }
  90  if (s->posn > SvCUR(s->var))
  91   {
  92    dTHX;
  93    (void) SvGROW(s->var,s->posn);
  94   }
  95  return 0;
  96 }
  97
  98 Off_t
  99 PerlIOScalar_tell(PerlIO *f)
 100 {
 101  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 102  return s->posn;
 103 }
 104
 105 SSize_t
 106 PerlIOScalar_unread(PerlIO *f, const void *vbuf, Size_t count)
 107 {
 108  dTHX;
 109  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 110  char *dst = SvGROW(s->var,s->posn+count);
 111  Move(vbuf,dst,count,char);
 112  s->posn += count;
 113  SvCUR_set(s->var,s->posn);
 114  SvPOK_on(s->var);
 115  return count;
 116 }
 117
 118 SSize_t
 119 PerlIOScalar_write(PerlIO *f, const void *vbuf, Size_t count)
 120 {
 121  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
 122   {
 123    return PerlIOScalar_unread(f,vbuf,count);
 124   }
 125  return 0;
 126 }
 127
 128 IV
 129 PerlIOScalar_fill(PerlIO *f)
 130 {
 131  return -1;
 132 }
 133
 134 IV
 135 PerlIOScalar_flush(PerlIO *f)
 136 {
 137  return 0;
 138 }
 139
 140 STDCHAR *
 141 PerlIOScalar_get_base(PerlIO *f)
 142 {
 143  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 144  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 145   {
 146    dTHX;
 147    return (STDCHAR *)SvPV_nolen(s->var);
 148   }
 149  return (STDCHAR *) Nullch;
 150 }
 151
 152 STDCHAR *
 153 PerlIOScalar_get_ptr(PerlIO *f)
 154 {
 155  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 156   {
 157    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 158    return PerlIOScalar_get_base(f)+s->posn;
 159   }
 160  return (STDCHAR *) Nullch;
 161 }
 162
 163 SSize_t
 164 PerlIOScalar_get_cnt(PerlIO *f)
 165 {
 166  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 167   {
 168    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 169    return SvCUR(s->var) - s->posn;
 170   }
 171  return 0;
 172 }
 173
 174 Size_t
 175 PerlIOScalar_bufsiz(PerlIO *f)
 176 {
 177  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 178   {
 179    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 180    return SvCUR(s->var);
 181   }
 182  return 0;
 183 }
 184
 185 void
 186 PerlIOScalar_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
 187 {
 188  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 189  s->posn = SvCUR(s->var)-cnt;
 190 }
 191
 192 PerlIO *
 193 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)
 194 {
 195  PerlIOScalar *s;
 196  SV *arg = (narg > 0) ? *args : PerlIOArg;
 197  if (SvROK(arg) || SvPOK(arg))
 198   {
 199    f = PerlIO_allocate(aTHX);
 200    s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,arg),PerlIOScalar);
 201    PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 202    return f;
 203   }
 204  return NULL;
 205 }
 206
 207
 208 PerlIO_funcs PerlIO_scalar = {
 209  "Scalar",
 210  sizeof(PerlIOScalar),
 211  PERLIO_K_BUFFERED,
 212  PerlIOScalar_pushed,
 213  PerlIOScalar_popped,
 214  PerlIOScalar_open,
 215  NULL,
 216  PerlIOScalar_fileno,
 217  PerlIOBase_read,
 218  PerlIOScalar_unread,
 219  PerlIOScalar_write,
 220  PerlIOScalar_seek,
 221  PerlIOScalar_tell,
 222  PerlIOScalar_close,
 223  PerlIOScalar_flush,
 224  PerlIOScalar_fill,
 225  PerlIOBase_eof,
 226  PerlIOBase_error,
 227  PerlIOBase_clearerr,
 228  PerlIOBase_setlinebuf,
 229  PerlIOScalar_get_base,
 230  PerlIOScalar_bufsiz,
 231  PerlIOScalar_get_ptr,
 232  PerlIOScalar_get_cnt,
 233  PerlIOScalar_set_ptrcnt,
 234 };
 235
 236
 237 #endif /* Layers available */
 238
 239 MODULE = PerlIO::Scalar PACKAGE = PerlIO::Scalar
 240
 241 PROTOTYPES: ENABLE
 242
 243 BOOT:
 244 {
 245 #ifdef PERLIO_LAYERS
 246  PerlIO_define_layer(aTHX_ &PerlIO_scalar);
 247 #endif
 248 }
 249