X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=perl.ml;h=770e59a3a7195be8121762808435e24245ea86e2;hb=31b49439d92ab7d8c555951335709dd41412b697;hp=0f2d9fc16abbd93ac442b8cbc1d770feee0b72f7;hpb=9e88eacb7d2a8883900fba0c8abedc26c7510d98;p=perl4caml.git diff --git a/perl.ml b/perl.ml index 0f2d9fc..770e59a 100644 --- a/perl.ml +++ b/perl.ml @@ -1,51 +1,49 @@ (* Interface to Perl from OCaml. - * Copyright (C) 2003 Merjis Ltd. - * $Id: perl.ml,v 1.6 2003-10-15 16:51:12 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 create : ?args:string array -> unit -> t - = "perl4caml_create" - (* 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 () = - (* Leave this debugging message in for now until init support in OCaml - * is debugged. - *) - prerr_endline "perl_init: Initialising Perl support ..."; Callback.register_exception "perl4caml_perl_failure" (Perl_failure ""); c_init (); (* Initialise C code. *) - (* Create the default interpreter. *) - create ~args:[| ""; "-w"; "-e"; "0" |] (); () -external current_interpreter : unit -> t - = "perl4caml_current_interpreter" - -external destroy : t -> unit - = "perl4caml_destroy" - -external set_context : t -> unit - = "perl4caml_set_context" - 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_is_undef : sv -> bool = "perl4caml_sv_is_undef" 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" @@ -80,8 +78,19 @@ 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" + +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" @@ -103,8 +112,74 @@ let av_map f av = 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"