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