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