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 static const char code_point_warning[] =
  10  "Strings with code points over 0xFF may not be mapped into in-memory file handles\n";
  11
  12 typedef struct {
  13     struct _PerlIO base;        /* Base "class" info */
  14     SV *var;
  15     Off_t posn;
  16 } PerlIOScalar;
  17
  18 IV
  19 PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
  20                     PerlIO_funcs * tab)
  21 {
  22     IV code;
  23     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
  24     /* If called (normally) via open() then arg is ref to scalar we are
  25      * using, otherwise arg (from binmode presumably) is either NULL
  26      * or the _name_ of the scalar
  27      */
  28     if (arg && SvOK(arg)) {
  29         if (SvROK(arg)) {
  30             if (SvREADONLY(SvRV(arg)) && !SvIsCOW(SvRV(arg))
  31              && mode && *mode != 'r') {
  32                 if (ckWARN(WARN_LAYER))
  33                     Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
  34                 SETERRNO(EINVAL, SS_IVCHAN);
  35                 return -1;
  36             }
  37             s->var = SvREFCNT_inc(SvRV(arg));
  38             SvGETMAGIC(s->var);
  39             if (!SvPOK(s->var) && SvOK(s->var))
  40                 (void)SvPV_nomg_const_nolen(s->var);
  41         }
  42         else {
  43             s->var =
  44                 SvREFCNT_inc(perl_get_sv
  45                              (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
  46         }
  47     }
  48     else {
  49         s->var = newSVpvn("", 0);
  50     }
  51     SvUPGRADE(s->var, SVt_PV);
  52     code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
  53     if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
  54     {
  55         sv_force_normal(s->var);
  56         SvCUR_set(s->var, 0);
  57     }
  58     if (SvUTF8(s->var) && !sv_utf8_downgrade(s->var, TRUE)) {
  59         if (ckWARN(WARN_UTF8))
  60             Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
  61         SETERRNO(EINVAL, SS_IVCHAN);
  62         SvREFCNT_dec(s->var);
  63         s->var = Nullsv;
  64         return -1;
  65     }
  66     if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
  67     {
  68         sv_force_normal(s->var);
  69         s->posn = SvCUR(s->var);
  70     }
  71     else
  72         s->posn = 0;
  73     SvSETMAGIC(s->var);
  74     return code;
  75 }
  76
  77 IV
  78 PerlIOScalar_popped(pTHX_ PerlIO * f)
  79 {
  80     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
  81     if (s->var) {
  82         SvREFCNT_dec(s->var);
  83         s->var = Nullsv;
  84     }
  85     return 0;
  86 }
  87
  88 IV
  89 PerlIOScalar_close(pTHX_ PerlIO * f)
  90 {
  91     IV code = PerlIOBase_close(aTHX_ f);
  92     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
  93     return code;
  94 }
  95
  96 IV
  97 PerlIOScalar_fileno(pTHX_ PerlIO * f)
  98 {
  99     PERL_UNUSED_ARG(f);
 100     return -1;
 101 }
 102
 103 IV
 104 PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
 105 {
 106     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 107
 108     switch (whence) {
 109     case SEEK_SET:
 110         s->posn = offset;
 111         break;
 112     case SEEK_CUR:
 113         s->posn = offset + s->posn;
 114         break;
 115     case SEEK_END:
 116       {
 117         STRLEN oldcur;
 118         (void)SvPV(s->var, oldcur);
 119         s->posn = offset + oldcur;
 120         break;
 121       }
 122     }
 123     if (s->posn < 0) {
 124         if (ckWARN(WARN_LAYER))
 125             Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
 126         SETERRNO(EINVAL, SS_IVCHAN);
 127         return -1;
 128     }
 129     return 0;
 130 }
 131
 132 Off_t
 133 PerlIOScalar_tell(pTHX_ PerlIO * f)
 134 {
 135     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 136     return s->posn;
 137 }
 138
 139
 140 SSize_t
 141 PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 142 {
 143     if (!f)
 144         return 0;
 145     if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
 146         PerlIOBase(f)->flags |= PERLIO_F_ERROR;
 147         SETERRNO(EBADF, SS_IVCHAN);
 148         return 0;
 149     }
 150     {
 151         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 152         SV *sv = s->var;
 153         char *p;
 154         STRLEN len;
 155         I32 got;
 156         p = SvPV(sv, len);
 157         if (SvUTF8(sv)) {
 158             if (sv_utf8_downgrade(sv, TRUE)) {
 159                 p = SvPV_nomg(sv, len);
 160             }
 161             else {
 162                 if (ckWARN(WARN_UTF8))
 163                     Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
 164                 SETERRNO(EINVAL, SS_IVCHAN);
 165                 return -1;
 166             }
 167         }
 168         got = len - (STRLEN)(s->posn);
 169         if (got <= 0)
 170             return 0;
 171         if ((STRLEN)got > (STRLEN)count)
 172             got = (STRLEN)count;
 173         Copy(p + (STRLEN)(s->posn), vbuf, got, STDCHAR);
 174         s->posn += (Off_t)got;
 175         return (SSize_t)got;
 176     }
 177 }
 178
 179 SSize_t
 180 PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
 181 {
 182     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
 183         Off_t offset;
 184         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 185         SV *sv = s->var;
 186         char *dst;
 187         SvGETMAGIC(sv);
 188         if (!SvROK(sv)) sv_force_normal(sv);
 189         if (SvOK(sv)) SvPV_force_nomg_nolen(sv);
 190         if (SvUTF8(sv) && !sv_utf8_downgrade(sv, TRUE)) {
 191             if (ckWARN(WARN_UTF8))
 192                 Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
 193             SETERRNO(EINVAL, SS_IVCHAN);
 194             return 0;
 195         }
 196         if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
 197             dst = SvGROW(sv, SvCUR(sv) + count + 1);
 198             offset = SvCUR(sv);
 199             s->posn = offset + count;
 200         }
 201         else {
 202             STRLEN const cur = SvCUR(sv);
 203             if (s->posn > cur) {
 204                 dst = SvGROW(sv, (STRLEN)s->posn + count + 1);
 205                 Zero(SvPVX(sv) + cur, (STRLEN)s->posn - cur, char);
 206             }
 207             else if ((s->posn + count) >= cur)
 208                 dst = SvGROW(sv, (STRLEN)s->posn + count + 1);
 209             else
 210                 dst = SvPVX(sv);
 211             offset = s->posn;
 212             s->posn += count;
 213         }
 214         Move(vbuf, dst + offset, count, char);
 215         if ((STRLEN) s->posn > SvCUR(sv)) {
 216             SvCUR_set(sv, (STRLEN)s->posn);
 217             dst[(STRLEN) s->posn] = 0;
 218         }
 219         SvPOK_on(sv);
 220         SvSETMAGIC(sv);
 221         return count;
 222     }
 223     else
 224         return 0;
 225 }
 226
 227 IV
 228 PerlIOScalar_fill(pTHX_ PerlIO * f)
 229 {
 230     PERL_UNUSED_ARG(f);
 231     return -1;
 232 }
 233
 234 IV
 235 PerlIOScalar_flush(pTHX_ PerlIO * f)
 236 {
 237     PERL_UNUSED_ARG(f);
 238     return 0;
 239 }
 240
 241 STDCHAR *
 242 PerlIOScalar_get_base(pTHX_ PerlIO * f)
 243 {
 244     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 245     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
 246         SvGETMAGIC(s->var);
 247         return (STDCHAR *) SvPV_nolen(s->var);
 248     }
 249     return (STDCHAR *) NULL;
 250 }
 251
 252 STDCHAR *
 253 PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
 254 {
 255     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
 256         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 257         return PerlIOScalar_get_base(aTHX_ f) + s->posn;
 258     }
 259     return (STDCHAR *) NULL;
 260 }
 261
 262 SSize_t
 263 PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
 264 {
 265     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
 266         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 267         STRLEN len;
 268         SvGETMAGIC(s->var);
 269         if (isGV_with_GP(s->var))
 270             (void)SvPV(s->var,len);
 271         else len = SvCUR(s->var);
 272         if (len > (STRLEN) s->posn)
 273             return len - (STRLEN)s->posn;
 274         else
 275             return 0;
 276     }
 277     return 0;
 278 }
 279
 280 Size_t
 281 PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
 282 {
 283     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
 284         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 285         SvGETMAGIC(s->var);
 286         return SvCUR(s->var);
 287     }
 288     return 0;
 289 }
 290
 291 void
 292 PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
 293 {
 294     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 295     STRLEN len;
 296     PERL_UNUSED_ARG(ptr);
 297     SvGETMAGIC(s->var);
 298     if (isGV_with_GP(s->var)) (void)SvPV(s->var,len);
 299     else len = SvCUR(s->var);
 300     s->posn = len - cnt;
 301 }
 302
 303 PerlIO *
 304 PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
 305                   const char *mode, int fd, int imode, int perm,
 306                   PerlIO * f, int narg, SV ** args)
 307 {
 308     SV *arg = (narg > 0) ? *args : PerlIOArg;
 309     PERL_UNUSED_ARG(fd);
 310     PERL_UNUSED_ARG(imode);
 311     PERL_UNUSED_ARG(perm);
 312     if (SvROK(arg) || SvPOK(arg)) {
 313         if (!f) {
 314             f = PerlIO_allocate(aTHX);
 315         }
 316         if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
 317             PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 318         }
 319         return f;
 320     }
 321     return NULL;
 322 }
 323
 324 SV *
 325 PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
 326 {
 327     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 328     SV *var = s->var;
 329     if (flags & PERLIO_DUP_CLONE)
 330         var = PerlIO_sv_dup(aTHX_ var, param);
 331     else if (flags & PERLIO_DUP_FD) {
 332         /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
 333         var = newSVsv(var);
 334     }
 335     else {
 336         var = SvREFCNT_inc(var);
 337     }
 338     return newRV_noinc(var);
 339 }
 340
 341 PerlIO *
 342 PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
 343                  int flags)
 344 {
 345     /* Duplication causes the scalar layer to be pushed on to clone, caus-
 346        ing the cloned scalar to be set to the empty string by
 347        PerlIOScalar_pushed.  So set aside our scalar temporarily. */
 348     PerlIOScalar * const os = PerlIOSelf(o, PerlIOScalar);
 349     PerlIOScalar *fs;
 350     SV * const var = os->var;
 351     os->var = newSVpvs("");
 352     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
 353         fs = PerlIOSelf(f, PerlIOScalar);
 354         /* var has been set by implicit push, so replace it */
 355         SvREFCNT_dec(fs->var);
 356     }
 357     SvREFCNT_dec(os->var);
 358     os->var = var;
 359     if (f) {
 360         SV * const rv = PerlIOScalar_arg(aTHX_ o, param, flags);
 361         fs->var = SvREFCNT_inc(SvRV(rv));
 362         SvREFCNT_dec(rv);
 363         fs->posn = os->posn;
 364     }
 365     return f;
 366 }
 367
 368 PERLIO_FUNCS_DECL(PerlIO_scalar) = {
 369     sizeof(PerlIO_funcs),
 370     "scalar",
 371     sizeof(PerlIOScalar),
 372     PERLIO_K_BUFFERED | PERLIO_K_RAW,
 373     PerlIOScalar_pushed,
 374     PerlIOScalar_popped,
 375     PerlIOScalar_open,
 376     PerlIOBase_binmode,
 377     PerlIOScalar_arg,
 378     PerlIOScalar_fileno,
 379     PerlIOScalar_dup,
 380     PerlIOScalar_read,
 381     NULL, /* unread */
 382     PerlIOScalar_write,
 383     PerlIOScalar_seek,
 384     PerlIOScalar_tell,
 385     PerlIOScalar_close,
 386     PerlIOScalar_flush,
 387     PerlIOScalar_fill,
 388     PerlIOBase_eof,
 389     PerlIOBase_error,
 390     PerlIOBase_clearerr,
 391     PerlIOBase_setlinebuf,
 392     PerlIOScalar_get_base,
 393     PerlIOScalar_bufsiz,
 394     PerlIOScalar_get_ptr,
 395     PerlIOScalar_get_cnt,
 396     PerlIOScalar_set_ptrcnt,
 397 };
 398
 399
 400 #endif /* Layers available */
 401
 402 MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
 403
 404 PROTOTYPES: ENABLE
 405
 406 BOOT:
 407 {
 408 #ifdef PERLIO_LAYERS
 409  PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
 410 #endif
 411 }
 412