X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=perl.ml;h=770e59a3a7195be8121762808435e24245ea86e2;hb=95d760554441dac36fb77011c0c875490f873d68;hp=b8c10127699fa0ca46f2e7000a26ef3edeb89d2f;hpb=dafc0bde0b51d76c41b2d646af3699730e31dfbb;p=perl4caml.git diff --git a/perl.ml b/perl.ml index b8c1012..770e59a 100644 --- a/perl.ml +++ b/perl.ml @@ -1,45 +1,185 @@ (* Interface to Perl from OCaml. - * Copyright (C) 2003 Merjis Ltd. - * $Id: perl.ml,v 1.3 2003-10-12 11:56:26 rich Exp $ - *) -type t + Copyright (C) 2003 Merjis Ltd. + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this library; see the file COPYING. If not, write to + the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + $Id: perl.ml,v 1.16 2008-03-01 13:02:21 rich Exp $ + *) type sv +type av +type hv exception Perl_failure of string -external init : unit -> unit = "perl4caml_init" +(* Initialization. This must happen first, otherwise other parts of the + * program will segfault because of a missing interpreter. + *) +external c_init : unit -> unit = "perl4caml_init" let () = Callback.register_exception "perl4caml_perl_failure" (Perl_failure ""); - init () (* Initialise C code. *) - -external create : ?args:string array -> unit -> t - = "perl4caml_create" - -external destroy : t -> unit - = "perl4caml_destroy" - -external set_context : t -> unit - = "perl4caml_set_context" + c_init (); (* Initialise C code. *) + () external int_of_sv : sv -> int = "perl4caml_int_of_sv" external sv_of_int : int -> sv = "perl4caml_sv_of_int" -external float_of_sv : sv -> int = "perl4caml_float_of_sv" -external sv_of_float : int -> sv = "perl4caml_sv_of_float" +external float_of_sv : sv -> float = "perl4caml_float_of_sv" +external sv_of_float : float -> sv = "perl4caml_sv_of_float" external string_of_sv : sv -> string = "perl4caml_string_of_sv" external sv_of_string : string -> sv = "perl4caml_sv_of_string" external sv_is_true : sv -> bool = "perl4caml_sv_is_true" +external sv_undef : unit -> sv = "perl4caml_sv_undef" external sv_is_undef : sv -> bool = "perl4caml_sv_is_undef" -external sv_get_undef : unit -> sv = "perl4caml_sv_get_undef" -external sv_get_yes : unit -> sv = "perl4caml_sv_get_yes" -external sv_get_no : unit -> sv = "perl4caml_sv_get_no" +external sv_yes : unit -> sv = "perl4caml_sv_yes" +external sv_no : unit -> sv = "perl4caml_sv_no" + +let sv_true () = sv_of_int 1 +let sv_false () = sv_of_int 0 + +let bool_of_sv = sv_is_true +let sv_of_bool b = if b then sv_true () else sv_false () + +type sv_t = SVt_NULL + | SVt_IV + | SVt_NV + | SVt_PV + | SVt_RV + | SVt_PVAV + | SVt_PVHV + | SVt_PVCV + | SVt_PVGV + | SVt_PVMG + +external sv_type : sv -> sv_t = "perl4caml_sv_type" + +let string_of_sv_t = function + SVt_NULL -> "SVt_NULL" + | SVt_IV -> "SVt_IV" + | SVt_NV -> "SVt_NV" + | SVt_PV -> "SVt_PV" + | SVt_RV -> "SVt_RV" + | SVt_PVAV -> "SVt_PVAV" + | SVt_PVHV -> "SVt_PVHV" + | SVt_PVCV -> "SVt_PVCV" + | 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" + +external scalarref : sv -> sv = "perl4caml_scalarref" +external arrayref : av -> sv = "perl4caml_arrayref" +external hashref : hv -> sv = "perl4caml_hashref" + +external deref : sv -> sv = "perl4caml_deref" +external deref_array : sv -> av = "perl4caml_deref_array" +external deref_hash : sv -> hv = "perl4caml_deref_hash" + +external av_empty : unit -> av = "perl4caml_av_empty" +external av_of_sv_list : sv list -> av = "perl4caml_av_of_sv_list" +external av_push : av -> sv -> unit = "perl4caml_av_push" +external av_pop : av -> sv = "perl4caml_av_pop" +external av_shift : av -> sv = "perl4caml_av_shift" +external av_unshift : av -> sv -> unit = "perl4caml_av_unshift" +external av_length : av -> int = "perl4caml_av_length" +external av_set : av -> int -> sv -> unit = "perl4caml_av_set" +external av_get : av -> int -> sv = "perl4caml_av_get" +external av_clear : av -> unit = "perl4caml_av_clear" +external av_undef : av -> unit = "perl4caml_av_undef" +external av_extend : av -> int -> unit = "perl4caml_av_extend" + +let av_map f av = + let list = ref [] in + for i = 0 to av_length av - 1 do + list := f (av_get av i) :: !list + done; + List.rev !list + +let list_of_av av = + let list = ref [] in + for i = 0 to av_length av - 1 do + list := av_get av i :: !list + done; + List.rev !list + +let av_of_string_list strs = + av_of_sv_list (List.map sv_of_string strs) + +external hv_empty : unit -> hv = "perl4caml_hv_empty" +external hv_set : hv -> string -> sv -> unit = "perl4caml_hv_set" +external hv_get : hv -> string -> sv = "perl4caml_hv_get" +external hv_exists : hv -> string -> bool = "perl4caml_hv_exists" +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 sv_undef = sv_get_undef () -let sv_true = sv_get_yes () -let sv_false = sv_get_no () +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" external call : ?sv:sv -> ?fn:string -> sv list -> sv = "perl4caml_call"