-# $Header$
# basic C types
int T_IV
-unsigned T_IV
-unsigned int T_IV
+unsigned T_UV
+unsigned int T_UV
long T_IV
-unsigned long T_IV
+unsigned long T_UV
short T_IV
-unsigned short T_IV
+unsigned short T_UV
char T_CHAR
unsigned char T_U_CHAR
char * T_PV
unsigned char * T_PV
+const char * T_PV
caddr_t T_PV
wchar_t * T_PV
wchar_t T_IV
+# bool_t is defined in <rpc/rpc.h>
bool_t T_IV
-size_t T_IV
+size_t T_UV
ssize_t T_IV
time_t T_NV
unsigned long * T_OPAQUEPTR
-char ** T_PACKED
+char ** T_PACKEDARRAY
void * T_PTR
Time_t * T_PV
SV * T_SV
+
+# These are the backwards-compatibility AV*/HV* typemaps that
+# do not decrement refcounts. Locally override with
+# "AV* T_AVREF_REFCOUNT_FIXED", "HV* T_HVREF_REFCOUNT_FIXED",
+# "CV* T_CVREF_REFCOUNT_FIXED", "SVREF T_SVREF_REFCOUNT_FIXED",
+# to get the fixed versions.
SVREF T_SVREF
+CV * T_CVREF
AV * T_AVREF
HV * T_HVREF
-CV * T_CVREF
IV T_IV
+UV T_UV
+NV T_NV
I32 T_IV
I16 T_IV
I8 T_IV
+STRLEN T_UV
U32 T_U_LONG
U16 T_U_SHORT
-U8 T_IV
+U8 T_UV
Result T_U_CHAR
-Boolean T_IV
+Boolean T_BOOL
+float T_FLOAT
double T_DOUBLE
SysRet T_SYSRET
SysRetLong T_SYSRET
-FILE * T_IN
+FILE * T_STDIO
+PerlIO * T_INOUT
FileHandle T_PTROBJ
InputStream T_IN
InOutStream T_INOUT
T_SV
$var = $arg
T_SVREF
- if (sv_isa($arg, \"${ntype}\"))
- $var = (SV*)SvRV($arg);
- else
- croak(\"$var is not of type ${ntype}\")
+ STMT_START {
+ SV* const xsub_tmp_sv = $arg;
+ SvGETMAGIC(xsub_tmp_sv);
+ if (SvROK(xsub_tmp_sv)){
+ $var = SvRV(xsub_tmp_sv);
+ }
+ else{
+ Perl_croak_nocontext(\"%s: %s is not a reference\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\");
+ }
+ } STMT_END
+T_SVREF_REFCOUNT_FIXED
+ STMT_START {
+ SV* const xsub_tmp_sv = $arg;
+ SvGETMAGIC(xsub_tmp_sv);
+ if (SvROK(xsub_tmp_sv)){
+ $var = SvRV(xsub_tmp_sv);
+ }
+ else{
+ Perl_croak_nocontext(\"%s: %s is not a reference\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\");
+ }
+ } STMT_END
T_AVREF
- if (sv_isa($arg, \"${ntype}\"))
- $var = (AV*)SvRV($arg);
- else
- croak(\"$var is not of type ${ntype}\")
+ STMT_START {
+ SV* const xsub_tmp_sv = $arg;
+ SvGETMAGIC(xsub_tmp_sv);
+ if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){
+ $var = (AV*)SvRV(xsub_tmp_sv);
+ }
+ else{
+ Perl_croak_nocontext(\"%s: %s is not an ARRAY reference\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\");
+ }
+ } STMT_END
+T_AVREF_REFCOUNT_FIXED
+ STMT_START {
+ SV* const xsub_tmp_sv = $arg;
+ SvGETMAGIC(xsub_tmp_sv);
+ if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVAV){
+ $var = (AV*)SvRV(xsub_tmp_sv);
+ }
+ else{
+ Perl_croak_nocontext(\"%s: %s is not an ARRAY reference\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\");
+ }
+ } STMT_END
T_HVREF
- if (sv_isa($arg, \"${ntype}\"))
- $var = (HV*)SvRV($arg);
- else
- croak(\"$var is not of type ${ntype}\")
+ STMT_START {
+ SV* const xsub_tmp_sv = $arg;
+ SvGETMAGIC(xsub_tmp_sv);
+ if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){
+ $var = (HV*)SvRV(xsub_tmp_sv);
+ }
+ else{
+ Perl_croak_nocontext(\"%s: %s is not a HASH reference\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\");
+ }
+ } STMT_END
+T_HVREF_REFCOUNT_FIXED
+ STMT_START {
+ SV* const xsub_tmp_sv = $arg;
+ SvGETMAGIC(xsub_tmp_sv);
+ if (SvROK(xsub_tmp_sv) && SvTYPE(SvRV(xsub_tmp_sv)) == SVt_PVHV){
+ $var = (HV*)SvRV(xsub_tmp_sv);
+ }
+ else{
+ Perl_croak_nocontext(\"%s: %s is not a HASH reference\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\");
+ }
+ } STMT_END
T_CVREF
- if (sv_isa($arg, \"${ntype}\"))
- $var = (CV*)SvRV($arg);
- else
- croak(\"$var is not of type ${ntype}\")
+ STMT_START {
+ HV *st;
+ GV *gvp;
+ SV * const xsub_tmp_sv = $arg;
+ SvGETMAGIC(xsub_tmp_sv);
+ $var = sv_2cv(xsub_tmp_sv, &st, &gvp, 0);
+ if (!$var) {
+ Perl_croak_nocontext(\"%s: %s is not a CODE reference\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\");
+ }
+ } STMT_END
+T_CVREF_REFCOUNT_FIXED
+ STMT_START {
+ HV *st;
+ GV *gvp;
+ SV * const xsub_tmp_sv = $arg;
+ SvGETMAGIC(xsub_tmp_sv);
+ $var = sv_2cv(xsub_tmp_sv, &st, &gvp, 0);
+ if (!$var) {
+ Perl_croak_nocontext(\"%s: %s is not a CODE reference\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\");
+ }
+ } STMT_END
T_SYSRET
$var NOT IMPLEMENTED
+T_UV
+ $var = ($type)SvUV($arg)
T_IV
$var = ($type)SvIV($arg)
T_INT
T_ENUM
$var = ($type)SvIV($arg)
T_BOOL
- $var = (int)SvIV($arg)
+ $var = (bool)SvTRUE($arg)
T_U_INT
- $var = (unsigned int)SvIV($arg)
+ $var = (unsigned int)SvUV($arg)
T_SHORT
$var = (short)SvIV($arg)
T_U_SHORT
- $var = (unsigned short)SvIV($arg)
+ $var = (unsigned short)SvUV($arg)
T_LONG
$var = (long)SvIV($arg)
T_U_LONG
- $var = (unsigned long)SvIV($arg)
+ $var = (unsigned long)SvUV($arg)
T_CHAR
- $var = (char)*SvPV($arg,na)
+ $var = (char)*SvPV_nolen($arg)
T_U_CHAR
- $var = (unsigned char)SvIV($arg)
+ $var = (unsigned char)SvUV($arg)
T_FLOAT
$var = (float)SvNV($arg)
T_NV
T_DOUBLE
$var = (double)SvNV($arg)
T_PV
- $var = ($type)SvPV($arg,na)
+ $var = ($type)SvPV_nolen($arg)
T_PTR
- $var = ($type)SvIV($arg)
+ $var = INT2PTR($type,SvIV($arg))
T_PTRREF
if (SvROK($arg)) {
IV tmp = SvIV((SV*)SvRV($arg));
- $var = ($type) tmp;
+ $var = INT2PTR($type,tmp);
}
else
- croak(\"$var is not a reference\")
+ Perl_croak_nocontext(\"%s: %s is not a reference\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\")
T_REF_IV_REF
- if (sv_isa($arg, \"${type}\")) {
+ if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
- $var = *($type *) tmp;
+ $var = *INT2PTR($type *, tmp);
+ }
+ else {
+ const char* refstr = SvROK($arg) ? \"\" : SvOK($arg) ? \"scalar \" : \"undef\";
+ Perl_croak_nocontext(\"%s: Expected %s to be of type %s; got %s%\" SVf \" instead\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\", \"$ntype\",
+ refstr, $arg
+ );
}
- else
- croak(\"$var is not of type ${ntype}\")
T_REF_IV_PTR
- if (sv_isa($arg, \"${type}\")) {
+ if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
- $var = ($type) tmp;
+ $var = INT2PTR($type, tmp);
+ }
+ else {
+ const char* refstr = SvROK($arg) ? \"\" : SvOK($arg) ? \"scalar \" : \"undef\";
+ Perl_croak_nocontext(\"%s: Expected %s to be of type %s; got %s%\" SVf \" instead\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\", \"$ntype\",
+ refstr, $arg
+ );
}
- else
- croak(\"$var is not of type ${ntype}\")
T_PTROBJ
- if (sv_derived_from($arg, \"${ntype}\")) {
+ if (SvROK($arg) && sv_derived_from($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
- $var = ($type) tmp;
+ $var = INT2PTR($type,tmp);
+ }
+ else {
+ const char* refstr = SvROK($arg) ? \"\" : SvOK($arg) ? \"scalar \" : \"undef\";
+ Perl_croak_nocontext(\"%s: Expected %s to be of type %s; got %s%\" SVf \" instead\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\", \"$ntype\",
+ refstr, $arg
+ );
}
- else
- croak(\"$var is not of type ${ntype}\")
T_PTRDESC
if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
- ${type}_desc = (\U${type}_DESC\E*) tmp;
+ ${type}_desc = (\U${type}_DESC\E*) tmp;
$var = ${type}_desc->ptr;
}
- else
- croak(\"$var is not of type ${ntype}\")
+ else {
+ const char* refstr = SvROK($arg) ? \"\" : SvOK($arg) ? \"scalar \" : \"undef\";
+ Perl_croak_nocontext(\"%s: Expected %s to be of type %s; got %s%\" SVf \" instead\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\", \"$ntype\",
+ refstr, $arg
+ );
+ }
T_REFREF
if (SvROK($arg)) {
IV tmp = SvIV((SV*)SvRV($arg));
- $var = *($type) tmp;
+ $var = *INT2PTR($type,tmp);
}
else
- croak(\"$var is not a reference\")
+ Perl_croak_nocontext(\"%s: %s is not a reference\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\")
T_REFOBJ
if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
- $var = *($type) tmp;
+ $var = *INT2PTR($type,tmp);
+ }
+ else {
+ const char* refstr = SvROK($arg) ? \"\" : SvOK($arg) ? \"scalar \" : \"undef\";
+ Perl_croak_nocontext(\"%s: Expected %s to be of type %s; got %s%\" SVf \" instead\",
+ ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]},
+ \"$var\", \"$ntype\",
+ refstr, $arg
+ );
}
- else
- croak(\"$var is not of type ${ntype}\")
T_OPAQUE
- $var NOT IMPLEMENTED
+ $var = *($type *)SvPV_nolen($arg)
T_OPAQUEPTR
- $var = ($type)SvPV($arg,na)
+ $var = ($type)SvPV_nolen($arg)
T_PACKED
$var = XS_unpack_$ntype($arg)
T_PACKEDARRAY
$var = XS_unpack_$ntype($arg)
-T_CALLBACK
- $var = make_perl_cb_$type($arg)
T_ARRAY
- $var = $ntype(items -= $argoff);
U32 ix_$var = $argoff;
+ $var = $ntype(items -= $argoff);
while (items--) {
DO_ARRAY_ELEM;
+ ix_$var++;
}
+ /* this is the number of elements in the array */
+ ix_$var -= $argoff
+T_STDIO
+ $var = PerlIO_findFILE(IoIFP(sv_2io($arg)))
T_IN
$var = IoIFP(sv_2io($arg))
T_INOUT
#############################################################################
OUTPUT
T_SV
- $arg = $var;
+ ${ "$var" eq "RETVAL" ? \"$arg = $var;" : \"sv_setsv_mg($arg, $var);" }
T_SVREF
$arg = newRV((SV*)$var);
+T_SVREF_REFCOUNT_FIXED
+ ${ "$var" eq "RETVAL" ? \"$arg = newRV_noinc((SV*)$var);" : \"sv_setrv_noinc($arg, (SV*)$var);" }
T_AVREF
$arg = newRV((SV*)$var);
+T_AVREF_REFCOUNT_FIXED
+ $arg = newRV_noinc((SV*)$var);
T_HVREF
$arg = newRV((SV*)$var);
+T_HVREF_REFCOUNT_FIXED
+ $arg = newRV_noinc((SV*)$var);
T_CVREF
$arg = newRV((SV*)$var);
+T_CVREF_REFCOUNT_FIXED
+ $arg = newRV_noinc((SV*)$var);
T_IV
- SvSetMagicIV($arg, (IV)$var);
+ sv_setiv($arg, (IV)$var);
+T_UV
+ sv_setuv($arg, (UV)$var);
T_INT
- SvSetMagicIV($arg, (IV)$var);
+ sv_setiv($arg, (IV)$var);
T_SYSRET
if ($var != -1) {
if ($var == 0)
- SvSetMagicPVN($arg, "0 but true", 10);
+ sv_setpvn($arg, "0 but true", 10);
else
- SvSetMagicIV($arg, (IV)$var);
+ sv_setiv($arg, (IV)$var);
}
T_ENUM
- SvSetMagicIV($arg, (IV)$var);
+ sv_setiv($arg, (IV)$var);
T_BOOL
- $arg = boolSV($var);
+ ${"$var" eq "RETVAL" ? \"$arg = boolSV($var);" : \"sv_setsv($arg, boolSV($var));"}
T_U_INT
- SvSetMagicIV($arg, (IV)$var);
+ sv_setuv($arg, (UV)$var);
T_SHORT
- SvSetMagicIV($arg, (IV)$var);
+ sv_setiv($arg, (IV)$var);
T_U_SHORT
- SvSetMagicIV($arg, (IV)$var);
+ sv_setuv($arg, (UV)$var);
T_LONG
- SvSetMagicIV($arg, (IV)$var);
+ sv_setiv($arg, (IV)$var);
T_U_LONG
- SvSetMagicIV($arg, (IV)$var);
+ sv_setuv($arg, (UV)$var);
T_CHAR
- SvSetMagicPVN($arg, (char *)&$var, 1);
+ sv_setpvn($arg, (char *)&$var, 1);
T_U_CHAR
- SvSetMagicIV($arg, (IV)$var);
+ sv_setuv($arg, (UV)$var);
T_FLOAT
- SvSetMagicNV($arg, (double)$var);
+ sv_setnv($arg, (double)$var);
T_NV
- SvSetMagicNV($arg, (double)$var);
+ sv_setnv($arg, (NV)$var);
T_DOUBLE
- SvSetMagicNV($arg, (double)$var);
+ sv_setnv($arg, (double)$var);
T_PV
- SvSetMagicPV((SV*)$arg, $var);
+ sv_setpv((SV*)$arg, $var);
T_PTR
- SvSetMagicIV($arg, (IV)$var);
+ sv_setiv($arg, PTR2IV($var));
T_PTRREF
sv_setref_pv($arg, Nullch, (void*)$var);
T_REF_IV_REF
T_PTRDESC
sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var));
T_REFREF
- sv_setrefref($arg, \"${ntype}\", XS_service_$ntype,
- ($var ? (void*)new $ntype($var) : 0));
+ NOT_IMPLEMENTED
T_REFOBJ
NOT IMPLEMENTED
T_OPAQUE
- SvSetMagicPVN($arg, (char *)&$var, sizeof($var));
+ sv_setpvn($arg, (char *)&$var, sizeof($var));
T_OPAQUEPTR
- SvSetMagicPVN($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var);
+ sv_setpvn($arg, (char *)$var, sizeof(*$var));
T_PACKED
XS_pack_$ntype($arg, $var);
T_PACKEDARRAY
XS_pack_$ntype($arg, $var, count_$ntype);
-T_DATAUNIT
- SvSetMagicPVN($arg, $var.chp(), $var.size());
-T_CALLBACK
- SvSetMagicPVN($arg, $var.context.value().chp(),
- $var.context.value().size());
T_ARRAY
- ST_EXTEND($var.size);
- for (U32 ix_$var = 0; ix_$var < $var.size; ix_$var++) {
+ {
+ U32 ix_$var;
+ SSize_t extend_size =
+ /* The weird way this is written is because g++ is dumb
+ * enough to warn "comparison is always false" on something
+ * like:
+ *
+ * sizeof(a) > sizeof(b) && a > B_t_MAX
+ *
+ * (where the LH condition is false)
+ */
+ (size_$var > (sizeof(size_$var) > sizeof(SSize_t)
+ ? SSize_t_MAX : size_$var))
+ ? -1 : (SSize_t)size_$var;
+ EXTEND(SP, extend_size);
+ for (ix_$var = 0; ix_$var < size_$var; ix_$var++) {
ST(ix_$var) = sv_newmortal();
DO_ARRAY_ELEM
+ }
+ }
+T_STDIO
+ {
+ GV *gv = (GV *)sv_newmortal();
+ PerlIO *fp = PerlIO_importFILE($var,0);
+ gv_init_pvn(gv, gv_stashpvs("$Package",1),"__ANONIO__",10,0);
+ if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) ) {
+ SV *rv = newRV_inc((SV*)gv);
+ rv = sv_bless(rv, GvSTASH(gv));
+ ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);"
+ : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"}
+ }${"$var" ne "RETVAL" ? \"
+ else
+ sv_setsv($arg, &PL_sv_undef);\n" : \""}
}
- sp += $var.size - 1;
T_IN
{
- GV *gv = newGVgen("$Package");
- if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) )
- SvSetMagicSV($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+ GV *gv = (GV *)sv_newmortal();
+ gv_init_pvn(gv, gv_stashpvs("$Package",1),"__ANONIO__",10,0);
+ if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) ) {
+ SV *rv = newRV_inc((SV*)gv);
+ rv = sv_bless(rv, GvSTASH(gv));
+ ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);"
+ : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"}
+ }${"$var" ne "RETVAL" ? \"
else
- $arg = &sv_undef;
+ sv_setsv($arg, &PL_sv_undef);\n" : \""}
}
T_INOUT
{
- GV *gv = newGVgen("$Package");
- if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) )
- SvSetMagicSV($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+ GV *gv = (GV *)sv_newmortal();
+ gv_init_pvn(gv, gv_stashpvs("$Package",1),"__ANONIO__",10,0);
+ if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) ) {
+ SV *rv = newRV_inc((SV*)gv);
+ rv = sv_bless(rv, GvSTASH(gv));
+ ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);"
+ : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"}
+ }${"$var" ne "RETVAL" ? \"
else
- $arg = &sv_undef;
+ sv_setsv($arg, &PL_sv_undef);\n" : \""}
}
T_OUT
{
- GV *gv = newGVgen("$Package");
- if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
- SvSetMagicSV($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
+ GV *gv = (GV *)sv_newmortal();
+ gv_init_pvn(gv, gv_stashpvs("$Package",1),"__ANONIO__",10,0);
+ if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) {
+ SV *rv = newRV_inc((SV*)gv);
+ rv = sv_bless(rv, GvSTASH(gv));
+ ${"$var" eq "RETVAL" ? \"$arg = sv_2mortal(rv);"
+ : \"sv_setsv($arg, rv);\n\t\tSvREFCNT_dec_NN(rv);"}
+ }${"$var" ne "RETVAL" ? \"
else
- $arg = &sv_undef;
+ sv_setsv($arg, &PL_sv_undef);\n" : \""}
}
https://perl5.git.perl.org / perl5.git / blobdiff