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