This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Avoid AV and HV in perlio.c by inventing PerlIO_list_t which is AV-ish
[perl5.git] / 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  PerlIOScalar *s;
229  SV *arg = (narg > 0) ? *args : PerlIOArg;
230  if (SvROK(arg) || SvPOK(arg))
231   {
232    f = PerlIO_allocate(aTHX);
233    s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,arg),PerlIOScalar);
234    PerlIOBase(f)->flags |= PERLIO_F_OPEN;
235    return f;
236   }
237  return NULL;
238 }
239
240
241 PerlIO_funcs PerlIO_scalar = {
242  "Scalar",
243  sizeof(PerlIOScalar),
244  PERLIO_K_BUFFERED,
245  PerlIOScalar_pushed,
246  PerlIOScalar_popped,
247  PerlIOScalar_open,
248  NULL,
249  PerlIOScalar_fileno,
250  PerlIOBase_read,
251  PerlIOScalar_unread,
252  PerlIOScalar_write,
253  PerlIOScalar_seek,
254  PerlIOScalar_tell,
255  PerlIOScalar_close,
256  PerlIOScalar_flush,
257  PerlIOScalar_fill,
258  PerlIOBase_eof,
259  PerlIOBase_error,
260  PerlIOBase_clearerr,
261  PerlIOBase_setlinebuf,
262  PerlIOScalar_get_base,
263  PerlIOScalar_bufsiz,
264  PerlIOScalar_get_ptr,
265  PerlIOScalar_get_cnt,
266  PerlIOScalar_set_ptrcnt,
267 };
268
269
270 #endif /* Layers available */
271
272 MODULE = PerlIO::Scalar PACKAGE = PerlIO::Scalar
273
274 PROTOTYPES: ENABLE
275
276 BOOT:
277 {
278 #ifdef PERLIO_LAYERS
279  PerlIO_define_layer(aTHX_ &PerlIO_scalar);
280 #endif
281 }
282