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