This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Silence one more format warning
[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_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
129 {
130     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
131     char *dst = SvGROW(s->var, (STRLEN)s->posn + count);
132     s->posn -= count;
133     Move(vbuf, dst + s->posn, count, char);
134     SvPOK_on(s->var);
135     return count;
136 }
137
138 SSize_t
139 PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
140 {
141     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
142         Off_t offset;
143         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
144         SV *sv = s->var;
145         char *dst;
146         if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
147             dst = SvGROW(sv, SvCUR(sv) + count);
148             offset = SvCUR(sv);
149             s->posn = offset + count;
150         }
151         else {
152             if ((s->posn + count) > SvCUR(sv))
153                 dst = SvGROW(sv, (STRLEN)s->posn + count);
154             else
155                 dst = SvPV_nolen(sv);
156             offset = s->posn;
157             s->posn += count;
158         }
159         Move(vbuf, dst + offset, count, char);
160         if ((STRLEN) s->posn > SvCUR(sv))
161             SvCUR_set(sv, (STRLEN)s->posn);
162         SvPOK_on(s->var);
163         return count;
164     }
165     else
166         return 0;
167 }
168
169 IV
170 PerlIOScalar_fill(pTHX_ PerlIO * f)
171 {
172     return -1;
173 }
174
175 IV
176 PerlIOScalar_flush(pTHX_ PerlIO * f)
177 {
178     return 0;
179 }
180
181 STDCHAR *
182 PerlIOScalar_get_base(pTHX_ PerlIO * f)
183 {
184     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
185     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
186         return (STDCHAR *) SvPV_nolen(s->var);
187     }
188     return (STDCHAR *) NULL;
189 }
190
191 STDCHAR *
192 PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
193 {
194     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
195         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
196         return PerlIOScalar_get_base(aTHX_ f) + s->posn;
197     }
198     return (STDCHAR *) NULL;
199 }
200
201 SSize_t
202 PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
203 {
204     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
205         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
206         if (SvCUR(s->var) > (STRLEN) s->posn)
207             return SvCUR(s->var) - (STRLEN)s->posn;
208         else
209             return 0;
210     }
211     return 0;
212 }
213
214 Size_t
215 PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
216 {
217     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
218         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
219         return SvCUR(s->var);
220     }
221     return 0;
222 }
223
224 void
225 PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
226 {
227     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
228     s->posn = SvCUR(s->var) - cnt;
229 }
230
231 PerlIO *
232 PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
233                   const char *mode, int fd, int imode, int perm,
234                   PerlIO * f, int narg, SV ** args)
235 {
236     SV *arg = (narg > 0) ? *args : PerlIOArg;
237     if (SvROK(arg) || SvPOK(arg)) {
238         if (!f) {
239             f = PerlIO_allocate(aTHX);
240         }
241         if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
242             PerlIOBase(f)->flags |= PERLIO_F_OPEN;
243         }
244         return f;
245     }
246     return NULL;
247 }
248
249 SV *
250 PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
251 {
252     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
253     SV *var = s->var;
254     if (flags & PERLIO_DUP_CLONE)
255         var = PerlIO_sv_dup(aTHX_ var, param);
256     else if (flags & PERLIO_DUP_FD) {
257         /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
258         var = newSVsv(var);
259     }
260     else {
261         var = SvREFCNT_inc(var);
262     }
263     return newRV_noinc(var);
264 }
265
266 PerlIO *
267 PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
268                  int flags)
269 {
270     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
271         PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar);
272         PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar);
273         /* var has been set by implicit push */
274         fs->posn = os->posn;
275     }
276     return f;
277 }
278
279 PERLIO_FUNCS_DECL(PerlIO_scalar) = {
280     sizeof(PerlIO_funcs),
281     "scalar",
282     sizeof(PerlIOScalar),
283     PERLIO_K_BUFFERED | PERLIO_K_RAW,
284     PerlIOScalar_pushed,
285     PerlIOScalar_popped,
286     PerlIOScalar_open,
287     PerlIOBase_binmode,
288     PerlIOScalar_arg,
289     PerlIOScalar_fileno,
290     PerlIOScalar_dup,
291     PerlIOBase_read,
292     PerlIOScalar_unread,
293     PerlIOScalar_write,
294     PerlIOScalar_seek,
295     PerlIOScalar_tell,
296     PerlIOScalar_close,
297     PerlIOScalar_flush,
298     PerlIOScalar_fill,
299     PerlIOBase_eof,
300     PerlIOBase_error,
301     PerlIOBase_clearerr,
302     PerlIOBase_setlinebuf,
303     PerlIOScalar_get_base,
304     PerlIOScalar_bufsiz,
305     PerlIOScalar_get_ptr,
306     PerlIOScalar_get_cnt,
307     PerlIOScalar_set_ptrcnt,
308 };
309
310
311 #endif /* Layers available */
312
313 MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
314
315 PROTOTYPES: ENABLE
316
317 BOOT:
318 {
319 #ifdef PERLIO_LAYERS
320  PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
321 #endif
322 }
323