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  IV code = PerlIOBase_close(f);
  69  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
  70  return code;
  71 }
  72
  73 IV
  74 PerlIOScalar_fileno(PerlIO *f)
  75 {
  76  return -1;
  77 }
  78
  79 IV
  80 PerlIOScalar_seek(PerlIO *f, Off_t offset, int whence)
  81 {
  82  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
  83  switch(whence)
  84   {
  85    case 0:
  86     s->posn = offset;
  87     break;
  88    case 1:
  89     s->posn = offset + s->posn;
  90     break;
  91    case 2:
  92     s->posn = offset + SvCUR(s->var);
  93     break;
  94   }
  95  if (s->posn > SvCUR(s->var))
  96   {
  97    dTHX;
  98    (void) SvGROW(s->var,s->posn);
  99   }
 100  return 0;
 101 }
 102
 103 Off_t
 104 PerlIOScalar_tell(PerlIO *f)
 105 {
 106  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 107  return s->posn;
 108 }
 109
 110 SSize_t
 111 PerlIOScalar_unread(PerlIO *f, const void *vbuf, Size_t count)
 112 {
 113  dTHX;
 114  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 115  char *dst = SvGROW(s->var,s->posn+count);
 116  Move(vbuf,dst+s->posn,count,char);
 117  s->posn += count;
 118  SvCUR_set(s->var,s->posn);
 119  SvPOK_on(s->var);
 120  return count;
 121 }
 122
 123 SSize_t
 124 PerlIOScalar_write(PerlIO *f, const void *vbuf, Size_t count)
 125 {
 126  if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
 127   {
 128    dTHX;
 129    Off_t offset;
 130    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 131    SV *sv = s->var;
 132    char *dst;
 133    if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
 134     {
 135      dst = SvGROW(sv,SvCUR(sv)+count);
 136      offset = SvCUR(sv);
 137      s->posn = offset+count;
 138     }
 139    else
 140     {
 141      if ((s->posn+count) > SvCUR(sv))
 142       dst = SvGROW(sv,s->posn+count);
 143      else
 144       dst = SvPV_nolen(sv);
 145      offset = s->posn;
 146      s->posn += count;
 147     }
 148    Move(vbuf,dst+offset,count,char);
 149    if (s->posn > SvCUR(sv))
 150     SvCUR_set(sv,s->posn);
 151    SvPOK_on(s->var);
 152    return count;
 153   }
 154  else
 155   return 0;
 156 }
 157
 158 IV
 159 PerlIOScalar_fill(PerlIO *f)
 160 {
 161  return -1;
 162 }
 163
 164 IV
 165 PerlIOScalar_flush(PerlIO *f)
 166 {
 167  return 0;
 168 }
 169
 170 STDCHAR *
 171 PerlIOScalar_get_base(PerlIO *f)
 172 {
 173  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 174  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 175   {
 176    dTHX;
 177    return (STDCHAR *)SvPV_nolen(s->var);
 178   }
 179  return (STDCHAR *) Nullch;
 180 }
 181
 182 STDCHAR *
 183 PerlIOScalar_get_ptr(PerlIO *f)
 184 {
 185  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 186   {
 187    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 188    return PerlIOScalar_get_base(f)+s->posn;
 189   }
 190  return (STDCHAR *) Nullch;
 191 }
 192
 193 SSize_t
 194 PerlIOScalar_get_cnt(PerlIO *f)
 195 {
 196  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 197   {
 198    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 199    if (SvCUR(s->var) > s->posn)
 200     return SvCUR(s->var) - s->posn;
 201    else
 202     return 0;
 203   }
 204  return 0;
 205 }
 206
 207 Size_t
 208 PerlIOScalar_bufsiz(PerlIO *f)
 209 {
 210  if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
 211   {
 212    PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 213    return SvCUR(s->var);
 214   }
 215  return 0;
 216 }
 217
 218 void
 219 PerlIOScalar_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
 220 {
 221  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
 222  s->posn = SvCUR(s->var)-cnt;
 223 }
 224
 225 PerlIO *
 226 PerlIOScalar_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
 227 {
 228  SV *arg = (narg > 0) ? *args : PerlIOArg;
 229  if (SvROK(arg) || SvPOK(arg))
 230   {
 231    f = PerlIO_allocate(aTHX);
 232    (void)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