static SV*
gperl_io_channel_wrap (GType gtype,
const char * package,
GIOChannel * channel,
gboolean own)
{
PERL_UNUSED_VAR (gtype);
PERL_UNUSED_VAR (package);
PERL_UNUSED_VAR (own);
return newSViv (g_io_channel_unix_get_fd (channel));
}
static gpointer
gperl_io_channel_unwrap (GType gtype,
const char * package,
SV * sv)
{
PERL_UNUSED_VAR (gtype);
PERL_UNUSED_VAR (package);
PERL_UNUSED_VAR (sv);
croak ("can't unwrap GIOChannels -- how'd you get one in perl?!?\n"
" you appear to have found a bug in gtk2-perl-xs. congratulations.\n"
" please report this bug to [email protected]\n"
" croaking ");
return NULL;
}
static int eca_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param) {
SV *sv = mg->mg_obj;
ECAslot *dup = eca_dup(sv2slot(sv));
sv_setuv(sv, PTR2UV(dup));
PERL_UNUSED_VAR(param);
return 0;
}
/* can't really use xsubpp here... */
extern
XS(blizkost_callable_trampoline)
{
#ifdef dVAR
dVAR;
#endif
dXSARGS;
PMC *callable;
blizkost_nexus *nexus;
int i;
PMC *args, *posret, *namret;
blizkost_get_bound_pmc(my_perl, &nexus, (SV *)cv, &callable);
if (nexus->dying)
exit_fatal(1, "Attempted reentry of Parrot code during global destruction");
PERL_UNUSED_VAR(ax);
SP -= items;
PUTBACK;
args = Parrot_pmc_new_init_int(nexus->parrot_interp, enum_class_ResizablePMCArray, items);
for (i = 0; i < items; i++) {
SV *svarg = ST(i);
PMC *pmcarg = blizkost_wrap_sv(nexus, svarg);
VTABLE_set_pmc_keyed_int(nexus->parrot_interp, args, i, pmcarg);
}
Parrot_pcc_invoke_sub_from_c_args(nexus->parrot_interp, callable,
"Pf->PsPsn", args, &posret, &namret);
blizkost_slurpy_to_stack(nexus, posret, namret);
SPAGAIN;
}
static void
generic_interface_finalize (gpointer iface, gpointer data)
{
GIInterfaceInfo *info = data;
PERL_UNUSED_VAR (iface);
dwarn ("releasing interface info\n");
g_base_info_unref ((GIBaseInfo *) info);
}
int /* just to test syntax of macros etc */
dbd_st_rows(SV *h, imp_sth_t *imp_sth)
{
dTHX;
PERL_UNUSED_VAR(h);
DBIh_SET_ERR_CHAR(h, imp_sth, 0, 1, "err msg", "12345", Nullch);
return -1;
}
PerlFMM*
PerlFMM_create(SV *class_sv) {
PerlFMM *state;
PERL_UNUSED_VAR(class_sv);
Newz(1234, state, 1, PerlFMM);
state->magic = NULL;
state->error = NULL;
state->ext = st_init_strtable();
return state;
}
static gboolean
find_closure (GtkAccelKey * key,
GClosure * closure,
gpointer data)
{
GPerlClosure * gpc = (GPerlClosure*) closure;
FindClosureData * cd = (FindClosureData*) data;
PERL_UNUSED_VAR (key);
if (strEQ (cd->sv_str, SvPV_nolen (gpc->callback))) {
cd->closure = closure;
return TRUE;
} else
return FALSE;
}
static void
XS_Fcntl_S_ISREG(pTHX_ CV* cv)
{
dVAR;
dXSARGS;
dXSI32;
/* Preserve the semantics of the perl code, which was:
sub S_ISREG { ( $_[0] & _S_IFMT() ) == S_IFREG() }
*/
SV *mode;
PERL_UNUSED_VAR(cv); /* -W */
SP -= items;
if (items > 0)
mode = ST(0);
else {
mode = &PL_sv_undef;
EXTEND(SP, 1);
}
PUSHs(((SvUV(mode) & S_IFMT) == (UV)ix) ? &PL_sv_yes : &PL_sv_no);
PUTBACK;
}
static int eca_mg_free(pTHX_ SV *sv, MAGIC *mg) {
ECAslot *slot = sv2slot(mg->mg_obj);
PERL_UNUSED_VAR(sv);
eca_destroy(slot);
return 0;
}
void c_test (int max){
int i;
for (f=1)
}
#line 23 "ko_6_1_0_perllint_01cc.c"
#ifndef PERL_UNUSED_VAR
# define PERL_UNUSED_VAR(var) if (0) var = var
#endif
#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
/* prototype to pass -Wmissing-prototypes */
STATIC void
S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
STATIC void
S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
{
const GV *const gv = CvGV(cv);
PERL_ARGS_ASSERT_CROAK_XS_USAGE;
if (gv) {
const char *const gvname = GvNAME(gv);
const HV *const stash = GvSTASH(gv);
const char *const hvname = stash ? HvNAME(stash) : NULL;
if (hvname)
Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
else
Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
} else {
/* Pants. I don't think that it should be possible to get here. */
Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
}
}
#undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
#ifdef PERL_IMPLICIT_CONTEXT
#define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
#else
#define croak_xs_usage S_croak_xs_usage
#endif
#endif
/* NOTE: the prototype of newXSproto() is different in versions of perls,
* so we define a portable version of newXSproto()
*/
#ifdef newXS_flags
#define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
#else
#define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
#endif /* !defined(newXS_flags) */
#line 75 "ko_6_1_0_perllint_01cc.c"
XS(XS_main_c_test); /* prototype to pass -Wmissing-prototypes */
XS(XS_main_c_test)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
if (items != 1)
croak_xs_usage(cv, "max");
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
int max = (int)SvIV(ST(0));
#line 22 "ko_6_1_0_perllint_01cc.xs"
I32* temp;
#line 93 "ko_6_1_0_perllint_01cc.c"
#line 24 "ko_6_1_0_perllint_01cc.xs"
temp = PL_markstack_ptr++;
c_test(max);
if (PL_markstack_ptr != temp) {
/* truly void, because dXSARGS not invoked */
PL_markstack_ptr = temp;
XSRETURN_EMPTY; /* return empty stack */
}
/* must have used dXSARGS; list context implied */
return; /* assume stack size is correct */
#line 104 "ko_6_1_0_perllint_01cc.c"
PUTBACK;
return;
}
}
#ifdef __cplusplus
extern "C"
#endif
XS(boot_ko_6_1_0_perllint_01cc); /* prototype to pass -Wmissing-prototypes */
XS(boot_ko_6_1_0_perllint_01cc)
{
#ifdef dVAR
dVAR; dXSARGS;
#else
dXSARGS;
#endif
#if (PERL_REVISION == 5 && PERL_VERSION < 9)
char* file = __FILE__;
#else
const char* file = __FILE__;
#endif
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(items); /* -W */
XS_VERSION_BOOTCHECK ;
newXS("main::c_test", XS_main_c_test, file);
#if (PERL_REVISION == 5 && PERL_VERSION >= 9)
if (PL_unitcheckav)
call_list(PL_scopestack_ix, PL_unitcheckav);
#endif
XSRETURN_YES;
}
static void
invoke_callback (ffi_cif* cif, gpointer resp, gpointer* args, gpointer userdata)
{
GPerlI11nPerlCallbackInfo *info;
GICallableInfo *cb_interface;
GPerlI11nInvocationInfo iinfo = {0,};
guint i;
guint in_inout;
guint n_return_values, n_returned;
I32 context;
dGPERL_CALLBACK_MARSHAL_SP;
PERL_UNUSED_VAR (cif);
/* unwrap callback info struct from userdata */
info = (GPerlI11nPerlCallbackInfo *) userdata;
cb_interface = (GICallableInfo *) info->interface;
prepare_perl_invocation_info (&iinfo, cb_interface);
/* set perl context */
GPERL_CALLBACK_MARSHAL_INIT (info);
ENTER;
SAVETMPS;
PUSHMARK (SP);
/* find arguments; use type information from interface to find in and
* in-out args and their types, count in-out and out args, and find
* suitable converters; push in and in-out arguments onto the perl
* stack */
in_inout = 0;
for (i = 0; i < iinfo.n_args; i++) {
GIArgInfo *arg_info = g_callable_info_get_arg (cb_interface, i);
GITypeInfo *arg_type = g_arg_info_get_type (arg_info);
GITransfer transfer = g_arg_info_get_ownership_transfer (arg_info);
GIDirection direction = g_arg_info_get_direction (arg_info);
iinfo.current_pos = i;
/* the closure argument, which we handle separately, is marked
* by having get_closure == i */
if (g_arg_info_get_closure (arg_info) == (gint) i) {
g_base_info_unref ((GIBaseInfo *) arg_info);
g_base_info_unref ((GIBaseInfo *) arg_type);
continue;
}
dwarn ("arg info: %s (%p)\n"
" direction: %d\n"
" is return value: %d\n"
" is optional: %d\n"
" may be null: %d\n"
" transfer: %d\n",
g_base_info_get_name (arg_info), arg_info,
g_arg_info_get_direction (arg_info),
g_arg_info_is_return_value (arg_info),
g_arg_info_is_optional (arg_info),
g_arg_info_may_be_null (arg_info),
g_arg_info_get_ownership_transfer (arg_info));
dwarn ("arg type: %p\n"
" is pointer: %d\n"
" tag: %s (%d)\n",
arg_type,
g_type_info_is_pointer (arg_type),
g_type_tag_to_string (g_type_info_get_tag (arg_type)), g_type_info_get_tag (arg_type));
if (direction == GI_DIRECTION_IN ||
direction == GI_DIRECTION_INOUT)
{
GIArgument arg;
SV *sv;
raw_to_arg (args[i], &arg, arg_type);
sv = arg_to_sv (&arg, arg_type, transfer, &iinfo);
/* If arg_to_sv returns NULL, we take that as 'skip
* this argument'; happens for GDestroyNotify, for
* example. */
if (sv)
XPUSHs (sv_2mortal (sv));
}
if (direction == GI_DIRECTION_INOUT ||
direction == GI_DIRECTION_OUT)
{
in_inout++;
}
g_base_info_unref ((GIBaseInfo *) arg_info);
g_base_info_unref ((GIBaseInfo *) arg_type);
}
/* push user data onto the Perl stack */
if (info->data)
XPUSHs (sv_2mortal (SvREFCNT_inc (info->data)));
PUTBACK;
/* determine suitable Perl call context */
context = G_VOID | G_DISCARD;
if (iinfo.has_return_value) {
context = in_inout > 0
? G_ARRAY
: G_SCALAR;
} else {
if (in_inout == 1) {
context = G_SCALAR;
} else if (in_inout > 1) {
context = G_ARRAY;
}
}
/* do the call, demand #in-out+#out+#return-value return values */
n_return_values = iinfo.has_return_value
? in_inout + 1
: in_inout;
n_returned = info->sub_name
? call_method (info->sub_name, context)
: call_sv (info->code, context);
if (n_return_values != 0 && n_returned != n_return_values) {
ccroak ("callback returned %d values "
"but is supposed to return %d values",
n_returned, n_return_values);
}
/* call-scoped callback infos are freed by
* Glib::Object::Introspection::_FuncWrapper::DESTROY */
SPAGAIN;
/* convert in-out and out values and stuff them back into args */
if (in_inout > 0) {
SV **returned_values;
int out_index;
returned_values = g_new0 (SV *, in_inout);
/* pop scalars off the stack and put them into the array;
* reverse the order since POPs pops items off of the end of
* the stack. */
for (i = 0; i < in_inout; i++) {
returned_values[in_inout - i - 1] = POPs;
}
out_index = 0;
for (i = 0; i < iinfo.n_args; i++) {
GIArgInfo *arg_info = g_callable_info_get_arg (cb_interface, i);
GITypeInfo *arg_type = g_arg_info_get_type (arg_info);
GIDirection direction = g_arg_info_get_direction (arg_info);
gpointer out_pointer = * (gpointer *) args[i];
if (!out_pointer) {
dwarn ("skipping out arg %d\n", i);
g_base_info_unref (arg_info);
g_base_info_unref (arg_type);
continue;
}
if (direction == GI_DIRECTION_INOUT ||
direction == GI_DIRECTION_OUT)
{
GIArgument tmp_arg;
GITransfer transfer = g_arg_info_get_ownership_transfer (arg_info);
gboolean may_be_null = g_arg_info_may_be_null (arg_info);
gboolean is_caller_allocated = g_arg_info_is_caller_allocates (arg_info);
if (is_caller_allocated) {
tmp_arg.v_pointer = out_pointer;
}
sv_to_arg (returned_values[out_index], &tmp_arg,
arg_info, arg_type,
transfer, may_be_null, &iinfo);
if (!is_caller_allocated) {
arg_to_raw (&tmp_arg, out_pointer, arg_type);
}
out_index++;
}
g_base_info_unref (arg_info);
g_base_info_unref (arg_type);
}
g_free (returned_values);
}
void
Perl_taint_env(pTHX)
{
SV** svp;
MAGIC* mg;
const char* const *e;
static const char* const misc_env[] = {
"IFS", /* most shells' inter-field separators */
"CDPATH", /* ksh dain bramage #1 */
"ENV", /* ksh dain bramage #2 */
"BASH_ENV", /* bash dain bramage -- I guess it's contagious */
#ifdef WIN32
"PERL5SHELL", /* used for system() on Windows */
#endif
NULL
};
/* Don't bother if there's no *ENV glob */
if (!PL_envgv)
return;
/* If there's no %ENV hash or if it's not magical, croak, because
* it probably doesn't reflect the actual environment */
if (!GvHV(PL_envgv) || !(SvRMAGICAL(GvHV(PL_envgv))
&& mg_find((const SV *)GvHV(PL_envgv), PERL_MAGIC_env))) {
const bool was_tainted = TAINT_get;
const char * const name = GvENAME(PL_envgv);
TAINT;
if (strEQ(name,"ENV"))
/* hash alias */
taint_proper("%%ENV is aliased to %s%s", "another variable");
else
/* glob alias: report it in the error message */
taint_proper("%%ENV is aliased to %%%s%s", name);
/* this statement is reached under -t or -U */
TAINT_set(was_tainted);
#ifdef NO_TAINT_SUPPORT
PERL_UNUSED_VAR(was_tainted);
#endif
}
#ifdef VMS
{
int i = 0;
char name[10 + TYPE_DIGITS(int)] = "DCL$PATH";
STRLEN len = 8; /* strlen(name) */
while (1) {
if (i)
len = my_sprintf(name,"DCL$PATH;%d", i);
svp = hv_fetch(GvHVn(PL_envgv), name, len, FALSE);
if (!svp || *svp == &PL_sv_undef)
break;
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
}
if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
}
i++;
}
}
#endif /* VMS */
svp = hv_fetchs(GvHVn(PL_envgv),"PATH",FALSE);
if (svp && *svp) {
if (SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure %s%s", "$ENV{PATH}");
}
if ((mg = mg_find(*svp, PERL_MAGIC_envelem)) && MgTAINTEDDIR(mg)) {
TAINT;
taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
}
}
#ifndef VMS
/* tainted $TERM is okay if it contains no metachars */
svp = hv_fetchs(GvHVn(PL_envgv),"TERM",FALSE);
if (svp && *svp && SvTAINTED(*svp)) {
STRLEN len;
const bool was_tainted = TAINT_get;
const char *t = SvPV_const(*svp, len);
const char * const e = t + len;
TAINT_set(was_tainted);
#ifdef NO_TAINT_SUPPORT
PERL_UNUSED_VAR(was_tainted);
#endif
if (t < e && isWORDCHAR(*t))
t++;
while (t < e && (isWORDCHAR(*t) || strchr("-_.+", *t)))
t++;
if (t < e) {
TAINT;
taint_proper("Insecure $ENV{%s}%s", "TERM");
}
}
#endif /* !VMS */
for (e = misc_env; *e; e++) {
SV * const * const svp = hv_fetch(GvHVn(PL_envgv), *e, strlen(*e), FALSE);
if (svp && *svp != &PL_sv_undef && SvTAINTED(*svp)) {
TAINT;
taint_proper("Insecure $ENV{%s}%s", *e);
}
}
}
