File: test.ml

package info (click to toggle)
perl4caml 0.9.3-7
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k
  • size: 380 kB
  • ctags: 571
  • sloc: ml: 1,525; ansic: 934; makefile: 226; sh: 52; perl: 45
file content (57 lines) | stat: -rw-r--r-- 1,962 bytes parent folder | download | duplicates (7)
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 ()