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