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  */
   9
  10 #include "EXTERN.h"
  11 #include "perl.h"
  12 #include "XSUB.h"
  13
  14 #ifndef PERL_VERSION
  15 #    include "patchlevel.h"
  16 #    define PERL_REVISION       5
  17 #    define PERL_VERSION        PATCHLEVEL
  18 #    define PERL_SUBVERSION     SUBVERSION
  19 #endif
  20
  21 /* defgv must be accessed differently under threaded perl */
  22 /* DEFSV et al are in 5.004_56 */
  23 #ifndef DEFSV
  24 #    define DEFSV               GvSV(defgv)
  25 #endif
  26
  27 #ifndef pTHX
  28 #    define pTHX
  29 #    define pTHX_
  30 #    define aTHX
  31 #    define aTHX_
  32 #endif
  33
  34
  35 /* Internal defines */
  36 #define PERL_MODULE(s)          IoBOTTOM_NAME(s)
  37 #define PERL_OBJECT(s)          IoTOP_GV(s)
  38 #define FILTER_ACTIVE(s)        IoLINES(s)
  39 #define BUF_OFFSET(sv)          IoPAGE_LEN(sv)
  40 #define CODE_REF(sv)            IoPAGE(sv)
  41
  42 #define SET_LEN(sv,len) \
  43         do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0)
  44
  45
  46
  47 static int fdebug = 0;
  48 static int current_idx ;
  49
  50 static I32
  51 filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
  52 {
  53     SV   *my_sv = FILTER_DATA(idx);
  54     char *nl = "\n";
  55     char *p;
  56     char *out_ptr;
  57     int n;
  58
  59     if (fdebug)
  60         warn("**** In filter_call - maxlen = %d, out len buf = %d idx = %d my_sv = %d [%s]\n",
  61                 maxlen, SvCUR(buf_sv), idx, SvCUR(my_sv), SvPVX(my_sv) ) ;
  62
  63     while (1) {
  64
  65         /* anything left from last time */
  66         if (n = SvCUR(my_sv)) {
  67
  68             out_ptr = SvPVX(my_sv) + BUF_OFFSET(my_sv) ;
  69
  70             if (maxlen) {
  71                 /* want a block */
  72                 if (fdebug)
  73                     warn("BLOCK(%d): size = %d, maxlen = %d\n",
  74                         idx, n, maxlen) ;
  75
  76                 sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen );
  77                 if(n <= maxlen) {
  78                     BUF_OFFSET(my_sv) = 0 ;
  79                     SET_LEN(my_sv, 0) ;
  80                 }
  81                 else {
  82                     BUF_OFFSET(my_sv) += maxlen ;
  83                     SvCUR_set(my_sv, n - maxlen) ;
  84                 }
  85                 return SvCUR(buf_sv);
  86             }
  87             else {
  88                 /* want lines */
  89                 if (p = ninstr(out_ptr, out_ptr + n - 1, nl, nl)) {
  90
  91                     sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1);
  92
  93                     n = n - (p - out_ptr + 1);
  94                     BUF_OFFSET(my_sv) += (p - out_ptr + 1);
  95                     SvCUR_set(my_sv, n) ;
  96                     if (fdebug)
  97                         warn("recycle %d - leaving %d, returning %d [%s]",
  98                                 idx, n, SvCUR(buf_sv), SvPVX(buf_sv)) ;
  99
 100                     return SvCUR(buf_sv);
 101                 }
 102                 else /* no EOL, so append the complete buffer */
 103                     sv_catpvn(buf_sv, out_ptr, n) ;
 104             }
 105
 106         }
 107
 108
 109         SET_LEN(my_sv, 0) ;
 110         BUF_OFFSET(my_sv) = 0 ;
 111
 112         if (FILTER_ACTIVE(my_sv))
 113         {
 114             dSP ;
 115             int count ;
 116
 117             if (fdebug)
 118                 warn("gonna call %s::filter\n", PERL_MODULE(my_sv)) ;
 119
 120             ENTER ;
 121             SAVETMPS;
 122
 123             SAVEINT(current_idx) ;      /* save current idx */
 124             current_idx = idx ;
 125
 126             SAVESPTR(DEFSV) ;   /* save $_ */
 127             /* make $_ use our buffer */
 128             DEFSV = sv_2mortal(newSVpv("", 0)) ;
 129
 130             PUSHMARK(sp) ;
 131
 132             if (CODE_REF(my_sv)) {
 133             /* if (SvROK(PERL_OBJECT(my_sv)) && SvTYPE(SvRV(PERL_OBJECT(my_sv))) == SVt_PVCV) { */
 134                 count = perl_call_sv((SV*)PERL_OBJECT(my_sv), G_SCALAR);
 135             }
 136             else {
 137                 XPUSHs((SV*)PERL_OBJECT(my_sv)) ;
 138
 139                 PUTBACK ;
 140
 141                 count = perl_call_method("filter", G_SCALAR);
 142             }
 143
 144             SPAGAIN ;
 145
 146             if (count != 1)
 147                 croak("Filter::Util::Call - %s::filter returned %d values, 1 was expected \n",
 148                         PERL_MODULE(my_sv), count ) ;
 149
 150             n = POPi ;
 151
 152             if (fdebug)
 153                 warn("status = %d, length op buf = %d [%s]\n",
 154                      n, SvCUR(DEFSV), SvPVX(DEFSV) ) ;
 155             if (SvCUR(DEFSV))
 156                 sv_setpvn(my_sv, SvPVX(DEFSV), SvCUR(DEFSV)) ;
 157
 158             PUTBACK ;
 159             FREETMPS ;
 160             LEAVE ;
 161         }
 162         else
 163             n = FILTER_READ(idx + 1, my_sv, maxlen) ;
 164
 165         if (n <= 0)
 166         {
 167             /* Either EOF or an error */
 168
 169             if (fdebug)
 170                 warn ("filter_read %d returned %d , returning %d\n", idx, n,
 171                     (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n);
 172
 173             /* PERL_MODULE(my_sv) ; */
 174             /* PERL_OBJECT(my_sv) ; */
 175             filter_del(filter_call);
 176
 177             /* If error, return the code */
 178             if (n < 0)
 179                 return n ;
 180
 181             /* return what we have so far else signal eof */
 182             return (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n;
 183         }
 184
 185     }
 186 }
 187
 188
 189
 190 MODULE = Filter::Util::Call             PACKAGE = Filter::Util::Call
 191
 192 REQUIRE:        1.924
 193 PROTOTYPES:     ENABLE
 194
 195 #define IDX             current_idx
 196
 197 int
 198 filter_read(size=0)
 199         int     size
 200         CODE:
 201         {
 202             SV * buffer = DEFSV ;
 203
 204             RETVAL = FILTER_READ(IDX + 1, buffer, size) ;
 205         }
 206         OUTPUT:
 207             RETVAL
 208
 209
 210
 211
 212 void
 213 real_import(object, perlmodule, coderef)
 214     SV *        object
 215     char *      perlmodule
 216     int         coderef
 217     PPCODE:
 218     {
 219         SV * sv = newSV(1) ;
 220
 221         (void)SvPOK_only(sv) ;
 222         filter_add(filter_call, sv) ;
 223
 224         PERL_MODULE(sv) = savepv(perlmodule) ;
 225         PERL_OBJECT(sv) = (GV*) newSVsv(object) ;
 226         FILTER_ACTIVE(sv) = TRUE ;
 227         BUF_OFFSET(sv) = 0 ;
 228         CODE_REF(sv)   = coderef ;
 229
 230         SvCUR_set(sv, 0) ;
 231
 232     }
 233
 234 void
 235 filter_del()
 236     CODE:
 237         FILTER_ACTIVE(FILTER_DATA(IDX)) = FALSE ;
 238
 239
 240
 241 void
 242 unimport(...)
 243     PPCODE:
 244     filter_del(filter_call);
 245
 246
 247 BOOT:
 248     /* temporary hack to control debugging in toke.c */
 249     if (fdebug)
 250         filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0");
 251
 252