This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ext/ + -Wall
[perl5.git] / ext / Filter / Util / Call / Call.xs
CommitLineData
2c4bb738
JH
1/*
2 * Filename : Call.xs
3 *
4 * Author : Paul Marquess
5 * Date : 26th March 2000
6 * Version : 1.05
7 *
6ea26ce9
JH
8 * Copyright (c) 1995-2001 Paul Marquess. All rights reserved.
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"
18
19#ifndef PERL_VERSION
20# include "patchlevel.h"
21# define PERL_REVISION 5
22# define PERL_VERSION PATCHLEVEL
23# define PERL_SUBVERSION SUBVERSION
24#endif
25
26/* defgv must be accessed differently under threaded perl */
27/* DEFSV et al are in 5.004_56 */
28#ifndef DEFSV
29# define DEFSV GvSV(defgv)
30#endif
31
32#ifndef pTHX
33# define pTHX
34# define pTHX_
35# define aTHX
36# define aTHX_
37#endif
38
39
40/* Internal defines */
41#define PERL_MODULE(s) IoBOTTOM_NAME(s)
42#define PERL_OBJECT(s) IoTOP_GV(s)
43#define FILTER_ACTIVE(s) IoLINES(s)
44#define BUF_OFFSET(sv) IoPAGE_LEN(sv)
45#define CODE_REF(sv) IoPAGE(sv)
46
47#define SET_LEN(sv,len) \
48 do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0)
49
50
51
52static int fdebug = 0;
53static int current_idx ;
54
55static I32
56filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
57{
58 SV *my_sv = FILTER_DATA(idx);
59 char *nl = "\n";
60 char *p;
61 char *out_ptr;
62 int n;
63
64 if (fdebug)
65 warn("**** In filter_call - maxlen = %d, out len buf = %d idx = %d my_sv = %d [%s]\n",
66 maxlen, SvCUR(buf_sv), idx, SvCUR(my_sv), SvPVX(my_sv) ) ;
67
68 while (1) {
69
70 /* anything left from last time */
8063af02 71 if ((n = SvCUR(my_sv))) {
2c4bb738
JH
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 */
8063af02 94 if ((p = ninstr(out_ptr, out_ptr + n - 1, nl, nl))) {
2c4bb738
JH
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 %d [%s]",
103 idx, n, 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 SAVESPTR(DEFSV) ; /* save $_ */
132 /* make $_ use our buffer */
133 DEFSV = sv_2mortal(newSVpv("", 0)) ;
134
135 PUSHMARK(sp) ;
136
137 if (CODE_REF(my_sv)) {
138 /* if (SvROK(PERL_OBJECT(my_sv)) && SvTYPE(SvRV(PERL_OBJECT(my_sv))) == SVt_PVCV) { */
139 count = perl_call_sv((SV*)PERL_OBJECT(my_sv), G_SCALAR);
140 }
141 else {
142 XPUSHs((SV*)PERL_OBJECT(my_sv)) ;
143
144 PUTBACK ;
145
146 count = perl_call_method("filter", G_SCALAR);
147 }
148
149 SPAGAIN ;
150
151 if (count != 1)
152 croak("Filter::Util::Call - %s::filter returned %d values, 1 was expected \n",
153 PERL_MODULE(my_sv), count ) ;
154
155 n = POPi ;
156
157 if (fdebug)
158 warn("status = %d, length op buf = %d [%s]\n",
159 n, SvCUR(DEFSV), SvPVX(DEFSV) ) ;
160 if (SvCUR(DEFSV))
161 sv_setpvn(my_sv, SvPVX(DEFSV), SvCUR(DEFSV)) ;
162
163 PUTBACK ;
164 FREETMPS ;
165 LEAVE ;
166 }
167 else
168 n = FILTER_READ(idx + 1, my_sv, maxlen) ;
169
170 if (n <= 0)
171 {
172 /* Either EOF or an error */
173
174 if (fdebug)
175 warn ("filter_read %d returned %d , returning %d\n", idx, n,
176 (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n);
177
178 /* PERL_MODULE(my_sv) ; */
179 /* PERL_OBJECT(my_sv) ; */
180 filter_del(filter_call);
181
182 /* If error, return the code */
183 if (n < 0)
184 return n ;
185
186 /* return what we have so far else signal eof */
187 return (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n;
188 }
189
190 }
191}
192
193
194
195MODULE = Filter::Util::Call PACKAGE = Filter::Util::Call
196
197REQUIRE: 1.924
198PROTOTYPES: ENABLE
199
200#define IDX current_idx
201
202int
203filter_read(size=0)
204 int size
205 CODE:
206 {
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:
242 FILTER_ACTIVE(FILTER_DATA(IDX)) = FALSE ;
243
244
245
246void
c6c619a9
DM
247unimport(package="$Package", ...)
248 char *package
2c4bb738
JH
249 PPCODE:
250 filter_del(filter_call);
251
252
253BOOT:
254 /* temporary hack to control debugging in toke.c */
255 if (fdebug)
256 filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0");
257
258