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  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
  71  return code;
  72 }
  73
  74 IV
  75 PerlIOScalar_fileno(PerlIO *f)
  76 {
  77  return -1;
  78 }
  79
  80 IV
  81 PerlIOScalar_seek(PerlIO *f, Off_t offset, int whence)
  82 {
  83  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
  84  switch(whence)
  85   {
  86    case 0:
  87     s->posn = offset;
  88     break;
  89    case 1:
  90     s->posn = offset + s->posn;
  91     break;
  92    case 2:
  93     s->posn = offset + SvCUR(s->var);
  94     break;
  95   }
  96  if (s->posn > SvCUR(s->var))
  97   {
  98    dTHX;
  99    (void) SvGROW(s->var,s->posn);
 100   }
 101  return 0;
 102 }
 103
 104 Off_t
 105 PerlIOScalar_tell(PerlIO *f)
 106 {
 107  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 108  return s->posn;
 109 }
 110
 111 SSize_t
 112 PerlIOScalar_unread(PerlIO *f, const void *vbuf, Size_t count)
 113 {
 114  dTHX;
 115  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 116  char *dst = SvGROW(s->var,s->posn+count);
 117  Move(vbuf,dst+s->posn,count,char);
 118  s->posn += count;
 119  SvCUR_set(s->var,s->posn);
 120  SvPOK_on(s->var);
 121  return count;
 122 }
 123
 124 SSize_t
 125 PerlIOScalar_write(PerlIO *f, const void *vbuf, Size_t count)
 126 {
 127  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
 128   {
 129    dTHX;
 130    Off_t offset;
 131    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 132    SV *sv = s->var;
 133    char *dst;
 134    if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
 135     {
 136      dst = SvGROW(sv,SvCUR(sv)+count);
 137      offset = SvCUR(sv);
 138      s->posn = offset+count;
 139     }
 140    else
 141     {
 142      if ((s->posn+count) > SvCUR(sv))
 143       dst = SvGROW(sv,s->posn+count);
 144      else
 145       dst = SvPV_nolen(sv);
 146      offset = s->posn;
 147      s->posn += count;
 148     }
 149    Move(vbuf,dst+offset,count,char);
 150    if (s->posn > SvCUR(sv))
 151     SvCUR_set(sv,s->posn);
 152    SvPOK_on(s->var);
 153    return count;
 154   }
 155  else
 156   return 0;
 157 }
 158
 159 IV
 160 PerlIOScalar_fill(PerlIO *f)
 161 {
 162  return -1;
 163 }
 164
 165 IV
 166 PerlIOScalar_flush(PerlIO *f)
 167 {
 168  return 0;
 169 }
 170
 171 STDCHAR *
 172 PerlIOScalar_get_base(PerlIO *f)
 173 {
 174  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 175  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 176   {
 177    dTHX;
 178    return (STDCHAR *)SvPV_nolen(s->var);
 179   }
 180  return (STDCHAR *) Nullch;
 181 }
 182
 183 STDCHAR *
 184 PerlIOScalar_get_ptr(PerlIO *f)
 185 {
 186  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 187   {
 188    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 189    return PerlIOScalar_get_base(f)+s->posn;
 190   }
 191  return (STDCHAR *) Nullch;
 192 }
 193
 194 SSize_t
 195 PerlIOScalar_get_cnt(PerlIO *f)
 196 {
 197  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 198   {
 199    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 200    if (SvCUR(s->var) > s->posn)
 201     return SvCUR(s->var) - s->posn;
 202    else
 203     return 0;
 204   }
 205  return 0;
 206 }
 207
 208 Size_t
 209 PerlIOScalar_bufsiz(PerlIO *f)
 210 {
 211  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 212   {
 213    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 214    return SvCUR(s->var);
 215   }
 216  return 0;
 217 }
 218
 219 void
 220 PerlIOScalar_set_ptrcnt(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, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
 228 {
 229  PerlIOScalar *s;
 230  SV *arg = (narg > 0) ? *args : PerlIOArg;
 231  if (SvROK(arg) || SvPOK(arg))
 232   {
 233    f = PerlIO_allocate(aTHX);
 234    s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,arg),PerlIOScalar);
 235    PerlIOBase(f)->flags |= PERLIO_F_OPEN;
 236    return f;
 237   }
 238  return NULL;
 239 }
 240
 241
 242 PerlIO_funcs PerlIO_scalar = {
 243  "Scalar",
 244  sizeof(PerlIOScalar),
 245  PERLIO_K_BUFFERED,
 246  PerlIOScalar_pushed,
 247  PerlIOScalar_popped,
 248  PerlIOScalar_open,
 249  NULL,
 250  PerlIOScalar_fileno,
 251  PerlIOBase_read,
 252  PerlIOScalar_unread,
 253  PerlIOScalar_write,
 254  PerlIOScalar_seek,
 255  PerlIOScalar_tell,
 256  PerlIOScalar_close,
 257  PerlIOScalar_flush,
 258  PerlIOScalar_fill,
 259  PerlIOBase_eof,
 260  PerlIOBase_error,
 261  PerlIOBase_clearerr,
 262  PerlIOBase_setlinebuf,
 263  PerlIOScalar_get_base,
 264  PerlIOScalar_bufsiz,
 265  PerlIOScalar_get_ptr,
 266  PerlIOScalar_get_cnt,
 267  PerlIOScalar_set_ptrcnt,
 268 };
 269
 270
 271 #endif /* Layers available */
 272
 273 MODULE = PerlIO::Scalar PACKAGE = PerlIO::Scalar
 274
 275 PROTOTYPES: ENABLE
 276
 277 BOOT:
 278 {
 279 #ifdef PERLIO_LAYERS
 280  PerlIO_define_layer(aTHX_ &PerlIO_scalar);
 281 #endif
 282 }
 283