This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fd79c577a2e6aa2b56ffcbdc567109ee521755a0
[perl5.git] / cpan / Filter-Util-Call / Call.xs
1 /* 
2  * Filename : Call.xs
3  * 
4  * Author   : Paul Marquess 
5  * Date     : 2014-12-09 02:48:44 rurban
6  * Version  : 1.54
7  *
8  *    Copyright (c) 1995-2011 Paul Marquess. All rights reserved.
9  *    Copyright (c) 2011-2014 Reini Urban. All rights reserved.
10  *       This program is free software; you can redistribute it and/or
11  *              modify it under the same terms as Perl itself.
12  *
13  */
14
15 #define PERL_NO_GET_CONTEXT
16 #include "EXTERN.h"
17 #include "perl.h"
18 #include "XSUB.h"
19 #ifdef _NOT_CORE
20 #  include "ppport.h"
21 #endif
22
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)
29 #ifndef PERL_FILTER_EXISTS
30 #  define PERL_FILTER_EXISTS(i) (PL_rsfp_filters && (i) <= av_len(PL_rsfp_filters))
31 #endif
32
33 #define SET_LEN(sv,len) \
34         do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0)
35
36
37 /* Global Data */
38
39 #define MY_CXT_KEY "Filter::Util::Call::_guts" XS_VERSION
40  
41 typedef struct {
42     int x_fdebug ;
43     int x_current_idx ;
44 } my_cxt_t;
45  
46 START_MY_CXT
47  
48 #define fdebug          (MY_CXT.x_fdebug)
49 #define current_idx     (MY_CXT.x_current_idx)
50
51
52 static I32
53 filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
54 {
55     dMY_CXT;
56     SV   *my_sv = FILTER_DATA(idx);
57     const char *nl = "\n";
58     char *p;
59     char *out_ptr;
60     int n;
61
62     if (fdebug)
63         warn("**** In filter_call - maxlen = %d, out len buf = %" IVdf " idx = %d my_sv = %" IVdf " [%s]\n",
64              maxlen, (IV)SvCUR(buf_sv), idx, (IV)SvCUR(my_sv), SvPVX(my_sv) ) ;
65
66     while (1) {
67
68         /* anything left from last time */
69         if ((n = SvCUR(my_sv))) {
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 */
92                 if ((p = ninstr(out_ptr, out_ptr + n, nl, nl + 1))) {
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)
100                         warn("recycle %d - leaving %d, returning %" IVdf " [%s]",
101                              idx, n, (IV)SvCUR(buf_sv), SvPVX(buf_sv)) ;
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
129             SAVE_DEFSV ;        /* save $_ */
130             /* make $_ use our buffer */
131             DEFSV_set(newSVpv("", 0)) ; 
132
133             PUSHMARK(sp) ;
134
135             if (CODE_REF(my_sv)) {
136             /* if (SvROK(PERL_OBJECT(my_sv)) && SvTYPE(SvRV(PERL_OBJECT(my_sv))) == SVt_PVCV) { */
137                 count = perl_call_sv((SV*)PERL_OBJECT(my_sv), G_SCALAR);
138             }
139             else {
140                 XPUSHs((SV*)PERL_OBJECT(my_sv)) ;  
141         
142                 PUTBACK ;
143
144                 count = perl_call_method("filter", G_SCALAR);
145             }
146
147             SPAGAIN ;
148
149             if (count != 1)
150                 croak("Filter::Util::Call - %s::filter returned %d values, 1 was expected \n", 
151                         PERL_MODULE(my_sv), count ) ;
152     
153             n = POPi ;
154
155             if (fdebug)
156                 warn("status = %d, length op buf = %" IVdf " [%s]\n",
157                      n, (IV)SvCUR(DEFSV), SvPVX(DEFSV) ) ;
158             if (SvCUR(DEFSV))
159                 sv_setpvn(my_sv, SvPVX(DEFSV), SvCUR(DEFSV)) ; 
160
161             sv_2mortal(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 %" IVdf "\n", idx, n,
176                       (SvCUR(buf_sv)>0) ? (IV)SvCUR(buf_sv) : (IV)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) ? (int)SvCUR(buf_sv) : n;
188         }
189
190     }
191 }
192
193
194
195 MODULE = Filter::Util::Call             PACKAGE = Filter::Util::Call
196
197 REQUIRE:        1.924
198 PROTOTYPES:     ENABLE
199
200 #define IDX             current_idx
201
202 int
203 filter_read(size=0)
204         int     size 
205         CODE:
206         {
207             dMY_CXT;
208             SV * buffer = DEFSV ;
209
210             RETVAL = FILTER_READ(IDX + 1, buffer, size) ;
211         }
212         OUTPUT:
213             RETVAL
214
215
216
217
218 void
219 real_import(object, perlmodule, coderef)
220     SV *        object
221     char *      perlmodule 
222     int         coderef
223     PPCODE:
224     {
225         SV * sv = newSV(1) ;
226
227         (void)SvPOK_only(sv) ;
228         filter_add(filter_call, sv) ;
229
230         PERL_MODULE(sv) = savepv(perlmodule) ;
231         PERL_OBJECT(sv) = (GV*) newSVsv(object) ;
232         FILTER_ACTIVE(sv) = TRUE ;
233         BUF_OFFSET(sv) = 0 ;
234         CODE_REF(sv)   = coderef ;
235
236         SvCUR_set(sv, 0) ;
237
238     }
239
240 void
241 filter_del()
242     CODE:
243         dMY_CXT;
244         if (PERL_FILTER_EXISTS(IDX) && FILTER_DATA(IDX) && FILTER_ACTIVE(FILTER_DATA(IDX)))
245             FILTER_ACTIVE(FILTER_DATA(IDX)) = FALSE ;
246
247
248
249 void
250 unimport(package="$Package", ...)
251     const char *package
252     PPCODE:
253     PERL_UNUSED_VAR(package);
254     filter_del(filter_call);
255
256
257 BOOT:
258   {
259     MY_CXT_INIT;
260 #ifdef FDEBUG
261     fdebug = 1;
262 #else
263     fdebug = 0;
264 #endif
265     /* temporary hack to control debugging in toke.c */
266     if (fdebug)
267         filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0");  
268   }
269