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