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