Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 103 lines (87 sloc) 2.84 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 module Obj = BaseObj
19
20 include Marshal
21
22 let buffer = Buffer.create 1000
23
24 let special_string = Obj.repr "i_am_a_trashed_closure"
25 let rec replacement_fun x =
26 Printf.printf "BEWARE: unmarshalled fun is being called with %s.\n%!" (Obj.dump ~depth:5 x);
27 Printf.printf "I will pretend that nothing happened but the program may segfault at any time.\n%!";
28 Obj.magic replacement_fun
29 let replacement_fun = Obj.repr replacement_fun
30 let trashed_funs = Queue.create ()
31
32 let rec trash_obj obj =
33 if Obj.is_block obj && Obj.tag obj < Obj.no_scan_tag then (
34 for i = 0 to Obj.size obj - 1 do
35 let sub = Obj.field obj i in
36 if Obj.tag sub = Obj.closure_tag then (
37 Queue.add sub trashed_funs;
38 Obj.set_field obj i special_string
39 ) else
40 trash_obj sub
41 done
42 )
43
44 let trash_obj obj =
45 let obj = Obj.repr obj in
46 if Obj.tag obj = Obj.closure_tag || Obj.tag obj = Obj.infix_tag then
47 failwith "trash_obj: cannot trash a closure"
48 else (
49 assert (Queue.is_empty trashed_funs);
50 trash_obj obj
51 )
52
53 let rec restore_obj obj =
54 if Obj.is_block obj && Obj.tag obj < Obj.no_scan_tag then (
55 for i = 0 to Obj.size obj - 1 do
56 let sub = Obj.field obj i in
57 if sub = special_string then
58 Obj.set_field obj i (Queue.take trashed_funs)
59 else
60 restore_obj sub
61 done
62 )
63
64 let restore_obj obj =
65 let obj = Obj.repr obj in
66 if obj = special_string then
67 failwith "cannot restore"
68 else
69 restore_obj obj
70
71 let rec fake_restore_obj obj =
72 if Obj.is_block obj && Obj.tag obj < Obj.no_scan_tag then (
73 for i = 0 to Obj.size obj - 1 do
74 let sub = Obj.field obj i in
75 if sub = special_string then
76 Obj.set_field obj i replacement_fun
77 else
78 fake_restore_obj sub
79 done
80 )
81
82 let fake_restore_obj obj =
83 let obj = Obj.repr obj in
84 if obj = special_string then
85 failwith "cannot fake_restore"
86 else
87 fake_restore_obj obj
88
89 let marshal_no_fun oc obj =
90 trash_obj obj;
91 try
92 Marshal.to_channel oc obj [];
93 restore_obj obj;
94 with
95 | e ->
96 restore_obj obj;
97 raise e
98
99 let unmarshal_no_fun ic =
100 let obj = Marshal.from_channel ic in
101 fake_restore_obj obj;
102 obj
Something went wrong with that request. Please try again.