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