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