From b7d1588ac61499a3eb6e9abb2b7f3357eafe7f2a Mon Sep 17 00:00:00 2001 From: rich Date: Sat, 29 Jan 2005 12:22:49 +0000 Subject: [PATCH] Bindings for the iteration interface of Perl hashes. Version 0.9.1. --- MANIFEST | 1 + Makefile.config | 4 +-- perl.ml | 49 +++++++++++++++++++++++++++++++++++- perl.mli | 42 ++++++++++++++++++++++++------- perl_c.c | 71 ++++++++++++++++++++++++++++++++++++++++++++++++++++- test/130-hv-iter.ml | 35 ++++++++++++++++++++++++++ 6 files changed, 189 insertions(+), 13 deletions(-) create mode 100644 test/130-hv-iter.ml diff --git a/MANIFEST b/MANIFEST index bfb8d57..0341b68 100644 --- a/MANIFEST +++ b/MANIFEST @@ -27,6 +27,7 @@ test/030-call.ml test/100-sv.ml test/110-av.ml test/120-hv.ml +test/130-hv-iter.ml test/140-ref.ml wrappers/.cvsignore wrappers/pl_Date_Calc.ml diff --git a/Makefile.config b/Makefile.config index 09b198c..35472cb 100644 --- a/Makefile.config +++ b/Makefile.config @@ -1,5 +1,5 @@ # perl4caml configuration -*- Makefile -*- -# $Id: Makefile.config,v 1.22 2005-01-28 23:11:03 rich Exp $ +# $Id: Makefile.config,v 1.23 2005-01-29 12:22:49 rich Exp $ # PERLINCDIR # Directory containing the Perl include files, eg. . @@ -42,4 +42,4 @@ DYNALOADER_HACK := /usr/lib/perl/5.8/auto/DynaLoader/DynaLoader.a # PACKAGE and VERSION PACKAGE := perl4caml -VERSION := 0.9.0 +VERSION := 0.9.1 diff --git a/perl.ml b/perl.ml index 23bc833..95d1629 100644 --- a/perl.ml +++ b/perl.ml @@ -1,6 +1,6 @@ (* Interface to Perl from OCaml. * Copyright (C) 2003 Merjis Ltd. - * $Id: perl.ml,v 1.13 2005-01-28 23:09:31 rich Exp $ + * $Id: perl.ml,v 1.14 2005-01-29 12:22:49 rich Exp $ *) type sv @@ -111,6 +111,53 @@ external hv_delete : hv -> string -> unit = "perl4caml_hv_delete" external hv_clear : hv -> unit = "perl4caml_hv_clear" external hv_undef : hv -> unit = "perl4caml_hv_undef" +type he +external hv_iterinit : hv -> Int32.t = "perl4caml_hv_iterinit" +external hv_iternext : hv -> he = "perl4caml_hv_iternext" +external hv_iterkey : he -> string = "perl4caml_hv_iterkey" +external hv_iterval : hv -> he -> sv = "perl4caml_hv_iterval" +external hv_iternextsv : hv -> string * sv = "perl4caml_hv_iternextsv" + +let hv_of_assoc xs = + let hv = hv_empty () in + List.iter (fun (k, v) -> hv_set hv k v) xs; + hv +let assoc_of_hv hv = + ignore (hv_iterinit hv); + (* Someone please rewrite this to make it tail-rec! - Rich. XXX *) + let rec loop acc = + try + let k, v = hv_iternextsv hv in + loop ((k, v) :: acc) + with + Not_found -> acc + in + loop [] +let hv_keys hv = + ignore (hv_iterinit hv); + (* Someone please rewrite this to make it tail-rec! - Rich. XXX *) + let rec loop acc = + try + let he = hv_iternext hv in + let k = hv_iterkey he in + loop (k :: acc) + with + Not_found -> acc + in + loop [] +let hv_values hv = + ignore (hv_iterinit hv); + (* Someone please rewrite this to make it tail-rec! - Rich. XXX *) + let rec loop acc = + try + let he = hv_iternext hv in + let v = hv_iterval hv he in + loop (v :: acc) + with + Not_found -> acc + in + loop [] + external get_sv : ?create:bool -> string -> sv = "perl4caml_get_sv" external get_av : ?create:bool -> string -> av = "perl4caml_get_av" external get_hv : ?create:bool -> string -> hv = "perl4caml_get_hv" diff --git a/perl.mli b/perl.mli index 05c353a..f303d24 100644 --- a/perl.mli +++ b/perl.mli @@ -2,7 +2,7 @@ * * Copyright (C) 2003 Merjis Ltd. * - * $Id: perl.mli,v 1.13 2005-01-28 23:09:32 rich Exp $ + * $Id: perl.mli,v 1.14 2005-01-29 12:22:49 rich Exp $ *) type sv @@ -167,16 +167,40 @@ val hv_clear : hv -> unit (** Remove all elements from the [HV]. Same as Perl [%av = ()]. *) val hv_undef : hv -> unit (** Delete the [HV] (and all elements in it). Same as Perl [undef %hv]. *) +val hv_of_assoc : (string * sv) list -> hv +(** Create an [HV] directly from an assoc list. Perl hashes cannot + * support multiple values attached to the same key, so if you try + * to provide an assoc list with multiple identical keys, the results + * will be undefined. + *) +val assoc_of_hv : hv -> (string * sv) list +(** Take an [HV] and return an assoc list. *) +val hv_keys : hv -> string list +(** Return all the keys of an [HV]. *) +val hv_values : hv -> sv list +(** Return all the values of an [HV]. *) + +(* The following are the low-level iteration interface to hashes, + * which you probably shouldn't use directly. Use {!hv_keys}, + * {!assoc_of_hv}, etc. instead. See [perlguts(3)] if you really + * want to use this interface. + *) +type he +val hv_iterinit : hv -> Int32.t +val hv_iternext : hv -> he +val hv_iterkey : he -> string +val hv_iterval : hv -> he -> sv +val hv_iternextsv : hv -> string * sv val get_sv : ?create:bool -> string -> sv -(** Return a scalar value by name. For example, if you have a symbol - * called [$a] in Perl, then [get_sv "a"] will return its value. - * - * If the symbol does not exist, this throws [Not_found]. - * - * If the optional [?create] argument is set to true and the symbol does - * not exist, then Perl will create the symbol (with value [undef]) and - * this function will return the [SV] for [undef]. + (** Return a scalar value by name. For example, if you have a symbol + * called [$a] in Perl, then [get_sv "a"] will return its value. + * + * If the symbol does not exist, this throws [Not_found]. + * + * If the optional [?create] argument is set to true and the symbol does + * not exist, then Perl will create the symbol (with value [undef]) and + * this function will return the [SV] for [undef]. *) val get_av : ?create:bool -> string -> av (** Same as {!Perl.get_sv} except will return and/or create [\@a]. *) diff --git a/perl_c.c b/perl_c.c index 1737bc0..06b69b6 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.20 2005-01-28 23:09:32 rich Exp $ + * $Id: perl_c.c,v 1.21 2005-01-29 12:22:49 rich Exp $ */ #include @@ -59,6 +59,8 @@ static value Val_xv (SV *sv); #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) @@ -550,6 +552,73 @@ perl4caml_hv_undef (value hvv) } 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 perl4caml_get_sv (value optcreate, value name) { CAMLparam2 (optcreate, name); diff --git a/test/130-hv-iter.ml b/test/130-hv-iter.ml new file mode 100644 index 0000000..7947221 --- /dev/null +++ b/test/130-hv-iter.ml @@ -0,0 +1,35 @@ +(* Thoroughly test HV iteration functions. + * $Id: 130-hv-iter.ml,v 1.1 2005-01-29 12:22:50 rich Exp $ + *) + +open Perl + +let () = + let xs = [ "foo", sv_of_int 1; + "bar", sv_of_int 2; + "baz", sv_of_int 3; + "a", sv_of_int 4 ] in + + let hv = hv_of_assoc xs in + assert (1 = int_of_sv (hv_get hv "foo")); + assert (2 = int_of_sv (hv_get hv "bar")); + assert (3 = int_of_sv (hv_get hv "baz")); + assert (4 = int_of_sv (hv_get hv "a")); + assert (not (hv_exists hv "b")); + assert (not (hv_exists hv "c")); + + let keys = List.sort compare (hv_keys hv) in + assert (4 = List.length keys); + assert (["a"; "bar"; "baz"; "foo"] = keys); + + let values = List.sort compare (List.map int_of_sv (hv_values hv)) in + assert (4 = List.length values); + assert ([1; 2; 3; 4] = values); + + let xs = assoc_of_hv hv in + let xs = List.map (fun (k, sv) -> k, int_of_sv sv) xs in + let xs = List.sort compare xs in + assert (4 = List.length xs); + assert ([ "a", 4; "bar", 2; "baz", 3; "foo", 1 ] = xs) +;; +Gc.full_major () -- 1.8.3.1