X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=perl_c.c;h=42415348f4ff457eb1ffe09e070f6bdf181c467a;hb=7f82a6f31e40e596a43939ab18d685a8f0b78d7b;hp=29c9776c7c9184b92dbebe0ca3ff0054c2abe32c;hpb=432e85196383810d7f6d4e695c758a8d17b96f2b;p=perl4caml.git diff --git a/perl_c.c b/perl_c.c index 29c9776..4241534 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.10 2003-10-26 12:10:23 rich Exp $ + * $Id: perl_c.c,v 1.17 2004-11-25 22:16:17 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,18 +155,20 @@ perl4caml_sv_is_true (value svv) } CAMLprim value -perl4caml_sv_is_undef (value svv) +perl4caml_sv_undef (value unit) { - CAMLparam1 (svv); - SV *sv = Sv_val (svv); - CAMLreturn (SvLEN (sv) == 0 ? Val_true : Val_false); + CAMLparam1 (unit); + /*CAMLreturn (Val_sv (newSV (0)));*/ + CAMLreturn (Val_sv (&PL_sv_undef)); } CAMLprim value -perl4caml_sv_undef (value unit) +perl4caml_sv_is_undef (value svv) { - CAMLparam1 (unit); - CAMLreturn (Val_sv (newSV (0))); + CAMLparam1 (svv); + SV *sv = Sv_val (svv); + CAMLreturn (!SvPOK (sv) && !SvIOK (sv) && SvTYPE (sv) == SVt_NULL + ? Val_true : Val_false); } CAMLprim value @@ -277,7 +243,7 @@ perl4caml_deref (value 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: @@ -300,7 +266,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: @@ -319,13 +285,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); @@ -705,10 +671,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. */ @@ -879,10 +848,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. */ @@ -1084,11 +1056,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) {