File Coverage

perl_libyaml.c
Criterion Covered Total %
statement 709 831 85.3
branch 450 770 58.4
condition n/a
subroutine n/a
pod n/a
total 1159 1601 72.3


line stmt bran cond sub pod time code
1             #include "perl_libyaml.h"
2              
3             static SV *
4             load_node(YAML *self);
5             static SV *
6             load_mapping(YAML *self, char *tag);
7             static SV *
8             load_sequence(YAML *);
9             static SV *
10             load_scalar(YAML *);
11             static SV *
12             load_alias(YAML *);
13             static SV *
14             load_scalar_ref(YAML *);
15             static SV *
16             load_regexp(YAML *);
17             static SV *
18             load_glob(YAML *);
19             static SV *
20             load_code(YAML *);
21             static void
22             dump_prewalk(YAML *, SV *);
23             static void
24             dump_document(YAML *, SV *);
25             static void
26             dump_node(YAML *, SV *);
27             static void
28             dump_hash(YAML *, SV *, yaml_char_t *, yaml_char_t *);
29             static void
30             dump_array(YAML *, SV *);
31             static void
32             dump_scalar(YAML *, SV *, yaml_char_t *);
33             static void
34             dump_ref(YAML *, SV *);
35             static void
36             dump_code(YAML *, SV *);
37             static SV*
38             dump_glob(YAML *, SV *);
39             static yaml_char_t *
40             get_yaml_anchor(YAML *, SV *);
41             static yaml_char_t *
42             get_yaml_tag(SV *);
43             static int
44             yaml_sv_write_handler(void *sv, unsigned char *buffer, size_t size);
45             static int
46             yaml_perlio_read_handler(void *data, unsigned char *buffer, size_t size, size_t *size_read);
47             static int
48             yaml_perlio_write_handler(void *data, unsigned char *buffer, size_t size);
49              
50             /* can honor lexical warnings and $^W */
51             #if PERL_VERSION > 11
52             #define Perl_warner Perl_ck_warner
53             #endif
54              
55             #if 0
56             static const char* options[] =
57             {
58             /* Both */
59             "boolean", /* "JSON::PP", "boolean" or 0 */
60             "disableblessed", /* bool, default: 0 */
61             "enablecode", /* bool, default: 0 */
62             /* Loader */
63             "nonstrict", /* bool, default: 0 */
64             "loadcode", /* bool, default: 0 */
65             /* Dumper */
66             "dumpcode", /* bool, default: 0 */
67             "noindentmap", /* bool, default: 0 */
68             "indent", /* int, default: 2 */
69             "wrapwidth", /* int, default: 80 */
70             "canonical", /* bool, default: 0 */
71             "quotenum", /* bool, default: 1 */
72             "unicode", /* bool, default: 1 If unescaped Unicode characters are allowed */
73             "encoding", /* "any", "utf8", "utf16le" or "utf16be" */
74             "linebreak", /* "any", "cr", "ln" or "crln" */
75             "openended", /* bool, default: 0 */
76             };
77             static int numoptions = sizeof(options)/sizeof(options[0]);
78              
79             #endif
80              
81             static SV *
82 4           fold_results(I32 count)
83             {
84 4           dSP;
85 4           SV *retval = &PL_sv_undef;
86              
87 4 50         if (count > 1) {
88             /* convert multiple return items into a list reference */
89 0           AV *av = newAV();
90 0           SV *sv = &PL_sv_undef;
91             I32 i;
92              
93 0           av_extend(av, count - 1);
94 0 0         for(i = 1; i <= count; i++) {
95 0           sv = POPs;
96 0 0         if (SvOK(sv) && !av_store(av, count - i, SvREFCNT_inc(sv)))
    0          
    0          
    0          
97 0           SvREFCNT_dec(sv);
98             }
99 0           PUTBACK;
100              
101 0           retval = sv_2mortal((SV *) newRV_noinc((SV *) av));
102              
103 0 0         if (!SvOK(sv) || sv == &PL_sv_undef) {
    0          
    0          
    0          
104             /* if first element was undef, die */
105 0           croak("%sCall error", ERRMSG);
106             }
107 0           return retval;
108              
109             }
110             else {
111 4 50         if (count)
112 4           retval = POPs;
113 4           PUTBACK;
114 4           return retval;
115             }
116             }
117              
118             static SV *
119 4           call_coderef(SV *code, AV *args)
120             {
121 4           dSP;
122             SV **svp;
123 4 50         I32 count = args ? av_len(args) : -1;
124             I32 i;
125              
126 4 50         PUSHMARK(SP);
127 8 100         for (i = 0; i <= count; i++) {
128 4 50         if ((svp = av_fetch(args, i, FALSE))) {
129 4 50         XPUSHs(*svp);
130             }
131             }
132 4           PUTBACK;
133 4           count = call_sv(code, G_ARRAY);
134 4           SPAGAIN;
135              
136 4           return fold_results(count);
137             }
138              
139             static SV *
140 4           find_coderef(const char *perl_var)
141             {
142             SV *coderef;
143              
144 4 50         if ((coderef = get_sv(perl_var, FALSE))
145 4 50         && SvROK(coderef)
146 4 50         && SvTYPE(SvRV(coderef)) == SVt_PVCV)
147 4           return coderef;
148              
149 0           return NULL;
150             }
151              
152             /*
153             * Piece together a parser/loader error message
154             */
155             static char *
156 8           loader_error_msg(YAML *self, char *problem)
157             {
158             char *msg;
159 8 100         if (!problem)
160 6           problem = (char *)self->parser.problem;
161 8 50         if (self->filename)
162 0 0         msg = form("%s%s at file %s",
163             ERRMSG, (problem ? problem : "A problem"), self->filename);
164             else
165 8 50         msg = form("%s%s at document %d",
166             ERRMSG, (problem ? problem : "A problem"), self->document);
167 8 100         if (self->parser.problem_mark.line ||
    100          
168 4           self->parser.problem_mark.column)
169 5           msg = form("%s, line: %ld, column: %ld\n",
170             msg,
171 5           (long)self->parser.problem_mark.line + 1,
172 5           (long)self->parser.problem_mark.column + 1);
173 3 100         else if (self->parser.problem_offset)
174 1           msg = form("%s, offset: %ld\n", msg, (long)self->parser.problem_offset);
175             else
176 2           msg = form("%s\n", msg);
177 8 100         if (self->parser.context)
178 4           msg = form("%s%s at line: %ld, column: %ld\n",
179             msg,
180             self->parser.context,
181 4           (long)self->parser.context_mark.line + 1,
182 4           (long)self->parser.context_mark.column + 1);
183              
184 8           return msg;
185             }
186              
187             /*
188             * Set loader options from YAML* object.
189             */
190             void
191 109           set_parser_options(YAML *self, yaml_parser_t *parser)
192             {
193 109           self->document = 0;
194 109           self->filename = NULL;
195 109           self->parser.read_handler = NULL; /* we allow setting it mult. times */
196              
197 109 50         if ((int)self->encoding)
198 0           yaml_parser_set_encoding(parser, self->encoding);
199              
200             /* As with YAML::Tiny. Default: strict Load */
201             /* allow while parsing a quoted scalar found unknown escape character */
202 109           parser->problem_nonstrict = self->flags & F_NONSTRICT;
203 109           }
204              
205             /*
206             * Set dumper options from YAML* object
207             */
208             void
209 87           set_emitter_options(YAML *self, yaml_emitter_t *emitter)
210             {
211 87           yaml_emitter_set_unicode(emitter, self->flags & F_UNICODE);
212 87           yaml_emitter_set_indent(emitter, self->indent);
213 87           yaml_emitter_set_width(emitter, self->wrapwidth);
214 87 50         if ((int)self->encoding)
215 0           yaml_emitter_set_encoding(emitter, self->encoding);
216 87 50         if ((int)self->linebreak)
217 0           yaml_emitter_set_break(emitter, self->linebreak);
218 87           emitter->indentless_map = self->flags & F_NOINDENTMAP;
219 87           emitter->open_ended = self->flags & F_OPENENDED;
220 87           yaml_emitter_set_canonical(emitter, self->flags & F_CANONICAL);
221 87           }
222              
223             static int
224 116           load_impl(YAML *self)
225             {
226 109           dXCPT;
227 109           dXSARGS; /* does POPMARK */
228             SV *node;
229              
230 109           sp = mark;
231             if (0 && (items || ax)) {} /* XXX Quiet the -Wall warnings for now. */
232              
233             /* Get the first event. Must be a STREAM_START */
234 109 100         if (!yaml_parser_parse(&self->parser, &self->event))
235 1           goto load_error;
236 108 50         if (self->event.type != YAML_STREAM_START_EVENT)
237 0           croak("%sExpected STREAM_START_EVENT; Got: %d != %d",
238 0           ERRMSG, self->event.type, YAML_STREAM_START_EVENT);
239              
240 108           self->anchors = (HV *)sv_2mortal((SV *)newHV());
241              
242 115 100         XCPT_TRY_START {
243              
244             /* Keep calling load_node until end of stream */
245             while (1) {
246 214           self->document++;
247             /* We are through with the previous event - delete it! */
248 214           yaml_event_delete(&self->event);
249 214 100         if (!yaml_parser_parse(&self->parser, &self->event))
250 1           goto load_error;
251 213 100         if (self->event.type == YAML_STREAM_END_EVENT)
252 101           break;
253 112           node = load_node(self);
254             /* We are through with the previous event - delete it! */
255 106           yaml_event_delete(&self->event);
256 106           hv_clear(self->anchors);
257 106 50         if (! node) break;
258 106 50         XPUSHs(sv_2mortal(node));
259 106 50         if (!yaml_parser_parse(&self->parser, &self->event))
260 0           goto load_error;
261 106 50         if (self->event.type != YAML_DOCUMENT_END_EVENT)
262 0           croak("%sExpected DOCUMENT_END_EVENT", ERRMSG);
263 106           }
264              
265             /* Make sure the last event is a STREAM_END */
266 101 50         if (self->event.type != YAML_STREAM_END_EVENT)
267 0           croak("%sExpected STREAM_END_EVENT; Got: %d != %d",
268 0           ERRMSG, self->event.type, YAML_STREAM_END_EVENT);
269              
270 108           } XCPT_TRY_END
271              
272 108 100         XCPT_CATCH
273             {
274 7           yaml_parser_delete(&self->parser);
275 7 50         XCPT_RETHROW;
    0          
276             }
277              
278 101           yaml_parser_delete(&self->parser);
279 101           PUTBACK;
280 101           return 1;
281              
282             load_error:
283 2           croak("%s", loader_error_msg(self, NULL));
284             return 0;
285             }
286              
287             /*
288             * It takes a file or filename and turns it into 0 or more Perl objects.
289             */
290             int
291 5           LoadFile(YAML *self, SV *sv_file)
292             {
293 5           FILE *file = NULL;
294             const char *fname;
295             STRLEN len;
296             int ret;
297              
298 5           yaml_parser_initialize(&self->parser);
299 5           set_parser_options(self, &self->parser);
300 5 100         if (SvROK(sv_file)) { /* pv mg or io or gv */
301 2           SV *rv = SvRV(sv_file);
302              
303 2 50         if (SvTYPE(rv) == SVt_PVIO) {
304 0           self->perlio = IoIFP(rv);
305 0           yaml_parser_set_input(&self->parser,
306             &yaml_perlio_read_handler,
307             self);
308 2 50         } else if (SvTYPE(rv) == SVt_PVGV && GvIO(rv)) {
    50          
    50          
    0          
    50          
    50          
309 2           self->perlio = IoIFP(GvIOp(rv));
310 2           yaml_parser_set_input(&self->parser,
311             &yaml_perlio_read_handler,
312             self);
313 0 0         } else if (SvMAGIC(rv)) {
314 0           mg_get(rv);
315 0 0         fname = SvPV_const(rv, len);
316 0           goto pv_load;
317 0 0         } else if (SvAMAGIC(sv_file)) {
    0          
    0          
318 0 0         fname = SvPV_const(sv_file, len);
319 0           goto pv_load;
320             } else {
321 2           croak("Invalid argument type for file: ref of %s", Perl_sv_peek(aTHX_ rv));
322             return 0;
323             }
324             }
325 3 50         else if (SvPOK(sv_file)) {
326 3 50         fname = SvPV_const(sv_file, len);
327             pv_load:
328 3           file = fopen(fname, "rb");
329 3 50         if (!file) {
330 0           croak("Can't open '%s' for input", fname);
331             return 0;
332             }
333 3           self->filename = (char *)fname;
334 3           yaml_parser_set_input_file(&self->parser, file);
335 0 0         } else if (SvTYPE(sv_file) == SVt_PVIO) {
336 0           self->perlio = IoIFP(sv_file);
337 0           yaml_parser_set_input(&self->parser,
338             &yaml_perlio_read_handler,
339             self);
340 0 0         } else if (SvTYPE(sv_file) == SVt_PVGV
341 0 0         && GvIO(sv_file)) {
    0          
    0          
    0          
    0          
342 0           self->perlio = IoIFP(GvIOp(sv_file));
343 0           yaml_parser_set_input(&self->parser,
344             &yaml_perlio_read_handler,
345             self);
346             } else {
347 0           croak("Invalid argument type for file: %s", Perl_sv_peek(aTHX_ sv_file));
348             return 0;
349             }
350              
351 5           ret = load_impl(self);
352 5 100         if (file)
353 3           fclose(file);
354 2 50         else if (SvTYPE(sv_file) == SVt_PVIO)
355 0           PerlIO_close(IoIFP(sv_file));
356 5           return ret;
357             }
358              
359             /*
360             * This is the main Load function.
361             * It takes a yaml stream and turns it into 0 or more Perl objects.
362             */
363             int
364 104           Load(YAML *self, SV* yaml_sv)
365             {
366             const unsigned char *yaml_str;
367             STRLEN yaml_len;
368              
369 104 100         yaml_str = (const unsigned char *)SvPV_const(yaml_sv, yaml_len);
370 104           yaml_parser_initialize(&self->parser);
371 104           set_parser_options(self, &self->parser);
372 104 50         if (DO_UTF8(yaml_sv)) { /* overrides encoding setting */
    0          
373 0 0         if (self->encoding == YAML_ANY_ENCODING)
374 0           self->parser.encoding = YAML_UTF8_ENCODING;
375             } /* else check the BOM. don't check for decoded utf8. */
376              
377 104           yaml_parser_set_input_string(
378             &self->parser,
379             yaml_str,
380             yaml_len);
381              
382 104           return load_impl(self);
383             }
384              
385             /*
386             * This is the main function for dumping any node.
387             */
388             static SV *
389 621           load_node(YAML *self)
390             {
391 621           SV* return_sv = NULL;
392             /* This uses stack, but avoids (severe!) memory leaks */
393             yaml_event_t uplevel_event;
394              
395 621           uplevel_event = self->event;
396              
397             /* Get the next parser event */
398 621 100         if (!yaml_parser_parse(&self->parser, &self->event))
399 4           goto load_error;
400              
401             /* These events don't need yaml_event_delete */
402             /* Some kind of error occurred */
403 617 50         if (self->event.type == YAML_NO_EVENT)
404 0           goto load_error;
405              
406             /* Return NULL when we hit the end of a scope */
407 617 50         if (self->event.type == YAML_DOCUMENT_END_EVENT ||
    100          
408 543 100         self->event.type == YAML_MAPPING_END_EVENT ||
409 543           self->event.type == YAML_SEQUENCE_END_EVENT)
410             {
411             /* restore the uplevel event, so it can be properly deleted */
412 126           self->event = uplevel_event;
413 126           return return_sv;
414             }
415              
416             /* The rest all need cleanup */
417 491           switch (self->event.type) {
418             char *tag;
419              
420             /* Handle loading a mapping */
421             case YAML_MAPPING_START_EVENT:
422 77           tag = (char *)self->event.data.mapping_start.tag;
423              
424 77 100         if (tag) {
425             /* Handle mapping tagged as a Perl hard reference */
426 32 100         if (strEQ(tag, TAG_PERL_REF)) {
427 16           return_sv = load_scalar_ref(self);
428 16           break;
429             }
430             /* Handle mapping tagged as a Perl typeglob */
431 16 50         if (strEQ(tag, TAG_PERL_GLOB)) {
432 0           return_sv = load_glob(self);
433 0           break;
434             }
435             }
436              
437 61           return_sv = load_mapping(self, NULL);
438 57           break;
439              
440             /* Handle loading a sequence into an array */
441             case YAML_SEQUENCE_START_EVENT:
442 52           return_sv = load_sequence(self);
443 51           break;
444              
445             /* Handle loading a scalar */
446             case YAML_SCALAR_EVENT:
447 346           return_sv = load_scalar(self);
448 346           break;
449              
450             /* Handle loading an alias node */
451             case YAML_ALIAS_EVENT:
452 16           return_sv = load_alias(self);
453 16           break;
454              
455             default:
456 0           croak("%sInvalid event '%d' at top level",
457 0           ERRMSG, (int) self->event.type);
458             }
459              
460 486           yaml_event_delete(&self->event);
461              
462             /* restore the uplevel event, so it can be properly deleted */
463 486           self->event = uplevel_event;
464              
465 486           return return_sv;
466              
467             load_error:
468 616           croak("%s", loader_error_msg(self, NULL));
469             }
470              
471             /*
472             * Load a YAML mapping into a Perl hash
473             */
474             static SV *
475 61           load_mapping(YAML *self, char *tag)
476             {
477             SV *key_node;
478             SV *value_node;
479 61           HV *hash = newHV();
480 61           SV *hash_ref = (SV *)newRV_noinc((SV *)hash);
481 61           char *anchor = (char *)self->event.data.mapping_start.anchor;
482              
483 61 50         if (!tag)
484 61           tag = (char *)self->event.data.mapping_start.tag;
485              
486             /* Store the anchor label if any */
487 61 100         if (anchor)
488 5           (void)hv_store(self->anchors, anchor, strlen(anchor),
489             SvREFCNT_inc(hash_ref), 0);
490              
491             /* Get each key string and value node and put them in the hash */
492 171 100         while ((key_node = load_node(self))) {
493             assert(SvPOK(key_node));
494 111           value_node = load_node(self);
495 110           (void)hv_store_ent(hash, sv_2mortal(key_node), value_node, 0);
496             }
497              
498             /* Deal with possibly blessing the hash if the YAML tag has a class */
499 58 100         if (tag) {
500 16 100         if (strEQ(tag, TAG_PERL_PREFIX "hash")) {
501             }
502 14 100         else if (strEQ(tag, YAML_MAP_TAG)) {
503             }
504             else {
505             char *klass;
506 13           char *prefix = TAG_PERL_PREFIX "hash:";
507 13 100         if (*tag == '!') {
508 3           prefix = "!";
509             }
510 10 100         else if (strlen(tag) <= strlen(prefix) ||
    50          
511 9           ! strnEQ(tag, prefix, strlen(prefix)))
512 1           croak("%s", loader_error_msg(self,
513             form("bad tag found for hash: '%s'", tag)));
514 12 100         if (!(self->flags & F_DISABLEBLESSED)) {
515 10           klass = tag + strlen(prefix);
516 10 100         if (self->flags & F_SAFEMODE &&
    50          
517 2 100         (!self->safeclasses ||
518 2           !hv_exists(self->safeclasses, klass, strlen(klass))))
519             {
520 1           Perl_warner(aTHX_ packWARN(WARN_MISC),
521             WARNMSG "skipped loading unsafe HASH for class %s",
522             klass);
523 1           return hash_ref;
524             }
525 9           sv_bless(hash_ref, gv_stashpv(klass, TRUE));
526             }
527             }
528             }
529              
530 56           return hash_ref;
531             }
532              
533             /* Load a YAML sequence into a Perl array */
534             static SV *
535 52           load_sequence(YAML *self)
536             {
537             SV *node;
538 52           AV *array = newAV();
539 52           SV *array_ref = (SV *)newRV_noinc((SV *)array);
540 52           char *anchor = (char *)self->event.data.sequence_start.anchor;
541 52           char *tag = (char *)self->event.data.mapping_start.tag;
542 52 100         if (anchor)
543 2           (void)hv_store(self->anchors, anchor, strlen(anchor),
544             SvREFCNT_inc(array_ref), 0);
545 179 100         while ((node = load_node(self))) {
546 127           av_push(array, node);
547             }
548 52 100         if (tag) {
549 13 100         if (strEQ(tag, TAG_PERL_PREFIX "array")) {
550             }
551 11 100         else if (strEQ(tag, YAML_SEQ_TAG)) {
552             }
553             else {
554             char *klass;
555 10           char *prefix = TAG_PERL_PREFIX "array:";
556              
557 10 100         if (*tag == '!')
558 3           prefix = "!";
559 7 100         else if (strlen(tag) <= strlen(prefix) ||
    50          
560 6           ! strnEQ(tag, prefix, strlen(prefix)))
561 1           croak("%s", loader_error_msg(self,
562             form("bad tag found for array: '%s'", tag)));
563 9 100         if (!(self->flags & F_DISABLEBLESSED)) {
564 7           klass = tag + strlen(prefix);
565 7 100         if (self->flags & F_SAFEMODE &&
    50          
566 2 100         (!self->safeclasses ||
567 2           !hv_exists(self->safeclasses, klass, strlen(klass))))
568             {
569 1           Perl_warner(aTHX_ packWARN(WARN_MISC),
570             WARNMSG "skipped loading unsafe ARRAY for class %s",
571             klass);
572 1           return array_ref;
573             }
574 6           sv_bless(array_ref, gv_stashpv(klass, TRUE));
575             }
576             }
577             }
578 50           return array_ref;
579             }
580              
581             /* Load a YAML scalar into a Perl scalar */
582             static SV *
583 346           load_scalar(YAML *self)
584             {
585             SV *scalar;
586 346           char *string = (char *)self->event.data.scalar.value;
587 346           STRLEN length = (STRLEN)self->event.data.scalar.length;
588 346           char *anchor = (char *)self->event.data.scalar.anchor;
589 346           char *tag = (char *)self->event.data.scalar.tag;
590 346           yaml_scalar_style_t style = self->event.data.scalar.style;
591 346 100         if (tag) {
592 37 100         if (strEQ(tag, YAML_STR_TAG)) {
593 6           style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
594             }
595 31 100         else if (strEQ(tag, YAML_INT_TAG) || strEQ(tag, YAML_FLOAT_TAG)) {
    100          
596             /* TODO check int/float */
597 2           scalar = newSVpvn(string, length);
598 2 50         if ( looks_like_number(scalar) ) {
599             /* numify */
600 2 50         SvIV_please(scalar);
    50          
    50          
601             }
602             else {
603 0           croak("%s", loader_error_msg(self,
604             form("Invalid content found for !!int tag: '%s'",
605             tag)));
606             }
607 2 50         if (anchor)
608 0           (void)hv_store(self->anchors, anchor, strlen(anchor),
609             SvREFCNT_inc(scalar), 0);
610 2           return scalar;
611             }
612 29 100         else if (strEQ(tag, YAML_NULL_TAG) &&
    100          
613 3 100         (strEQ(string, "~") ||
614 2 50         strEQ(string, "null") ||
615 2           strEQ(string, "")))
616             {
617 4           scalar = newSV(0);
618 4 100         if (anchor)
619 1           (void)hv_store(self->anchors, anchor, strlen(anchor),
620             SvREFCNT_inc(scalar), 0);
621 4           return scalar;
622             }
623             else {
624             char *klass;
625 25           char *prefix = TAG_PERL_PREFIX "regexp";
626 25 100         if (strnEQ(tag, prefix, strlen(prefix)))
627 11           return load_regexp(self);
628 14           prefix = TAG_PERL_PREFIX "code";
629 14 100         if (strnEQ(tag, prefix, strlen(prefix)))
630 6           return load_code(self);
631 8           prefix = TAG_PERL_PREFIX "scalar:";
632 8 100         if (*tag == '!')
633 3           prefix = "!";
634 5 50         else if (strlen(tag) <= strlen(prefix) ||
    50          
635 5           !strnEQ(tag, prefix, strlen(prefix)))
636 0           croak("%sbad tag found for scalar: '%s'", ERRMSG, tag);
637 8           klass = tag + strlen(prefix);
638 8 100         if (!(self->flags & F_DISABLEBLESSED))
639 6 100         if (self->flags & F_SAFEMODE &&
    50          
640 2 100         (!self->safeclasses ||
641 2           !hv_exists(self->safeclasses, klass, strlen(klass))))
642             {
643 1           Perl_warner(aTHX_ packWARN(WARN_MISC),
644             WARNMSG "skipped loading unsafe SCALAR for class %s",
645             klass);
646 1           scalar = newSVpvn(string, length);
647             } else {
648 6           scalar = sv_setref_pvn(newSV(0), klass, string, strlen(string));
649             }
650             else
651 2           scalar = newSVpvn(string, length);
652 8           SvUTF8_on(scalar);
653 8 50         if (anchor)
654 0           (void)hv_store(self->anchors, anchor, strlen(anchor),
655             SvREFCNT_inc(scalar), 0);
656 8           return scalar;
657             }
658             }
659              
660 309 100         else if (style == YAML_PLAIN_SCALAR_STYLE) {
661 281 100         if (strEQ(string, "~") || strEQ(string, "null") || strEQ(string, "")) {
    100          
    100          
662 17           scalar = newSV(0);
663 17 100         if (anchor)
664 3           (void)hv_store(self->anchors, anchor, strlen(anchor),
665             SvREFCNT_inc(scalar), 0);
666 17           return scalar;
667             }
668 264 100         else if (strEQ(string, "true")) {
669             #if (PERL_BCDVERSION >= 0x5008009)
670 12 100         if (self->boolean == YAML_BOOLEAN_JSONPP) {
671 3           scalar = sv_setref_iv(newSV(1), "JSON::PP::Boolean", 1);
672             }
673 9 100         else if (self->boolean == YAML_BOOLEAN_BOOLEAN) {
674 1           scalar = sv_setref_iv(newSV(1), "boolean", 1);
675             }
676             else
677             #endif
678             {
679 8           scalar = &PL_sv_yes;
680             }
681 12 100         if (anchor)
682 1           (void)hv_store(self->anchors, anchor, strlen(anchor),
683             SvREFCNT_inc(scalar), 0);
684 12           return scalar;
685             }
686 252 100         else if (strEQ(string, "false")) {
687             #if (PERL_BCDVERSION >= 0x5008009)
688 7 100         if (self->boolean == YAML_BOOLEAN_JSONPP) {
689 3           scalar = sv_setref_iv(newSV(0), "JSON::PP::Boolean", 0);
690             }
691 4 100         else if (self->boolean == YAML_BOOLEAN_BOOLEAN) {
692 1           scalar = sv_setref_iv(newSV(0), "boolean", 0);
693             }
694             else
695             #endif
696             {
697 3           scalar = &PL_sv_no;
698             }
699 7 100         if (anchor)
700 1           (void)hv_store(self->anchors, anchor, strlen(anchor),
701             SvREFCNT_inc(scalar), 0);
702 7           return scalar;
703             }
704             }
705              
706 279           scalar = newSVpvn(string, length);
707              
708 279 100         if (style == YAML_PLAIN_SCALAR_STYLE && looks_like_number(scalar) ) {
    100          
709             /* numify */
710 48 50         SvIV_please(scalar);
    50          
    50          
711             }
712              
713 279           (void)sv_utf8_decode(scalar);
714 279 100         if (anchor)
715 1           (void)hv_store(self->anchors, anchor, strlen(anchor),
716             SvREFCNT_inc(scalar), 0);
717 279           return scalar;
718             }
719              
720             /* Load a scalar marked as a regexp as a Perl regular expression.
721             * This operation is less common and is tricky, so doing it in Perl code for
722             * now.
723             */
724             static SV *
725 11           load_regexp(YAML * self)
726             {
727 11           dSP;
728 11           char *string = (char *)self->event.data.scalar.value;
729 11           STRLEN length = (STRLEN)self->event.data.scalar.length;
730 11           char *anchor = (char *)self->event.data.scalar.anchor;
731 11           char *tag = (char *)self->event.data.scalar.tag;
732 11           char *prefix = (char*)TAG_PERL_PREFIX "regexp:";
733              
734 11           SV *regexp = newSVpvn(string, length);
735 11           SvUTF8_on(regexp);
736              
737 11           ENTER;
738 11           SAVETMPS;
739 11 50         PUSHMARK(sp);
740 11 50         XPUSHs(regexp);
741 11           PUTBACK;
742 11           call_pv("YAML::Safe::__qr_loader", G_SCALAR);
743 11           SPAGAIN;
744 11           regexp = newSVsv(POPs);
745              
746 11           PUTBACK;
747 11 50         FREETMPS;
748 11           LEAVE;
749              
750 11 100         if (strlen(tag) > strlen(prefix) && strnEQ(tag, prefix, strlen(prefix))) {
    50          
751 3 100         if (!(self->flags & F_DISABLEBLESSED)) {
752 2           char *klass = tag + strlen(prefix);
753 2 50         if (self->flags & F_SAFEMODE) {
754 0           if (!self->safeclasses ||
755 0           !hv_exists(self->safeclasses, klass, strlen(klass)))
756             {
757 0           Perl_warner(aTHX_ packWARN(WARN_MISC),
758             WARNMSG "skipped loading unsafe REGEXP for class %s",
759             klass);
760 0           goto cont_rx;
761             }
762             }
763 2           sv_bless(regexp, gv_stashpv(klass, TRUE));
764             }
765             }
766             cont_rx:
767 11 100         if (anchor)
768 1           (void)hv_store(self->anchors, anchor, strlen(anchor),
769             SvREFCNT_inc(regexp), 0);
770 11           return regexp;
771             }
772              
773             /* Load a scalar marked as code as a Perl code reference.
774             * This operation is less common and is tricky, so doing it in Perl code for
775             * now.
776             */
777             SV*
778 6           load_code(YAML * self)
779             {
780 6           dSP;
781 6           char *string = (char *)self->event.data.scalar.value;
782 6           STRLEN length = (STRLEN)self->event.data.scalar.length;
783 6           char *anchor = (char *)self->event.data.scalar.anchor;
784 6           char *tag = (char *)self->event.data.scalar.tag;
785 6           char *prefix = TAG_PERL_PREFIX "code:";
786             SV *code;
787              
788 6 50         if (strlen(tag) > strlen(prefix) && strnEQ(tag, prefix, strlen(prefix))) {
    50          
789 6           char *klass = tag + strlen(prefix);
790 6 100         if (self->flags & F_SAFEMODE &&
    50          
791 2 100         (!self->safeclasses ||
792 2           !hv_exists(self->safeclasses, klass, strlen(klass))))
793             {
794 1           Perl_warner(aTHX_ packWARN(WARN_MISC),
795             WARNMSG "skipped loading unsafe CODE for class %s",
796             klass);
797 1           return &PL_sv_undef;
798             }
799             }
800              
801 5 100         if (!(self->flags & F_LOADCODE)) {
802 1           tag = "";
803 1           string = "{}";
804 1           length = 2;
805             }
806              
807 5           code = newSVpvn(string, length);
808 5           SvUTF8_on(code);
809              
810 5           ENTER;
811 5           SAVETMPS;
812 5 50         PUSHMARK(sp);
813 5 50         XPUSHs(code);
814 5           PUTBACK;
815 5           call_pv("YAML::Safe::__code_loader", G_SCALAR);
816 5           SPAGAIN;
817 5           code = newSVsv(POPs);
818              
819 5           PUTBACK;
820 5 50         FREETMPS;
821 5           LEAVE;
822              
823 5 100         if (strlen(tag) > strlen(prefix) && strnEQ(tag, prefix, strlen(prefix))) {
    50          
824 4 50         if (!(self->flags & F_DISABLEBLESSED)) {
825 4           char *klass = tag + strlen(prefix);
826 4           sv_bless(code, gv_stashpv(klass, TRUE));
827             }
828             }
829              
830 5 50         if (anchor)
831 0           (void)hv_store(self->anchors, anchor, strlen(anchor),
832             SvREFCNT_inc(code), 0);
833 5           return code;
834             }
835              
836              
837             /*
838             * Load a reference to a previously loaded node.
839             */
840             static SV *
841 16           load_alias(YAML *self)
842             {
843 16           char *anchor = (char *)self->event.data.alias.anchor;
844 16           SV **entry = hv_fetch(self->anchors, anchor, strlen(anchor), 0);
845 16 50         if (entry)
846 16           return SvREFCNT_inc(*entry);
847 0           croak("%sNo anchor for alias '%s'", ERRMSG, anchor);
848             }
849              
850             /*
851             * Load a Perl hard reference.
852             */
853             SV *
854 16           load_scalar_ref(YAML *self)
855             {
856             SV *value_node;
857 16           char *anchor = (char *)self->event.data.mapping_start.anchor;
858 16           SV *rv = newRV_noinc(&PL_sv_undef);
859 16 100         if (anchor)
860 2           (void)hv_store(self->anchors, anchor, strlen(anchor),
861             SvREFCNT_inc(rv), 0);
862 16           load_node(self); /* Load the single hash key (=) */
863 16           value_node = load_node(self);
864 16           SvRV(rv) = value_node;
865 16 50         if (load_node(self))
866 0           croak("%sExpected end of node", ERRMSG);
867 16           return rv;
868             }
869              
870             /*
871             * Load a Perl typeglob.
872             */
873             static SV *
874 0           load_glob(YAML *self)
875             {
876             /* XXX Call back a Perl sub to do something interesting here */
877 0           return load_mapping(self, (char*)TAG_PERL_PREFIX "hash");
878             }
879              
880             /* -------------------------------------------------------------------------- */
881              
882              
883             /*
884             * This is the main Dump function.
885             * Take zero or more Perl objects from the stack
886             * and return a YAML stream (as a string)
887             */
888             int
889 83           Dump(YAML *self, int yaml_ix)
890             {
891 83           dXSARGS; /* does POPMARK */
892             yaml_event_t event_stream_start;
893             yaml_event_t event_stream_end;
894             int i;
895 83           SV *yaml = sv_2mortal(newSVpvn("", 0));
896              
897 83           sp = mark;
898              
899 83           yaml_emitter_initialize(&self->emitter);
900 83           set_emitter_options(self, &self->emitter);
901 83           yaml_emitter_set_output(
902             &self->emitter,
903             &yaml_sv_write_handler,
904             (void *)yaml);
905              
906 83           yaml_stream_start_event_initialize(&event_stream_start, self->encoding);
907 83           yaml_emitter_emit(&self->emitter, &event_stream_start);
908              
909 83           self->anchors = (HV *)sv_2mortal((SV *)newHV());
910 83           self->shadows = (HV *)sv_2mortal((SV *)newHV());
911              
912 186 100         for (i = yaml_ix; i < items; i++) {
913 103           self->anchor = 0;
914              
915 103           dump_prewalk(self, ST(i));
916 103           dump_document(self, ST(i));
917              
918 103           hv_clear(self->anchors);
919 103           hv_clear(self->shadows);
920             }
921              
922             /* End emitting and destroy the emitter object */
923 83           yaml_stream_end_event_initialize(&event_stream_end);
924 83           yaml_emitter_emit(&self->emitter, &event_stream_end);
925 83           yaml_emitter_delete(&self->emitter);
926              
927             /* Put the YAML stream scalar on the XS output stack */
928 83 50         if (yaml) {
929 83           sp = PL_stack_base + ax - 1; /* ax 0 */
930 83           SvUTF8_off(yaml);
931 83 50         XPUSHs(yaml);
932 83           PUTBACK;
933 83           return 1;
934             } else {
935 0           PUTBACK;
936 83           return 0;
937             }
938             }
939              
940             /*
941             * Dump zero or more Perl objects into the file
942             */
943             int
944 4           DumpFile(YAML *self, SV *sv_file, int yaml_ix)
945             {
946 4           dXSARGS;
947             yaml_event_t event_stream_start;
948             yaml_event_t event_stream_end;
949 4           FILE *file = NULL;
950             const char *fname;
951             STRLEN len;
952             long i;
953              
954 4           sp = mark;
955              
956 4           yaml_emitter_initialize(&self->emitter);
957 4           set_emitter_options(self, &self->emitter);
958              
959 4 100         if (SvROK(sv_file)) { /* pv mg or io or gv */
960 2           SV *rv = SvRV(sv_file);
961              
962 2 50         if (SvTYPE(rv) == SVt_PVIO) {
963 0           self->perlio = IoOFP(rv);
964 0           yaml_emitter_set_output(&self->emitter,
965             &yaml_perlio_write_handler,
966             self);
967 2 50         } else if (SvTYPE(rv) == SVt_PVGV && GvIO(rv)) {
    50          
    50          
    0          
    50          
    50          
968 2           self->perlio = IoOFP(GvIOp(SvRV(sv_file)));
969 2           yaml_emitter_set_output(&self->emitter,
970             &yaml_perlio_write_handler,
971             self);
972 0 0         } else if (SvMAGIC(rv)) {
973 0           mg_get(rv);
974 0 0         fname = SvPV_const(rv, len);
975 0           goto pv_dump;
976 0 0         } else if (SvAMAGIC(sv_file)) {
    0          
    0          
977 0 0         fname = SvPV_const(sv_file, len);
978 0           goto pv_dump;
979             } else {
980 2           croak("Invalid argument type for file: ref of %s", Perl_sv_peek(aTHX_ rv));
981             return 0;
982             }
983             }
984 2 50         else if (SvPOK(sv_file)) {
985 2 50         fname = (const char *)SvPV_const(sv_file, len);
986             pv_dump:
987 2           file = fopen(fname, "wb");
988 2 50         if (!file) {
989 0           croak("Can't open '%s' for output", fname);
990             return 0;
991             }
992 2           self->filename = (char *)fname;
993 2           yaml_emitter_set_output_file(&self->emitter, file);
994 0 0         } else if (SvTYPE(sv_file) == SVt_PVIO) {
995 0           self->perlio = IoOFP(sv_file);
996 0           yaml_emitter_set_output(&self->emitter,
997             &yaml_perlio_write_handler,
998             self);
999 0 0         } else if (SvTYPE(sv_file) == SVt_PVGV && GvIO(sv_file)) {
    0          
    0          
    0          
    0          
    0          
1000 0           self->perlio = IoOFP(GvIOp(sv_file));
1001 0           yaml_emitter_set_output(&self->emitter,
1002             &yaml_perlio_write_handler,
1003             self);
1004             } else {
1005             /* sv_peek since 5.005 */
1006 0           croak("Invalid argument type for file: %s", Perl_sv_peek(aTHX_ sv_file));
1007             return 0;
1008             }
1009              
1010 4           yaml_stream_start_event_initialize(&event_stream_start,
1011             self->encoding);
1012 4 50         if (!yaml_emitter_emit(&self->emitter, &event_stream_start)) {
1013 0           PUTBACK;
1014 0           return 0;
1015             }
1016              
1017 4           self->anchors = (HV *)sv_2mortal((SV *)newHV());
1018 4           self->shadows = (HV *)sv_2mortal((SV *)newHV());
1019              
1020             /* ST(yaml_ix) is the file */
1021 10 100         for (i = yaml_ix+1; i < items; i++) {
1022 6           self->anchor = 0;
1023              
1024 6           dump_prewalk(self, ST(i));
1025 6           dump_document(self, ST(i));
1026              
1027 6           hv_clear(self->anchors);
1028 6           hv_clear(self->shadows);
1029             }
1030              
1031             /* End emitting and destroy the emitter object */
1032 4           yaml_stream_end_event_initialize(&event_stream_end);
1033 4 50         if (!yaml_emitter_emit(&self->emitter, &event_stream_end)) {
1034 0           PUTBACK;
1035 0           return 0;
1036             }
1037 4           yaml_emitter_delete(&self->emitter);
1038 4 100         if (file)
1039 2           fclose(file);
1040 2 50         else if (SvTYPE(sv_file) == SVt_PVIO)
1041 0           PerlIO_close(IoOFP(sv_file));
1042              
1043 4           PUTBACK;
1044 4           return 1;
1045             }
1046              
1047             /*
1048             * In order to know which nodes will need anchors (for later aliasing) it is
1049             * necessary to walk the entire data structure first. Once a node has been
1050             * seen twice you can stop walking it. That way we can handle circular refs.
1051             * All the node information is stored in an HV.
1052             */
1053             static void
1054 306           dump_prewalk(YAML *self, SV *node)
1055             {
1056             int i;
1057             U32 ref_type;
1058              
1059 306 100         if (! (SvROK(node) || SvTYPE(node) == SVt_PVGV)) return;
    100          
1060              
1061             {
1062 148 100         SV *object = SvROK(node) ? SvRV(node) : node;
1063 148           SV **seen =
1064 148           hv_fetch(self->anchors, (char *)&object, sizeof(object), 0);
1065 148 100         if (seen) {
1066 17 100         if (*seen == &PL_sv_undef) {
1067 16           (void)hv_store(self->anchors, (char *)&object, sizeof(object),
1068             &PL_sv_yes, 0);
1069             }
1070 17           return;
1071             }
1072 131           (void)hv_store(self->anchors, (char *)&object, sizeof(object),
1073             &PL_sv_undef, 0);
1074             }
1075              
1076 131 100         if (SvTYPE(node) == SVt_PVGV) {
1077 2           node = dump_glob(self, node);
1078             }
1079              
1080 131           ref_type = SvTYPE(SvRV(node));
1081 131 100         if (ref_type == SVt_PVAV) {
1082 44           AV *array = (AV *)SvRV(node);
1083 44           int array_size = av_len(array) + 1;
1084 135 100         for (i = 0; i < array_size; i++) {
1085 91           SV **entry = av_fetch(array, i, 0);
1086 91 50         if (entry)
1087 91           dump_prewalk(self, *entry);
1088             }
1089             }
1090 87 100         else if (ref_type == SVt_PVHV) {
1091 47           HV *hash = (HV *)SvRV(node);
1092             HE *he;
1093 47           hv_iterinit(hash);
1094 140 100         while ((he = hv_iternext(hash))) {
1095 93           SV *val = HeVAL(he);
1096 93 100         if (val)
1097 87           dump_prewalk(self, val);
1098             }
1099             }
1100 40 100         else if (ref_type <= SVt_PVNV || ref_type == SVt_PVGV) {
    100          
1101 19           SV *scalar = SvRV(node);
1102 19           dump_prewalk(self, scalar);
1103             }
1104             }
1105              
1106             static void
1107 109           dump_document(YAML *self, SV *node)
1108             {
1109             yaml_event_t event_document_start;
1110             yaml_event_t event_document_end;
1111 109           yaml_document_start_event_initialize(
1112             &event_document_start, NULL, NULL, NULL, 0);
1113 109           yaml_emitter_emit(&self->emitter, &event_document_start);
1114 109           dump_node(self, node);
1115 109           yaml_document_end_event_initialize(&event_document_end, 1);
1116 109           yaml_emitter_emit(&self->emitter, &event_document_end);
1117 109           }
1118              
1119             static void
1120 399           dump_node(YAML *self, SV *node)
1121             {
1122 399           yaml_char_t *anchor = NULL;
1123 399           yaml_char_t *tag = NULL;
1124 399           const char *klass = NULL;
1125              
1126 399 100         if (SvTYPE(node) == SVt_PVGV) {
1127             SV **svr;
1128 5           tag = (yaml_char_t *)TAG_PERL_PREFIX "glob";
1129 5           anchor = get_yaml_anchor(self, node);
1130 5 100         if (anchor && strEQ((char *)anchor, ""))
    50          
1131 3           return;
1132 2           svr = hv_fetch(self->shadows, (char *)&node, sizeof(node), 0);
1133 2 50         if (svr) {
1134 2           node = SvREFCNT_inc(*svr);
1135             }
1136             }
1137              
1138 396 100         if (SvROK(node)) {
1139 145           SV *rnode = SvRV(node);
1140 145           U32 ref_type = SvTYPE(rnode);
1141 145 100         if (ref_type == SVt_PVHV)
1142 52           dump_hash(self, node, anchor, tag);
1143 93 100         else if (ref_type == SVt_PVAV)
1144 50           dump_array(self, node);
1145 43 100         else if (ref_type <= SVt_PVNV || ref_type == SVt_PVGV)
    100          
1146 22           dump_ref(self, node);
1147 21 100         else if (ref_type == SVt_PVCV)
1148 5           dump_code(self, node);
1149 16 100         else if (ref_type == SVt_PVMG) {
1150             MAGIC *mg;
1151 10           yaml_char_t *tag = NULL;
1152 10 50         if (SvMAGICAL(rnode)) {
1153 0 0         if ((mg = mg_find(rnode, PERL_MAGIC_qr))) {
1154 0           tag = (yaml_char_t *)form(TAG_PERL_PREFIX "regexp");
1155 0           klass = sv_reftype(rnode, TRUE);
1156 0 0         if (!strEQ(klass, "Regexp"))
1157 0           tag = (yaml_char_t *)form("%s:%s", tag, klass);
1158             }
1159 0           dump_scalar(self, node, tag);
1160             }
1161             else {
1162 10           klass = sv_reftype(rnode, TRUE);
1163 10 100         if (self->boolean != YAML_BOOLEAN_NONE) {
1164 8 50         if (SvIV(node))
    100          
1165 4           dump_scalar(self, &PL_sv_yes, NULL);
1166             else
1167 8           dump_scalar(self, &PL_sv_no, NULL);
1168             }
1169             else {
1170 2           tag = (yaml_char_t *)form(
1171             TAG_PERL_PREFIX "scalar:%s",
1172             klass);
1173 2           node = rnode;
1174 10           dump_scalar(self, node, tag);
1175             }
1176             }
1177             }
1178             #if PERL_VERSION >= 11
1179 6 50         else if (ref_type == SVt_REGEXP) {
1180 6           yaml_char_t *tag = (yaml_char_t *)form(TAG_PERL_PREFIX "regexp");
1181 6           klass = sv_reftype(rnode, TRUE);
1182 6 100         if (!strEQ(klass, "Regexp"))
1183 1           tag = (yaml_char_t *)form("%s:%s", tag, klass);
1184 6           dump_scalar(self, node, tag);
1185             }
1186             #endif
1187             else {
1188 0           printf("YAML::Safe dump unhandled ref. type == '%d'!\n",
1189             (int)ref_type);
1190 145           dump_scalar(self, rnode, NULL);
1191             }
1192             }
1193             else {
1194 251           dump_scalar(self, node, NULL);
1195             }
1196             }
1197              
1198             static yaml_char_t *
1199 129           get_yaml_anchor(YAML *self, SV *node)
1200             {
1201             yaml_event_t event_alias;
1202             SV *iv;
1203 129           SV **seen = hv_fetch(self->anchors, (char *)&node, sizeof(node), 0);
1204 129 100         if (seen && *seen != &PL_sv_undef) {
    100          
1205 33 100         if (*seen == &PL_sv_yes) {
1206 16           self->anchor++;
1207 16           iv = newSViv(self->anchor);
1208 16           (void)hv_store(self->anchors, (char *)&node, sizeof(node), iv, 0);
1209 16 50         return (yaml_char_t*)SvPV_nolen(iv);
1210             }
1211             else {
1212 17 50         yaml_char_t *anchor = (yaml_char_t *)SvPV_nolen(*seen);
1213 17           yaml_alias_event_initialize(&event_alias, anchor);
1214 17           yaml_emitter_emit(&self->emitter, &event_alias);
1215 17           return (yaml_char_t *) "";
1216             }
1217             }
1218 129           return NULL;
1219             }
1220              
1221             static yaml_char_t *
1222 94           get_yaml_tag(SV *node)
1223             {
1224 94           yaml_char_t *tag = NULL;
1225 94           char *kind = (char*)"";
1226             char *klass;
1227              
1228 94 100         if (! (sv_isobject(node)
    50          
1229 81 100         || (SvRV(node) && ( SvTYPE(SvRV(node)) == SVt_PVCV))))
1230 80           return NULL;
1231 14           klass = (char *)sv_reftype(SvRV(node), TRUE);
1232              
1233 14           switch (SvTYPE(SvRV(node))) {
1234             case SVt_PVAV:
1235 3           tag = (yaml_char_t *)form("%s%s:%s", TAG_PERL_PREFIX, "array", klass);
1236 3           break;
1237             case SVt_PVHV:
1238 6           tag = (yaml_char_t *)form("%s%s:%s", TAG_PERL_PREFIX, "hash", klass);
1239 6           break;
1240             case SVt_PVCV:
1241 5           kind = (char*)"code";
1242 5 100         if (strEQ(klass, "CODE"))
1243 1           tag = (yaml_char_t *)form("%s%s", TAG_PERL_PREFIX, kind);
1244             else
1245 4           tag = (yaml_char_t *)form("%s%s:%s", TAG_PERL_PREFIX, kind, klass);
1246 5           break;
1247             default:
1248 0           tag = (yaml_char_t *)form("%s%s", TAG_PERL_PREFIX, klass);
1249 0           break;
1250             }
1251 14 50         if (!tag)
1252 0           tag = (yaml_char_t *)form("%s%s:%s", TAG_PERL_PREFIX, kind, klass);
1253 14           return tag;
1254             }
1255              
1256             static void
1257 52           dump_hash(
1258             YAML *self, SV *node,
1259             yaml_char_t *anchor, yaml_char_t *tag)
1260             {
1261             yaml_event_t event_mapping_start;
1262             yaml_event_t event_mapping_end;
1263             STRLEN i, len;
1264             AV *av;
1265 52           HV *hash = (HV *)SvRV(node);
1266             HE *he;
1267              
1268 52 50         if (!anchor)
1269 52           anchor = get_yaml_anchor(self, (SV *)hash);
1270 52 100         if (anchor && strEQ((char*)anchor, ""))
    100          
1271 5           return;
1272              
1273 47 100         if (!tag)
1274 45           tag = get_yaml_tag(node);
1275 47 100         if (tag && self->flags & F_SAFEMODE) {
    100          
1276 1           char *prefix = TAG_PERL_PREFIX "hash:";
1277 1           char *klass = (char*)tag + strlen(prefix);
1278 1           STRLEN len = strlen(klass);
1279 1 50         if (SvOBJECT(node)) {
1280 0           HV* stash = SvSTASH(node);
1281 0 0         klass = HvNAME_get(stash);
    0          
    0          
    0          
    0          
    0          
1282 0 0         len = HvNAMELEN_get(stash);
    0          
    0          
    0          
    0          
    0          
1283 0 0         if (HvNAMEUTF8(stash))
    0          
    0          
    0          
    0          
    0          
    0          
1284 0           len = -len;
1285             }
1286 2           if (!self->safeclasses ||
1287 1           !hv_exists(self->safeclasses, klass, len))
1288             {
1289 0           Perl_warner(aTHX_ packWARN(WARN_MISC),
1290             WARNMSG "skipped dumping unsafe HASH in class %s",
1291             klass);
1292 0           hash = (HV*)sv_2mortal((SV*)newHV());
1293             }
1294             }
1295              
1296 47           yaml_mapping_start_event_initialize(
1297             &event_mapping_start, anchor, tag, 0, YAML_BLOCK_MAPPING_STYLE);
1298 47           yaml_emitter_emit(&self->emitter, &event_mapping_start);
1299              
1300 47           av = newAV();
1301 47           len = 0;
1302 47           hv_iterinit(hash);
1303 137 100         while ((he = hv_iternext(hash))) {
1304 90           SV *key = hv_iterkeysv(he);
1305 90           av_store(av, AvFILLp(av)+1, key); /* av_push(), really */
1306 90           len++;
1307             }
1308 47           STORE_HASH_SORT;
1309 137 100         for (i = 0; i < len; i++) {
1310 90           SV *key = av_shift(av);
1311 90           HE *he = hv_fetch_ent(hash, key, 0, 0);
1312 90 50         SV *val = he ? HeVAL(he) : NULL;
1313 90 50         if (val == NULL)
1314 0           val = &PL_sv_undef;
1315 90           dump_node(self, key);
1316 90           dump_node(self, val);
1317             }
1318              
1319 47           SvREFCNT_dec(av);
1320              
1321 47           yaml_mapping_end_event_initialize(&event_mapping_end);
1322 47           yaml_emitter_emit(&self->emitter, &event_mapping_end);
1323             }
1324              
1325             static void
1326 50           dump_array(YAML *self, SV *node)
1327             {
1328             yaml_event_t event_sequence_start;
1329             yaml_event_t event_sequence_end;
1330             yaml_char_t *tag;
1331 50           AV *array = (AV *)SvRV(node);
1332             STRLEN i;
1333 50           STRLEN array_size = av_len(array) + 1;
1334              
1335 50           yaml_char_t *anchor = get_yaml_anchor(self, (SV *)array);
1336 50 100         if (anchor && strEQ((char *)anchor, ""))
    100          
1337 6           return;
1338 44           tag = get_yaml_tag(node);
1339 44 100         if (tag && self->flags & F_SAFEMODE) {
    100          
1340 1           char *prefix = TAG_PERL_PREFIX "array:";
1341 1           char *klass = (char*)tag + strlen(prefix);
1342 1           STRLEN len = strlen(klass);
1343 1 50         if (SvOBJECT(node)) {
1344 0           HV* stash = SvSTASH(node);
1345 0 0         klass = HvNAME_get(stash);
    0          
    0          
    0          
    0          
    0          
1346 0 0         len = HvNAMELEN_get(stash);
    0          
    0          
    0          
    0          
    0          
1347 0 0         if (HvNAMEUTF8(stash))
    0          
    0          
    0          
    0          
    0          
    0          
1348 0           len = -len;
1349             }
1350 2           if (!self->safeclasses ||
1351 1           !hv_exists(self->safeclasses, klass, len))
1352             {
1353 0           Perl_warner(aTHX_ packWARN(WARN_MISC),
1354             WARNMSG "skipped dumping unsafe ARRAY in class %s",
1355             klass);
1356 0           array_size = 0;
1357             }
1358             }
1359              
1360 44           yaml_sequence_start_event_initialize(
1361             &event_sequence_start, anchor, tag, 0, YAML_BLOCK_SEQUENCE_STYLE);
1362 44           yaml_emitter_emit(&self->emitter, &event_sequence_start);
1363              
1364 135 100         for (i = 0; i < array_size; i++) {
1365 91           SV **entry = av_fetch(array, i, 0);
1366 91 50         if (entry == NULL)
1367 0           dump_node(self, &PL_sv_undef);
1368             else
1369 91           dump_node(self, *entry);
1370             }
1371 44           yaml_sequence_end_event_initialize(&event_sequence_end);
1372 44           yaml_emitter_emit(&self->emitter, &event_sequence_end);
1373             }
1374              
1375             static void
1376 267           dump_scalar(YAML *self, SV *node, yaml_char_t *tag)
1377             {
1378             yaml_event_t event_scalar;
1379             char *string;
1380             STRLEN string_len;
1381             int plain_implicit, quoted_implicit;
1382 267           yaml_scalar_style_t style = YAML_PLAIN_SCALAR_STYLE;
1383              
1384 267 100         if (tag) {
1385 8 100         if (self->flags & F_SAFEMODE && SvOBJECT(node)) {
    50          
1386 1           HV* stash = SvSTASH(node);
1387 1 50         char *klass = HvNAME_get(stash);
    50          
    50          
    0          
    50          
    50          
1388 1 50         STRLEN len = HvNAMELEN_get(stash);
    50          
    50          
    0          
    50          
    50          
1389 1 50         if (HvNAMEUTF8(stash))
    50          
    50          
    50          
    50          
    50          
    50          
1390 0           len = -len;
1391 2           if (!self->safeclasses ||
1392 1           !hv_exists(self->safeclasses, klass, len))
1393             {
1394 0           Perl_warner(aTHX_ packWARN(WARN_MISC),
1395             WARNMSG "skipped dumping unsafe SCALAR for class %s",
1396             klass);
1397 0           node = &PL_sv_undef;
1398             }
1399             }
1400 8           plain_implicit = quoted_implicit = 0;
1401             }
1402             else {
1403 259           tag = (yaml_char_t *)TAG_PERL_STR;
1404 259           plain_implicit = quoted_implicit = 1;
1405             }
1406              
1407 267 100         SvGETMAGIC(node);
    50          
1408 267 100         if (!SvOK(node)) {
    50          
    50          
1409 6           string = "~";
1410 6           string_len = 1;
1411 6           style = YAML_PLAIN_SCALAR_STYLE;
1412             }
1413 261 100         else if (node == &PL_sv_yes) {
1414 6           string = "true";
1415 6           string_len = 4;
1416 6           style = YAML_PLAIN_SCALAR_STYLE;
1417             }
1418 255 100         else if (node == &PL_sv_no) {
1419 6           string = "false";
1420 6           string_len = 5;
1421 6           style = YAML_PLAIN_SCALAR_STYLE;
1422             }
1423             else {
1424 249           SV *node_clone = sv_mortalcopy(node);
1425 249 100         string = SvPV_nomg(node_clone, string_len);
1426 249 100         if (
1427 244 100         (string_len == 0) ||
1428 244 100         (string_len == 1 && strEQ(string, "~")) ||
    100          
1429 25 100         (string_len == 4 &&
1430 238 50         (strEQ(string, "true") || strEQ(string, "null"))) ||
    100          
1431 238 100         (string_len == 5 && strEQ(string, "false")) ||
    50          
1432 233 100         (SvTYPE(node_clone) >= SVt_PVGV) ||
1433 226 100         ( (self->flags & F_QUOTENUM) &&
1434 180 100         !SvNIOK(node_clone) &&
1435 180           looks_like_number(node_clone) ) )
1436             {
1437 20           style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
1438             } else {
1439 229 100         if (!SvUTF8(node_clone)) {
1440             /* copy to new SV and promote to utf8 */
1441 200           SV *utf8sv = sv_mortalcopy(node_clone);
1442              
1443             /* get string and length out of utf8 */
1444 200 50         string = SvPVutf8(utf8sv, string_len);
1445             }
1446 229 100         if(strchr(string, '\n'))
1447 4 100         style = (string_len > 30) ? YAML_LITERAL_SCALAR_STYLE
1448             : YAML_DOUBLE_QUOTED_SCALAR_STYLE;
1449             }
1450             }
1451 267           yaml_scalar_event_initialize(
1452             &event_scalar,
1453             NULL, /* anchor */
1454             tag,
1455             (unsigned char *) string,
1456             (int) string_len,
1457             plain_implicit,
1458             quoted_implicit,
1459             style);
1460 267 50         if (! yaml_emitter_emit(&self->emitter, &event_scalar))
1461 0           croak("%sEmit scalar '%s', error: %s\n",
1462             ERRMSG, string, self->emitter.problem);
1463 267           }
1464              
1465             static void
1466 5           dump_code(YAML *self, SV *node)
1467             {
1468             yaml_event_t event_scalar;
1469             yaml_char_t *tag;
1470 5           yaml_scalar_style_t style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
1471 5           char *string = "{ \"DUMMY\" }";
1472              
1473 5           tag = get_yaml_tag(node);
1474              
1475 5 100         if (self->flags & F_DUMPCODE) {
1476             /* load_module(PERL_LOADMOD_NOIMPORT, newSVpv("B::Deparse", 0), NULL);
1477             */
1478             SV *code;
1479 3           SV *result = NULL;
1480 3 100         if (self->flags & F_SAFEMODE) {
1481             char *klass; STRLEN len;
1482 2           SV* rnode = SvRV(node);
1483 4           HV* stash = SvOBJECT(rnode)
1484 2           ? SvSTASH(rnode)
1485 2 50         : GvSTASH(CvGV(rnode));
1486 2 50         if (!stash)
1487 0           stash = CvSTASH(rnode);
1488 2 50         klass = HvNAME_get(stash);
    50          
    50          
    0          
    50          
    50          
1489 2 50         len = HvNAMELEN_get(stash);
    50          
    50          
    0          
    50          
    50          
1490 2 50         if (HvNAMEUTF8(stash))
    50          
    50          
    50          
    50          
    50          
    50          
1491 0           len = -len;
1492 2 50         if (!self->safeclasses || !hv_exists(self->safeclasses, klass, len)) {
    100          
1493 1           Perl_warner(aTHX_ packWARN(WARN_MISC),
1494             WARNMSG "skipped dumping unsafe CODE for class %s",
1495             klass);
1496 1           string = "{ \"UNSAFE\" }";
1497 1           result = &PL_sv_undef;
1498             }
1499             }
1500 3 100         if (result != &PL_sv_undef) {
1501 2           AV *args = newAV();
1502 2           av_push(args, SvREFCNT_inc(node));
1503 2           code = find_coderef("YAML::Safe::coderef2text");
1504 2           result = call_coderef(code, (AV*)sv_2mortal((SV *)args));
1505             }
1506 3 50         if (result && result != &PL_sv_undef) {
    100          
1507 2 50         string = SvPV_nolen(result);
1508 2           style = YAML_LITERAL_SCALAR_STYLE;
1509             }
1510             }
1511              
1512 5 50         yaml_scalar_event_initialize(
1513             &event_scalar,
1514             NULL, /* anchor */
1515             tag,
1516             (unsigned char *)string,
1517 5           string ? strlen(string) : 0,
1518             0,
1519             0,
1520             style);
1521 5           yaml_emitter_emit(&self->emitter, &event_scalar);
1522 5           }
1523              
1524             static SV *
1525 2           dump_glob(YAML *self, SV *node)
1526             {
1527             SV *result;
1528 2           SV *code = find_coderef("YAML::Safe::glob2hash");
1529 2           AV *args = newAV();
1530             /* TODO: safemode */
1531 2           av_push(args, SvREFCNT_inc(node));
1532 2           args = (AV *)sv_2mortal((SV *)args);
1533 2           result = call_coderef(code, args);
1534 2           (void)hv_store(self->shadows, (char *)&node, sizeof(node),
1535             result, 0);
1536 2           return result;
1537             }
1538              
1539             /* XXX Refo this to just dump a special map */
1540             static void
1541 22           dump_ref(YAML *self, SV *node)
1542             {
1543             yaml_event_t event_mapping_start;
1544             yaml_event_t event_mapping_end;
1545             yaml_event_t event_scalar;
1546 22           SV *referent = SvRV(node);
1547              
1548 22           yaml_char_t *anchor = get_yaml_anchor(self, referent);
1549 22 100         if (anchor && strEQ((char *)anchor, ""))
    100          
1550 3           return;
1551              
1552 19           yaml_mapping_start_event_initialize(
1553             &event_mapping_start, anchor,
1554             (unsigned char *)TAG_PERL_PREFIX "ref",
1555             0, YAML_BLOCK_MAPPING_STYLE);
1556 19           yaml_emitter_emit(&self->emitter, &event_mapping_start);
1557              
1558 19           yaml_scalar_event_initialize(
1559             &event_scalar,
1560             NULL, /* anchor */
1561             NULL, /* tag */
1562             (unsigned char *)"=", 1,
1563             1, 1,
1564             YAML_PLAIN_SCALAR_STYLE);
1565 19           yaml_emitter_emit(&self->emitter, &event_scalar);
1566 19           dump_node(self, referent);
1567              
1568 19           yaml_mapping_end_event_initialize(&event_mapping_end);
1569 19           yaml_emitter_emit(&self->emitter, &event_mapping_end);
1570             }
1571              
1572             static int
1573 103           yaml_sv_write_handler(void *sv, unsigned char *buffer, size_t size)
1574             {
1575 103           sv_catpvn((SV *)sv, (const char *)buffer, (STRLEN)size);
1576 103           return 1;
1577             }
1578              
1579             static int
1580 4           yaml_perlio_read_handler(void *data, unsigned char *buffer, size_t size, size_t *size_read)
1581             {
1582 4           YAML *self = (YAML *)data;
1583              
1584 4           *size_read = PerlIO_read(self->perlio, buffer, size);
1585 4           return !PerlIO_error(self->perlio);
1586             }
1587              
1588             static int
1589 2           yaml_perlio_write_handler(void *data, unsigned char *buffer, size_t size)
1590             {
1591 2           YAML *self = (YAML *)data;
1592 2           return (PerlIO_write(self->perlio, (char*)buffer, (long)size) == (SSize_t)size);
1593             }
1594              
1595             /* XXX Make -Wall not complain about 'local_patches' not being used. */
1596             #if !defined(PERL_PATCHLEVEL_H_IMPLICIT)
1597 0           void xxx_local_patches() {
1598 0 0         if (local_patches[0])
1599 0           printf("%s", local_patches[0]);
1600 0           }
1601             #endif
1602              
1603             void
1604 23           yaml_destroy (YAML *self)
1605             {
1606 23 50         if (!self)
1607 0           return;
1608             /* self->filename gets deleted with sv_file */
1609 23           yaml_parser_delete (&self->parser);
1610 23           yaml_event_delete (&self->event);
1611 23           yaml_emitter_delete (&self->emitter);
1612 23           Zero(self, 1, YAML);
1613             }