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