Simple.xs

/*
Copyright 2012, 2013, 2017 Lukas Mai.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.
 */

#ifdef __GNUC__
 #if __GNUC__ >= 5
  #define IF_HAVE_GCC_5(X) X
 #endif

 #if (__GNUC__ == 4 && __GNUC_MINOR__ >= 6) || __GNUC__ >= 5
  #define PRAGMA_GCC_(X) _Pragma(#X)
  #define PRAGMA_GCC(X) PRAGMA_GCC_(GCC X)
 #endif
#endif

#ifndef IF_HAVE_GCC_5
 #define IF_HAVE_GCC_5(X)
#endif

#ifndef PRAGMA_GCC
 #define PRAGMA_GCC(X)
#endif

#ifdef DEVEL
 #define WARNINGS_RESET PRAGMA_GCC(diagnostic pop)
 #define WARNINGS_ENABLEW(X) PRAGMA_GCC(diagnostic error #X)
 #define WARNINGS_ENABLE \
    WARNINGS_ENABLEW(-Wall) \
    WARNINGS_ENABLEW(-Wextra) \
    WARNINGS_ENABLEW(-Wundef) \
    WARNINGS_ENABLEW(-Wshadow) \
    WARNINGS_ENABLEW(-Wbad-function-cast) \
    WARNINGS_ENABLEW(-Wcast-align) \
    WARNINGS_ENABLEW(-Wwrite-strings) \
    WARNINGS_ENABLEW(-Wstrict-prototypes) \
    WARNINGS_ENABLEW(-Wmissing-prototypes) \
    WARNINGS_ENABLEW(-Winline) \
    WARNINGS_ENABLEW(-Wdisabled-optimization) \
    IF_HAVE_GCC_5(WARNINGS_ENABLEW(-Wnested-externs))

#else
 #define WARNINGS_RESET
 #define WARNINGS_ENABLE
#endif


#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include <string.h>
#include <stdlib.h>

#ifdef DEVEL
#undef NDEBUG
#endif
#include <assert.h>

#define HAVE_PERL_VERSION(R, V, S) \
    (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))

#ifndef STATIC_ASSERT_STMT
 #if (defined(static_assert) || (defined(__cplusplus) && __cplusplus >= 201103L)) && (!defined(__IBMC__) || __IBMC__ >= 1210)
 /* static_assert is a macro defined in <assert.h> in C11 or a compiler
    builtin in C++11.  But IBM XL C V11 does not support _Static_assert, no
    matter what <assert.h> says.
 */
 #  define STATIC_ASSERT_DECL(COND) static_assert(COND, #COND)
 #else
 /* We use a bit-field instead of an array because gcc accepts
    'typedef char x[n]' where n is not a compile-time constant.
    We want to enforce constantness.
 */
 #  define STATIC_ASSERT_2(COND, SUFFIX) \
     typedef struct { \
         unsigned int _static_assertion_failed_##SUFFIX : (COND) ? 1 : -1; \
     } _static_assertion_failed_##SUFFIX PERL_UNUSED_DECL
 #  define STATIC_ASSERT_1(COND, SUFFIX) STATIC_ASSERT_2(COND, SUFFIX)
 #  define STATIC_ASSERT_DECL(COND)    STATIC_ASSERT_1(COND, __LINE__)
 #endif
 /* We need this wrapper even in C11 because 'case X: static_assert(...);' is an
    error (static_assert is a declaration, and only statements can have labels).
 */
 #define STATIC_ASSERT_STMT(COND)      do { STATIC_ASSERT_DECL(COND); } while (0)
#endif

WARNINGS_ENABLE


#define MY_PKG "Keyword::Simple"

#define HINTK_KEYWORDS MY_PKG "/keywords"


#ifndef PL_rsfp_filters
#define PL_rsfp_filters (PL_parser->rsfp_filters)
#endif

#ifndef PL_parser_filtered
 #if HAVE_PERL_VERSION(5, 15, 5)
  #define PL_parser_filtered (PL_parser->filtered)
 #else
  #define PL_parser_filtered 0
 #endif
#endif


static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);

static SV *kw_handler(pTHX_ const char *kw_ptr, STRLEN kw_len) {
    HV *hints;
    SV **psv, *sv, *sv2;
    I32 kw_xlen;


    /* don't bother doing anything fancy after a syntax error */
    if (PL_parser && PL_parser->error_count) {
        return NULL;
    }

    STATIC_ASSERT_STMT(~(STRLEN)0 > (U32)I32_MAX);
    if (kw_len > (STRLEN)I32_MAX) {
        return NULL;
    }

    if (!(hints = GvHV(PL_hintgv))) {
        return NULL;
    }

    if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) {
        return NULL;
    }

    sv = *psv;
    if (!(SvROK(sv) && (sv2 = SvRV(sv), SvTYPE(sv2) == SVt_PVHV))) {
        croak("%s: internal error: $^H{'%s'} not a hashref: %"SVf, MY_PKG, HINTK_KEYWORDS, SVfARG(sv));
    }

    kw_xlen = kw_len;
    if (lex_bufutf8()) {
        kw_xlen = -kw_xlen;
    }
    if (!(psv = hv_fetch((HV *)sv2, kw_ptr, kw_xlen, 0))) {
        return NULL;
    }

    sv = *psv;
    if (!(SvROK(sv) && (sv2 = SvRV(sv), SvTYPE(sv2) == SVt_PVCV))) {
        croak("%s: internal error: $^H{'%s'}{'%.*s'} not a coderef: %"SVf, MY_PKG, HINTK_KEYWORDS, (int)kw_len, kw_ptr, SVfARG(sv));
    }

    return sv2;
}

static I32 playback(pTHX_ int idx, SV *buf, int n) {
    char *ptr;
    STRLEN len, d;
    SV *sv = FILTER_DATA(idx);

    ptr = SvPV(sv, len);
    if (!len) {
        return 0;
    }

    if (!n) {
        char *nl = memchr(ptr, '\n', len);
        d = nl ? (STRLEN)(nl - ptr + 1) : len;
    } else {
        d = n < 0 ? INT_MAX : n;
        if (d > len) {
            d = len;
        }
    }

    sv_catpvn(buf, ptr, d);
    sv_chop(sv, ptr + d);
    return 1;
}

static void total_recall(pTHX_ SV *cb) {
    SV *sv;
    dSP;

    ENTER;
    SAVETMPS;

    sv = sv_2mortal(newSVpvs(""));
    if (lex_bufutf8()) {
        SvUTF8_on(sv);
    }

    /* sluuuuuurrrrp */

    sv_setpvn(sv, PL_parser->bufptr, PL_parser->bufend - PL_parser->bufptr);
    lex_unstuff(PL_parser->bufend); /* you saw nothing */

    if (PL_parser->rsfp || PL_parser_filtered) {
        if (!PL_rsfp_filters) {
            /* because FILTER_READ fails with filters=null but DTRT with filters=[] */
            PL_rsfp_filters = newAV();
        }
        while (FILTER_READ(0, sv, 4096) > 0)
            ;
    }

    PUSHMARK(SP);
    mXPUSHs(newRV_inc(sv));
    PUTBACK;

    call_sv(cb, G_VOID);
    SPAGAIN;

    { /* $sv .= "\n" */
        char *p;
        STRLEN n;
        SvPV_force(sv, n);
        p = SvGROW(sv, n + 2);
        p[n] = '\n';
        p[n + 1] = '\0';
        SvCUR_set(sv, n + 1);
    }

    if (PL_parser->rsfp || PL_parser_filtered) {
        filter_add(playback, SvREFCNT_inc_simple_NN(sv));
        CopLINE_dec(PL_curcop);
    } else {
        lex_stuff_sv(sv, 0);
    }

    FREETMPS;
    LEAVE;
}

static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
    SV *cb;

    if ((cb = kw_handler(aTHX_ keyword_ptr, keyword_len))) {
        total_recall(aTHX_ cb);
        *op_ptr = newOP(OP_NULL, 0);
        return KEYWORD_PLUGIN_STMT;
    }

    return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
}


static void my_boot(pTHX) {
    HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);

    newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));

    next_keyword_plugin = PL_keyword_plugin;
    PL_keyword_plugin = my_keyword_plugin;
}

WARNINGS_RESET

MODULE = Keyword::Simple   PACKAGE = Keyword::Simple
PROTOTYPES: ENABLE

BOOT:
    my_boot(aTHX);