1 #include <perl_libyaml.h>
2
3 static SV *
call_coderef(SV * code,AV * args)4 call_coderef(SV *code, AV *args)
5 {
6 dSP;
7 SV **svp;
8 I32 count = (args && args != Nullav) ? av_len(args) : -1;
9 I32 i;
10
11 PUSHMARK(SP);
12 for (i = 0; i <= count; i++) {
13 if ((svp = av_fetch(args, i, FALSE))) {
14 XPUSHs(*svp);
15 }
16 }
17 PUTBACK;
18 count = call_sv(code, G_ARRAY);
19 SPAGAIN;
20
21 return fold_results(count);
22 }
23
24 static SV *
fold_results(I32 count)25 fold_results(I32 count)
26 {
27 dSP;
28 SV *retval = &PL_sv_undef;
29
30 if (count > 1) {
31 /* convert multiple return items into a list reference */
32 AV *av = newAV();
33 SV *last_sv = &PL_sv_undef;
34 SV *sv = &PL_sv_undef;
35 I32 i;
36
37 av_extend(av, count - 1);
38 for(i = 1; i <= count; i++) {
39 last_sv = sv;
40 sv = POPs;
41 if (SvOK(sv) && !av_store(av, count - i, SvREFCNT_inc(sv)))
42 SvREFCNT_dec(sv);
43 }
44 PUTBACK;
45
46 retval = sv_2mortal((SV *) newRV_noinc((SV *) av));
47
48 if (!SvOK(sv) || sv == &PL_sv_undef) {
49 /* if first element was undef, die */
50 croak("%sCall error", ERRMSG);
51 }
52 return retval;
53
54 }
55 else {
56 if (count)
57 retval = POPs;
58 PUTBACK;
59 return retval;
60 }
61 }
62
63 static SV *
find_coderef(char * perl_var)64 find_coderef(char *perl_var)
65 {
66 SV *coderef;
67
68 if ((coderef = get_sv(perl_var, FALSE))
69 && SvROK(coderef)
70 && SvTYPE(SvRV(coderef)) == SVt_PVCV)
71 return coderef;
72
73 return NULL;
74 }
75
76 /*
77 * Piece together a parser/loader error message
78 */
79 char *
loader_error_msg(perl_yaml_loader_t * loader,char * problem)80 loader_error_msg(perl_yaml_loader_t *loader, char *problem)
81 {
82 char *msg;
83 if (!problem)
84 problem = (char *)loader->parser.problem;
85 msg = form(
86 LOADERRMSG
87 "%swas found at "
88 "document: %d",
89 (problem ? form("The problem:\n\n %s\n\n", problem) : "A problem "),
90 loader->document
91 );
92 if (
93 loader->parser.problem_mark.line ||
94 loader->parser.problem_mark.column
95 )
96 msg = form("%s, line: %lu, column: %lu\n",
97 msg,
98 (unsigned long)loader->parser.problem_mark.line + 1,
99 (unsigned long)loader->parser.problem_mark.column + 1
100 );
101 else
102 msg = form("%s\n", msg);
103 if (loader->parser.context)
104 msg = form("%s%s at line: %lu, column: %lu\n",
105 msg,
106 loader->parser.context,
107 (unsigned long)loader->parser.context_mark.line + 1,
108 (unsigned long)loader->parser.context_mark.column + 1
109 );
110
111 return msg;
112 }
113
114 /*
115 * This is the main Load function.
116 * It takes a yaml stream and turns it into 0 or more Perl objects.
117 */
118 void
Load(SV * yaml_sv)119 Load(SV *yaml_sv)
120 {
121 dXCPT;
122
123 dXSARGS;
124 perl_yaml_loader_t loader;
125 SV *node;
126 const unsigned char *yaml_str;
127 STRLEN yaml_len;
128
129 GV *gv = gv_fetchpv("YAML::XS::Boolean", FALSE, SVt_PV);
130 char* boolean = "";
131 loader.load_bool_jsonpp = 0;
132 loader.load_bool_boolean = 0;
133 if (SvTRUE(GvSV(gv))) {
134 boolean = SvPV_nolen(GvSV(gv));
135 if (strEQ(boolean, "JSON::PP")) {
136 loader.load_bool_jsonpp = 1;
137 load_module(PERL_LOADMOD_NOIMPORT, newSVpv("JSON::PP", 0), Nullsv);
138 }
139 else if (strEQ(boolean, "boolean")) {
140 loader.load_bool_boolean = 1;
141 load_module(PERL_LOADMOD_NOIMPORT, newSVpv("boolean", 0), Nullsv);
142 }
143 else {
144 croak("%s",
145 "$YAML::XS::Boolean only accepts 'JSON::PP', 'boolean' or a false value");
146 }
147 }
148
149 loader.load_code = (
150 ((gv = gv_fetchpv("YAML::XS::UseCode", TRUE, SVt_PV)) &&
151 SvTRUE(GvSV(gv)))
152 ||
153 ((gv = gv_fetchpv("YAML::XS::LoadCode", TRUE, SVt_PV)) &&
154 SvTRUE(GvSV(gv)))
155 );
156
157 loader.load_blessed = 0;
158 gv = gv_fetchpv("YAML::XS::LoadBlessed", FALSE, SVt_PV);
159 if (SvOK(GvSV(gv))) {
160 if (SvTRUE(GvSV(gv))) {
161 loader.load_blessed = 1;
162 }
163 }
164
165 yaml_str = (const unsigned char *)SvPV_const(yaml_sv, yaml_len);
166
167 if (DO_UTF8(yaml_sv)) {
168 yaml_sv = sv_mortalcopy(yaml_sv);
169 if (!sv_utf8_downgrade(yaml_sv, TRUE))
170 croak("%s", "Wide character in YAML::XS::Load()");
171 yaml_str = (const unsigned char *)SvPV_const(yaml_sv, yaml_len);
172 }
173
174 sp = mark;
175 if (0 && (items || ax)) {} /* XXX Quiet the -Wall warnings for now. */
176
177 yaml_parser_initialize(&loader.parser);
178
179 loader.document = 0;
180 yaml_parser_set_input_string(
181 &loader.parser,
182 yaml_str,
183 yaml_len
184 );
185
186 /* Get the first event. Must be a STREAM_START */
187 if (!yaml_parser_parse(&loader.parser, &loader.event))
188 goto load_error;
189 if (loader.event.type != YAML_STREAM_START_EVENT)
190 croak("%sExpected STREAM_START_EVENT; Got: %d != %d",
191 ERRMSG,
192 loader.event.type,
193 YAML_STREAM_START_EVENT
194 );
195
196 loader.anchors = newHV();
197 sv_2mortal((SV *)loader.anchors);
198
199 XCPT_TRY_START {
200
201 /* Keep calling load_node until end of stream */
202 while (1) {
203 loader.document++;
204 /* We are through with the previous event - delete it! */
205 yaml_event_delete(&loader.event);
206 if (!yaml_parser_parse(&loader.parser, &loader.event))
207 goto load_error;
208 if (loader.event.type == YAML_STREAM_END_EVENT)
209 break;
210 node = load_node(&loader);
211 /* We are through with the previous event - delete it! */
212 yaml_event_delete(&loader.event);
213 hv_clear(loader.anchors);
214 if (! node) break;
215 XPUSHs(sv_2mortal(node));
216 if (!yaml_parser_parse(&loader.parser, &loader.event))
217 goto load_error;
218 if (loader.event.type != YAML_DOCUMENT_END_EVENT)
219 croak("%sExpected DOCUMENT_END_EVENT", ERRMSG);
220 }
221
222 /* Make sure the last event is a STREAM_END */
223 if (loader.event.type != YAML_STREAM_END_EVENT)
224 croak("%sExpected STREAM_END_EVENT; Got: %d != %d",
225 ERRMSG,
226 loader.event.type,
227 YAML_STREAM_END_EVENT
228 );
229
230 } XCPT_TRY_END
231
232 XCPT_CATCH
233 {
234 yaml_parser_delete(&loader.parser);
235 XCPT_RETHROW;
236 }
237
238 yaml_parser_delete(&loader.parser);
239 PUTBACK;
240 return;
241
242 load_error:
243 croak("%s", loader_error_msg(&loader, NULL));
244 }
245
246 /*
247 * This is the main function for dumping any node.
248 */
249 SV *
load_node(perl_yaml_loader_t * loader)250 load_node(perl_yaml_loader_t *loader)
251 {
252 char *tag;
253 SV* return_sv = NULL;
254 /* This uses stack, but avoids (severe!) memory leaks */
255 yaml_event_t uplevel_event;
256
257 uplevel_event = loader->event;
258
259 /* Get the next parser event */
260 if (!yaml_parser_parse(&loader->parser, &loader->event))
261 goto load_error;
262
263 /* These events don't need yaml_event_delete */
264 /* Some kind of error occurred */
265 if (loader->event.type == YAML_NO_EVENT)
266 goto load_error;
267
268 /* Return NULL when we hit the end of a scope */
269 if (loader->event.type == YAML_DOCUMENT_END_EVENT ||
270 loader->event.type == YAML_MAPPING_END_EVENT ||
271 loader->event.type == YAML_SEQUENCE_END_EVENT) {
272 /* restore the uplevel event, so it can be properly deleted */
273 loader->event = uplevel_event;
274 return return_sv;
275 }
276
277 /* The rest all need cleanup */
278 switch (loader->event.type) {
279
280 /* Handle loading a mapping */
281 case YAML_MAPPING_START_EVENT:
282 tag = (char *)loader->event.data.mapping_start.tag;
283
284 /* Handle mapping tagged as a Perl hard reference */
285 if (tag && strEQ(tag, TAG_PERL_REF)) {
286 return_sv = load_scalar_ref(loader);
287 break;
288 }
289
290 /* Handle mapping tagged as a Perl typeglob */
291 if (tag && strEQ(tag, TAG_PERL_GLOB)) {
292 return_sv = load_glob(loader);
293 break;
294 }
295
296 return_sv = load_mapping(loader, NULL);
297 break;
298
299 /* Handle loading a sequence into an array */
300 case YAML_SEQUENCE_START_EVENT:
301 return_sv = load_sequence(loader);
302 break;
303
304 /* Handle loading a scalar */
305 case YAML_SCALAR_EVENT:
306 return_sv = load_scalar(loader);
307 break;
308
309 /* Handle loading an alias node */
310 case YAML_ALIAS_EVENT:
311 return_sv = load_alias(loader);
312 break;
313
314 default:
315 croak("%sInvalid event '%d' at top level", ERRMSG, (int) loader->event.type);
316 }
317
318 yaml_event_delete(&loader->event);
319
320 /* restore the uplevel event, so it can be properly deleted */
321 loader->event = uplevel_event;
322
323 return return_sv;
324
325 load_error:
326 croak("%s", loader_error_msg(loader, NULL));
327 }
328
329 /*
330 * Load a YAML mapping into a Perl hash
331 */
332 SV *
load_mapping(perl_yaml_loader_t * loader,char * tag)333 load_mapping(perl_yaml_loader_t *loader, char *tag)
334 {
335 dXCPT;
336 SV *key_node;
337 SV *value_node;
338 HV *hash = newHV();
339 SV *hash_ref = (SV *)newRV_noinc((SV *)hash);
340 char *anchor = (char *)loader->event.data.mapping_start.anchor;
341
342 if (!tag)
343 tag = (char *)loader->event.data.mapping_start.tag;
344
345 /* Store the anchor label if any */
346 if (anchor)
347 hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(hash_ref), 0);
348
349 XCPT_TRY_START {
350
351 /* Get each key string and value node and put them in the hash */
352 while ((key_node = load_node(loader))) {
353 assert(SvPOK(key_node));
354 value_node = load_node(loader);
355 hv_store_ent(
356 hash, sv_2mortal(key_node), value_node, 0
357 );
358 }
359
360 /* Deal with possibly blessing the hash if the YAML tag has a class */
361 if (tag) {
362 if (strEQ(tag, TAG_PERL_PREFIX "hash")) {
363 }
364 else if (strEQ(tag, YAML_MAP_TAG)) {
365 }
366 else {
367 char *class;
368 char *prefix = TAG_PERL_PREFIX "hash:";
369 if (*tag == '!') {
370 prefix = "!";
371 }
372 else if (strlen(tag) <= strlen(prefix) ||
373 ! strnEQ(tag, prefix, strlen(prefix))
374 ) croak("%s",
375 loader_error_msg(loader, form("bad tag found for hash: '%s'", tag))
376 );
377 if (loader->load_blessed) {
378 class = tag + strlen(prefix);
379 sv_bless(hash_ref, gv_stashpv(class, TRUE));
380 }
381 }
382 }
383
384 } XCPT_TRY_END
385
386 XCPT_CATCH
387 {
388 SvREFCNT_dec(hash_ref);
389 XCPT_RETHROW;
390 }
391
392 return hash_ref;
393 }
394
395 /* Load a YAML sequence into a Perl array */
396 SV *
load_sequence(perl_yaml_loader_t * loader)397 load_sequence(perl_yaml_loader_t *loader)
398 {
399 dXCPT;
400 SV *node;
401 AV *array = newAV();
402 SV *array_ref = (SV *)newRV_noinc((SV *)array);
403 char *anchor = (char *)loader->event.data.sequence_start.anchor;
404 char *tag = (char *)loader->event.data.mapping_start.tag;
405
406 XCPT_TRY_START {
407
408 if (anchor)
409 hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(array_ref), 0);
410 while ((node = load_node(loader))) {
411 av_push(array, node);
412 }
413
414 if (tag) {
415 if (strEQ(tag, TAG_PERL_PREFIX "array")) {
416 }
417 else if (strEQ(tag, YAML_SEQ_TAG)) {
418 }
419 else {
420 char *class;
421 char *prefix = TAG_PERL_PREFIX "array:";
422
423 if (*tag == '!')
424 prefix = "!";
425 else if (strlen(tag) <= strlen(prefix) ||
426 ! strnEQ(tag, prefix, strlen(prefix))
427 ) croak("%s",
428 loader_error_msg(loader, form("bad tag found for array: '%s'", tag))
429 );
430 if (loader->load_blessed) {
431 class = tag + strlen(prefix);
432 sv_bless(array_ref, gv_stashpv(class, TRUE));
433 }
434 }
435 }
436
437 } XCPT_TRY_END
438
439 XCPT_CATCH
440 {
441 SvREFCNT_dec(array_ref);
442 XCPT_RETHROW;
443 }
444
445 return array_ref;
446 }
447
448 /* Load a YAML scalar into a Perl scalar */
449 SV *
load_scalar(perl_yaml_loader_t * loader)450 load_scalar(perl_yaml_loader_t *loader)
451 {
452 SV *scalar;
453 char *string = (char *)loader->event.data.scalar.value;
454 STRLEN length = (STRLEN)loader->event.data.scalar.length;
455 char *anchor = (char *)loader->event.data.scalar.anchor;
456 char *tag = (char *)loader->event.data.scalar.tag;
457 yaml_scalar_style_t style = loader->event.data.scalar.style;
458 if (tag) {
459 if (strEQ(tag, YAML_STR_TAG)) {
460 style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
461 }
462 else if (strEQ(tag, YAML_INT_TAG) || strEQ(tag, YAML_FLOAT_TAG)) {
463 /* TODO check int/float */
464 scalar = newSVpvn(string, length);
465 if ( looks_like_number(scalar) ) {
466 /* numify */
467 SvIV_please(scalar);
468 }
469 else {
470 croak("%s",
471 loader_error_msg(loader, form("Invalid content found for !!int tag: '%s'", tag))
472 );
473 }
474 if (anchor)
475 hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(scalar), 0);
476 return scalar;
477 }
478 else if (
479 strEQ(tag, YAML_NULL_TAG)
480 &&
481 (strEQ(string, "~") || strEQ(string, "null") || strEQ(string, ""))
482 ) {
483 scalar = newSV(0);
484 if (anchor)
485 hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(scalar), 0);
486 return scalar;
487 }
488 else {
489 char *class;
490 char *prefix = TAG_PERL_PREFIX "regexp";
491 if (strnEQ(tag, prefix, strlen(prefix)))
492 return load_regexp(loader);
493 prefix = TAG_PERL_PREFIX "code";
494 if (strnEQ(tag, prefix, strlen(prefix)))
495 return load_code(loader);
496 prefix = TAG_PERL_PREFIX "scalar:";
497 if (*tag == '!')
498 prefix = "!";
499 else if (strlen(tag) <= strlen(prefix) ||
500 ! strnEQ(tag, prefix, strlen(prefix))
501 ) croak("%sbad tag found for scalar: '%s'", ERRMSG, tag);
502 class = tag + strlen(prefix);
503 if (loader->load_blessed)
504 scalar = sv_setref_pvn(newSV(0), class, string, strlen(string));
505 else
506 scalar = newSVpvn(string, length);
507 SvUTF8_on(scalar);
508 if (anchor)
509 hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(scalar), 0);
510 return scalar;
511 }
512 }
513
514 else if (style == YAML_PLAIN_SCALAR_STYLE) {
515 if (strEQ(string, "~") || strEQ(string, "null") || strEQ(string, "")) {
516 scalar = newSV(0);
517 if (anchor)
518 hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(scalar), 0);
519 return scalar;
520 }
521 else if (strEQ(string, "true")) {
522 if (loader->load_bool_jsonpp) {
523 char *name = "JSON::PP::Boolean";
524 scalar = newSV(1);
525 scalar = sv_setref_iv(scalar, name, 1);
526 }
527 else if (loader->load_bool_boolean) {
528 char *name = "boolean";
529 scalar = newSV(1);
530 scalar = sv_setref_iv(scalar, name, 1);
531 }
532 else {
533 scalar = &PL_sv_yes;
534 }
535 if (anchor)
536 hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(scalar), 0);
537 return scalar;
538 }
539 else if (strEQ(string, "false")) {
540 if (loader->load_bool_jsonpp) {
541 char *name = "JSON::PP::Boolean";
542 scalar = newSV(1);
543 scalar = sv_setref_iv(scalar, name, 0);
544 }
545 else if (loader->load_bool_boolean) {
546 char *name = "boolean";
547 scalar = newSV(1);
548 scalar = sv_setref_iv(scalar, name, 0);
549 }
550 else {
551 scalar = &PL_sv_no;
552 }
553 if (anchor)
554 hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(scalar), 0);
555 return scalar;
556 }
557 }
558
559 scalar = newSVpvn(string, length);
560
561 if (style == YAML_PLAIN_SCALAR_STYLE && looks_like_number(scalar) ) {
562 /* numify */
563 SvIV_please(scalar);
564 }
565
566 (void)sv_utf8_decode(scalar);
567 if (anchor)
568 hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(scalar), 0);
569 return scalar;
570 }
571
572 /* Load a scalar marked as a regexp as a Perl regular expression.
573 * This operation is less common and is tricky, so doing it in Perl code for
574 * now.
575 */
576 SV *
load_regexp(perl_yaml_loader_t * loader)577 load_regexp(perl_yaml_loader_t * loader)
578 {
579 dSP;
580 char *string = (char *)loader->event.data.scalar.value;
581 STRLEN length = (STRLEN)loader->event.data.scalar.length;
582 char *anchor = (char *)loader->event.data.scalar.anchor;
583 char *tag = (char *)loader->event.data.scalar.tag;
584 char *prefix = TAG_PERL_PREFIX "regexp:";
585
586 SV *regexp = newSVpvn(string, length);
587 SvUTF8_on(regexp);
588
589 ENTER;
590 SAVETMPS;
591 PUSHMARK(sp);
592 XPUSHs(regexp);
593 PUTBACK;
594 call_pv("YAML::XS::__qr_loader", G_SCALAR);
595 SPAGAIN;
596 regexp = newSVsv(POPs);
597
598 PUTBACK;
599 FREETMPS;
600 LEAVE;
601
602 if (strlen(tag) > strlen(prefix) && strnEQ(tag, prefix, strlen(prefix))) {
603 if (loader->load_blessed) {
604 char *class = tag + strlen(prefix);
605 sv_bless(regexp, gv_stashpv(class, TRUE));
606 }
607 }
608
609 if (anchor)
610 hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(regexp), 0);
611 return regexp;
612 }
613
614 /* Load a scalar marked as code as a Perl code reference.
615 * This operation is less common and is tricky, so doing it in Perl code for
616 * now.
617 */
618 SV*
load_code(perl_yaml_loader_t * loader)619 load_code(perl_yaml_loader_t * loader)
620 {
621 dSP;
622 char *string = (char *)loader->event.data.scalar.value;
623 STRLEN length = (STRLEN)loader->event.data.scalar.length;
624 char *anchor = (char *)loader->event.data.scalar.anchor;
625 char *tag = (char *)loader->event.data.scalar.tag;
626 char *prefix = TAG_PERL_PREFIX "code:";
627
628 if (! loader->load_code) {
629 string = "{}";
630 length = 2;
631 }
632 SV *code = newSVpvn(string, length);
633 SvUTF8_on(code);
634
635
636 ENTER;
637 SAVETMPS;
638 PUSHMARK(sp);
639 XPUSHs(code);
640 PUTBACK;
641 call_pv("YAML::XS::__code_loader", G_SCALAR);
642 SPAGAIN;
643 code = newSVsv(POPs);
644
645 PUTBACK;
646 FREETMPS;
647 LEAVE;
648
649 if (strlen(tag) > strlen(prefix) && strnEQ(tag, prefix, strlen(prefix))) {
650 if (loader->load_blessed) {
651 char *class = tag + strlen(prefix);
652 sv_bless(code, gv_stashpv(class, TRUE));
653 }
654 }
655
656 if (anchor)
657 hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(code), 0);
658 return code;
659 }
660
661
662 /*
663 * Load a reference to a previously loaded node.
664 */
665 SV *
load_alias(perl_yaml_loader_t * loader)666 load_alias(perl_yaml_loader_t *loader)
667 {
668 char *anchor = (char *)loader->event.data.alias.anchor;
669 SV **entry = hv_fetch(loader->anchors, anchor, strlen(anchor), 0);
670 if (entry)
671 return SvREFCNT_inc(*entry);
672 croak("%sNo anchor for alias '%s'", ERRMSG, anchor);
673 }
674
675 /*
676 * Load a Perl hard reference.
677 */
678 SV *
load_scalar_ref(perl_yaml_loader_t * loader)679 load_scalar_ref(perl_yaml_loader_t *loader)
680 {
681 SV *value_node;
682 char *anchor = (char *)loader->event.data.mapping_start.anchor;
683 SV *rv = newRV_noinc(&PL_sv_undef);
684 if (anchor)
685 hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(rv), 0);
686 load_node(loader); /* Load the single hash key (=) */
687 value_node = load_node(loader);
688 SvRV(rv) = value_node;
689 if (load_node(loader))
690 croak("%sExpected end of node", ERRMSG);
691 return rv;
692 }
693
694 /*
695 * Load a Perl typeglob.
696 */
697 SV *
load_glob(perl_yaml_loader_t * loader)698 load_glob(perl_yaml_loader_t *loader)
699 {
700 /* XXX Call back a Perl sub to do something interesting here */
701 return load_mapping(loader, TAG_PERL_PREFIX "hash");
702 }
703
704 /* -------------------------------------------------------------------------- */
705
706 /*
707 * Set dumper options from global variables.
708 */
709 void
set_dumper_options(perl_yaml_dumper_t * dumper)710 set_dumper_options(perl_yaml_dumper_t *dumper)
711 {
712 GV *gv;
713 char* boolean = "";
714 dumper->dump_code = (
715 ((gv = gv_fetchpv("YAML::XS::UseCode", TRUE, SVt_PV)) &&
716 SvTRUE(GvSV(gv)))
717 ||
718 ((gv = gv_fetchpv("YAML::XS::DumpCode", TRUE, SVt_PV)) &&
719 SvTRUE(GvSV(gv)))
720 );
721
722 dumper->quote_number_strings = (
723 ((gv = gv_fetchpv("YAML::XS::QuoteNumericStrings", TRUE, SVt_PV)) &&
724 SvTRUE(GvSV(gv)))
725 );
726
727 gv = gv_fetchpv("YAML::XS::Boolean", FALSE, SVt_PV);
728 dumper->dump_bool_jsonpp = 0;
729 dumper->dump_bool_boolean = 0;
730 if (SvTRUE(GvSV(gv))) {
731 boolean = SvPV_nolen(GvSV(gv));
732 if (strEQ(boolean, "JSON::PP")) {
733 dumper->dump_bool_jsonpp = 1;
734 load_module(PERL_LOADMOD_NOIMPORT, newSVpv("JSON::PP", 0), Nullsv);
735 }
736 else if (strEQ(boolean, "boolean")) {
737 dumper->dump_bool_boolean = 1;
738 load_module(PERL_LOADMOD_NOIMPORT, newSVpv("boolean", 0), Nullsv);
739 }
740 else {
741 croak("%s",
742 "$YAML::XS::Boolean only accepts 'JSON::PP', 'boolean' or a false value");
743 }
744 }
745
746 /* dumper->emitter.open_ended = 1;
747 */
748 }
749
750 /*
751 * This is the main Dump function.
752 * Take zero or more Perl objects and return a YAML stream (as a string)
753 */
754 void
Dump(SV * dummy,...)755 Dump(SV *dummy, ...)
756 {
757 dXSARGS;
758 perl_yaml_dumper_t dumper;
759 yaml_event_t event_stream_start;
760 yaml_event_t event_stream_end;
761 int i;
762 SV *yaml = sv_2mortal(newSVpvn("", 0));
763 sp = mark;
764
765 set_dumper_options(&dumper);
766
767 /* Set up the emitter object and begin emitting */
768 yaml_emitter_initialize(&dumper.emitter);
769
770 /* set indent */
771 SV* indent = get_sv("YAML::XS::Indent", GV_ADD);
772 if (SvIOK(indent)) yaml_emitter_set_indent(&dumper.emitter, SvIV(indent));
773
774 yaml_emitter_set_unicode(&dumper.emitter, 1);
775 yaml_emitter_set_width(&dumper.emitter, 2);
776 yaml_emitter_set_output(
777 &dumper.emitter,
778 &append_output,
779 (void *) yaml
780 );
781 yaml_stream_start_event_initialize(
782 &event_stream_start,
783 YAML_UTF8_ENCODING
784 );
785 yaml_emitter_emit(&dumper.emitter, &event_stream_start);
786
787 dumper.anchors = newHV();
788 dumper.shadows = newHV();
789
790 sv_2mortal((SV *)dumper.anchors);
791 sv_2mortal((SV *)dumper.shadows);
792
793 for (i = 0; i < items; i++) {
794 dumper.anchor = 0;
795
796 dump_prewalk(&dumper, ST(i));
797 dump_document(&dumper, ST(i));
798
799 hv_clear(dumper.anchors);
800 hv_clear(dumper.shadows);
801 }
802
803 /* End emitting and destroy the emitter object */
804 yaml_stream_end_event_initialize(&event_stream_end);
805 yaml_emitter_emit(&dumper.emitter, &event_stream_end);
806 yaml_emitter_delete(&dumper.emitter);
807
808 /* Put the YAML stream scalar on the XS output stack */
809 if (yaml) {
810 SvUTF8_off(yaml);
811 XPUSHs(yaml);
812 }
813 PUTBACK;
814 }
815
816 /*
817 * In order to know which nodes will need anchors (for later aliasing) it is
818 * necessary to walk the entire data structure first. Once a node has been
819 * seen twice you can stop walking it. That way we can handle circular refs.
820 * All the node information is stored in an HV.
821 */
822 void
dump_prewalk(perl_yaml_dumper_t * dumper,SV * node)823 dump_prewalk(perl_yaml_dumper_t *dumper, SV *node)
824 {
825 int i, len;
826 U32 ref_type;
827 SvGETMAGIC(node);
828
829 if (! (SvROK(node) || SvTYPE(node) == SVt_PVGV)) return;
830
831 {
832 SV *object = SvROK(node) ? SvRV(node) : node;
833 SV **seen =
834 hv_fetch(dumper->anchors, (char *)&object, sizeof(object), 0);
835 if (seen) {
836 if (*seen == &PL_sv_undef) {
837 hv_store(
838 dumper->anchors, (char *)&object, sizeof(object),
839 &PL_sv_yes, 0
840 );
841 }
842 return;
843 }
844 hv_store(
845 dumper->anchors, (char *)&object, sizeof(object), &PL_sv_undef, 0
846 );
847 }
848
849 if (SvTYPE(node) == SVt_PVGV) {
850 node = dump_glob(dumper, node);
851 }
852
853 ref_type = SvTYPE(SvRV(node));
854 if (ref_type == SVt_PVAV) {
855 AV *array = (AV *)SvRV(node);
856 int array_size = av_len(array) + 1;
857 for (i = 0; i < array_size; i++) {
858 SV **entry = av_fetch(array, i, 0);
859 if (entry)
860 dump_prewalk(dumper, *entry);
861 }
862 }
863 else if (ref_type == SVt_PVHV) {
864 HV *hash = (HV *)SvRV(node);
865 HE *he;
866 SV *key;
867 SV *val;
868 hv_iterinit(hash);
869
870 while ((he = hv_iternext(hash))) {
871 key = hv_iterkeysv(he);
872 he = hv_fetch_ent(hash, key, 0, 0);
873 val = he ? HeVAL(he) : NULL;
874 if (val) {
875 dump_prewalk(dumper, val);
876 }
877 }
878 }
879 else if (ref_type <= SVt_PVNV || ref_type == SVt_PVGV) {
880 SV *scalar = SvRV(node);
881 dump_prewalk(dumper, scalar);
882 }
883 }
884
885 void
dump_document(perl_yaml_dumper_t * dumper,SV * node)886 dump_document(perl_yaml_dumper_t *dumper, SV *node)
887 {
888 yaml_event_t event_document_start;
889 yaml_event_t event_document_end;
890 yaml_document_start_event_initialize(
891 &event_document_start, NULL, NULL, NULL, 0
892 );
893 yaml_emitter_emit(&dumper->emitter, &event_document_start);
894 dump_node(dumper, node);
895 yaml_document_end_event_initialize(&event_document_end, 1);
896 yaml_emitter_emit(&dumper->emitter, &event_document_end);
897 }
898
899 void
dump_node(perl_yaml_dumper_t * dumper,SV * node)900 dump_node(perl_yaml_dumper_t *dumper, SV *node)
901 {
902 yaml_char_t *anchor = NULL;
903 yaml_char_t *tag = NULL;
904 const char *class = NULL;
905
906 SvGETMAGIC(node);
907 if (SvTYPE(node) == SVt_PVGV) {
908 SV **svr;
909 tag = (yaml_char_t *)TAG_PERL_PREFIX "glob";
910 anchor = get_yaml_anchor(dumper, node);
911 if (anchor && strEQ((char *)anchor, "")) return;
912 svr = hv_fetch(dumper->shadows, (char *)&node, sizeof(node), 0);
913 if (svr) {
914 node = SvREFCNT_inc(*svr);
915 }
916 }
917
918 if (SvROK(node)) {
919 SV *rnode = SvRV(node);
920 U32 ref_type = SvTYPE(rnode);
921 if (ref_type == SVt_PVHV)
922 dump_hash(dumper, node, anchor, tag);
923 else if (ref_type == SVt_PVAV)
924 dump_array(dumper, node);
925 else if (ref_type <= SVt_PVNV || ref_type == SVt_PVGV)
926 dump_ref(dumper, node);
927 else if (ref_type == SVt_PVCV)
928 dump_code(dumper, node);
929 else if (ref_type == SVt_PVMG) {
930 MAGIC *mg;
931 yaml_char_t *tag = NULL;
932 if (SvMAGICAL(rnode)) {
933 if ((mg = mg_find(rnode, PERL_MAGIC_qr))) {
934 tag = (yaml_char_t *)form(TAG_PERL_PREFIX "regexp");
935 class = sv_reftype(rnode, TRUE);
936 if (!strEQ(class, "Regexp"))
937 tag = (yaml_char_t *)form("%s:%s", tag, class);
938 }
939 dump_scalar(dumper, node, tag);
940 }
941 else {
942 class = sv_reftype(rnode, TRUE);
943 if (
944 dumper->dump_bool_jsonpp
945 && strEQ(class, "JSON::PP::Boolean")
946 ||
947 dumper->dump_bool_boolean
948 && strEQ(class, "boolean")
949 ) {
950 if (SvIV(node)) {
951 dump_scalar(dumper, &PL_sv_yes, NULL);
952 }
953 else {
954 dump_scalar(dumper, &PL_sv_no, NULL);
955 }
956 }
957 else {
958 tag = (yaml_char_t *)form(
959 TAG_PERL_PREFIX "scalar:%s",
960 class
961 );
962 node = rnode;
963 dump_scalar(dumper, node, tag);
964 }
965 }
966 }
967 #if PERL_REVISION > 5 || (PERL_REVISION == 5 && PERL_VERSION >= 11)
968 else if (ref_type == SVt_REGEXP) {
969 yaml_char_t *tag = (yaml_char_t *)form(TAG_PERL_PREFIX "regexp");
970 class = sv_reftype(rnode, TRUE);
971 if (!strEQ(class, "Regexp"))
972 tag = (yaml_char_t *)form("%s:%s", tag, class);
973 dump_scalar(dumper, node, tag);
974 }
975 #endif
976 else {
977 printf(
978 "YAML::XS dump unhandled ref. type == '%d'!\n",
979 (int)ref_type
980 );
981 dump_scalar(dumper, rnode, NULL);
982 }
983 }
984 else {
985 dump_scalar(dumper, node, NULL);
986 }
987 }
988
989 yaml_char_t *
get_yaml_anchor(perl_yaml_dumper_t * dumper,SV * node)990 get_yaml_anchor(perl_yaml_dumper_t *dumper, SV *node)
991 {
992 yaml_event_t event_alias;
993 SV *iv;
994 SV **seen = hv_fetch(dumper->anchors, (char *)&node, sizeof(node), 0);
995 if (seen && *seen != &PL_sv_undef) {
996 if (*seen == &PL_sv_yes) {
997 dumper->anchor++;
998 iv = newSViv(dumper->anchor);
999 hv_store(dumper->anchors, (char *)&node, sizeof(node), iv, 0);
1000 return (yaml_char_t*)SvPV_nolen(iv);
1001 }
1002 else {
1003 yaml_char_t *anchor = (yaml_char_t *)SvPV_nolen(*seen);
1004 yaml_alias_event_initialize(&event_alias, anchor);
1005 yaml_emitter_emit(&dumper->emitter, &event_alias);
1006 return (yaml_char_t *) "";
1007 }
1008 }
1009 return NULL;
1010 }
1011
1012 yaml_char_t *
get_yaml_tag(SV * node)1013 get_yaml_tag(SV *node)
1014 {
1015 yaml_char_t *tag;
1016 const char *class;
1017 const char *kind = "";
1018 if (! (
1019 sv_isobject(node) ||
1020 (SvRV(node) && ( SvTYPE(SvRV(node)) == SVt_PVCV))
1021 )) return NULL;
1022 class = sv_reftype(SvRV(node), TRUE);
1023
1024 switch (SvTYPE(SvRV(node))) {
1025 case SVt_PVAV: { kind = "array"; break; }
1026 case SVt_PVHV: { kind = "hash"; break; }
1027 case SVt_PVCV: { kind = "code"; break; }
1028 }
1029 if ((strlen(kind) == 0))
1030 tag = (yaml_char_t *)form("%s%s", TAG_PERL_PREFIX, class);
1031 else if (SvTYPE(SvRV(node)) == SVt_PVCV && strEQ(class, "CODE"))
1032 tag = (yaml_char_t *)form("%s%s", TAG_PERL_PREFIX, kind);
1033 else
1034 tag = (yaml_char_t *)form("%s%s:%s", TAG_PERL_PREFIX, kind, class);
1035 return tag;
1036 }
1037
1038 void
dump_hash(perl_yaml_dumper_t * dumper,SV * node,yaml_char_t * anchor,yaml_char_t * tag)1039 dump_hash(
1040 perl_yaml_dumper_t *dumper, SV *node,
1041 yaml_char_t *anchor, yaml_char_t *tag)
1042 {
1043 yaml_event_t event_mapping_start;
1044 yaml_event_t event_mapping_end;
1045 int i;
1046 int len;
1047 AV *av;
1048 HV *hash = (HV *)SvRV(node);
1049 HE *he;
1050
1051 if (!anchor)
1052 anchor = get_yaml_anchor(dumper, (SV *)hash);
1053 if (anchor && strEQ((char*)anchor, "")) return;
1054
1055 if (!tag)
1056 tag = get_yaml_tag(node);
1057
1058 yaml_mapping_start_event_initialize(
1059 &event_mapping_start, anchor, tag, 0, YAML_BLOCK_MAPPING_STYLE
1060 );
1061 yaml_emitter_emit(&dumper->emitter, &event_mapping_start);
1062
1063 av = newAV();
1064 len = 0;
1065 hv_iterinit(hash);
1066 while ((he = hv_iternext(hash))) {
1067 SV *key = hv_iterkeysv(he);
1068 av_store(av, AvFILLp(av)+1, key); /* av_push(), really */
1069 len++;
1070 }
1071 STORE_HASH_SORT;
1072 for (i = 0; i < len; i++) {
1073 SV *key = av_shift(av);
1074 HE *he = hv_fetch_ent(hash, key, 0, 0);
1075 SV *val = he ? HeVAL(he) : NULL;
1076 if (val == NULL) { val = &PL_sv_undef; }
1077 dump_node(dumper, key);
1078 dump_node(dumper, val);
1079 }
1080
1081 SvREFCNT_dec(av);
1082
1083 yaml_mapping_end_event_initialize(&event_mapping_end);
1084 yaml_emitter_emit(&dumper->emitter, &event_mapping_end);
1085 }
1086
1087 void
dump_array(perl_yaml_dumper_t * dumper,SV * node)1088 dump_array(perl_yaml_dumper_t *dumper, SV *node)
1089 {
1090 yaml_event_t event_sequence_start;
1091 yaml_event_t event_sequence_end;
1092 int i;
1093 yaml_char_t *tag;
1094 AV *array = (AV *)SvRV(node);
1095 int array_size = av_len(array) + 1;
1096
1097 yaml_char_t *anchor = get_yaml_anchor(dumper, (SV *)array);
1098 if (anchor && strEQ((char *)anchor, "")) return;
1099 tag = get_yaml_tag(node);
1100
1101 yaml_sequence_start_event_initialize(
1102 &event_sequence_start, anchor, tag, 0, YAML_BLOCK_SEQUENCE_STYLE
1103 );
1104
1105 yaml_emitter_emit(&dumper->emitter, &event_sequence_start);
1106 for (i = 0; i < array_size; i++) {
1107 SV **entry = av_fetch(array, i, 0);
1108 if (entry == NULL)
1109 dump_node(dumper, &PL_sv_undef);
1110 else
1111 dump_node(dumper, *entry);
1112 }
1113 yaml_sequence_end_event_initialize(&event_sequence_end);
1114 yaml_emitter_emit(&dumper->emitter, &event_sequence_end);
1115 }
1116
1117 void
dump_scalar(perl_yaml_dumper_t * dumper,SV * node,yaml_char_t * tag)1118 dump_scalar(perl_yaml_dumper_t *dumper, SV *node, yaml_char_t *tag)
1119 {
1120 yaml_event_t event_scalar;
1121 char *string;
1122 STRLEN string_len;
1123 int plain_implicit, quoted_implicit;
1124 yaml_scalar_style_t style = YAML_PLAIN_SCALAR_STYLE;
1125
1126 if (tag) {
1127 plain_implicit = quoted_implicit = 0;
1128 }
1129 else {
1130 tag = (yaml_char_t *)TAG_PERL_STR;
1131 plain_implicit = quoted_implicit = 1;
1132 }
1133
1134 SvGETMAGIC(node);
1135 if (!SvOK(node)) {
1136 string = "~";
1137 string_len = 1;
1138 style = YAML_PLAIN_SCALAR_STYLE;
1139 }
1140 else if (node == &PL_sv_yes) {
1141 string = "true";
1142 string_len = 4;
1143 style = YAML_PLAIN_SCALAR_STYLE;
1144 }
1145 else if (node == &PL_sv_no) {
1146 string = "false";
1147 string_len = 5;
1148 style = YAML_PLAIN_SCALAR_STYLE;
1149 }
1150 else {
1151 SV *node_clone = sv_mortalcopy(node);
1152 string = SvPV_nomg(node_clone, string_len);
1153 if (
1154 (string_len == 0) ||
1155 (string_len == 1 && strEQ(string, "~")) ||
1156 (string_len == 4 && strEQ(string, "true")) ||
1157 (string_len == 5 && strEQ(string, "false")) ||
1158 (string_len == 4 && strEQ(string, "null")) ||
1159 (SvTYPE(node_clone) >= SVt_PVGV) ||
1160 ( dumper->quote_number_strings && !SvNIOK(node_clone) && looks_like_number(node_clone) )
1161 ) {
1162 style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
1163 } else {
1164 if (!SvUTF8(node_clone)) {
1165 /* copy to new SV and promote to utf8 */
1166 SV *utf8sv = sv_mortalcopy(node_clone);
1167
1168 /* get string and length out of utf8 */
1169 string = SvPVutf8(utf8sv, string_len);
1170 }
1171 if(strchr(string, '\n'))
1172 style = (string_len > 30) ? YAML_LITERAL_SCALAR_STYLE : YAML_DOUBLE_QUOTED_SCALAR_STYLE;
1173 }
1174 }
1175 if (! yaml_scalar_event_initialize(
1176 &event_scalar,
1177 NULL,
1178 tag,
1179 (unsigned char *) string,
1180 (int) string_len,
1181 plain_implicit,
1182 quoted_implicit,
1183 style
1184 )) {
1185 croak("Could not initialize scalar event\n");
1186 }
1187 if (! yaml_emitter_emit(&dumper->emitter, &event_scalar))
1188 croak("%sEmit scalar '%s', error: %s\n",
1189 ERRMSG,
1190 string, dumper->emitter.problem
1191 );
1192 }
1193
1194 void
dump_code(perl_yaml_dumper_t * dumper,SV * node)1195 dump_code(perl_yaml_dumper_t *dumper, SV *node)
1196 {
1197 yaml_event_t event_scalar;
1198 yaml_char_t *tag;
1199 yaml_scalar_style_t style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
1200 char *string = "{ \"DUMMY\" }";
1201 if (dumper->dump_code) {
1202 /* load_module(PERL_LOADMOD_NOIMPORT, newSVpv("B::Deparse", 0), NULL);
1203 */
1204 SV *result;
1205 SV *code = find_coderef("YAML::XS::coderef2text");
1206 AV *args = newAV();
1207 av_push(args, SvREFCNT_inc(node));
1208 args = (AV *)sv_2mortal((SV *)args);
1209 result = call_coderef(code, args);
1210 if (result && result != &PL_sv_undef) {
1211 string = SvPV_nolen(result);
1212 style = YAML_LITERAL_SCALAR_STYLE;
1213 }
1214 }
1215 tag = get_yaml_tag(node);
1216
1217 yaml_scalar_event_initialize(
1218 &event_scalar,
1219 NULL,
1220 tag,
1221 (unsigned char *)string,
1222 strlen(string),
1223 0,
1224 0,
1225 style
1226 );
1227
1228 yaml_emitter_emit(&dumper->emitter, &event_scalar);
1229 }
1230
1231 SV *
dump_glob(perl_yaml_dumper_t * dumper,SV * node)1232 dump_glob(perl_yaml_dumper_t *dumper, SV *node)
1233 {
1234 SV *result;
1235 SV *code = find_coderef("YAML::XS::glob2hash");
1236 AV *args = newAV();
1237 av_push(args, SvREFCNT_inc(node));
1238 args = (AV *)sv_2mortal((SV *)args);
1239 result = call_coderef(code, args);
1240 hv_store(
1241 dumper->shadows, (char *)&node, sizeof(node),
1242 result, 0
1243 );
1244 return result;
1245 }
1246
1247 /* XXX Refo this to just dump a special map */
1248 void
dump_ref(perl_yaml_dumper_t * dumper,SV * node)1249 dump_ref(perl_yaml_dumper_t *dumper, SV *node)
1250 {
1251 yaml_event_t event_mapping_start;
1252 yaml_event_t event_mapping_end;
1253 yaml_event_t event_scalar;
1254 SV *referent = SvRV(node);
1255
1256 yaml_char_t *anchor = get_yaml_anchor(dumper, referent);
1257 if (anchor && strEQ((char *)anchor, "")) return;
1258
1259 yaml_mapping_start_event_initialize(
1260 &event_mapping_start, anchor,
1261 (unsigned char *)TAG_PERL_PREFIX "ref",
1262 0, YAML_BLOCK_MAPPING_STYLE
1263 );
1264 yaml_emitter_emit(&dumper->emitter, &event_mapping_start);
1265
1266 yaml_scalar_event_initialize(
1267 &event_scalar,
1268 NULL, NULL,
1269 (unsigned char *)"=", 1,
1270 1, 1,
1271 YAML_PLAIN_SCALAR_STYLE
1272 );
1273 yaml_emitter_emit(&dumper->emitter, &event_scalar);
1274 dump_node(dumper, referent);
1275
1276 yaml_mapping_end_event_initialize(&event_mapping_end);
1277 yaml_emitter_emit(&dumper->emitter, &event_mapping_end);
1278 }
1279
1280 int
append_output(void * yaml,unsigned char * buffer,size_t size)1281 append_output(void *yaml, unsigned char *buffer, size_t size)
1282 {
1283 sv_catpvn((SV *)yaml, (const char *)buffer, (STRLEN)size);
1284 return 1;
1285 }
1286
1287 /* XXX Make -Wall not complain about 'local_patches' not being used. */
1288 #if !defined(PERL_PATCHLEVEL_H_IMPLICIT)
xxx_local_patches()1289 void xxx_local_patches() {
1290 printf("%s", local_patches[0]);
1291 }
1292 #endif
1293