1 /*
2 * Filename : Call.xs
3 *
4 * Author : Paul Marquess
5 * Date : 2014-12-09 02:48:44 rurban
6 * Version : 1.60
7 *
8 * Copyright (c) 1995-2011 Paul Marquess. All rights reserved.
9 * Copyright (c) 2011-2014 Reini Urban. All rights reserved.
10 * This program is free software; you can redistribute it and/or
11 * modify it under the same terms as Perl itself.
12 *
13 */
14
15 #define PERL_NO_GET_CONTEXT
16 #include "EXTERN.h"
17 #include "perl.h"
18 #include "XSUB.h"
19 #ifdef _NOT_CORE
20 # include "ppport.h"
21 #endif
22
23 /* Internal defines */
24 #define PERL_MODULE(s) IoBOTTOM_NAME(s)
25 #define PERL_OBJECT(s) IoTOP_GV(s)
26 #define FILTER_ACTIVE(s) IoLINES(s)
27 #define BUF_OFFSET(sv) IoPAGE_LEN(sv)
28 #define CODE_REF(sv) IoPAGE(sv)
29 #ifndef PERL_FILTER_EXISTS
30 # define PERL_FILTER_EXISTS(i) (PL_rsfp_filters && (i) <= av_len(PL_rsfp_filters))
31 #endif
32
33 #define SET_LEN(sv,len) \
34 do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0)
35
36
37 /* Global Data */
38
39 #define MY_CXT_KEY "Filter::Util::Call::_guts" XS_VERSION
40
41 typedef struct {
42 int x_fdebug ;
43 int x_current_idx ;
44 } my_cxt_t;
45
46 START_MY_CXT
47
48 #define fdebug (MY_CXT.x_fdebug)
49 #define current_idx (MY_CXT.x_current_idx)
50
51
52 static I32
filter_call(pTHX_ int idx,SV * buf_sv,int maxlen)53 filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
54 {
55 dMY_CXT;
56 SV *my_sv = FILTER_DATA(idx);
57 const char *nl = "\n";
58 char *p;
59 char *out_ptr;
60 int n;
61
62 if (fdebug)
63 warn("**** In filter_call - maxlen = %d, out len buf = %" IVdf " idx = %d my_sv = %" IVdf " [%s]\n",
64 maxlen, (IV)SvCUR(buf_sv), idx, (IV)SvCUR(my_sv), SvPVX(my_sv) ) ;
65
66 while (1) {
67
68 /* anything left from last time */
69
70 if ((n = SvCUR(my_sv))) {
71 assert(SvCUR(my_sv) < PERL_INT_MAX) ;
72
73 out_ptr = SvPVX(my_sv) + BUF_OFFSET(my_sv) ;
74
75 if (maxlen) {
76 /* want a block */
77 if (fdebug)
78 warn("BLOCK(%d): size = %d, maxlen = %d\n",
79 idx, n, maxlen) ;
80
81 sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen );
82 if(n <= maxlen) {
83 BUF_OFFSET(my_sv) = 0 ;
84 SET_LEN(my_sv, 0) ;
85 }
86 else {
87 BUF_OFFSET(my_sv) += maxlen ;
88 SvCUR_set(my_sv, n - maxlen) ;
89 }
90 return SvCUR(buf_sv);
91 }
92 else {
93 /* want lines */
94 if ((p = ninstr(out_ptr, out_ptr + n, nl, nl + 1))) {
95
96 sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1);
97
98 n = n - (p - out_ptr + 1);
99 BUF_OFFSET(my_sv) += (p - out_ptr + 1);
100 SvCUR_set(my_sv, n) ;
101 if (fdebug)
102 warn("recycle %d - leaving %d, returning %" IVdf " [%s]",
103 idx, n, (IV)SvCUR(buf_sv), SvPVX(buf_sv)) ;
104
105 return SvCUR(buf_sv);
106 }
107 else /* no EOL, so append the complete buffer */
108 sv_catpvn(buf_sv, out_ptr, n) ;
109 }
110
111 }
112
113
114 SET_LEN(my_sv, 0) ;
115 BUF_OFFSET(my_sv) = 0 ;
116
117 if (FILTER_ACTIVE(my_sv))
118 {
119 dSP ;
120 int count ;
121
122 if (fdebug)
123 warn("gonna call %s::filter\n", PERL_MODULE(my_sv)) ;
124
125 ENTER ;
126 SAVETMPS;
127
128 SAVEINT(current_idx) ; /* save current idx */
129 current_idx = idx ;
130
131 SAVE_DEFSV ; /* save $_ */
132 /* make $_ use our buffer */
133 DEFSV_set(newSVpv("", 0)) ;
134
135 PUSHMARK(sp) ;
136 if (CODE_REF(my_sv)) {
137 /* if (SvROK(PERL_OBJECT(my_sv)) && SvTYPE(SvRV(PERL_OBJECT(my_sv))) == SVt_PVCV) { */
138 count = perl_call_sv((SV*)PERL_OBJECT(my_sv), G_SCALAR);
139 }
140 else {
141 XPUSHs((SV*)PERL_OBJECT(my_sv)) ;
142 PUTBACK ;
143 count = perl_call_method("filter", G_SCALAR);
144 }
145 SPAGAIN ;
146
147 if (count != 1)
148 croak("Filter::Util::Call - %s::filter returned %d values, 1 was expected \n",
149 PERL_MODULE(my_sv), count ) ;
150
151 n = (IV)POPi ;
152
153 if (fdebug)
154 warn("status = %d, length op buf = %" IVdf " [%s]\n",
155 n, (IV)SvCUR(DEFSV), SvPVX(DEFSV) ) ;
156 if (SvCUR(DEFSV))
157 sv_setpvn(my_sv, SvPVX(DEFSV), SvCUR(DEFSV)) ;
158
159 sv_2mortal(DEFSV);
160
161 PUTBACK ;
162 FREETMPS ;
163 LEAVE ;
164 }
165 else
166 n = FILTER_READ(idx + 1, my_sv, maxlen) ;
167
168 if (n <= 0)
169 {
170 /* Either EOF or an error */
171
172 if (fdebug)
173 warn ("filter_read %d returned %d , returning %" IVdf "\n", idx, n,
174 (SvCUR(buf_sv)>0) ? (IV)SvCUR(buf_sv) : (IV)n);
175
176 /* PERL_MODULE(my_sv) ; */
177 /* PERL_OBJECT(my_sv) ; */
178 filter_del(filter_call);
179
180 /* If error, return the code */
181 if (n < 0)
182 return n ;
183
184 /* return what we have so far else signal eof */
185 return (SvCUR(buf_sv)>0) ? (int)SvCUR(buf_sv) : n;
186 }
187
188 }
189 }
190
191
192
193 MODULE = Filter::Util::Call PACKAGE = Filter::Util::Call
194
195 REQUIRE: 1.924
196 PROTOTYPES: ENABLE
197
198 #define IDX current_idx
199
200 int
201 filter_read(size=0)
202 int size
203 CODE:
204 {
205 dMY_CXT;
206 SV * buffer = DEFSV ;
207
208 RETVAL = FILTER_READ(IDX + 1, buffer, size) ;
209 }
210 OUTPUT:
211 RETVAL
212
213
214
215
216 void
real_import(object,perlmodule,coderef)217 real_import(object, perlmodule, coderef)
218 SV * object
219 char * perlmodule
220 IV coderef
221 PPCODE:
222 {
223 SV * sv = newSV(1) ;
224
225 (void)SvPOK_only(sv) ;
226 filter_add(filter_call, sv) ;
227
228 PERL_MODULE(sv) = savepv(perlmodule) ;
229 PERL_OBJECT(sv) = (GV*) newSVsv(object) ;
230 FILTER_ACTIVE(sv) = TRUE ;
231 BUF_OFFSET(sv) = 0 ;
232 CODE_REF(sv) = coderef ;
233
234 SvCUR_set(sv, 0) ;
235
236 }
237
238 void
239 filter_del()
240 CODE:
241 dMY_CXT;
242 if (PERL_FILTER_EXISTS(IDX) && FILTER_DATA(IDX) && FILTER_ACTIVE(FILTER_DATA(IDX)))
243 FILTER_ACTIVE(FILTER_DATA(IDX)) = FALSE ;
244
245
246
247 void
248 unimport(package="$Package", ...)
249 const char *package
250 PPCODE:
251 PERL_UNUSED_VAR(package);
252 filter_del(filter_call);
253
254
255 BOOT:
256 {
257 MY_CXT_INIT;
258 #ifdef FDEBUG
259 fdebug = 1;
260 #else
261 fdebug = 0;
262 #endif
263 /* temporary hack to control debugging in toke.c */
264 if (fdebug)
265 filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0");
266 }
267
268