X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=perl_c.c;h=f11a2b5535553a588d81bdfcbd2f8d5c4c3cacdc;hb=f71f13bd5e85b5cca4e9c2e63bf9d9c3283d66cf;hp=9ad8d68248421951e6f81d95caf1fa3ee5a4bd0b;hpb=3099885336bf959064b00e4205e11e4e5d68e7d5;p=perl4caml.git diff --git a/perl_c.c b/perl_c.c index 9ad8d68..f11a2b5 100644 --- a/perl_c.c +++ b/perl_c.c @@ -1,6 +1,6 @@ /* Interface to Perl from OCaml. * Copyright (C) 2003 Merjis Ltd. - * $Id: perl_c.c,v 1.8 2003-10-18 12:36:09 rich Exp $ + * $Id: perl_c.c,v 1.16 2004-11-03 14:15:18 rich Exp $ */ #include @@ -11,6 +11,7 @@ #include #include +#include #include #include #include @@ -20,46 +21,51 @@ */ #define off64_t __off64_t +/* XXX This is required by Perl >= 5.8.2. */ +#define __USE_GNU +#include + #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)) +#if PERL4CAML_REFCOUNTING_EXPERIMENTAL + +/* Unwrap a custom block. */ +#define Xv_val(rv) (*((void **)Data_custom_val(rv))) + +/* 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); + +#else + +#define Xv_val(rv) Voidptr_val (SV, (rv)) +#define Val_xv(sv) Val_voidptr ((sv)) + +#endif + /* 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))) -#define Val_av(av) (Val_voidptr ((av))) -#define Av_val(avv) (Voidptr_val (AV, (avv))) -#define Val_hv(hv) (Val_voidptr ((hv))) -#define Hv_val(hvv) (Voidptr_val (HV, (hvv))) - -CAMLprim value -perl4caml_init (value unit) -{ - CAMLparam1 (unit); - PERL_SYS_INIT3 (NULL, NULL, NULL); - CAMLreturn (Val_unit); -} - -CAMLprim value -perl4caml_current_interpreter (value unit) -{ - CAMLparam1 (unit); - if (my_perl == 0) raise_not_found (); - CAMLreturn (Val_perl (my_perl)); -} +#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)) static void xs_init (pTHX) @@ -71,61 +77,19 @@ xs_init (pTHX) } CAMLprim value -perl4caml_create (value optargs, value unit) +perl4caml_init (value unit) { - CAMLparam2 (optargs, unit); - CAMLlocal1 (args); - int argc, i; - char **argv; - static char *no_args[] = { "", "-w", "-e", "0" }; - - /* Arguments given? */ - if (optargs == Val_int (0)) /* "None" */ - { - argc = 4; - 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)); - } + CAMLparam1 (unit); + int argc = 4; + static char *argv[] = { "", "-w", "-e", "0" }; + PERL_SYS_INIT3 (NULL, NULL, NULL); my_perl = perl_alloc (); perl_construct (my_perl); PL_exit_flags |= PERL_EXIT_DESTRUCT_END; perl_parse (my_perl, xs_init, argc, argv, NULL); /*perl_run (my_perl);*/ - CAMLreturn (Val_perl (my_perl)); -} - -CAMLprim value -perl4caml_destroy (value plv) -{ - CAMLparam1 (plv); - PerlInterpreter *pl = Perl_val (plv); - - perl_destruct (pl); - perl_free (pl); - - /* Current interpreter? */ - if (my_perl == pl) my_perl = 0; - - CAMLreturn (Val_unit); -} - -CAMLprim value -perl4caml_set_context (value plv) -{ - CAMLparam1 (plv); - PerlInterpreter *pl = Perl_val (plv); - - PERL_SET_CONTEXT (pl); - my_perl = pl; - CAMLreturn (Val_unit); } @@ -191,14 +155,6 @@ perl4caml_sv_is_true (value svv) } CAMLprim value -perl4caml_sv_is_undef (value svv) -{ - CAMLparam1 (svv); - SV *sv = Sv_val (svv); - CAMLreturn (SvLEN (sv) == 0 ? Val_true : Val_false); -} - -CAMLprim value perl4caml_sv_undef (value unit) { CAMLparam1 (unit); @@ -241,13 +197,43 @@ perl4caml_sv_type (value svv) } 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_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_deref (value svv) { CAMLparam1 (svv); CAMLlocal1 (rsvv); SV *sv = Sv_val (svv); - if (SvTYPE (sv) != SVt_RV) + if (!SvROK (sv)) invalid_argument ("deref: SV is not a reference"); switch (SvTYPE (SvRV (sv))) { case SVt_IV: @@ -270,7 +256,7 @@ perl4caml_deref_array (value svv) CAMLlocal1 (ravv); SV *sv = Sv_val (svv); - if (SvTYPE (sv) != SVt_RV) + if (!SvROK (sv)) invalid_argument ("deref_array: SV is not a reference"); switch (SvTYPE (SvRV (sv))) { case SVt_PVAV: @@ -289,13 +275,13 @@ perl4caml_deref_hash (value svv) CAMLlocal1 (rhvv); SV *sv = Sv_val (svv); - if (SvTYPE (sv) != SVt_RV) - invalid_argument ("deref_array: SV is not a reference"); + if (!SvROK (sv)) + invalid_argument ("deref_hash: SV is not a reference"); switch (SvTYPE (SvRV (sv))) { case SVt_PVHV: break; default: - invalid_argument ("deref_array: SV is not a reference to a hash"); + invalid_argument ("deref_hash: SV is not a reference to a hash"); } rhvv = Val_hv ((HV *) SvRV (sv)); CAMLreturn (rhvv); @@ -675,10 +661,13 @@ perl4caml_call_array (value optsv, value optfnname, value arglist) */ list = Val_int (0); for (i = 0; i < count; ++i) { + SV *sv; + cons = 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. */ @@ -725,7 +714,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 { @@ -736,7 +725,7 @@ 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; @@ -849,10 +838,13 @@ perl4caml_call_method_array (value ref, value name, value arglist) */ list = Val_int (0); for (i = 0; i < count; ++i) { + SV *sv; + cons = 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. */ @@ -893,11 +885,11 @@ 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; @@ -1035,11 +1027,11 @@ 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; @@ -1054,11 +1046,42 @@ perl4caml_call_class_method_void (value classname, value name, value arglist) static value Val_voidptr (void *ptr) { - value rv = alloc (1, Abstract_tag); /* XXX Is this correct? */ + CAMLparam0 (); + CAMLlocal1 (rv); + rv = alloc (1, Abstract_tag); Field(rv, 0) = (value) ptr; - return rv; + CAMLreturn (rv); } +#if PERL4CAML_REFCOUNTING_EXPERIMENTAL + +static void +xv_finalize (value 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 = 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) {