This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #77684] Restore the 5.10/12 behaviour of open $fh, ">", \$glob_copy
[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     struct _PerlIO base;        /* Base "class" info */
11     SV *var;
12     Off_t posn;
13 } PerlIOScalar;
14
15 IV
16 PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
17                     PerlIO_funcs * tab)
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         if (SvROK(arg)) {
27             if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') {
28                 if (ckWARN(WARN_LAYER))
29                     Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
30                 SETERRNO(EINVAL, SS_IVCHAN);
31                 return -1;
32             }
33             s->var = SvREFCNT_inc(SvRV(arg));
34             SvGETMAGIC(s->var);
35             if (!SvPOK(s->var) && SvOK(s->var))
36                 (void)SvPV_nomg_const_nolen(s->var);
37         }
38         else {
39             s->var =
40                 SvREFCNT_inc(perl_get_sv
41                              (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
42         }
43     }
44     else {
45         s->var = newSVpvn("", 0);
46     }
47     SvUPGRADE(s->var, SVt_PV);
48     code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
49     if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
50     {
51         sv_force_normal(s->var);
52         SvCUR_set(s->var, 0);
53     }
54     if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
55     {
56         sv_force_normal(s->var);
57         s->posn = SvCUR(s->var);
58     }
59     else
60         s->posn = 0;
61     SvSETMAGIC(s->var);
62     return code;
63 }
64
65 IV
66 PerlIOScalar_popped(pTHX_ PerlIO * f)
67 {
68     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
69     if (s->var) {
70         SvREFCNT_dec(s->var);
71         s->var = Nullsv;
72     }
73     return 0;
74 }
75
76 IV
77 PerlIOScalar_close(pTHX_ PerlIO * f)
78 {
79     IV code = PerlIOBase_close(aTHX_ f);
80     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
81     return code;
82 }
83
84 IV
85 PerlIOScalar_fileno(pTHX_ PerlIO * f)
86 {
87     return -1;
88 }
89
90 IV
91 PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
92 {
93     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
94     STRLEN oldcur;
95     STRLEN newlen;
96
97     SvGETMAGIC(s->var);
98     oldcur = SvCUR(s->var);
99
100     switch (whence) {
101     case SEEK_SET:
102         s->posn = offset;
103         break;
104     case SEEK_CUR:
105         s->posn = offset + s->posn;
106         break;
107     case SEEK_END:
108         s->posn = offset + SvCUR(s->var);
109         break;
110     }
111     if (s->posn < 0) {
112         if (ckWARN(WARN_LAYER))
113             Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
114         SETERRNO(EINVAL, SS_IVCHAN);
115         return -1;
116     }
117     newlen = (STRLEN) s->posn;
118     if (newlen > oldcur) {
119         (void) SvGROW(s->var, newlen);
120         Zero(SvPVX(s->var) + oldcur, newlen - oldcur, char);
121         /* No SvCUR_set(), though.  This is just a seek, not a write. */
122     }
123     else if (!SvPVX(s->var)) {
124         /* ensure there's always a character buffer */
125         (void)SvGROW(s->var,1);
126     }
127     SvPOK_on(s->var);
128     return 0;
129 }
130
131 Off_t
132 PerlIOScalar_tell(pTHX_ PerlIO * f)
133 {
134     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
135     return s->posn;
136 }
137
138
139 SSize_t
140 PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
141 {
142     if (!f)
143         return 0;
144     if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
145         PerlIOBase(f)->flags |= PERLIO_F_ERROR;
146         SETERRNO(EBADF, SS_IVCHAN);
147         return 0;
148     }
149     {
150         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
151         SV *sv = s->var;
152         char *p;
153         STRLEN len, got;
154         p = SvPV(sv, len);
155         got = len - (STRLEN)(s->posn);
156         if (got <= 0)
157             return 0;
158         if (got > (STRLEN)count)
159             got = (STRLEN)count;
160         Copy(p + (STRLEN)(s->posn), vbuf, got, STDCHAR);
161         s->posn += (Off_t)got;
162         return (SSize_t)got;
163     }
164 }
165
166 SSize_t
167 PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
168 {
169     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
170         Off_t offset;
171         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
172         SV *sv = s->var;
173         char *dst;
174         SvGETMAGIC(sv);
175         sv_force_normal(sv);
176         if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
177             dst = SvGROW(sv, SvCUR(sv) + count);
178             offset = SvCUR(sv);
179             s->posn = offset + count;
180         }
181         else {
182             if ((s->posn + count) > SvCUR(sv))
183                 dst = SvGROW(sv, (STRLEN)s->posn + count);
184             else
185                 dst = SvPVX(sv);
186             offset = s->posn;
187             s->posn += count;
188         }
189         Move(vbuf, dst + offset, count, char);
190         if ((STRLEN) s->posn > SvCUR(sv))
191             SvCUR_set(sv, (STRLEN)s->posn);
192         SvPOK_on(sv);
193         SvSETMAGIC(sv);
194         return count;
195     }
196     else
197         return 0;
198 }
199
200 IV
201 PerlIOScalar_fill(pTHX_ PerlIO * f)
202 {
203     return -1;
204 }
205
206 IV
207 PerlIOScalar_flush(pTHX_ PerlIO * f)
208 {
209     return 0;
210 }
211
212 STDCHAR *
213 PerlIOScalar_get_base(pTHX_ PerlIO * f)
214 {
215     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
216     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
217         SvGETMAGIC(s->var);
218         return (STDCHAR *) SvPV_nolen(s->var);
219     }
220     return (STDCHAR *) NULL;
221 }
222
223 STDCHAR *
224 PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
225 {
226     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
227         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
228         return PerlIOScalar_get_base(aTHX_ f) + s->posn;
229     }
230     return (STDCHAR *) NULL;
231 }
232
233 SSize_t
234 PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
235 {
236     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
237         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
238         SvGETMAGIC(s->var);
239         if (SvCUR(s->var) > (STRLEN) s->posn)
240             return SvCUR(s->var) - (STRLEN)s->posn;
241         else
242             return 0;
243     }
244     return 0;
245 }
246
247 Size_t
248 PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
249 {
250     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
251         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
252         SvGETMAGIC(s->var);
253         return SvCUR(s->var);
254     }
255     return 0;
256 }
257
258 void
259 PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
260 {
261     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
262     SvGETMAGIC(s->var);
263     s->posn = SvCUR(s->var) - cnt;
264 }
265
266 PerlIO *
267 PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
268                   const char *mode, int fd, int imode, int perm,
269                   PerlIO * f, int narg, SV ** args)
270 {
271     SV *arg = (narg > 0) ? *args : PerlIOArg;
272     if (SvROK(arg) || SvPOK(arg)) {
273         if (!f) {
274             f = PerlIO_allocate(aTHX);
275         }
276         if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
277             PerlIOBase(f)->flags |= PERLIO_F_OPEN;
278         }
279         return f;
280     }
281     return NULL;
282 }
283
284 SV *
285 PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
286 {
287     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
288     SV *var = s->var;
289     if (flags & PERLIO_DUP_CLONE)
290         var = PerlIO_sv_dup(aTHX_ var, param);
291     else if (flags & PERLIO_DUP_FD) {
292         /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
293         var = newSVsv(var);
294     }
295     else {
296         var = SvREFCNT_inc(var);
297     }
298     return newRV_noinc(var);
299 }
300
301 PerlIO *
302 PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
303                  int flags)
304 {
305     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
306         PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar);
307         PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar);
308         /* var has been set by implicit push */
309         fs->posn = os->posn;
310     }
311     return f;
312 }
313
314 PERLIO_FUNCS_DECL(PerlIO_scalar) = {
315     sizeof(PerlIO_funcs),
316     "scalar",
317     sizeof(PerlIOScalar),
318     PERLIO_K_BUFFERED | PERLIO_K_RAW,
319     PerlIOScalar_pushed,
320     PerlIOScalar_popped,
321     PerlIOScalar_open,
322     PerlIOBase_binmode,
323     PerlIOScalar_arg,
324     PerlIOScalar_fileno,
325     PerlIOScalar_dup,
326     PerlIOScalar_read,
327     NULL, /* unread */
328     PerlIOScalar_write,
329     PerlIOScalar_seek,
330     PerlIOScalar_tell,
331     PerlIOScalar_close,
332     PerlIOScalar_flush,
333     PerlIOScalar_fill,
334     PerlIOBase_eof,
335     PerlIOBase_error,
336     PerlIOBase_clearerr,
337     PerlIOBase_setlinebuf,
338     PerlIOScalar_get_base,
339     PerlIOScalar_bufsiz,
340     PerlIOScalar_get_ptr,
341     PerlIOScalar_get_cnt,
342     PerlIOScalar_set_ptrcnt,
343 };
344
345
346 #endif /* Layers available */
347
348 MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
349
350 PROTOTYPES: ENABLE
351
352 BOOT:
353 {
354 #ifdef PERLIO_LAYERS
355  PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
356 #endif
357 }
358