1 #include "r_ext.h"
2
3 SEXP Ryaml_KeysSymbol = NULL;
4 SEXP Ryaml_TagSymbol = NULL;
5 SEXP Ryaml_IdenticalFunc = NULL;
6 SEXP Ryaml_FormatFunc = NULL;
7 SEXP Ryaml_PasteFunc = NULL;
8 SEXP Ryaml_DeparseFunc = NULL;
9 SEXP Ryaml_ClassFunc = NULL;
10 SEXP Ryaml_CollapseSymbol = NULL;
11 SEXP Ryaml_Sentinel = NULL;
12 SEXP Ryaml_SequenceStart = NULL;
13 SEXP Ryaml_MappingStart = NULL;
14 SEXP Ryaml_MappingEnd = NULL;
15 char Ryaml_error_msg[ERROR_MSG_SIZE];
16
17 void
Ryaml_set_error_msg(const char * format,...)18 Ryaml_set_error_msg(const char *format, ...)
19 {
20 va_list args;
21 int result;
22
23 va_start(args, format);
24 result = vsnprintf(Ryaml_error_msg, ERROR_MSG_SIZE, format, args);
25 if (result >= ERROR_MSG_SIZE) {
26 warning("an error occurred, but the message was too long to format properly");
27
28 /* ensure the string is null terminated */
29 Ryaml_error_msg[ERROR_MSG_SIZE-1] = 0;
30 }
31 }
32
33 /* Returns true if obj is a named list */
34 int
Ryaml_is_named_list(s_obj)35 Ryaml_is_named_list(s_obj)
36 SEXP s_obj;
37 {
38 SEXP s_names = NULL;
39 if (TYPEOF(s_obj) != VECSXP)
40 return 0;
41
42 s_names = GET_NAMES(s_obj);
43 return (TYPEOF(s_names) == STRSXP && LENGTH(s_names) == LENGTH(s_obj));
44 }
45
46 /* Call R's paste() function with collapse */
47 SEXP
Ryaml_collapse(s_obj,collapse)48 Ryaml_collapse(s_obj, collapse)
49 SEXP s_obj;
50 char *collapse;
51 {
52 SEXP s_call = NULL, s_retval = NULL;
53
54 PROTECT(s_call = lang3(Ryaml_PasteFunc, s_obj, ScalarString(mkCharCE(collapse, CE_UTF8))));
55 SET_TAG(CDDR(s_call), Ryaml_CollapseSymbol);
56 s_retval = eval(s_call, R_GlobalEnv);
57 UNPROTECT(1);
58
59 return s_retval;
60 }
61
62 /* Return a string representation of the object for error messages */
63 SEXP
Ryaml_inspect(s_obj)64 Ryaml_inspect(s_obj)
65 SEXP s_obj;
66 {
67 SEXP s_call = NULL, s_str = NULL, s_result = NULL;
68
69 /* Using format/paste here is not really what I want, but without
70 * jumping through all kinds of hoops so that I can get the output
71 * of print(), this is the most effort I want to put into this. */
72
73 PROTECT(s_call = lang2(Ryaml_FormatFunc, s_obj));
74 s_str = eval(s_call, R_GlobalEnv);
75 UNPROTECT(1);
76
77 PROTECT(s_str);
78 s_result = Ryaml_collapse(s_str, " ");
79 UNPROTECT(1);
80
81 return s_result;
82 }
83
84 SEXP
Ryaml_get_classes(s_obj)85 Ryaml_get_classes(s_obj)
86 SEXP s_obj;
87 {
88 SEXP s_call = NULL, s_result = NULL;
89
90 PROTECT(s_call = lang2(Ryaml_ClassFunc, s_obj));
91 s_result = eval(s_call, R_GlobalEnv);
92 UNPROTECT(1);
93
94 return s_result;
95 }
96
97 /* Return 1 if obj is of the specified class */
98 int
Ryaml_has_class(s_obj,name)99 Ryaml_has_class(s_obj, name)
100 SEXP s_obj;
101 char *name;
102 {
103 SEXP s_classes = NULL;
104 int i = 0, len = 0, result = 0;
105
106 PROTECT(s_obj);
107 PROTECT(s_classes = Ryaml_get_classes(s_obj));
108 if (TYPEOF(s_classes) == STRSXP) {
109 len = length(s_classes);
110 for (i = 0; i < len; i++) {
111 if (strcmp(CHAR(STRING_ELT(s_classes, i)), name) == 0) {
112 result = 1;
113 break;
114 }
115 }
116 }
117 UNPROTECT(2);
118 return result;
119 }
120
121 SEXP
Ryaml_sanitize_handlers(s_handlers)122 Ryaml_sanitize_handlers(s_handlers)
123 SEXP s_handlers;
124 {
125 SEXP s_handlers_2 = NULL, s_handler = NULL, s_names = NULL, s_names_2 = NULL,
126 s_name = NULL;
127 const char *name = NULL, *name_2 = NULL;
128 cetype_t encoding = CE_NATIVE;
129 int i = 0;
130
131 if (s_handlers == R_NilValue) {
132 return R_NilValue;
133 }
134 else if (!Ryaml_is_named_list(s_handlers)) {
135 error("handlers must be either NULL or a named list of functions");
136 return R_NilValue;
137 }
138 else {
139 PROTECT(s_names = GET_NAMES(s_handlers));
140
141 PROTECT(s_handlers_2 = allocVector(VECSXP, length(s_handlers)));
142 PROTECT(s_names_2 = allocVector(STRSXP, length(s_names)));
143
144 for (i = 0; i < length(s_handlers); i++) {
145 /* Possibly convert name to UTF-8 */
146 PROTECT(s_name = STRING_ELT(s_names, i));
147 encoding = getCharCE(s_name);
148 if (encoding == CE_UTF8) {
149 SET_STRING_ELT(s_names_2, i, s_name);
150 }
151 else {
152 name = CHAR(s_name);
153 name_2 = reEnc(name, encoding, CE_UTF8, 1);
154 UNPROTECT(1); /* s_name */
155
156 PROTECT(s_name = mkCharCE(name_2, CE_UTF8));
157 SET_STRING_ELT(s_names_2, i, s_name);
158 }
159 name = CHAR(s_name);
160
161 /* Validate handler */
162 s_handler = VECTOR_ELT(s_handlers, i);
163
164 if (TYPEOF(s_handler) != CLOSXP) {
165 warning("Your handler for type '%s' is not a function; using default", name);
166 s_handler = R_NilValue;
167 }
168 else if (strcmp(name, "merge") == 0 || strcmp(name, "default") == 0) {
169 /* custom handlers for merge and default are illegal */
170 warning("Custom handling for type '%s' is not allowed; handler ignored", name);
171 s_handler = R_NilValue;
172 }
173
174 SET_VECTOR_ELT(s_handlers_2, i, s_handler);
175 UNPROTECT(1); /* s_name */
176 }
177
178 SET_NAMES(s_handlers_2, s_names_2);
179 s_handlers = s_handlers_2;
180
181 UNPROTECT(3); /* s_names, s_names_2, s_handlers_2 */
182 }
183
184 return s_handlers_2;
185 }
186
187 SEXP
Ryaml_find_handler(s_handlers,name)188 Ryaml_find_handler(s_handlers, name)
189 SEXP s_handlers;
190 const char *name;
191 {
192 SEXP s_names = NULL, s_name = NULL, s_retval = R_NilValue;
193 const char *handler_name = NULL;
194 int i = 0, found = 0;
195
196 /* Look for a custom R handler */
197 if (s_handlers != R_NilValue) {
198 PROTECT(s_names = GET_NAMES(s_handlers));
199 for (i = 0; i < length(s_names); i++) {
200 PROTECT(s_name = STRING_ELT(s_names, i));
201 if (s_name != NA_STRING) {
202 handler_name = CHAR(s_name);
203 if (strcmp(handler_name, name) == 0) {
204 /* Found custom handler */
205 s_retval = VECTOR_ELT(s_handlers, i);
206 found = 1;
207 }
208 }
209 UNPROTECT(1); /* s_name */
210
211 if (found) break;
212 }
213 UNPROTECT(1); /* s_names */
214 }
215
216 return s_retval;
217 }
218
219 int
Ryaml_run_handler(s_handler,s_arg,s_result)220 Ryaml_run_handler(s_handler, s_arg, s_result)
221 SEXP s_handler;
222 SEXP s_arg;
223 SEXP *s_result;
224 {
225 SEXP s_cmd = NULL;
226 int err = 0;
227
228 PROTECT(s_cmd = lang2(s_handler, s_arg));
229 *s_result = R_tryEval(s_cmd, R_GlobalEnv, &err);
230 UNPROTECT(1);
231
232 return err;
233 }
234
235 R_CallMethodDef callMethods[] = {
236 {"unserialize_from_yaml", (DL_FUNC)&Ryaml_unserialize_from_yaml, 8},
237 {"serialize_to_yaml", (DL_FUNC)&Ryaml_serialize_to_yaml, 9},
238 {NULL, NULL, 0}
239 };
240
R_init_yaml(DllInfo * dll)241 void R_init_yaml(DllInfo *dll) {
242 Ryaml_KeysSymbol = install("keys");
243 Ryaml_TagSymbol = install("tag");
244 Ryaml_CollapseSymbol = install("collapse");
245 Ryaml_IdenticalFunc = findFun(install("identical"), R_GlobalEnv);
246 Ryaml_FormatFunc = findFun(install("format"), R_GlobalEnv);
247 Ryaml_PasteFunc = findFun(install("paste"), R_GlobalEnv);
248 Ryaml_DeparseFunc = findFun(install("deparse"), R_GlobalEnv);
249 Ryaml_ClassFunc = findFun(install("class"), R_GlobalEnv);
250 Ryaml_Sentinel = install("sentinel");
251 Ryaml_SequenceStart = install("sequence.start");
252 Ryaml_MappingStart = install("mapping.start");
253 Ryaml_MappingEnd = install("mapping.end");
254 R_registerRoutines(dll, NULL, callMethods, NULL, NULL);
255 R_useDynamicSymbols(dll, FALSE);
256 R_forceSymbols(dll, TRUE);
257 }
258