cpan/Filter-Util-Call/Call.xs

   1 /*
   2  * Filename : Call.xs
   3  *
   4  * Author   : Paul Marquess
   5  * Date     : 24th April 2011
   6  * Version  : 1.40
   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 = %d idx = %d my_sv = %d [%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 %d [%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 = %d [%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 %d\n", idx, n,
 175                     (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : 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     fdebug = 0;
 259     /* temporary hack to control debugging in toke.c */
 260     if (fdebug)
 261         filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0");
 262   }
 263
 264