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