File Coverage

pl_duk.c
Criterion Covered Total %
statement 364 409 89.0
branch 155 262 59.1
condition n/a
subroutine n/a
pod n/a
total 519 671 77.3


line stmt bran cond sub pod time code
1             #include "duk_console.h"
2             #include "c_eventloop.h"
3             #include "pl_stats.h"
4             #include "pl_util.h"
5             #include "pl_duk.h"
6              
7             #define NEED_sv_2pv_flags
8             #include "ppport.h"
9              
10             #define PL_GC_RUNS 2
11              
12             #define PL_JSON_CLASS "JSON::PP"
13             #define PL_JSON_BOOLEAN_CLASS PL_JSON_CLASS "::" "Boolean"
14             #define PL_JSON_BOOLEAN_TRUE PL_JSON_CLASS "::" "true"
15             #define PL_JSON_BOOLEAN_FALSE PL_JSON_CLASS "::" "false"
16              
17             static duk_ret_t perl_caller(duk_context* ctx);
18              
19             static HV* seen;
20              
21 3000832           static SV* pl_duk_to_perl_impl(pTHX_ duk_context* ctx, int pos, HV* seen)
22             {
23 3000832           SV* ret = &PL_sv_undef; /* return undef by default */
24 3000832           switch (duk_get_type(ctx, pos)) {
25             case DUK_TYPE_NONE:
26             case DUK_TYPE_UNDEFINED:
27             case DUK_TYPE_NULL: {
28 309           break;
29             }
30             case DUK_TYPE_BOOLEAN: {
31 35           duk_bool_t val = duk_get_boolean(ctx, pos);
32 35 100         ret = get_sv(val ? PL_JSON_BOOLEAN_TRUE : PL_JSON_BOOLEAN_FALSE, 0);
33 35           SvREFCNT_inc(ret);
34 35           break;
35             }
36             case DUK_TYPE_NUMBER: {
37 3000144           duk_double_t val = duk_get_number(ctx, pos);
38 3000144           ret = newSVnv(val); /* JS numbers are always doubles */
39 3000144           break;
40             }
41             case DUK_TYPE_STRING: {
42 134           duk_size_t clen = 0;
43 134           const char* cstr = duk_get_lstring(ctx, pos, &clen);
44 134           ret = newSVpvn(cstr, clen);
45 134           SvUTF8_on(ret); /* yes, always */
46 134           break;
47             }
48             case DUK_TYPE_OBJECT: {
49 210 100         if (duk_is_c_function(ctx, pos)) {
50             /* if the JS function has a slot with the Perl callback, */
51             /* then we know we created it, so we return that */
52 31 100         if (duk_get_prop_lstring(ctx, pos, PL_SLOT_GENERIC_CALLBACK, sizeof(PL_SLOT_GENERIC_CALLBACK) - 1)) {
53 3           ret = (SV*) duk_get_pointer(ctx, pos);
54             }
55 31           duk_pop(ctx); /* pop function / null pointer */
56 179 100         } else if (duk_is_array(ctx, pos)) {
57 74           void* ptr = duk_get_heapptr(ctx, pos);
58             char kstr[100];
59 74           int klen = sprintf(kstr, "%p", ptr);
60 74           SV** answer = hv_fetch(seen, kstr, klen, 0);
61 74 100         if (answer) {
62             /* TODO: weaken reference? */
63 3           ret = newRV_inc(*answer);
64             } else {
65 71           int array_top = 0;
66 71           int j = 0;
67 71           AV* values_array = newAV();
68 71           SV* values = sv_2mortal((SV*) values_array);
69 71 50         if (hv_store(seen, kstr, klen, values, 0)) {
70 71           SvREFCNT_inc(values);
71             }
72 71           ret = newRV_inc(values);
73              
74 71           array_top = duk_get_length(ctx, pos);
75 220 100         for (j = 0; j < array_top; ++j) {
76 146           SV* nested = 0;
77 146 50         if (!duk_get_prop_index(ctx, pos, j)) {
78 0           continue; /* index doesn't exist => end of array */
79             }
80 146           nested = sv_2mortal(pl_duk_to_perl_impl(aTHX_ ctx, -1, seen));
81 146           duk_pop(ctx); /* value in current pos */
82 146 50         if (!nested) {
83 0           croak("Could not create Perl SV for array\n");
84             }
85 146 50         if (av_store(values_array, j, nested)) {
86 146           SvREFCNT_inc(nested);
87             }
88             }
89             }
90             } else { /* if (duk_is_object(ctx, pos)) { */
91 105           void* ptr = duk_get_heapptr(ctx, pos);
92             char kstr[100];
93 105           int klen = sprintf(kstr, "%p", ptr);
94 105           SV** answer = hv_fetch(seen, kstr, klen, 0);
95 105 100         if (answer) {
96             /* TODO: weaken reference? */
97 9           ret = newRV_inc(*answer);
98             } else {
99 96           HV* values_hash = newHV();
100 96           SV* values = sv_2mortal((SV*) values_hash);
101 96 50         if (hv_store(seen, kstr, klen, values, 0)) {
102 96           SvREFCNT_inc(values);
103             }
104 96           ret = newRV_inc(values);
105              
106 96           duk_enum(ctx, pos, 0);
107 274 100         while (duk_next(ctx, -1, 1)) { /* get key and value */
108 178           duk_size_t klen = 0;
109 178           const char* kstr = duk_get_lstring(ctx, -2, &klen);
110 178           SV* nested = sv_2mortal(pl_duk_to_perl_impl(aTHX_ ctx, -1, seen));
111 178           duk_pop_2(ctx); /* key and value */
112 178 50         if (!nested) {
113 0           croak("Could not create Perl SV for hash\n");
114             }
115 178 50         if (hv_store(values_hash, kstr, -klen, nested, 0)) {
116 178           SvREFCNT_inc(nested);
117             }
118             }
119 105           duk_pop(ctx); /* iterator */
120             }
121             }
122 210           break;
123             }
124             case DUK_TYPE_POINTER: {
125 0           ret = (SV*) duk_get_pointer(ctx, -1);
126 0           break;
127             }
128             case DUK_TYPE_BUFFER: {
129 0           croak("Don't know how to deal with a JS buffer\n");
130             break;
131             }
132             case DUK_TYPE_LIGHTFUNC: {
133 0           croak("Don't know how to deal with a JS lightfunc\n");
134             break;
135             }
136             default:
137 0           croak("Don't know how to deal with an undetermined JS object\n");
138             break;
139             }
140 3000832           return ret;
141             }
142              
143 5314           static int pl_perl_to_duk_impl(pTHX_ SV* value, duk_context* ctx, HV* seen, int ref)
144             {
145 5314           int ret = 1;
146 5314 50         if (SvTYPE(value) >= SVt_PVMG) {
147             /* any Perl SV that has magic (think tied objects) needs to have that
148             * magic actually called to retrieve the value */
149 0           mg_get(value);
150             }
151 5314 100         if (!SvOK(value)) {
    50          
    50          
152 5           duk_push_null(ctx);
153 5309 100         } else if (sv_isa(value, PL_JSON_BOOLEAN_CLASS)) {
154 2 50         int val = SvTRUE(value);
    50          
    0          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    100          
155 2           duk_push_boolean(ctx, val);
156 5307 100         } else if (SvPOK(value)) {
157 1070           STRLEN vlen = 0;
158 1070 50         const char* vstr = SvPV_const(value, vlen);
159 1070           duk_push_lstring(ctx, vstr, vlen);
160 4237 100         } else if (SvIOK(value)) {
161 3103 50         long val = SvIV(value);
162 3103 100         if (ref && (val == 0 || val == 1)) {
    100          
    100          
163 4           duk_push_boolean(ctx, val);
164             } else {
165 3103           duk_push_number(ctx, (duk_double_t) val);
166             }
167 1134 100         } else if (SvNOK(value)) {
168 3 50         double val = SvNV(value);
169 3           duk_push_number(ctx, (duk_double_t) val);
170 1131 50         } else if (SvROK(value)) {
171 1131           SV* ref = SvRV(value);
172 1131           int type = SvTYPE(ref);
173 1131 100         if (type < SVt_PVAV) {
174 15 50         if (!pl_perl_to_duk_impl(aTHX_ ref, ctx, seen, 1)) {
175 0           croak("Could not create JS element for reference\n");
176             }
177 1116 100         } else if (type == SVt_PVAV) {
178 1056           AV* values = (AV*) ref;
179             char kstr[100];
180 1056           int klen = sprintf(kstr, "%p", values);
181 1056           SV** answer = hv_fetch(seen, kstr, klen, 0);
182 1056 100         if (answer) {
183 3 50         void* ptr = (void*) SvUV(*answer);
184 3           duk_push_heapptr(ctx, ptr);
185             } else {
186 1053           int array_top = 0;
187 1053           int count = 0;
188 1053           int j = 0;
189 1053           duk_idx_t array_pos = duk_push_array(ctx);
190 1053           void* ptr = duk_get_heapptr(ctx, array_pos);
191 1053           SV* uptr = sv_2mortal(newSVuv(PTR2UV(ptr)));
192 1053 50         if (hv_store(seen, kstr, klen, uptr, 0)) {
193 1053           SvREFCNT_inc(uptr);
194             }
195              
196 1053           array_top = av_len(values);
197 4169 100         for (j = 0; j <= array_top; ++j) { /* yes, [0, array_top] */
198 3113           SV** elem = av_fetch(values, j, 0);
199 3113 50         if (!elem || !*elem) {
    50          
200             break; /* could not get element */
201             }
202 3113 50         if (!pl_perl_to_duk_impl(aTHX_ *elem, ctx, seen, 0)) {
203 0           croak("Could not create JS element for array\n");
204             }
205 3113 50         if (!duk_put_prop_index(ctx, array_pos, count)) {
206 0           croak("Could not push JS element for array\n");
207             }
208 3113           ++count;
209             }
210             }
211 60 100         } else if (type == SVt_PVHV) {
212 35           HV* values = (HV*) ref;
213             char kstr[100];
214 35           int klen = sprintf(kstr, "%p", values);
215 35           SV** answer = hv_fetch(seen, kstr, klen, 0);
216 35 100         if (answer) {
217 3 50         void* ptr = (void*) SvUV(*answer);
218 3           duk_push_heapptr(ctx, ptr);
219             } else {
220 32           duk_idx_t hash_pos = duk_push_object(ctx);
221 32           void* ptr = duk_get_heapptr(ctx, hash_pos);
222 32           SV* uptr = sv_2mortal(newSVuv(PTR2UV(ptr)));
223 32 50         if (hv_store(seen, kstr, klen, uptr, 0)) {
224 32           SvREFCNT_inc(uptr);
225             }
226              
227 32           hv_iterinit(values);
228             while (1) {
229 84           SV* key = 0;
230 84           SV* value = 0;
231 84           char* kstr = 0;
232 84           STRLEN klen = 0;
233 84           HE* entry = hv_iternext(values);
234 84 100         if (!entry) {
235 32           break; /* no more hash keys */
236             }
237 52           key = hv_iterkeysv(entry);
238 52 50         if (!key) {
239 0           continue; /* invalid key */
240             }
241 52           SvUTF8_on(key); /* yes, always */
242 52 50         kstr = SvPV(key, klen);
243 52 50         if (!kstr) {
244 0           continue; /* invalid key */
245             }
246              
247 52           value = hv_iterval(values, entry);
248 52 50         if (!value) {
249 0           continue; /* invalid value */
250             }
251 52           SvUTF8_on(value); /* yes, always */
252              
253 52 50         if (!pl_perl_to_duk_impl(aTHX_ value, ctx, seen, 0)) {
254 0           croak("Could not create JS element for hash\n");
255             }
256 52 50         if (! duk_put_prop_lstring(ctx, hash_pos, kstr, klen)) {
257 52           croak("Could not push JS element for hash\n");
258             }
259 87           }
260             }
261 25 50         } else if (type == SVt_PVCV) {
262             /* use perl_caller as generic handler, but store the real callback */
263             /* in a slot, from where we can later retrieve it */
264 25           SV* func = newSVsv(value);
265 25           duk_push_c_function(ctx, perl_caller, DUK_VARARGS);
266 25 50         if (!func) {
267 0           croak("Could not create copy of Perl callback\n");
268             }
269 25           duk_push_pointer(ctx, func);
270 25 50         if (! duk_put_prop_lstring(ctx, -2, PL_SLOT_GENERIC_CALLBACK, sizeof(PL_SLOT_GENERIC_CALLBACK) - 1)) {
271 25           croak("Could not associate C dispatcher and Perl callback\n");
272             }
273             } else {
274 1131           croak("Don't know how to deal with an undetermined Perl reference (type: %d)\n", type);
275             ret = 0;
276             }
277             } else {
278 0           croak("Don't know how to deal with an undetermined Perl object\n");
279             ret = 0;
280             }
281 5314           return ret;
282             }
283              
284 3000508           SV* pl_duk_to_perl(pTHX_ duk_context* ctx, int pos)
285             {
286 3000508 100         if (!seen) {
287 25           seen = newHV();
288             }
289 3000508           SV* ret = pl_duk_to_perl_impl(aTHX_ ctx, pos, seen);
290 3000508           hv_clear(seen);
291 3000508           return ret;
292             }
293              
294 2134           int pl_perl_to_duk(pTHX_ SV* value, duk_context* ctx)
295             {
296 2134 50         if (!seen) {
297 0           seen = newHV();
298             }
299 2134           int ret = pl_perl_to_duk_impl(aTHX_ value, ctx, seen, 0);
300 2134           hv_clear(seen);
301 2134           return ret;
302             }
303              
304 18           static const char* get_typeof(duk_context* ctx, int pos)
305             {
306 18           const char* label = "undefined";
307 18           switch (duk_get_type(ctx, pos)) {
308             case DUK_TYPE_NONE:
309             case DUK_TYPE_UNDEFINED:
310 0           break;
311             case DUK_TYPE_NULL:
312 1           label = "null";
313 1           break;
314             case DUK_TYPE_BOOLEAN:
315 4           label = "boolean";
316 4           break;
317             case DUK_TYPE_NUMBER:
318 3           label = "number";
319 3           break;
320             case DUK_TYPE_STRING:
321 5           label = "string";
322 5           break;
323             case DUK_TYPE_OBJECT:
324 5 100         if (duk_is_array(ctx, pos)) {
325 2           label = "array";
326             }
327 3 50         else if (duk_is_symbol(ctx, pos)) {
328 0           label = "symbol";
329             }
330 3 50         else if (duk_is_pointer(ctx, pos)) {
331 0           label = "pointer";
332             }
333 3 100         else if (duk_is_function(ctx, pos)) {
334 1           label = "function";
335             }
336 2 50         else if (duk_is_c_function(ctx, pos)) {
337 0           label = "c_function";
338             }
339 2 50         else if (duk_is_thread(ctx, pos)) {
340 0           label = "thread";
341             }
342             else {
343 2           label = "object";
344             }
345 5           break;
346             case DUK_TYPE_POINTER:
347 0           label = "pointer";
348 0           break;
349             case DUK_TYPE_BUFFER:
350 0           label = "buffer";
351 0           break;
352             case DUK_TYPE_LIGHTFUNC:
353 0           label = "lightfunc";
354 0           break;
355             default:
356 0           croak("Don't know how to deal with an undetermined JS object\n");
357             break;
358             }
359 18           return label;
360             }
361              
362 35           int pl_call_perl_sv(duk_context* ctx, SV* func)
363             {
364 35           duk_idx_t j = 0;
365 35           duk_idx_t nargs = 0;
366 35           SV* ret = 0;
367             SV *err_tmp;
368              
369             /* prepare Perl environment for calling the CV */
370             dTHX;
371 35           dSP;
372 35           ENTER;
373 35           SAVETMPS;
374 35 50         PUSHMARK(SP);
375              
376             /* pass in the stack each of the params we received */
377 35           nargs = duk_get_top(ctx);
378 106 100         for (j = 0; j < nargs; j++) {
379 71           SV* val = pl_duk_to_perl(aTHX_ ctx, j);
380 71 50         mXPUSHs(val);
381             }
382              
383             /* you would think we need to pop off the args from duktape's stack, but
384             * they get popped off somewhere else, probably by duktape itself */
385              
386             /* call actual Perl CV, passing all params */
387 35           PUTBACK;
388 35           call_sv(func, G_SCALAR | G_EVAL);
389 35           SPAGAIN;
390              
391 35 50         err_tmp = ERRSV;
392 35 50         if (SvTRUE(err_tmp)) {
    50          
    50          
    0          
    0          
    50          
    50          
    100          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    100          
393 3 50         croak("Perl sub died with error: %s", SvPV_nolen(err_tmp));
394             }
395              
396             /* get returned value from Perl and push its JS equivalent back in */
397             /* duktape's stack */
398 32           ret = POPs;
399 32           pl_perl_to_duk(aTHX_ ret, ctx);
400              
401             /* cleanup and return 1, indicating we are returning a value */
402 32           PUTBACK;
403 32 50         FREETMPS;
404 32           LEAVE;
405 32           return 1;
406             }
407              
408 1003307           static int find_last_dot(const char* name, int* len)
409             {
410 1003307           int last_dot = -1;
411 1003307           int l = 0;
412 7039988 100         for (; name[l] != '\0'; ++l) {
413 6036681 100         if (name[l] == '.') {
414 1046           last_dot = l;
415             }
416             }
417 1003307           *len = l;
418 1003307           return last_dot;
419             }
420              
421 1001197           static int find_global_or_property(duk_context* ctx, const char* name)
422             {
423 1001197           int ret = 0;
424 1001197           int len = 0;
425 1001197           int last_dot = find_last_dot(name, &len);
426 1001197 100         if (last_dot < 0) {
427 1001164 100         if (duk_get_global_string(ctx, name)) {
428             /* that leaves global value in stack, for caller to deal with */
429 1000134           ret = 1;
430             } else {
431 1001164           duk_pop(ctx); /* pop value (which was undef) */
432             }
433             } else {
434 33 50         if (duk_peval_lstring(ctx, name, last_dot) == 0) {
435             /* that leaves object containing value in stack */
436 33 100         if (duk_get_prop_lstring(ctx, -1, name + last_dot + 1, len - last_dot - 1)) {
437             /* that leaves value in stack */
438 28           ret = 1;
439              
440             /* have [object, value], need just [value] */
441 28           duk_swap(ctx, -2, -1); /* now have [value, object] */
442 28           duk_pop(ctx); /* pop object, leave canoli... er, value */
443             } else {
444 33           duk_pop_2(ctx); /* pop object and value (which was undef) */
445             }
446             } else {
447 0           duk_pop(ctx); /* pop error */
448             }
449             }
450 1001197           return ret;
451             }
452              
453 60           SV* pl_exists_global_or_property(pTHX_ duk_context* ctx, const char* name)
454             {
455 60           SV* ret = &PL_sv_no; /* return false by default */
456 60 100         if (find_global_or_property(ctx, name)) {
457 30           ret = &PL_sv_yes;
458 30           duk_pop(ctx); /* pop value */
459             }
460 60           return ret;
461             }
462              
463 20           SV* pl_typeof_global_or_property(pTHX_ duk_context* ctx, const char* name)
464             {
465 20           const char* cstr = "undefined";
466 20           STRLEN clen = 0;
467 20           SV* ret = 0;
468 20 100         if (find_global_or_property(ctx, name)) {
469 18           cstr = get_typeof(ctx, -1);
470 18           duk_pop(ctx); /* pop value */
471             }
472 20           ret = newSVpv(cstr, clen);
473 20           return ret;
474             }
475              
476 12           SV* pl_instanceof_global_or_property(pTHX_ duk_context* ctx, const char* object, const char* class)
477             {
478 12           SV* ret = &PL_sv_no; /* return false by default */
479 12 50         if (find_global_or_property(ctx, object)) {
480 12 100         if (find_global_or_property(ctx, class)) {
481 9 100         if (duk_instanceof(ctx, -2, -1)) {
482 6           ret = &PL_sv_yes;
483             }
484 9           duk_pop(ctx); /* pop class */
485             }
486 12           duk_pop(ctx); /* pop value */
487             }
488 12           return ret;
489             }
490              
491 1001093           SV* pl_get_global_or_property(pTHX_ duk_context* ctx, const char* name)
492             {
493 1001093           SV* ret = &PL_sv_undef; /* return undef by default */
494 1001093 100         if (find_global_or_property(ctx, name)) {
495             /* Convert found value to Perl and pop it off the stack */
496 1000093           ret = pl_duk_to_perl(aTHX_ ctx, -1);
497 1000093           duk_pop(ctx);
498             }
499 1001093           return ret;
500             }
501              
502 2102           int pl_set_global_or_property(pTHX_ duk_context* ctx, const char* name, SV* value)
503             {
504 2102           int len = 0;
505 2102           int last_dot = 0;
506              
507             /* fprintf(stderr, "STACK: %ld\n", (long) duk_get_top(ctx)); */
508              
509 2102 50         if (pl_perl_to_duk(aTHX_ value, ctx)) {
510             /* that put value in stack */
511             } else {
512 0           return 0;
513             }
514 2102           last_dot = find_last_dot(name, &len);
515 2102 100         if (last_dot < 0) {
516 1098 50         if (duk_put_global_lstring(ctx, name, len)) {
517             /* that consumed value that was in stack */
518             } else {
519 0           duk_pop(ctx); /* pop value */
520 0           croak("Could not save duk value for %s\n", name);
521             }
522             } else {
523 1004           duk_push_lstring(ctx, name + last_dot + 1, len - last_dot - 1);
524             /* that put key in stack */
525 1004 50         if (duk_peval_lstring(ctx, name, last_dot) == 0) {
526             /* that put object in stack */
527             } else {
528 0           duk_pop_2(ctx); /* object (error) and value */
529 0           croak("Could not eval JS object %*.*s: %s\n",
530             last_dot, last_dot, name, duk_safe_to_string(ctx, -1));
531             }
532             /* Have [value, key, object], need [object, key, value], hence swap */
533 1004           duk_swap(ctx, -3, -1);
534              
535 1004           duk_put_prop(ctx, -3); /* consumes key and value */
536 1004           duk_pop(ctx); /* pop object */
537             }
538 2102           return 1;
539             }
540              
541 8           int pl_del_global_or_property(pTHX_ duk_context* ctx, const char* name)
542             {
543 8           int len = 0;
544 8           int last_dot = find_last_dot(name, &len);
545 8 100         if (last_dot < 0) {
546 4           duk_push_global_object(ctx);
547 4           duk_del_prop_lstring(ctx, -1, name, len);
548             } else {
549 4 50         if (duk_peval_lstring(ctx, name, last_dot) == 0) {
550             /* that put object in stack */
551             } else {
552 0           duk_pop(ctx); /* object (error) */
553 0           croak("Could not eval JS object %*.*s: %s\n",
554             last_dot, last_dot, name, duk_safe_to_string(ctx, -1));
555             }
556 4           duk_del_prop_lstring(ctx, -1, name + last_dot + 1, len - last_dot - 1);
557             }
558 8           duk_pop(ctx); /* pop global or property object */
559 8           return 1;
560             }
561              
562 2000347           SV* pl_eval(pTHX_ Duk* duk, const char* js, const char* file)
563             {
564 2000347           SV* ret = &PL_sv_undef; /* return undef by default */
565 2000347           duk_context* ctx = duk->ctx;
566 2000347           duk_int_t rc = 0;
567              
568             do {
569             Stats stats;
570 2000347           duk_uint_t flags = 0;
571              
572             /* flags |= DUK_COMPILE_STRICT; */
573              
574 2000347           pl_stats_start(aTHX_ duk, &stats);
575 2000347 100         if (!file) {
576             /* Compile the requested code without a reference to the file where it lives */
577 2000082           rc = duk_pcompile_string(ctx, flags, js);
578             }
579             else {
580             /* Compile the requested code referencing the file where it lives */
581 265           duk_push_string(ctx, file);
582 265           rc = duk_pcompile_string_filename(ctx, flags, js);
583             }
584 2000347           pl_stats_stop(aTHX_ duk, &stats, "compile");
585 2000347 50         if (rc != DUK_EXEC_SUCCESS) {
586             /* Only for an error this early we print something out and bail out */
587 0           duk_console_log(DUK_CONSOLE_FLUSH | DUK_CONSOLE_TO_STDERR,
588             "JS could not compile code: %s\n",
589             duk_safe_to_string(ctx, -1));
590 0           break;
591             }
592              
593             /* Run the requested code and check for possible errors*/
594 2000347           pl_stats_start(aTHX_ duk, &stats);
595 2000347           rc = duk_pcall(ctx, 0);
596 2000344           pl_stats_stop(aTHX_ duk, &stats, "run");
597 2000344           check_duktape_call_for_errors(rc, ctx);
598              
599             /* Convert returned value to Perl and pop it off the stack */
600 2000344           ret = pl_duk_to_perl(aTHX_ ctx, -1);
601 2000344           duk_pop(ctx);
602              
603             /* Launch eventloop and check for errors again. */
604             /* This call only returns after the eventloop terminates. */
605 2000344           rc = duk_safe_call(ctx, eventloop_run, duk, 0 /*nargs*/, 1 /*nrets*/);
606 2000344           check_duktape_call_for_errors(rc, ctx);
607              
608 2000344           duk_pop(ctx); /* pop return value from duk_safe_call */
609             } while (0);
610              
611 2000344           return ret;
612             }
613              
614 1           int pl_run_gc(Duk* duk)
615             {
616 1           int j = 0;
617              
618             /*
619             * From docs in http://duktape.org/api.html#duk_gc
620             *
621             * You may want to call this function twice to ensure even objects with
622             * finalizers are collected. Currently it takes two mark-and-sweep rounds
623             * to collect such objects. First round marks the object as finalizable
624             * and runs the finalizer. Second round ensures the object is still
625             * unreachable after finalization and then frees the object.
626             */
627 1           duk_context* ctx = duk->ctx;
628 3 100         for (j = 0; j < PL_GC_RUNS; ++j) {
629             /* DUK_GC_COMPACT: Force object property table compaction */
630 2           duk_gc(ctx, DUK_GC_COMPACT);
631             }
632 1           return PL_GC_RUNS;
633             }
634              
635 18           SV* pl_global_objects(pTHX_ duk_context* ctx)
636             {
637 18           int count = 0;
638 18           AV* values = newAV();
639              
640 18           duk_push_global_object(ctx);
641 18           duk_enum(ctx, -1, 0);
642 223 100         while (duk_next(ctx, -1, 0)) { /* get keys only */
643 205           duk_size_t klen = 0;
644 205           const char* kstr = duk_get_lstring(ctx, -1, &klen);
645 205           SV* name = sv_2mortal(newSVpvn(kstr, klen));
646 205           SvUTF8_on(name); /* yes, always */
647 205 50         if (av_store(values, count, name)) {
648 205           SvREFCNT_inc(name);
649 205           ++count;
650             }
651 205           duk_pop(ctx); /* key */
652             }
653 18           duk_pop_2(ctx); /* iterator and global object */
654 18           return newRV_inc((SV*) values);
655             }
656              
657 11           static duk_ret_t perl_caller(duk_context* ctx)
658             {
659 11           SV* func = 0;
660              
661             /* get actual Perl CV stored as a function property */
662 11           duk_push_current_function(ctx);
663 11 50         if (!duk_get_prop_lstring(ctx, -1, PL_SLOT_GENERIC_CALLBACK, sizeof(PL_SLOT_GENERIC_CALLBACK) - 1)) {
664 0           croak("Calling Perl handler for a non-Perl function\n");
665             }
666              
667 11           func = (SV*) duk_get_pointer(ctx, -1);
668 11           duk_pop_2(ctx); /* pop pointer and function */
669 11 50         if (func == 0) {
670 0           croak("Could not get value for property %s\n", PL_SLOT_GENERIC_CALLBACK);
671             }
672              
673 11           return pl_call_perl_sv(ctx, func);
674             }
675              
676 3           static void add_hash_key_int(pTHX_ HV* hash, const char* key, int val)
677             {
678 3           STRLEN klen = strlen(key);
679 3           SV* pval = sv_2mortal(newSVnv(val));
680 3 50         if (hv_store(hash, key, klen, pval, 0)) {
681 3           SvREFCNT_inc(pval);
682             }
683             else {
684 0           croak("Could not create numeric entry %s=%d in hash\n", key, val);
685             }
686 3           }
687              
688 1           static void add_hash_key_str(pTHX_ HV* hash, const char* key, const char* val)
689             {
690 1           STRLEN klen = strlen(key);
691 1           STRLEN vlen = strlen(val);
692 1           SV* pval = sv_2mortal(newSVpv(val, vlen));
693 1 50         if (hv_store(hash, key, klen, pval, 0)) {
694 1           SvREFCNT_inc(pval);
695             }
696             else {
697 0           croak("Could not create string entry %s=[%s] in hash\n", key, val);
698             }
699 1           }
700              
701 1           HV* pl_get_version_info(pTHX)
702             {
703 1           HV* version = newHV();
704              
705 1           long duk_version = DUK_VERSION;
706 1           int patch = duk_version % 100;
707 1           duk_version /= 100;
708 1           int minor = duk_version % 100;
709 1           duk_version /= 100;
710 1           int major = duk_version;
711              
712 1           add_hash_key_int(aTHX_ version, "major" , major);
713 1           add_hash_key_int(aTHX_ version, "minor" , minor);
714 1           add_hash_key_int(aTHX_ version, "patch" , patch);
715              
716             char buf[100];
717 1           sprintf(buf, "%d.%d.%d", major, minor, patch);
718              
719 1           add_hash_key_str(aTHX_ version, "version", buf);
720              
721 1           return version;
722             }