/*
* This file was generated automatically by ExtUtils::ParseXS version 2.18 from the
* contents of namespaces.xs. Do not edit this file, edit namespaces.xs instead.
*
* ANY CHANGES MADE HERE WILL BE LOST!
*
*/
#line 1 "namespaces.xs"
/* Copyright (c) 1997-2006 -*- C -*-
Ewgenij Gawrilow, Michael Joswig (Technische Universitaet Berlin, Germany)
http://www.math.tu-berlin.de/polymake, mailto:polymake@math.tu-berlin.de
This program is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 2, or (at your option) any
later version: http://www.gnu.org/licenses/gpl.txt.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
*/
#ident "$Project: polymake $$Id: namespaces.xs 7533 2006-12-20 23:55:58Z gawrilow $"
#include "Ext.h"
#ifdef DEBUGGING
#define DebugNamespaces 1
#endif
struct ToRestore;
typedef OP* (*ck_fun_ptr)(pTHX_ OP*);
typedef OP* (*op_fun_ptr)(pTHX);
static ck_fun_ptr def_ck_CONST, def_ck_ENTERSUB, def_ck_LEAVESUB, def_ck_LEAVEEVAL, def_ck_GLOB;
static op_fun_ptr def_pp_GV, def_pp_GVSV, def_pp_RV2GV, def_pp_AELEMFAST, def_pp_ENTEREVAL, def_pp_REGCOMP;
/* TRUE if namespace mode active */
int current_mode() { return PL_ppaddr[OP_GV] != def_pp_GV; }
#ifdef USE_ITHREADS
#define n_saved_words 3
#else
#define n_saved_words 6
#endif
typedef struct ToRestore {
ANY saved[n_saved_words];
I32 inserted, old_state, hints, import_from_level;
} ToRestore;
static AV* restores;
static I32 restores_ix=-1;
static HV *last_stash;
static AV *last_dotLOOKUP, *import_from_av;
static CV *declare_cv;
static GV *alt_lookup_gv;
static const char dot_lookup[]=".LOOKUP";
static const char dot_import[]=".IMPORT";
static const char declare[]="declare";
static const char instanceof[]="instanceof";
static I32 skip_debug_cx=FALSE;
static
void catch_ptrs(pTHX_ void *to_restore);
static
void reset_ptrs(pTHX_ void *to_restore);
#ifdef DebugNamespaces
static int debug=0;
#endif
static inline
ToRestore* newToRestore(pTHX_ I32 old_state)
{
ToRestore *to_restore;
New(0, to_restore, 1, ToRestore);
to_restore->old_state=old_state;
to_restore->hints=PL_hints;
to_restore->import_from_level=AvFILLp(import_from_av);
to_restore->inserted=FALSE;
#if DebugNamespaces
if (debug) fprintf(stderr, "newToRestore(%d) ptr=%p\n", old_state, to_restore), fflush(stderr);
#endif
return to_restore;
}
static
void finish_undo(pTHX_ ToRestore *to_restore)
{
I32 where=PL_savestack_ix;
#ifdef USE_ITHREADS
if (to_restore->inserted) {
ANY *saved=PL_savestack+where;
*saved++=to_restore->saved[0];
*saved++=to_restore->saved[1];
*saved =to_restore->saved[2];
PL_savestack_ix+=3;
}
#endif
if (to_restore->old_state)
PL_hints &= ~HINT_STRICT_VARS;
else
PL_hints |= to_restore->hints & HINT_STRICT_VARS;
av_fill(import_from_av, to_restore->import_from_level);
#ifdef USE_ITHREADS
Safefree(to_restore);
#endif
while (restores_ix>0 && SvIVX(*av_fetch(restores, restores_ix, FALSE)) >= where)
restores_ix-=2;
}
#ifndef USE_ITHREADS
static
void unpack_saved(pTHX_ void *x)
{
ToRestore *to_restore=(ToRestore*)x;
I32 where=PL_savestack_ix;
ANY *saved=PL_savestack+where;
*saved++=to_restore->saved[0];
*saved++=to_restore->saved[1];
*saved++=to_restore->saved[2];
*saved++=to_restore->saved[3];
*saved++=to_restore->saved[4];
*saved =to_restore->saved[5];
PL_savestack_ix+=6;
Safefree(to_restore);
}
#endif
static
ANY* find_bottom_slot(pTHX)
{
ANY *bottom=PL_savestack, *s=bottom+PL_scopestack[1]-1;
for (;;) {
int dist=s-bottom;
if (dist<=10) {
if (dist>=3)
return s-2;
croak("can't find bottom slot in the save stack");
}
switch (s->any_i32) {
case SAVEt_NSTAB:
case SAVEt_FREESV:
case SAVEt_MORTALIZESV:
case SAVEt_FREEOP:
case SAVEt_FREEPV:
case SAVEt_CLEARSV:
case SAVEt_OP:
case SAVEt_STACK_POS:
case SAVEt_COMPPAD:
case SAVEt_HINTS:
s-=2; break;
case SAVEt_ITEM:
case SAVEt_INT:
case SAVEt_LONG:
case SAVEt_BOOL:
case SAVEt_I32:
case SAVEt_I16:
case SAVEt_I8:
case SAVEt_IV:
case SAVEt_PPTR:
case SAVEt_VPTR:
case SAVEt_SPTR:
case SAVEt_HPTR:
case SAVEt_APTR:
case SAVEt_DESTRUCTOR:
case SAVEt_DESTRUCTOR_X:
case SAVEt_SV:
case SAVEt_SVREF:
case SAVEt_GENERIC_SVREF:
case SAVEt_GENERIC_PVREF:
case SAVEt_SHARED_PVREF:
case SAVEt_AV:
case SAVEt_HV:
s-=3; break;
case SAVEt_PADSV:
case SAVEt_DELETE:
case SAVEt_AELEM:
case SAVEt_HELEM:
s-=4; break;
case SAVEt_GP:
s-=6; break;
case SAVEt_ALLOC:
case SAVEt_REGCONTEXT:
s-=s[-1].any_i32+2; break;
default:
croak("unknown code in the save stack");
}
}
}
static
ANY* find_undo(pTHX_ ANY **saves_p)
{
I32 cix=cxstack_ix;
if (CxTYPE(cxstack+cix) == CXt_SUB && CvSPECIAL(cxstack[cix].blk_sub.cv)) {
for (;;) {
--cix;
switch (CxTYPE(cxstack+cix)) {
case CXt_BLOCK:
if (skip_debug_cx) {
COP *cop=cxstack[cix].blk_oldcop;
if (CopSTASH_eq(cop,PL_debstash))
continue;
}
break;
case CXt_SUB:
if (skip_debug_cx && CvSTASH(cxstack[cix].blk_sub.cv)==PL_debstash)
continue;
break;
case CXt_EVAL:
--cix;
if (restores_ix>0 && SvIVX(*av_fetch(restores, restores_ix-1, FALSE))==cix) {
ANY *saves=PL_savestack+SvIVX(*av_fetch(restores, restores_ix, FALSE))-3;
if (saves_p) *saves_p=saves;
return saves;
} else {
if (saves_p) {
if (cix>=0) {
#ifdef USE_ITHREADS
/* there is a useful ENTER at the beginning of yyparse() which marks the suitable position on the save stack */
*saves_p=PL_savestack+PL_scopestack[cxstack[cix].blk_oldscopesp]-3;
#else
/* here our destructor block is inserted beneath the stored scope mark; the latter is pushed down in the context stack */
*saves_p=PL_savestack+(PL_scopestack[cxstack[cix].blk_oldscopesp-1]-=3);
#endif
} else {
*saves_p=find_bottom_slot(aTHX);
}
}
return 0;
}
}
break;
}
}
croak("namespaces::{un,}import may not be used directly; write 'use namespaces' or 'no namespaces' instead");
/* UNREACHABLE */
return 0;
}
static
ToRestore* insert_undo(pTHX_ I32 old_state)
{
ToRestore *to_restore;
ANY *saves, *rest;
if (find_undo(aTHX_ &saves)) {
to_restore=(ToRestore*)saves[1].any_ptr;
to_restore->old_state=old_state;
saves[0].any_dxptr=old_state ? &catch_ptrs : &reset_ptrs;
return to_restore;
}
to_restore=newToRestore(aTHX_ old_state);
to_restore->inserted=TRUE;
rest=to_restore->saved;
#ifndef USE_ITHREADS
saves-=3;
*rest=*saves;
saves->any_dxptr=&unpack_saved;
*++rest=*++saves;
saves->any_ptr=to_restore;
*++rest=*++saves;
saves->any_i32=SAVEt_DESTRUCTOR_X;
++rest; ++saves;
#endif
*rest=*saves;
saves->any_dxptr=old_state ? &catch_ptrs : &reset_ptrs;
*++rest=*++saves;
saves->any_ptr=to_restore;
*++rest=*++saves;
saves->any_i32=SAVEt_DESTRUCTOR_X;
return 0;
}
static
OP* switch_off_namespaces(pTHX)
{
reset_ptrs(aTHX_ 0);
PL_op->op_ppaddr=&Perl_pp_null;
#if DebugNamespaces
if (debug) {
if (PL_op->op_next->op_type != OP_STUB) {
COP* o=(COP*)PL_op->op_next;
fprintf(stderr, "reset before executing %s, line %d cx=%d scope=%d\n", CopFILE(o), CopLINE(o), cxstack_ix, PL_scopestack_ix), fflush(stderr);
} else {
fprintf(stderr, "reset before executing stub cx=%d scope=%d\n", cxstack_ix, PL_scopestack_ix), fflush(stderr);
}
}
#endif
return NORMAL;
}
#if DebugNamespaces
static
void dump_array(AV *av, const char* name)
{
SV **impp=AvARRAY(av), **end;
fprintf(stderr, ".%s(%d)=[", name, SvREFCNT(av));
if (impp)
for (end=impp+AvFILLp(av); impp<=end; ++impp)
fprintf(stderr, " %s", HvNAME((HV*)SvRV(*impp)));
fprintf(stderr, " ]\n");
}
#endif
static
I32 append_imp_stash(AV *dotLOOKUP, HV *imp_stash)
{
SV **lookp, **endp;
if ((lookp=AvARRAY(dotLOOKUP)))
for (endp=lookp+AvFILLp(dotLOOKUP); lookp<=endp; ++lookp)
if ((HV*)SvRV(*lookp)==imp_stash) return FALSE;
av_push(dotLOOKUP, newRV((SV*)imp_stash));
return TRUE;
}
static
void append_lookup(HV *stash, AV *dotLOOKUP, AV *imp_dotLOOKUP)
{
SV **lookp=AvARRAY(imp_dotLOOKUP), **endp;
if (lookp) {
for (endp=lookp+AvFILLp(imp_dotLOOKUP); lookp<=endp; ++lookp) {
HV *imp_stash=(HV*)SvRV(*lookp);
if (imp_stash != stash)
append_imp_stash(dotLOOKUP, imp_stash);
}
}
}
static
AV* get_dotLOOKUP(HV *stash)
{
AV *dotLOOKUP=0;
int i;
GV *lookup_gv=*(GV**)hv_fetch(stash, dot_lookup, sizeof(dot_lookup)-1, TRUE);
if (SvTYPE(lookup_gv)!=SVt_PVGV)
gv_init(lookup_gv, stash, dot_lookup, sizeof(dot_lookup)-1, GV_ADDMULTI);
else
dotLOOKUP=GvAV(lookup_gv);
if (!dotLOOKUP) {
char *st_name=HvNAME(stash);
I32 st_name_len=strlen(st_name);
AV *dotIMPORT;
GV **imp_gvp;
dotLOOKUP=newAV();
if ( (imp_gvp=(GV**)hv_fetch(stash, dot_import, sizeof(dot_import)-1, FALSE)) &&
(dotIMPORT=GvAV(*imp_gvp)) ) {
SV **impp=AvARRAY(dotIMPORT), **end;
if (impp)
for (end=impp+AvFILLp(dotIMPORT); impp<=end; ++impp) {
HV *imp_stash=(HV*)SvRV(*impp);
if (imp_stash != stash && append_imp_stash(dotLOOKUP, imp_stash)) {
AV *imp_dotLOOKUP=get_dotLOOKUP(imp_stash);
if (imp_dotLOOKUP) append_lookup(stash, dotLOOKUP, imp_dotLOOKUP);
}
}
} else {
return 0;
}
for (i=st_name_len-2; i>0; --i) {
if (st_name[i]==':' && st_name[i-1]==':') {
HV *encl_stash=gv_stashpvn(st_name, --i, FALSE);
if (encl_stash) {
if (append_imp_stash(dotLOOKUP, encl_stash)) {
if (hv_exists(encl_stash, dot_import, sizeof(dot_import)-1)) {
AV *encl_lookup=get_dotLOOKUP(encl_stash);
if (encl_lookup) {
append_lookup(stash, dotLOOKUP, encl_lookup);
break; /* encl_stash::.LOOKUP certainly contains all enclosing packages */
}
}
} else {
break;
}
}
}
}
GvAV(lookup_gv)=dotLOOKUP;
#if DebugNamespaces
if (debug)
fprintf(stderr, "created %s::", HvNAME(stash)), dump_array(dotLOOKUP, "LOOKUP"), fflush(stderr);
#endif
if (AvFILLp(dotLOOKUP)<0) dotLOOKUP=0;
}
last_stash=stash;
last_dotLOOKUP=dotLOOKUP;
return dotLOOKUP;
}
static
OP *pp_popmark(pTHX)
{
(void)POPMARK;
return NORMAL;
}
static
void lookup(pTHX_ GV *var_gv, I32 type, OP **pnext_op, OP *access_op)
{
HV *stash=GvSTASH(var_gv);
if (stash != PL_defstash && stash != PL_debstash) {
const char *varname=GvNAME(var_gv);
STRLEN varnamelen=GvNAMELEN(var_gv);
OP *assign_op=0, *declare_op=0;
#if DebugNamespaces
if (debug) {
fprintf(stderr, "lookup %c", type==SVt_PV ? '$' : type==SVt_PVAV ? '@' : type==SVt_PVHV ? '%' : '&');
if (CopSTASH_eq(PL_curcop, stash))
fprintf(stderr, "%.*s in %s", varnamelen, varname, HvNAME(stash));
else
fprintf(stderr, "%s::%.*s in %s", HvNAME(stash), varnamelen, varname, CopSTASHPV(PL_curcop));
fprintf(stderr, " at %s, line %d:", CopFILE(PL_curcop), CopLINE(PL_curcop));
}
#endif
if (access_op) {
switch (type) {
case SVt_PV:
declare_op= access_op->op_next->op_type == OP_SASSIGN ? (assign_op=access_op->op_next)->op_next : access_op->op_next;
break;
case SVt_PVAV:
case SVt_PVHV:
declare_op= access_op->op_next->op_type == OP_AASSIGN ? (assign_op=access_op->op_next)->op_next : access_op->op_next;
break;
}
if (declare_op->op_type != OP_GV || GvCV(cGVOPx_gv(declare_op)) != declare_cv)
declare_op=0;
}
if (!pnext_op || CopSTASH_eq(PL_curcop, stash)) {
/* unqualified */
if (declare_op) {
#if DebugNamespaces
if (debug) fprintf(stderr, " - declared here\n"), fflush(stderr);
#endif
if (assign_op) /* change to void context */
assign_op->op_flags ^= OPf_WANT_LIST ^ OPf_WANT_VOID;
declare_op->op_ppaddr=&pp_popmark;
declare_op->op_next=declare_op->op_next->op_next; /* skip entersub */
switch (type) {
case SVt_PV:
GvIMPORTED_SV_on(var_gv);
break;
case SVt_PVAV:
GvIMPORTED_AV_on(var_gv);
break;
case SVt_PVHV:
GvIMPORTED_HV_on(var_gv);
break;
}
return;
}
if (type != SVt_PVCV ||
(GvFLAGS(var_gv) & (GVf_ASSUMECV | GVf_IMPORTED_CV)) != GVf_IMPORTED_CV) {
AV *dotLOOKUP= stash==last_stash ? last_dotLOOKUP : get_dotLOOKUP(stash);
if (dotLOOKUP) {
GV **imp_gvp;
SV **lookp, **endp;
for (lookp=AvARRAY(dotLOOKUP), endp=lookp+AvFILLp(dotLOOKUP); lookp<=endp; ++lookp) {
HV *imp_stash=(HV*)SvRV(*lookp);
#if DebugNamespaces
if (debug) fprintf(stderr, " [%s]", HvNAME(imp_stash));
#endif
if ((imp_gvp=(GV**)hv_fetch(imp_stash, varname, varnamelen, FALSE))) {
GV *imp_gv=*imp_gvp;
CV *imp_cv;
switch (type) {
case SVt_PV:
if (GvIMPORTED_SV(imp_gv)) {
SV *imp_sv=GvSV(imp_gv);
SvREFCNT_dec(GvSV(var_gv));
SvREFCNT_inc(imp_sv);
GvSV(var_gv)=imp_sv;
GvIMPORTED_SV_on(var_gv);
#if DebugNamespaces
if (debug) fprintf(stderr, " - found\n"), fflush(stderr);
#endif
return;
}
break;
case SVt_PVAV:
if (GvIMPORTED_AV(imp_gv)) {
AV *imp_av=GvAV(imp_gv);
SvREFCNT_dec(GvAV(var_gv));
SvREFCNT_inc(imp_av);
GvAV(var_gv)=imp_av;
GvIMPORTED_AV_on(var_gv);
#if DebugNamespaces
if (debug) fprintf(stderr, " - found\n"), fflush(stderr);
#endif
return;
}
break;
case SVt_PVHV:
if (GvIMPORTED_HV(imp_gv)) {
HV *imp_hv=GvHV(imp_gv);
SvREFCNT_dec(GvHV(var_gv));
SvREFCNT_inc(imp_hv);
GvHV(var_gv)=imp_hv;
GvIMPORTED_HV_on(var_gv);
#if DebugNamespaces
if (debug) fprintf(stderr, " - found\n"), fflush(stderr);
#endif
return;
}
break;
case SVt_PVCV:
if ((imp_cv=GvCV(imp_gv))) {
if (CvMETHOD(imp_cv) && pnext_op && (*pnext_op)->op_type == OP_ENTERSUB) {
#if DebugNamespaces
if (debug) fprintf(stderr, " method found (skipping)"), fflush(stderr);
#endif
/* may not discover methods in object-less call */
break;
}
if (!CvROOT(imp_cv) && !CvXSUB(imp_cv) && GvASSUMECV(imp_gv)) {
/* only promised - let's try later, or die if the next op is ENTERSUB */
if (pnext_op) pnext_op=0;
return;
}
SvREFCNT_inc(imp_cv);
GvCV(var_gv)=imp_cv;
GvIMPORTED_CV_on(var_gv); GvASSUMECV_on(var_gv);
#if DebugNamespaces
if (debug) fprintf(stderr, " - found(%s)\n", CvROOT(imp_cv) || CvXSUB(imp_cv) ? "defined" : "undef"), fflush(stderr);
#endif
return;
}
}
}
}
}
}
if (pnext_op) {
/* Nothing found: time to croak... But let's check for exceptions first */
OP *next_gv;
switch (type) {
case SVt_PVCV:
/* new UnqualPackage(arg,...) is often misinterpreted as new(UnqualPackage(arg,...)) */
next_gv=*pnext_op;
if (next_gv->op_type == OP_ENTERSUB &&
(next_gv=next_gv->op_next)->op_type == OP_GV &&
next_gv->op_next->op_type == OP_ENTERSUB) {
OP *pushmark2_op=cUNOPx(next_gv->op_next)->op_first, *pushmark1_op;
if (!pushmark2_op->op_sibling)
pushmark2_op=cUNOPx(pushmark2_op)->op_first;
if ((pushmark1_op=pushmark2_op->op_next)->op_type == OP_PUSHMARK) {
HV *pkg_stash;
#if DebugNamespaces
if (debug) fprintf(stderr, " - trying as class method ");
#endif
if ((pkg_stash=namespace_lookup_class(aTHX_ stash, varname, varnamelen))) {
GV *next_sub=cGVOPx_gv(next_gv);
GV *method_gv=gv_fetchmethod(pkg_stash, GvNAME(next_sub));
if (method_gv) {
CV *method_cv=GvCV(method_gv);
OP *this_gv_op=PL_op,
*class_const_op=newSVOP(OP_CONST, 0, &PL_sv_undef),
*method_const_op=newSVOP(OP_CONST, 0, &PL_sv_undef);
dSP;
EXTEND(SP,2);
/* push the package name under the args, and the method GV on the top */
SV **bottom=PL_stack_base+POPMARK;
while (--SP>bottom) SP[1]=*SP;
varname=HvNAME(pkg_stash);
SP[1]=cSVOPx(class_const_op)->op_sv=newSVpvn_share(varname, strlen(varname), 0);
cSVOPx(method_const_op)->op_sv=SvREFCNT_inc((SV*)method_cv);
*++PL_stack_sp=(SV*)method_cv;
GvIMPORTED_CV_on(var_gv); /* but without ASSUME_CV! */
/* what follows is a fierce reorganization of the op tree */
if (pushmark1_op->op_next == this_gv_op) {
class_const_op->op_next=method_const_op;
class_const_op->op_sibling=method_const_op;
} else {
OP *arg_op=pushmark1_op->op_sibling, *s;
class_const_op->op_next=pushmark1_op->op_next;
class_const_op->op_sibling=arg_op;
while ((s=arg_op->op_sibling)->op_sibling)
arg_op=s;
pushmark1_op->op_sibling=s;
arg_op->op_sibling=method_const_op;
while (!arg_op->op_seq) {
arg_op=cUNOPx(arg_op)->op_first;
while ((s=arg_op->op_sibling))
arg_op=s;
}
while (arg_op->op_next != this_gv_op)
arg_op=arg_op->op_next;
arg_op->op_next=method_const_op;
}
pushmark2_op->op_next=class_const_op;
pushmark2_op->op_sibling=class_const_op;
method_const_op->op_next=next_gv->op_next;
op_free(this_gv_op->op_next);
PL_op=method_const_op;
}
#if DebugNamespaces
else { if (debug) fprintf(stderr, " - but method %.*s not found\n", GvNAMELEN(next_sub), GvNAME(next_sub)); }
#endif
}
#if DebugNamespaces
else { if (debug) fprintf(stderr, " - nowhere\n"); }
#endif
}
}
/* pp_entersub will produce a suitable message when it gets stuck on the undefined sub */
return;
case SVt_PV:
if (varnamelen==8 && *varname=='A' && !memcmp(varname, "AUTOLOAD", 8)
&& GvCV(var_gv)) {
/* allow to use $AUTOLOAD if there is a sub AUTOLOAD */
GvIMPORTED_SV_on(var_gv);
return;
}
if (PL_curstackinfo->si_type == PERLSI_SORT &&
varnamelen==1 && (*varname=='a' || *varname=='b'))
/* allow to use sort placeholders: sort { $a <=> $b } */
return;
break;
case SVt_PVAV:
if (varnamelen==3 && varname[0]=='I' && varname[1]=='S' && varname[2]=='A') {
/* allow to use @ISA */
GvIMPORTED_AV_on(var_gv);
return;
}
}
*pnext_op=die("reference to an undeclared variable %c%.*s",
type==SVt_PV ? '$' : type==SVt_PVAV ? '@' : '%',
varnamelen, varname);
}
#if DebugNamespaces
else
if (debug) fprintf(stderr, " - nowhere\n"), fflush(stderr);
#endif
} else {
/* full qualified, but undeclared */
HV *other_stash;
if (declare_op) {
*pnext_op=die("can't declare variables from other packages");
return;
}
/* check for exceptions */
if (type==SVt_PVHV && varnamelen>=3 && varname[varnamelen-2]==':' && varname[varnamelen-1]==':'
&& GvHV(var_gv) && HvNAME(GvHV(var_gv)))
/* allow to refer to the symbol table of a defined package */
return;
other_stash=namespace_lookup_class(aTHX_ CopSTASH(PL_curcop), HvNAME(stash), strlen(HvNAME(stash)));
if (other_stash && other_stash!=stash) {
GV *imp_gv=*(GV**)hv_fetch(other_stash, varname, varnamelen, TRUE);
I32 other_found=FALSE;
if (SvTYPE(imp_gv) != SVt_PVGV)
gv_init(imp_gv, other_stash, varname, varnamelen, GV_ADDMULTI);
switch (type) {
case SVt_PV:
if (!GvIMPORTED_SV(imp_gv))
lookup(aTHX_ imp_gv, type, 0, 0);
other_found=GvIMPORTED_SV(imp_gv);
break;
case SVt_PVAV:
if (!GvIMPORTED_AV(imp_gv))
lookup(aTHX_ imp_gv, type, 0, 0);
other_found=GvIMPORTED_AV(imp_gv);
break;
case SVt_PVHV:
if (!GvIMPORTED_HV(imp_gv))
lookup(aTHX_ imp_gv, type, 0, 0);
other_found=GvIMPORTED_HV(imp_gv);
break;
case SVt_PVCV:
if (!GvCV(imp_gv))
lookup(aTHX_ imp_gv, type, 0, 0);
other_found=GvCV(imp_gv) != 0;
break;
}
if (other_found) {
dSP;
#if DebugNamespaces
if (debug) fprintf(stderr, " - found in %s\n", HvNAME(GvSTASH(imp_gv))), fflush(stderr);
#endif
SvREFCNT_dec(var_gv);
SvREFCNT_inc(imp_gv);
#ifdef USE_ITHREADS
PAD_SVl(cPADOP->op_padix)=(SV*)imp_gv;
#else
cSVOP->op_sv=(SV*)imp_gv;
#endif
SETs((SV*)imp_gv);
return;
}
}
if (type != SVt_PVCV && hv_exists(stash, dot_import, sizeof(dot_import)-1))
/* complain now if the addressed package is compiled with namespace mode
and we are not looking for a subroutine (otherwise OP_ENTERSUB makes a better message) */
*pnext_op=die("reference to an undeclared variable %c%s::%.*s",
type==SVt_PV ? '$' : type==SVt_PVAV ? '@' : '%',
HvNAME(stash), varnamelen, varname);
}
}
}
SV* try_namespace_lookup(pTHX_ HV *stash, SV *name, I32 type)
{
if (get_dotLOOKUP(stash)) {
STRLEN l;
const char *n=SvPV(name,l);
GV* gv=*(GV**)hv_fetch(stash, n, l, TRUE);
if (SvTYPE(gv) != SVt_PVGV)
gv_init(gv, stash, n, l, GV_ADDMULTI);
lookup(aTHX_ gv, type, 0, 0);
switch (type) {
case SVt_PV:
return GvSV(gv);
case SVt_PVAV:
return (SV*)GvAV(gv);
case SVt_PVHV:
return (SV*)GvHV(gv);
case SVt_PVCV:
return (SV*)GvCV(gv);
case SVt_PVGV:
return (SV*)gv;
}
}
return 0;
}
static
OP* intercept_pp_gv(pTHX)
{
OP *next_op=def_pp_GV(aTHX);
dSP;
GV *var_gv=(GV*)TOPs;
CV *cv;
#ifdef not_PERL_5_8
while (next_op->op_type == OP_NULL)
next_op=next_op->op_next;
#endif
switch (next_op->op_type) {
case OP_RV2SV:
if (!GvIMPORTED_SV(var_gv))
lookup(aTHX_ var_gv, SVt_PV, &next_op, next_op);
break;
case OP_RV2AV:
if (!GvIMPORTED_AV(var_gv))
lookup(aTHX_ var_gv, SVt_PVAV, &next_op, next_op);
break;
case OP_RV2HV:
if (!GvIMPORTED_HV(var_gv))
lookup(aTHX_ var_gv, SVt_PVHV, &next_op, next_op);
break;
case OP_RV2CV:
if ((cv=GvCV(var_gv)) && (next_op->op_next->op_type != OP_REFGEN || CvROOT(cv) || CvXSUB(cv)))
break;
lookup(aTHX_ var_gv, SVt_PVCV, &next_op, 0);
break;
case OP_ENTERSUB:
if (GvCV(var_gv)) {
OP *pushmark=cUNOPx(next_op)->op_first, *meth_op;
if (!pushmark->op_sibling) pushmark=cUNOPx(pushmark)->op_first;
OP *first_arg=pushmark->op_sibling;
#ifdef not_PERL_5_8
FIXME="descend all NULLs";
#endif
if (first_arg->op_next==PL_op && first_arg->op_type==OP_CONST && (first_arg->op_private & OPpCONST_BARE)) {
/* a very special case: `method XXX;' where (another) sub `method' is defined in the current package too */
SV *pkg_name_sv=cSVOPx_sv(first_arg);
HV *pkg_stash=namespace_lookup_class(aTHX_ GvSTASH(var_gv), SvPVX(pkg_name_sv), SvCUR(pkg_name_sv));
if (pkg_stash) {
GV *method_gv=gv_fetchmethod(pkg_stash, GvNAME(var_gv));
if (method_gv) {
CV *method_cv=GvCV(method_gv);
const char *pkg_name=HvNAME(pkg_stash);
SvREFCNT_dec(pkg_name_sv);
cSVOPx(first_arg)->op_sv=TOPm1s=newSVpvn_share(pkg_name, strlen(pkg_name), 0);
SvREFCNT_dec(var_gv);
SvREFCNT_inc((SV*)method_cv);
#ifdef USE_ITHREADS
PAD_SVl(cPADOP->op_padix)=(SV*)method_cv;
#else
cSVOP->op_sv=(SV*)method_cv;
#endif
SETs((SV*)method_cv);
}
}
} else if (pushmark->op_next==PL_op && (meth_op=PL_op->op_next->op_next)->op_type==OP_METHOD_NAMED && CvMETHOD(GvCV(var_gv))) {
/* another suspicious case: `name->method' where sub name is defined as method: look for a namespace `name' first */
HV *pkg_stash=namespace_lookup_class(aTHX_ GvSTASH(var_gv), GvNAME(var_gv), GvNAMELEN(var_gv));
if (pkg_stash) {
SV *pkg_name=newSVpvn_share(HvNAME(pkg_stash), strlen(HvNAME(pkg_stash)), 0);
SvREFCNT_dec(var_gv);
#ifdef USE_ITHREADS
PAD_SVl(cPADOP->op_padix)=pkg_name;
#else
cSVOP->op_sv=pkg_name;
#endif
SETs(pkg_name);
POPMARK;
pushmark->op_ppaddr=&Perl_pp_null; /* skip pushmark and entersub */
PL_op->op_next=meth_op;
PL_op->op_ppaddr=def_pp_GV;
}
}
} else {
lookup(aTHX_ var_gv, SVt_PVCV, &next_op, 0);
}
if (next_op == PL_op->op_next) { /* not changed */
SV *alt_lookup_sv=GvSV(alt_lookup_gv);
if (SvPOK(alt_lookup_sv)) {
HE *alt_stash_ent;
U32 alt_hash;
HV *alt_stash;
SvUPGRADE(alt_lookup_sv, SVt_PVIV);
alt_hash= SvIOKp(alt_lookup_sv) ? SvIV(alt_lookup_sv) : 0;
alt_stash_ent=hv_fetch_ent(GvSTASH(CvGV(GvCV(var_gv))), alt_lookup_sv, FALSE, alt_hash);
if (alt_stash_ent && (alt_stash=GvHV(HeVAL(alt_stash_ent)))) {
GV *alt_gv;
SV **alt_gvp;
if (!alt_hash) {
SvIVX(alt_lookup_sv)=HeHASH(alt_stash_ent);
SvIOK_on(alt_lookup_sv);
}
if ((alt_gvp=hv_fetch(alt_stash, GvNAME(var_gv), GvNAMELEN(var_gv), FALSE)) &&
(alt_gv=(GV*)*alt_gvp, GvCV(alt_gv))) {
SvREFCNT_dec(var_gv);
SvREFCNT_inc(alt_gv);
#ifdef USE_ITHREADS
PAD_SVl(cPADOP->op_padix)=(SV*)alt_gv;
#else
cSVOP->op_sv=(SV*)alt_gv;
#endif
SETs((SV*)alt_gv);
}
}
}
PL_op->op_ppaddr=def_pp_GV;
}
return PL_op->op_next;
}
if (next_op == PL_op->op_next) /* not died */
PL_op->op_ppaddr=def_pp_GV;
return next_op;
}
static
OP* intercept_pp_rv2gv(pTHX)
{
OP *next_op=def_pp_RV2GV(aTHX), *declare_op=0;
I32 defuse=FALSE;
if (next_op->op_type==OP_SASSIGN) {
declare_op=next_op->op_next;
if (declare_op->op_type == OP_GV && GvCV(cGVOPx_gv(declare_op)) == declare_cv) {
dSP;
GV *dst_gv=(GV*)TOPs;
SV *src_sv=TOPm1s;
if (SvROK(src_sv)) {
I32 src_type=SvTYPE(SvRV(src_sv));
switch (src_type) {
case SVt_PVAV:
GvIMPORTED_AV_on(dst_gv);
defuse=TRUE;
break;
case SVt_PVHV:
GvIMPORTED_HV_on(dst_gv);
defuse=TRUE;
break;
default:
if (src_type >= SVt_IV && src_type <= SVt_PVMG) {
GvIMPORTED_SV_on(dst_gv);
defuse=TRUE;
}
break;
}
} else if (SvTYPE(src_sv)==SVt_PVGV) {
defuse=TRUE;
}
}
}
if (defuse) {
if (declare_op->op_ppaddr != &pp_popmark) {
/* change to void context */
next_op->op_flags ^= OPf_WANT_LIST ^ OPf_WANT_VOID;
/* skip entersub */
declare_op->op_ppaddr=&pp_popmark;
declare_op->op_next=declare_op->op_next->op_next;
}
} else {
PL_op->op_ppaddr=def_pp_RV2GV;
}
return next_op;
}
static
OP* intercept_pp_gvsv(pTHX)
{
GV *var_gv=cGVOP_gv;
OP *next_op=0;
if (!GvIMPORTED_SV(var_gv))
lookup(aTHX_ var_gv, SVt_PV, &next_op, PL_op);
if (next_op) return next_op; /* died */
PL_op->op_ppaddr=def_pp_GVSV;
return def_pp_GVSV(aTHX);
}
static
OP* intercept_pp_aelemfast(pTHX)
{
if (!(PL_op->op_flags & OPf_SPECIAL)) {
GV *var_gv=cGVOP_gv;
OP *next_op=0;
if (!GvIMPORTED_AV(var_gv))
lookup(aTHX_ var_gv, SVt_PVAV, &next_op, 0);
if (next_op) return next_op; /* died */
}
PL_op->op_ppaddr=def_pp_AELEMFAST;
return def_pp_AELEMFAST(aTHX);
}
static
AV* get_dotIMPORT(HV *stash, I32 unique)
{
GV *imp_gv=*(GV**)hv_fetch(stash, dot_import, sizeof(dot_import)-1, TRUE);
AV *dotIMPORT=0;
if (SvTYPE(imp_gv)!=SVt_PVGV)
gv_init(imp_gv, stash, dot_import, sizeof(dot_import)-1, GV_ADDMULTI);
else
dotIMPORT=GvAV(imp_gv);
if (!dotIMPORT) {
GV *declare_gv=*(GV**)hv_fetch(stash, declare, sizeof(declare)-1, TRUE);
if (SvTYPE(declare_gv)!=SVt_PVGV)
gv_init(declare_gv, stash, declare, sizeof(declare)-1, GV_ADDMULTI);
sv_setsv((SV*)declare_gv, sv_2mortal(newRV((SV*)declare_cv)));
if (AvFILLp(import_from_av)>=0) {
GvAV(imp_gv)=dotIMPORT=(AV*)SvRV(AvARRAY(import_from_av)[AvFILLp(import_from_av)]);
SvREFCNT_inc(dotIMPORT);
} else {
GvAV(imp_gv)=dotIMPORT=newAV();
}
#if DebugNamespaces
if (debug) fprintf(stderr, "created %s::", HvNAME(stash)), dump_array(dotIMPORT, "IMPORT"), fflush(stderr);
#endif
}
if (unique && SvREFCNT(dotIMPORT)>1) {
SvREFCNT_dec(dotIMPORT);
return (GvAV(imp_gv)=av_make(AvFILLp(dotIMPORT)+1, AvARRAY(dotIMPORT)));
}
return dotIMPORT;
}
static
OP* ck_const(pTHX_ OP *o)
{
if (PL_curcop == &PL_compiling) {
SV *sv=cSVOPo->op_sv;
const char *buf=PL_bufptr;
if (buf && SvPOKp(sv) && buf[0] == 'p' && !strncmp(buf, "package ", 8)) {
HV *stash=gv_stashpvn(SvPVX(sv), SvCUR(sv), TRUE);
if (stash != PL_defstash && stash != PL_debstash)
get_dotIMPORT(stash, FALSE);
}
}
return def_ck_CONST(aTHX_ o);
}
static
void inject_switch_op(pTHX_ OP *o)
{
OP *sw_op=newOP(OP_CUSTOM, 0);
sw_op->op_ppaddr=&switch_off_namespaces;
cUNOPo->op_first=Perl_prepend_elem(aTHX_ OP_LINESEQ, sw_op, cUNOPo->op_first);
}
static
OP* ck_leaveeval(pTHX_ OP *o)
{
inject_switch_op(aTHX_ o);
return def_ck_LEAVEEVAL(aTHX_ o);
}
static
OP* ck_leavesub(pTHX_ OP *o)
{
CV *cv=PL_compcv;
if (CvSPECIAL(cv)) {
GV *gv=CvGV(cv);
if (GvNAMELEN(gv)==5 && !strncmp(GvNAME(gv), "BEGIN", 5)) {
ToRestore *to_restore=newToRestore(aTHX_ TRUE);
#if DebugNamespaces
if (debug) fprintf(stderr, "reset before BEGIN(%s, line %d) cx=%d savesp=%d\n", CopFILE(PL_curcop), CopLINE(PL_curcop), cxstack_ix, PL_savestack_ix), fflush(stderr);
#endif
SAVEDESTRUCTOR_X(&catch_ptrs,to_restore);
sv_setiv(*av_fetch(restores, ++restores_ix, TRUE), cxstack_ix);
sv_setiv(*av_fetch(restores, ++restores_ix, TRUE), PL_savestack_ix);
inject_switch_op(aTHX_ o);
}
}
return def_ck_LEAVESUB(aTHX_ o);
}
static
OP* intercept_ck_glob(pTHX_ OP *o)
{
reset_ptrs(aTHX_ 0);
o=def_ck_GLOB(aTHX_ o);
catch_ptrs(aTHX_ 0);
return o;
}
static
OP* intercept_eval(pTHX)
{
AV *my_imports=get_dotIMPORT(CopSTASH(PL_curcop), FALSE);
ToRestore *to_restore;
OPCODE my_type=PL_op->op_type;
op_fun_ptr my_func=PL_ppaddr[my_type];
OP *next;
#if DebugNamespaces
if (debug) fprintf(stderr, "%s at %s, line %d: enabling namespaces inherited from %s cx=%d\n",
my_type==OP_ENTEREVAL ? "eval" : "regcomp",
CopFILE(PL_curcop), CopLINE(PL_curcop), HvNAME(CopSTASH(PL_curcop)), cxstack_ix),
dump_array(my_imports,"IMPORT"), fflush(stderr);
#endif
if (current_mode())
croak("something wrong here!");
to_restore=newToRestore(aTHX_ FALSE);
av_push(import_from_av, newRV((SV*)my_imports));
catch_ptrs(aTHX_ 0);
next=my_func(aTHX);
reset_ptrs(aTHX_ to_restore);
if (next->op_ppaddr==&switch_off_namespaces) {
next->op_ppaddr=&Perl_pp_null;
next=next->op_next;
}
return next;
}
HV* namespace_lookup_class(pTHX_ HV *stash, const char *class_name, STRLEN class_namelen)
{
HV *imp_class=0;
GV *class_gv, **imp_class_gvp;
size_t l=class_namelen+2;
char smallbuf[64];
char *buf;
if (l<sizeof(smallbuf))
buf=smallbuf;
else
New(0, buf, class_namelen+3, char);
Copy(class_name, buf, l-2, char);
buf[l-2]=':'; buf[l-1]=':';
class_gv=*(GV**)hv_fetch(stash, buf, l, TRUE);
if (SvTYPE(class_gv)==SVt_PVGV) {
imp_class=GvHV(class_gv);
} else {
AV *dotLOOKUP= stash==last_stash ? last_dotLOOKUP : get_dotLOOKUP(stash);
if (dotLOOKUP) {
const char *first_colon=strchr(class_name, ':'), *colon, *last_name=buf;
SV **lookp=AvARRAY(dotLOOKUP), **endp;
if (lookp) {
#if DebugNamespaces
if (debug) fprintf(stderr, "lookup package %.*s in %s at %s, line %d:",
class_namelen, class_name, HvNAME(stash), CopFILE(PL_curcop), CopLINE(PL_curcop));
#endif
for (endp=lookp+AvFILLp(dotLOOKUP); lookp<=endp; ++lookp) {
HV *imp_stash=(HV*)SvRV(*lookp);
#if DebugNamespaces
if (debug) fprintf(stderr, " [%s]", HvNAME(imp_stash));
#endif
if ((colon=first_colon)) {
const char *class_name_part=class_name, *next_colon=colon;
do {
l=(colon=next_colon+2)-class_name_part;
imp_class_gvp=(GV**)hv_fetch(imp_stash, class_name_part, l, FALSE);
if (!imp_class_gvp || !(imp_stash=GvHV(*imp_class_gvp)))
goto NEXT;
} while ((next_colon=strchr((class_name_part=colon), ':')));
last_name=buf+(class_name_part-class_name);
l=class_namelen-(class_name_part-class_name)+2;
}
if ((imp_class_gvp=(GV**)hv_fetch(imp_stash, last_name, l, FALSE)) &&
(imp_class=GvHV(*imp_class_gvp)))
break;
NEXT:;
}
}
}
if (!imp_class) imp_class=gv_stashpvn(class_name, class_namelen, FALSE);
gv_init(class_gv, stash, buf, l+2, GV_ADDMULTI);
if (imp_class)
GvHV(class_gv)=(HV*)SvREFCNT_inc(imp_class);
#if DebugNamespaces
if (debug) {
if (imp_class)
fprintf(stderr, " - found(%s)\n", HvNAME(imp_class));
else
fprintf(stderr, " - nowhere\n");
fflush(stderr);
}
#endif
}
if (buf != smallbuf) Safefree(buf);
return imp_class;
}
static
OP* pp_instance_of(pTHX)
{
dSP; dTOPss;
HV *class=(HV*)cSVOP_sv;
if (SvRV(sv) && SvOBJECT(sv) && SvSTASH(sv)==class) {
SETs(&PL_sv_yes);
} else {
I32 answer=sv_derived_from(sv, HvNAME(class));
SPAGAIN;
SETs(answer ? &PL_sv_yes : &PL_sv_no);
}
return NORMAL;
}
static
OP* pp_class_method(pTHX)
{
dSP;
SV *method_name=cSVOP_sv;
SV *first_arg=PL_stack_base[TOPMARK+1];
const char *class_name=SvPVX(first_arg);
STRLEN l=SvCUR(first_arg), prefix=0;
HV *class;
GV *method_gv;
if (class_name[0]==':' && class_name[1]==':') {
prefix=2;
} else if (l>6 && class_name[4]==':' && class_name[0]=='m' && !memcmp(class_name, "main::", 6)) {
prefix=6;
}
if (prefix) {
class=gv_stashpvn(class_name+prefix, l-prefix, FALSE);
} else {
class=namespace_lookup_class(aTHX_ CopSTASH(PL_curcop), class_name, l);
}
if (!class)
croak("Package \"%.*s\" does not exist", SvCUR(first_arg), SvPVX(first_arg));
if ((method_gv=gv_fetchmethod(class, SvPVX(method_name)))) {
CV *method_cv=GvCV(method_gv);
OP *o=PL_op;
Perl_op_clear(aTHX_ o);
o->op_ppaddr=PL_ppaddr[OP_CONST];
o->op_type=OP_CONST;
o->op_flags=OPf_WANT_SCALAR;
cSVOPo->op_sv=SvREFCNT_inc((SV*)method_cv);
SPAGAIN;
XPUSHs((SV*)method_cv);
if (!prefix && (l=strlen(class_name=HvNAME(class)))!=SvCUR(first_arg)) {
o=cUNOPx(PL_op->op_next)->op_first->op_sibling;
Perl_op_clear(aTHX_ o);
cSVOPo->op_sv=PL_stack_base[TOPMARK+1]=newSVpvn_share(class_name, l, 0);
}
} else if (SvCUR(method_name)==sizeof(instanceof)-1 && !memcmp(SvPVX(method_name),instanceof,sizeof(instanceof)-1)) {
SPAGAIN;
if (PL_stack_base+TOPMARK+2==SP) {
OP *o=PL_op, *sub_op=o->op_next;
Perl_op_clear(aTHX_ o);
o->op_ppaddr=&pp_instance_of;
cSVOPo->op_sv=SvREFCNT_inc((SV*)class);
o->op_next=sub_op->op_next; /* skip ENTERSUB */
o=cUNOPx(sub_op)->op_first;
if (!o->op_sibling) o=cUNOPo->op_first;
o->op_ppaddr=&Perl_pp_null; /* suppress PUSHMARK, skip CONST(package_name) */
o->op_next=o->op_next->op_next;
SP[-1]=SP[0]; --SP;
POPMARK; PUTBACK;
return pp_instance_of(aTHX);
} else {
croak("usage: instanceof CLASS $object");
}
} else {
croak("Can't locate object method \"%.*s\" via package \"%s\"",
SvCUR(method_name), SvPVX(method_name), HvNAME(class));
}
RETURN;
}
static
OP* ck_sub(pTHX_ OP* o)
{
if (PL_curstash!=PL_defstash &&
(o->op_flags & (OPf_STACKED | OPf_KIDS)) == (OPf_STACKED | OPf_KIDS)) {
OP *arg=cUNOPo->op_first->op_sibling;
if (arg && arg->op_type == OP_CONST && (arg->op_private & OPpCONST_BARE)) {
while ((arg=arg->op_sibling)) {
if (arg->op_type == OP_METHOD_NAMED) {
arg->op_ppaddr=&pp_class_method;
break;
}
}
}
}
return def_ck_ENTERSUB(aTHX_ o);
}
static
void catch_ptrs(pTHX_ void *to_restore)
{
if (!to_restore || !current_mode()) {
PL_ppaddr[OP_GV] =&intercept_pp_gv;
PL_ppaddr[OP_GVSV] =&intercept_pp_gvsv;
PL_ppaddr[OP_RV2GV] =&intercept_pp_rv2gv;
PL_ppaddr[OP_AELEMFAST]=&intercept_pp_aelemfast;
PL_ppaddr[OP_ENTEREVAL]=&intercept_eval;
PL_ppaddr[OP_REGCOMP] =&intercept_eval;
PL_check[OP_CONST] =&ck_const;
PL_check[OP_ENTERSUB] =&ck_sub;
PL_check[OP_LEAVESUB] =&ck_leavesub;
PL_check[OP_LEAVEEVAL] =&ck_leaveeval;
PL_check[OP_GLOB] =&intercept_ck_glob;
}
if (to_restore) {
#if DebugNamespaces
if (debug) fprintf(stderr, "catch executed in cx=%d scope=%d savesp=%d ptr=%p\n", cxstack_ix, PL_scopestack_ix, PL_savestack_ix, to_restore), fflush(stderr);
#endif
finish_undo(aTHX_ (ToRestore*)to_restore);
} else {
PL_hints &= ~HINT_STRICT_VARS;
}
}
static
void reset_ptrs(pTHX_ void *to_restore)
{
if (!to_restore || current_mode()) {
PL_ppaddr[OP_GV] =def_pp_GV;
PL_ppaddr[OP_GVSV] =def_pp_GVSV;
PL_ppaddr[OP_RV2GV] =def_pp_RV2GV;
PL_ppaddr[OP_AELEMFAST]=def_pp_AELEMFAST;
PL_ppaddr[OP_ENTEREVAL]=def_pp_ENTEREVAL;
PL_ppaddr[OP_REGCOMP] =def_pp_REGCOMP;
PL_check[OP_CONST] =def_ck_CONST;
PL_check[OP_ENTERSUB] =def_ck_ENTERSUB;
PL_check[OP_LEAVESUB] =def_ck_LEAVESUB;
PL_check[OP_LEAVEEVAL] =def_ck_LEAVEEVAL;
PL_check[OP_GLOB] =def_ck_GLOB;
}
if (to_restore) {
#if DebugNamespaces
if (debug) fprintf(stderr, "restore executed in cx=%d scope=%d savesp=%d ptr=%p\n", cxstack_ix, PL_scopestack_ix, PL_savestack_ix, to_restore), fflush(stderr);
#endif
finish_undo(aTHX_ (ToRestore*)to_restore);
} else {
PL_hints |= HINT_STRICT_VARS;
}
}
#ifndef PERL_UNUSED_VAR
# define PERL_UNUSED_VAR(var) if (0) var = var
#endif
#line 1280 "namespaces.c"
XS(XS_namespaces_import); /* prototype to pass -Wmissing-prototypes */
XS(XS_namespaces_import)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
PERL_UNUSED_VAR(cv); /* -W */
{
#line 1273 "namespaces.xs"
{
ToRestore *to_restore=insert_undo(aTHX_ FALSE);
AV *new_imports=newAV();
I32 i;
for (i=1; i<items; ++i) {
STRLEN l;
const char *n=SvPV(ST(i),l);
HV *imp_stash=gv_stashpvn(n, l, FALSE);
if (imp_stash)
av_push(new_imports, newRV((SV*)imp_stash));
}
if (to_restore) {
if (items>1) {
}
} else {
catch_ptrs(aTHX_ 0);
av_push(import_from_av, newRV_noinc((SV*)new_imports));
}
}
#line 1312 "namespaces.c"
}
XSRETURN_EMPTY;
}
XS(XS_namespaces_unimport); /* prototype to pass -Wmissing-prototypes */
XS(XS_namespaces_unimport)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
PERL_UNUSED_VAR(cv); /* -W */
{
#line 1296 "namespaces.xs"
{
if (items>1) {
/* just remove some packages from the global import list */
if (AvFILLp(import_from_av)>=0) {
AV *cur_imports=(AV*)SvRV(AvARRAY(import_from_av)[AvFILLp(import_from_av)]);
SV **impp=AvARRAY(cur_imports), **end;
if (impp) {
AV *new_imports=newAV();
I32 i, last_found=0;
ANY *saves;
for (i=1; i<items; ++i) {
STRLEN l;
const char *n=SvPV(ST(i),l);
HV *imp_stash=gv_stashpvn(n, l, FALSE);
if (imp_stash) {
ST(last_found)=(SV*)imp_stash; ++last_found;
}
}
for (end=impp+AvFILLp(cur_imports); impp<=end; ++impp) {
HV *imp=(HV*)SvRV(*impp);
for (i=0; i<last_found && imp!=(HV*)ST(i); ++i) ;
if (i==last_found)
av_push(new_imports, newRV((SV*)imp));
}
av_push(import_from_av, newRV_noinc((SV*)new_imports));
if ((saves=find_undo(aTHX_ 0)))
((ToRestore*)saves[1].any_ptr)->import_from_level++;
}
}
} else {
/* switch off the namespace compilation mode for the rest of the lex. scope */
insert_undo(aTHX_ FALSE);
}
XSRETURN_EMPTY;
}
#line 1364 "namespaces.c"
}
XSRETURN(1);
}
XS(XS_namespaces_temp_disable); /* prototype to pass -Wmissing-prototypes */
XS(XS_namespaces_temp_disable)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
if (items != 0)
Perl_croak(aTHX_ "Usage: %s(%s)", "namespaces::temp_disable", "");
PERL_UNUSED_VAR(cv); /* -W */
{
#line 1335 "namespaces.xs"
{
if (current_mode()) {
reset_ptrs(aTHX_ 0);
LEAVE;
SAVEDESTRUCTOR_X(&catch_ptrs,0);
ENTER;
}
}
#line 1391 "namespaces.c"
}
XSRETURN_EMPTY;
}
XS(XS_namespaces_using); /* prototype to pass -Wmissing-prototypes */
XS(XS_namespaces_using)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
if (items < 1)
Perl_croak(aTHX_ "Usage: %s(%s)", "namespaces::using", "dst, ...");
PERL_UNUSED_VAR(cv); /* -W */
{
SV * dst = ST(0);
#line 1348 "namespaces.xs"
{
HV *caller_stash=
(SvCUR(dst)==10 && !memcmp(SvPVX(dst),"namespaces",10))
? (last_stash=0, CopSTASH(PL_curcop))
: gv_stashpvn(SvPVX(dst), SvCUR(dst), TRUE);
I32 i;
AV *dotLOOKUP, *dotIMPORT;
GV **av_gvp=(GV**)hv_fetch(caller_stash, dot_lookup, sizeof(dot_lookup)-1, FALSE);
if (av_gvp && SvTYPE(*av_gvp) == SVt_PVGV && (dotLOOKUP=GvAV(*av_gvp))) {
for (i=1; i<items; ++i) {
STRLEN l;
const char *n=SvPV(ST(i),l);
HV *imp_stash=gv_stashpvn(n, l, FALSE);
if (!imp_stash)
croak("package not found: %.*s", l, n);
if (imp_stash != caller_stash && append_imp_stash(dotLOOKUP, imp_stash)) {
AV *imp_dotLOOKUP=get_dotLOOKUP(imp_stash);
if (imp_dotLOOKUP) append_lookup(caller_stash, dotLOOKUP, imp_dotLOOKUP);
}
}
#if DebugNamespaces
if (debug) fprintf(stderr, "added to %s::", HvNAME(caller_stash)), dump_array(dotLOOKUP, "LOOKUP"), fflush(stderr);
#endif
} else {
dotIMPORT=get_dotIMPORT(caller_stash, TRUE);
for (i=1; i<items; ++i) {
STRLEN l;
const char *n=SvPV(ST(i),l);
HV *imp_stash=gv_stashpvn(n, l, FALSE);
if (!imp_stash)
croak("package not found: %.*s", l, n);
if (imp_stash != caller_stash)
av_push(dotIMPORT, newRV((SV*)imp_stash));
}
#if DebugNamespaces
if (debug) fprintf(stderr, "added to %s::", HvNAME(caller_stash)), dump_array(dotIMPORT, "IMPORT"), fflush(stderr);
#endif
}
}
#line 1452 "namespaces.c"
}
XSRETURN_EMPTY;
}
XS(XS_namespaces_lookup_sub); /* prototype to pass -Wmissing-prototypes */
XS(XS_namespaces_lookup_sub)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
if (items != 2)
Perl_croak(aTHX_ "Usage: %s(%s)", "namespaces::lookup_sub", "pkg, subname");
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
SV * pkg = ST(0);
SV * subname = ST(1);
#line 1394 "namespaces.xs"
{
STRLEN l;
const char *n;
HV *stash;
int wantarray=GIMME==G_ARRAY;
int owner_status=0;
if (SvROK(pkg)) {
stash=SvSTASH(SvRV(pkg));
} else {
n=SvPV(pkg,l);
stash=gv_stashpvn(n, l, FALSE);
}
if (stash) {
GV *gv;
CV *cv;
n=SvPV(subname,l);
gv=*(GV**)hv_fetch(stash, n, l, TRUE);
if (SvTYPE(gv) != SVt_PVGV)
gv_init(gv, stash, n, l, GV_ADDMULTI);
else if (wantarray && GvCV(gv))
owner_status= GvIMPORTED_CV(gv) ? 2 : 1;
lookup(aTHX_ gv, SVt_PVCV, 0, 0);
cv=GvCV(gv);
if (cv && (CvROOT(cv) || CvXSUB(cv))) {
PUSHs(sv_2mortal(newRV((SV*)cv)));
if (wantarray) {
PUSHs(sv_2mortal(newSViv(owner_status)));
XSRETURN(2);
} else {
XSRETURN(1);
}
}
}
XSRETURN_EMPTY;
}
#line 1511 "namespaces.c"
PUTBACK;
return;
}
}
XS(XS_namespaces_lookup_class); /* prototype to pass -Wmissing-prototypes */
XS(XS_namespaces_lookup_class)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
if (items < 2)
Perl_croak(aTHX_ "Usage: %s(%s)", "namespaces::lookup_class", "pkg, class_name, ...");
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
SV * pkg = ST(0);
SV * class_name = ST(1);
#line 1436 "namespaces.xs"
{
STRLEN l;
const char *n;
HV *class_stash, *stash;
if (SvROK(pkg)) {
stash=SvSTASH(SvRV(pkg));
} else {
n=SvPV(pkg,l);
stash=gv_stashpvn(n, l, FALSE);
}
n=SvPV(class_name,l);
if (stash && (class_stash=namespace_lookup_class(aTHX_ stash, n, l))) {
if (items==3 && SvTRUE(ST(2)))
PUSHs(sv_2mortal(newRV((SV*)class_stash)));
else
PUSHs(sv_2mortal(newSVpv(HvNAME(class_stash), 0)));
XSRETURN(1);
}
class_stash=gv_stashpvn(n, l, FALSE);
if (class_stash) {
ST(0)=ST(1);
XSRETURN(1);
}
XSRETURN_UNDEF;
}
#line 1560 "namespaces.c"
PUTBACK;
return;
}
}
XS(XS_namespaces_declare); /* prototype to pass -Wmissing-prototypes */
XS(XS_namespaces_declare)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
PERL_UNUSED_VAR(cv); /* -W */
{
#line 1465 "namespaces.xs"
{
croak("multiple declaration of a variable");
}
items=0;
#line 1582 "namespaces.c"
}
XSRETURN_EMPTY;
}
#ifdef __cplusplus
extern "C"
#endif
XS(boot_namespaces); /* prototype to pass -Wmissing-prototypes */
XS(boot_namespaces)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
char* file = __FILE__;
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(items); /* -W */
XS_VERSION_BOOTCHECK ;
newXS("namespaces::import", XS_namespaces_import, file);
newXS("namespaces::unimport", XS_namespaces_unimport, file);
newXS("namespaces::temp_disable", XS_namespaces_temp_disable, file);
newXS("namespaces::using", XS_namespaces_using, file);
newXS("namespaces::lookup_sub", XS_namespaces_lookup_sub, file);
newXS("namespaces::lookup_class", XS_namespaces_lookup_class, file);
newXS("namespaces::declare", XS_namespaces_declare, file);
/* Initialisation Section */
#line 1471 "namespaces.xs"
{
last_stash=0;
import_from_av=get_av("namespaces::IMPORT_FROM", TRUE);
declare_cv=get_cv("namespaces::declare", FALSE);
alt_lookup_gv=gv_fetchpv("namespaces::alt_lookup", TRUE, SVt_PV);
restores=newAV();
if (PL_DBgv) {
CvFLAGS(get_cv("namespaces::import", FALSE)) |= CVf_NODEBUG;
CvFLAGS(get_cv("namespaces::unimport", FALSE)) |= CVf_NODEBUG;
CvFLAGS(get_cv("namespaces::temp_disable", FALSE)) |= CVf_NODEBUG;
skip_debug_cx=TRUE;
}
#if DebugNamespaces
debug=getenv("POLYMAKE_DEBUG_NAMESPACES")!=0;
#endif
def_pp_GV =PL_ppaddr[OP_GV];
def_pp_GVSV =PL_ppaddr[OP_GVSV];
def_pp_RV2GV =PL_ppaddr[OP_RV2GV];
def_pp_AELEMFAST=PL_ppaddr[OP_AELEMFAST];
def_pp_ENTEREVAL=PL_ppaddr[OP_ENTEREVAL];
def_pp_REGCOMP =PL_ppaddr[OP_REGCOMP];
def_ck_CONST =PL_check[OP_CONST];
def_ck_ENTERSUB =PL_check[OP_ENTERSUB];
def_ck_LEAVESUB =PL_check[OP_LEAVESUB];
def_ck_LEAVEEVAL=PL_check[OP_LEAVEEVAL];
def_ck_GLOB =PL_check[OP_GLOB];
}
#line 1644 "namespaces.c"
/* End of Initialisation Section */
XSRETURN_YES;
}
syntax highlighted by Code2HTML, v. 0.9.1