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