自学教程：C++ sv_2mortal函数代码示例

// create a new coroSV * coroae_coro_new(CV *block) {	SV *newobj = NULL;	dSP;        ENTER;        SAVETMPS;        PUSHMARK(SP);        XPUSHs(sv_2mortal(newSVpv( "Coro", 4)));        XPUSHs(newRV_inc((SV *)block));        PUTBACK;        call_method("new", G_SCALAR);        SPAGAIN;        if(SvTRUE(ERRSV)) {                uwsgi_log("[uwsgi-perl error] %s", SvPV_nolen(ERRSV));        }        else {                newobj = SvREFCNT_inc(POPs);        }	PUTBACK;        FREETMPS;        LEAVE;	return newobj;}

void owl_perlconfig_new_command(const char *name){  dSP;  ENTER;  SAVETMPS;  PUSHMARK(SP);  XPUSHs(sv_2mortal(owl_new_sv(name)));  PUTBACK;  call_pv("BarnOwl::Hooks::_new_command", G_SCALAR|G_VOID);  SPAGAIN;  if(SvTRUE(ERRSV)) {    owl_function_error("%s", SvPV_nolen(ERRSV));  }  FREETMPS;  LEAVE;}

static SV *fold_results(I32 count){    dSP;    SV *retval = &PL_sv_undef;    if (count > 1) {        /* convert multiple return items into a list reference */        AV *av = newAV();        SV *last_sv = &PL_sv_undef;        SV *sv = &PL_sv_undef;        I32 i;        av_extend(av, count - 1);        for(i = 1; i <= count; i++) {            last_sv = sv;            sv = POPs;            if (SvOK(sv) && !av_store(av, count - i, SvREFCNT_inc(sv)))                SvREFCNT_dec(sv);        }        PUTBACK;        retval = sv_2mortal((SV *) newRV_noinc((SV *) av));        if (!SvOK(sv) || sv == &PL_sv_undef) {            /* if first element was undef, die */            croak(ERRMSG "Call error");        }        return retval;    }    else {        if (count)            retval = POPs;        PUTBACK;        return retval;    }}

staticXS (XS_Xchat_get_info){	SV *temp = NULL;	dXSARGS;	if (items != 1) {		hexchat_print (ph, "Usage: Xchat::get_info(id)");	} else {		SV *id = ST (0);		const char *RETVAL;		RETVAL = hexchat_get_info (ph, SvPV_nolen (id));		if (RETVAL == NULL) {			XSRETURN_UNDEF;		}		if (!strncmp ("win_ptr", SvPV_nolen (id), 7)			|| !strncmp ("gtkwin_ptr", SvPV_nolen (id), 10))		{			XSRETURN_IV (PTR2IV (RETVAL));		} else {						if (				!strncmp ("libdirfs", SvPV_nolen (id), 8) ||				!strncmp ("xchatdirfs", SvPV_nolen (id), 10) ||				!strncmp ("configdir", SvPV_nolen (id), 9)			) {				XSRETURN_PV (RETVAL);			} else {				temp = newSVpv (RETVAL, 0);				SvUTF8_on (temp);				PUSHMARK (SP);				XPUSHs (sv_2mortal (temp));				PUTBACK;			}		}	}}

void Embperl::dosub(const char * subname, const std::vector<std::string> * args, int mode){//as seen in perlembed docs#if EQDEBUG >= 5	if(InUse()) {		LogFile->write(EQEMuLog::Debug, "Warning: Perl dosub called for %s when perl is allready in use./n", subname);	}#endif	in_use = true;	bool err = false;	dSP;                            /* initialize stack pointer      */	ENTER;                          /* everything created after here */	SAVETMPS;                       /* ...is a temporary variable.   */	PUSHMARK(SP);                   /* remember the stack pointer    */	if(args && args->size())	{		for(std::vector<std::string>::const_iterator i = args->begin(); i != args->end(); ++i)		{/* push the arguments onto the perl stack  */			XPUSHs(sv_2mortal(newSVpv(i->c_str(), i->length())));		}	}	PUTBACK;                      /* make local stack pointer global */	call_pv(subname, mode); /*eval our code*/	SPAGAIN;                        /* refresh stack pointer         */	if(SvTRUE(ERRSV))	{		err = true;	}	FREETMPS;                       /* free temp values        */	LEAVE;                       /* ...and the XPUSHed "mortal" args.*/	in_use = false;	if(err)	{		errmsg = "Perl runtime error: ";		errmsg += SvPVX(ERRSV);		throw errmsg.c_str();	}}

void ht_to_perl_ht(HV *perl_ht, struct hashtable *params) {    if (!hashtable_count(params)) return;    struct hashtable_itr *itr;    itr = hashtable_iterator(params);    do {        char *param = hashtable_iterator_key(itr);        char *value = hashtable_iterator_value(itr);                // check if key already exists        if (hv_exists(perl_ht, param, strlen(param))) {            fprintf(stderr, "Parameter '%s' is already defined. Ignoring./n", param);            continue;        }        hv_store(perl_ht, param, strlen(param),            sv_2mortal(newSVpv(value, 0)), 0);            } while (hashtable_iterator_advance(itr));    free(itr);}

static voiddestroy_package(const char *package){	dSP;	PERL_SET_CONTEXT(my_perl);	SPAGAIN;	ENTER;	SAVETMPS;	PUSHMARK(SP);	XPUSHs(sv_2mortal(newSVpv(package, strlen(package))));	PUTBACK;	perl_call_pv("Purple::PerlLoader::destroy_package",	             G_VOID | G_EVAL | G_DISCARD);	SPAGAIN;	PUTBACK;	FREETMPS;	LEAVE;}

SV*ffi_pl_custom_perl(SV *subref, SV *in_arg, int i){  if(subref == NULL)  {    return newSVsv(in_arg);  }  else  {    dSP;    int count;    SV *out_arg;    ENTER;    SAVETMPS;    PUSHMARK(SP);    XPUSHs(in_arg);    XPUSHs(sv_2mortal(newSViv(i)));    PUTBACK;    count = call_sv(subref, G_ARRAY);    SPAGAIN;    if(count >= 1)      out_arg = SvREFCNT_inc(POPs);    else      out_arg = NULL;    PUTBACK;    FREETMPS;    LEAVE;    return out_arg;  }}

void IvrPython::onNotify(AmSessionEvent* event) {   if (onNotifyCallback == NULL) {    DBG("IvrPython::onNotify, but script did not set onNotify callback!/n");    return;  }  DBG("IvrPython::onNotify(): calling onNotifyCallback .../n");#ifndef IVR_PERL  PyThreadState* pyThreadState;  if ( (pyThreadState = Py_NewInterpreter()) != NULL){    PyObject *arglist;    PyObject *result;    arglist = Py_BuildValue("(s)", event->request.getBody().c_str());;    result = PyEval_CallObject(onNotifyCallback, arglist);    Py_DECREF(arglist);    if (result == NULL) {      DBG("Calling IVR" SCRIPT_TYPE "onNotify failed./n");      // PyErr_Print();      return ;    }    Py_DECREF(result);  }  Py_EndInterpreter(pyThreadState);#else   //IVR_PERL	PERL_SET_CONTEXT(my_perl_interp);	DBG("context is %ld/n", (long) Perl_get_context());	dSP ;	ENTER ;	SAVETMPS ;	PUSHMARK(SP) ;	XPUSHs(sv_2mortal(newSVpv((event->request.getBody().c_str()), 0)));	PUTBACK ;	call_pv(onNotifyCallback, G_DISCARD);	FREETMPS ;	LEAVE ;#endif	//IVR_PERL}

PJS_EXTERN SV *PJS_CallPerlMethod(    pTHX_    JSContext *cx,    const char *method,    ...) {    dSP;    va_list ap;    SV *arg, *ret;    PJS_Context *pcx = PJS_GET_CONTEXT(cx);    ENTER;    SAVETMPS;    PUSHMARK(SP);        sv_setiv(save_scalar(PJS_Context_SV), PTR2IV(pcx));    va_start(ap, method);    while( (arg = va_arg(ap, SV*)) ) XPUSHs(arg);    va_end(ap);    PUTBACK;    call_method(method, G_SCALAR | G_EVAL);    ret = newSVsv(*PL_stack_sp--);    FREETMPS;    LEAVE;    if (SvTRUE(ERRSV)) {	sv_free(ret); // Don't want leaks	propagate2JS(aTHX_ pcx, NULL);	return NULL;    }    return sv_2mortal(ret);}

/* caller must free the result */CALLER_OWN char *owl_perlconfig_perlcmd(const owl_cmd *cmd, int argc, const char *const *argv){  int i, count;  char * ret = NULL;  SV *rv;  dSP;  ENTER;  SAVETMPS;  PUSHMARK(SP);  for(i=0;i<argc;i++) {    XPUSHs(sv_2mortal(owl_new_sv(argv[i])));  }  PUTBACK;  count = call_sv(cmd->cmd_perl, G_SCALAR|G_EVAL);  SPAGAIN;  if(SvTRUE(ERRSV)) {    owl_function_error("%s", SvPV_nolen(ERRSV));    (void)POPs;  } else {    if(count != 1)      croak("Perl command %s returned more than one value!", cmd->name);    rv = POPs;    if(SvTRUE(rv)) {      ret = g_strdup(SvPV_nolen(rv));    }  }  FREETMPS;  LEAVE;  return ret;}

JSObject*PJS_InitPerlSubClass(    pTHX_    JSContext *cx,    JSObject *global) {    CV *pcv = get_cv(NAMESPACE"PerlSub::prototype", 0);    JSObject *proto;    if(pcv && (CvROOT(pcv) || CvXSUB(pcv))) {	proto = JS_InitClass(	    cx,	    global,	    PJS_GetPackageObject(aTHX_ cx, PerlSubPkg),	    &perlsub_class,	    PerlSub, 1, 	    NULL, NULL,	    NULL, NULL	);	return PJS_CreateJSVis(aTHX_ cx, proto,	                       sv_2mortal(newRV_inc((SV *)pcv)));    }    croak("Can't locate PerlSub::prototype");    return NULL;}

staticXS (XS_Xchat_get_prefs){	const char *str;	int integer;	SV *temp = NULL;	dXSARGS;	if (items != 1) {		xchat_print (ph, "Usage: Xchat::get_prefs(name)");	} else {		switch (xchat_get_prefs (ph, SvPV_nolen (ST (0)), &str, &integer)) {		case 0:			XSRETURN_UNDEF;			break;		case 1:			temp = newSVpv (str, 0);			SvUTF8_on (temp);			SP -= items;			sp = mark;			XPUSHs (sv_2mortal (temp));			PUTBACK;			break;		case 2:			XSRETURN_IV (integer);			break;		case 3:			if (integer) {				XSRETURN_YES;			} else {				XSRETURN_NO;			}		}	}}

intreport_cluster_rec_list_to_av(List list, AV* av){    HV* rh;    ListIterator itr = NULL;    slurmdb_report_cluster_rec_t* rec = NULL;    if (list) {	itr = slurm_list_iterator_create(list);	while ((rec = slurm_list_next(itr))) {	    rh = (HV*)sv_2mortal((SV*)newHV());	    if (report_cluster_rec_to_hv(rec, rh) < 0) {		Perl_warn(aTHX_ "Failed to convert a report_cluster_rec to a hv");		slurm_list_iterator_destroy(itr);		return -1;	    } else {		av_push(av, newRV((SV*)rh));	    }	}	slurm_list_iterator_destroy(itr);    }    return 0;}

static SV *coroae_add_watcher(int fd, SV *cb) {        SV *newobj;        dSP;        ENTER;        SAVETMPS;        PUSHMARK(SP);        XPUSHs(sv_2mortal(newSVpv( "AnyEvent", 8)));        XPUSHs(sv_2mortal(newSVpv( "fh", 2)));        XPUSHs(sv_2mortal(newSViv(fd)));        XPUSHs(sv_2mortal(newSVpv( "poll", 4)));        XPUSHs(sv_2mortal(newSVpv( "r", 1)));        XPUSHs(sv_2mortal(newSVpv( "cb", 2)));        XPUSHs(newRV_inc(cb));        PUTBACK;        call_method( "io", G_SCALAR);        SPAGAIN;	if(SvTRUE(ERRSV)) {		// no need to continue...                uwsgi_log("[uwsgi-perl error] %s", SvPV_nolen(ERRSV));		exit(1);        }	else {        	newobj = SvREFCNT_inc(POPs);	}        PUTBACK;        FREETMPS;        LEAVE;        return newobj;}

static void perl_call_signal(PERL_SCRIPT_REC *script, SV *func,			     int signal_id, gconstpointer *args){	dSP;	PERL_SIGNAL_ARGS_REC *rec;	SV *sv, *perlarg, *saved_args[SIGNAL_MAX_ARGUMENTS];	AV *av;        void *arg;	int n;	ENTER;	SAVETMPS;	PUSHMARK(sp);	/* push signal argument to perl stack */	rec = perl_signal_args_find(signal_id);        memset(saved_args, 0, sizeof(saved_args));	for (n = 0; n < SIGNAL_MAX_ARGUMENTS &&		    rec != NULL && rec->args[n] != NULL; n++) {		arg = (void *) args[n];                if (strncmp(rec->args[n], "glistptr_", 9) == 0) {			/* pointer to linked list - push as AV */			GList *tmp, **ptr;                        int is_iobject, is_str;                        is_iobject = strcmp(rec->args[n]+9, "iobject") == 0;                        is_str = strcmp(rec->args[n]+9, "char*") == 0;			av = newAV();			ptr = arg;			for (tmp = *ptr; tmp != NULL; tmp = tmp->next) {				sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) :					is_str ? new_pv(tmp->data) :					irssi_bless_plain(rec->args[n]+9, tmp->data);				av_push(av, sv);			}			saved_args[n] = perlarg = newRV_noinc((SV *) av);                } else if (strcmp(rec->args[n], "int") == 0)                        perlarg = newSViv((IV)arg);                else if (arg == NULL)                        perlarg = &PL_sv_undef;                else if (strcmp(rec->args[n], "string") == 0)                        perlarg = new_pv(arg);                else if (strcmp(rec->args[n], "ulongptr") == 0)                        perlarg = newSViv(*(unsigned long *) arg);                else if (strcmp(rec->args[n], "intptr") == 0)                        saved_args[n] = perlarg = newRV_noinc(newSViv(*(int *) arg));                else if (strncmp(rec->args[n], "gslist_", 7) == 0) {			/* linked list - push as AV */			GSList *tmp;			int is_iobject;                        is_iobject = strcmp(rec->args[n]+7, "iobject") == 0;			av = newAV();			for (tmp = arg; tmp != NULL; tmp = tmp->next) {				sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) :					irssi_bless_plain(rec->args[n]+7, tmp->data);				av_push(av, sv);			}			perlarg = newRV_noinc((SV *) av);		} else if (strcmp(rec->args[n], "iobject") == 0) {			/* "irssi object" - any struct that has			   "int type; int chat_type" as it's first			   variables (server, channel, ..) */			perlarg = iobject_bless((SERVER_REC *) arg);		} else if (strcmp(rec->args[n], "siobject") == 0) {			/* "simple irssi object" - any struct that has			   int type; as it's first variable (dcc) */			perlarg = simple_iobject_bless((SERVER_REC *) arg);		} else {			/* blessed object */			perlarg = plain_bless(arg, rec->args[n]);		}		XPUSHs(sv_2mortal(perlarg));	}	PUTBACK;	perl_call_sv(func, G_EVAL|G_DISCARD);	SPAGAIN;	if (SvTRUE(ERRSV)) {		char *error = g_strdup(SvPV_nolen(ERRSV));		signal_emit("script error", 2, script, error);                g_free(error);                rec = NULL;	}        /* restore arguments the perl script modified */	for (n = 0; n < SIGNAL_MAX_ARGUMENTS &&		    rec != NULL && rec->args[n] != NULL; n++) {		arg = (void *) args[n];		if (saved_args[n] == NULL)//.........这里部分代码省略.........

/* * Run function, with current SIP message as a parameter */int perl_exec(struct sip_msg* _msg, str* _fnc_s, str* mystr){	int retval;	SV *m;	str reason;	str pfnc, pparam;	char *fnc;	fnc = pkg_malloc(_fnc_s->len);	if (!fnc) {		LM_ERR("No more pkg mem!/n");		return -1;	}	memcpy(fnc, _fnc_s->s, _fnc_s->len);	fnc[_fnc_s->len] = 0;	dSP;	if (!perl_checkfnc(fnc)) {		LM_ERR("unknown perl function called./n");		reason.s = "Internal error";		reason.len = sizeof("Internal error")-1;		if (sigb.reply(_msg, 500, &reason, NULL) == -1)		{			LM_ERR("failed to send reply/n");		}		goto error;	}	switch ((_msg->first_line).type) {	case SIP_REQUEST:		if (parse_sip_msg_uri(_msg) < 0) {			LM_ERR("failed to parse Request-URI/n");			reason.s = "Bad Request-URI";			reason.len = sizeof("Bad Request-URI")-1;			if (sigb.reply(_msg, 400, &reason, NULL) == -1) {				LM_ERR("failed to send reply/n");			}			goto error;		}		break;	case SIP_REPLY:		break;	default:		LM_ERR("invalid firstline/n");		goto error;	}	ENTER;				/* everything created after here */	SAVETMPS;			/* ...is a temporary variable.   */	PUSHMARK(SP);			/* remember the stack pointer    */	m = sv_newmortal();		/* create a mortal SV to be killed on FREETMPS */	sv_setref_pv(m, "OpenSIPS::Message", (void *)_msg); /* bless the message with a class */	SvREADONLY_on(SvRV(m));		/* set the content of m to be readonly  */	XPUSHs(m);			/* Our reference to the stack... */	if (mystr)		XPUSHs(sv_2mortal(newSVpv(mystr->s, mystr->len)));		/* Our string to the stack... */	PUTBACK;			/* make local stack pointer global */	call_pv(fnc, G_EVAL|G_SCALAR);		/* call the function     */	SPAGAIN;			/* refresh stack pointer         */	/* pop the return value from stack */	retval = POPi;	PUTBACK;	FREETMPS;			/* free that return value        */	LEAVE;				/* ...and the XPUSHed "mortal" args.*/	return retval;error:	pkg_free(fnc);	return -1;}

//.........这里部分代码省略.........		       quit = 1;		       return;		    }		  memset(arg2, 0, cut_string(temp, '/005') + 2);		  strncpy(arg2, temp, cut_string(temp, '/005') + 1);		  /* Third argument */		  temp = temp + cut_string(temp, '/005') + 1;	 		  if((arg3 = malloc(sizeof(char) * (cut_string(temp, '|') + 2))) == NULL)		    {		       logprintf(1, "Error - In sub_to_script()/malloc(): ");		       logerror(1, errno);		       quit = 1;		       return;		    }		  memset(arg3, 0, cut_string(temp, '|') + 2);		  strncpy(arg3, temp, cut_string(temp, '|'));	       }	  }     }   /* And call the sub.  */     {	dSP;		ENTER;	SAVETMPS;		PUSHMARK(SP);	      	/* These subs take three arguments:  */ 	if(!strncmp(subname, "added_temp_ban", 14))	  {	     XPUSHs(sv_2mortal(newSVpvn(arg1, strlen(arg1))));	     XPUSHs(sv_2mortal(newSVuv(atol(arg2))));	     if(arg3 != NULL)	       XPUSHs(sv_2mortal(newSVpvn(arg3, strlen(arg3))));	  }	else if(!strncmp(subname, "added_temp_allow", 16))	  {	     XPUSHs(sv_2mortal(newSVpvn(arg1, strlen(arg1))));	     XPUSHs(sv_2mortal(newSVuv(atol(arg2))));	     if(arg3 != NULL)	       XPUSHs(sv_2mortal(newSVpvn(arg3, strlen(arg3))));	  }      	/* These subs take two arguments:  */ 	else if(!strncmp(subname, "data_arrival", 12))	  {	     XPUSHs(sv_2mortal(newSVpvn(arg1, strlen(arg1))));	     /* We'll have to add the pipe here, since we actually want it in 	      * this argument. It looks a bit ugly, but it seems to be the best	      * way since the pipe can't be used internally between processes.	      * Maybe Open DC Hub shouldn't be using the flawed Direct Connect	      * protocol between processes, but thats a _big_ todo...  */	     strcat(arg2, "|");	     XPUSHs(sv_2mortal(newSVpvn(arg2, strlen(arg2))));	  }	else if(!strncmp(subname, "added_multi_hub", 15))	  {	     XPUSHs(sv_2mortal(newSVpvn(arg1, strlen(arg1))));	     XPUSHs(sv_2mortal(newSViv(atoi(arg2))));	  }	else if(!strncmp(subname, "added_perm_ban", 14))	  {	     XPUSHs(sv_2mortal(newSVpvn(arg1, strlen(arg1))));	     if(arg2 != NULL)

GV *Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload){    register const char *nend;    const char *nsplit = 0;    GV* gv;    HV* ostash = stash;    if (stash && SvTYPE(stash) < SVt_PVHV)	stash = Nullhv;    for (nend = name; *nend; nend++) {	if (*nend == '/'')	    nsplit = nend;	else if (*nend == ':' && *(nend + 1) == ':')	    nsplit = ++nend;    }    if (nsplit) {	const char *origname = name;	name = nsplit + 1;	if (*nsplit == ':')	    --nsplit;	if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {	    /* ->SUPER::method should really be looked up in original stash */	    SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",						  CopSTASHPV(PL_curcop)));	    /* __PACKAGE__::SUPER stash should be autovivified */	    stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);	    DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s/n",			 origname, HvNAME(stash), name) );	}	else {            /* don't autovifify if ->NoSuchStash::method */            stash = gv_stashpvn(origname, nsplit - origname, FALSE);	    /* however, explicit calls to Pkg::SUPER::method may	       happen, and may require autovivification to work */	    if (!stash && (nsplit - origname) >= 7 &&		strnEQ(nsplit - 7, "::SUPER", 7) &&		gv_stashpvn(origname, nsplit - origname - 7, FALSE))	      stash = gv_stashpvn(origname, nsplit - origname, TRUE);	}	ostash = stash;    }    gv = gv_fetchmeth(stash, name, nend - name, 0);    if (!gv) {	if (strEQ(name,"import") || strEQ(name,"unimport"))	    gv = (GV*)&PL_sv_yes;	else if (autoload)	    gv = gv_autoload4(ostash, name, nend - name, TRUE);    }    else if (autoload) {	CV* cv = GvCV(gv);	if (!CvROOT(cv) && !CvXSUB(cv)) {	    GV* stubgv;	    GV* autogv;	    if (CvANON(cv))		stubgv = gv;	    else {		stubgv = CvGV(cv);		if (GvCV(stubgv) != cv)		/* orphaned import */		    stubgv = gv;	    }	    autogv = gv_autoload4(GvSTASH(stubgv),				  GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);	    if (autogv)		gv = autogv;	}    }    return gv;}

//.........这里部分代码省略.........		free(cd);		return (ISC_R_NOMEMORY);	}	perlrun[1] = cd->perl_source;	if (perl_parse(cd->perl, xs_init, 3, perlrun, (char **)NULL)) {		cd->log(ISC_LOG_ERROR,			"DLZ Perl '%s': Failed to parse Perl script, aborting",			dlzname);		goto CLEAN_UP_PERL_AND_FAIL;	}	/* Let Perl know about our callbacks. */	call_argv("DLZ_Perl::clientinfo::bootstrap",		  G_DISCARD|G_NOARGS, &call_argv_args);	call_argv("DLZ_Perl::bootstrap",		  G_DISCARD|G_NOARGS, &call_argv_args);	/*	 * Run the script. We don't really need to do this since we have	 * the init callback, but there's not really a downside either.	 */	if (perl_run(cd->perl)) {		cd->log(ISC_LOG_ERROR,			"DLZ Perl '%s': Script exited with an error, aborting",			dlzname);		goto CLEAN_UP_PERL_AND_FAIL;	}#ifdef MULTIPLICITY	if (missing_method_name = missing_perl_method(perl_class_name, my_perl))#else	if (missing_method_name = missing_perl_method(perl_class_name))#endif	{		cd->log(ISC_LOG_ERROR,			"DLZ Perl '%s': Missing required function '%s', "			"aborting", dlzname, missing_method_name);		goto CLEAN_UP_PERL_AND_FAIL;	}	dSP;	ENTER;	SAVETMPS;	PUSHMARK(SP);	XPUSHs(sv_2mortal(newSVpv(perl_class_name, 0)));	/* Build flattened hash of config info. */	XPUSHs(sv_2mortal(newSVpv("log_context", 0)));	XPUSHs(sv_2mortal(newSViv((IV)cd->log)));	/* Argument to pass to new? */	if (argc == 4) {		XPUSHs(sv_2mortal(newSVpv("argv", 0)));		XPUSHs(sv_2mortal(newSVpv(argv[3], 0)));	}	PUTBACK;	r = call_method("new", G_EVAL|G_SCALAR);	SPAGAIN;	if (r) cd->perl_class = SvREFCNT_inc(POPs);	PUTBACK;	FREETMPS;	LEAVE;	if (SvTRUE(ERRSV)) {		POPs;		cd->log(ISC_LOG_ERROR,			"DLZ Perl '%s': new died in eval: %s",			dlzname, SvPV_nolen(ERRSV));		goto CLEAN_UP_PERL_AND_FAIL;	}	if (!r || !sv_isobject(cd->perl_class)) {		cd->log(ISC_LOG_ERROR,			"DLZ Perl '%s': new failed to return a blessed object",			dlzname);		goto CLEAN_UP_PERL_AND_FAIL;	}	*dbdata = cd;#ifndef MULTIPLICITY	global_perl = cd->perl;#endif	return (ISC_R_SUCCESS);CLEAN_UP_PERL_AND_FAIL:	PL_perl_destruct_level = 1;	perl_destruct(cd->perl);	perl_free(cd->perl);	free(cd->perl_source);	free(cd);	return (ISC_R_FAILURE);}

isc_result_tdlz_findzonedb(void *dbdata, const char *name,	       dns_clientinfomethods_t *methods,	       dns_clientinfo_t *clientinfo)#endif{	config_data_t *cd = (config_data_t *) dbdata;	int r;	isc_result_t retval;#ifdef MULTIPLICITY	PerlInterpreter *my_perl = cd->perl;#endif#if DLZ_DLOPEN_VERSION >= 3	UNUSED(methods);	UNUSED(clientinfo);#endif	dSP;	carp("DLZ Perl: findzone looking for '%s'", name);	PERL_SET_CONTEXT(cd->perl);	ENTER;	SAVETMPS;		PUSHMARK(SP);	XPUSHs(cd->perl_class);	XPUSHs(sv_2mortal(newSVpv(name, 0)));	PUTBACK;	r = call_method("findzone", G_SCALAR|G_EVAL);	SPAGAIN;	if (SvTRUE(ERRSV)) {		/*		 * On error there's an undef at the top of the stack. Pop		 * it away so we don't leave junk on the stack for the next		 * caller.		 */		POPs;		cd->log(ISC_LOG_ERROR,			"DLZ Perl: findzone died in eval: %s",			SvPV_nolen(ERRSV));		retval = ISC_R_FAILURE;	} else if (r == 0) {	 	retval = ISC_R_FAILURE;	} else if (r > 1) {		/* Once again, clean out the stack when possible. */		while (r--) POPi;		cd->log(ISC_LOG_ERROR,			"DLZ Perl: findzone returned too many parameters!");		retval = ISC_R_FAILURE;	} else {		r = POPi;		if (r)			retval = ISC_R_SUCCESS;		else			retval = ISC_R_NOTFOUND;	}	PUTBACK;	FREETMPS;	LEAVE;	return (retval);}

static SV  *plperl_create_sub(char *s, bool trusted){	dSP;	SV		   *subref;	int			count;	char	   *compile_sub;	if (trusted && !plperl_safe_init_done)	{		plperl_safe_init();		SPAGAIN;	}	ENTER;	SAVETMPS;	PUSHMARK(SP);	XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0)));	XPUSHs(sv_2mortal(newSVpv(s, 0)));	PUTBACK;	/*	 * G_KEEPERR seems to be needed here, else we don't recognize compile	 * errors properly.  Perhaps it's because there's another level of eval	 * inside mksafefunc?	 */	if (trusted && plperl_use_strict)		compile_sub = "::mk_strict_safefunc";	else if (plperl_use_strict)		compile_sub = "::mk_strict_unsafefunc";	else if (trusted)		compile_sub = "::mksafefunc";	else		compile_sub = "::mkunsafefunc";	count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);	SPAGAIN;	if (count != 1)	{		PUTBACK;		FREETMPS;		LEAVE;		elog(ERROR, "didn't get a return item from mksafefunc");	}	if (SvTRUE(ERRSV))	{		(void) POPs;		PUTBACK;		FREETMPS;		LEAVE;		ereport(ERROR,				(errcode(ERRCODE_SYNTAX_ERROR),				 errmsg("creation of Perl function failed: %s",						strip_trailing_ws(SvPV(ERRSV, PL_na)))));	}	/*	 * need to make a deep copy of the return. it comes off the stack as a	 * temporary.	 */	subref = newSVsv(POPs);	if (!SvROK(subref) || SvTYPE(SvRV(subref)) != SVt_PVCV)	{		PUTBACK;		FREETMPS;		LEAVE;		/*		 * subref is our responsibility because it is not mortal		 */		SvREFCNT_dec(subref);		elog(ERROR, "didn't get a code ref");	}	PUTBACK;	FREETMPS;	LEAVE;	return subref;}

/* * This is the main Load function. * It takes a yaml stream and turns it into 0 or more Perl objects. */voidLoad(SV *yaml_sv){    dXSARGS;    perl_yaml_loader_t loader;    SV *node;    char *yaml_str;    STRLEN yaml_len;        /* If UTF8, make copy and downgrade */    if (SvPV_nolen(yaml_sv) && SvUTF8(yaml_sv)) {        yaml_sv = sv_mortalcopy(yaml_sv);    }    yaml_str = SvPVbyte(yaml_sv, yaml_len);    sp = mark;    if (0 && (items || ax)) {} /* XXX Quiet the -Wall warnings for now. */    yaml_parser_initialize(&loader.parser);    loader.document = 0;    yaml_parser_set_input_string(        &loader.parser,        (unsigned char *)yaml_str,        yaml_len    );    /* Get the first event. Must be a STREAM_START */    if (!yaml_parser_parse(&loader.parser, &loader.event))        goto load_error;    if (loader.event.type != YAML_STREAM_START_EVENT)        croak(ERRMSG "Expected STREAM_START_EVENT; Got: %d != %d",            loader.event.type,            YAML_STREAM_START_EVENT         );    loader.anchors = newHV();    sv_2mortal((SV*)loader.anchors);    /* Keep calling load_node until end of stream */    while (1) {        loader.document++;        if (!yaml_parser_parse(&loader.parser, &loader.event))            goto load_error;        if (loader.event.type == YAML_STREAM_END_EVENT)            break;        node = load_node(&loader);        hv_clear(loader.anchors);        if (! node) break;        XPUSHs(sv_2mortal(node));        if (!yaml_parser_parse(&loader.parser, &loader.event))            goto load_error;        if (loader.event.type != YAML_DOCUMENT_END_EVENT)            croak(ERRMSG "Expected DOCUMENT_END_EVENT");    }    /* Make sure the last event is a STREAM_END */    if (loader.event.type != YAML_STREAM_END_EVENT)        croak(ERRMSG "Expected STREAM_END_EVENT; Got: %d != %d",            loader.event.type,            YAML_STREAM_END_EVENT         );    yaml_parser_delete(&loader.parser);    PUTBACK;    return;load_error:    croak(loader_error_msg(&loader, NULL));}

/* *	The xlat function */static ssize_t perl_xlat(UNUSED TALLOC_CTX *ctx, char **out, size_t outlen,			 void const *mod_inst, UNUSED void const *xlat_inst,			 REQUEST *request, char const *fmt){	rlm_perl_t	*inst;	char		*tmp;	char const	*p, *q;	int		count;	size_t		ret = 0;	STRLEN		n_a;	memcpy(&inst, &mod_inst, sizeof(inst));#ifdef USE_ITHREADS	PerlInterpreter *interp;	pthread_mutex_lock(&inst->clone_mutex);	interp = rlm_perl_clone(inst->perl, inst->thread_key);	{		dTHXa(interp);		PERL_SET_CONTEXT(interp);	}	pthread_mutex_unlock(&inst->clone_mutex);#else	PERL_SET_CONTEXT(inst->perl);#endif	{		dSP;		ENTER;SAVETMPS;		PUSHMARK(SP);		p = q = fmt;		while (*p == ' ') {			p++;			q++;		}		while (*q) {			if (*q == ' ') {				XPUSHs(sv_2mortal(newSVpvn(p, q - p)));				p = q + 1;				/*				 *	Don't use an empty string				 */				while (*p == ' ') p++;				q = p;			}			q++;		}		/*		 *	And the last bit.		 */		if (*p) {			XPUSHs(sv_2mortal(newSVpvn(p, strlen(p))));		}		PUTBACK;		count = call_pv(inst->func_xlat, G_SCALAR | G_EVAL);		SPAGAIN;		if (SvTRUE(ERRSV)) {			REDEBUG("Exit %s", SvPV(ERRSV,n_a));			(void)POPs;		} else if (count > 0) {			tmp = POPp;			strlcpy(*out, tmp, outlen);			ret = strlen(*out);			RDEBUG2("Len is %zu , out is %s freespace is %zu", ret, *out, outlen);		}		PUTBACK ;		FREETMPS ;		LEAVE ;	}	return ret;}

isc_result_tdlz_lookup(const char *zone, const char *name,	   void *dbdata, dns_sdlzlookup_t *lookup,	   dns_clientinfomethods_t *methods,	   dns_clientinfo_t *clientinfo)#endif{	isc_result_t retval;	config_data_t *cd = (config_data_t *) dbdata;	int rrcount, r;	dlz_perl_clientinfo_opaque opaque;	SV *record_ref;	SV **rr_type;	SV **rr_ttl;	SV **rr_data;#ifdef MULTIPLICITY	PerlInterpreter *my_perl = cd->perl;#endif#if DLZ_DLOPEN_VERSION >= 2	UNUSED(methods);	UNUSED(clientinfo);#endif	dSP;	PERL_SET_CONTEXT(cd->perl);	ENTER;	SAVETMPS;	opaque.methods = methods;	opaque.clientinfo = clientinfo;	PUSHMARK(SP);	XPUSHs(cd->perl_class);	XPUSHs(sv_2mortal(newSVpv(name, 0)));	XPUSHs(sv_2mortal(newSVpv(zone, 0)));	XPUSHs(sv_2mortal(newSViv((IV)&opaque)));	PUTBACK;	carp("DLZ Perl: Searching for name %s in zone %s", name, zone);	rrcount = call_method("lookup", G_ARRAY|G_EVAL);	carp("DLZ Perl: Call to lookup returned %i", rrcount);	SPAGAIN;	if (SvTRUE(ERRSV)) {		POPs;		cd->log(ISC_LOG_ERROR, "DLZ Perl: lookup died in eval: %s",			SvPV_nolen(ERRSV));		retval = ISC_R_FAILURE;		goto CLEAN_UP_AND_RETURN;	}	if (!rrcount) {		retval = ISC_R_NOTFOUND;		goto CLEAN_UP_AND_RETURN;	}	retval = ISC_R_SUCCESS;	r = 0;	while (r++ < rrcount) {		record_ref = POPs;		if ((!SvROK(record_ref)) ||		    (SvTYPE(SvRV(record_ref)) != SVt_PVAV))		{			cd->log(ISC_LOG_ERROR,				"DLZ Perl: lookup returned an "				"invalid value (expected array of arrayrefs)!");			retval = ISC_R_FAILURE;			break;		}		record_ref = SvRV(record_ref);		rr_type = av_fetch((AV *) record_ref, 0, 0);		rr_ttl = av_fetch((AV *) record_ref, 1, 0);		rr_data = av_fetch((AV *) record_ref, 2, 0);		if (rr_type == NULL || rr_ttl == NULL || rr_data == NULL) {			cd->log(ISC_LOG_ERROR,				"DLZ Perl: lookup for record %s in "				"zone %s returned an array that was "				"missing data", name, zone);			retval = ISC_R_FAILURE;			break;		}		carp("DLZ Perl: Got record %s = %s",		     SvPV_nolen(*rr_type), SvPV_nolen(*rr_data));		retval = cd->putrr(lookup, SvPV_nolen(*rr_type),				   SvIV(*rr_ttl), SvPV_nolen(*rr_data));		if (retval != ISC_R_SUCCESS) {			cd->log(ISC_LOG_ERROR,				"DLZ Perl: putrr for lookup of %s in "				"zone %s failed with code %i "				"(did lookup return invalid record data?)",				name, zone, retval);			break;		}//.........这里部分代码省略.........

static SV  *plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo){	dSP;	SV		   *retval;	int			i;	int			count;	SV		   *sv;	ENTER;	SAVETMPS;	PUSHMARK(SP);	XPUSHs(&PL_sv_undef);		/* no trigger data */	for (i = 0; i < desc->nargs; i++)	{		if (fcinfo->argnull[i])			XPUSHs(&PL_sv_undef);		else if (desc->arg_is_rowtype[i])		{			HeapTupleHeader td;			Oid			tupType;			int32		tupTypmod;			TupleDesc	tupdesc;			HeapTupleData tmptup;			SV		   *hashref;			td = DatumGetHeapTupleHeader(fcinfo->arg[i]);			/* Extract rowtype info and find a tupdesc */			tupType = HeapTupleHeaderGetTypeId(td);			tupTypmod = HeapTupleHeaderGetTypMod(td);			tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);			/* Build a temporary HeapTuple control structure */			tmptup.t_len = HeapTupleHeaderGetDatumLength(td);			tmptup.t_data = td;			hashref = plperl_hash_from_tuple(&tmptup, tupdesc);			XPUSHs(sv_2mortal(hashref));		}		else		{			char	   *tmp;			tmp = DatumGetCString(FunctionCall1(&(desc->arg_out_func[i]),												fcinfo->arg[i]));			sv = newSVpv(tmp, 0);#if PERL_BCDVERSION >= 0x5006000L			if (GetDatabaseEncoding() == PG_UTF8)				SvUTF8_on(sv);#endif			XPUSHs(sv_2mortal(sv));			pfree(tmp);		}	}	PUTBACK;	/* Do NOT use G_KEEPERR here */	count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);	SPAGAIN;	if (count != 1)	{		PUTBACK;		FREETMPS;		LEAVE;		elog(ERROR, "didn't get a return item from function");	}	if (SvTRUE(ERRSV))	{		(void) POPs;		PUTBACK;		FREETMPS;		LEAVE;		/* XXX need to find a way to assign an errcode here */		ereport(ERROR,				(errmsg("error from Perl function: %s",						strip_trailing_ws(SvPV(ERRSV, PL_na)))));	}	retval = newSVsv(POPs);	PUTBACK;	FREETMPS;	LEAVE;	return retval;}

void _mpack_item(SV *res, SV *o){	size_t len, res_len, new_len;	char *s, *res_s;	res_s = SvPVbyte(res, res_len);	unsigned i;	if (!SvOK(o)) {		new_len = res_len + mp_sizeof_nil();		res_s = SvGROW(res, new_len);		SvCUR_set(res, new_len);		mp_encode_nil(res_s + res_len);		return;	}	if (SvROK(o)) {		o = SvRV(o);		if (SvOBJECT(o)) {			SvGETMAGIC(o);			HV *stash = SvSTASH(o);			GV *mtd = gv_fetchmethod_autoload(stash, "msgpack", 0);			if (!mtd)				croak("Object has no method 'msgpack'");			dSP;			ENTER;			SAVETMPS;			PUSHMARK(SP);			XPUSHs (sv_bless (sv_2mortal (newRV_inc(o)), stash));			PUTBACK;			call_sv((SV *)GvCV(mtd), G_SCALAR);			SPAGAIN;			SV *pkt = POPs;			if (!SvOK(pkt))				croak("O->msgpack returned undef");			s = SvPV(pkt, len);			new_len = res_len + len;			res_s = SvGROW(res, new_len);			SvCUR_set(res, new_len);			memcpy(res_s + res_len, s, len);			PUTBACK;			FREETMPS;			LEAVE;			return;		}		switch(SvTYPE(o)) {			case SVt_PVAV: {				AV *a = (AV *)o;				len = av_len(a) + 1;				new_len = res_len + mp_sizeof_array(len);				res_s = SvGROW(res, new_len);				SvCUR_set(res, new_len);				mp_encode_array(res_s + res_len, len);				for (i = 0; i < len; i++) {					SV **item = av_fetch(a, i, 0);					if (!item)						_mpack_item(res, 0);					else						_mpack_item(res, *item);				}				break;			}			case SVt_PVHV: {				HV *h = (HV *)o;				len = hv_iterinit(h);				new_len = res_len + mp_sizeof_map(len);				res_s = SvGROW(res, new_len);				SvCUR_set(res, new_len);				mp_encode_map(res_s + res_len, len);				for (;;) {					HE * iter = hv_iternext(h);					if (!iter)						break;					SV *k = hv_iterkeysv(iter);					SV *v = HeVAL(iter);					_mpack_item(res, k);					_mpack_item(res, v);				}				break;			}			default:				croak("Can't serialize reference");		}		return;	}	switch(SvTYPE(o)) {//.........这里部分代码省略.........

/********************************************************** * * Bind * **********************************************************/intperl_back_bind(	Operation *op,	SlapReply *rs ){	int count;	PerlBackend *perl_back = (PerlBackend *) op->o_bd->be_private;	/* allow rootdn as a means to auth without the need to actually 	 * contact the proxied DSA */	switch ( be_rootdn_bind( op, rs ) ) {	case SLAP_CB_CONTINUE:		break;	default:		return rs->sr_err;	}#if defined(HAVE_WIN32_ASPERL) || defined(USE_ITHREADS)	PERL_SET_CONTEXT( PERL_INTERPRETER );#endif	ldap_pvt_thread_mutex_lock( &perl_interpreter_mutex );		{		dSP; ENTER; SAVETMPS;		PUSHMARK(SP);		XPUSHs( perl_back->pb_obj_ref );		XPUSHs(sv_2mortal(newSVpv( op->o_req_dn.bv_val , 0)));		XPUSHs(sv_2mortal(newSVpv( op->orb_cred.bv_val , op->orb_cred.bv_len)));		PUTBACK;#ifdef PERL_IS_5_6		count = call_method("bind", G_SCALAR);#else		count = perl_call_method("bind", G_SCALAR);#endif		SPAGAIN;		if (count != 1) {			croak("Big trouble in back_bind/n");		}		rs->sr_err = POPi;							 		PUTBACK; FREETMPS; LEAVE;	}	ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex );		Debug( LDAP_DEBUG_ANY, "Perl BIND returned 0x%04x/n", rs->sr_err, 0, 0 );	/* frontend will send result on success (0) */	if( rs->sr_err != LDAP_SUCCESS )		send_ldap_result( op, rs );	return ( rs->sr_err );}

isc_result_t dlz_allnodes(const char *zone, void *dbdata,			  dns_sdlzallnodes_t *allnodes){	config_data_t *cd = (config_data_t *) dbdata;	isc_result_t retval;	int rrcount, r;	SV *record_ref;	SV **rr_name;	SV **rr_type;	SV **rr_ttl;	SV **rr_data;#ifdef MULTIPLICITY	PerlInterpreter *my_perl = cd->perl;#endif	dSP;	PERL_SET_CONTEXT(cd->perl);	ENTER;	SAVETMPS;		PUSHMARK(SP);	XPUSHs(cd->perl_class);	XPUSHs(sv_2mortal(newSVpv(zone, 0)));	PUTBACK;	carp("DLZ Perl: Calling allnodes for zone %s", zone);	rrcount = call_method("allnodes", G_ARRAY|G_EVAL);	carp("DLZ Perl: Call to allnodes returned rrcount of %i", rrcount);	SPAGAIN;	if (SvTRUE(ERRSV)) {		POPs;		cd->log(ISC_LOG_ERROR, "DLZ Perl: allnodes for zone %s died in eval: %s", zone, SvPV_nolen(ERRSV));		retval = ISC_R_FAILURE;		goto CLEAN_UP_AND_RETURN;	}	if (!rrcount) {		retval = ISC_R_NOTFOUND;		goto CLEAN_UP_AND_RETURN;	}	retval = ISC_R_SUCCESS;	r = 0;	while (r++ < rrcount) {		record_ref = POPs;		if (			(!SvROK(record_ref)) ||			(SvTYPE(SvRV(record_ref)) != SVt_PVAV)		) {			cd->log(ISC_LOG_ERROR,				"DLZ Perl: allnodes for zone %s "				"returned an invalid value "				"(expected array of arrayrefs)",				zone);			retval = ISC_R_FAILURE;			break;		}		record_ref = SvRV(record_ref);		rr_name = av_fetch((AV *) record_ref, 0, 0);		rr_type = av_fetch((AV *) record_ref, 1, 0);		rr_ttl = av_fetch((AV *) record_ref, 2, 0);		rr_data = av_fetch((AV *) record_ref, 3, 0);		if (rr_name == NULL || rr_type == NULL ||		    rr_ttl == NULL || rr_data == NULL)		{			cd->log(ISC_LOG_ERROR,				"DLZ Perl: allnodes for zone %s "				"returned an array that was missing data",				zone);			retval = ISC_R_FAILURE;			break;		}		carp("DLZ Perl: Got record %s/%s = %s",		     SvPV_nolen(*rr_name), SvPV_nolen(*rr_type),		     SvPV_nolen(*rr_data));   		retval = cd->putnamedrr(allnodes,					SvPV_nolen(*rr_name),					SvPV_nolen(*rr_type),					SvIV(*rr_ttl), SvPV_nolen(*rr_data));		if (retval != ISC_R_SUCCESS) {			cd->log(ISC_LOG_ERROR,				"DLZ Perl: putnamedrr in allnodes "				"for zone %s failed with code %i "				"(did lookup return invalid record data?)",				zone, retval);			break;		}	}CLEAN_UP_AND_RETURN:	PUTBACK;	FREETMPS;	LEAVE;//.........这里部分代码省略.........