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) && SvTYPE(SvRV(arg)) > SVt_NULL)
  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     SvUPGRADE(s->var, SVt_PV);
  41     code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
  42     if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
  43         SvCUR_set(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, (STRLEN)s->posn + count);
 109     s->posn -= count;
 110     Move(vbuf, dst + s->posn, count, char);
 111     SvPOK_on(s->var);
 112     return count;
 113 }
 114
 115 SSize_t
 116 PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
 117 {
 118     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
 119         Off_t offset;
 120         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 121         SV *sv = s->var;
 122         char *dst;
 123         if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
 124             dst = SvGROW(sv, SvCUR(sv) + count);
 125             offset = SvCUR(sv);
 126             s->posn = offset + count;
 127         }
 128         else {
 129             if ((s->posn + count) > SvCUR(sv))
 130                 dst = SvGROW(sv, (STRLEN)s->posn + count);
 131             else
 132                 dst = SvPV_nolen(sv);
 133             offset = s->posn;
 134             s->posn += count;
 135         }
 136         Move(vbuf, dst + offset, count, char);
 137         if ((STRLEN) s->posn > SvCUR(sv))
 138             SvCUR_set(sv, (STRLEN)s->posn);
 139         SvPOK_on(s->var);
 140         return count;
 141     }
 142     else
 143         return 0;
 144 }
 145
 146 IV
 147 PerlIOScalar_fill(pTHX_ PerlIO * f)
 148 {
 149     return -1;
 150 }
 151
 152 IV
 153 PerlIOScalar_flush(pTHX_ PerlIO * f)
 154 {
 155     return 0;
 156 }
 157
 158 STDCHAR *
 159 PerlIOScalar_get_base(pTHX_ PerlIO * f)
 160 {
 161     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 162     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
 163         return (STDCHAR *) SvPV_nolen(s->var);
 164     }
 165     return (STDCHAR *) Nullch;
 166 }
 167
 168 STDCHAR *
 169 PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
 170 {
 171     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
 172         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 173         return PerlIOScalar_get_base(aTHX_ f) + s->posn;
 174     }
 175     return (STDCHAR *) Nullch;
 176 }
 177
 178 SSize_t
 179 PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
 180 {
 181     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
 182         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 183         if (SvCUR(s->var) > (STRLEN) s->posn)
 184             return SvCUR(s->var) - (STRLEN)s->posn;
 185         else
 186             return 0;
 187     }
 188     return 0;
 189 }
 190
 191 Size_t
 192 PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
 193 {
 194     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
 195         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 196         return SvCUR(s->var);
 197     }
 198     return 0;
 199 }
 200
 201 void
 202 PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
 203 {
 204     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 205     s->posn = SvCUR(s->var) - cnt;
 206 }
 207
 208 PerlIO *
 209 PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
 210                   const char *mode, int fd, int imode, int perm,
 211                   PerlIO * f, int narg, SV ** args)
 212 {
 213     SV *arg = (narg > 0) ? *args : PerlIOArg;
 214     if (SvROK(arg) || SvPOK(arg)) {
 215         if (!f) {
 216             f = PerlIO_allocate(aTHX);
 217         }
 218         if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
 219             PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 220         }
 221         return f;
 222     }
 223     return NULL;
 224 }
 225
 226 SV *
 227 PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
 228 {
 229     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
 230     SV *var = s->var;
 231     if (flags & PERLIO_DUP_CLONE)
 232         var = PerlIO_sv_dup(aTHX_ var, param);
 233     else if (flags & PERLIO_DUP_FD) {
 234         /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
 235         var = newSVsv(var);
 236     }
 237     else {
 238         var = SvREFCNT_inc(var);
 239     }
 240     return newRV_noinc(var);
 241 }
 242
 243 PerlIO *
 244 PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
 245                  int flags)
 246 {
 247     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
 248         PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar);
 249         PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar);
 250         /* var has been set by implicit push */
 251         fs->posn = os->posn;
 252     }
 253     return f;
 254 }
 255
 256 PERLIO_FUNCS_DECL(PerlIO_scalar) = {
 257     sizeof(PerlIO_funcs),
 258     "scalar",
 259     sizeof(PerlIOScalar),
 260     PERLIO_K_BUFFERED | PERLIO_K_RAW,
 261     PerlIOScalar_pushed,
 262     PerlIOScalar_popped,
 263     PerlIOScalar_open,
 264     PerlIOBase_binmode,
 265     PerlIOScalar_arg,
 266     PerlIOScalar_fileno,
 267     PerlIOScalar_dup,
 268     PerlIOBase_read,
 269     PerlIOScalar_unread,
 270     PerlIOScalar_write,
 271     PerlIOScalar_seek,
 272     PerlIOScalar_tell,
 273     PerlIOScalar_close,
 274     PerlIOScalar_flush,
 275     PerlIOScalar_fill,
 276     PerlIOBase_eof,
 277     PerlIOBase_error,
 278     PerlIOBase_clearerr,
 279     PerlIOBase_setlinebuf,
 280     PerlIOScalar_get_base,
 281     PerlIOScalar_bufsiz,
 282     PerlIOScalar_get_ptr,
 283     PerlIOScalar_get_cnt,
 284     PerlIOScalar_set_ptrcnt,
 285 };
 286
 287
 288 #endif /* Layers available */
 289
 290 MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
 291
 292 PROTOTYPES: ENABLE
 293
 294 BOOT:
 295 {
 296 #ifdef PERLIO_LAYERS
 297  PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
 298 #endif
 299 }
 300