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