Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

422 lines (346 sloc) 9.181 kb
/*
:tee - write to files.
Usage: open(my $out, '>>:tee', \*STDOUT, \*SOCKET, $file, \$scalar)
$out->push_layer(tee => $another);
*/
#include "perlioutil.h"
#define TeeOut(f) (PerlIOSelf(f, PerlIOTee)->out)
#define TeeArg(f) (PerlIOSelf(f, PerlIOTee)->arg)
/* copied from perlio.c */
static PerlIO_funcs *
PerlIO_layer_from_ref(pTHX_ SV* const sv)
{
dVAR;
/*
* For any scalar type load the handler which is bundled with perl
*/
if (SvTYPE(sv) < SVt_PVAV) {
PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1);
/* This isn't supposed to happen, since PerlIO::scalar is core,
* but could happen anyway in smaller installs or with PAR */
if (!f)
PerlIOUtil_warnif(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\"");
return f;
}
/*
* For other types allow if layer is known but don't try and load it
*/
switch (SvTYPE(sv)) {
case SVt_PVAV:
return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Array"), 0);
case SVt_PVHV:
return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Hash"), 0);
case SVt_PVCV:
return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0);
case SVt_PVGV:
return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0);
default:
return NULL;
}
} /* PerlIO_layer_from_ref() */
static PerlIO*
PerlIO_dup(pTHX_ PerlIO* newfp, PerlIO* const oldfp, CLONE_PARAMS* const params, int const flags){
if(PerlIOValid(oldfp)){
PerlIO* (*my_dup)(pTHX_ PerlIO*, PerlIO*, CLONE_PARAMS*, int);
my_dup = PerlIOBase(oldfp)->tab->Dup;
if(!newfp) newfp = PerlIO_allocate(aTHX);
if(!my_dup) my_dup = PerlIOBase_dup;
return my_dup(aTHX_ newfp, oldfp, params, flags);
}
SETERRNO(EBADF, SS_IVCHAN);
return NULL;
}
typedef struct {
struct _PerlIO base; /* virtual table and flags */
SV* arg;
PerlIO* out;
} PerlIOTee;
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){
SV* arg;
if(!(PerlIOUnix_oflags(mode) & O_WRONLY)){ /* cannot open:tee for reading */
SETERRNO(EINVAL, LIB_INVARG);
return NULL;
}
f = PerlIOUtil_openn(aTHX_ NULL, layers, n, mode,
fd, imode, perm, f, 1, args);
if(!f){
return NULL;
}
if(narg > 1){
int i;
for(i = 1; i < narg; i++){
if(!PerlIO_push(aTHX_ f, self, mode, args[i])){
PerlIO_close(f);
return NULL;
}
}
}
arg = PerlIOArg;
if(arg && SvOK(arg)){
if(!PerlIO_push(aTHX_ f, self, mode, arg)){
PerlIO_close(f);
return NULL;
}
}
return f;
}
static SV*
parse_fname(pTHX_ SV* const arg, const char** const mode){
STRLEN len;
const char* pv = SvPV_const(arg, len);
switch (*pv){
case '>':
pv++;
len--;
if(*pv == '>'){ /* ">> file" */
pv++;
len--;
*mode = "a";
}
else{ /* "> file" */
*mode = "w";
}
while(isSPACE(*pv)){
pv++;
len--;
}
break;
case '+':
case '<':
case '|':
return NULL;
default:
/* noop */;
}
return newSVpvn(pv, len);
}
static IO*
sv_2io_or_null(pTHX_ SV* sv){
if(SvROK(sv)) sv = SvRV(sv);
switch(SvTYPE(sv)){
case SVt_PVGV:
return GvIO(sv);
case SVt_PVIO:
return (IO*)sv;
default:
NOOP;
}
return NULL;
}
static IV
PerlIOTee_pushed(pTHX_ PerlIO* const f, const char* mode, SV* const arg, PerlIO_funcs* const tab){
PerlIO* nx;
IO* io;
PerlIOTee* const proto = (mode && !arg) ? (PerlIOTee*)(mode) : NULL; /* dup */
PERL_UNUSED_ARG(tab);
if(!(PerlIOValid(f) && (nx = PerlIONext(f)) && PerlIOValid(nx))){
SETERRNO(EBADF, SS_IVCHAN);
return -1;
}
if(!IOLflag(nx, PERLIO_F_CANWRITE)) goto cannot_tee;
if(arg && !SvOK(arg)){
SETERRNO(EINVAL, LIB_INVARG);
return -1;
}
if(proto){ /* dup */
TeeOut(f) = proto->out;
TeeArg(f) = proto->arg;
}
else if((io = sv_2io_or_null(aTHX_ arg))){ /* pushed \*FILEHANDLE */
if(!( IoOFP(io) && IOLflag(IoOFP(io), PERLIO_F_CANWRITE) )){
cannot_tee:
SETERRNO(EBADF, SS_IVCHAN);
return -1;
}
TeeArg(f) = SvREFCNT_inc_simple_NN( arg );
TeeOut(f) = IoOFP(io);
}
else{
PerlIO_list_t* const layers = PL_def_layerlist;
PerlIO_funcs* tab = NULL;
TAINT_IF(SvTAINTED(arg));
TAINT_PROPER(":tee");
if(SvPOK(arg) && SvCUR(arg) > 1){
TeeArg(f) = parse_fname(aTHX_ arg, &mode);
if(!TeeArg(f)){
SETERRNO(EINVAL, LIB_INVARG);
return -1;
}
}
else{
TeeArg(f) = newSVsv(arg);
}
if( SvROK(TeeArg(f)) ){
tab = PerlIO_layer_from_ref(aTHX_ SvRV(TeeArg(f)));
}
if(!mode){
mode = "w";
}
TeeOut(f) = PerlIOUtil_openn(aTHX_ tab, layers,
layers->cur, mode, -1, 0, 0, NULL, 1, &(TeeArg(f)));
/*dump_perlio(aTHX_ TeeOut(f), 0);*/
}
if(!PerlIOValid(TeeOut(f))){
return -1; /* failure */
}
PerlIOBase(f)->flags = PerlIOBase(nx)->flags;
IOLflag_on(TeeOut(f),
PerlIOBase(f)->flags & (PERLIO_F_UTF8 | PERLIO_F_LINEBUF | PERLIO_F_UNBUF));
return 0;
}
static IV
PerlIOTee_popped(pTHX_ PerlIO* const f){
#if 0
printf("#popped:%s(my_perl=%p, f=%p) arg=%p(%d), out=%p\n",
PerlIOBase(f)->tab->name, my_perl, f,
TeeArg(f), (TeeArg(f) ? (int)SvREFCNT(TeeArg(f)) : 0), TeeOut(f));
#endif
if(TeeArg(f)){
if(sv_2io_or_null(aTHX_ TeeArg(f)) == NULL){
PerlIO_close(TeeOut(f));
}
if(SvREFCNT(TeeArg(f)) > 0) /* for 5.8.8 */
SvREFCNT_dec(TeeArg(f));
}
else if(TeeOut(f)){ /* dup()-ed fp */
PerlIO_close(TeeOut(f));
}
return 0;
}
static IV
PerlIOTee_binmode(pTHX_ PerlIO* const f){
if(!PerlIOValid(f)){
return -1;
}
PerlIOBase_binmode(aTHX_ f); /* remove PERLIO_F_UTF8 */
PerlIO_binmode(aTHX_ PerlIONext(f), '>', O_BINARY, NULL);
/* warn("Tee_binmode %s", PerlIOBase(f)->tab->name); */
/* there is a case where an unknown layer is supplied */
if( PerlIOBase(f)->tab != &PerlIO_tee ){
#if 0 /* May, 2008 */
PerlIO* t = PerlIONext(f);
int n = 0;
int ok = 0;
while(PerlIOValid(t)){
if(PerlIOBase(t)->tab == &PerlIO_tee){
n++;
if(PerlIO_binmode(aTHX_ TeeOut(t), '>'/*not used*/,
O_BINARY, NULL)){
ok++;
}
}
t = PerlIONext(t);
}
return n == ok ? 0 : -1;
#endif
return 0;
}
return PerlIO_binmode(aTHX_ TeeOut(f), '>'/*not used*/,
O_BINARY, NULL) ? 0 : -1;
}
static SV*
PerlIOTee_getarg(pTHX_ PerlIO* const f, CLONE_PARAMS* const param, int const flags){
PERL_UNUSED_ARG(flags);
return PerlIO_sv_dup(aTHX_ TeeArg(f), param);
}
static PerlIO*
PerlIOTee_dup(pTHX_ PerlIO* f, PerlIO* const o, CLONE_PARAMS* const param, int const flags){
#if 0
printf("#dup:%s (my_perl=%p, f=%p, o=%p, {proto_perl=%p,flags=0x%x}, flags=%d)\n",
PerlIOBase(o)->tab->name, my_perl, f, o, param->proto_perl,
(unsigned)param->flags, flags);
#endif
f = PerlIO_dup(aTHX_ f, PerlIONext(o), param, flags);
if(f){
PerlIOTee proto;
#if 0
IO* io;
proto.arg = PerlIOTee_getarg(aTHX_ o, param, flags);
if((io = sv_2io_or_null(aTHX_ proto.arg))){
proto.out = IoOFP(io);
}
else{
proto.out = PerlIO_fdupopen(aTHX_ TeeOut(o), param, flags);
}
#else
if(!SvROK(TeeArg(o))){
proto.arg = PerlIO_sv_dup(aTHX_ TeeArg(o), param);
//SvREFCNT_inc_simple_void_NN(proto.arg);
}
else{
proto.arg = NULL;
}
proto.out = PerlIO_dup(aTHX_ NULL, TeeOut(o), param, flags);
#endif
#if 0
printf("# newarg=%p(%d), oldarg=%p(%d)\n",
proto.arg, (int)(proto.arg ? SvREFCNT(proto.arg) : 0),
TeeArg(o), (int)(TeeArg(o) ? SvREFCNT(TeeArg(o)) : 0) );
#endif
f = PerlIO_push(aTHX_ f, PerlIOBase(o)->tab, (const char*)&proto, NULL);
}
return f;
}
static SSize_t
PerlIOTee_write(pTHX_ PerlIO* const f, const void* const vbuf, Size_t const count){
if(PerlIO_write(TeeOut(f), vbuf, count) != (SSize_t)count){
PerlIOUtil_warnif(aTHX_ packWARN(WARN_IO), "Failed to write to tee-out");
}
return PerlIO_write(PerlIONext(f), vbuf, count);
}
static IV
PerlIOTee_flush(pTHX_ PerlIO* const f){
if(TeeOut(f) && PerlIO_flush(TeeOut(f)) != 0){
PerlIOUtil_warnif(aTHX_ packWARN(WARN_IO), "Failed to flush tee-out");
}
return PerlIO_flush(PerlIONext(f));
}
static IV
PerlIOTee_seek(pTHX_ PerlIO* const f, Off_t const offset, int const whence){
if(PerlIO_seek(TeeOut(f), offset, whence) != 0){
PerlIOUtil_warnif(aTHX_ packWARN(WARN_IO), "Failed to seek tee-out");
}
return PerlIO_seek(PerlIONext(f), offset, whence);
}
static Off_t
PerlIOTee_tell(pTHX_ PerlIO* const f){
PerlIO* const nx = PerlIONext(f);
return PerlIO_tell(nx);
}
PerlIO*
PerlIOTee_teeout(pTHX_ const PerlIO* const f){
return PerlIOValid(f) ? TeeOut(f) : NULL;
}
PERLIO_FUNCS_DECL(PerlIO_tee) = {
sizeof(PerlIO_funcs),
"tee",
sizeof(PerlIOTee),
PERLIO_K_BUFFERED | PERLIO_K_RAW | PERLIO_K_MULTIARG,
PerlIOTee_pushed,
PerlIOTee_popped,
PerlIOTee_open,
PerlIOTee_binmode,
PerlIOTee_getarg,
NULL, /* fileno */
PerlIOTee_dup,
NULL, /* read */
NULL, /* unread */
PerlIOTee_write,
PerlIOTee_seek,
PerlIOTee_tell,
NULL, /* close */
PerlIOTee_flush,
NULL, /* fill */
NULL, /* eof */
NULL, /* error */
NULL, /* clearerror */
NULL, /* setlinebuf */
NULL, /* get_base */
NULL, /* bufsiz */
NULL, /* get_ptr */
NULL, /* get_cnt */
NULL, /* set_ptrcnt */
};
Jump to Line
Something went wrong with that request. Please try again.