ext/Filter/Util/Call/Call.xs

   1 /*
   2  * Filename : Call.xs
   3  *
   4  * Author   : Paul Marquess
   5  * Date     : 11th November 2001
   6  * Version  : 1.06
   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 #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
  29 #define SET_LEN(sv,len) \
  30         do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0)
  31
  32
  33 /* Global Data */
  34
  35 #define MY_CXT_KEY "Filter::Util::Call::_guts" XS_VERSION
  36
  37 typedef struct {
  38     int x_fdebug ;
  39     int x_current_idx ;
  40 } my_cxt_t;
  41
  42 START_MY_CXT
  43
  44 #define fdebug          (MY_CXT.x_fdebug)
  45 #define current_idx     (MY_CXT.x_current_idx)
  46
  47
  48 static I32
  49 filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
  50 {
  51     dMY_CXT;
  52     SV   *my_sv = FILTER_DATA(idx);
  53     char *nl = "\n";
  54     char *p;
  55     char *out_ptr;
  56     int n;
  57
  58     if (fdebug)
  59         warn("**** In filter_call - maxlen = %d, out len buf = %d idx = %d my_sv = %d [%s]\n",
  60                 maxlen, SvCUR(buf_sv), idx, SvCUR(my_sv), SvPVX(my_sv) ) ;
  61
  62     while (1) {
  63
  64         /* anything left from last time */
  65         if ((n = SvCUR(my_sv))) {
  66
  67             out_ptr = SvPVX(my_sv) + BUF_OFFSET(my_sv) ;
  68
  69             if (maxlen) {
  70                 /* want a block */
  71                 if (fdebug)
  72                     warn("BLOCK(%d): size = %d, maxlen = %d\n",
  73                         idx, n, maxlen) ;
  74
  75                 sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen );
  76                 if(n <= maxlen) {
  77                     BUF_OFFSET(my_sv) = 0 ;
  78                     SET_LEN(my_sv, 0) ;
  79                 }
  80                 else {
  81                     BUF_OFFSET(my_sv) += maxlen ;
  82                     SvCUR_set(my_sv, n - maxlen) ;
  83                 }
  84                 return SvCUR(buf_sv);
  85             }
  86             else {
  87                 /* want lines */
  88                 if ((p = ninstr(out_ptr, out_ptr + n, nl, nl + 1))) {
  89
  90                     sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1);
  91
  92                     n = n - (p - out_ptr + 1);
  93                     BUF_OFFSET(my_sv) += (p - out_ptr + 1);
  94                     SvCUR_set(my_sv, n) ;
  95                     if (fdebug)
  96                         warn("recycle %d - leaving %d, returning %d [%s]",
  97                                 idx, n, SvCUR(buf_sv), SvPVX(buf_sv)) ;
  98
  99                     return SvCUR(buf_sv);
 100                 }
 101                 else /* no EOL, so append the complete buffer */
 102                     sv_catpvn(buf_sv, out_ptr, n) ;
 103             }
 104
 105         }
 106
 107
 108         SET_LEN(my_sv, 0) ;
 109         BUF_OFFSET(my_sv) = 0 ;
 110
 111         if (FILTER_ACTIVE(my_sv))
 112         {
 113             dSP ;
 114             int count ;
 115
 116             if (fdebug)
 117                 warn("gonna call %s::filter\n", PERL_MODULE(my_sv)) ;
 118
 119             ENTER ;
 120             SAVETMPS;
 121
 122             SAVEINT(current_idx) ;      /* save current idx */
 123             current_idx = idx ;
 124
 125             SAVESPTR(DEFSV) ;   /* save $_ */
 126             /* make $_ use our buffer */
 127             DEFSV = sv_2mortal(newSVpv("", 0)) ;
 128
 129             PUSHMARK(sp) ;
 130
 131             if (CODE_REF(my_sv)) {
 132             /* if (SvROK(PERL_OBJECT(my_sv)) && SvTYPE(SvRV(PERL_OBJECT(my_sv))) == SVt_PVCV) { */
 133                 count = perl_call_sv((SV*)PERL_OBJECT(my_sv), G_SCALAR);
 134             }
 135             else {
 136                 XPUSHs((SV*)PERL_OBJECT(my_sv)) ;
 137
 138                 PUTBACK ;
 139
 140                 count = perl_call_method("filter", G_SCALAR);
 141             }
 142
 143             SPAGAIN ;
 144
 145             if (count != 1)
 146                 croak("Filter::Util::Call - %s::filter returned %d values, 1 was expected \n",
 147                         PERL_MODULE(my_sv), count ) ;
 148
 149             n = POPi ;
 150
 151             if (fdebug)
 152                 warn("status = %d, length op buf = %d [%s]\n",
 153                      n, SvCUR(DEFSV), SvPVX(DEFSV) ) ;
 154             if (SvCUR(DEFSV))
 155                 sv_setpvn(my_sv, SvPVX(DEFSV), SvCUR(DEFSV)) ;
 156
 157             PUTBACK ;
 158             FREETMPS ;
 159             LEAVE ;
 160         }
 161         else
 162             n = FILTER_READ(idx + 1, my_sv, maxlen) ;
 163
 164         if (n <= 0)
 165         {
 166             /* Either EOF or an error */
 167
 168             if (fdebug)
 169                 warn ("filter_read %d returned %d , returning %d\n", idx, n,
 170                     (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n);
 171
 172             /* PERL_MODULE(my_sv) ; */
 173             /* PERL_OBJECT(my_sv) ; */
 174             filter_del(filter_call);
 175
 176             /* If error, return the code */
 177             if (n < 0)
 178                 return n ;
 179
 180             /* return what we have so far else signal eof */
 181             return (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n;
 182         }
 183
 184     }
 185 }
 186
 187
 188
 189 MODULE = Filter::Util::Call             PACKAGE = Filter::Util::Call
 190
 191 REQUIRE:        1.924
 192 PROTOTYPES:     ENABLE
 193
 194 #define IDX             current_idx
 195
 196 int
 197 filter_read(size=0)
 198         int     size
 199         CODE:
 200         {
 201             dMY_CXT;
 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         dMY_CXT;
 238         if (PL_rsfp_filters && IDX <= av_len(PL_rsfp_filters) && FILTER_DATA(IDX) && FILTER_ACTIVE(FILTER_DATA(IDX)))
 239             FILTER_ACTIVE(FILTER_DATA(IDX)) = FALSE ;
 240
 241
 242
 243 void
 244 unimport(package="$Package", ...)
 245     char *package
 246     PPCODE:
 247     filter_del(filter_call);
 248
 249
 250 BOOT:
 251   {
 252     MY_CXT_INIT;
 253     fdebug = 0;
 254     /* temporary hack to control debugging in toke.c */
 255     if (fdebug)
 256         filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0");
 257   }
 258
 259