X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=perl_c.c;h=f11a2b5535553a588d81bdfcbd2f8d5c4c3cacdc;hb=92ee36459463e0a040d32f5eac0ec38bb28be8f4;hp=905659163edf35be885fad66007212c45f4db155;hpb=c6a26bacdd51fbe32048e4ac15545dd58039cf32;p=perl4caml.git diff --git a/perl_c.c b/perl_c.c index 9056591..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.7 2003-10-16 11:03:51 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,44 +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))) - -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) @@ -69,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); } @@ -189,18 +155,10 @@ perl4caml_sv_is_true (value svv) } CAMLprim value -perl4caml_sv_is_undef (value svv) -{ - CAMLparam1 (svv); - SV *sv = Sv_val (svv); - CAMLreturn (sv == &PL_sv_undef ? Val_true : Val_false); -} - -CAMLprim value perl4caml_sv_undef (value unit) { CAMLparam1 (unit); - CAMLreturn (Val_sv (&PL_sv_undef)); + CAMLreturn (Val_sv (newSV (0))); } CAMLprim value @@ -239,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: @@ -268,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: @@ -281,6 +269,25 @@ perl4caml_deref_array (value svv) } CAMLprim value +perl4caml_deref_hash (value svv) +{ + CAMLparam1 (svv); + CAMLlocal1 (rhvv); + SV *sv = Sv_val (svv); + + if (!SvROK (sv)) + invalid_argument ("deref_hash: SV is not a reference"); + switch (SvTYPE (SvRV (sv))) { + case SVt_PVHV: + break; + default: + invalid_argument ("deref_hash: SV is not a reference to a hash"); + } + rhvv = Val_hv ((HV *) SvRV (sv)); + CAMLreturn (rhvv); +} + +CAMLprim value perl4caml_av_empty (value unit) { CAMLparam1 (unit); @@ -419,6 +426,72 @@ perl4caml_av_extend (value avv, value i) } 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), 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), string_length (key), 0); + if (svp == 0) raise_not_found (); + 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), 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), 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_get_sv (value optcreate, value name) { CAMLparam2 (optcreate, name); @@ -446,6 +519,20 @@ perl4caml_get_av (value optcreate, value name) 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) raise_not_found (); + + CAMLreturn (Val_hv (hv)); +} + static inline void check_perl_failure () { @@ -574,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. */ @@ -624,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 { @@ -635,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; @@ -748,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. */ @@ -792,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; @@ -934,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; @@ -953,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) {