From: rich <rich>
Date: Thu, 14 Apr 2005 13:05:12 +0000 (+0000)
Subject: Added reftype operator.
X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;h=2e1b60f9fffb9eddae136a233bf875a23022fa24;p=perl4caml.git

Added reftype operator.
---

diff --git a/perl.ml b/perl.ml
index 95d1629..c88ff85 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.14 2005-01-29 12:22:49 rich Exp $
+ * $Id: perl.ml,v 1.15 2005-04-14 13:05:12 rich Exp $
  *)
 
 type sv
@@ -61,6 +61,8 @@ let string_of_sv_t = function
   | SVt_PVGV  -> "SVt_PVGV"
   | SVt_PVMG  -> "SVt_PVMG"
 
+external reftype : sv -> sv_t = "perl4caml_reftype"
+
 external address_of_sv : sv -> Nativeint.t = "perl4caml_address_of_sv"
 external address_of_av : av -> Nativeint.t = "perl4caml_address_of_av"
 external address_of_hv : hv -> Nativeint.t = "perl4caml_address_of_hv"
diff --git a/perl.mli b/perl.mli
index f303d24..e16ada2 100644
--- a/perl.mli
+++ b/perl.mli
@@ -2,7 +2,7 @@
   *
   * Copyright (C) 2003 Merjis Ltd.
   *
-  * $Id: perl.mli,v 1.14 2005-01-29 12:22:49 rich Exp $
+  * $Id: perl.mli,v 1.15 2005-04-14 13:05:12 rich Exp $
   *)
 
 type sv
@@ -72,6 +72,12 @@ val sv_type : sv -> sv_t
 val string_of_sv_t : sv_t -> string
 (** Return a printable string for an [sv_t] ([SV] type). *)
 
+val reftype : sv -> sv_t
+(** The parameter [sv] must be a reference.  This convenience function
+ * works out what it is a reference to, either a scalar, array, hash,
+ * code or glob.  If the parameter is not a reference, or is a reference
+ * to an unknown type, then this will throw [Invalid_argument].  *)
+
 val address_of_sv : sv -> Nativeint.t
 (** Returns the address of the SV.  Useful for debugging since
   * Perl also prints out addresses on internal errors.
diff --git a/perl_c.c b/perl_c.c
index 11d1cc6..1a6b1ef 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.22 2005-02-13 16:33:27 rich Exp $
+ * $Id: perl_c.c,v 1.23 2005-04-14 13:05:12 rich Exp $
  */
 
 #include <stdio.h>
@@ -180,25 +180,31 @@ perl4caml_sv_no (value unit)
   CAMLreturn (Val_sv (&PL_sv_no));
 }
 
+static int
+sv_type (SV *sv)
+{
+  switch (SvTYPE (sv))
+    {
+    case SVt_IV: return 1;
+    case SVt_NV: return 2;
+    case SVt_PV: return 3;
+    case SVt_RV: return 4;
+    case SVt_PVAV: return 5;
+    case SVt_PVHV: return 6;
+    case SVt_PVCV: return 7;
+    case SVt_PVGV: return 8;
+    case SVt_PVMG: return 9;
+    default: return 0;
+    }
+}
+
 CAMLprim value
 perl4caml_sv_type (value svv)
 {
   CAMLparam1 (svv);
   SV *sv = Sv_val (svv);
 
-  switch (SvTYPE (sv))
-    {
-    case SVt_IV: CAMLreturn (Val_int (1));
-    case SVt_NV: CAMLreturn (Val_int (2));
-    case SVt_PV: CAMLreturn (Val_int (3));
-    case SVt_RV: CAMLreturn (Val_int (4));
-    case SVt_PVAV: CAMLreturn (Val_int (5));
-    case SVt_PVHV: CAMLreturn (Val_int (6));
-    case SVt_PVCV: CAMLreturn (Val_int (7));
-    case SVt_PVGV: CAMLreturn (Val_int (8));
-    case SVt_PVMG: CAMLreturn (Val_int (9));
-    default: CAMLreturn (Val_int (0));
-    }
+  CAMLreturn (Val_int (sv_type (sv)));
 }
 
 CAMLprim value
@@ -256,6 +262,18 @@ perl4caml_hashref (value hvv)
 }
 
 CAMLprim value
+perl4caml_reftype (value svv)
+{
+  CAMLparam1 (svv);
+  SV *sv = Sv_val (svv);
+
+  if (!SvROK (sv))
+    caml_invalid_argument ("reftype: SV is not a reference");
+
+  CAMLreturn (Val_int (sv_type (SvRV (sv))));
+}
+
+CAMLprim value
 perl4caml_deref (value svv)
 {
   CAMLparam1 (svv);
diff --git a/test/140-ref.ml b/test/140-ref.ml
index bf6dd91..65dec49 100644
--- a/test/140-ref.ml
+++ b/test/140-ref.ml
@@ -1,5 +1,5 @@
 (* Reference, dereference.
- * $Id: 140-ref.ml,v 1.1 2005-01-28 23:09:33 rich Exp $
+ * $Id: 140-ref.ml,v 1.2 2005-04-14 13:05:12 rich Exp $
  *)
 
 open Perl
@@ -8,12 +8,14 @@ let () =
   let sv = sv_of_int 42 in
   let sv = scalarref sv in
   assert (sv_type sv = SVt_RV);
+  assert (reftype sv = SVt_IV);
   let sv = deref sv in
   assert (42 = int_of_sv sv);
 
   let av = av_of_string_list [ "foo"; "bar" ] in
   let sv = arrayref av in
   assert (sv_type sv = SVt_RV);
+  assert (reftype sv = SVt_PVAV);
   let av = deref_array sv in
   assert (2 = av_length av);
 
@@ -22,6 +24,7 @@ let () =
   hv_set hv "bar" (sv_of_int 2);
   let sv = hashref hv in
   assert (sv_type sv = SVt_RV);
+  assert (reftype sv = SVt_PVHV);
   let hv = deref_hash sv in
   assert (1 = int_of_sv (hv_get hv "foo"));
   assert (2 = int_of_sv (hv_get hv "bar"));