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(pTHX_ PerlIO *f, const char *mode, SV *arg)
  18 {
  19  IV code;
  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  code = PerlIOBase_pushed(aTHX_ f,mode,Nullsv);
  42  if ((PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
  43    SvCUR(s->var) = 0;
  44  if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
  45    s->posn = SvCUR(s->var);
  46  else
  47    s->posn = 0;
  48  return code;
  49 }
  50
  51 IV
  52 PerlIOScalar_popped(pTHX_ PerlIO *f)
  53 {
  54  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
  55  if (s->var)
  56   {
  57    SvREFCNT_dec(s->var);
  58    s->var = Nullsv;
  59   }
  60  return 0;
  61 }
  62
  63 IV
  64 PerlIOScalar_close(pTHX_ PerlIO *f)
  65 {
  66  IV code = PerlIOBase_close(aTHX_ f);
  67  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
  68  return code;
  69 }
  70
  71 IV
  72 PerlIOScalar_fileno(pTHX_ PerlIO *f)
  73 {
  74  return -1;
  75 }
  76
  77 IV
  78 PerlIOScalar_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
  79 {
  80  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
  81  switch(whence)
  82   {
  83    case 0:
  84     s->posn = offset;
  85     break;
  86    case 1:
  87     s->posn = offset + s->posn;
  88     break;
  89    case 2:
  90     s->posn = offset + SvCUR(s->var);
  91     break;
  92   }
  93  if ((STRLEN)s->posn > SvCUR(s->var))
  94   {
  95    (void) SvGROW(s->var,(STRLEN)s->posn);
  96   }
  97  return 0;
  98 }
  99
 100 Off_t
 101 PerlIOScalar_tell(pTHX_ PerlIO *f)
 102 {
 103  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 104  return s->posn;
 105 }
 106
 107 SSize_t
 108 PerlIOScalar_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 109 {
 110  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 111  char *dst = SvGROW(s->var,s->posn+count);
 112  Move(vbuf,dst+s->posn,count,char);
 113  s->posn += count;
 114  SvCUR_set(s->var,s->posn);
 115  SvPOK_on(s->var);
 116  return count;
 117 }
 118
 119 SSize_t
 120 PerlIOScalar_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 121 {
 122  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
 123   {
 124    Off_t offset;
 125    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 126    SV *sv = s->var;
 127    char *dst;
 128    if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
 129     {
 130      dst = SvGROW(sv,SvCUR(sv)+count);
 131      offset = SvCUR(sv);
 132      s->posn = offset+count;
 133     }
 134    else
 135     {
 136      if ((s->posn+count) > SvCUR(sv))
 137       dst = SvGROW(sv,s->posn+count);
 138      else
 139       dst = SvPV_nolen(sv);
 140      offset = s->posn;
 141      s->posn += count;
 142     }
 143    Move(vbuf,dst+offset,count,char);
 144    if ((STRLEN)s->posn > SvCUR(sv))
 145     SvCUR_set(sv,s->posn);
 146    SvPOK_on(s->var);
 147    return count;
 148   }
 149  else
 150   return 0;
 151 }
 152
 153 IV
 154 PerlIOScalar_fill(pTHX_ PerlIO *f)
 155 {
 156  return -1;
 157 }
 158
 159 IV
 160 PerlIOScalar_flush(pTHX_ PerlIO *f)
 161 {
 162  return 0;
 163 }
 164
 165 STDCHAR *
 166 PerlIOScalar_get_base(pTHX_ PerlIO *f)
 167 {
 168  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 169  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 170   {
 171    return (STDCHAR *)SvPV_nolen(s->var);
 172   }
 173  return (STDCHAR *) Nullch;
 174 }
 175
 176 STDCHAR *
 177 PerlIOScalar_get_ptr(pTHX_ PerlIO *f)
 178 {
 179  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 180   {
 181    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 182    return PerlIOScalar_get_base(aTHX_ f)+s->posn;
 183   }
 184  return (STDCHAR *) Nullch;
 185 }
 186
 187 SSize_t
 188 PerlIOScalar_get_cnt(pTHX_ PerlIO *f)
 189 {
 190  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 191   {
 192    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 193    if (SvCUR(s->var) > (STRLEN)s->posn)
 194     return SvCUR(s->var) - s->posn;
 195    else
 196     return 0;
 197   }
 198  return 0;
 199 }
 200
 201 Size_t
 202 PerlIOScalar_bufsiz(pTHX_ PerlIO *f)
 203 {
 204  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 205   {
 206    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 207    return SvCUR(s->var);
 208   }
 209  return 0;
 210 }
 211
 212 void
 213 PerlIOScalar_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR *ptr, SSize_t cnt)
 214 {
 215  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 216  s->posn = SvCUR(s->var)-cnt;
 217 }
 218
 219 PerlIO *
 220 PerlIOScalar_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
 221 {
 222  SV *arg = (narg > 0) ? *args : PerlIOArg;
 223  if (SvROK(arg) || SvPOK(arg))
 224   {
 225    f = PerlIO_allocate(aTHX);
 226    (void)PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,arg),PerlIOScalar);
 227    PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 228    return f;
 229   }
 230  return NULL;
 231 }
 232
 233 SV *
 234 PerlIOScalar_arg(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
 235 {
 236  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 237  SV *var = s->var;
 238  if (flags & PERLIO_DUP_CLONE)
 239   var = PerlIO_sv_dup(aTHX_ var, param);
 240  else if (flags & PERLIO_DUP_FD)
 241   {
 242    /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
 243    var = newSVsv(var);
 244   }
 245  else
 246   {
 247    var = SvREFCNT_inc(var);
 248   }
 249  return newRV_noinc(var);
 250 }
 251
 252 PerlIO *
 253 PerlIOScalar_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 254 {
 255  if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags)))
 256   {
 257    PerlIOScalar *fs = PerlIOSelf(f,PerlIOScalar);
 258    PerlIOScalar *os = PerlIOSelf(o,PerlIOScalar);
 259    /* var has been set by implicit push */
 260    fs->posn = os->posn;
 261   }
 262  return f;
 263 }
 264
 265 PerlIO_funcs PerlIO_scalar = {
 266  "Scalar",
 267  sizeof(PerlIOScalar),
 268  PERLIO_K_BUFFERED,
 269  PerlIOScalar_pushed,
 270  PerlIOScalar_popped,
 271  PerlIOScalar_open,
 272  PerlIOScalar_arg,
 273  PerlIOScalar_fileno,
 274  PerlIOScalar_dup,
 275  PerlIOBase_read,
 276  PerlIOScalar_unread,
 277  PerlIOScalar_write,
 278  PerlIOScalar_seek,
 279  PerlIOScalar_tell,
 280  PerlIOScalar_close,
 281  PerlIOScalar_flush,
 282  PerlIOScalar_fill,
 283  PerlIOBase_eof,
 284  PerlIOBase_error,
 285  PerlIOBase_clearerr,
 286  PerlIOBase_setlinebuf,
 287  PerlIOScalar_get_base,
 288  PerlIOScalar_bufsiz,
 289  PerlIOScalar_get_ptr,
 290  PerlIOScalar_get_cnt,
 291  PerlIOScalar_set_ptrcnt,
 292 };
 293
 294
 295 #endif /* Layers available */
 296
 297 MODULE = PerlIO::Scalar PACKAGE = PerlIO::Scalar
 298
 299 PROTOTYPES: ENABLE
 300
 301 BOOT:
 302 {
 303 #ifdef PERLIO_LAYERS
 304  PerlIO_define_layer(aTHX_ &PerlIO_scalar);
 305 #endif
 306 }
 307