← Back to branch summary

~ubuntu-branches/debian/sid/libyaml-libyaml-perl/sid

« back to all changes in this revision

Viewing changes to .pc/fix_ftbfs_hardening_flags.diff/LibYAML/perl_libyaml.c

  • Committer: Package Import Robot
  • Author(s): Niko Tyni, Julián Moreno Patiño, Niko Tyni
  • Date: 2012-03-10 08:57:07 UTC
  • Revision ID: package-import@ubuntu.com-20120310085707-bkfpg839l9fvj59w
Tags: 0.38-2
http://bugs.debian.org/661548
* Team upload.

[ Julián Moreno Patiño ]
* Enable hardening flags. (Closes: #661548)
  + Switch compat level 8 to 9.
  + Add fix_ftbfs_hardening_flags.diff patch.
  + Bump debhelper version to 9.
* Bump Standards-Version to 3.9.3.
  + Update to DEP5 copyright-format 1.0.
    + Add /me to debian copyright.

[ Niko Tyni ]
* Note that this fixes CVE-2012-1152.
* Upload at urgency=medium

Show diffs side-by-side

added added

removed removed

Lines of Context:
.pc/fix_ftbfs_hardening_flags.diff/LibYAML/perl_libyaml.c
 
1
#include <perl_libyaml.h>
 
2
 
 
3
static SV *
 
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 *
 
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(ERRMSG "Call error");
 
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 *
 
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 *
 
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: %d, column: %d\n",
 
97
            msg,
 
98
            loader->parser.problem_mark.line + 1,
 
99
            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: %d, column: %d\n",
 
105
            msg,
 
106
            loader->parser.context,
 
107
            loader->parser.context_mark.line + 1,
 
108
            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
 
119
Load(SV *yaml_sv)
 
120
{
 
121
    dXSARGS;
 
122
    perl_yaml_loader_t loader;
 
123
    SV *node;
 
124
    const unsigned char *yaml_str;
 
125
    STRLEN yaml_len;
 
126
 
 
127
    yaml_str = (const unsigned char *)SvPV_const(yaml_sv, yaml_len);
 
128
 
 
129
    if (DO_UTF8(yaml_sv)) {
 
130
        yaml_sv = sv_mortalcopy(yaml_sv);
 
131
        if (!sv_utf8_downgrade(yaml_sv, TRUE))
 
132
            croak("Wide character in YAML::XS::Load()");
 
133
        yaml_str = (const unsigned char *)SvPV_const(yaml_sv, yaml_len);
 
134
    }
 
135
 
 
136
    sp = mark;
 
137
    if (0 && (items || ax)) {} /* XXX Quiet the -Wall warnings for now. */
 
138
 
 
139
    yaml_parser_initialize(&loader.parser);
 
140
    loader.document = 0;
 
141
    yaml_parser_set_input_string(
 
142
        &loader.parser,
 
143
        yaml_str,
 
144
        yaml_len
 
145
    );
 
146
 
 
147
    /* Get the first event. Must be a STREAM_START */
 
148
    if (!yaml_parser_parse(&loader.parser, &loader.event))
 
149
        goto load_error;
 
150
    if (loader.event.type != YAML_STREAM_START_EVENT)
 
151
        croak(ERRMSG "Expected STREAM_START_EVENT; Got: %d != %d",
 
152
            loader.event.type,
 
153
            YAML_STREAM_START_EVENT
 
154
         );
 
155
 
 
156
    loader.anchors = newHV();
 
157
    sv_2mortal((SV *)loader.anchors);
 
158
 
 
159
    /* Keep calling load_node until end of stream */
 
160
    while (1) {
 
161
        loader.document++;
 
162
        /* We are through with the previous event - delete it! */
 
163
        yaml_event_delete(&loader.event);
 
164
        if (!yaml_parser_parse(&loader.parser, &loader.event))
 
165
            goto load_error;
 
166
        if (loader.event.type == YAML_STREAM_END_EVENT)
 
167
            break;
 
168
        node = load_node(&loader);
 
169
        /* We are through with the previous event - delete it! */
 
170
        yaml_event_delete(&loader.event);
 
171
        hv_clear(loader.anchors);
 
172
        if (! node) break;
 
173
        XPUSHs(sv_2mortal(node));
 
174
        if (!yaml_parser_parse(&loader.parser, &loader.event))
 
175
            goto load_error;
 
176
        if (loader.event.type != YAML_DOCUMENT_END_EVENT)
 
177
            croak(ERRMSG "Expected DOCUMENT_END_EVENT");
 
178
    }
 
179
 
 
180
    /* Make sure the last event is a STREAM_END */
 
181
    if (loader.event.type != YAML_STREAM_END_EVENT)
 
182
        croak(ERRMSG "Expected STREAM_END_EVENT; Got: %d != %d",
 
183
            loader.event.type,
 
184
            YAML_STREAM_END_EVENT
 
185
         );
 
186
    yaml_parser_delete(&loader.parser);
 
187
    PUTBACK;
 
188
    return;
 
189
 
 
190
load_error:
 
191
    croak(loader_error_msg(&loader, NULL));
 
192
}
 
193
 
 
194
/*
 
195
 * This is the main function for dumping any node.
 
196
 */
 
197
SV *
 
198
load_node(perl_yaml_loader_t *loader)
 
199
{
 
200
    SV* return_sv = NULL;
 
201
    /* This uses stack, but avoids (severe!) memory leaks */
 
202
    yaml_event_t uplevel_event;
 
203
 
 
204
    uplevel_event = loader->event;
 
205
 
 
206
    /* Get the next parser event */
 
207
    if (!yaml_parser_parse(&loader->parser, &loader->event))
 
208
        goto load_error;
 
209
 
 
210
    /* These events don't need yaml_event_delete */
 
211
    /* Some kind of error occurred */
 
212
    if (loader->event.type == YAML_NO_EVENT)
 
213
        goto load_error;
 
214
 
 
215
    /* Return NULL when we hit the end of a scope */
 
216
    if (loader->event.type == YAML_DOCUMENT_END_EVENT ||
 
217
        loader->event.type == YAML_MAPPING_END_EVENT ||
 
218
        loader->event.type == YAML_SEQUENCE_END_EVENT) {
 
219
            /* restore the uplevel event, so it can be properly deleted */
 
220
            loader->event = uplevel_event;
 
221
            return return_sv;
 
222
    }
 
223
 
 
224
    /* The rest all need cleanup */
 
225
    switch (loader->event.type) {
 
226
        char *tag;
 
227
 
 
228
        /* Handle loading a mapping */
 
229
        case YAML_MAPPING_START_EVENT:
 
230
            tag = (char *)loader->event.data.mapping_start.tag;
 
231
 
 
232
            /* Handle mapping tagged as a Perl hard reference */
 
233
            if (tag && strEQ(tag, TAG_PERL_REF)) {
 
234
                return_sv = load_scalar_ref(loader);
 
235
                break;
 
236
            }
 
237
 
 
238
            /* Handle mapping tagged as a Perl typeglob */
 
239
            if (tag && strEQ(tag, TAG_PERL_GLOB)) {
 
240
                return_sv = load_glob(loader);
 
241
                break;
 
242
            }
 
243
 
 
244
            return_sv = load_mapping(loader, NULL);
 
245
            break;
 
246
 
 
247
        /* Handle loading a sequence into an array */
 
248
        case YAML_SEQUENCE_START_EVENT:
 
249
            return_sv = load_sequence(loader);
 
250
            break;
 
251
 
 
252
        /* Handle loading a scalar */
 
253
        case YAML_SCALAR_EVENT:
 
254
            return_sv = load_scalar(loader);
 
255
            break;
 
256
 
 
257
        /* Handle loading an alias node */
 
258
        case YAML_ALIAS_EVENT:
 
259
            return_sv = load_alias(loader);
 
260
            break;
 
261
 
 
262
        default:
 
263
            croak(ERRMSG "Invalid event '%d' at top level", (int) loader->event.type);
 
264
    }
 
265
 
 
266
    yaml_event_delete(&loader->event);
 
267
 
 
268
    /* restore the uplevel event, so it can be properly deleted */
 
269
    loader->event = uplevel_event;
 
270
 
 
271
    return return_sv;
 
272
 
 
273
    load_error:
 
274
        croak(loader_error_msg(loader, NULL));
 
275
}
 
276
 
 
277
/*
 
278
 * Load a YAML mapping into a Perl hash
 
279
 */
 
280
SV *
 
281
load_mapping(perl_yaml_loader_t *loader, char *tag)
 
282
{
 
283
    SV *key_node;
 
284
    SV *value_node;
 
285
    HV *hash = newHV();
 
286
    SV *hash_ref = (SV *)newRV_noinc((SV *)hash);
 
287
    char *anchor = (char *)loader->event.data.mapping_start.anchor;
 
288
 
 
289
    if (!tag)
 
290
        tag = (char *)loader->event.data.mapping_start.tag;
 
291
 
 
292
    /* Store the anchor label if any */
 
293
    if (anchor)
 
294
        hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(hash_ref), 0);
 
295
 
 
296
    /* Get each key string and value node and put them in the hash */
 
297
    while ((key_node = load_node(loader))) {
 
298
        assert(SvPOK(key_node));
 
299
        value_node = load_node(loader);
 
300
        hv_store_ent(
 
301
            hash, sv_2mortal(key_node), value_node, 0
 
302
        );
 
303
    } 
 
304
 
 
305
    /* Deal with possibly blessing the hash if the YAML tag has a class */
 
306
    if (tag && strEQ(tag, TAG_PERL_PREFIX "hash"))
 
307
        tag = NULL;
 
308
    if (tag) {
 
309
        char *class;
 
310
        char *prefix = TAG_PERL_PREFIX "hash:";
 
311
        if (*tag == '!') {
 
312
            prefix = "!";
 
313
        }
 
314
        else if (strlen(tag) <= strlen(prefix) ||
 
315
            ! strnEQ(tag, prefix, strlen(prefix))
 
316
        ) croak(
 
317
            loader_error_msg(loader, form("bad tag found for hash: '%s'", tag))
 
318
        );
 
319
        class = tag + strlen(prefix);
 
320
        sv_bless(hash_ref, gv_stashpv(class, TRUE)); 
 
321
    }
 
322
 
 
323
    return hash_ref;
 
324
}
 
325
 
 
326
/* Load a YAML sequence into a Perl array */
 
327
SV *
 
328
load_sequence(perl_yaml_loader_t *loader)
 
329
{
 
330
    SV *node;
 
331
    AV *array = newAV();
 
332
    SV *array_ref = (SV *)newRV_noinc((SV *)array);
 
333
    char *anchor = (char *)loader->event.data.sequence_start.anchor;
 
334
    char *tag = (char *)loader->event.data.mapping_start.tag;
 
335
    if (anchor)
 
336
        hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(array_ref), 0);
 
337
    while ((node = load_node(loader))) {
 
338
        av_push(array, node);
 
339
    } 
 
340
    if (tag && strEQ(tag, TAG_PERL_PREFIX "array"))
 
341
        tag = NULL;
 
342
    if (tag) {
 
343
        char *class;
 
344
        char *prefix = TAG_PERL_PREFIX "array:";
 
345
        if (*tag == '!')
 
346
            prefix = "!";
 
347
        else if (strlen(tag) <= strlen(prefix) ||
 
348
            ! strnEQ(tag, prefix, strlen(prefix))
 
349
        ) croak(
 
350
            loader_error_msg(loader, form("bad tag found for array: '%s'", tag))
 
351
        );
 
352
        class = tag + strlen(prefix);
 
353
        sv_bless(array_ref, gv_stashpv(class, TRUE)); 
 
354
    }
 
355
    return array_ref;
 
356
}
 
357
 
 
358
/* Load a YAML scalar into a Perl scalar */
 
359
SV *
 
360
load_scalar(perl_yaml_loader_t *loader)
 
361
{
 
362
    SV *scalar;
 
363
    char *string = (char *)loader->event.data.scalar.value;
 
364
    STRLEN length = (STRLEN)loader->event.data.scalar.length;
 
365
    char *anchor = (char *)loader->event.data.scalar.anchor;
 
366
    char *tag = (char *)loader->event.data.scalar.tag;
 
367
    if (tag) {
 
368
        char *class;
 
369
        char *prefix = TAG_PERL_PREFIX "regexp";
 
370
        if (strnEQ(tag, prefix, strlen(prefix)))
 
371
            return load_regexp(loader);
 
372
        prefix = TAG_PERL_PREFIX "scalar:";
 
373
        if (*tag == '!')
 
374
            prefix = "!";
 
375
        else if (strlen(tag) <= strlen(prefix) ||
 
376
            ! strnEQ(tag, prefix, strlen(prefix))
 
377
        ) croak(ERRMSG "bad tag found for scalar: '%s'", tag);
 
378
        class = tag + strlen(prefix);
 
379
        scalar = sv_setref_pvn(newSV(0), class, string, strlen(string));
 
380
        SvUTF8_on(scalar);
 
381
    return scalar;
 
382
    }
 
383
 
 
384
    if (loader->event.data.scalar.style == YAML_PLAIN_SCALAR_STYLE) {
 
385
        if (strEQ(string, "~"))
 
386
            return newSV(0);
 
387
        else if (strEQ(string, ""))
 
388
            return newSV(0);
 
389
        else if (strEQ(string, "null"))
 
390
            return newSV(0);
 
391
        else if (strEQ(string, "true"))
 
392
            return &PL_sv_yes;
 
393
        else if (strEQ(string, "false"))
 
394
            return &PL_sv_no;
 
395
    }
 
396
 
 
397
    scalar = newSVpvn(string, length);
 
398
 
 
399
    if (loader->event.data.scalar.style == YAML_PLAIN_SCALAR_STYLE && looks_like_number(scalar) ) {
 
400
        /* numify */
 
401
        SvIV_please(scalar);
 
402
    }
 
403
 
 
404
    (void)sv_utf8_decode(scalar);
 
405
    if (anchor)
 
406
        hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(scalar), 0);
 
407
    return scalar;
 
408
}
 
409
 
 
410
/* Load a scalar marked as a regexp as a Perl regular expression.
 
411
 * This operation is less common and is tricky, so doing it in Perl code for
 
412
 * now.
 
413
 */
 
414
SV *
 
415
load_regexp(perl_yaml_loader_t * loader)
 
416
{
 
417
    dSP;
 
418
    char *string = (char *)loader->event.data.scalar.value;
 
419
    STRLEN length = (STRLEN)loader->event.data.scalar.length;
 
420
    char *anchor = (char *)loader->event.data.scalar.anchor;
 
421
    char *tag = (char *)loader->event.data.scalar.tag;
 
422
    char *prefix = TAG_PERL_PREFIX "regexp:";
 
423
 
 
424
    SV *regexp = newSVpvn(string, length);
 
425
    SvUTF8_on(regexp);
 
426
 
 
427
    ENTER;
 
428
    SAVETMPS;
 
429
    PUSHMARK(sp);
 
430
    XPUSHs(regexp);
 
431
    PUTBACK;
 
432
    call_pv("YAML::XS::__qr_loader", G_SCALAR);
 
433
    SPAGAIN;
 
434
    regexp = newSVsv(POPs);
 
435
 
 
436
    if (strlen(tag) > strlen(prefix) && strnEQ(tag, prefix, strlen(prefix))) {
 
437
        char *class = tag + strlen(prefix);
 
438
        sv_bless(regexp, gv_stashpv(class, TRUE));
 
439
    }
 
440
 
 
441
    if (anchor)
 
442
        hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(regexp), 0);
 
443
    return regexp;
 
444
}
 
445
 
 
446
/*
 
447
 * Load a reference to a previously loaded node.
 
448
 */
 
449
SV *
 
450
load_alias(perl_yaml_loader_t *loader)
 
451
{
 
452
    char *anchor = (char *)loader->event.data.alias.anchor;
 
453
    SV **entry = hv_fetch(loader->anchors, anchor, strlen(anchor), 0);
 
454
    if (entry)
 
455
        return SvREFCNT_inc(*entry);
 
456
    croak(ERRMSG "No anchor for alias '%s'", anchor);
 
457
}
 
458
 
 
459
/*
 
460
 * Load a Perl hard reference.
 
461
 */
 
462
SV *
 
463
load_scalar_ref(perl_yaml_loader_t *loader)
 
464
{
 
465
    SV *value_node;
 
466
    char *anchor = (char *)loader->event.data.mapping_start.anchor;
 
467
    SV *rv = newRV_noinc(&PL_sv_undef);
 
468
    if (anchor)
 
469
        hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(rv), 0);
 
470
    load_node(loader);  /* Load the single hash key (=) */
 
471
    value_node = load_node(loader);
 
472
    SvRV(rv) = value_node;
 
473
    if (load_node(loader)) 
 
474
        croak(ERRMSG "Expected end of node");
 
475
    return rv;
 
476
}
 
477
 
 
478
/*
 
479
 * Load a Perl typeglob.
 
480
 */
 
481
SV *
 
482
load_glob(perl_yaml_loader_t *loader)
 
483
{
 
484
    /* XXX Call back a Perl sub to do something interesting here */
 
485
    return load_mapping(loader, TAG_PERL_PREFIX "hash");
 
486
}
 
487
 
 
488
/* -------------------------------------------------------------------------- */
 
489
 
 
490
/*
 
491
 * Set dumper options from global variables.
 
492
 */
 
493
void
 
494
set_dumper_options(perl_yaml_dumper_t *dumper)
 
495
{
 
496
    GV *gv;
 
497
    dumper->dump_code = (
 
498
        ((gv = gv_fetchpv("YAML::XS::UseCode", TRUE, SVt_PV)) &&
 
499
        SvTRUE(GvSV(gv)))
 
500
    ||
 
501
        ((gv = gv_fetchpv("YAML::XS::DumpCode", TRUE, SVt_PV)) &&
 
502
        SvTRUE(GvSV(gv)))
 
503
    );
 
504
 
 
505
    dumper->quote_number_strings = (
 
506
        ((gv = gv_fetchpv("YAML::XS::QuoteNumericStrings", TRUE, SVt_PV)) &&
 
507
        SvTRUE(GvSV(gv)))
 
508
    );
 
509
}
 
510
 
 
511
/*
 
512
 * This is the main Dump function.
 
513
 * Take zero or more Perl objects and return a YAML stream (as a string)
 
514
 */
 
515
void
 
516
Dump(SV *dummy, ...)
 
517
{
 
518
    dXSARGS;
 
519
    perl_yaml_dumper_t dumper;
 
520
    yaml_event_t event_stream_start;
 
521
    yaml_event_t event_stream_end;
 
522
    int i;
 
523
    SV *yaml = sv_2mortal(newSVpvn("", 0));
 
524
    sp = mark;
 
525
 
 
526
    set_dumper_options(&dumper);
 
527
 
 
528
    /* Set up the emitter object and begin emitting */
 
529
    yaml_emitter_initialize(&dumper.emitter);
 
530
    yaml_emitter_set_unicode(&dumper.emitter, 1);
 
531
    yaml_emitter_set_width(&dumper.emitter, 2);
 
532
    yaml_emitter_set_output(
 
533
        &dumper.emitter,
 
534
        &append_output,
 
535
        (void *) yaml
 
536
    );
 
537
    yaml_stream_start_event_initialize(
 
538
        &event_stream_start,
 
539
        YAML_UTF8_ENCODING
 
540
    );
 
541
    yaml_emitter_emit(&dumper.emitter, &event_stream_start);
 
542
 
 
543
    dumper.anchors = newHV();
 
544
    dumper.shadows = newHV();
 
545
 
 
546
    sv_2mortal((SV *)dumper.anchors);
 
547
    sv_2mortal((SV *)dumper.shadows);
 
548
 
 
549
    for (i = 0; i < items; i++) {
 
550
        dumper.anchor = 0;
 
551
 
 
552
        dump_prewalk(&dumper, ST(i));
 
553
        dump_document(&dumper, ST(i));
 
554
 
 
555
        hv_clear(dumper.anchors);
 
556
        hv_clear(dumper.shadows);
 
557
    }
 
558
 
 
559
    /* End emitting and destroy the emitter object */
 
560
    yaml_stream_end_event_initialize(&event_stream_end);
 
561
    yaml_emitter_emit(&dumper.emitter, &event_stream_end);
 
562
    yaml_emitter_delete(&dumper.emitter);
 
563
 
 
564
    /* Put the YAML stream scalar on the XS output stack */
 
565
    if (yaml) {
 
566
        SvUTF8_off(yaml);
 
567
        XPUSHs(yaml);
 
568
    }
 
569
    PUTBACK;
 
570
}
 
571
 
 
572
/*
 
573
 * In order to know which nodes will need anchors (for later aliasing) it is
 
574
 * necessary to walk the entire data structure first. Once a node has been
 
575
 * seen twice you can stop walking it. That way we can handle circular refs.
 
576
 * All the node information is stored in an HV.
 
577
 */
 
578
void
 
579
dump_prewalk(perl_yaml_dumper_t *dumper, SV *node)
 
580
{
 
581
    int i, len;
 
582
    U32 ref_type;
 
583
 
 
584
    if (! (SvROK(node) || SvTYPE(node) == SVt_PVGV)) return;
 
585
 
 
586
    {
 
587
        SV *object = SvROK(node) ? SvRV(node) : node;
 
588
        SV **seen =
 
589
            hv_fetch(dumper->anchors, (char *)&object, sizeof(object), 0);
 
590
        if (seen) {
 
591
            if (*seen == &PL_sv_undef) {
 
592
                hv_store(
 
593
                    dumper->anchors, (char *)&object, sizeof(object),
 
594
                    &PL_sv_yes, 0
 
595
                );
 
596
            }
 
597
            return;
 
598
        }
 
599
        hv_store(
 
600
            dumper->anchors, (char *)&object, sizeof(object), &PL_sv_undef, 0
 
601
        );
 
602
    }
 
603
 
 
604
    if (SvTYPE(node) == SVt_PVGV) {
 
605
        node = dump_glob(dumper, node);
 
606
    }
 
607
 
 
608
    ref_type = SvTYPE(SvRV(node));
 
609
    if (ref_type == SVt_PVAV) {
 
610
        AV *array = (AV *)SvRV(node);
 
611
        int array_size = av_len(array) + 1;
 
612
        for (i = 0; i < array_size; i++) {
 
613
            SV **entry = av_fetch(array, i, 0);
 
614
            if (entry)
 
615
                dump_prewalk(dumper, *entry);
 
616
        }
 
617
    }
 
618
    else if (ref_type == SVt_PVHV) {
 
619
        HV *hash = (HV *)SvRV(node);
 
620
        HE *he;
 
621
        hv_iterinit(hash);
 
622
        while ((he = hv_iternext(hash))) {
 
623
            SV *val = HeVAL(he);
 
624
            if (val)
 
625
                dump_prewalk(dumper, val);
 
626
        }
 
627
    }
 
628
    else if (ref_type <= SVt_PVNV || ref_type == SVt_PVGV) {
 
629
        SV *scalar = SvRV(node);
 
630
        dump_prewalk(dumper, scalar);
 
631
    }
 
632
}
 
633
 
 
634
void
 
635
dump_document(perl_yaml_dumper_t *dumper, SV *node)
 
636
{
 
637
    yaml_event_t event_document_start;
 
638
    yaml_event_t event_document_end;
 
639
    yaml_document_start_event_initialize(
 
640
        &event_document_start, NULL, NULL, NULL, 0
 
641
    );
 
642
    yaml_emitter_emit(&dumper->emitter, &event_document_start);
 
643
    dump_node(dumper, node);
 
644
    yaml_document_end_event_initialize(&event_document_end, 1);
 
645
    yaml_emitter_emit(&dumper->emitter, &event_document_end);
 
646
}
 
647
 
 
648
void
 
649
dump_node(perl_yaml_dumper_t *dumper, SV *node)
 
650
{
 
651
    yaml_char_t *anchor = NULL;
 
652
    yaml_char_t *tag = NULL;
 
653
    const char *class = NULL;
 
654
 
 
655
    if (SvTYPE(node) == SVt_PVGV) {
 
656
        SV **svr;
 
657
        tag = (yaml_char_t *)TAG_PERL_PREFIX "glob";
 
658
        anchor = get_yaml_anchor(dumper, node);
 
659
        if (anchor && strEQ((char *)anchor, "")) return;
 
660
        svr = hv_fetch(dumper->shadows, (char *)&node, sizeof(node), 0);
 
661
        if (svr) {
 
662
            node = SvREFCNT_inc(*svr);
 
663
        }
 
664
    }
 
665
 
 
666
    if (SvROK(node)) {
 
667
        SV *rnode = SvRV(node);
 
668
        U32 ref_type = SvTYPE(rnode);
 
669
        if (ref_type == SVt_PVHV)
 
670
            dump_hash(dumper, node, anchor, tag);
 
671
        else if (ref_type == SVt_PVAV)
 
672
            dump_array(dumper, node);
 
673
        else if (ref_type <= SVt_PVNV || ref_type == SVt_PVGV)
 
674
            dump_ref(dumper, node);
 
675
        else if (ref_type == SVt_PVCV)
 
676
            dump_code(dumper, node);
 
677
        else if (ref_type == SVt_PVMG) {
 
678
            MAGIC *mg;
 
679
            yaml_char_t *tag = NULL;
 
680
            if (SvMAGICAL(rnode)) {
 
681
                if ((mg = mg_find(rnode, PERL_MAGIC_qr))) {
 
682
                    tag = (yaml_char_t *)form(TAG_PERL_PREFIX "regexp");
 
683
                    class = sv_reftype(rnode, TRUE);
 
684
                    if (!strEQ(class, "Regexp"))
 
685
                        tag = (yaml_char_t *)form("%s:%s", tag, class);
 
686
                }
 
687
            }
 
688
            else {
 
689
                tag = (yaml_char_t *)form(
 
690
                    TAG_PERL_PREFIX "scalar:%s",
 
691
                    sv_reftype(rnode, TRUE)
 
692
                );
 
693
                node = rnode;
 
694
            }
 
695
            dump_scalar(dumper, node, tag);
 
696
        }
 
697
#if PERL_REVISION > 5 || (PERL_REVISION == 5 && PERL_VERSION >= 11)
 
698
        else if (ref_type == SVt_REGEXP) {
 
699
            yaml_char_t *tag = (yaml_char_t *)form(TAG_PERL_PREFIX "regexp");
 
700
            class = sv_reftype(rnode, TRUE);
 
701
                if (!strEQ(class, "Regexp"))
 
702
                     tag = (yaml_char_t *)form("%s:%s", tag, class);
 
703
            dump_scalar(dumper, node, tag);
 
704
        }
 
705
#endif
 
706
        else {
 
707
            printf(
 
708
                "YAML::XS dump unhandled ref. type == '%d'!\n",
 
709
                (int)ref_type
 
710
            );
 
711
            dump_scalar(dumper, rnode, NULL);
 
712
        }
 
713
    }
 
714
    else {
 
715
        dump_scalar(dumper, node, NULL);
 
716
    }
 
717
}
 
718
 
 
719
yaml_char_t *
 
720
get_yaml_anchor(perl_yaml_dumper_t *dumper, SV *node)
 
721
{
 
722
    yaml_event_t event_alias;
 
723
    SV *iv;
 
724
    SV **seen = hv_fetch(dumper->anchors, (char *)&node, sizeof(node), 0);
 
725
    if (seen && *seen != &PL_sv_undef) {
 
726
        if (*seen == &PL_sv_yes) {
 
727
            dumper->anchor++;
 
728
            iv = newSViv(dumper->anchor);
 
729
            hv_store(dumper->anchors, (char *)&node, sizeof(node), iv, 0);
 
730
            return (yaml_char_t*)SvPV_nolen(iv);
 
731
        }
 
732
        else {
 
733
            yaml_char_t *anchor = (yaml_char_t *)SvPV_nolen(*seen);
 
734
            yaml_alias_event_initialize(&event_alias, anchor);
 
735
            yaml_emitter_emit(&dumper->emitter, &event_alias);
 
736
            return (yaml_char_t *) "";
 
737
        }
 
738
    }
 
739
    return NULL;
 
740
}
 
741
 
 
742
yaml_char_t *
 
743
get_yaml_tag(SV *node)
 
744
{
 
745
    yaml_char_t *tag;
 
746
    const char *class;
 
747
    const char *kind = "";
 
748
    if (! (
 
749
        sv_isobject(node) ||
 
750
        (SvRV(node) && ( SvTYPE(SvRV(node)) == SVt_PVCV))
 
751
    )) return NULL;
 
752
    class = sv_reftype(SvRV(node), TRUE);
 
753
 
 
754
    switch (SvTYPE(SvRV(node))) {
 
755
        case SVt_PVAV: { kind = "array"; break; }
 
756
        case SVt_PVHV: { kind = "hash"; break; }
 
757
        case SVt_PVCV: { kind = "code"; break; }
 
758
    }
 
759
    if ((strlen(kind) == 0))
 
760
        tag = (yaml_char_t *)form("%s%s", TAG_PERL_PREFIX, class);
 
761
    else if (SvTYPE(SvRV(node)) == SVt_PVCV && strEQ(class, "CODE"))
 
762
        tag = (yaml_char_t *)form("%s%s", TAG_PERL_PREFIX, kind);
 
763
    else
 
764
        tag = (yaml_char_t *)form("%s%s:%s", TAG_PERL_PREFIX, kind, class);
 
765
    return tag;
 
766
} 
 
767
 
 
768
void
 
769
dump_hash(
 
770
    perl_yaml_dumper_t *dumper, SV *node,
 
771
    yaml_char_t *anchor, yaml_char_t *tag)
 
772
{
 
773
    yaml_event_t event_mapping_start;
 
774
    yaml_event_t event_mapping_end;
 
775
    int i;
 
776
    int len;
 
777
    AV *av;
 
778
    HV *hash = (HV *)SvRV(node);
 
779
    HE *he;
 
780
 
 
781
    if (!anchor)
 
782
        anchor = get_yaml_anchor(dumper, (SV *)hash);
 
783
    if (anchor && strEQ((char*)anchor, "")) return;
 
784
 
 
785
    if (!tag)
 
786
        tag = get_yaml_tag(node);
 
787
    
 
788
    yaml_mapping_start_event_initialize(
 
789
        &event_mapping_start, anchor, tag, 0, YAML_BLOCK_MAPPING_STYLE
 
790
    );
 
791
    yaml_emitter_emit(&dumper->emitter, &event_mapping_start);
 
792
 
 
793
    av = newAV();
 
794
    len = 0;
 
795
    hv_iterinit(hash);
 
796
    while ((he = hv_iternext(hash))) {
 
797
        SV *key = hv_iterkeysv(he);
 
798
        av_store(av, AvFILLp(av)+1, key); /* av_push(), really */
 
799
        len++;
 
800
    }
 
801
    STORE_HASH_SORT;
 
802
    for (i = 0; i < len; i++) {
 
803
        SV *key = av_shift(av);
 
804
        HE *he  = hv_fetch_ent(hash, key, 0, 0);
 
805
        SV *val = he ? HeVAL(he) : NULL;
 
806
        if (val == NULL) { val = &PL_sv_undef; }
 
807
        dump_node(dumper, key);
 
808
        dump_node(dumper, val);
 
809
    }
 
810
 
 
811
    SvREFCNT_dec(av);
 
812
 
 
813
    yaml_mapping_end_event_initialize(&event_mapping_end);
 
814
    yaml_emitter_emit(&dumper->emitter, &event_mapping_end);
 
815
}
 
816
 
 
817
void
 
818
dump_array(perl_yaml_dumper_t *dumper, SV *node)
 
819
{
 
820
    yaml_event_t event_sequence_start;
 
821
    yaml_event_t event_sequence_end;
 
822
    int i;
 
823
    yaml_char_t *tag;
 
824
    AV *array = (AV *)SvRV(node);
 
825
    int array_size = av_len(array) + 1;
 
826
 
 
827
    yaml_char_t *anchor = get_yaml_anchor(dumper, (SV *)array);
 
828
    if (anchor && strEQ((char *)anchor, "")) return;
 
829
    tag = get_yaml_tag(node);
 
830
 
 
831
    yaml_sequence_start_event_initialize(
 
832
        &event_sequence_start, anchor, tag, 0, YAML_BLOCK_SEQUENCE_STYLE
 
833
    );
 
834
 
 
835
    yaml_emitter_emit(&dumper->emitter, &event_sequence_start);
 
836
    for (i = 0; i < array_size; i++) {
 
837
        SV **entry = av_fetch(array, i, 0);
 
838
        if (entry == NULL)
 
839
            dump_node(dumper, &PL_sv_undef);
 
840
        else
 
841
            dump_node(dumper, *entry);
 
842
    }
 
843
    yaml_sequence_end_event_initialize(&event_sequence_end);
 
844
    yaml_emitter_emit(&dumper->emitter, &event_sequence_end);
 
845
}
 
846
 
 
847
void
 
848
dump_scalar(perl_yaml_dumper_t *dumper, SV *node, yaml_char_t *tag)
 
849
{
 
850
    yaml_event_t event_scalar;
 
851
    char *string;
 
852
    STRLEN string_len;
 
853
    int plain_implicit, quoted_implicit;
 
854
    yaml_scalar_style_t style = YAML_PLAIN_SCALAR_STYLE;
 
855
 
 
856
    if (tag) {
 
857
        plain_implicit = quoted_implicit = 0;
 
858
    }
 
859
    else {
 
860
        tag = (yaml_char_t *)TAG_PERL_STR;
 
861
        plain_implicit = quoted_implicit = 1;
 
862
    }
 
863
 
 
864
    SvGETMAGIC(node);
 
865
    if (!SvOK(node)) {
 
866
        string = "~";
 
867
        string_len = 1;
 
868
        style = YAML_PLAIN_SCALAR_STYLE;
 
869
    }
 
870
    else if (node == &PL_sv_yes) {
 
871
        string = "true";
 
872
        string_len = 4;
 
873
        style = YAML_PLAIN_SCALAR_STYLE;
 
874
    }
 
875
    else if (node == &PL_sv_no) {
 
876
        string = "false";
 
877
        string_len = 5;
 
878
        style = YAML_PLAIN_SCALAR_STYLE;
 
879
    }
 
880
    else {
 
881
        string = SvPV_nomg(node, string_len);
 
882
        if (
 
883
            (string_len == 0) ||
 
884
            strEQ(string, "~") ||
 
885
            strEQ(string, "true") ||
 
886
            strEQ(string, "false") ||
 
887
            strEQ(string, "null") ||
 
888
            (SvTYPE(node) >= SVt_PVGV) ||
 
889
            ( dumper->quote_number_strings && !SvNIOK(node) && looks_like_number(node) )
 
890
        ) {
 
891
            style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
 
892
        }
 
893
        if (!SvUTF8(node)) {
 
894
        /* copy to new SV and promote to utf8 */
 
895
        SV *utf8sv = sv_mortalcopy(node);
 
896
 
 
897
        /* get string and length out of utf8 */
 
898
        string = SvPVutf8(utf8sv, string_len);
 
899
        }
 
900
    }
 
901
    yaml_scalar_event_initialize(
 
902
        &event_scalar,
 
903
        NULL,
 
904
        tag,
 
905
        (unsigned char *) string,
 
906
        (int) string_len,
 
907
        plain_implicit,
 
908
        quoted_implicit,
 
909
        style
 
910
    );
 
911
    if (! yaml_emitter_emit(&dumper->emitter, &event_scalar))
 
912
        croak(
 
913
            ERRMSG "Emit scalar '%s', error: %s\n",
 
914
            string, dumper->emitter.problem
 
915
        );
 
916
}
 
917
 
 
918
void
 
919
dump_code(perl_yaml_dumper_t *dumper, SV *node)
 
920
{
 
921
    yaml_event_t event_scalar;
 
922
    yaml_char_t *tag;
 
923
    yaml_scalar_style_t style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
 
924
    char *string = "{ \"DUMMY\" }";
 
925
    if (dumper->dump_code) {
 
926
        /* load_module(PERL_LOADMOD_NOIMPORT, newSVpv("B::Deparse", 0), NULL);
 
927
         */
 
928
        SV *result;
 
929
        SV *code = find_coderef("YAML::XS::coderef2text");
 
930
        AV *args = newAV();
 
931
        av_push(args, SvREFCNT_inc(node));
 
932
        args = (AV *)sv_2mortal((SV *)args);
 
933
        result = call_coderef(code, args);
 
934
        if (result && result != &PL_sv_undef) {
 
935
            string = SvPV_nolen(result);
 
936
            style = YAML_LITERAL_SCALAR_STYLE;
 
937
        }
 
938
    }
 
939
    tag = get_yaml_tag(node);
 
940
    
 
941
    yaml_scalar_event_initialize(
 
942
        &event_scalar,
 
943
        NULL,
 
944
        tag,
 
945
        (unsigned char *)string,
 
946
        strlen(string),
 
947
        0,
 
948
        0,
 
949
        style
 
950
    );
 
951
 
 
952
    yaml_emitter_emit(&dumper->emitter, &event_scalar);
 
953
}
 
954
 
 
955
SV *
 
956
dump_glob(perl_yaml_dumper_t *dumper, SV *node)
 
957
{
 
958
    SV *result;
 
959
    SV *code = find_coderef("YAML::XS::glob2hash");
 
960
    AV *args = newAV();
 
961
    av_push(args, SvREFCNT_inc(node));
 
962
    args = (AV *)sv_2mortal((SV *)args);
 
963
    result = call_coderef(code, args);
 
964
    hv_store(
 
965
        dumper->shadows, (char *)&node, sizeof(node),
 
966
        result, 0
 
967
    );
 
968
    return result;
 
969
}
 
970
 
 
971
/* XXX Refo this to just dump a special map */
 
972
void
 
973
dump_ref(perl_yaml_dumper_t *dumper, SV *node)
 
974
{
 
975
    yaml_event_t event_mapping_start;
 
976
    yaml_event_t event_mapping_end;
 
977
    yaml_event_t event_scalar;
 
978
    SV *referent = SvRV(node);
 
979
 
 
980
    yaml_char_t *anchor = get_yaml_anchor(dumper, referent);
 
981
    if (anchor && strEQ((char *)anchor, "")) return;
 
982
 
 
983
    yaml_mapping_start_event_initialize(
 
984
        &event_mapping_start, anchor,
 
985
        (unsigned char *)TAG_PERL_PREFIX "ref",
 
986
        0, YAML_BLOCK_MAPPING_STYLE
 
987
    );
 
988
    yaml_emitter_emit(&dumper->emitter, &event_mapping_start);
 
989
 
 
990
    yaml_scalar_event_initialize(
 
991
        &event_scalar,
 
992
        NULL, NULL,
 
993
        (unsigned char *)"=", 1,
 
994
        1, 1,
 
995
        YAML_PLAIN_SCALAR_STYLE
 
996
    );
 
997
    yaml_emitter_emit(&dumper->emitter, &event_scalar);
 
998
    dump_node(dumper, referent);
 
999
 
 
1000
    yaml_mapping_end_event_initialize(&event_mapping_end);
 
1001
    yaml_emitter_emit(&dumper->emitter, &event_mapping_end);
 
1002
}
 
1003
 
 
1004
int
 
1005
append_output(void *yaml, unsigned char *buffer, size_t size)
 
1006
{
 
1007
    sv_catpvn((SV *)yaml, (const char *)buffer, (STRLEN)size);
 
1008
    return 1;
 
1009
}
 
1010
 
 
1011
/* XXX Make -Wall not complain about 'local_patches' not being used. */
 
1012
#if !defined(PERL_PATCHLEVEL_H_IMPLICIT)
 
1013
void xxx_local_patches() {
 
1014
    printf("%s", local_patches[0]);
 
1015
}
 
1016
#endif