cpan/Filter-Util-Call/Call.xs

   1 /*
   2  * Filename : Call.xs
   3  *
   4  * Author   : Paul Marquess
   5  * Date     : 2014-12-09 02:48:44 rurban
   6  * Version  : 1.55
   7  *
   8  *    Copyright (c) 1995-2011 Paul Marquess. All rights reserved.
   9  *    Copyright (c) 2011-2014 Reini Urban. All rights reserved.
  10  *       This program is free software; you can redistribute it and/or
  11  *              modify it under the same terms as Perl itself.
  12  *
  13  */
  14
  15 #define PERL_NO_GET_CONTEXT
  16 #include "EXTERN.h"
  17 #include "perl.h"
  18 #include "XSUB.h"
  19 #ifdef _NOT_CORE
  20 #  include "ppport.h"
  21 #endif
  22
  23 /* Internal defines */
  24 #define PERL_MODULE(s)          IoBOTTOM_NAME(s)
  25 #define PERL_OBJECT(s)          IoTOP_GV(s)
  26 #define FILTER_ACTIVE(s)        IoLINES(s)
  27 #define BUF_OFFSET(sv)          IoPAGE_LEN(sv)
  28 #define CODE_REF(sv)            IoPAGE(sv)
  29 #ifndef PERL_FILTER_EXISTS
  30 #  define PERL_FILTER_EXISTS(i) (PL_rsfp_filters && (i) <= av_len(PL_rsfp_filters))
  31 #endif
  32
  33 #define SET_LEN(sv,len) \
  34         do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0)
  35
  36
  37 /* Global Data */
  38
  39 #define MY_CXT_KEY "Filter::Util::Call::_guts" XS_VERSION
  40
  41 typedef struct {
  42     int x_fdebug ;
  43     int x_current_idx ;
  44 } my_cxt_t;
  45
  46 START_MY_CXT
  47
  48 #define fdebug          (MY_CXT.x_fdebug)
  49 #define current_idx     (MY_CXT.x_current_idx)
  50
  51
  52 static I32
  53 filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
  54 {
  55     dMY_CXT;
  56     SV   *my_sv = FILTER_DATA(idx);
  57     const char *nl = "\n";
  58     char *p;
  59     char *out_ptr;
  60     int n;
  61
  62     if (fdebug)
  63         warn("**** In filter_call - maxlen = %d, out len buf = %" IVdf " idx = %d my_sv = %" IVdf " [%s]\n",
  64              maxlen, (IV)SvCUR(buf_sv), idx, (IV)SvCUR(my_sv), SvPVX(my_sv) ) ;
  65
  66     while (1) {
  67
  68         /* anything left from last time */
  69         if ((n = SvCUR(my_sv))) {
  70
  71             out_ptr = SvPVX(my_sv) + BUF_OFFSET(my_sv) ;
  72
  73             if (maxlen) {
  74                 /* want a block */
  75                 if (fdebug)
  76                     warn("BLOCK(%d): size = %d, maxlen = %d\n",
  77                         idx, n, maxlen) ;
  78
  79                 sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen );
  80                 if(n <= maxlen) {
  81                     BUF_OFFSET(my_sv) = 0 ;
  82                     SET_LEN(my_sv, 0) ;
  83                 }
  84                 else {
  85                     BUF_OFFSET(my_sv) += maxlen ;
  86                     SvCUR_set(my_sv, n - maxlen) ;
  87                 }
  88                 return SvCUR(buf_sv);
  89             }
  90             else {
  91                 /* want lines */
  92                 if ((p = ninstr(out_ptr, out_ptr + n, nl, nl + 1))) {
  93
  94                     sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1);
  95
  96                     n = n - (p - out_ptr + 1);
  97                     BUF_OFFSET(my_sv) += (p - out_ptr + 1);
  98                     SvCUR_set(my_sv, n) ;
  99                     if (fdebug)
 100                         warn("recycle %d - leaving %d, returning %" IVdf " [%s]",
 101                              idx, n, (IV)SvCUR(buf_sv), SvPVX(buf_sv)) ;
 102
 103                     return SvCUR(buf_sv);
 104                 }
 105                 else /* no EOL, so append the complete buffer */
 106                     sv_catpvn(buf_sv, out_ptr, n) ;
 107             }
 108
 109         }
 110
 111
 112         SET_LEN(my_sv, 0) ;
 113         BUF_OFFSET(my_sv) = 0 ;
 114
 115         if (FILTER_ACTIVE(my_sv))
 116         {
 117             dSP ;
 118             int count ;
 119
 120             if (fdebug)
 121                 warn("gonna call %s::filter\n", PERL_MODULE(my_sv)) ;
 122
 123             ENTER ;
 124             SAVETMPS;
 125
 126             SAVEINT(current_idx) ;      /* save current idx */
 127             current_idx = idx ;
 128
 129             SAVE_DEFSV ;        /* save $_ */
 130             /* make $_ use our buffer */
 131             DEFSV_set(newSVpv("", 0)) ;
 132
 133             PUSHMARK(sp) ;
 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                 PUTBACK ;
 141                 count = perl_call_method("filter", G_SCALAR);
 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 = %" IVdf " [%s]\n",
 153                      n, (IV)SvCUR(DEFSV), SvPVX(DEFSV) ) ;
 154             if (SvCUR(DEFSV))
 155                 sv_setpvn(my_sv, SvPVX(DEFSV), SvCUR(DEFSV)) ;
 156
 157             sv_2mortal(DEFSV);
 158
 159             PUTBACK ;
 160             FREETMPS ;
 161             LEAVE ;
 162         }
 163         else
 164             n = FILTER_READ(idx + 1, my_sv, maxlen) ;
 165
 166         if (n <= 0)
 167         {
 168             /* Either EOF or an error */
 169
 170             if (fdebug)
 171                 warn ("filter_read %d returned %d , returning %" IVdf "\n", idx, n,
 172                       (SvCUR(buf_sv)>0) ? (IV)SvCUR(buf_sv) : (IV)n);
 173
 174             /* PERL_MODULE(my_sv) ; */
 175             /* PERL_OBJECT(my_sv) ; */
 176             filter_del(filter_call);
 177
 178             /* If error, return the code */
 179             if (n < 0)
 180                 return n ;
 181
 182             /* return what we have so far else signal eof */
 183             return (SvCUR(buf_sv)>0) ? (int)SvCUR(buf_sv) : n;
 184         }
 185
 186     }
 187 }
 188
 189
 190
 191 MODULE = Filter::Util::Call             PACKAGE = Filter::Util::Call
 192
 193 REQUIRE:        1.924
 194 PROTOTYPES:     ENABLE
 195
 196 #define IDX             current_idx
 197
 198 int
 199 filter_read(size=0)
 200         int     size
 201         CODE:
 202         {
 203             dMY_CXT;
 204             SV * buffer = DEFSV ;
 205
 206             RETVAL = FILTER_READ(IDX + 1, buffer, size) ;
 207         }
 208         OUTPUT:
 209             RETVAL
 210
 211
 212
 213
 214 void
 215 real_import(object, perlmodule, coderef)
 216     SV *        object
 217     char *      perlmodule
 218     int         coderef
 219     PPCODE:
 220     {
 221         SV * sv = newSV(1) ;
 222
 223         (void)SvPOK_only(sv) ;
 224         filter_add(filter_call, sv) ;
 225
 226         PERL_MODULE(sv) = savepv(perlmodule) ;
 227         PERL_OBJECT(sv) = (GV*) newSVsv(object) ;
 228         FILTER_ACTIVE(sv) = TRUE ;
 229         BUF_OFFSET(sv) = 0 ;
 230         CODE_REF(sv)   = coderef ;
 231
 232         SvCUR_set(sv, 0) ;
 233
 234     }
 235
 236 void
 237 filter_del()
 238     CODE:
 239         dMY_CXT;
 240         if (PERL_FILTER_EXISTS(IDX) && FILTER_DATA(IDX) && FILTER_ACTIVE(FILTER_DATA(IDX)))
 241             FILTER_ACTIVE(FILTER_DATA(IDX)) = FALSE ;
 242
 243
 244
 245 void
 246 unimport(package="$Package", ...)
 247     const char *package
 248     PPCODE:
 249     PERL_UNUSED_VAR(package);
 250     filter_del(filter_call);
 251
 252
 253 BOOT:
 254   {
 255     MY_CXT_INIT;
 256 #ifdef FDEBUG
 257     fdebug = 1;
 258 #else
 259     fdebug = 0;
 260 #endif
 261     /* temporary hack to control debugging in toke.c */
 262     if (fdebug)
 263         filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0");
 264   }
 265