whoami7 - Manager
:
/
root
/
.cpanm
/
latest-build
/
YAML-Syck-1.34
/
Upload File:
files >> //root/.cpanm/latest-build/YAML-Syck-1.34/perl_syck.h
/* Implementation-specific variables */ #undef PACKAGE_NAME #undef NULL_LITERAL #undef NULL_LITERAL_LENGTH #undef SCALAR_NUMBER #undef SCALAR_STRING #undef SCALAR_QUOTED #undef SCALAR_UTF8 #undef SEQ_NONE #undef MAP_NONE #undef IS_UTF8 #undef TYPE_IS_NULL #undef OBJOF #undef PERL_SYCK_PARSER_HANDLER #undef PERL_SYCK_EMITTER_HANDLER #undef PERL_SYCK_INDENT_LEVEL #undef PERL_SYCK_MARK_EMITTER #undef PERL_SYCK_EMITTER_MARK_NODE_FLAGS #ifdef YAML_IS_JSON # define PACKAGE_NAME "JSON::Syck" # define NULL_LITERAL "null" # define NULL_LITERAL_LENGTH 4 # define SCALAR_NUMBER scalar_none # define PERL_SYCK_EMITTER_MARK_NODE_FLAGS EMITTER_MARK_NODE_FLAG_PERMIT_DUPLICATE_NODES int json_max_depth = 512; char json_quote_char = '"'; static enum scalar_style json_quote_style = scalar_2quote; # define SCALAR_STRING json_quote_style # define SCALAR_QUOTED json_quote_style # define SCALAR_UTF8 scalar_fold # define SEQ_NONE seq_inline # define MAP_NONE map_inline # define IS_UTF8(x) TRUE # define TYPE_IS_NULL(x) ((x == NULL) || strEQ( x, "str" )) # define OBJOF(a) (a) # define PERL_SYCK_PARSER_HANDLER json_syck_parser_handler # define PERL_SYCK_EMITTER_HANDLER json_syck_emitter_handler # define PERL_SYCK_MARK_EMITTER json_syck_mark_emitter # define PERL_SYCK_INDENT_LEVEL 0 #else # define PACKAGE_NAME "YAML::Syck" # define REGEXP_LITERAL "REGEXP" # define REGEXP_LITERAL_LENGTH 6 # define REF_LITERAL "=" # define REF_LITERAL_LENGTH 1 # define NULL_LITERAL "~" # define NULL_LITERAL_LENGTH 1 # define SCALAR_NUMBER scalar_none # define PERL_SYCK_EMITTER_MARK_NODE_FLAGS 0 static enum scalar_style yaml_quote_style = scalar_none; # define SCALAR_STRING yaml_quote_style # define SCALAR_QUOTED scalar_1quote # define SCALAR_UTF8 scalar_fold # define SEQ_NONE seq_none # define MAP_NONE map_none #ifdef SvUTF8 # define IS_UTF8(x) (SvUTF8(sv)) #else # define IS_UTF8(x) (FALSE) #endif # define TYPE_IS_NULL(x) (x == NULL) # define OBJOF(a) (*tag ? tag : a) # define PERL_SYCK_PARSER_HANDLER yaml_syck_parser_handler # define PERL_SYCK_EMITTER_HANDLER yaml_syck_emitter_handler # define PERL_SYCK_MARK_EMITTER yaml_syck_mark_emitter # define PERL_SYCK_INDENT_LEVEL 2 #endif #define TRACK_OBJECT(sv) (av_push(((struct parser_xtra *)p->bonus)->objects, sv)) #define USE_OBJECT(sv) (SvREFCNT_inc(sv)) #ifndef YAML_IS_JSON #ifndef SvRV_set /* prior to 5.8.7; thx charsbar! */ #define SvRV_set(sv, val) \ STMT_START { \ (SvRV(sv) = (val)); } STMT_END #endif static const char * is_bad_alias_object( SV *sv ) { SV *hv, **psv; if (! sv_isobject(sv)) return NULL; hv = SvRV(sv); if (! strnEQ(sv_reftype(hv, 1), "YAML::Syck::BadAlias", 20-1)) return NULL; psv = hv_fetch((HV *) hv, "name", 4, 0); if (! psv) return NULL; return SvPVX(*psv); } static void register_bad_alias( SyckParser *p, const char *anchor, SV *sv ) { HV *map; SV **pref_av, *new_rvav; AV *rvs; map = ((struct parser_xtra *)p->bonus)->bad_anchors; pref_av = hv_fetch(map, anchor, strlen(anchor), 0); if (! pref_av) { new_rvav = newRV_noinc((SV *) newAV()); hv_store(map, anchor, strlen(anchor), new_rvav, 0); pref_av = &new_rvav; } rvs = (AV *) SvRV(*pref_av); SvREFCNT_inc(sv); av_push(rvs, sv); } static void resolve_bad_alias( SyckParser *p, const char *anchor, SV *sv ) { HV *map; SV **pref_av, *entity; AV *rvs; I32 len, i; entity = SvRV(sv); map = ((struct parser_xtra *)p->bonus)->bad_anchors; pref_av = hv_fetch(map, anchor, strlen(anchor), 0); if (! pref_av) return; rvs = (AV *) SvRV(*pref_av); len = av_len(rvs)+1; for (i = 0; i < len; i ++) { SV **prv = av_fetch(rvs, i, 0); if (prv) { SvREFCNT_dec(SvRV(*prv)); SvRV_set(*prv, entity); SvREFCNT_inc(entity); } } av_clear(rvs); } #endif SYMID #ifdef YAML_IS_JSON json_syck_parser_handler #else yaml_syck_parser_handler #endif (SyckParser *p, SyckNode *n) { SV *sv = NULL; AV *seq; HV *map; long i; char *id = n->type_id; #ifndef YAML_IS_JSON struct parser_xtra *bonus = (struct parser_xtra *)p->bonus; bool load_code = bonus->load_code; bool load_blessed = bonus->load_blessed; #endif while (id && (*id == '!')) { id++; } switch (n->kind) { case syck_str_kind: if (TYPE_IS_NULL(id)) { if (strnEQ( n->data.str->ptr, NULL_LITERAL, 1+NULL_LITERAL_LENGTH) && (n->data.str->style == scalar_plain)) { sv = newSV(0); } else { sv = newSVpvn(n->data.str->ptr, n->data.str->len); CHECK_UTF8; } } else if (strEQ( id, "null" )) { sv = newSV(0); } else if (strEQ( id, "bool#yes" )) { sv = newSVsv(&PL_sv_yes); } else if (strEQ( id, "bool#no" )) { sv = newSVsv(&PL_sv_no); } else if (strEQ( id, "default" )) { sv = newSVpvn(n->data.str->ptr, n->data.str->len); CHECK_UTF8; } else if (strEQ( id, "float#base60" )) { char *ptr, *end; UV sixty = 1; NV total = 0.0; syck_str_blow_away_commas( n ); ptr = n->data.str->ptr; end = n->data.str->ptr + n->data.str->len; while ( end > ptr ) { NV bnum = 0; char *colon = end - 1; while ( colon >= ptr && *colon != ':' ) { colon--; } if ( *colon == ':' ) *colon = '\0'; bnum = strtod( colon + 1, NULL ); total += bnum * sixty; sixty *= 60; end = colon; } sv = newSVnv(total); #ifdef NV_NAN } else if (strEQ( id, "float#nan" )) { sv = newSVnv(NV_NAN); #endif #ifdef NV_INF } else if (strEQ( id, "float#inf" )) { sv = newSVnv(NV_INF); } else if (strEQ( id, "float#neginf" )) { sv = newSVnv(-NV_INF); #endif } else if (strnEQ( id, "float", 5 )) { NV f; syck_str_blow_away_commas( n ); f = strtod( n->data.str->ptr, NULL ); sv = newSVnv( f ); } else if (strEQ( id, "int#base60" )) { char *ptr, *end; UV sixty = 1; UV total = 0; syck_str_blow_away_commas( n ); ptr = n->data.str->ptr; end = n->data.str->ptr + n->data.str->len; while ( end > ptr ) { long bnum = 0; char *colon = end - 1; while ( colon >= ptr && *colon != ':' ) { colon--; } if ( *colon == ':' ) *colon = '\0'; bnum = strtol( colon + 1, NULL, 10 ); total += bnum * sixty; sixty *= 60; end = colon; } sv = newSVuv(total); } else if (strEQ( id, "int#hex" )) { I32 flags = 0; STRLEN len = n->data.str->len; syck_str_blow_away_commas( n ); sv = newSVuv( grok_hex( n->data.str->ptr, &len, &flags, NULL) ); } else if (strEQ( id, "int#oct" )) { I32 flags = 0; STRLEN len = n->data.str->len; syck_str_blow_away_commas( n ); sv = newSVuv( grok_oct( n->data.str->ptr, &len, &flags, NULL) ); } else if (strEQ( id, "int" ) ) { UV uv; int flags; syck_str_blow_away_commas( n ); flags = grok_number( n->data.str->ptr, n->data.str->len, &uv); if (flags == IS_NUMBER_IN_UV) { if (uv <= IV_MAX) { sv = newSViv(uv); } else { sv = newSVuv(uv); } } else if ((flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) && (uv <= (UV) IV_MIN)) { sv = newSViv(-(IV)uv); } else { sv = newSVnv(Atof( n->data.str->ptr )); } } else if (strEQ( id, "binary" )) { long len = 0; char *blob = syck_base64dec(n->data.str->ptr, n->data.str->len, &len); sv = newSVpv(blob, len); #ifndef YAML_IS_JSON #ifdef PERL_LOADMOD_NOIMPORT } else if (strEQ(id, "perl/code") || strnEQ(id, "perl/code:", 10)) { SV *cv; SV *sub; char *pkg = id + 10; if (load_code) { SV *text; /* This code is copypasted from Storable.xs */ /* * prepend "sub " to the source */ text = newSVpvn(n->data.str->ptr, n->data.str->len); sub = newSVpvn("sub ", 4); sv_catpv(sub, SvPV_nolen(text)); /* XXX no sv_catsv! */ SvREFCNT_dec(text); } else { sub = newSVpvn("sub {}", 6); } ENTER; SAVETMPS; cv = eval_pv(SvPV_nolen(sub), TRUE); sv_2mortal(sub); if (cv && SvROK(cv) && SvTYPE(SvRV(cv)) == SVt_PVCV) { sv = cv; } else { croak("code %s did not evaluate to a subroutine reference\n", SvPV_nolen(sub)); } SvREFCNT_inc(sv); /* XXX seems to be necessary */ FREETMPS; LEAVE; if ( load_blessed && (*(pkg - 1) != '\0') && (*pkg != '\0') ) { sv_bless(sv, gv_stashpv(pkg, TRUE)); } /* END Storable */ } else if (strnEQ( n->data.str->ptr, REF_LITERAL, 1+REF_LITERAL_LENGTH)) { /* type tag in a scalar ref */ char *lang = strtok(id, "/:"); char *type = strtok(NULL, ""); if (lang == NULL || (strEQ(lang, "perl"))) { sv = newSVpv(type, 0); } else { sv = newSVpv(form((type == NULL) ? "%s" : "%s::%s", lang, type), 0); } } else if ( strEQ( id, "perl/scalar" ) || strnEQ( id, "perl/scalar:", 12 ) ) { char *pkg = id + 12; if (strnEQ( n->data.str->ptr, NULL_LITERAL, 1+NULL_LITERAL_LENGTH) && (n->data.str->style == scalar_plain)) { sv = newSV(0); } else { sv = newSVpvn(n->data.str->ptr, n->data.str->len); CHECK_UTF8; } sv = newRV_inc(sv); if ( load_blessed && (*(pkg - 1) != '\0') && (*pkg != '\0') ) { sv_bless(sv, gv_stashpv(id + 12, TRUE)); } } else if ( (strEQ(id, "perl/regexp") || strnEQ( id, "perl/regexp:", 12 ) ) ) { dSP; SV *val = newSVpvn(n->data.str->ptr, n->data.str->len); char *lang = strtok(id, "/:"); char *type = strtok(NULL, ""); ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(val); PUTBACK; call_pv("YAML::Syck::__qr_helper", G_SCALAR); SPAGAIN; sv = newSVsv(POPs); PUTBACK; FREETMPS; LEAVE; /* bless it if necessary */ if ( type != NULL && strnEQ(type, "regexp:", 7)) { /* !perl/regexp:Foo::Bar blesses into Foo::Bar */ type += 7; } if ( load_blessed ) { if (lang == NULL || (strEQ(lang, "perl"))) { /* !perl/regexp on it's own causes no blessing */ if ( (type != NULL) && strNE(type, "regexp") && (*type != '\0')) { sv_bless(sv, gv_stashpv(type, TRUE)); } } else { sv_bless(sv, gv_stashpv(form((type == NULL) ? "%s" : "%s::%s", lang, type), TRUE)); } } #endif /* PERL_LOADMOD_NOIMPORT */ #endif /* !YAML_IS_JSON */ } else { /* croak("unknown node type: %s", id); */ sv = newSVpvn(n->data.str->ptr, n->data.str->len); CHECK_UTF8; } break; case syck_seq_kind: /* load the seq into a new AV and place a ref to it in the SV */ seq = newAV(); for (i = 0; i < n->data.list->idx; i++) { SV *a = perl_syck_lookup_sym(p, syck_seq_read(n, i)); #ifndef YAML_IS_JSON const char *forward_anchor; a = sv_2mortal(newSVsv(a)); forward_anchor = is_bad_alias_object(a); if (forward_anchor) register_bad_alias(p, forward_anchor, a); #endif av_push(seq, a); USE_OBJECT(a); } /* create the ref to the new array in the sv */ sv = newRV_noinc((SV*)seq); #ifndef YAML_IS_JSON if (id) { /* bless it if necessary */ char *lang = strtok(id, "/:"); char *type = strtok(NULL, ""); if ( type != NULL ) { if (strnEQ(type, "array:", 6)) { /* !perl/array:Foo::Bar blesses into Foo::Bar */ type += 6; } /* FIXME deprecated - here compatibility with @Foo::Bar style blessing */ while ( *type == '@' ) { type++; } } if (load_blessed) { if (lang == NULL || (strEQ(lang, "perl"))) { /* !perl/array on it's own causes no blessing */ if ( (type != NULL) && strNE(type, "array") && *type != '\0' ) { sv_bless(sv, gv_stashpv(type, TRUE)); } } else { sv_bless(sv, gv_stashpv(form((type == NULL) ? "%s" : "%s::%s", lang, type), TRUE)); } } } #endif break; case syck_map_kind: #ifndef YAML_IS_JSON if ( (id != NULL) && (strEQ(id, "perl/ref") || strnEQ( id, "perl/ref:", 9 ) ) ) { /* handle scalar references, that are a weird type of mappings */ SV* key = perl_syck_lookup_sym(p, syck_map_read(n, map_key, 0)); SV* val = perl_syck_lookup_sym(p, syck_map_read(n, map_value, 0)); char *ref_type = SvPVX(key); #if 0 /* need not to duplicate scalar reference */ const char *forward_anchor; val = sv_2mortal(newSVsv(val)); forward_anchor = is_bad_alias_object(val); if (forward_anchor) register_bad_alias(p, forward_anchor, val); #endif sv = newRV_noinc(val); USE_OBJECT(val); if ( load_blessed ) { if ( strnNE(ref_type, REF_LITERAL, REF_LITERAL_LENGTH+1)) { /* handle the weird audrey scalar ref stuff */ sv_bless(sv, gv_stashpv(ref_type, TRUE)); } else { /* bless it if necessary */ char *lang = strtok(id, "/:"); char *type = strtok(NULL, ""); if ( type != NULL && strnEQ(type, "ref:", 4)) { /* !perl/ref:Foo::Bar blesses into Foo::Bar */ type += 4; } if (lang == NULL || (strEQ(lang, "perl"))) { /* !perl/ref on it's own causes no blessing */ if ( (type != NULL) && strNE(type, "ref") && (*type != '\0')) { sv_bless(sv, gv_stashpv(type, TRUE)); } } else { sv_bless(sv, gv_stashpv(form((type == NULL) ? "%s" : "%s::%s", lang, type), TRUE)); } } } } else if ( (id != NULL) && (strEQ(id, "perl/regexp") || strnEQ( id, "perl/regexp:", 12 ) ) ) { /* handle regexp references, that are a weird type of mappings */ dSP; SV* key = perl_syck_lookup_sym(p, syck_map_read(n, map_key, 0)); SV* val = perl_syck_lookup_sym(p, syck_map_read(n, map_value, 0)); char *ref_type = SvPVX(key); ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(val); PUTBACK; call_pv("YAML::Syck::__qr_helper", G_SCALAR); SPAGAIN; sv = newSVsv(POPs); PUTBACK; FREETMPS; LEAVE; if ( load_blessed ) { if (strnNE(ref_type, REGEXP_LITERAL, REGEXP_LITERAL_LENGTH+1)) { /* handle the weird audrey scalar ref stuff */ sv_bless(sv, gv_stashpv(ref_type, TRUE)); } else { /* bless it if necessary */ char *lang = strtok(id, "/:"); char *type = strtok(NULL, ""); if ( type != NULL && strnEQ(type, "regexp:", 7)) { /* !perl/regexp:Foo::Bar blesses into Foo::Bar */ type += 7; } if (lang == NULL || (strEQ(lang, "perl"))) { /* !perl/regexp on it's own causes no blessing */ if ( (type != NULL) && strNE(type, "regexp") && (*type != '\0')) { sv_bless(sv, gv_stashpv(type, TRUE)); } } else { sv_bless(sv, gv_stashpv(form((type == NULL) ? "%s" : "%s::%s", lang, type), TRUE)); } } } } else if (id && strnEQ(id, "perl:YAML::Syck::BadAlias", 25-1)) { SV* key = (SV *) syck_map_read(n, map_key, 0); SV* val = (SV *) syck_map_read(n, map_value, 0); map = newHV(); if (hv_store_ent(map, key, val, 0) != NULL) USE_OBJECT(val); sv = newRV_noinc((SV*)map); sv_bless(sv, gv_stashpv("YAML::Syck::BadAlias", TRUE)); } else #endif { /* load the map into a new HV and place a ref to it in the SV */ map = newHV(); for (i = 0; i < n->data.pairs->idx; i++) { SV* key = perl_syck_lookup_sym(p, syck_map_read(n, map_key, i)); SV* val = perl_syck_lookup_sym(p, syck_map_read(n, map_value, i)); #ifndef YAML_IS_JSON const char *forward_anchor; val = sv_2mortal(newSVsv(val)); forward_anchor = is_bad_alias_object(val); if (forward_anchor) register_bad_alias(p, forward_anchor, val); #endif if (hv_store_ent(map, key, val, 0) != NULL) USE_OBJECT(val); } sv = newRV_noinc((SV*)map); #ifndef YAML_IS_JSON if (id) { /* bless it if necessary */ char *lang = strtok(id, "/:"); char *type = strtok(NULL, ""); if ( type != NULL ) { if (strnEQ(type, "hash:", 5)) { /* !perl/hash:Foo::Bar blesses into Foo::Bar */ type += 5; } /* FIXME deprecated - here compatibility with %Foo::Bar style blessing */ while ( *type == '%' ) { type++; } } if (load_blessed) { if (lang == NULL || (strEQ(lang, "perl"))) { /* !perl/hash on it's own causes no blessing */ if ( (type != NULL) && strNE(type, "hash") && *type != '\0' ) { sv_bless(sv, gv_stashpv(type, TRUE)); } } else { sv_bless(sv, gv_stashpv(form((type == NULL) ? "%s" : "%s::%s", lang, type), TRUE)); } } } #endif } break; } #ifndef YAML_IS_JSON /* Fix bad anchors using sv_setsv */ if (n->id) { if (n->anchor) resolve_bad_alias(p, n->anchor, sv); sv_setsv( perl_syck_lookup_sym(p, n->id), sv ); } #endif TRACK_OBJECT(sv); return syck_add_sym(p, (char *)sv); } #ifdef YAML_IS_JSON static char* perl_json_preprocess(char *s) { int i; char *out; char ch; char in_string = '\0'; bool in_quote = 0; char *pos; STRLEN len = strlen(s); New(2006, out, len*2+1, char); pos = out; for (i = 0; i < len; i++) { ch = *(s+i); *pos++ = ch; if (in_quote) { in_quote = !in_quote; if (ch == '\'') { *(pos - 2) = '\''; } } else if (ch == '\\') { in_quote = 1; } else if (in_string == '\0') { switch (ch) { case ':': { *pos++ = ' '; break; } case ',': { *pos++ = ' '; break; } case '"': { in_string = '"'; break; } case '\'': { in_string = '\''; break; } } } else if (ch == in_string) { in_string = '\0'; } } *pos = '\0'; return out; } void perl_json_postprocess(SV *sv) { int i; char ch; bool in_string = 0; bool in_quote = 0; char *pos; char *s = SvPVX(sv); STRLEN len = sv_len(sv); STRLEN final_len = len; pos = s; /* Horrible kluge if your quote char does not match what's wrapping this line */ if ( (json_quote_char == '\'') && (len > 1) && (*s == '\"') && (*(s+len-2) == '\"') ) { *s = '\''; *(s+len-2) = '\''; } /* 2010-07-20 - TODDR: This for loop doesn't appear to do anything other than shorten * the line if it sees [,:] when not in quotes. Even then it appears that the \0 isn't * being placed right if that happens. TODO: need test case to prove this does not work * as expected. */ for (i = 0; i < len; i++) { ch = *(s+i); *pos++ = ch; if (in_quote) { in_quote = !in_quote; } else if (ch == '\\') { in_quote = 1; } else if (ch == json_quote_char) { in_string = !in_string; } else if ((ch == ':' || ch == ',') && !in_string) { i++; /* has to be a space afterwards */ final_len--; } } /* Remove the trailing newline */ if (final_len > 0) { final_len--; pos--; } *pos = '\0'; SvCUR_set(sv, final_len); } #endif #ifdef YAML_IS_JSON static SV * LoadJSON (char *s) { #else static SV * LoadYAML (char *s) { #endif SYMID v; SyckParser *parser; struct parser_xtra bonus; SV *obj = &PL_sv_undef; SV *use_code = GvSV(gv_fetchpv(form("%s::UseCode", PACKAGE_NAME), TRUE, SVt_PV)); SV *load_code = GvSV(gv_fetchpv(form("%s::LoadCode", PACKAGE_NAME), TRUE, SVt_PV)); SV *implicit_typing = GvSV(gv_fetchpv(form("%s::ImplicitTyping", PACKAGE_NAME), TRUE, SVt_PV)); SV *implicit_unicode = GvSV(gv_fetchpv(form("%s::ImplicitUnicode", PACKAGE_NAME), TRUE, SVt_PV)); SV *singlequote = GvSV(gv_fetchpv(form("%s::SingleQuote", PACKAGE_NAME), TRUE, SVt_PV)); SV *load_blessed = GvSV(gv_fetchpv(form("%s::LoadBlessed", PACKAGE_NAME), TRUE, SVt_PV)); json_quote_char = (SvTRUE(singlequote) ? '\'' : '"' ); ENTER; SAVETMPS; /* Don't even bother if the string is empty. */ if (*s == '\0') { return &PL_sv_undef; } #ifdef YAML_IS_JSON s = perl_json_preprocess(s); #else /* Special preprocessing to maintain compat with YAML.pm <= 0.35 */ if (strnEQ( s, "--- #YAML:1.0", 13)) { s[4] = '%'; } #endif parser = syck_new_parser(); syck_parser_str_auto(parser, s, NULL); syck_parser_handler(parser, PERL_SYCK_PARSER_HANDLER); syck_parser_error_handler(parser, perl_syck_error_handler); syck_parser_bad_anchor_handler( parser, perl_syck_bad_anchor_handler ); syck_parser_implicit_typing(parser, SvTRUE(implicit_typing)); syck_parser_taguri_expansion(parser, 0); bonus.objects = (AV*)sv_2mortal((SV*)newAV()); bonus.implicit_unicode = SvTRUE(implicit_unicode); bonus.load_code = SvTRUE(use_code) || SvTRUE(load_code); bonus.load_blessed = SvTRUE(load_blessed); parser->bonus = &bonus; #ifndef YAML_IS_JSON bonus.bad_anchors = (HV*)sv_2mortal((SV*)newHV()); if (GIMME_V == G_ARRAY) { SYMID prev_v = 0; obj = (SV*)newAV(); while ((v = syck_parse(parser)) && (v != prev_v)) { SV *cur = &PL_sv_undef; if (!syck_lookup_sym(parser, v, (char **)&cur)) { break; } av_push((AV*)obj, cur); USE_OBJECT(cur); prev_v = v; } obj = newRV_noinc(obj); } else #endif { v = syck_parse(parser); if (syck_lookup_sym(parser, v, (char **)&obj)) { USE_OBJECT(obj); } } syck_free_parser(parser); #ifdef YAML_IS_JSON Safefree(s); #endif FREETMPS; LEAVE; return obj; } void #ifdef YAML_IS_JSON json_syck_mark_emitter #else yaml_syck_mark_emitter #endif (SyckEmitter *e, SV *sv) { #ifdef YAML_IS_JSON e->depth++; #endif if (syck_emitter_mark_node(e, (st_data_t)sv, PERL_SYCK_EMITTER_MARK_NODE_FLAGS) == 0) { #ifdef YAML_IS_JSON e->depth--; #endif return; } #ifdef YAML_IS_JSON if (e->depth >= e->max_depth) { croak("Dumping circular structures is not supported with JSON::Syck, consider increasing $JSON::Syck::MaxDepth higher then %d.", e->max_depth); } #endif if (SvROK(sv)) { PERL_SYCK_MARK_EMITTER(e, SvRV(sv)); #ifdef YAML_IS_JSON st_insert(e->markers, (st_data_t)sv, 0); e->depth--; #endif return; } switch (SvTYPE(sv)) { case SVt_PVAV: { I32 len, i; len = av_len((AV*)sv) + 1; for (i = 0; i < len; i++) { SV** sav = av_fetch((AV*)sv, i, 0); if (sav != NULL) { PERL_SYCK_MARK_EMITTER( e, *sav ); } } break; } case SVt_PVHV: { I32 len, i; #ifdef HAS_RESTRICTED_HASHES len = HvTOTALKEYS((HV*)sv); #else len = HvKEYS((HV*)sv); #endif hv_iterinit((HV*)sv); for (i = 0; i < len; i++) { #ifdef HV_ITERNEXT_WANTPLACEHOLDERS HE *he = hv_iternext_flags((HV*)sv, HV_ITERNEXT_WANTPLACEHOLDERS); #else HE *he = hv_iternext((HV*)sv); #endif SV *val = hv_iterval((HV*)sv, he); PERL_SYCK_MARK_EMITTER( e, val ); } break; } } #ifdef YAML_IS_JSON st_insert(e->markers, (st_data_t)sv, 0); --e->depth; #endif } void #ifdef YAML_IS_JSON json_syck_emitter_handler #else yaml_syck_emitter_handler #endif (SyckEmitter *e, st_data_t data) { I32 len, i; SV* sv = (SV*)data; struct emitter_xtra *bonus = (struct emitter_xtra *)e->bonus; char* tag = bonus->tag; svtype ty = SvTYPE(sv); #ifndef YAML_IS_JSON char dump_code = bonus->dump_code; char implicit_binary = bonus->implicit_binary; char* ref = NULL; #endif #define OBJECT_TAG "tag:!perl:" if (SvMAGICAL(sv)) { mg_get(sv); } #ifndef YAML_IS_JSON /* Handle blessing into the right class */ if (sv_isobject(sv)) { ref = savepv(sv_reftype(SvRV(sv), TRUE)); *tag = '\0'; strcat(tag, OBJECT_TAG); switch (SvTYPE(SvRV(sv))) { case SVt_PVAV: { strcat(tag, "array:"); break; } case SVt_PVHV: { strcat(tag, "hash:"); break; } case SVt_PVCV: { strcat(tag, "code:"); break; } case SVt_PVGV: { strcat(tag, "glob:"); break; } #if PERL_VERSION > 10 case SVt_REGEXP: { if (strEQ(ref, "Regexp")) { strcat(tag, "regexp"); ref += 6; /* empty string */ } else { strcat(tag, "regexp:"); } break; } #endif /* flatten scalar ref objects so that they dump as !perl/scalar:Foo::Bar foo */ case SVt_PVMG: { if ( SvROK(SvRV(sv)) ) { strcat(tag, "ref:"); break; } #if PERL_VERSION > 10 else { strcat(tag, "scalar:"); sv = SvRV(sv); ty = SvTYPE(sv); break; } #else else { MAGIC *mg; if ( (mg = mg_find(SvRV(sv), PERL_MAGIC_qr) ) ) { if (strEQ(ref, "Regexp")) { strcat(tag, "regexp"); ref += 6; /* empty string */ } else { strcat(tag, "regexp:"); } sv = newSVpvn(SvPV_nolen(sv), sv_len(sv)); ty = SvTYPE(sv); } else { strcat(tag, "scalar:"); sv = SvRV(sv); ty = SvTYPE(sv); } break; } #endif } } strcat(tag, ref); } #endif if (SvROK(sv)) { /* emit a scalar ref */ #ifdef YAML_IS_JSON PERL_SYCK_EMITTER_HANDLER(e, (st_data_t)SvRV(sv)); #else switch (SvTYPE(SvRV(sv))) { case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: { /* Arrays, hashes and code values are inlined, and will be wrapped by a ref in the undumping */ e->indent = 0; syck_emit_item(e, (st_data_t)SvRV(sv)); e->indent = PERL_SYCK_INDENT_LEVEL; break; } #if PERL_VERSION > 10 case SVt_REGEXP: { STRLEN len = sv_len(sv); syck_emit_scalar( e, OBJOF("tag:!perl:regexp"), SCALAR_STRING, 0, 0, 0, SvPV_nolen(sv), len ); syck_emit_end(e); break; } #endif default: { syck_emit_map(e, OBJOF("tag:!perl:ref"), MAP_NONE); *tag = '\0'; syck_emit_item( e, (st_data_t)newSVpvn_share(REF_LITERAL, REF_LITERAL_LENGTH, 0) ); syck_emit_item( e, (st_data_t)SvRV(sv) ); syck_emit_end(e); } } #endif } else if (ty == SVt_NULL) { /* emit an undef */ syck_emit_scalar(e, "str", scalar_plain, 0, 0, 0, NULL_LITERAL, NULL_LITERAL_LENGTH); } else if ((ty == SVt_PVMG) && !SvOK(sv)) { /* emit an undef (typically pointed from a blesed SvRV) */ syck_emit_scalar(e, OBJOF("str"), scalar_plain, 0, 0, 0, NULL_LITERAL, NULL_LITERAL_LENGTH); } else if (SvPOK(sv)) { /* emit a string */ STRLEN len = sv_len(sv); /* JSON should preserve quotes even on simple integers ("0" is true in javascript) */ #ifndef YAML_IS_JSON if (looks_like_number(sv)) { if(syck_str_is_unquotable_integer(SvPV_nolen(sv), sv_len(sv))) { /* emit an unquoted number only if it's a very basic integer. /^-?[1-9][0-9]*$/ */ syck_emit_scalar(e, OBJOF("str"), SCALAR_NUMBER, 0, 0, 0, SvPV_nolen(sv), len); } else { /* Even though it looks like a number, quote it or it won't round trip correctly. */ syck_emit_scalar(e, OBJOF("str"), SCALAR_QUOTED, 0, 0, 0, SvPV_nolen(sv), len); } } else #endif if (len == 0) { syck_emit_scalar(e, OBJOF("str"), SCALAR_QUOTED, 0, 0, 0, "", 0); } else if (IS_UTF8(sv)) { /* if we support UTF8 and the string contains UTF8 */ enum scalar_style old_s = e->style; e->style = SCALAR_UTF8; syck_emit_scalar(e, OBJOF("str"), SCALAR_STRING, 0, 0, 0, SvPV_nolen(sv), len); e->style = old_s; } #ifndef YAML_IS_JSON else if (implicit_binary) { /* scan string for high-bits in the SV */ bool is_ascii = TRUE; char *str = SvPV_nolen(sv); STRLEN len = sv_len(sv); for (i = 0; i < len; i++) { if (*(str + i) & 0x80) { /* Binary here */ char *base64 = syck_base64enc( str, len ); syck_emit_scalar(e, "tag:yaml.org,2002:binary", SCALAR_STRING, 0, 0, 0, base64, strlen(base64)); is_ascii = FALSE; break; } } if (is_ascii) { syck_emit_scalar(e, OBJOF("str"), SCALAR_STRING, 0, 0, 0, str, len); } } #endif else { syck_emit_scalar(e, OBJOF("str"), SCALAR_STRING, 0, 0, 0, SvPV_nolen(sv), len); } } else if (SvNIOK(sv)) { /* Stringify the sv, being careful not to overwrite its PV part */ SV *sv2 = newSVsv(sv); STRLEN len; char *str = SvPV(sv2, len); if (SvIOK(sv) /* original SV was an int */ && syck_str_is_unquotable_integer(str, len)) /* small enough to safely round-trip */ { syck_emit_scalar(e, OBJOF("str"), SCALAR_NUMBER, 0, 0, 0, str, len); } else { /* We need to quote it */ syck_emit_scalar(e, OBJOF("str"), SCALAR_QUOTED, 0, 0, 0, str, len); } SvREFCNT_dec(sv2); } else { switch (ty) { case SVt_PVAV: { /* array */ syck_emit_seq(e, OBJOF("array"), SEQ_NONE); e->indent = PERL_SYCK_INDENT_LEVEL; *tag = '\0'; len = av_len((AV*)sv) + 1; for (i = 0; i < len; i++) { SV** sav = av_fetch((AV*)sv, i, 0); if (sav == NULL) { syck_emit_item( e, (st_data_t)(&PL_sv_undef) ); } else { syck_emit_item( e, (st_data_t)(*sav) ); } } syck_emit_end(e); return; } case SVt_PVHV: { /* hash */ HV *hv = (HV*)sv; syck_emit_map(e, OBJOF("hash"), MAP_NONE); e->indent = PERL_SYCK_INDENT_LEVEL; *tag = '\0'; #ifdef HAS_RESTRICTED_HASHES len = HvTOTALKEYS((HV*)sv); #else len = HvKEYS((HV*)sv); #endif hv_iterinit((HV*)sv); if (e->sort_keys) { AV *av = (AV*)sv_2mortal((SV*)newAV()); for (i = 0; i < len; i++) { #ifdef HAS_RESTRICTED_HASHES HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS); #else HE *he = hv_iternext(hv); #endif SV *key = hv_iterkeysv(he); av_store(av, AvFILLp(av)+1, key); /* av_push(), really */ } STORE_HASH_SORT; for (i = 0; i < len; i++) { #ifdef HAS_RESTRICTED_HASHES int placeholders = (int)HvPLACEHOLDERS_get(hv); #endif SV *key = av_shift(av); HE *he = hv_fetch_ent(hv, key, 0, 0); SV *val = HeVAL(he); if (val == NULL) { val = &PL_sv_undef; } syck_emit_item( e, (st_data_t)key ); syck_emit_item( e, (st_data_t)val ); } } else { for (i = 0; i < len; i++) { #ifdef HV_ITERNEXT_WANTPLACEHOLDERS HE *he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS); #else HE *he = hv_iternext(hv); #endif SV *key = hv_iterkeysv(he); SV *val = hv_iterval(hv, he); syck_emit_item( e, (st_data_t)key ); syck_emit_item( e, (st_data_t)val ); } } /* reset the hash pointer */ hv_iterinit(hv); syck_emit_end(e); return; } case SVt_PVCV: { /* code */ #ifdef YAML_IS_JSON syck_emit_scalar(e, "str", scalar_plain, 0, 0, 0, NULL_LITERAL, NULL_LITERAL_LENGTH); #else /* This following code is mostly copypasted from Storable */ #if PERL_VERSION < 8 syck_emit_scalar(e, OBJOF("tag:!perl:code:"), SCALAR_QUOTED, 0, 0, 0, "{ \"DUMMY\" }", 11); #else if ( !dump_code ) { syck_emit_scalar(e, OBJOF("tag:!perl:code:"), SCALAR_QUOTED, 0, 0, 0, "{ \"DUMMY\" }", 11); } else { dSP; I32 len; int count, reallen; SV *text; CV *cv = (CV*)sv; SV *bdeparse = GvSV(gv_fetchpv(form("%s::DeparseObject", PACKAGE_NAME), TRUE, SVt_PV)); if (!SvTRUE(bdeparse)) { croak("B::Deparse initialization failed -- cannot dump code object"); } ENTER; SAVETMPS; /* * call the coderef2text method */ PUSHMARK(sp); XPUSHs(bdeparse); /* XXX is this already mortal? */ XPUSHs(sv_2mortal(newRV_inc((SV*)cv))); PUTBACK; count = call_method("coderef2text", G_SCALAR); SPAGAIN; if (count != 1) { croak("Unexpected return value from B::Deparse::coderef2text\n"); } text = POPs; len = SvLEN(text); reallen = strlen(SvPV_nolen(text)); /* * Empty code references or XS functions are deparsed as * "(prototype) ;" or ";". */ if (len == 0 || *(SvPV_nolen(text)+reallen-1) == ';') { croak("The result of B::Deparse::coderef2text was empty - maybe you're trying to serialize an XS function?\n"); } /* * Now store the source code. */ syck_emit_scalar(e, OBJOF("tag:!perl:code:"), SCALAR_UTF8, 0, 0, 0, SvPV_nolen(text), reallen); FREETMPS; LEAVE; /* END Storable */ } #endif #endif *tag = '\0'; break; } case SVt_PVGV: /* glob (not a filehandle, a symbol table entry) */ case SVt_PVFM: { /* format */ /* XXX TODO XXX */ syck_emit_scalar(e, OBJOF("str"), SCALAR_STRING, 0, 0, 0, SvPV_nolen(sv), sv_len(sv)); break; } case SVt_PVIO: { /* filehandle */ syck_emit_scalar(e, OBJOF("str"), SCALAR_STRING, 0, 0, 0, SvPV_nolen(sv), sv_len(sv)); break; } default: { syck_emit_scalar(e, "str", scalar_plain, 0, 0, 0, NULL_LITERAL, NULL_LITERAL_LENGTH); } } } /* cleanup: */ *tag = '\0'; } void #ifdef YAML_IS_JSON DumpJSONImpl #else DumpYAMLImpl #endif (SV *sv, struct emitter_xtra *bonus, SyckOutputHandler output_handler) { SyckEmitter *emitter = syck_new_emitter(); SV *headless = GvSV(gv_fetchpv(form("%s::Headless", PACKAGE_NAME), TRUE, SVt_PV)); SV *implicit_binary = GvSV(gv_fetchpv(form("%s::ImplicitBinary", PACKAGE_NAME), TRUE, SVt_PV)); SV *use_code = GvSV(gv_fetchpv(form("%s::UseCode", PACKAGE_NAME), TRUE, SVt_PV)); SV *dump_code = GvSV(gv_fetchpv(form("%s::DumpCode", PACKAGE_NAME), TRUE, SVt_PV)); SV *sortkeys = GvSV(gv_fetchpv(form("%s::SortKeys", PACKAGE_NAME), TRUE, SVt_PV)); #ifdef YAML_IS_JSON SV *singlequote = GvSV(gv_fetchpv(form("%s::SingleQuote", PACKAGE_NAME), TRUE, SVt_PV)); SV *max_depth = GvSV(gv_fetchpv(form("%s::MaxDepth", PACKAGE_NAME), TRUE, SVt_PV)); json_quote_char = (SvTRUE(singlequote) ? '\'' : '"' ); json_quote_style = (SvTRUE(singlequote) ? scalar_2quote_1 : scalar_2quote ); emitter->indent = PERL_SYCK_INDENT_LEVEL; emitter->max_depth = SvIOK(max_depth) ? SvIV(max_depth) : json_max_depth; #else SV *singlequote = GvSV(gv_fetchpv(form("%s::SingleQuote", PACKAGE_NAME), TRUE, SVt_PV)); yaml_quote_style = (SvTRUE(singlequote) ? scalar_1quote : scalar_none); #endif ENTER; SAVETMPS; #ifndef YAML_IS_JSON if (SvTRUE(use_code) || SvTRUE(dump_code)) { SV *bdeparse = GvSV(gv_fetchpv(form("%s::DeparseObject", PACKAGE_NAME), TRUE, SVt_PV)); if (!SvTRUE(bdeparse)) { eval_pv(form( "local $@; require B::Deparse; $%s::DeparseObject = B::Deparse->new", PACKAGE_NAME ), 1); } } #endif emitter->headless = SvTRUE(headless); emitter->sort_keys = SvTRUE(sortkeys); emitter->anchor_format = "%d"; New(801, bonus->tag, 512, char); *(bonus->tag) = '\0'; bonus->dump_code = SvTRUE(use_code) || SvTRUE(dump_code); bonus->implicit_binary = SvTRUE(implicit_binary); emitter->bonus = bonus; syck_emitter_handler( emitter, PERL_SYCK_EMITTER_HANDLER ); syck_output_handler( emitter, output_handler ); PERL_SYCK_MARK_EMITTER( emitter, sv ); #ifdef YAML_IS_JSON st_free_table(emitter->markers); emitter->markers = st_init_numtable(); #endif syck_emit( emitter, (st_data_t)sv ); syck_emitter_flush( emitter, 0 ); syck_free_emitter( emitter ); Safefree(bonus->tag); FREETMPS; LEAVE; return; } SV* #ifdef YAML_IS_JSON DumpJSON #else DumpYAML #endif (SV *sv) { SV *implicit_unicode = GvSV(gv_fetchpv(form("%s::ImplicitUnicode", PACKAGE_NAME), TRUE, SVt_PV)); struct emitter_xtra bonus; SV *out = newSVpvn("", 0); bonus.out.outsv = out; #ifdef YAML_IS_JSON DumpJSONImpl(sv, &bonus, perl_syck_output_handler_pv); if (SvCUR(out) > 0) { perl_json_postprocess(out); } #else DumpYAMLImpl(sv, &bonus, perl_syck_output_handler_pv); #endif #ifdef SvUTF8_on if (SvTRUE(implicit_unicode)) { SvUTF8_on(out); } #endif return out; } int #ifdef YAML_IS_JSON DumpJSONFile #else DumpYAMLFile #endif (SV *sv, PerlIO *out) { struct emitter_xtra bonus; bonus.out.outio = out; bonus.ioerror = 0; #ifdef YAML_IS_JSON DumpJSONImpl(sv, &bonus, perl_syck_output_handler_io); /* TODO: how do we do perl_json_postprocess? */ #else DumpYAMLImpl(sv, &bonus, perl_syck_output_handler_io); #endif return bonus.ioerror; } int #ifdef YAML_IS_JSON DumpJSONInto #else DumpYAMLInto #endif (SV *sv, SV *out) { SV *implicit_unicode = GvSV(gv_fetchpv(form("%s::ImplicitUnicode", PACKAGE_NAME), TRUE, SVt_PV)); struct emitter_xtra bonus; if (SvROK(out)) { out = SvRV(out); if (! SvPOK(out)) { sv_setpv(out, ""); } } else { return 0; /* perl wrapper should die for us */ } bonus.out.outsv = out; #ifdef YAML_IS_JSON DumpJSONImpl(sv, &bonus, perl_syck_output_handler_mg); if (SvCUR(out) > 0) { /* XXX: needs to handle magic? */ perl_json_postprocess(out); } #else DumpYAMLImpl(sv, &bonus, perl_syck_output_handler_mg); #endif #ifdef SvUTF8_on if (SvTRUE(implicit_unicode)) { SvUTF8_on(out); /* XXX: needs to handle magic? */ } #endif return 1; }
Copyright ©2021 || Defacer Indonesia