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