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

#include "perl_libyaml.h"

static SV *
load_node(YAML *self);
static SV *
load_mapping(YAML *self, char *tag);
static SV *
load_sequence(YAML *);
static SV *
load_scalar(YAML *);
static SV *
load_alias(YAML *);
static SV *
load_scalar_ref(YAML *);
static SV *
load_regexp(YAML *);
static SV *
load_glob(YAML *);
static SV *
load_code(YAML *);
static void
dump_prewalk(YAML *, SV *);
static void
dump_document(YAML *, SV *);
static void
dump_node(YAML *, SV *);
static void
dump_hash(YAML *, SV *, yaml_char_t *, yaml_char_t *);
static void
dump_array(YAML *, SV *);
static void
dump_scalar(YAML *, SV *, yaml_char_t *);
static void
dump_ref(YAML *, SV *);
static void
dump_code(YAML *, SV *);
static SV*
dump_glob(YAML *, SV *);
static yaml_char_t *
get_yaml_anchor(YAML *, SV *);
static yaml_char_t *
get_yaml_tag(SV *);
static int
yaml_sv_write_handler(void *sv, unsigned char *buffer, size_t size);
static int
yaml_perlio_read_handler(void *data, unsigned char *buffer, size_t size, size_t *size_read);
static int
yaml_perlio_write_handler(void *data, unsigned char *buffer, size_t size);

/* can honor lexical warnings and $^W */
#if PERL_VERSION > 11
#define Perl_warner Perl_ck_warner
#endif

#if 0
static const char* options[] =
  {
   /* Both */
   "boolean",         /* "JSON::PP", "boolean" or 0 */
   "disableblessed",  /* bool, default: 0 */
   "enablecode",      /* bool, default: 0 */
   /* Loader */
   "nonstrict",       /* bool, default: 0 */
   "loadcode",        /* bool, default: 0 */
   /* Dumper */
   "dumpcode",        /* bool, default: 0 */
   "noindentmap",     /* bool, default: 0 */
   "indent",          /* int, default: 2 */
   "wrapwidth",       /* int, default: 80 */
   "canonical",       /* bool, default: 0 */
   "quotenum",        /* bool, default: 1 */
   "unicode",         /* bool, default: 1 If unescaped Unicode characters are allowed */
   "encoding",        /* "any", "utf8", "utf16le" or "utf16be" */
   "linebreak",       /* "any", "cr", "ln" or "crln" */
   "openended",       /* bool, default: 0 */
  };
static int numoptions = sizeof(options)/sizeof(options[0]);

#endif

static SV *
fold_results(I32 count)
{
    dSP;
    SV *retval = &PL_sv_undef;

    if (count > 1) {
        /* convert multiple return items into a list reference */
        AV *av = newAV();
        SV *sv = &PL_sv_undef;
        I32 i;

        av_extend(av, count - 1);
        for(i = 1; i <= count; i++) {
            sv = POPs;
            if (SvOK(sv) && !av_store(av, count - i, SvREFCNT_inc(sv)))
                SvREFCNT_dec(sv);
        }
        PUTBACK;

        retval = sv_2mortal((SV *) newRV_noinc((SV *) av));

        if (!SvOK(sv) || sv == &PL_sv_undef) {
            /* if first element was undef, die */
            croak("%sCall error", ERRMSG);
        }
        return retval;

    }
    else {
        if (count)
            retval = POPs;
        PUTBACK;
        return retval;
    }
}

static SV *
call_coderef(SV *code, AV *args)
{
    dSP;
    SV **svp;
    I32 count = args ? av_len(args) : -1;
    I32 i;

    PUSHMARK(SP);
    for (i = 0; i <= count; i++) {
        if ((svp = av_fetch(args, i, FALSE))) {
            XPUSHs(*svp);
        }
    }
    PUTBACK;
    count = call_sv(code, G_ARRAY);
    SPAGAIN;

    return fold_results(count);
}

static SV *
find_coderef(const char *perl_var)
{
    SV *coderef;

    if ((coderef = get_sv(perl_var, FALSE))
        && SvROK(coderef)
        && SvTYPE(SvRV(coderef)) == SVt_PVCV)
        return coderef;

    return NULL;
}

/*
 * Piece together a parser/loader error message
 */
static char *
loader_error_msg(YAML *self, char *problem)
{
    char *msg;
    if (!problem)
        problem = (char *)self->parser.problem;
    if (self->filename)
      msg = form("%s%s at file %s",
                 ERRMSG, (problem ? problem : "A problem"), self->filename);
    else
      msg = form("%s%s at document %d",
                 ERRMSG, (problem ? problem : "A problem"), self->document);
    if (self->parser.problem_mark.line ||
        self->parser.problem_mark.column)
        msg = form("%s, line: %ld, column: %ld\n",
                   msg,
                   (long)self->parser.problem_mark.line + 1,
                   (long)self->parser.problem_mark.column + 1);
    else if (self->parser.problem_offset)
        msg = form("%s, offset: %ld\n", msg, (long)self->parser.problem_offset);
    else
        msg = form("%s\n", msg);
    if (self->parser.context)
        msg = form("%s%s at line: %ld, column: %ld\n",
                   msg,
                   self->parser.context,
                   (long)self->parser.context_mark.line + 1,
                   (long)self->parser.context_mark.column + 1);

    return msg;
}

/*
 * Set loader options from YAML* object.
 */
void
set_parser_options(YAML *self, yaml_parser_t *parser)
{
    self->document = 0;
    self->filename = NULL;
    self->parser.read_handler = NULL; /* we allow setting it mult. times */

    if ((int)self->encoding)
        yaml_parser_set_encoding(parser, self->encoding);

    /* As with YAML::Tiny. Default: strict Load */
    /* allow while parsing a quoted scalar found unknown escape character */
    parser->problem_nonstrict = self->flags & F_NONSTRICT;
}

/*
 * Set dumper options from YAML* object
 */
void
set_emitter_options(YAML *self, yaml_emitter_t *emitter)
{
    yaml_emitter_set_unicode(emitter, self->flags & F_UNICODE);
    yaml_emitter_set_indent(emitter, self->indent);
    yaml_emitter_set_width(emitter, self->wrapwidth);
    if ((int)self->encoding)
        yaml_emitter_set_encoding(emitter, self->encoding);
    if ((int)self->linebreak)
        yaml_emitter_set_break(emitter, self->linebreak);
    emitter->indentless_map = self->flags & F_NOINDENTMAP;
    emitter->open_ended = self->flags & F_OPENENDED;
    yaml_emitter_set_canonical(emitter, self->flags & F_CANONICAL);
}

static int
load_impl(YAML *self)
{
    dXCPT;
    dXSARGS; /* does POPMARK */
    SV *node;

    sp = mark;
    if (0 && (items || ax)) {} /* XXX Quiet the -Wall warnings for now. */

    /* Get the first event. Must be a STREAM_START */
    if (!yaml_parser_parse(&self->parser, &self->event))
        goto load_error;
    if (self->event.type != YAML_STREAM_START_EVENT)
        croak("%sExpected STREAM_START_EVENT; Got: %d != %d",
            ERRMSG, self->event.type, YAML_STREAM_START_EVENT);

    self->anchors = (HV *)sv_2mortal((SV *)newHV());

    XCPT_TRY_START {

        /* Keep calling load_node until end of stream */
        while (1) {
            self->document++;
            /* We are through with the previous event - delete it! */
            yaml_event_delete(&self->event);
            if (!yaml_parser_parse(&self->parser, &self->event))
                goto load_error;
            if (self->event.type == YAML_STREAM_END_EVENT)
                break;
            node = load_node(self);
            /* We are through with the previous event - delete it! */
            yaml_event_delete(&self->event);
            hv_clear(self->anchors);
            if (! node) break;
            XPUSHs(sv_2mortal(node));
            if (!yaml_parser_parse(&self->parser, &self->event))
                goto load_error;
            if (self->event.type != YAML_DOCUMENT_END_EVENT)
                croak("%sExpected DOCUMENT_END_EVENT", ERRMSG);
        }

        /* Make sure the last event is a STREAM_END */
        if (self->event.type != YAML_STREAM_END_EVENT)
            croak("%sExpected STREAM_END_EVENT; Got: %d != %d",
                ERRMSG, self->event.type, YAML_STREAM_END_EVENT);

    } XCPT_TRY_END

    XCPT_CATCH
    {
        yaml_parser_delete(&self->parser);
        XCPT_RETHROW;
    }

    yaml_parser_delete(&self->parser);
    PUTBACK;
    return 1;

load_error:
    croak("%s", loader_error_msg(self, NULL));
    return 0;
}

/*
 * It takes a file or filename and turns it into 0 or more Perl objects.
 */
int
LoadFile(YAML *self, SV *sv_file)
{
    FILE *file = NULL;
    const char *fname;
    STRLEN len;
    int ret;

    yaml_parser_initialize(&self->parser);
    set_parser_options(self, &self->parser);
    if (SvROK(sv_file)) { /* pv mg or io or gv */
        SV *rv = SvRV(sv_file);

        if (SvTYPE(rv) == SVt_PVIO) {
            self->perlio = IoIFP(rv);
            yaml_parser_set_input(&self->parser,
                                  &yaml_perlio_read_handler,
                                  self);
        } else if (SvTYPE(rv) == SVt_PVGV && GvIO(rv)) {
            self->perlio = IoIFP(GvIOp(rv));
            yaml_parser_set_input(&self->parser,
                                  &yaml_perlio_read_handler,
                                  self);
        } else if (SvMAGIC(rv)) {
            mg_get(rv);
            fname = SvPV_const(rv, len);
            goto pv_load;
        } else if (SvAMAGIC(sv_file)) {
            fname = SvPV_const(sv_file, len);
            goto pv_load;
        } else {
            croak("Invalid argument type for file: ref of %s", Perl_sv_peek(aTHX_ rv));
            return 0;
        }
    }
    else if (SvPOK(sv_file)) {
        fname = SvPV_const(sv_file, len);
    pv_load:
        file = fopen(fname, "rb");
        if (!file) {
            croak("Can't open '%s' for input", fname);
            return 0;
        }
        self->filename = (char *)fname;
        yaml_parser_set_input_file(&self->parser, file);
    } else if (SvTYPE(sv_file) == SVt_PVIO) {
        self->perlio = IoIFP(sv_file);
        yaml_parser_set_input(&self->parser,
                              &yaml_perlio_read_handler,
                              self);
    } else if (SvTYPE(sv_file) == SVt_PVGV
               && GvIO(sv_file)) {
        self->perlio = IoIFP(GvIOp(sv_file));
        yaml_parser_set_input(&self->parser,
                              &yaml_perlio_read_handler,
                              self);
    } else {
        croak("Invalid argument type for file: %s", Perl_sv_peek(aTHX_ sv_file));
        return 0;
    }

    ret = load_impl(self);
    if (file)
        fclose(file);
    else if (SvTYPE(sv_file) == SVt_PVIO)
        PerlIO_close(IoIFP(sv_file));
    return ret;
}

/*
 * This is the main Load function.
 * It takes a yaml stream and turns it into 0 or more Perl objects.
 */
int
Load(YAML *self, SV* yaml_sv)
{
    const unsigned char *yaml_str;
    STRLEN yaml_len;

    yaml_str = (const unsigned char *)SvPV_const(yaml_sv, yaml_len);
    yaml_parser_initialize(&self->parser);
    set_parser_options(self, &self->parser);
    if (DO_UTF8(yaml_sv)) { /* overrides encoding setting */
        if (self->encoding == YAML_ANY_ENCODING)
            self->parser.encoding = YAML_UTF8_ENCODING;
    } /* else check the BOM. don't check for decoded utf8. */

    yaml_parser_set_input_string(
        &self->parser,
        yaml_str,
        yaml_len);

    return load_impl(self);
}

/*
 * This is the main function for dumping any node.
 */
static SV *
load_node(YAML *self)
{
    SV* return_sv = NULL;
    /* This uses stack, but avoids (severe!) memory leaks */
    yaml_event_t uplevel_event;

    uplevel_event = self->event;

    /* Get the next parser event */
    if (!yaml_parser_parse(&self->parser, &self->event))
        goto load_error;

    /* These events don't need yaml_event_delete */
    /* Some kind of error occurred */
    if (self->event.type == YAML_NO_EVENT)
        goto load_error;

    /* Return NULL when we hit the end of a scope */
    if (self->event.type == YAML_DOCUMENT_END_EVENT ||
        self->event.type == YAML_MAPPING_END_EVENT ||
        self->event.type == YAML_SEQUENCE_END_EVENT)
    {
        /* restore the uplevel event, so it can be properly deleted */
        self->event = uplevel_event;
        return return_sv;
    }

    /* The rest all need cleanup */
    switch (self->event.type) {
        char *tag;

        /* Handle loading a mapping */
        case YAML_MAPPING_START_EVENT:
            tag = (char *)self->event.data.mapping_start.tag;

            if (tag) {
                /* Handle mapping tagged as a Perl hard reference */
                if (strEQ(tag, TAG_PERL_REF)) {
                    return_sv = load_scalar_ref(self);
                    break;
                }
                /* Handle mapping tagged as a Perl typeglob */
                if (strEQ(tag, TAG_PERL_GLOB)) {
                    return_sv = load_glob(self);
                    break;
                }
            }

            return_sv = load_mapping(self, NULL);
            break;

        /* Handle loading a sequence into an array */
        case YAML_SEQUENCE_START_EVENT:
            return_sv = load_sequence(self);
            break;

        /* Handle loading a scalar */
        case YAML_SCALAR_EVENT:
            return_sv = load_scalar(self);
            break;

        /* Handle loading an alias node */
        case YAML_ALIAS_EVENT:
            return_sv = load_alias(self);
            break;

        default:
            croak("%sInvalid event '%d' at top level",
                  ERRMSG, (int) self->event.type);
    }

    yaml_event_delete(&self->event);

    /* restore the uplevel event, so it can be properly deleted */
    self->event = uplevel_event;

    return return_sv;

    load_error:
        croak("%s", loader_error_msg(self, NULL));
}

/*
 * Load a YAML mapping into a Perl hash
 */
static SV *
load_mapping(YAML *self, char *tag)
{
    SV *key_node;
    SV *value_node;
    HV *hash = newHV();
    SV *hash_ref = (SV *)newRV_noinc((SV *)hash);
    char *anchor = (char *)self->event.data.mapping_start.anchor;

    if (!tag)
        tag = (char *)self->event.data.mapping_start.tag;

    /* Store the anchor label if any */
    if (anchor)
        (void)hv_store(self->anchors, anchor, strlen(anchor),
                       SvREFCNT_inc(hash_ref), 0);

    /* Get each key string and value node and put them in the hash */
    while ((key_node = load_node(self))) {
        assert(SvPOK(key_node));
        value_node = load_node(self);
        (void)hv_store_ent(hash, sv_2mortal(key_node), value_node, 0);
    }

    /* Deal with possibly blessing the hash if the YAML tag has a class */
    if (tag) {
        if (strEQ(tag, TAG_PERL_PREFIX "hash")) {
        }
        else if (strEQ(tag, YAML_MAP_TAG)) {
        }
        else {
            char *klass;
            char *prefix = TAG_PERL_PREFIX "hash:";
            if (*tag == '!') {
                prefix = "!";
            }
            else if (strlen(tag) <= strlen(prefix) ||
                     ! strnEQ(tag, prefix, strlen(prefix)))
                croak("%s", loader_error_msg(self,
                                form("bad tag found for hash: '%s'", tag)));
            if (!(self->flags & F_DISABLEBLESSED)) {
                klass = tag + strlen(prefix);
                if (self->flags & F_SAFEMODE &&
                    (!self->safeclasses ||
                     !hv_exists(self->safeclasses, klass, strlen(klass))))
                {
                    Perl_warner(aTHX_ packWARN(WARN_MISC),
                                WARNMSG "skipped loading unsafe HASH for class %s",
                                klass);
                    return hash_ref;
                }
                sv_bless(hash_ref, gv_stashpv(klass, TRUE));
            }
        }
    }

    return hash_ref;
}

/* Load a YAML sequence into a Perl array */
static SV *
load_sequence(YAML *self)
{
    SV *node;
    AV *array = newAV();
    SV *array_ref = (SV *)newRV_noinc((SV *)array);
    char *anchor = (char *)self->event.data.sequence_start.anchor;
    char *tag = (char *)self->event.data.mapping_start.tag;
    if (anchor)
        (void)hv_store(self->anchors, anchor, strlen(anchor),
                       SvREFCNT_inc(array_ref), 0);
    while ((node = load_node(self))) {
        av_push(array, node);
    }
    if (tag) {
        if (strEQ(tag, TAG_PERL_PREFIX "array")) {
        }
        else if (strEQ(tag, YAML_SEQ_TAG)) {
        }
        else {
            char *klass;
            char *prefix = TAG_PERL_PREFIX "array:";

            if (*tag == '!')
                prefix = "!";
            else if (strlen(tag) <= strlen(prefix) ||
                     ! strnEQ(tag, prefix, strlen(prefix)))
                croak("%s", loader_error_msg(self,
                              form("bad tag found for array: '%s'", tag)));
            if (!(self->flags & F_DISABLEBLESSED)) {
                klass = tag + strlen(prefix);
                if (self->flags & F_SAFEMODE &&
                    (!self->safeclasses ||
                     !hv_exists(self->safeclasses, klass, strlen(klass))))
                {
                    Perl_warner(aTHX_ packWARN(WARN_MISC),
                                WARNMSG "skipped loading unsafe ARRAY for class %s",
                                klass);
                    return array_ref;
                }
                sv_bless(array_ref, gv_stashpv(klass, TRUE));
            }
        }
    }
    return array_ref;
}

/* Load a YAML scalar into a Perl scalar */
static SV *
load_scalar(YAML *self)
{
    SV *scalar;
    char *string = (char *)self->event.data.scalar.value;
    STRLEN length = (STRLEN)self->event.data.scalar.length;
    char *anchor = (char *)self->event.data.scalar.anchor;
    char *tag = (char *)self->event.data.scalar.tag;
    yaml_scalar_style_t style = self->event.data.scalar.style;
    if (tag) {
        if (strEQ(tag, YAML_STR_TAG)) {
            style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
        }
        else if (strEQ(tag, YAML_INT_TAG) || strEQ(tag, YAML_FLOAT_TAG)) {
            /* TODO check int/float */
            scalar = newSVpvn(string, length);
            if ( looks_like_number(scalar) ) {
                /* numify */
                SvIV_please(scalar);
            }
            else {
                croak("%s", loader_error_msg(self,
                                form("Invalid content found for !!int tag: '%s'",
                                     tag)));
            }
            if (anchor)
              (void)hv_store(self->anchors, anchor, strlen(anchor),
                             SvREFCNT_inc(scalar), 0);
            return scalar;
        }
        else if (strEQ(tag, YAML_NULL_TAG) &&
                 (strEQ(string, "~") ||
                  strEQ(string, "null") ||
                  strEQ(string, "")))
        {
            scalar = newSV(0);
            if (anchor)
                (void)hv_store(self->anchors, anchor, strlen(anchor),
                               SvREFCNT_inc(scalar), 0);
            return scalar;
        }
        else {
            char *klass;
            char *prefix = TAG_PERL_PREFIX "regexp";
            if (strnEQ(tag, prefix, strlen(prefix)))
                return load_regexp(self);
            prefix = TAG_PERL_PREFIX "code";
            if (strnEQ(tag, prefix, strlen(prefix)))
                return load_code(self);
            prefix = TAG_PERL_PREFIX "scalar:";
            if (*tag == '!')
                prefix = "!";
            else if (strlen(tag) <= strlen(prefix) ||
                     !strnEQ(tag, prefix, strlen(prefix)))
                croak("%sbad tag found for scalar: '%s'", ERRMSG, tag);
            klass = tag + strlen(prefix);
            if (!(self->flags & F_DISABLEBLESSED))
                if (self->flags & F_SAFEMODE &&
                    (!self->safeclasses ||
                     !hv_exists(self->safeclasses, klass, strlen(klass))))
                {
                    Perl_warner(aTHX_ packWARN(WARN_MISC),
                                WARNMSG "skipped loading unsafe SCALAR for class %s",
                                klass);
                    scalar = newSVpvn(string, length);
                } else {
                    scalar = sv_setref_pvn(newSV(0), klass, string, strlen(string));
                }
            else
                scalar = newSVpvn(string, length);
            SvUTF8_on(scalar);
            if (anchor)
                (void)hv_store(self->anchors, anchor, strlen(anchor),
                               SvREFCNT_inc(scalar), 0);
            return scalar;
        }
    }

    else if (style == YAML_PLAIN_SCALAR_STYLE) {
        if (strEQ(string, "~") || strEQ(string, "null") || strEQ(string, "")) {
            scalar = newSV(0);
            if (anchor)
                (void)hv_store(self->anchors, anchor, strlen(anchor),
                               SvREFCNT_inc(scalar), 0);
            return scalar;
        }
        else if (strEQ(string, "true")) {
#if (PERL_BCDVERSION >= 0x5008009)
            if (self->boolean == YAML_BOOLEAN_JSONPP) {
                scalar = sv_setref_iv(newSV(1), "JSON::PP::Boolean", 1);
            }
            else if (self->boolean == YAML_BOOLEAN_BOOLEAN) {
                scalar = sv_setref_iv(newSV(1), "boolean", 1);
            }
            else
#endif
            {
                scalar = &PL_sv_yes;
            }
            if (anchor)
                (void)hv_store(self->anchors, anchor, strlen(anchor),
                               SvREFCNT_inc(scalar), 0);
            return scalar;
        }
        else if (strEQ(string, "false")) {
#if (PERL_BCDVERSION >= 0x5008009)
            if (self->boolean == YAML_BOOLEAN_JSONPP) {
                scalar = sv_setref_iv(newSV(0), "JSON::PP::Boolean", 0);
            }
            else if (self->boolean == YAML_BOOLEAN_BOOLEAN) {
                scalar = sv_setref_iv(newSV(0), "boolean", 0);
            }
            else
#endif
            {
                scalar = &PL_sv_no;
            }
            if (anchor)
              (void)hv_store(self->anchors, anchor, strlen(anchor),
                             SvREFCNT_inc(scalar), 0);
            return scalar;
        }
    }

    scalar = newSVpvn(string, length);

    if (style == YAML_PLAIN_SCALAR_STYLE && looks_like_number(scalar) ) {
        /* numify */
        SvIV_please(scalar);
    }

    (void)sv_utf8_decode(scalar);
    if (anchor)
        (void)hv_store(self->anchors, anchor, strlen(anchor),
                       SvREFCNT_inc(scalar), 0);
    return scalar;
}

/* Load a scalar marked as a regexp as a Perl regular expression.
 * This operation is less common and is tricky, so doing it in Perl code for
 * now.
 */
static SV *
load_regexp(YAML * self)
{
    dSP;
    char *string = (char *)self->event.data.scalar.value;
    STRLEN length = (STRLEN)self->event.data.scalar.length;
    char *anchor = (char *)self->event.data.scalar.anchor;
    char *tag = (char *)self->event.data.scalar.tag;
    char *prefix = (char*)TAG_PERL_PREFIX "regexp:";

    SV *regexp = newSVpvn(string, length);
    SvUTF8_on(regexp);

    ENTER;
    SAVETMPS;
    PUSHMARK(sp);
    XPUSHs(regexp);
    PUTBACK;
    call_pv("YAML::Safe::__qr_loader", G_SCALAR);
    SPAGAIN;
    regexp = newSVsv(POPs);

    PUTBACK;
    FREETMPS;
    LEAVE;

    if (strlen(tag) > strlen(prefix) && strnEQ(tag, prefix, strlen(prefix))) {
        if (!(self->flags & F_DISABLEBLESSED)) {
            char *klass = tag + strlen(prefix);
            if (self->flags & F_SAFEMODE) {
                if (!self->safeclasses ||
                    !hv_exists(self->safeclasses, klass, strlen(klass)))
                {
                    Perl_warner(aTHX_ packWARN(WARN_MISC),
                                WARNMSG "skipped loading unsafe REGEXP for class %s",
                                klass);
                    goto cont_rx;
                }
            }
            sv_bless(regexp, gv_stashpv(klass, TRUE));
        }
    }
 cont_rx:
    if (anchor)
        (void)hv_store(self->anchors, anchor, strlen(anchor),
                       SvREFCNT_inc(regexp), 0);
    return regexp;
}

/* Load a scalar marked as code as a Perl code reference.
 * This operation is less common and is tricky, so doing it in Perl code for
 * now.
 */
SV*
load_code(YAML * self)
{
    dSP;
    char *string = (char *)self->event.data.scalar.value;
    STRLEN length = (STRLEN)self->event.data.scalar.length;
    char *anchor = (char *)self->event.data.scalar.anchor;
    char *tag = (char *)self->event.data.scalar.tag;
    char *prefix = TAG_PERL_PREFIX "code:";
    SV *code;

    if (strlen(tag) > strlen(prefix) && strnEQ(tag, prefix, strlen(prefix))) {
        char *klass = tag + strlen(prefix);
        if (self->flags & F_SAFEMODE &&
            (!self->safeclasses ||
             !hv_exists(self->safeclasses, klass, strlen(klass))))
        {
            Perl_warner(aTHX_ packWARN(WARN_MISC),
                        WARNMSG "skipped loading unsafe CODE for class %s",
                        klass);
            return &PL_sv_undef;
        }
    }

    if (!(self->flags & F_LOADCODE)) {
        tag = "";
        string = "{}";
        length = 2;
    }

    code = newSVpvn(string, length);
    SvUTF8_on(code);

    ENTER;
    SAVETMPS;
    PUSHMARK(sp);
    XPUSHs(code);
    PUTBACK;
    call_pv("YAML::Safe::__code_loader", G_SCALAR);
    SPAGAIN;
    code = newSVsv(POPs);

    PUTBACK;
    FREETMPS;
    LEAVE;

    if (strlen(tag) > strlen(prefix) && strnEQ(tag, prefix, strlen(prefix))) {
        if (!(self->flags & F_DISABLEBLESSED)) {
            char *klass = tag + strlen(prefix);
            sv_bless(code, gv_stashpv(klass, TRUE));
        }
    }

    if (anchor)
        (void)hv_store(self->anchors, anchor, strlen(anchor),
                       SvREFCNT_inc(code), 0);
    return code;
}


/*
 * Load a reference to a previously loaded node.
 */
static SV *
load_alias(YAML *self)
{
    char *anchor = (char *)self->event.data.alias.anchor;
    SV **entry = hv_fetch(self->anchors, anchor, strlen(anchor), 0);
    if (entry)
        return SvREFCNT_inc(*entry);
    croak("%sNo anchor for alias '%s'", ERRMSG, anchor);
}

/*
 * Load a Perl hard reference.
 */
SV *
load_scalar_ref(YAML *self)
{
    SV *value_node;
    char *anchor = (char *)self->event.data.mapping_start.anchor;
    SV *rv = newRV_noinc(&PL_sv_undef);
    if (anchor)
        (void)hv_store(self->anchors, anchor, strlen(anchor),
                       SvREFCNT_inc(rv), 0);
    load_node(self);  /* Load the single hash key (=) */
    value_node = load_node(self);
    SvRV(rv) = value_node;
    if (load_node(self))
        croak("%sExpected end of node", ERRMSG);
    return rv;
}

/*
 * Load a Perl typeglob.
 */
static SV *
load_glob(YAML *self)
{
    /* XXX Call back a Perl sub to do something interesting here */
    return load_mapping(self, (char*)TAG_PERL_PREFIX "hash");
}

/* -------------------------------------------------------------------------- */


/*
 * This is the main Dump function.
 * Take zero or more Perl objects from the stack
 * and return a YAML stream (as a string)
 */
int
Dump(YAML *self, int yaml_ix)
{
    dXSARGS;  /* does POPMARK */
    yaml_event_t event_stream_start;
    yaml_event_t event_stream_end;
    int i;
    SV *yaml = sv_2mortal(newSVpvn("", 0));

    sp = mark;

    yaml_emitter_initialize(&self->emitter);
    set_emitter_options(self, &self->emitter);
    yaml_emitter_set_output(
        &self->emitter,
        &yaml_sv_write_handler,
        (void *)yaml);

    yaml_stream_start_event_initialize(&event_stream_start, self->encoding);
    yaml_emitter_emit(&self->emitter, &event_stream_start);

    self->anchors = (HV *)sv_2mortal((SV *)newHV());
    self->shadows = (HV *)sv_2mortal((SV *)newHV());

    for (i = yaml_ix; i < items; i++) {
        self->anchor = 0;

        dump_prewalk(self, ST(i));
        dump_document(self, ST(i));

        hv_clear(self->anchors);
        hv_clear(self->shadows);
    }

    /* End emitting and destroy the emitter object */
    yaml_stream_end_event_initialize(&event_stream_end);
    yaml_emitter_emit(&self->emitter, &event_stream_end);
    yaml_emitter_delete(&self->emitter);

    /* Put the YAML stream scalar on the XS output stack */
    if (yaml) {
        sp = PL_stack_base + ax - 1; /* ax 0 */
        SvUTF8_off(yaml);
        XPUSHs(yaml);
        PUTBACK;
        return 1;
    } else {
        PUTBACK;
        return 0;
    }
}

/*
 * Dump zero or more Perl objects into the file
 */
int
DumpFile(YAML *self, SV *sv_file, int yaml_ix)
{
    dXSARGS;
    yaml_event_t event_stream_start;
    yaml_event_t event_stream_end;
    FILE *file = NULL;
    const char *fname;
    STRLEN len;
    long i;

    sp = mark;

    yaml_emitter_initialize(&self->emitter);
    set_emitter_options(self, &self->emitter);

    if (SvROK(sv_file)) { /* pv mg or io or gv */
        SV *rv = SvRV(sv_file);

        if (SvTYPE(rv) == SVt_PVIO) {
            self->perlio = IoOFP(rv);
            yaml_emitter_set_output(&self->emitter,
                                    &yaml_perlio_write_handler,
                                    self);
        } else if (SvTYPE(rv) == SVt_PVGV && GvIO(rv)) {
            self->perlio = IoOFP(GvIOp(SvRV(sv_file)));
            yaml_emitter_set_output(&self->emitter,
                                    &yaml_perlio_write_handler,
                                    self);
        } else if (SvMAGIC(rv)) {
            mg_get(rv);
            fname = SvPV_const(rv, len);
            goto pv_dump;
        } else if (SvAMAGIC(sv_file)) {
            fname = SvPV_const(sv_file, len);
            goto pv_dump;
        } else {
            croak("Invalid argument type for file: ref of %s", Perl_sv_peek(aTHX_ rv));
            return 0;
        }
    }
    else if (SvPOK(sv_file)) {
        fname = (const char *)SvPV_const(sv_file, len);
    pv_dump:
        file = fopen(fname, "wb");
        if (!file) {
            croak("Can't open '%s' for output", fname);
            return 0;
        }
        self->filename = (char *)fname;
        yaml_emitter_set_output_file(&self->emitter, file);
    } else if (SvTYPE(sv_file) == SVt_PVIO) {
        self->perlio = IoOFP(sv_file);
        yaml_emitter_set_output(&self->emitter,
                                &yaml_perlio_write_handler,
                                self);
    } else if (SvTYPE(sv_file) == SVt_PVGV && GvIO(sv_file)) {
        self->perlio = IoOFP(GvIOp(sv_file));
        yaml_emitter_set_output(&self->emitter,
                                &yaml_perlio_write_handler,
                                self);
    } else {
        /* sv_peek since 5.005 */
        croak("Invalid argument type for file: %s", Perl_sv_peek(aTHX_ sv_file));
        return 0;
    }

    yaml_stream_start_event_initialize(&event_stream_start,
                                       self->encoding);
    if (!yaml_emitter_emit(&self->emitter, &event_stream_start)) {
        PUTBACK;
        return 0;
    }

    self->anchors = (HV *)sv_2mortal((SV *)newHV());
    self->shadows = (HV *)sv_2mortal((SV *)newHV());

    /* ST(yaml_ix) is the file */
    for (i = yaml_ix+1; i < items; i++) {
        self->anchor = 0;

        dump_prewalk(self, ST(i));
        dump_document(self, ST(i));

        hv_clear(self->anchors);
        hv_clear(self->shadows);
    }

    /* End emitting and destroy the emitter object */
    yaml_stream_end_event_initialize(&event_stream_end);
    if (!yaml_emitter_emit(&self->emitter, &event_stream_end)) {
        PUTBACK;
        return 0;
    }
    yaml_emitter_delete(&self->emitter);
    if (file)
        fclose(file);
    else if (SvTYPE(sv_file) == SVt_PVIO)
        PerlIO_close(IoOFP(sv_file));

    PUTBACK;
    return 1;
}

/*
 * In order to know which nodes will need anchors (for later aliasing) it is
 * necessary to walk the entire data structure first. Once a node has been
 * seen twice you can stop walking it. That way we can handle circular refs.
 * All the node information is stored in an HV.
 */
static void
dump_prewalk(YAML *self, SV *node)
{
    int i;
    U32 ref_type;

    if (! (SvROK(node) || SvTYPE(node) == SVt_PVGV)) return;

    {
        SV *object = SvROK(node) ? SvRV(node) : node;
        SV **seen =
            hv_fetch(self->anchors, (char *)&object, sizeof(object), 0);
        if (seen) {
            if (*seen == &PL_sv_undef) {
                (void)hv_store(self->anchors, (char *)&object, sizeof(object),
                               &PL_sv_yes, 0);
            }
            return;
        }
        (void)hv_store(self->anchors, (char *)&object, sizeof(object),
                       &PL_sv_undef, 0);
    }

    if (SvTYPE(node) == SVt_PVGV) {
        node = dump_glob(self, node);
    }

    ref_type = SvTYPE(SvRV(node));
    if (ref_type == SVt_PVAV) {
        AV *array = (AV *)SvRV(node);
        int array_size = av_len(array) + 1;
        for (i = 0; i < array_size; i++) {
            SV **entry = av_fetch(array, i, 0);
            if (entry)
                dump_prewalk(self, *entry);
        }
    }
    else if (ref_type == SVt_PVHV) {
        HV *hash = (HV *)SvRV(node);
        HE *he;
        hv_iterinit(hash);
        while ((he = hv_iternext(hash))) {
            SV *val = HeVAL(he);
            if (val)
                dump_prewalk(self, val);
        }
    }
    else if (ref_type <= SVt_PVNV || ref_type == SVt_PVGV) {
        SV *scalar = SvRV(node);
        dump_prewalk(self, scalar);
    }
}

static void
dump_document(YAML *self, SV *node)
{
    yaml_event_t event_document_start;
    yaml_event_t event_document_end;
    yaml_document_start_event_initialize(
        &event_document_start, NULL, NULL, NULL, 0);
    yaml_emitter_emit(&self->emitter, &event_document_start);
    dump_node(self, node);
    yaml_document_end_event_initialize(&event_document_end, 1);
    yaml_emitter_emit(&self->emitter, &event_document_end);
}

static void
dump_node(YAML *self, SV *node)
{
    yaml_char_t *anchor = NULL;
    yaml_char_t *tag = NULL;
    const char *klass = NULL;

    if (SvTYPE(node) == SVt_PVGV) {
        SV **svr;
        tag = (yaml_char_t *)TAG_PERL_PREFIX "glob";
        anchor = get_yaml_anchor(self, node);
        if (anchor && strEQ((char *)anchor, ""))
            return;
        svr = hv_fetch(self->shadows, (char *)&node, sizeof(node), 0);
        if (svr) {
            node = SvREFCNT_inc(*svr);
        }
    }

    if (SvROK(node)) {
        SV *rnode = SvRV(node);
        U32 ref_type = SvTYPE(rnode);
        if (ref_type == SVt_PVHV)
            dump_hash(self, node, anchor, tag);
        else if (ref_type == SVt_PVAV)
            dump_array(self, node);
        else if (ref_type <= SVt_PVNV || ref_type == SVt_PVGV)
            dump_ref(self, node);
        else if (ref_type == SVt_PVCV)
            dump_code(self, node);
        else if (ref_type == SVt_PVMG) {
            MAGIC *mg;
            yaml_char_t *tag = NULL;
            if (SvMAGICAL(rnode)) {
                if ((mg = mg_find(rnode, PERL_MAGIC_qr))) {
                    tag = (yaml_char_t *)form(TAG_PERL_PREFIX "regexp");
                    klass = sv_reftype(rnode, TRUE);
                    if (!strEQ(klass, "Regexp"))
                        tag = (yaml_char_t *)form("%s:%s", tag, klass);
                }
                dump_scalar(self, node, tag);
            }
            else {
                klass = sv_reftype(rnode, TRUE);
                if (self->boolean != YAML_BOOLEAN_NONE) {
                    if (SvIV(node))
                        dump_scalar(self, &PL_sv_yes, NULL);
                    else
                        dump_scalar(self, &PL_sv_no, NULL);
                }
                else {
                    tag = (yaml_char_t *)form(
                        TAG_PERL_PREFIX "scalar:%s",
                        klass);
                    node = rnode;
                    dump_scalar(self, node, tag);
                }
            }
        }
#if PERL_VERSION >= 11
        else if (ref_type == SVt_REGEXP) {
            yaml_char_t *tag = (yaml_char_t *)form(TAG_PERL_PREFIX "regexp");
            klass = sv_reftype(rnode, TRUE);
            if (!strEQ(klass, "Regexp"))
                tag = (yaml_char_t *)form("%s:%s", tag, klass);
            dump_scalar(self, node, tag);
        }
#endif
        else {
            printf("YAML::Safe dump unhandled ref. type == '%d'!\n",
                   (int)ref_type);
            dump_scalar(self, rnode, NULL);
        }
    }
    else {
        dump_scalar(self, node, NULL);
    }
}

static yaml_char_t *
get_yaml_anchor(YAML *self, SV *node)
{
    yaml_event_t event_alias;
    SV *iv;
    SV **seen = hv_fetch(self->anchors, (char *)&node, sizeof(node), 0);
    if (seen && *seen != &PL_sv_undef) {
        if (*seen == &PL_sv_yes) {
            self->anchor++;
            iv = newSViv(self->anchor);
            (void)hv_store(self->anchors, (char *)&node, sizeof(node), iv, 0);
            return (yaml_char_t*)SvPV_nolen(iv);
        }
        else {
            yaml_char_t *anchor = (yaml_char_t *)SvPV_nolen(*seen);
            yaml_alias_event_initialize(&event_alias, anchor);
            yaml_emitter_emit(&self->emitter, &event_alias);
            return (yaml_char_t *) "";
        }
    }
    return NULL;
}

static yaml_char_t *
get_yaml_tag(SV *node)
{
    yaml_char_t *tag = NULL;
    char *kind = (char*)"";
    char *klass;

    if (! (sv_isobject(node)
           || (SvRV(node) && ( SvTYPE(SvRV(node)) == SVt_PVCV))))
        return NULL;
    klass = (char *)sv_reftype(SvRV(node), TRUE);

    switch (SvTYPE(SvRV(node))) {
        case SVt_PVAV:
            tag = (yaml_char_t *)form("%s%s:%s", TAG_PERL_PREFIX, "array", klass);
            break;
        case SVt_PVHV:
            tag = (yaml_char_t *)form("%s%s:%s", TAG_PERL_PREFIX, "hash", klass);
            break;
        case SVt_PVCV:
            kind = (char*)"code";
            if (strEQ(klass, "CODE"))
                tag = (yaml_char_t *)form("%s%s", TAG_PERL_PREFIX, kind);
            else
                tag = (yaml_char_t *)form("%s%s:%s", TAG_PERL_PREFIX, kind, klass);
          break;
        default:
            tag = (yaml_char_t *)form("%s%s", TAG_PERL_PREFIX, klass);
            break;
    }
    if (!tag)
        tag = (yaml_char_t *)form("%s%s:%s", TAG_PERL_PREFIX, kind, klass);
    return tag;
}

static void
dump_hash(
    YAML *self, SV *node,
    yaml_char_t *anchor, yaml_char_t *tag)
{
    yaml_event_t event_mapping_start;
    yaml_event_t event_mapping_end;
    STRLEN i, len;
    AV *av;
    HV *hash = (HV *)SvRV(node);
    HE *he;

    if (!anchor)
        anchor = get_yaml_anchor(self, (SV *)hash);
    if (anchor && strEQ((char*)anchor, ""))
        return;

    if (!tag)
        tag = get_yaml_tag(node);
    if (tag && self->flags & F_SAFEMODE) {
        char *prefix = TAG_PERL_PREFIX "hash:";
        char *klass = (char*)tag + strlen(prefix);
        STRLEN len = strlen(klass);
        if (SvOBJECT(node)) {
            HV* stash = SvSTASH(node);
            klass = HvNAME_get(stash);
            len = HvNAMELEN_get(stash);
            if (HvNAMEUTF8(stash))
                len = -len;
        }
        if (!self->safeclasses ||
            !hv_exists(self->safeclasses, klass, len))
        {
            Perl_warner(aTHX_ packWARN(WARN_MISC),
                        WARNMSG "skipped dumping unsafe HASH in class %s",
                        klass);
            hash = (HV*)sv_2mortal((SV*)newHV());
        }
    }

    yaml_mapping_start_event_initialize(
        &event_mapping_start, anchor, tag, 0, YAML_BLOCK_MAPPING_STYLE);
    yaml_emitter_emit(&self->emitter, &event_mapping_start);

    av = newAV();
    len = 0;
    hv_iterinit(hash);
    while ((he = hv_iternext(hash))) {
        SV *key = hv_iterkeysv(he);
        av_store(av, AvFILLp(av)+1, key); /* av_push(), really */
        len++;
    }
    STORE_HASH_SORT;
    for (i = 0; i < len; i++) {
        SV *key = av_shift(av);
        HE *he  = hv_fetch_ent(hash, key, 0, 0);
        SV *val = he ? HeVAL(he) : NULL;
        if (val == NULL)
            val = &PL_sv_undef;
        dump_node(self, key);
        dump_node(self, val);
    }

    SvREFCNT_dec(av);

    yaml_mapping_end_event_initialize(&event_mapping_end);
    yaml_emitter_emit(&self->emitter, &event_mapping_end);
}

static void
dump_array(YAML *self, SV *node)
{
    yaml_event_t event_sequence_start;
    yaml_event_t event_sequence_end;
    yaml_char_t *tag;
    AV *array = (AV *)SvRV(node);
    STRLEN i;
    STRLEN array_size = av_len(array) + 1;

    yaml_char_t *anchor = get_yaml_anchor(self, (SV *)array);
    if (anchor && strEQ((char *)anchor, ""))
        return;
    tag = get_yaml_tag(node);
    if (tag && self->flags & F_SAFEMODE) {
        char *prefix = TAG_PERL_PREFIX "array:";
        char *klass = (char*)tag + strlen(prefix);
        STRLEN len = strlen(klass);
        if (SvOBJECT(node)) {
            HV* stash = SvSTASH(node);
            klass = HvNAME_get(stash);
            len = HvNAMELEN_get(stash);
            if (HvNAMEUTF8(stash))
                len = -len;
        }
        if (!self->safeclasses ||
            !hv_exists(self->safeclasses, klass, len))
        {
            Perl_warner(aTHX_ packWARN(WARN_MISC),
                        WARNMSG "skipped dumping unsafe ARRAY in class %s",
                        klass);
            array_size = 0;
        }
    }

    yaml_sequence_start_event_initialize(
        &event_sequence_start, anchor, tag, 0, YAML_BLOCK_SEQUENCE_STYLE);
    yaml_emitter_emit(&self->emitter, &event_sequence_start);

    for (i = 0; i < array_size; i++) {
        SV **entry = av_fetch(array, i, 0);
        if (entry == NULL)
            dump_node(self, &PL_sv_undef);
        else
            dump_node(self, *entry);
    }
    yaml_sequence_end_event_initialize(&event_sequence_end);
    yaml_emitter_emit(&self->emitter, &event_sequence_end);
}

static void
dump_scalar(YAML *self, SV *node, yaml_char_t *tag)
{
    yaml_event_t event_scalar;
    char *string;
    STRLEN string_len;
    int plain_implicit, quoted_implicit;
    yaml_scalar_style_t style = YAML_PLAIN_SCALAR_STYLE;

    if (tag) {
        if (self->flags & F_SAFEMODE && SvOBJECT(node)) {
            HV* stash = SvSTASH(node);
            char *klass = HvNAME_get(stash);
            STRLEN len = HvNAMELEN_get(stash);
            if (HvNAMEUTF8(stash))
                len = -len;
            if (!self->safeclasses ||
                !hv_exists(self->safeclasses, klass, len))
            {
                Perl_warner(aTHX_ packWARN(WARN_MISC),
                            WARNMSG "skipped dumping unsafe SCALAR for class %s",
                            klass);
                node = &PL_sv_undef;
            }
        }
        plain_implicit = quoted_implicit = 0;
    }
    else {
        tag = (yaml_char_t *)TAG_PERL_STR;
        plain_implicit = quoted_implicit = 1;
    }

    SvGETMAGIC(node);
    if (!SvOK(node)) {
        string = "~";
        string_len = 1;
        style = YAML_PLAIN_SCALAR_STYLE;
    }
    else if (node == &PL_sv_yes) {
        string = "true";
        string_len = 4;
        style = YAML_PLAIN_SCALAR_STYLE;
    }
    else if (node == &PL_sv_no) {
        string = "false";
        string_len = 5;
        style = YAML_PLAIN_SCALAR_STYLE;
    }
    else {
        SV *node_clone = sv_mortalcopy(node);
        string = SvPV_nomg(node_clone, string_len);
        if (
            (string_len == 0) ||
            (string_len == 1 && strEQ(string, "~")) ||
            (string_len == 4 &&
             (strEQ(string, "true") || strEQ(string, "null"))) ||
            (string_len == 5 && strEQ(string, "false")) ||
            (SvTYPE(node_clone) >= SVt_PVGV) ||
            ( (self->flags & F_QUOTENUM) &&
              !SvNIOK(node_clone) &&
              looks_like_number(node_clone) ) )
        {
            style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
        } else {
            if (!SvUTF8(node_clone)) {
                /* copy to new SV and promote to utf8 */
                SV *utf8sv = sv_mortalcopy(node_clone);

                /* get string and length out of utf8 */
                string = SvPVutf8(utf8sv, string_len);
            }
            if(strchr(string, '\n'))
               style = (string_len > 30) ? YAML_LITERAL_SCALAR_STYLE
                                         : YAML_DOUBLE_QUOTED_SCALAR_STYLE;
        }
    }
    yaml_scalar_event_initialize(
        &event_scalar,
        NULL, /* anchor */
        tag,
        (unsigned char *) string,
        (int) string_len,
        plain_implicit,
        quoted_implicit,
        style);
    if (! yaml_emitter_emit(&self->emitter, &event_scalar))
        croak("%sEmit scalar '%s', error: %s\n",
            ERRMSG, string, self->emitter.problem);
}

static void
dump_code(YAML *self, SV *node)
{
    yaml_event_t event_scalar;
    yaml_char_t *tag;
    yaml_scalar_style_t style = YAML_SINGLE_QUOTED_SCALAR_STYLE;
    char *string = "{ \"DUMMY\" }";

    tag = get_yaml_tag(node);

    if (self->flags & F_DUMPCODE) {
        /* load_module(PERL_LOADMOD_NOIMPORT, newSVpv("B::Deparse", 0), NULL);
         */
        SV *code;
        SV *result = NULL;
        if (self->flags & F_SAFEMODE) {
            char *klass; STRLEN len;
            SV* rnode = SvRV(node);
            HV* stash = SvOBJECT(rnode)
                ? SvSTASH(rnode)
                : GvSTASH(CvGV(rnode));
            if (!stash)
                stash = CvSTASH(rnode);
            klass = HvNAME_get(stash);
            len = HvNAMELEN_get(stash);
            if (HvNAMEUTF8(stash))
                len = -len;
            if (!self->safeclasses || !hv_exists(self->safeclasses, klass, len)) {
                Perl_warner(aTHX_ packWARN(WARN_MISC),
                            WARNMSG "skipped dumping unsafe CODE for class %s",
                            klass);
                string = "{ \"UNSAFE\" }";
                result = &PL_sv_undef;
            }
        }
        if (result != &PL_sv_undef) {
            AV *args = newAV();
            av_push(args, SvREFCNT_inc(node));
            code = find_coderef("YAML::Safe::coderef2text");
            result = call_coderef(code, (AV*)sv_2mortal((SV *)args));
        }
        if (result && result != &PL_sv_undef) {
            string = SvPV_nolen(result);
            style = YAML_LITERAL_SCALAR_STYLE;
        }
    }

    yaml_scalar_event_initialize(
        &event_scalar,
        NULL, /* anchor */
        tag,
        (unsigned char *)string,
        string ? strlen(string) : 0,
        0,
        0,
        style);
    yaml_emitter_emit(&self->emitter, &event_scalar);
}

static SV *
dump_glob(YAML *self, SV *node)
{
    SV *result;
    SV *code = find_coderef("YAML::Safe::glob2hash");
    AV *args = newAV();
    /* TODO: safemode */
    av_push(args, SvREFCNT_inc(node));
    args = (AV *)sv_2mortal((SV *)args);
    result = call_coderef(code, args);
    (void)hv_store(self->shadows, (char *)&node, sizeof(node),
                   result, 0);
    return result;
}

/* XXX Refo this to just dump a special map */
static void
dump_ref(YAML *self, SV *node)
{
    yaml_event_t event_mapping_start;
    yaml_event_t event_mapping_end;
    yaml_event_t event_scalar;
    SV *referent = SvRV(node);

    yaml_char_t *anchor = get_yaml_anchor(self, referent);
    if (anchor && strEQ((char *)anchor, ""))
        return;

    yaml_mapping_start_event_initialize(
        &event_mapping_start, anchor,
        (unsigned char *)TAG_PERL_PREFIX "ref",
        0, YAML_BLOCK_MAPPING_STYLE);
    yaml_emitter_emit(&self->emitter, &event_mapping_start);

    yaml_scalar_event_initialize(
        &event_scalar,
        NULL, /* anchor */
        NULL, /* tag */
        (unsigned char *)"=", 1,
        1, 1,
        YAML_PLAIN_SCALAR_STYLE);
    yaml_emitter_emit(&self->emitter, &event_scalar);
    dump_node(self, referent);

    yaml_mapping_end_event_initialize(&event_mapping_end);
    yaml_emitter_emit(&self->emitter, &event_mapping_end);
}

static int
yaml_sv_write_handler(void *sv, unsigned char *buffer, size_t size)
{
    sv_catpvn((SV *)sv, (const char *)buffer, (STRLEN)size);
    return 1;
}

static int
yaml_perlio_read_handler(void *data, unsigned char *buffer, size_t size, size_t *size_read)
{
    YAML *self = (YAML *)data;

    *size_read = PerlIO_read(self->perlio, buffer, size);
    return !PerlIO_error(self->perlio);
}

static int
yaml_perlio_write_handler(void *data, unsigned char *buffer, size_t size)
{
    YAML *self = (YAML *)data;
    return (PerlIO_write(self->perlio, (char*)buffer, (long)size) == (SSize_t)size);
}

/* XXX Make -Wall not complain about 'local_patches' not being used. */
#if !defined(PERL_PATCHLEVEL_H_IMPLICIT)
void xxx_local_patches() {
    if (local_patches[0])
        printf("%s", local_patches[0]);
}
#endif

void
yaml_destroy (YAML *self)
{
    if (!self)
        return;
    /* self->filename gets deleted with sv_file */
    yaml_parser_delete (&self->parser);
    yaml_event_delete (&self->event);
    yaml_emitter_delete (&self->emitter);
    Zero(self, 1, YAML);
}