Identify.xs

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"

#ifndef CvISXSUB
#   define CvISXSUB(cv) CvXSUB(cv)
#endif

/*
get_code_info:
  Pass in a coderef, returns:
  [ $pkg_name, $coderef_name ] ie:
  [ 'Foo::Bar', 'new' ]
*/

MODULE = Sub::Identify   PACKAGE = Sub::Identify

PROTOTYPES: ENABLE

void
get_code_info(coderef)
    SV* coderef
    PREINIT:
        char* name;
        char* pkg;
    PPCODE:
        if (SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV) {
            coderef = SvRV(coderef);
            if (CvGV(coderef)) {
                name = GvNAME( CvGV(coderef) );
                pkg = HvNAME( GvSTASH(CvGV(coderef)) );
                EXTEND(SP, 2);
                PUSHs(sv_2mortal(newSVpvn(pkg, strlen(pkg))));
                PUSHs(sv_2mortal(newSVpvn(name, strlen(name))));
            }
            else {
                /* sub is being compiled: bail out and return nothing. */
            }
        }

void
get_code_location(coderef)
    SV* coderef
    PREINIT:
        char* file;
        line_t line;
    PPCODE:
        if (SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV) {
            coderef = SvRV(coderef);
            if (CvSTART(coderef) && !CvISXSUB(coderef)) {
                file = CvFILE(coderef);
                line = CopLINE((const COP*)CvSTART(coderef));
                EXTEND(SP, 2);
                PUSHs(sv_2mortal(newSVpvn(file, strlen(file))));
                PUSHs(sv_2mortal(newSViv(line)));
            }
        }

#if PERL_VERSION >= 16

bool
is_sub_constant(coderef)
    SV* coderef
    CODE:
        if (SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV) {
            coderef = SvRV(coderef);
            RETVAL = CvPROTO(coderef) && CvPROTOLEN(coderef) == 0 && CvCONST(coderef);
        }
        else
            RETVAL = 0;
    OUTPUT:
        RETVAL

#endif