1 /*
2 :tee - write to files.
3
4 Usage: open(my $out, '>>:tee', \*STDOUT, \*SOCKET, $file, \$scalar)
5 $out->push_layer(tee => $another);
6 */
7
8 #include "perlioutil.h"
9
10 #define TeeOut(f) (PerlIOSelf(f, PerlIOTee)->out)
11 #define TeeArg(f) (PerlIOSelf(f, PerlIOTee)->arg)
12
13 /* copied from perlio.c */
14 static PerlIO_funcs *
PerlIO_layer_from_ref(pTHX_ SV * const sv)15 PerlIO_layer_from_ref(pTHX_ SV* const sv)
16 {
17 dVAR;
18 /*
19 * For any scalar type load the handler which is bundled with perl
20 */
21 if (SvTYPE(sv) < SVt_PVAV) {
22 PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
23 /* This isn't supposed to happen, since PerlIO::scalar is core,
24 * but could happen anyway in smaller installs or with PAR */
25 if (!f)
26 PerlIOUtil_warnif(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
27 return f;
28 }
29
30 /*
31 * For other types allow if layer is known but don't try and load it
32 */
33 switch (SvTYPE(sv)) {
34 case SVt_PVAV:
35 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
36 case SVt_PVHV:
37 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
38 case SVt_PVCV:
39 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
40 case SVt_PVGV:
41 return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
42 default:
43 return NULL;
44 }
45 } /* PerlIO_layer_from_ref() */
46
47 static PerlIO*
PerlIO_dup(pTHX_ PerlIO * newfp,PerlIO * const oldfp,CLONE_PARAMS * const params,int const flags)48 PerlIO_dup(pTHX_ PerlIO* newfp, PerlIO* const oldfp, CLONE_PARAMS* const params, int const flags){
49 if(PerlIOValid(oldfp)){
50 PerlIO* (*my_dup)(pTHX_ PerlIO*, PerlIO*, CLONE_PARAMS*, int);
51
52 my_dup = PerlIOBase(oldfp)->tab->Dup;
53
54 if(!newfp) newfp = PerlIO_allocate(aTHX);
55 if(!my_dup) my_dup = PerlIOBase_dup;
56
57 return my_dup(aTHX_ newfp, oldfp, params, flags);
58 }
59
60 SETERRNO(EBADF, SS_IVCHAN);
61 return NULL;
62 }
63
64 typedef struct {
65 struct _PerlIO base; /* virtual table and flags */
66
67 SV* arg;
68
69 PerlIO* out;
70 } PerlIOTee;
71
72
73 static PerlIO*
PerlIOTee_open(pTHX_ PerlIO_funcs * const self,PerlIO_list_t * const layers,IV const n,const char * const mode,int const fd,int const imode,int const perm,PerlIO * f,int const narg,SV ** const args)74 PerlIOTee_open(pTHX_ PerlIO_funcs* const self, PerlIO_list_t* const layers, IV const n,
75 const char* const mode, int const fd, int const imode, int const perm,
76 PerlIO* f, int const narg, SV** const args){
77 SV* arg;
78
79 if(!(PerlIOUnix_oflags(mode) & O_WRONLY)){ /* cannot open:tee for reading */
80 SETERRNO(EINVAL, LIB_INVARG);
81 return NULL;
82 }
83
84 f = PerlIOUtil_openn(aTHX_ NULL, layers, n, mode,
85 fd, imode, perm, f, 1, args);
86
87 if(!f){
88 return NULL;
89 }
90
91 if(narg > 1){
92 int i;
93 for(i = 1; i < narg; i++){
94 if(!PerlIO_push(aTHX_ f, self, mode, args[i])){
95 PerlIO_close(f);
96 return NULL;
97 }
98 }
99 }
100
101 arg = PerlIOArg;
102 if(arg && SvOK(arg)){
103 if(!PerlIO_push(aTHX_ f, self, mode, arg)){
104 PerlIO_close(f);
105 return NULL;
106 }
107 }
108
109 return f;
110 }
111
112
113 static SV*
parse_fname(pTHX_ SV * const arg,const char ** const mode)114 parse_fname(pTHX_ SV* const arg, const char** const mode){
115 STRLEN len;
116 const char* pv = SvPV_const(arg, len);
117
118 switch (*pv){
119 case '>':
120 pv++;
121 len--;
122 if(*pv == '>'){ /* ">> file" */
123 pv++;
124 len--;
125 *mode = "a";
126 }
127 else{ /* "> file" */
128 *mode = "w";
129 }
130 while(isSPACE(*pv)){
131 pv++;
132 len--;
133 }
134 break;
135
136 case '+':
137 case '<':
138 case '|':
139 return NULL;
140 default:
141 /* noop */;
142 }
143 return newSVpvn(pv, len);
144 }
145
146 static IO*
sv_2io_or_null(pTHX_ SV * sv)147 sv_2io_or_null(pTHX_ SV* sv){
148 if(SvROK(sv)) sv = SvRV(sv);
149
150 switch(SvTYPE(sv)){
151 case SVt_PVGV:
152 return GvIO(sv);
153 case SVt_PVIO:
154 return (IO*)sv;
155 default:
156 NOOP;
157 }
158 return NULL;
159 }
160
161 static IV
PerlIOTee_pushed(pTHX_ PerlIO * const f,const char * mode,SV * const arg,PerlIO_funcs * const tab)162 PerlIOTee_pushed(pTHX_ PerlIO* const f, const char* mode, SV* const arg, PerlIO_funcs* const tab){
163 PerlIO* nx;
164 IO* io;
165 PerlIOTee* const proto = (mode && !arg) ? (PerlIOTee*)(mode) : NULL; /* dup */
166
167 PERL_UNUSED_ARG(tab);
168
169 if(!(PerlIOValid(f) && (nx = PerlIONext(f)) && PerlIOValid(nx))){
170 SETERRNO(EBADF, SS_IVCHAN);
171 return -1;
172 }
173
174
175 if(!IOLflag(nx, PERLIO_F_CANWRITE)) goto cannot_tee;
176
177 if(arg && !SvOK(arg)){
178 SETERRNO(EINVAL, LIB_INVARG);
179 return -1;
180 }
181
182 if(proto){ /* dup */
183 TeeOut(f) = proto->out;
184 TeeArg(f) = proto->arg;
185 }
186 else if((io = sv_2io_or_null(aTHX_ arg))){ /* pushed \*FILEHANDLE */
187 if(!( IoOFP(io) && IOLflag(IoOFP(io), PERLIO_F_CANWRITE) )){
188 cannot_tee:
189 SETERRNO(EBADF, SS_IVCHAN);
190 return -1;
191 }
192
193 TeeArg(f) = SvREFCNT_inc_simple_NN( arg );
194 TeeOut(f) = IoOFP(io);
195 }
196 else{
197 PerlIO_list_t* const layers = PL_def_layerlist;
198 PerlIO_funcs* tab = NULL;
199
200 TAINT_IF(SvTAINTED(arg));
201 TAINT_PROPER(":tee");
202
203 if(SvPOK(arg) && SvCUR(arg) > 1){
204 TeeArg(f) = parse_fname(aTHX_ arg, &mode);
205 if(!TeeArg(f)){
206 SETERRNO(EINVAL, LIB_INVARG);
207 return -1;
208 }
209 }
210 else{
211 TeeArg(f) = newSVsv(arg);
212 }
213
214 if( SvROK(TeeArg(f)) ){
215 tab = PerlIO_layer_from_ref(aTHX_ SvRV(TeeArg(f)));
216 }
217
218 if(!mode){
219 mode = "w";
220 }
221
222 TeeOut(f) = PerlIOUtil_openn(aTHX_ tab, layers,
223 layers->cur, mode, -1, 0, 0, NULL, 1, &(TeeArg(f)));
224
225 /*dump_perlio(aTHX_ TeeOut(f), 0);*/
226 }
227 if(!PerlIOValid(TeeOut(f))){
228 return -1; /* failure */
229 }
230
231 PerlIOBase(f)->flags = PerlIOBase(nx)->flags;
232
233 IOLflag_on(TeeOut(f),
234 PerlIOBase(f)->flags & (PERLIO_F_UTF8 | PERLIO_F_LINEBUF | PERLIO_F_UNBUF));
235
236 return 0;
237 }
238
239 static IV
PerlIOTee_popped(pTHX_ PerlIO * const f)240 PerlIOTee_popped(pTHX_ PerlIO* const f){
241 #if 0
242 printf("#popped:%s(my_perl=%p, f=%p) arg=%p(%d), out=%p\n",
243 PerlIOBase(f)->tab->name, my_perl, f,
244 TeeArg(f), (TeeArg(f) ? (int)SvREFCNT(TeeArg(f)) : 0), TeeOut(f));
245 #endif
246
247 if(TeeArg(f)){
248 if(sv_2io_or_null(aTHX_ TeeArg(f)) == NULL){
249 PerlIO_close(TeeOut(f));
250 }
251 if(SvREFCNT(TeeArg(f)) > 0) /* for 5.8.8 */
252 SvREFCNT_dec(TeeArg(f));
253
254 }
255 else if(TeeOut(f)){ /* dup()-ed fp */
256 PerlIO_close(TeeOut(f));
257 }
258 return 0;
259 }
260
261 static IV
PerlIOTee_binmode(pTHX_ PerlIO * const f)262 PerlIOTee_binmode(pTHX_ PerlIO* const f){
263 if(!PerlIOValid(f)){
264 return -1;
265 }
266
267 PerlIOBase_binmode(aTHX_ f); /* remove PERLIO_F_UTF8 */
268
269 PerlIO_binmode(aTHX_ PerlIONext(f), '>', O_BINARY, NULL);
270
271 /* warn("Tee_binmode %s", PerlIOBase(f)->tab->name); */
272 /* there is a case where an unknown layer is supplied */
273 if( PerlIOBase(f)->tab != &PerlIO_tee ){
274 #if 0 /* May, 2008 */
275 PerlIO* t = PerlIONext(f);
276 int n = 0;
277 int ok = 0;
278
279 while(PerlIOValid(t)){
280 if(PerlIOBase(t)->tab == &PerlIO_tee){
281 n++;
282 if(PerlIO_binmode(aTHX_ TeeOut(t), '>'/*not used*/,
283 O_BINARY, NULL)){
284 ok++;
285 }
286 }
287
288 t = PerlIONext(t);
289 }
290 return n == ok ? 0 : -1;
291 #endif
292 return 0;
293 }
294
295 return PerlIO_binmode(aTHX_ TeeOut(f), '>'/*not used*/,
296 O_BINARY, NULL) ? 0 : -1;
297 }
298
299 static SV*
PerlIOTee_getarg(pTHX_ PerlIO * const f,CLONE_PARAMS * const param,int const flags)300 PerlIOTee_getarg(pTHX_ PerlIO* const f, CLONE_PARAMS* const param, int const flags){
301 PERL_UNUSED_ARG(flags);
302
303 return PerlIO_sv_dup(aTHX_ TeeArg(f), param);
304 }
305
306 static PerlIO*
PerlIOTee_dup(pTHX_ PerlIO * f,PerlIO * const o,CLONE_PARAMS * const param,int const flags)307 PerlIOTee_dup(pTHX_ PerlIO* f, PerlIO* const o, CLONE_PARAMS* const param, int const flags){
308 #if 0
309 printf("#dup:%s (my_perl=%p, f=%p, o=%p, {proto_perl=%p,flags=0x%x}, flags=%d)\n",
310 PerlIOBase(o)->tab->name, my_perl, f, o, param->proto_perl,
311 (unsigned)param->flags, flags);
312 #endif
313
314 f = PerlIO_dup(aTHX_ f, PerlIONext(o), param, flags);
315
316 if(f){
317 PerlIOTee proto;
318 #if 0
319 IO* io;
320 proto.arg = PerlIOTee_getarg(aTHX_ o, param, flags);
321 if((io = sv_2io_or_null(aTHX_ proto.arg))){
322 proto.out = IoOFP(io);
323 }
324 else{
325 proto.out = PerlIO_fdupopen(aTHX_ TeeOut(o), param, flags);
326 }
327 #else
328 if(!SvROK(TeeArg(o))){
329 proto.arg = PerlIO_sv_dup(aTHX_ TeeArg(o), param);
330 //SvREFCNT_inc_simple_void_NN(proto.arg);
331 }
332 else{
333 proto.arg = NULL;
334 }
335
336 proto.out = PerlIO_dup(aTHX_ NULL, TeeOut(o), param, flags);
337 #endif
338
339 #if 0
340 printf("# newarg=%p(%d), oldarg=%p(%d)\n",
341 proto.arg, (int)(proto.arg ? SvREFCNT(proto.arg) : 0),
342 TeeArg(o), (int)(TeeArg(o) ? SvREFCNT(TeeArg(o)) : 0) );
343 #endif
344 f = PerlIO_push(aTHX_ f, PerlIOBase(o)->tab, (const char*)&proto, NULL);
345 }
346
347 return f;
348 }
349
350 static SSize_t
PerlIOTee_write(pTHX_ PerlIO * const f,const void * const vbuf,Size_t const count)351 PerlIOTee_write(pTHX_ PerlIO* const f, const void* const vbuf, Size_t const count){
352 if(PerlIO_write(TeeOut(f), vbuf, count) != (SSize_t)count){
353 PerlIOUtil_warnif(aTHX_ packWARN(WARN_IO), "Failed to write to tee-out");
354 }
355
356 return PerlIO_write(PerlIONext(f), vbuf, count);
357 }
358
359 static IV
PerlIOTee_flush(pTHX_ PerlIO * const f)360 PerlIOTee_flush(pTHX_ PerlIO* const f){
361 if(TeeOut(f) && PerlIO_flush(TeeOut(f)) != 0){
362 PerlIOUtil_warnif(aTHX_ packWARN(WARN_IO), "Failed to flush tee-out");
363 }
364
365 return PerlIO_flush(PerlIONext(f));
366 }
367
368 static IV
PerlIOTee_seek(pTHX_ PerlIO * const f,Off_t const offset,int const whence)369 PerlIOTee_seek(pTHX_ PerlIO* const f, Off_t const offset, int const whence){
370 if(PerlIO_seek(TeeOut(f), offset, whence) != 0){
371 PerlIOUtil_warnif(aTHX_ packWARN(WARN_IO), "Failed to seek tee-out");
372 }
373
374 return PerlIO_seek(PerlIONext(f), offset, whence);
375 }
376
377 static Off_t
PerlIOTee_tell(pTHX_ PerlIO * const f)378 PerlIOTee_tell(pTHX_ PerlIO* const f){
379 PerlIO* const nx = PerlIONext(f);
380
381 return PerlIO_tell(nx);
382 }
383
384 PerlIO*
PerlIOTee_teeout(pTHX_ const PerlIO * const f)385 PerlIOTee_teeout(pTHX_ const PerlIO* const f){
386 return PerlIOValid(f) ? TeeOut(f) : NULL;
387 }
388
389
390 PERLIO_FUNCS_DECL(PerlIO_tee) = {
391 sizeof(PerlIO_funcs),
392 "tee",
393 sizeof(PerlIOTee),
394 PERLIO_K_BUFFERED | PERLIO_K_RAW | PERLIO_K_MULTIARG,
395 PerlIOTee_pushed,
396 PerlIOTee_popped,
397 PerlIOTee_open,
398 PerlIOTee_binmode,
399 PerlIOTee_getarg,
400 NULL, /* fileno */
401 PerlIOTee_dup,
402 NULL, /* read */
403 NULL, /* unread */
404 PerlIOTee_write,
405 PerlIOTee_seek,
406 PerlIOTee_tell,
407 NULL, /* close */
408 PerlIOTee_flush,
409 NULL, /* fill */
410 NULL, /* eof */
411 NULL, /* error */
412 NULL, /* clearerror */
413 NULL, /* setlinebuf */
414 NULL, /* get_base */
415 NULL, /* bufsiz */
416 NULL, /* get_ptr */
417 NULL, /* get_cnt */
418 NULL, /* set_ptrcnt */
419 };
420
421
422