/*
* This is the main function for dumping any node.
*/
SV *
load_node(perl_yaml_loader_t *loader)
{
/* Get the next parser event */
if (!yaml_parser_parse(&loader->parser, &loader->event))
goto load_error;
/* Return NULL when we hit the end of a scope */
if (loader->event.type == YAML_DOCUMENT_END_EVENT ||
loader->event.type == YAML_MAPPING_END_EVENT ||
loader->event.type == YAML_SEQUENCE_END_EVENT) return NULL;
/* Handle loading a mapping */
if (loader->event.type == YAML_MAPPING_START_EVENT) {
SV *hash_ref;
char *tag = (char *)loader->event.data.mapping_start.tag;
/* Handle mapping tagged as a Perl hard reference */
if (tag && strEQ(tag, TAG_PERL_REF))
return load_scalar_ref(loader);
/* Handle mapping tagged as a Perl typeglob */
if (tag && strEQ(tag, TAG_PERL_GLOB))
return load_glob(loader);
/* Load the mapping into a hash ref and return it */
return load_mapping(loader, NULL);
}
/* Handle loading a sequence into an array */
if (loader->event.type == YAML_SEQUENCE_START_EVENT)
return load_sequence(loader);
/* Handle loading a scalar */
if (loader->event.type == YAML_SCALAR_EVENT)
return load_scalar(loader);
/* Handle loading an alias node */
if (loader->event.type == YAML_ALIAS_EVENT)
return load_alias(loader);
/* Some kind of error occurred */
if (loader->event.type == YAML_NO_EVENT)
croak(loader_error_msg(loader, NULL));
croak(ERRMSG "Invalid event '%d' at top level", (int) loader->event.type);
load_error:
croak(loader_error_msg(loader, NULL));
}
/* Load a YAML sequence into a Perl array */
SV *
load_sequence(perl_yaml_loader_t *loader)
{
SV *node;
AV *array = newAV();
SV *array_ref = (SV *)newRV_noinc((SV *)array);
char *anchor = (char *)loader->event.data.sequence_start.anchor;
char *tag = (char *)loader->event.data.mapping_start.tag;
if (anchor)
hv_store(loader->anchors, anchor, strlen(anchor), SvREFCNT_inc(array_ref), 0);
while ((node = load_node(loader))) {
av_push(array, node);
}
if (tag && strEQ(tag, TAG_PERL_PREFIX "array"))
tag = NULL;
if (tag) {
char *class;
char *prefix = TAG_PERL_PREFIX "array:";
if (*tag == '!')
prefix = "!";
else if (strlen(tag) <= strlen(prefix) ||
! strnEQ(tag, prefix, strlen(prefix))
) croak(
loader_error_msg(loader, form("bad tag found for array: '%s'", tag))
);
class = tag + strlen(prefix);
sv_bless(array_ref, gv_stashpv(class, TRUE));
}
return array_ref;
}
/*
* Load a YAML mapping into a Perl hash
*/
SV *
load_mapping(perl_yaml_loader_t *loader, char *tag)
{
SV *key_node;
SV *value_node;
HV *hash = newHV();
SV *hash_ref = (SV *)newRV_noinc((SV *)hash);
char *anchor = (char *)loader->event.data.mapping_start.anchor;
if (!tag)
tag = (char *)loader->event.data.mapping_start.tag;
/* Store the anchor label if any */
if (anchor)
hv_store(loader->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(loader))) {
assert(SvPOK(key_node));
value_node = load_node(loader);
hv_store_ent(
hash, key_node, value_node, 0
);
}
/* Deal with possibly blessing the hash if the YAML tag has a class */
if (tag && strEQ(tag, TAG_PERL_PREFIX "hash"))
tag = NULL;
if (tag) {
char *class;
char *prefix = TAG_PERL_PREFIX "hash:";
if (*tag == '!') {
prefix = "!";
}
else if (strlen(tag) <= strlen(prefix) ||
! strnEQ(tag, prefix, strlen(prefix))
) croak(
loader_error_msg(loader, form("bad tag found for hash: '%s'", tag))
);
class = tag + strlen(prefix);
sv_bless(hash_ref, gv_stashpv(class, TRUE));
}
return hash_ref;
}
/*
* This is the main Load function.
* It takes a yaml stream and turns it into 0 or more Perl objects.
*/
void
Load(SV *yaml_sv)
{
dXSARGS;
perl_yaml_loader_t loader;
SV *node;
char *yaml_str;
STRLEN yaml_len;
/* If UTF8, make copy and downgrade */
if (SvPV_nolen(yaml_sv) && SvUTF8(yaml_sv)) {
yaml_sv = sv_mortalcopy(yaml_sv);
}
yaml_str = SvPVbyte(yaml_sv, yaml_len);
sp = mark;
if (0 && (items || ax)) {} /* XXX Quiet the -Wall warnings for now. */
yaml_parser_initialize(&loader.parser);
loader.document = 0;
yaml_parser_set_input_string(
&loader.parser,
(unsigned char *)yaml_str,
yaml_len
);
/* Get the first event. Must be a STREAM_START */
if (!yaml_parser_parse(&loader.parser, &loader.event))
goto load_error;
if (loader.event.type != YAML_STREAM_START_EVENT)
croak(ERRMSG "Expected STREAM_START_EVENT; Got: %d != %d",
loader.event.type,
YAML_STREAM_START_EVENT
);
loader.anchors = newHV();
sv_2mortal((SV*)loader.anchors);
/* Keep calling load_node until end of stream */
while (1) {
loader.document++;
if (!yaml_parser_parse(&loader.parser, &loader.event))
goto load_error;
if (loader.event.type == YAML_STREAM_END_EVENT)
break;
node = load_node(&loader);
hv_clear(loader.anchors);
if (! node) break;
XPUSHs(sv_2mortal(node));
if (!yaml_parser_parse(&loader.parser, &loader.event))
goto load_error;
if (loader.event.type != YAML_DOCUMENT_END_EVENT)
croak(ERRMSG "Expected DOCUMENT_END_EVENT");
}
/* Make sure the last event is a STREAM_END */
if (loader.event.type != YAML_STREAM_END_EVENT)
croak(ERRMSG "Expected STREAM_END_EVENT; Got: %d != %d",
loader.event.type,
YAML_STREAM_END_EVENT
);
yaml_parser_delete(&loader.parser);
PUTBACK;
return;
load_error:
croak(loader_error_msg(&loader, NULL));
}
/*
* This is the main function for dumping any node.
*/
SV *
load_node(perl_yaml_loader_t *loader)
{
SV* return_sv = NULL;
/* This uses stack, but avoids (severe!) memory leaks */
yaml_event_t uplevel_event;
uplevel_event = loader->event;
/* Get the next parser event */
if (!yaml_parser_parse(&loader->parser, &loader->event))
goto load_error;
/* These events don't need yaml_event_delete */
/* Some kind of error occurred */
if (loader->event.type == YAML_NO_EVENT)
goto load_error;
/* Return NULL when we hit the end of a scope */
if (loader->event.type == YAML_DOCUMENT_END_EVENT ||
loader->event.type == YAML_MAPPING_END_EVENT ||
loader->event.type == YAML_SEQUENCE_END_EVENT) {
/* restore the uplevel event, so it can be properly deleted */
loader->event = uplevel_event;
return return_sv;
}
/* The rest all need cleanup */
switch (loader->event.type) {
char *tag;
/* Handle loading a mapping */
case YAML_MAPPING_START_EVENT:
tag = (char *)loader->event.data.mapping_start.tag;
/* Handle mapping tagged as a Perl hard reference */
if (tag && strEQ(tag, TAG_PERL_REF)) {
return_sv = load_scalar_ref(loader);
break;
}
/* Handle mapping tagged as a Perl typeglob */
if (tag && strEQ(tag, TAG_PERL_GLOB)) {
return_sv = load_glob(loader);
break;
}
return_sv = load_mapping(loader, NULL);
break;
/* Handle loading a sequence into an array */
case YAML_SEQUENCE_START_EVENT:
return_sv = load_sequence(loader);
break;
/* Handle loading a scalar */
case YAML_SCALAR_EVENT:
return_sv = load_scalar(loader);
break;
/* Handle loading an alias node */
case YAML_ALIAS_EVENT:
return_sv = load_alias(loader);
break;
default:
croak("%sInvalid event '%d' at top level", ERRMSG, (int) loader->event.type);
}
yaml_event_delete(&loader->event);
/* restore the uplevel event, so it can be properly deleted */
loader->event = uplevel_event;
return return_sv;
load_error:
croak("%s", loader_error_msg(loader, NULL));
}
/*
* This is the main Load function.
* It takes a yaml stream and turns it into 0 or more Perl objects.
*/
void
Load(SV *yaml_sv)
{
dXSARGS;
perl_yaml_loader_t loader;
SV *node;
const unsigned char *yaml_str;
STRLEN yaml_len;
yaml_str = (const unsigned char *)SvPV_const(yaml_sv, yaml_len);
if (DO_UTF8(yaml_sv)) {
yaml_sv = sv_mortalcopy(yaml_sv);
if (!sv_utf8_downgrade(yaml_sv, TRUE))
croak("%s", "Wide character in YAML::XS::Load()");
yaml_str = (const unsigned char *)SvPV_const(yaml_sv, yaml_len);
}
sp = mark;
if (0 && (items || ax)) {} /* XXX Quiet the -Wall warnings for now. */
yaml_parser_initialize(&loader.parser);
loader.document = 0;
yaml_parser_set_input_string(
&loader.parser,
yaml_str,
yaml_len
);
/* Get the first event. Must be a STREAM_START */
if (!yaml_parser_parse(&loader.parser, &loader.event))
goto load_error;
if (loader.event.type != YAML_STREAM_START_EVENT)
croak("%sExpected STREAM_START_EVENT; Got: %d != %d",
ERRMSG,
loader.event.type,
YAML_STREAM_START_EVENT
);
loader.anchors = newHV();
sv_2mortal((SV *)loader.anchors);
/* Keep calling load_node until end of stream */
while (1) {
loader.document++;
/* We are through with the previous event - delete it! */
yaml_event_delete(&loader.event);
if (!yaml_parser_parse(&loader.parser, &loader.event))
goto load_error;
if (loader.event.type == YAML_STREAM_END_EVENT)
break;
node = load_node(&loader);
/* We are through with the previous event - delete it! */
yaml_event_delete(&loader.event);
hv_clear(loader.anchors);
if (! node) break;
XPUSHs(sv_2mortal(node));
if (!yaml_parser_parse(&loader.parser, &loader.event))
goto load_error;
if (loader.event.type != YAML_DOCUMENT_END_EVENT)
croak("%sExpected DOCUMENT_END_EVENT", ERRMSG);
}
/* Make sure the last event is a STREAM_END */
if (loader.event.type != YAML_STREAM_END_EVENT)
croak("%sExpected STREAM_END_EVENT; Got: %d != %d",
ERRMSG,
loader.event.type,
YAML_STREAM_END_EVENT
);
yaml_parser_delete(&loader.parser);
PUTBACK;
return;
load_error:
croak("%s", loader_error_msg(&loader, NULL));
}
