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