X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=perl.ml;h=770e59a3a7195be8121762808435e24245ea86e2;hb=31b49439d92ab7d8c555951335709dd41412b697;hp=b31466be20e2018f5e83479e4d013fadfed48946;hpb=16900866ff592a4c28e84579b28dd20efedd8613;p=perl4caml.git diff --git a/perl.ml b/perl.ml index b31466b..770e59a 100644 --- a/perl.ml +++ b/perl.ml @@ -1,44 +1,205 @@ (* Interface to Perl from OCaml. - * Copyright (C) 2003 Merjis Ltd. - * $Id: perl.ml,v 1.1 2003-10-11 18:25:52 rich Exp $ - *) -type t + Copyright (C) 2003 Merjis Ltd. -type sv + 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. -exception PerlFailure of string + 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. -(* Perform some once-only initialization when the library is loaded. *) -external init : unit -> unit = "perl4caml_init" -let () = init () + $Id: perl.ml,v 1.16 2008-03-01 13:02:21 rich Exp $ + *) -external create : ?args:string array -> unit -> t - = "perl4caml_create" +type sv +type av +type hv -external destroy : t -> unit - = "perl4caml_destroy" +exception Perl_failure of string -external set_context : t -> unit - = "perl4caml_set_context" +(* 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 ""); + 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_yes : unit -> sv = "perl4caml_sv_yes" +external sv_no : unit -> sv = "perl4caml_sv_no" -external call_scalar : string -> sv list -> sv - = "perl4caml_call_scalar" +let sv_true () = sv_of_int 1 +let sv_false () = sv_of_int 0 -(* -external call_array : string -> sv list -> sv list - = "perl4caml_call_array" +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 call : string -> sv list -> unit +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 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" +external call_array : ?sv:sv -> ?fn:string -> sv list -> sv list + = "perl4caml_call_array" +external call_void : ?sv:sv -> ?fn:string -> sv list -> unit + = "perl4caml_call_void" external eval : string -> sv = "perl4caml_eval" -*) + +external call_method : sv -> string -> sv list -> sv + = "perl4caml_call_method" +external call_method_array : sv -> string -> sv list -> sv list + = "perl4caml_call_method_array" +external call_method_void : sv -> string -> sv list -> unit + = "perl4caml_call_method_void" +external call_class_method : string -> string -> sv list -> sv + = "perl4caml_call_class_method" +external call_class_method_array : string -> string -> sv list -> sv list + = "perl4caml_call_class_method_array" +external call_class_method_void : string -> string -> sv list -> unit + = "perl4caml_call_class_method_void"