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