1 /*
2 PerlIO-Util/Util.xs
3 */
4
5 #include "perlioutil.h"
6
7 #ifndef gv_stashpvs
8 #define gv_stashpvs(s, c) gv_stashpvn(s "", sizeof(s)-1, c)
9 #endif
10
11 PerlIO*
PerlIOUtil_openn(pTHX_ PerlIO_funcs * const force_tab,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)12 PerlIOUtil_openn(pTHX_ PerlIO_funcs* const force_tab, PerlIO_list_t* const layers, IV const n,
13 const char* const mode, int const fd, int const imode, int const perm,
14 PerlIO* f, int const narg, SV** const args){
15 PerlIO_funcs* tab = NULL;
16 IV i = n;
17
18 while(--i >= 0){ /* find a layer with Open() */
19 tab = LayerFetch(layers, i);
20 if(tab && tab->Open){
21 break;
22 }
23 }
24
25 if(force_tab) tab = force_tab;
26
27 if(tab && tab->Open){
28 f = tab->Open(aTHX_ tab, layers, i, mode,
29 fd, imode, perm, f, narg, args);
30
31 /* apply 'upper' layers
32 e.g. [ :unix :perlio :utf8 :creat ]
33 ~~~~~
34 */
35
36 if(f && ++i < n){
37 if(PerlIO_apply_layera(aTHX_ f, mode, layers, i, n) != 0){
38 PerlIO_close(f);
39 f = NULL;
40 }
41 }
42
43 }
44 else{
45 SETERRNO(EINVAL, LIB_INVARG);
46 }
47
48 return f;
49 }
50
51 #define PutFlag(c) do{\
52 if(PerlIOBase(f)->flags & (PERLIO_F_##c)){\
53 sv_catpvs(sv, " " #c);\
54 }\
55 }while(0)
56
57 SV*
PerlIOUtil_inspect(pTHX_ PerlIO * f,int const level)58 PerlIOUtil_inspect(pTHX_ PerlIO* f, int const level){
59 int i;
60 SV* const sv = newSVpvs(" ");
61
62 for(i = 0; i < level; i++) sv_catpvs(sv, " ");
63
64 sv_catpvf(sv, "PerlIO 0x%p\n", f);
65
66 if(!PerlIOValid(f)){
67 for(i = 0; i <= level; i++) sv_catpvs(sv, " ");
68
69 sv_catpvs(sv, "(Invalid filehandle)\n");
70 }
71
72 while(PerlIOValid(f)){
73 for(i = 0; i <= level; i++) sv_catpv(sv, " ");
74
75 sv_catpvf(sv, "0x%p:%s(%d)",
76 *f, PerlIOBase(f)->tab->name,
77 (int)PerlIO_fileno(f));
78 PutFlag(EOF);
79 PutFlag(CANWRITE);
80 PutFlag(CANREAD);
81 PutFlag(ERROR);
82 PutFlag(TRUNCATE);
83 PutFlag(APPEND);
84 PutFlag(CRLF);
85 PutFlag(UTF8);
86 PutFlag(UNBUF);
87
88 PutFlag(WRBUF);
89 if(IOLflag(f, PERLIO_F_WRBUF)){
90 sv_catpvf(sv, "(%" IVdf "/%" IVdf ")",
91 (IV)PerlIO_get_cnt(f),
92 (IV)PerlIO_get_bufsiz(f));
93 }
94 PutFlag(RDBUF);
95 if(IOLflag(f, PERLIO_F_RDBUF)){
96 sv_catpvf(sv, "(%" IVdf "/%" IVdf ")",
97 (IV)PerlIO_get_cnt(f),
98 (IV)PerlIO_get_bufsiz(f));
99 }
100
101 PutFlag(LINEBUF);
102 PutFlag(TEMP);
103 PutFlag(OPEN);
104 PutFlag(FASTGETS);
105 PutFlag(TTY);
106 PutFlag(NOTREG);
107 sv_catpvs(sv, "\n");
108
109 if( strEQ(PerlIOBase(f)->tab->name, "tee") ){
110 PerlIO* const teeout = PerlIOTee_teeout(aTHX_ f);
111 SV* const t = PerlIOUtil_inspect(aTHX_ teeout, level+1);
112
113 sv_catsv(sv, t);
114 SvREFCNT_dec(t);
115 }
116
117 f = PerlIONext(f);
118 }
119
120 return sv;
121 }
122
123 void
PerlIOUtil_warnif(pTHX_ U32 const category,const char * const fmt,...)124 PerlIOUtil_warnif(pTHX_ U32 const category, const char* const fmt, ...){
125 if(ckWARN(category)){
126 va_list args;
127 va_start(args, fmt);
128 vwarner(category, fmt, &args);
129 va_end(args);
130 }
131 }
132
133 MODULE = PerlIO::Util PACKAGE = PerlIO::Util
134
135 PROTOTYPES: DISABLE
136
137 BOOT:
138 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_flock));
139 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_creat));
140 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_excl));
141 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_tee));
142 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_dir));
143 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_reverse));
144
145 void
146 known_layers(...)
147 PREINIT:
148 const PerlIO_list_t* const layers = PL_known_layers;
149 int i;
150 PPCODE:
151 EXTEND(SP, layers->cur);
152 for(i = 0; i < layers->cur; i++){
153 SV* const name = newSVpv( LayerFetch(layers, i)->name, 0);
154 PUSHs( sv_2mortal(name) );
155 }
156 XSRETURN(layers->cur);
157
158 SV*
159 _gensym_ref(SV* pkg, SV* name)
160 PREINIT:
161 STRLEN len;
162 const char* pv;
163 GV* const gv = (GV*)newSV(0);
164 CODE:
165 pv = SvPV_const(name, len);
166 /* see also pp_rv2gv() in pp.c */
167 gv_init(gv, gv_stashsv(pkg, TRUE), pv, len, GV_ADD);
168 RETVAL = newRV_noinc((SV*)gv);
169
170 sv_bless(RETVAL, gv_stashpvs("IO::Handle", TRUE));
171 OUTPUT:
172 RETVAL
173
174
175 MODULE = PerlIO::Util PACKAGE = IO::Handle
176
177
178 #define undef (&PL_sv_undef)
179
180 void
181 push_layer(filehandle, layer, arg = undef)
182 PerlIO* filehandle
183 SV* layer
184 SV* arg
185 PREINIT:
186 PerlIO_funcs* tab;
187 const char* laypv;
188 STRLEN laylen;
189 PPCODE:
190 laypv = SvPV_const(layer, laylen);
191 if(laypv[0] == ':'){ /* ignore a layer prefix */
192 laypv++;
193 laylen--;
194 }
195 tab = PerlIO_find_layer(aTHX_ laypv, laylen, TRUE);
196 if(tab){
197 if(!PerlIO_push(aTHX_ filehandle, tab, NULL, arg)){
198 Perl_croak(aTHX_ "push_layer() failed: %s",
199 PerlIOValid(filehandle)
200 ? Strerror(errno)
201 : "Invalid filehandle");
202 }
203 }
204 else{
205 Perl_croak(aTHX_ "Unknown PerlIO layer \"%.*s\"",
206 (int)laylen, laypv);
207 }
208 XSRETURN(1); /* returns self */
209
210 void
211 pop_layer(filehandle)
212 PerlIO* filehandle
213 PREINIT:
214 const char* popped_layer;
215 PPCODE:
216 if(!PerlIOValid(filehandle)) XSRETURN_EMPTY;
217 popped_layer = PerlIOBase(filehandle)->tab->name;
218
219 PerlIO_flush(filehandle);
220 PerlIO_pop(aTHX_ filehandle);
221
222 if(GIMME_V != G_VOID){
223 XSRETURN_PV(popped_layer);
224 }
225
226 MODULE = PerlIO::Util PACKAGE = IO::Handle PREFIX = perlio_
227
228
229 SV*
230 perlio_inspect(f)
231 PerlIO* f
232