1 /*
2 * Copyright (C) 2012 Citrix Ltd.
3 * Author Ian Campbell <ian.campbell@citrix.com>
4 *
5 * This program is free software; you can redistribute it and/or modify
6 * it under the terms of the GNU Lesser General Public License as published
7 * by the Free Software Foundation; version 2.1 only. with the special
8 * exception on linking described in file LICENSE.
9 *
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU Lesser General Public License for more details.
14 */
15
16 #define _GNU_SOURCE
17 #include <stdio.h>
18 #include <string.h>
19 #include <unistd.h>
20 #include <errno.h>
21
22 #define CAML_NAME_SPACE
23 #include <caml/alloc.h>
24 #include <caml/memory.h>
25 #include <caml/signals.h>
26 #include <caml/fail.h>
27 #include <caml/callback.h>
28 #include <caml/custom.h>
29
30 #include <xentoollog.h>
31
32 #include "caml_xentoollog.h"
33
34 /* The following is equal to the CAMLreturn macro, but without the return */
35 #define CAMLdone do{ \
36 caml_local_roots = caml__frame; \
37 }while (0)
38
39 #define XTL ((xentoollog_logger *) Xtl_val(handle))
40
dup_String_val(value s)41 static char * dup_String_val(value s)
42 {
43 int len;
44 char *c;
45 len = caml_string_length(s);
46 c = calloc(len + 1, sizeof(char));
47 if (!c)
48 caml_raise_out_of_memory();
49 memcpy(c, String_val(s), len);
50 return c;
51 }
52
53 #include "_xtl_levels.inc"
54
55 /* Option type support as per http://www.linux-nantes.org/~fmonnier/ocaml/ocaml-wrapping-c.php */
56 #define Val_none Val_int(0)
57 #define Some_val(v) Field(v,0)
58
Val_some(value v)59 static value Val_some(value v)
60 {
61 CAMLparam1(v);
62 CAMLlocal1(some);
63 some = caml_alloc(1, 0);
64 Store_field(some, 0, v);
65 CAMLreturn(some);
66 }
67
Val_errno(int errnoval)68 static value Val_errno(int errnoval)
69 {
70 if (errnoval == -1)
71 return Val_none;
72 return Val_some(Val_int(errnoval));
73 }
74
Val_context(const char * context)75 static value Val_context(const char *context)
76 {
77 if (context == NULL)
78 return Val_none;
79 return Val_some(caml_copy_string(context));
80 }
81
stub_xtl_ocaml_vmessage(struct xentoollog_logger * logger,xentoollog_level level,int errnoval,const char * context,const char * format,va_list al)82 static void stub_xtl_ocaml_vmessage(struct xentoollog_logger *logger,
83 xentoollog_level level,
84 int errnoval,
85 const char *context,
86 const char *format,
87 va_list al)
88 {
89 caml_leave_blocking_section();
90 CAMLparam0();
91 CAMLlocalN(args, 4);
92 struct caml_xtl *xtl = (struct caml_xtl*)logger;
93 value *func = caml_named_value(xtl->vmessage_cb) ;
94 char *msg;
95
96 if (func == NULL)
97 caml_raise_sys_error(caml_copy_string("Unable to find callback"));
98 if (vasprintf(&msg, format, al) < 0)
99 caml_raise_out_of_memory();
100
101 /* vmessage : level -> int option -> string option -> string -> unit; */
102 args[0] = Val_level(level);
103 args[1] = Val_errno(errnoval);
104 args[2] = Val_context(context);
105 args[3] = caml_copy_string(msg);
106
107 free(msg);
108
109 caml_callbackN(*func, 4, args);
110 CAMLdone;
111 caml_enter_blocking_section();
112 }
113
stub_xtl_ocaml_progress(struct xentoollog_logger * logger,const char * context,const char * doing_what,int percent,unsigned long done,unsigned long total)114 static void stub_xtl_ocaml_progress(struct xentoollog_logger *logger,
115 const char *context,
116 const char *doing_what /* no \r,\n */,
117 int percent, unsigned long done, unsigned long total)
118 {
119 caml_leave_blocking_section();
120 CAMLparam0();
121 CAMLlocalN(args, 5);
122 struct caml_xtl *xtl = (struct caml_xtl*)logger;
123 value *func = caml_named_value(xtl->progress_cb) ;
124
125 if (func == NULL)
126 caml_raise_sys_error(caml_copy_string("Unable to find callback"));
127
128 /* progress : string option -> string -> int -> int64 -> int64 -> unit; */
129 args[0] = Val_context(context);
130 args[1] = caml_copy_string(doing_what);
131 args[2] = Val_int(percent);
132 args[3] = caml_copy_int64(done);
133 args[4] = caml_copy_int64(total);
134
135 caml_callbackN(*func, 5, args);
136 CAMLdone;
137 caml_enter_blocking_section();
138 }
139
xtl_destroy(struct xentoollog_logger * logger)140 static void xtl_destroy(struct xentoollog_logger *logger)
141 {
142 struct caml_xtl *xtl = (struct caml_xtl*)logger;
143 free(xtl->vmessage_cb);
144 free(xtl->progress_cb);
145 free(xtl);
146 }
147
xtl_finalize(value handle)148 void xtl_finalize(value handle)
149 {
150 xtl_destroy(XTL);
151 }
152
153 static struct custom_operations xentoollogger_custom_operations = {
154 "xentoollogger_custom_operations",
155 xtl_finalize /* custom_finalize_default */,
156 custom_compare_default,
157 custom_hash_default,
158 custom_serialize_default,
159 custom_deserialize_default
160 };
161
162 /* external _create_logger: (string * string) -> handle = "stub_xtl_create_logger" */
stub_xtl_create_logger(value cbs)163 CAMLprim value stub_xtl_create_logger(value cbs)
164 {
165 CAMLparam1(cbs);
166 CAMLlocal1(handle);
167 struct caml_xtl *xtl = malloc(sizeof(*xtl));
168 if (xtl == NULL)
169 caml_raise_out_of_memory();
170
171 memset(xtl, 0, sizeof(*xtl));
172
173 xtl->vtable.vmessage = &stub_xtl_ocaml_vmessage;
174 xtl->vtable.progress = &stub_xtl_ocaml_progress;
175 xtl->vtable.destroy = &xtl_destroy;
176
177 xtl->vmessage_cb = dup_String_val(Field(cbs, 0));
178 xtl->progress_cb = dup_String_val(Field(cbs, 1));
179
180 handle = caml_alloc_custom(&xentoollogger_custom_operations, sizeof(xtl), 0, 1);
181 Xtl_val(handle) = xtl;
182
183 CAMLreturn(handle);
184 }
185
186 /* external test: handle -> unit = "stub_xtl_test" */
stub_xtl_test(value handle)187 CAMLprim value stub_xtl_test(value handle)
188 {
189 unsigned long l;
190 CAMLparam1(handle);
191 xtl_log(XTL, XTL_DEBUG, -1, "debug", "%s -- debug", __func__);
192 xtl_log(XTL, XTL_INFO, -1, "test", "%s -- test 1", __func__);
193 xtl_log(XTL, XTL_INFO, ENOSYS, "test errno", "%s -- test 2", __func__);
194 xtl_log(XTL, XTL_CRITICAL, -1, "critical", "%s -- critical", __func__);
195 for (l = 0UL; l<=100UL; l += 10UL) {
196 xtl_progress(XTL, "progress", "testing", l, 100UL);
197 usleep(10000);
198 }
199 CAMLreturn(Val_unit);
200 }
201
202