From: rich <rich>
Date: Sat, 29 Jan 2005 12:22:49 +0000 (+0000)
Subject: Bindings for the iteration interface of Perl hashes.
X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;h=b7d1588ac61499a3eb6e9abb2b7f3357eafe7f2a;p=perl4caml.git

Bindings for the iteration interface of Perl hashes.
Version 0.9.1.
---

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. <EXTERN.h>.
@@ -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 <stdio.h>
@@ -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 ()