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
1 /* 
2  * Filename : Call.xs
3  * 
4  * Author   : Paul Marquess 
5  * Date     : 26th March 2000
6  * Version  : 1.05
7  *
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  *
12  */
13
14 #define PERL_NO_GET_CONTEXT
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
52 static int fdebug = 0;
53 static int current_idx ;
54
55 static I32
56 filter_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 */
71         if ((n = SvCUR(my_sv))) {
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 */
94                 if ((p = ninstr(out_ptr, out_ptr + n - 1, nl, nl))) {
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
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             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         FILTER_ACTIVE(FILTER_DATA(IDX)) = FALSE ;
243
244
245
246 void
247 unimport(package="$Package", ...)
248     char *package
249     PPCODE:
250     filter_del(filter_call);
251
252
253 BOOT:
254     /* temporary hack to control debugging in toke.c */
255     if (fdebug)
256         filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0");  
257
258