package gapi-ocaml

You can search for identifiers within the package.
in-package search v0.2.0
gapi-ocaml
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source
Source file `netexn.ml`

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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
(* $Id$ *)

(* Since Ocaml 3.11.2 there is also Printexc.register_printer allowing
   the user to register a printer directly with the Ocaml stdlib.
   Of course, we register our printer there, too, but we have to be
   careful to avoid recursion

   FORMAT OF EXCEPTIONS UNTIL 4.01:

   - tag=0
   - field(exn,0) is a block shared by all exceptions with the same
     identity.
   - field(field(exn,0),0) is the name as OCaml string
   - field(exn,1): start of arguments

   FORMAT OF EXCEPTIONS SINCE 4.02:

   Exceptions without arguments: The exception is identical to the
   exception descriptor:

   - tag=object tag
   - field(exn,0) is the name as OCaml string (NB. objects have in this
     field a pointer to the method table)
   - field(exn,1) is the OID (OCaml integer)

   Exceptions with arguments:

   - tag=0
   - field(exn,0) is the exception descriptor object
   - hence, field(field(exn,0),0) is the name
   - hence, field(field(exn,0),1) is the OID
   - field(exn,1): start of arguments
 *)

type printer = exn -> string

let registry = 
  (Hashtbl.create 50 : (string, (Obj.t * printer) list) Hashtbl.t)
    (* The hashtable maps the name of the exception to an assoc list
       mapping the exception anchor to the printer.
     *)

let scopy s =
  (* we really want to make here a copy! *)
  String.sub s 0 (String.length s)

let register_printer e f =
  let e1 = Obj.repr e in
  let descriptor = if Obj.tag e1 = 0 then Obj.field e1 0 else e1 in
  let name = scopy (Obj.obj (Obj.field descriptor 0) : string) in
  let descr_is_object = (Obj.tag descriptor = Obj.object_tag) in

  let alist =
    try Hashtbl.find registry name with Not_found -> [] in

  let alist' =
    (descriptor, f) :: 
      (if descr_is_object then
         List.remove_assoc descriptor alist
       else
         List.remove_assq descriptor alist
      ) in
  
  Hashtbl.replace registry name alist'

(* to_string_opt: This is the function registered at Printexc.
   It must not call Printexc.
 *)

let to_string_opt (e : exn) : string option =
  let e1 = Obj.repr e in
  let descriptor = if Obj.tag e1 = 0 then Obj.field e1 0 else e1 in
  let name = scopy (Obj.obj (Obj.field descriptor 0) : string) in
  let descr_is_object = (Obj.tag descriptor = Obj.object_tag) in

  let f_opt =
    try
      let alist = Hashtbl.find registry name in
      try
        if descr_is_object then
          Some(List.assoc descriptor alist)
        else
	  Some(List.assq descriptor alist)
      with
	| Not_found ->
(*
	    prerr_endline "Strange: exn by name found, but not by anchor";
	    prerr_endline ("name: " ^ name);
	    prerr_endline ("anchor: " ^ 
			     string_of_int(Obj.magic anchor : int));
	    let ea = fst(List.hd alist) in
	    prerr_endline ("expected anchor: " ^ 
			     string_of_int(Obj.magic ea : int));
 *)
	    None
    with
      | Not_found ->
	  None in
  match f_opt with
    | None -> None
    | Some f -> Some(f e)

(* to_string: This is the function called by users. If there is
   Printexc.register_printer, we simply call Printexc.to_string
   - our printers are also registered with Printexc. If Ocaml does
   not provide this feature, we can only use our own registry
 *)

let to_string e =
  if Netsys_conf.have_printexc_register_printer then
    Printexc.to_string e
  else
    match to_string_opt e with
      | None -> Printexc.to_string e
      | Some s -> s

(* If supported, register our registry: *)

let () =
  if Netsys_conf.have_printexc_register_printer then
    Netsys_conf.printexc_register_printer to_string_opt


(* Add printers for the core exceptions: *)
    
let string_of_unix_code =
  function
    | Unix.E2BIG -> "E2BIG"   
    | Unix.EACCES -> "EACCES"  
    | Unix.EAGAIN -> "EAGAIN"  
    | Unix.EBADF -> "EBADF"   
    | Unix.EBUSY -> "EBUSY"   
    | Unix.ECHILD -> "ECHILD"  
    | Unix.EDEADLK -> "EDEADLK"         
    | Unix.EDOM -> "EDOM"    
    | Unix.EEXIST -> "EEXIST"  
    | Unix.EFAULT -> "EFAULT"  
    | Unix.EFBIG -> "EFBIG"   
    | Unix.EINTR -> "EINTR"   
    | Unix.EINVAL -> "EINVAL"  
    | Unix.EIO -> "EIO"     
    | Unix.EISDIR -> "EISDIR"  
    | Unix.EMFILE -> "EMFILE"  
    | Unix.EMLINK -> "EMLINK"  
    | Unix.ENAMETOOLONG -> "ENAMETOOLONG"    
    | Unix.ENFILE -> "ENFILE"  
    | Unix.ENODEV -> "ENODEV"  
    | Unix.ENOENT -> "ENOENT"  
    | Unix.ENOEXEC -> "ENOEXEC"         
    | Unix.ENOLCK -> "ENOLCK"  
    | Unix.ENOMEM -> "ENOMEM"  
    | Unix.ENOSPC -> "ENOSPC"  
    | Unix.ENOSYS -> "ENOSYS"  
    | Unix.ENOTDIR -> "ENOTDIR"         
    | Unix.ENOTEMPTY -> "ENOTEMPTY"       
    | Unix.ENOTTY -> "ENOTTY"  
    | Unix.ENXIO -> "ENXIO"   
    | Unix.EPERM -> "EPERM"   
    | Unix.EPIPE -> "EPIPE"   
    | Unix.ERANGE -> "ERANGE"  
    | Unix.EROFS -> "EROFS"   
    | Unix.ESPIPE -> "ESPIPE"  
    | Unix.ESRCH -> "ESRCH"   
    | Unix.EXDEV -> "EXDEV"   
    | Unix.EWOULDBLOCK -> "EWOULDBLOCK"     
    | Unix.EINPROGRESS -> "EINPROGRESS"     
    | Unix.EALREADY -> "EALREADY"        
    | Unix.ENOTSOCK -> "ENOTSOCK"        
    | Unix.EDESTADDRREQ -> "EDESTADDRREQ"    
    | Unix.EMSGSIZE -> "EMSGSIZE"        
    | Unix.EPROTOTYPE -> "EPROTOTYPE"      
    | Unix.ENOPROTOOPT -> "ENOPROTOOPT"     
    | Unix.EPROTONOSUPPORT -> "EPROTONOSUPPORT"         
    | Unix.ESOCKTNOSUPPORT -> "ESOCKTNOSUPPORT"         
    | Unix.EOPNOTSUPP -> "EOPNOTSUPP"      
    | Unix.EPFNOSUPPORT -> "EPFNOSUPPORT"    
    | Unix.EAFNOSUPPORT -> "EAFNOSUPPORT"    
    | Unix.EADDRINUSE -> "EADDRINUSE"      
    | Unix.EADDRNOTAVAIL -> "EADDRNOTAVAIL"   
    | Unix.ENETDOWN -> "ENETDOWN"        
    | Unix.ENETUNREACH -> "ENETUNREACH"     
    | Unix.ENETRESET -> "ENETRESET"       
    | Unix.ECONNABORTED -> "ECONNABORTED"    
    | Unix.ECONNRESET -> "ECONNRESET"      
    | Unix.ENOBUFS -> "ENOBUFS"         
    | Unix.EISCONN -> "EISCONN"         
    | Unix.ENOTCONN -> "ENOTCONN"        
    | Unix.ESHUTDOWN -> "ESHUTDOWN"       
    | Unix.ETOOMANYREFS -> "ETOOMANYREFS"    
    | Unix.ETIMEDOUT -> "ETIMEDOUT"       
    | Unix.ECONNREFUSED -> "ECONNREFUSED"    
    | Unix.EHOSTDOWN -> "EHOSTDOWN"       
    | Unix.EHOSTUNREACH -> "EHOSTUNREACH"    
    | Unix.ELOOP -> "ELOOP"   
    | Unix.EOVERFLOW -> "EOVERFLOW"       
    | Unix.EUNKNOWNERR n -> "EUNKNOWNERR " ^ string_of_int n


let string_literal s =
  "\"" ^ String.escaped s ^ "\""

let string_of_unix_error e =
  match e with
    | Unix.Unix_error(code, fname, arg) ->
	"Unix.Unix_error(" ^ 
	  string_of_unix_code code ^ ", " ^ 
	  string_literal fname ^ ", " ^ 
	  string_literal arg ^ ")"
    | _ ->
	assert false


let rec string_contains_at s1 s2 k =
  let l1 = String.length s1 in
  let l2 = String.length s2 in
  k + l2 <= l1 && (
    String.sub s1 k l2 = s2 ||
      string_contains_at s1 s2 (k+1)
  )
    
let string_contains s1 s2 =
  (* Is s2 a substring of s1? *)
  string_contains_at s1 s2 0


let have_nice_unix_error =
  (* maybe somebody enhances Printexc at some time so it can already
     print nice Unix errors. Test for this.
   *)
  let s =
    Printexc.to_string (Unix.Unix_error(Unix.ENOENT,"","")) in
  string_contains s "ENOENT"


let () =
  if not have_nice_unix_error then (
    register_printer
      (Unix.Unix_error(Unix.ENOENT,"",""))
      string_of_unix_error
  )
package gapi-ocaml

Source file netexn.ml

Source file `netexn.ml`
