X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=perl_c.c;h=ce5366722ee07171212957e3e9accb4e28abdebe;hb=36b9a44ab49471646b7a3548d1e2d28c015063ad;hp=690b14572df218a152af0e064ae1212cfa570a59;hpb=dafc0bde0b51d76c41b2d646af3699730e31dfbb;p=perl4caml.git diff --git a/perl_c.c b/perl_c.c index 690b145..ce53667 100644 --- a/perl_c.c +++ b/perl_c.c @@ -1,6 +1,22 @@ /* Interface to Perl from OCaml. - * Copyright (C) 2003 Merjis Ltd. - * $Id: perl_c.c,v 1.3 2003-10-12 11:56:26 rich Exp $ + Copyright (C) 2003 Merjis Ltd. + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library 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 + Library General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this library; see the file COPYING. If not, write to + the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + $Id: perl_c.c,v 1.25 2008-03-01 13:02:21 rich Exp $ */ #include @@ -9,97 +25,81 @@ #include #include +#define CAML_NAME_SPACE 1 + #include #include +#include #include #include #include -/* XXX This was required to avoid an error on my machine when loading the Perl - * headers. Not clear why this is missing. - */ -#define off64_t __off64_t - #include #include /* Perl requires the interpreter to be called literally 'my_perl'! */ static PerlInterpreter *my_perl; -/* Wrap up an arbitrary void pointer in an opaque OCaml object. */ -static value Val_voidptr (void *ptr); - /* Get the concrete value from an optional field. */ static value unoption (value option, value deflt); +/* Wrap up an arbitrary void pointer in an opaque OCaml object. */ +static value Val_voidptr (void *ptr); + /* Unwrap an arbitrary void pointer from an opaque OCaml object. */ #define Voidptr_val(type,rv) ((type *) Field ((rv), 0)) -/* Hide Perl types in opaque OCaml objects. */ -#define Val_perl(pl) (Val_voidptr ((pl))) -#define Perl_val(plv) (Voidptr_val (PerlInterpreter, (plv))) -#define Val_sv(sv) (Val_voidptr ((sv))) -#define Sv_val(svv) (Voidptr_val (SV, (svv))) +#if PERL4CAML_REFCOUNTING_EXPERIMENTAL -CAMLprim value -perl4caml_init (value unit) -{ - PERL_SYS_INIT3 (NULL, NULL, NULL); - return Val_unit; -} +/* Unwrap a custom block. */ +#define Xv_val(rv) (*((void **)Data_custom_val(rv))) -CAMLprim value -perl4caml_create (value optargs, value unit) -{ - CAMLparam2 (optargs, unit); - CAMLlocal1 (args); - int argc, i; - char **argv; - static char *no_args[] = { "", "-e", "0" }; +/* Wrap up an SV, AV or HV in a custom OCaml object which will decrement + * the reference count on finalization. + */ +static value Val_xv (SV *sv); - /* Arguments given? */ - if (optargs == Val_int (0)) /* "None" */ - { - argc = 3; - argv = no_args; - } - else /* "Some args" where args is a string array. */ - { - args = Field (optargs, 0); - argc = Wosize_val (args); - argv = alloca (argc * sizeof (char *)); - for (i = 0; i < argc; ++i) argv[i] = String_val (Field (args, i)); - } +#else - my_perl = perl_alloc (); - perl_construct (my_perl); - PL_exit_flags |= PERL_EXIT_DESTRUCT_END; - perl_parse (my_perl, NULL, argc, argv, NULL); - perl_run (my_perl); +#define Xv_val(rv) Voidptr_val (SV, (rv)) +#define Val_xv(sv) Val_voidptr ((sv)) - CAMLreturn (Val_perl (my_perl)); -} +#endif -CAMLprim value -perl4caml_destroy (value plv) +/* Hide Perl types in opaque OCaml objects. */ +#define Val_perl(pl) (Val_voidptr ((pl))) +#define Perl_val(plv) (Voidptr_val (PerlInterpreter, (plv))) +#define Val_sv(sv) (Val_xv ((sv))) +#define Sv_val(svv) ((SV *) Xv_val (svv)) +#define Val_av(av) (Val_xv ((SV *)(av))) +#define Av_val(avv) ((AV *) Xv_val (avv)) +#define Val_hv(hv) (Val_xv ((SV *)(hv))) +#define Hv_val(hvv) ((HV *) Xv_val (hvv)) +#define Val_he(he) (Val_voidptr ((he))) +#define He_val(hev) (Voidptr_val (HE, (hev))) + +static void +xs_init (pTHX) { - CAMLparam1 (plv); - PerlInterpreter *pl = Perl_val (plv); - - perl_destruct (pl); - perl_free (pl); + char *file = __FILE__; + EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); - CAMLreturn (Val_unit); + newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); } CAMLprim value -perl4caml_set_context (value plv) +perl4caml_init (value unit) { - CAMLparam1 (plv); - PerlInterpreter *pl = Perl_val (plv); + CAMLparam1 (unit); + int argc = 4; + static char *argv[] = { "", "-w", "-e", "0", NULL }; - PERL_SET_CONTEXT (pl); - my_perl = pl; + PERL_SYS_INIT (&argc, &argv); + my_perl = perl_alloc (); + perl_construct (my_perl); + PL_exit_flags |= PERL_EXIT_DESTRUCT_END; + perl_parse (my_perl, xs_init, argc, argv, (char **) NULL); + /*perl_run (my_perl);*/ CAMLreturn (Val_unit); } @@ -125,7 +125,7 @@ perl4caml_float_of_sv (value svv) CAMLparam1 (svv); SV *sv = Sv_val (svv); CAMLlocal1 (f); - f = copy_double (SvNV (sv)); + f = caml_copy_double (SvNV (sv)); CAMLreturn (f); } @@ -133,7 +133,7 @@ CAMLprim value perl4caml_sv_of_float (value fv) { CAMLparam1 (fv); - CAMLreturn (Val_sv (newSViv (Double_val (fv)))); + CAMLreturn (Val_sv (newSVnv (Double_val (fv)))); } CAMLprim value @@ -145,8 +145,8 @@ perl4caml_string_of_sv (value svv) STRLEN len; CAMLlocal1 (strv); str = SvPV (sv, len); - /* XXX This won't work if the string contains NUL. */ - strv = copy_string (str); + strv = caml_alloc_string (len); + memcpy (String_val (strv), str, len); CAMLreturn (strv); } @@ -154,7 +154,7 @@ CAMLprim value perl4caml_sv_of_string (value strv) { CAMLparam1 (strv); - CAMLreturn (Val_sv (newSVpv (String_val (strv), string_length (strv)))); + CAMLreturn (Val_sv (newSVpv (String_val (strv), caml_string_length (strv)))); } CAMLprim value @@ -166,32 +166,497 @@ perl4caml_sv_is_true (value svv) } CAMLprim value +perl4caml_sv_undef (value unit) +{ + CAMLparam1 (unit); + /*CAMLreturn (Val_sv (newSV (0)));*/ + CAMLreturn (Val_sv (&PL_sv_undef)); +} + +CAMLprim value perl4caml_sv_is_undef (value svv) { CAMLparam1 (svv); SV *sv = Sv_val (svv); - CAMLreturn (sv == &PL_sv_undef ? Val_true : Val_false); + CAMLreturn (!SvPOK (sv) && !SvIOK (sv) && SvTYPE (sv) == SVt_NULL + ? Val_true : Val_false); } CAMLprim value -perl4caml_sv_get_undef (value unit) +perl4caml_sv_yes (value unit) { CAMLparam1 (unit); - CAMLreturn (Val_sv (&PL_sv_undef)); + CAMLreturn (Val_sv (&PL_sv_yes)); } CAMLprim value -perl4caml_sv_get_yes (value unit) +perl4caml_sv_no (value unit) { CAMLparam1 (unit); - CAMLreturn (Val_sv (&PL_sv_yes)); + CAMLreturn (Val_sv (&PL_sv_no)); +} + +static int +sv_type (SV *sv) +{ +#if PERL_VERSION >= 11 + if (SvROK(sv)) return 4; +#endif + switch (SvTYPE (sv)) + { + case SVt_IV: return 1; + case SVt_NV: return 2; + case SVt_PV: return 3; +#if PERL_VERSION < 11 + case SVt_RV: return 4; +#endif + case SVt_PVAV: return 5; + case SVt_PVHV: return 6; + case SVt_PVCV: return 7; + case SVt_PVGV: return 8; + case SVt_PVMG: return 9; + default: return 0; + } +} + +CAMLprim value +perl4caml_sv_type (value svv) +{ + CAMLparam1 (svv); + SV *sv = Sv_val (svv); + + CAMLreturn (Val_int (sv_type (sv))); +} + +CAMLprim value +perl4caml_address_of_sv (value svv) +{ + CAMLparam1 (svv); + SV *sv = Sv_val (svv); + CAMLreturn (caml_copy_nativeint ((long) sv)); +} + +CAMLprim value +perl4caml_address_of_av (value avv) +{ + CAMLparam1 (avv); + AV *av = Av_val (avv); + CAMLreturn (caml_copy_nativeint ((long) av)); +} + +CAMLprim value +perl4caml_address_of_hv (value hvv) +{ + CAMLparam1 (hvv); + HV *hv = Hv_val (hvv); + CAMLreturn (caml_copy_nativeint ((long) hv)); +} + +CAMLprim value +perl4caml_scalarref (value svv) +{ + CAMLparam1 (svv); + CAMLlocal1 (rsvv); + SV *sv = Sv_val (svv); + rsvv = Val_sv (newRV_inc (sv)); + CAMLreturn (rsvv); } CAMLprim value -perl4caml_sv_get_no (value unit) +perl4caml_arrayref (value avv) +{ + CAMLparam1 (avv); + CAMLlocal1 (rsvv); + AV *av = Av_val (avv); + rsvv = Val_sv (newRV_inc ((SV *) av)); + CAMLreturn (rsvv); +} + +CAMLprim value +perl4caml_hashref (value hvv) +{ + CAMLparam1 (hvv); + CAMLlocal1 (rsvv); + HV *hv = Hv_val (hvv); + rsvv = Val_sv (newRV_inc ((SV *) hv)); + CAMLreturn (rsvv); +} + +CAMLprim value +perl4caml_reftype (value svv) +{ + CAMLparam1 (svv); + SV *sv = Sv_val (svv); + + if (!SvROK (sv)) + caml_invalid_argument ("reftype: SV is not a reference"); + + CAMLreturn (Val_int (sv_type (SvRV (sv)))); +} + +CAMLprim value +perl4caml_deref (value svv) +{ + CAMLparam1 (svv); + CAMLlocal1 (rsvv); + SV *sv = Sv_val (svv); + + if (!SvROK (sv)) + caml_invalid_argument ("deref: SV is not a reference"); + switch (SvTYPE (SvRV (sv))) { + case SVt_IV: + case SVt_NV: + case SVt_PV: +#if PERL_VERSION < 11 + case SVt_RV: +#endif + case SVt_PVMG: + break; + default: + caml_invalid_argument ("deref: SV is not a reference to a scalar"); + } + sv = SvRV (sv); + /* Increment the reference count because we're creating another + * value pointing at the referenced SV. + */ + sv = SvREFCNT_inc (sv); + rsvv = Val_sv (sv); + CAMLreturn (rsvv); +} + +CAMLprim value +perl4caml_deref_array (value svv) +{ + CAMLparam1 (svv); + CAMLlocal1 (ravv); + SV *sv = Sv_val (svv); + + if (!SvROK (sv)) + caml_invalid_argument ("deref_array: SV is not a reference"); + switch (SvTYPE (SvRV (sv))) { + case SVt_PVAV: + break; + default: + caml_invalid_argument ("deref_array: SV is not a reference to an array"); + } + sv = SvRV (sv); + /* Increment the reference count because we're creating another + * value pointing at the referenced AV. + */ + sv = SvREFCNT_inc (sv); + ravv = Val_av ((AV *) sv); + CAMLreturn (ravv); +} + +CAMLprim value +perl4caml_deref_hash (value svv) +{ + CAMLparam1 (svv); + CAMLlocal1 (rhvv); + SV *sv = Sv_val (svv); + + if (!SvROK (sv)) + caml_invalid_argument ("deref_hash: SV is not a reference"); + switch (SvTYPE (SvRV (sv))) { + case SVt_PVHV: + break; + default: + caml_invalid_argument ("deref_hash: SV is not a reference to a hash"); + } + sv = SvRV (sv); + /* Increment the reference count because we're creating another + * value pointing at the referenced HV. + */ + sv = SvREFCNT_inc (sv); + rhvv = Val_hv ((HV *) sv); + CAMLreturn (rhvv); +} + +CAMLprim value +perl4caml_av_empty (value unit) { CAMLparam1 (unit); - CAMLreturn (Val_sv (&PL_sv_no)); + AV *av = newAV (); + CAMLreturn (Val_av (av)); +} + +/* We don't know in advance how long the list will be, which makes this + * a little harder. + */ +CAMLprim value +perl4caml_av_of_sv_list (value svlistv) +{ + CAMLparam1 (svlistv); + CAMLlocal1 (svv); + SV *sv, **svlist = 0; + int alloc = 0, size = 0; + AV *av; + + for (; svlistv != Val_int (0); svlistv = Field (svlistv, 1)) + { + svv = Field (svlistv, 0); + sv = Sv_val (svv); + if (size >= alloc) { + alloc = alloc == 0 ? 1 : alloc * 2; + svlist = realloc (svlist, alloc * sizeof (SV *)); + } + svlist[size++] = sv; + } + + av = av_make (size, svlist); + + if (alloc > 0) free (svlist); /* Free memory allocated to SV list. */ + + CAMLreturn (Val_av (av)); +} + +/* XXX av_map would be faster if we also had sv_list_of_av. */ + +CAMLprim value +perl4caml_av_push (value avv, value svv) +{ + CAMLparam2 (avv, svv); + AV *av = Av_val (avv); + SV *sv = Sv_val (svv); + av_push (av, sv); + CAMLreturn (Val_unit); +} + +CAMLprim value +perl4caml_av_pop (value avv) +{ + CAMLparam1 (avv); + AV *av = Av_val (avv); + SV *sv = av_pop (av); + /* Increment the reference count because we're creating another + * value pointing at the referenced AV. + */ + sv = SvREFCNT_inc (sv); + CAMLreturn (Val_sv (sv)); +} + +CAMLprim value +perl4caml_av_unshift (value avv, value svv) +{ + CAMLparam2 (avv, svv); + AV *av = Av_val (avv); + SV *sv = Sv_val (svv); + av_unshift (av, 1); + SvREFCNT_inc (sv); + if (av_store (av, 0, sv) == 0) + SvREFCNT_dec (sv); + CAMLreturn (Val_unit); +} + +CAMLprim value +perl4caml_av_shift (value avv) +{ + CAMLparam1 (avv); + AV *av = Av_val (avv); + SV *sv = av_shift (av); + /* Increment the reference count because we're creating another + * value pointing at the referenced AV. + */ + sv = SvREFCNT_inc (sv); + CAMLreturn (Val_sv (sv)); +} + +CAMLprim value +perl4caml_av_length (value avv) +{ + CAMLparam1 (avv); + AV *av = Av_val (avv); + CAMLreturn (Val_int (av_len (av) + 1)); +} + +CAMLprim value +perl4caml_av_set (value avv, value i, value svv) +{ + CAMLparam3 (avv, i, svv); + AV *av = Av_val (avv); + SV *sv = Sv_val (svv); + SvREFCNT_inc (sv); + if (av_store (av, Int_val (i), sv) == 0) + SvREFCNT_dec (sv); + CAMLreturn (Val_unit); +} + +CAMLprim value +perl4caml_av_get (value avv, value i) +{ + CAMLparam2 (avv, i); + AV *av = Av_val (avv); + SV **svp = av_fetch (av, Int_val (i), 0); + if (svp == 0) caml_invalid_argument ("av_get: index out of bounds"); + /* Increment the reference count because we're creating another + * value pointing at the referenced AV. + */ + *svp = SvREFCNT_inc (*svp); + CAMLreturn (Val_sv (*svp)); +} + +CAMLprim value +perl4caml_av_clear (value avv) +{ + CAMLparam1 (avv); + AV *av = Av_val (avv); + av_clear (av); + CAMLreturn (Val_unit); +} + +CAMLprim value +perl4caml_av_undef (value avv) +{ + CAMLparam1 (avv); + AV *av = Av_val (avv); + av_undef (av); + CAMLreturn (Val_unit); +} + +CAMLprim value +perl4caml_av_extend (value avv, value i) +{ + CAMLparam2 (avv, i); + AV *av = Av_val (avv); + av_extend (av, Int_val (i)); + CAMLreturn (Val_unit); +} + +CAMLprim value +perl4caml_hv_empty (value unit) +{ + CAMLparam1 (unit); + HV *hv = newHV (); + CAMLreturn (Val_hv (hv)); +} + +CAMLprim value +perl4caml_hv_set (value hvv, value key, value svv) +{ + CAMLparam3 (hvv, key, svv); + HV *hv = Hv_val (hvv); + SV *sv = Sv_val (svv); + SvREFCNT_inc (sv); + if (hv_store (hv, String_val (key), caml_string_length (key), sv, 0) == 0) + SvREFCNT_dec (sv); + CAMLreturn (Val_unit); +} + +CAMLprim value +perl4caml_hv_get (value hvv, value key) +{ + CAMLparam2 (hvv, key); + HV *hv = Hv_val (hvv); + SV **svp = hv_fetch (hv, String_val (key), caml_string_length (key), 0); + if (svp == 0) caml_raise_not_found (); + /* Increment the reference count because we're creating another + * value pointing at the referenced SV. + */ + SvREFCNT_inc (*svp); + CAMLreturn (Val_sv (*svp)); +} + +CAMLprim value +perl4caml_hv_exists (value hvv, value key) +{ + CAMLparam2 (hvv, key); + HV *hv = Hv_val (hvv); + bool r = hv_exists (hv, String_val (key), caml_string_length (key)); + CAMLreturn (r ? Val_true : Val_false); +} + +CAMLprim value +perl4caml_hv_delete (value hvv, value key) +{ + CAMLparam2 (hvv, key); + HV *hv = Hv_val (hvv); + hv_delete (hv, String_val (key), caml_string_length (key), G_DISCARD); + CAMLreturn (Val_unit); +} + +CAMLprim value +perl4caml_hv_clear (value hvv) +{ + CAMLparam1 (hvv); + HV *hv = Hv_val (hvv); + hv_clear (hv); + CAMLreturn (Val_unit); +} + +CAMLprim value +perl4caml_hv_undef (value hvv) +{ + CAMLparam1 (hvv); + HV *hv = Hv_val (hvv); + hv_undef (hv); + CAMLreturn (Val_unit); +} + +CAMLprim value +perl4caml_hv_iterinit (value hvv) +{ + CAMLparam1 (hvv); + HV *hv = Hv_val (hvv); + int i = hv_iterinit (hv); + CAMLreturn (caml_copy_int32 (i)); +} + +CAMLprim value +perl4caml_hv_iternext (value hvv) +{ + CAMLparam1 (hvv); + CAMLlocal1 (hev); + HV *hv = Hv_val (hvv); + HE *he = hv_iternext (hv); + if (he == NULL) caml_raise_not_found (); + hev = Val_he (he); + CAMLreturn (hev); +} + +CAMLprim value +perl4caml_hv_iterkey (value hev) +{ + CAMLparam1 (hev); + CAMLlocal1 (strv); + HE *he = He_val (hev); + I32 len; + char *str = hv_iterkey (he, &len); + strv = caml_alloc_string (len); + memcpy (String_val (strv), str, len); + CAMLreturn (strv); +} + +CAMLprim value +perl4caml_hv_iterval (value hvv, value hev) +{ + CAMLparam2 (hvv, hev); + CAMLlocal1 (svv); + HV *hv = Hv_val (hvv); + HE *he = He_val (hev); + SV *sv = hv_iterval (hv, he); + SvREFCNT_inc (sv); + svv = Val_sv (sv); + CAMLreturn (svv); +} + +CAMLprim value +perl4caml_hv_iternextsv (value hvv) +{ + CAMLparam1 (hvv); + CAMLlocal3 (strv, svv, rv); + HV *hv = Hv_val (hvv); + char *str; I32 len; + SV *sv = hv_iternextsv (hv, &str, &len); + if (sv == NULL) caml_raise_not_found (); + SvREFCNT_inc (sv); + svv = Val_sv (sv); + strv = caml_alloc_string (len); + memcpy (String_val (strv), str, len); + /* Construct a tuple (strv, svv). */ + rv = caml_alloc_tuple (2); + Field (rv, 0) = strv; + Field (rv, 1) = svv; + CAMLreturn (rv); } CAMLprim value @@ -203,12 +668,76 @@ perl4caml_get_sv (value optcreate, value name) create = unoption (optcreate, Val_false); sv = get_sv (String_val (name), create == Val_true ? TRUE : FALSE); - if (sv == NULL) raise_not_found (); + if (sv == NULL) caml_raise_not_found (); + + /* Increment the reference count because we're creating another + * value pointing at the referenced SV. + */ + SvREFCNT_inc (sv); CAMLreturn (Val_sv (sv)); } CAMLprim value +perl4caml_get_av (value optcreate, value name) +{ + CAMLparam2 (optcreate, name); + CAMLlocal1 (create); + AV *av; + + create = unoption (optcreate, Val_false); + av = get_av (String_val (name), create == Val_true ? TRUE : FALSE); + if (av == NULL) caml_raise_not_found (); + + /* Increment the reference count because we're creating another + * value pointing at the AV. + */ + SvREFCNT_inc (av); + + CAMLreturn (Val_av (av)); +} + +CAMLprim value +perl4caml_get_hv (value optcreate, value name) +{ + CAMLparam2 (optcreate, name); + CAMLlocal1 (create); + HV *hv; + + create = unoption (optcreate, Val_false); + hv = get_hv (String_val (name), create == Val_true ? TRUE : FALSE); + if (hv == NULL) caml_raise_not_found (); + + /* Increment the reference count because we're creating another + * value pointing at the HV. + */ + SvREFCNT_inc (hv); + + CAMLreturn (Val_hv (hv)); +} + +static inline void +check_perl_failure () +{ + CAMLparam0 (); + CAMLlocal1 (errv); + + SV *errsv = get_sv ("@", TRUE); + + if (SvTRUE (errsv)) /* Equivalent of $@ in Perl. */ + { + STRLEN n_a; + const char *err = SvPV (errsv, n_a); + + errv = caml_copy_string (err); + + caml_raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); + } + + CAMLreturn0; +} + +CAMLprim value perl4caml_call (value optsv, value optfnname, value arglist) { CAMLparam3 (optsv, optfnname, arglist); @@ -263,23 +792,10 @@ perl4caml_call (value optsv, value optfnname, value arglist) FREETMPS; LEAVE; - /* Died with an error? - * XXX Actually this doesn't work for some reason. - */ - if (SvTRUE (ERRSV)) - { - STRLEN n_a; - const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */ + check_perl_failure (); - errv = copy_string (err); - - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - { - svv = Val_sv (sv); - CAMLreturn (svv); - } + svv = Val_sv (sv); + CAMLreturn (svv); } CAMLprim value @@ -332,10 +848,13 @@ perl4caml_call_array (value optsv, value optfnname, value arglist) */ list = Val_int (0); for (i = 0; i < count; ++i) { - cons = alloc (2, 0); + SV *sv; + + cons = caml_alloc (2, 0); Field (cons, 1) = list; list = cons; - Field (cons, 0) = Val_sv (newSVsv (POPs)); + sv = newSVsv (POPs); + Field (cons, 0) = Val_sv (sv); } /* Restore the stack. */ @@ -343,20 +862,9 @@ perl4caml_call_array (value optsv, value optfnname, value arglist) FREETMPS; LEAVE; - /* Died with an error? - * XXX Actually this doesn't work for some reason. - */ - if (SvTRUE (ERRSV)) - { - STRLEN n_a; - const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */ - - errv = copy_string (err); + check_perl_failure (); - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - CAMLreturn (list); + CAMLreturn (list); } CAMLprim value @@ -393,7 +901,7 @@ perl4caml_call_void (value optsv, value optfnname, value arglist) else if (optfnname != Val_int (0)) { fnname = unoption (optfnname, Val_false); - count = call_pv (String_val (fnname), G_EVAL|G_VOID); + count = call_pv (String_val (fnname), G_EVAL|G_VOID|G_DISCARD); } else { @@ -404,27 +912,16 @@ perl4caml_call_void (value optsv, value optfnname, value arglist) SPAGAIN; - assert (count == 0); /* Pretty sure it should never be anything else. */ + assert (count == 0); /* Restore the stack. */ PUTBACK; FREETMPS; LEAVE; - /* Died with an error? - * XXX Actually this doesn't work for some reason. - */ - if (SvTRUE (ERRSV)) - { - STRLEN n_a; - const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */ - - errv = copy_string (err); + check_perl_failure (); - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - CAMLreturn (Val_unit); + CAMLreturn (Val_unit); } CAMLprim value @@ -435,35 +932,12 @@ perl4caml_eval (value expr) SV *sv; CAMLlocal2 (errv, svv); - ENTER; - SAVETMPS; - - PUSHMARK (SP); - eval_pv (String_val (expr), G_SCALAR); - - SPAGAIN; - sv = newSVsv (POPs); - PUTBACK; - FREETMPS; - LEAVE; - - /* Died with an error? - * XXX Actually this doesn't work for some reason. - */ - if (SvTRUE (ERRSV)) - { - STRLEN n_a; - const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */ + sv = eval_pv (String_val (expr), G_SCALAR); - errv = copy_string (err); + check_perl_failure (); - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - { - svv = Val_sv (sv); - CAMLreturn (svv); - } + svv = Val_sv (sv); + CAMLreturn (svv); } CAMLprim value @@ -508,23 +982,10 @@ perl4caml_call_method (value ref, value name, value arglist) FREETMPS; LEAVE; - /* Died with an error? - * XXX Actually this doesn't work for some reason. - */ - if (SvTRUE (ERRSV)) - { - STRLEN n_a; - const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */ - - errv = copy_string (err); + check_perl_failure (); - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - { - svv = Val_sv (sv); - CAMLreturn (svv); - } + svv = Val_sv (sv); + CAMLreturn (svv); } CAMLprim value @@ -564,10 +1025,13 @@ perl4caml_call_method_array (value ref, value name, value arglist) */ list = Val_int (0); for (i = 0; i < count; ++i) { - cons = alloc (2, 0); + SV *sv; + + cons = caml_alloc (2, 0); Field (cons, 1) = list; list = cons; - Field (cons, 0) = Val_sv (newSVsv (POPs)); + sv = newSVsv (POPs); + Field (cons, 0) = Val_sv (sv); } /* Restore the stack. */ @@ -575,20 +1039,9 @@ perl4caml_call_method_array (value ref, value name, value arglist) FREETMPS; LEAVE; - /* Died with an error? - * XXX Actually this doesn't work for some reason. - */ - if (SvTRUE (ERRSV)) - { - STRLEN n_a; - const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */ - - errv = copy_string (err); + check_perl_failure (); - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - CAMLreturn (list); + CAMLreturn (list); } CAMLprim value @@ -619,31 +1072,20 @@ perl4caml_call_method_void (value ref, value name, value arglist) PUTBACK; - count = call_method (String_val (name), G_EVAL|G_VOID); + count = call_method (String_val (name), G_EVAL|G_VOID|G_DISCARD); SPAGAIN; - assert (count == 0); /* Pretty sure it should never be anything else. */ + assert (count == 0); /* Restore the stack. */ PUTBACK; FREETMPS; LEAVE; - /* Died with an error? - * XXX Actually this doesn't work for some reason. - */ - if (SvTRUE (ERRSV)) - { - STRLEN n_a; - const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */ - - errv = copy_string (err); + check_perl_failure (); - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - CAMLreturn (Val_unit); + CAMLreturn (Val_unit); } CAMLprim value @@ -687,23 +1129,10 @@ perl4caml_call_class_method (value classname, value name, value arglist) FREETMPS; LEAVE; - /* Died with an error? - * XXX Actually this doesn't work for some reason. - */ - if (SvTRUE (ERRSV)) - { - STRLEN n_a; - const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */ - - errv = copy_string (err); + check_perl_failure (); - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - { - svv = Val_sv (sv); - CAMLreturn (svv); - } + svv = Val_sv (sv); + CAMLreturn (svv); } CAMLprim value @@ -742,7 +1171,7 @@ perl4caml_call_class_method_array (value classname, value name, value arglist) */ list = Val_int (0); for (i = 0; i < count; ++i) { - cons = alloc (2, 0); + cons = caml_alloc (2, 0); Field (cons, 1) = list; list = cons; Field (cons, 0) = Val_sv (newSVsv (POPs)); @@ -753,20 +1182,9 @@ perl4caml_call_class_method_array (value classname, value name, value arglist) FREETMPS; LEAVE; - /* Died with an error? - * XXX Actually this doesn't work for some reason. - */ - if (SvTRUE (ERRSV)) - { - STRLEN n_a; - const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */ + check_perl_failure (); - errv = copy_string (err); - - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - CAMLreturn (list); + CAMLreturn (list); } CAMLprim value @@ -796,41 +1214,62 @@ perl4caml_call_class_method_void (value classname, value name, value arglist) PUTBACK; - count = call_method (String_val (name), G_EVAL|G_VOID); + count = call_method (String_val (name), G_EVAL|G_VOID|G_DISCARD); SPAGAIN; - assert (count == 0); /* Pretty sure it should never be anything else. */ + assert (count == 0); /* Restore the stack. */ PUTBACK; FREETMPS; LEAVE; - /* Died with an error? - * XXX Actually this doesn't work for some reason. - */ - if (SvTRUE (ERRSV)) - { - STRLEN n_a; - const char *err = SvPV (ERRSV, n_a); /* Equivalent of $@ in Perl. */ + check_perl_failure (); - errv = copy_string (err); - - raise_with_arg (*caml_named_value ("perl4caml_perl_failure"), errv); - } - else - CAMLreturn (Val_unit); + CAMLreturn (Val_unit); } static value Val_voidptr (void *ptr) { - value rv = alloc (1, Abstract_tag); /* XXX Is this correct? */ + CAMLparam0 (); + CAMLlocal1 (rv); + rv = caml_alloc (1, Abstract_tag); Field(rv, 0) = (value) ptr; - return rv; + CAMLreturn (rv); +} + +#if PERL4CAML_REFCOUNTING_EXPERIMENTAL + +static void +xv_finalize (value v) +{ + /*fprintf (stderr, "about to decrement %p\n", Xv_val (v));*/ + SvREFCNT_dec ((SV *) Xv_val (v)); } +static struct custom_operations xv_custom_operations = { + "xv_custom_operations", + xv_finalize, + custom_compare_default, + custom_hash_default, + custom_serialize_default, + custom_deserialize_default +}; + +static value +Val_xv (SV *sv) +{ + CAMLparam0 (); + CAMLlocal1 (rv); + rv = caml_alloc_custom (&xv_custom_operations, sizeof (void *), 0, 1); + Xv_val (rv) = sv; + CAMLreturn (rv); +} + +#endif /* PERL4CAML_REFCOUNTING_EXPERIMENTAL */ + static value unoption (value option, value deflt) {