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