YAML::Syck とアンカー・エイリアス 解決編
【YAML::Syck とアンカー・エイリアス - daily dayflower】の続きです。ついにできたどー。
昨日，解決策を2つあげました。後者（RV ではなく AV / HV を syck_add_sym() する）のほうが本筋だと思うのですが，修正箇所が多くなるので前者（AV や HV に newSVsv で duplicate した RV (SV) を登録する*1）のアプローチにしました。
ただ，昨日も書いたように親参照等，前方参照するエイリアスに対する解決がうまくいかなくなるので，前方参照が発生した場合，その RV をキャッシュに登録しておいて，アンカー登録の際に，そのキャッシュの RV の参照先を変更するという力業仕様になってます。
ちょっと大がかりな変更になってしまったので，私から RT にはまだ投げません。一応付属品全テストが通る*2ことは確認したのですが，暇ができたらもうちょっと厳しいテストを書いたり，内製プロジェクトで支障がでないか試したりしたいと思ってます。
もちろんテストしてくださる方大歓迎。スーパーハカーが commit するのも歓迎です。
以下，パッチ＆テストファイルが続きます。すべて YAML::Syck 同様 MIT ライセンスに準じます。
2007/02/02 にパッチとテストを更新しました。
perl_common.h へのパッチ
bad alias 管理用ツール関数群を perl_sych.h に移したので，短くなってます。HV と，BadAlias クラス名のバグフィックスのみ。
--- perl_common.h.orig 2007-01-26 07:52:19.000000000 +0900 +++ perl_common.h 2007-02-02 13:25:08.909512131 +0900 @@ -39,6 +39,7 @@ AV *objects; bool implicit_unicode; bool load_code; + HV *forward_bad_anchors; }; SV* perl_syck_lookup_sym( SyckParser *p, SYMID v) { @@ -62,7 +63,7 @@ (SYMID)newSVpvn_share("name", 4, 0), (SYMID)newSVpvn_share(a, strlen(a), 0) ); - badanc->type_id = syck_strndup( "!perl:YAML::Syck::BadAlias", 25 ); + badanc->type_id = syck_strndup( "!perl:YAML::Syck::BadAlias", 26 ); return badanc; }
perl_syck.h へのパッチ
id:charsbar さんのご指摘により SvRV_set が定義されてない環境で定義したり，細々とした整理したりしました。
--- perl_syck.h.orig 2007-01-26 08:15:04.000000000 +0900 +++ perl_syck.h 2007-02-02 16:24:05.408316219 +0900 @@ -63,6 +63,80 @@ #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_anchor_dummy_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_rv( SyckParser *p, const char *anchor, SV *sv ) { + HV *map; + SV **pref_av, *new_rvav; + AV *rvs; + + map = ((struct parser_xtra *)p->bonus)->forward_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_rvs( 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)->forward_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 @@ -270,6 +344,14 @@ 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_anchor_dummy_object(a); + if (forward_anchor) + register_bad_alias_rv(p, forward_anchor, a); +#endif av_push(seq, a); USE_OBJECT(a); } @@ -312,7 +394,14 @@ 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_anchor_dummy_object(val); + if (forward_anchor) + register_bad_alias_rv(p, forward_anchor, val); +#endif sv = newRV_noinc(val); USE_OBJECT(val); @@ -341,6 +430,15 @@ } } } + 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 { @@ -349,7 +447,14 @@ 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_anchor_dummy_object(val); + if (forward_anchor) + register_bad_alias_rv(p, forward_anchor, val); +#endif if (hv_store_ent(map, key, val, 0) != NULL) USE_OBJECT(val); } @@ -387,6 +492,9 @@ #ifndef YAML_IS_JSON /* Fix bad anchors using sv_setsv */ if (n->id) { + if (n->anchor) + resolve_bad_alias_rvs(p, n->anchor, sv); + sv_setsv( perl_syck_lookup_sym(p, n->id), sv ); } #endif @@ -521,6 +629,9 @@ bonus.objects = (AV*)sv_2mortal((SV*)newAV()); bonus.implicit_unicode = SvTRUE(implicit_unicode); bonus.load_code = SvTRUE(use_code) || SvTRUE(load_code); +#ifndef YAML_IS_JSON + bonus.forward_bad_anchors = (HV*)sv_2mortal((SV*)newHV()); +#endif parser->bonus = &bonus; #ifndef YAML_IS_JSON
アンカー／エイリアスのテスト yaml-alias.t
必要ないテスト等を削ってシンプルにしました。また結構追加してます。
#!/usr/bin/perl use t::TestYAML tests => 14; my ($a, $b, $c); *skip = *Test::skip; $a = [ {} ]; $a->[1] = $a->[0]; $b = Load(Dump($a)); is(Dump($b), Dump($a), "array with anchor"); $a->[1] = 'xyz'; $b->[1] = 'xyz'; is(Dump($b), Dump($a), "touched array with anchor"); $a = { abc => {} }; $a->{'def'} = $a->{'abc'}; $b = Load(Dump($a)); is(Dump($b), Dump($a), "hash with anchor"); $a->{'def'} = 'xyz'; $b->{'def'} = 'xyz'; is(Dump($b), Dump($a), "touched hash with anchor"); $a = [ {} ]; push @$a, $a->[0] for (1..10); $b = Load(Dump($a)); is(Dump($b), Dump($a), "huge array with anchor"); $a->[0] = 'xyz'; $b->[0] = 'xyz'; is(Dump($b), Dump($a), "touched huge array with anchor"); $a = { abc => {}, def => {} }; $a->{abc}->{sibling} = $a->{def}; $a->{def}->{sibling} = $a->{abc}; $b = Load(Dump($a)); is(Dump($b), Dump($a), "circular"); $a->{def}->{sibling} = {}; $b->{def}->{sibling} = {}; is(Dump($b), Dump($a), "touched circular"); $a = [ {}, {} ]; push @$a, $a->[0], $a->[1] for (1..10); $b = Load(Dump($a)); is(Dump($b), Dump($a), "many anchors"); $a->[0] = 'abc'; $a->[3] = 'def'; $b->[0] = 'abc'; $b->[3] = 'def'; is(Dump($b), Dump($a), "touched many anchors"); my $s = 'scal'; $a = [ \$s, \$s, \$s ]; $b = Load(Dump($a)); is(Dump($b), Dump($a), "scalar reference"); $a->[1] = 'hello'; $b->[1] = 'hello'; is(Dump($b), Dump($a), "touched scalar reference"); my $os = bless \$s, 'obj_scal'; my $oa = bless [ 'array' ], 'obj_array'; my $oh = bless { key => 'value' }, 'obj_hash'; $a = [ $os, $oa, $oh, $os, $oa, $oh ]; $b = Load(Dump($a)); skip("Skip this because anchor #1 is going to be truncated. no problem", Dump($b), Dump($a), "object"); $a->[3] = 'mod'; $a->[4] = {}; $a->[5] = $a->[4]; $b->[3] = 'mod'; $b->[4] = {}; $b->[5] = $b->[4]; is(Dump($b), Dump($a), "touched object");
