This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Filter-Util-Call to CPAN version 1.49
[perl5.git] / cpan / Filter-Util-Call / Call.xs
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 filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
53 {
54     dMY_CXT;
55     SV   *my_sv = FILTER_DATA(idx);
56     const char *nl = "\n";
57     char *p;
58     char *out_ptr;
59     int n;
60
61     if (fdebug)
62         warn("**** In filter_call - maxlen = %d, out len buf = %" IVdf " idx = %d my_sv = %" IVdf " [%s]\n",
63                 maxlen, SvCUR(buf_sv), idx, SvCUR(my_sv), SvPVX(my_sv) ) ;
64
65     while (1) {
66
67         /* anything left from last time */
68         if ((n = SvCUR(my_sv))) {
69
70             out_ptr = SvPVX(my_sv) + BUF_OFFSET(my_sv) ;
71
72             if (maxlen) { 
73                 /* want a block */ 
74                 if (fdebug)
75                     warn("BLOCK(%d): size = %d, maxlen = %d\n", 
76                         idx, n, maxlen) ;
77
78                 sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen );
79                 if(n <= maxlen) {
80                     BUF_OFFSET(my_sv) = 0 ;
81                     SET_LEN(my_sv, 0) ;
82                 }
83                 else {
84                     BUF_OFFSET(my_sv) += maxlen ;
85                     SvCUR_set(my_sv, n - maxlen) ;
86                 }
87                 return SvCUR(buf_sv);
88             }
89             else {
90                 /* want lines */
91                 if ((p = ninstr(out_ptr, out_ptr + n, nl, nl + 1))) {
92
93                     sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1);
94
95                     n = n - (p - out_ptr + 1);
96                     BUF_OFFSET(my_sv) += (p - out_ptr + 1);
97                     SvCUR_set(my_sv, n) ;
98                     if (fdebug)
99                         warn("recycle %d - leaving %d, returning %" IVdf " [%s]",
100                                 idx, n, SvCUR(buf_sv), SvPVX(buf_sv)) ;
101
102                     return SvCUR(buf_sv);
103                 }
104                 else /* no EOL, so append the complete buffer */
105                     sv_catpvn(buf_sv, out_ptr, n) ;
106             }
107             
108         }
109
110
111         SET_LEN(my_sv, 0) ;
112         BUF_OFFSET(my_sv) = 0 ;
113
114         if (FILTER_ACTIVE(my_sv))
115         {
116             dSP ;
117             int count ;
118
119             if (fdebug)
120                 warn("gonna call %s::filter\n", PERL_MODULE(my_sv)) ;
121
122             ENTER ;
123             SAVETMPS;
124         
125             SAVEINT(current_idx) ;      /* save current idx */
126             current_idx = idx ;
127
128             SAVE_DEFSV ;        /* save $_ */
129             /* make $_ use our buffer */
130             DEFSV_set(newSVpv("", 0)) ; 
131
132             PUSHMARK(sp) ;
133
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)) ;  
140         
141                 PUTBACK ;
142
143                 count = perl_call_method("filter", G_SCALAR);
144             }
145
146             SPAGAIN ;
147
148             if (count != 1)
149                 croak("Filter::Util::Call - %s::filter returned %d values, 1 was expected \n", 
150                         PERL_MODULE(my_sv), count ) ;
151     
152             n = POPi ;
153
154             if (fdebug)
155                 warn("status = %d, length op buf = %" IVdf " [%s]\n",
156                      n, SvCUR(DEFSV), SvPVX(DEFSV) ) ;
157             if (SvCUR(DEFSV))
158                 sv_setpvn(my_sv, SvPVX(DEFSV), SvCUR(DEFSV)) ; 
159
160             sv_2mortal(DEFSV);
161
162             PUTBACK ;
163             FREETMPS ;
164             LEAVE ;
165         }
166         else
167             n = FILTER_READ(idx + 1, my_sv, maxlen) ;
168
169         if (n <= 0)
170         {
171             /* Either EOF or an error */
172
173             if (fdebug) 
174                 warn ("filter_read %d returned %d , returning %" IVdf "\n", idx, n,
175                       (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : (STRLEN)n);
176
177             /* PERL_MODULE(my_sv) ; */
178             /* PERL_OBJECT(my_sv) ; */
179             filter_del(filter_call); 
180
181             /* If error, return the code */
182             if (n < 0)
183                 return n ;
184
185             /* return what we have so far else signal eof */
186             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             SV * buffer = DEFSV ;
208
209             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         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
239 void
240 filter_del()
241     CODE:
242         dMY_CXT;
243         if (PERL_FILTER_EXISTS(IDX) && FILTER_DATA(IDX) && FILTER_ACTIVE(FILTER_DATA(IDX)))
244             FILTER_ACTIVE(FILTER_DATA(IDX)) = FALSE ;
245
246
247
248 void
249 unimport(package="$Package", ...)
250     const char *package
251     PPCODE:
252     filter_del(filter_call);
253
254
255 BOOT:
256   {
257     MY_CXT_INIT;
258 #ifdef FDEBUG
259     fdebug = 1;
260 #else
261     fdebug = 0;
262 #endif
263     /* temporary hack to control debugging in toke.c */
264     if (fdebug)
265         filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0");  
266   }
267