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