File Coverage

cpan/Filter-Util-Call/Call.xs
Criterion Covered Total %
statement 62 84 73.8
branch n/a
condition n/a
subroutine n/a
total 62 84 73.8


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