/usr/share/doc/libperl4caml-ocaml-doc/examples/test.ml is in libperl4caml-ocaml-doc 0.9.5-4build7.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | (* Simple test of the API.
* Copyright (C) 2003 Merjis Ltd.
* $Id: test.ml,v 1.7 2004/11/25 22:16:17 rich Exp $
*)
open Printf
let () =
(* Perform a full collection - good way to find bugs in initialization code*)
Gc.full_major ();
(* Load "test.pl". *)
Perl.eval "require 'examples/test.pl'";
(* Call some subroutines in [test.pl]. *)
let sv = Perl.call ~fn:"return_one" [] in
printf "return_one returned %d\n" (Perl.int_of_sv sv); flush stdout;
let sv = Perl.call ~fn:"adder" [Perl.sv_of_int 3; Perl.sv_of_int 4] in
printf "adder (3, 4) = %d\n" (Perl.int_of_sv sv); flush stdout;
let svlist = Perl.call_array ~fn:"return_array" [] in
print_string "array returned:";
List.iter (
fun sv ->
printf " %d" (Perl.int_of_sv sv);
) svlist;
printf "\n"; flush stdout;
let sv = Perl.sv_of_string "return_one" in
let sv = Perl.call ~sv [] in
printf "return_one returned %d\n" (Perl.int_of_sv sv); flush stdout;
(* Call a Perl closure. *)
let sv = Perl.call ~fn:"return_closure" [] in
let sv = Perl.call ~sv [Perl.sv_of_int 3; Perl.sv_of_int 4] in
printf "closure returned %d\n" (Perl.int_of_sv sv); flush stdout;
(* Evaluate a simple expression. *)
Perl.eval "$a = 3";
printf "$a contains %d\n" (Perl.int_of_sv (Perl.get_sv "a")); flush stdout;
(* Test calling methods in the "TestClass" class. *)
let obj = Perl.call_class_method "TestClass" "new" [] in
let sv = Perl.call_method obj "get_foo" [] in
printf "TestClass.foo is %d\n" (Perl.int_of_sv sv); flush stdout;
Perl.call_method obj "set_foo" [Perl.sv_of_int 2];
let sv = Perl.call_method obj "get_foo" [] in
printf "TestClass.foo is %d\n" (Perl.int_of_sv sv); flush stdout;
(* Create an undef value and test it. *)
let undef = Perl.sv_undef () in
printf "sv_is_undef (undef) = %s\n"
(string_of_bool (Perl.sv_is_undef undef));
(* Perform a full collection - good way to find GC/allocation bugs. *)
Gc.full_major ()
|