root/JSON-Syck/trunk/perl_syck.h

Revision 1741 (checked in by miyagawa, 15 years ago)

merge audrey's changes and added Unicode test: still failing

Line 
1 #include "EXTERN.h"
2 #include "perl.h"
3 #include "XSUB.h"
4
5 #define NEED_grok_oct
6 #define NEED_grok_hex
7 #define NEED_grok_number
8 #define NEED_grok_numeric_radix
9 #define NEED_newRV_noinc
10 #include "ppport.h"
11 #include "ppport_math.h"
12
13 #undef DEBUG /* maybe defined in perl.h */
14 #include <syck.h>
15
16 #ifdef YAML_IS_JSON
17 #  define PACKAGE_NAME  "JSON::Syck"
18 #  define NULL_LITERAL  "null"
19 #  define SCALAR_NUMBER scalar_none
20 #  define SCALAR_STRING scalar_2quote
21 #  define SCALAR_QUOTED scalar_2quote
22 #  define SCALAR_UTF8   scalar_fold
23 #  define SEQ_NONE      seq_inline
24 #  define MAP_NONE      map_inline
25 #  define TYPE_IS_NULL(x) ((x == NULL) || (strcmp( x, "str" ) == 0))
26 #  define OBJOF(a)        (a)
27 #else
28 #  define PACKAGE_NAME  "YAML::Syck"
29 #  define NULL_LITERAL  "~"
30 #  define SCALAR_NUMBER scalar_none
31 #  define SCALAR_STRING scalar_none
32 #  define SCALAR_QUOTED scalar_1quote
33 #  define SCALAR_UTF8   scalar_fold
34 #  define SEQ_NONE      seq_none
35 #  define MAP_NONE      map_none
36 #  define TYPE_IS_NULL(x) (x == NULL)
37 #  define OBJOF(a)        (*tag ? tag : a)
38 #endif
39
40 /*
41 #undef ASSERT
42 #include "Storable.xs"
43 */
44
45 struct emitter_xtra {
46     SV* port;
47     char* tag;
48 };
49
50 SV* perl_syck_lookup_sym( SyckParser *p, SYMID v) {
51     SV *obj = &PL_sv_undef;
52     syck_lookup_sym(p, v, (char **)&obj);
53     return obj;
54 }
55
56 #define CHECK_UTF8 \
57     if (p->bonus && is_utf8_string((U8*)n->data.str->ptr, n->data.str->len)) \
58         SvUTF8_on(sv);
59
60 SYMID perl_syck_parser_handler(SyckParser *p, SyckNode *n) {
61     SV *sv;
62     AV *seq;
63     HV *map;
64     long i;
65     switch (n->kind) {
66         case syck_str_kind:
67             if (TYPE_IS_NULL(n->type_id)) {
68                 if ((strcmp( n->data.str->ptr, NULL_LITERAL ) == 0)
69                     && (n->data.str->style == scalar_plain)) {
70                     sv = &PL_sv_undef;
71                 } else {
72                     sv = newSVpvn(n->data.str->ptr, n->data.str->len);
73                     CHECK_UTF8;
74                 }
75             } else if (strcmp( n->type_id, "str" ) == 0 ) {
76                 sv = newSVpvn(n->data.str->ptr, n->data.str->len);
77                 CHECK_UTF8;
78             } else if (strcmp( n->type_id, "null" ) == 0 ) {
79                 sv = &PL_sv_undef;
80             } else if (strcmp( n->type_id, "bool#yes" ) == 0 ) {
81                 sv = &PL_sv_yes;
82             } else if (strcmp( n->type_id, "bool#no" ) == 0 ) {
83                 sv = &PL_sv_no;
84             } else if (strcmp( n->type_id, "default" ) == 0 ) {
85                 sv = newSVpvn(n->data.str->ptr, n->data.str->len);
86                 CHECK_UTF8;
87             } else if (strcmp( n->type_id, "float#base60" ) == 0 ) {
88                 char *ptr, *end;
89                 UV sixty = 1;
90                 NV total = 0.0;
91                 syck_str_blow_away_commas( n );
92                 ptr = n->data.str->ptr;
93                 end = n->data.str->ptr + n->data.str->len;
94                 while ( end > ptr )
95                 {
96                     NV bnum = 0;
97                     char *colon = end - 1;
98                     while ( colon >= ptr && *colon != ':' )
99                     {
100                         colon--;
101                     }
102                     if ( *colon == ':' ) *colon = '\0';
103
104                     bnum = strtod( colon + 1, NULL );
105                     total += bnum * sixty;
106                     sixty *= 60;
107                     end = colon;
108                 }
109                 sv = newSVnv(total);
110 #ifdef NV_NAN
111             } else if (strcmp( n->type_id, "float#nan" ) == 0 ) {
112                 sv = newSVnv(NV_NAN);
113 #endif
114 #ifdef NV_INF
115             } else if (strcmp( n->type_id, "float#inf" ) == 0 ) {
116                 sv = newSVnv(NV_INF);
117             } else if (strcmp( n->type_id, "float#neginf" ) == 0 ) {
118                 sv = newSVnv(-NV_INF);
119 #endif
120             } else if (strncmp( n->type_id, "float", 5 ) == 0) {
121                 NV f;
122                 syck_str_blow_away_commas( n );
123                 f = strtod( n->data.str->ptr, NULL );
124                 sv = newSVnv( f );
125             } else if (strcmp( n->type_id, "int#base60" ) == 0 ) {
126                 char *ptr, *end;
127                 UV sixty = 1;
128                 UV total = 0;
129                 syck_str_blow_away_commas( n );
130                 ptr = n->data.str->ptr;
131                 end = n->data.str->ptr + n->data.str->len;
132                 while ( end > ptr )
133                 {
134                     long bnum = 0;
135                     char *colon = end - 1;
136                     while ( colon >= ptr && *colon != ':' )
137                     {
138                         colon--;
139                     }
140                     if ( *colon == ':' ) *colon = '\0';
141
142                     bnum = strtol( colon + 1, NULL, 10 );
143                     total += bnum * sixty;
144                     sixty *= 60;
145                     end = colon;
146                 }
147                 sv = newSVuv(total);
148             } else if (strcmp( n->type_id, "int#hex" ) == 0 ) {
149                 STRLEN len = n->data.str->len;
150                 syck_str_blow_away_commas( n );
151                 sv = newSVuv( grok_hex( n->data.str->ptr, &len, 0, NULL) );
152             } else if (strcmp( n->type_id, "int#oct" ) == 0 ) {
153                 STRLEN len = n->data.str->len;
154                 syck_str_blow_away_commas( n );
155                 sv = newSVuv( grok_oct( n->data.str->ptr, &len, 0, NULL) );
156             } else if (strncmp( n->type_id, "int", 3 ) == 0) {
157                 UV uv = 0;
158                 syck_str_blow_away_commas( n );
159                 grok_number( n->data.str->ptr, n->data.str->len, &uv);
160                 sv = newSVuv(uv);
161             } else {
162                 /* croak("unknown node type: %s", n->type_id); */
163                 sv = newSVpvn(n->data.str->ptr, n->data.str->len);
164                 CHECK_UTF8;
165             }
166         break;
167
168         case syck_seq_kind:
169             seq = newAV();
170             for (i = 0; i < n->data.list->idx; i++) {
171                 av_push(seq, perl_syck_lookup_sym(p, syck_seq_read(n, i) ));
172             }
173             sv = newRV_noinc((SV*)seq);
174 #ifndef YAML_IS_JSON
175             if (n->type_id) {
176                 sv_bless(sv, gv_stashpv(n->type_id + 6, TRUE));
177             }
178 #endif
179         break;
180
181         case syck_map_kind:
182 #ifndef YAML_IS_JSON
183             if ( (n->type_id != NULL) && (strcmp( n->type_id, "perl/ref:" ) == 0) ) {
184                 sv = newRV_noinc( perl_syck_lookup_sym(p, syck_map_read(n, map_value, 0) ) );
185             }
186             else
187 #endif
188             {
189                 map = newHV();
190                 for (i = 0; i < n->data.pairs->idx; i++) {
191                     hv_store_ent(
192                         map,
193                         perl_syck_lookup_sym(p, syck_map_read(n, map_key, i) ),
194                         perl_syck_lookup_sym(p, syck_map_read(n, map_value, i) ),
195                         0
196                     );
197                 }
198                 sv = newRV_noinc((SV*)map);
199 #ifndef YAML_IS_JSON
200                 if (n->type_id) {
201                     sv_bless(sv, gv_stashpv(n->type_id + 5, TRUE));
202                 }
203 #endif
204             }
205         break;
206     }
207     return syck_add_sym(p, (char *)sv);
208 }
209
210 void perl_syck_mark_emitter(SyckEmitter *e, SV *sv) {
211     if (syck_emitter_mark_node(e, (st_data_t)sv) == 0) {
212         return;
213     }
214
215     if (SvROK(sv)) {
216         perl_syck_mark_emitter(e, SvRV(sv));
217         return;
218     }
219
220     switch (SvTYPE(sv)) {
221         case SVt_PVAV: {
222             I32 len, i;
223             len = av_len((AV*)sv) + 1;
224             for (i = 0; i < len; i++) {
225                 SV** sav = av_fetch((AV*)sv, i, 0);
226                 perl_syck_mark_emitter( e, *sav );
227             }
228             break;
229         }
230         case SVt_PVHV: {
231             I32 len, i;
232 #ifdef HAS_RESTRICTED_HASHES
233             len = HvTOTALKEYS((HV*)sv);
234 #else
235             len = HvKEYS((HV*)sv);
236 #endif
237             hv_iterinit((HV*)sv);
238             for (i = 0; i < len; i++) {
239 #ifdef HV_ITERNEXT_WANTPLACEHOLDERS
240                 HE *he = hv_iternext_flags((HV*)sv, HV_ITERNEXT_WANTPLACEHOLDERS);
241 #else
242                 HE *he = hv_iternext((HV*)sv);
243 #endif
244                 I32 keylen;
245                 SV *val = hv_iterval((HV*)sv, he);
246                 perl_syck_mark_emitter( e, val );
247             }
248             break;
249         }
250     }
251 }
252
253 SyckNode * perl_syck_bad_anchor_handler(SyckParser *p, char *a) {
254     croak(form( "%s parser (line %d, column %d): Unsupported self-recursive anchor *%s",
255         PACKAGE_NAME,
256         p->linect + 1,
257         p->cursor - p->lineptr,
258         a ));
259     /*
260     SyckNode *badanc = syck_new_map(
261         (SYMID)newSVpvn_share("name", 4, 0),
262         (SYMID)newSVpvn_share(a, strlen(a), 0)
263     );
264     badanc->type_id = syck_strndup( "perl:YAML::Syck::BadAlias", 25 );
265     return badanc;
266     */
267 }
268
269 void perl_syck_error_handler(SyckParser *p, char *msg) {
270     croak(form( "%s parser (line %d, column %d): %s",
271         PACKAGE_NAME,
272         p->linect + 1,
273         p->cursor - p->lineptr,
274         msg ));
275 }
276
277 static char* perl_json_preprocess(char *s) {
278     int i;
279     char *out;
280     char ch;
281     bool in_string = 0;
282     bool in_quote  = 0;
283     char *pos;
284     STRLEN len = strlen(s);
285
286     New(2006, out, len*2+1, char);
287     pos = out;
288
289     for (i = 0; i < len; i++) {
290         ch = *(s+i);
291         *pos++ = ch;
292         if (in_quote) {
293             in_quote = !in_quote;
294         }
295         else if (ch == '\"') {
296             in_string = !in_string;
297         }
298         else if ((ch == ':' || ch == ',') && !in_string) {
299             *pos++ = ' ';
300         }
301     }
302
303     *pos = '\0';
304     return out;
305 }
306
307 void perl_json_postprocess(SV *sv) {
308     int i;
309     char ch;
310     bool in_string = 0;
311     bool in_quote  = 0;
312     char *pos;
313     char *s = SvPVX(sv);
314     STRLEN len = sv_len(sv);
315     STRLEN final_len = len;
316
317     pos = s;
318
319     for (i = 0; i < len; i++) {
320         ch = *(s+i);
321         *pos++ = ch;
322         if (in_quote) {
323             in_quote = !in_quote;
324         }
325         else if (ch == '\"') {
326             in_string = !in_string;
327         }
328         else if ((ch == ':' || ch == ',') && !in_string) {
329             i++; /* has to be a space afterwards */
330             final_len--;
331         }
332     }
333
334     /* Remove the trailing newline */
335     if (final_len > 0) {
336         final_len--; pos--;
337     }
338     *pos = '\0';
339     SvCUR_set(sv, final_len);
340 }
341
342 static SV * Load(char *s) {
343     SYMID v;
344     SyckParser *parser;
345     SV *obj = &PL_sv_undef;
346     SV *implicit = GvSV(gv_fetchpv(form("%s::ImplicitTyping", PACKAGE_NAME), TRUE, SVt_PV));
347     SV *unicode = GvSV(gv_fetchpv(form("%s::ImplicitUnicode", PACKAGE_NAME), TRUE, SVt_PV));
348
349     /* Don't even bother if the string is empty. */
350     if (*s == '\0') { return &PL_sv_undef; }
351
352 #ifdef YAML_IS_JSON
353     s = perl_json_preprocess(s);
354 #endif
355
356     parser = syck_new_parser();
357     syck_parser_str_auto(parser, s, NULL);
358     syck_parser_handler(parser, perl_syck_parser_handler);
359     syck_parser_error_handler(parser, perl_syck_error_handler);
360     syck_parser_bad_anchor_handler( parser, perl_syck_bad_anchor_handler );
361     syck_parser_implicit_typing(parser, SvTRUE(implicit));
362     syck_parser_taguri_expansion(parser, 0);
363
364     parser->bonus = (void*)SvTRUE(unicode);
365
366     v = syck_parse(parser);
367     syck_lookup_sym(parser, v, (char **)&obj);
368     syck_free_parser(parser);
369
370 #ifdef YAML_IS_JSON
371     Safefree(s);
372 #endif
373
374     return obj;
375 }
376
377 void perl_syck_output_handler(SyckEmitter *e, char *str, long len) {
378     struct emitter_xtra *bonus = (struct emitter_xtra *)e->bonus;
379     sv_catpvn_nomg(bonus->port, str, len);
380     e->headless = 1;
381 }
382
383 void perl_syck_emitter_handler(SyckEmitter *e, st_data_t data) {
384     I32  len, i;
385     SV*  sv = (SV*)data;
386     struct emitter_xtra *bonus = (struct emitter_xtra *)e->bonus;
387     char* tag = bonus->tag;
388     char* ref = NULL;
389
390     if (sv == &PL_sv_undef) {
391         return syck_emit_scalar(e, "string", scalar_none, 0, 0, 0, NULL_LITERAL, 1);
392     }
393    
394 #define OBJECT_TAG     "tag:perl:"
395    
396     if (SvMAGICAL(sv)) {
397         mg_get(sv);
398     }
399
400 #ifndef YAML_IS_JSON
401     if (sv_isobject(sv)) {
402         ref = savepv(sv_reftype(SvRV(sv), TRUE));
403         *tag = '\0';
404         strcat(tag, OBJECT_TAG);
405         switch (SvTYPE(SvRV(sv))) {
406             case SVt_PVAV: { strcat(tag, "@"); break; }
407             case SVt_RV:   { strcat(tag, "$"); break; }
408             case SVt_PVCV: { strcat(tag, "code"); break; }
409             case SVt_PVGV: { strcat(tag, "glob"); break; }
410         }
411         strcat(tag, ref);
412     }
413 #endif
414
415     if (SvROK(sv)) {
416         switch (SvTYPE(SvRV(sv))) {
417             case SVt_PVAV:
418             case SVt_PVHV:
419             case SVt_PVCV: {
420                 perl_syck_emitter_handler(e, (st_data_t)SvRV(sv));
421                 break;
422             }
423             default: {
424                 syck_emit_map(e, "tag:perl:ref:", MAP_NONE);
425                 syck_emit_item( e, (st_data_t)newSVpvn_share("=", 1, 0) );
426                 syck_emit_item( e, (st_data_t)SvRV(sv) );
427                 syck_emit_end(e);
428             }
429         }
430         *tag = '\0';
431         return;
432     }
433
434     switch (SvTYPE(sv)) {
435         case SVt_NULL: { return; }
436         case SVt_PVIV:
437         case SVt_PVNV: {
438             if (sv_len(sv) > 0) {
439                 syck_emit_scalar(e, OBJOF("string"), SvNIOK(sv) ? SCALAR_NUMBER : SCALAR_STRING, 0, 0, 0, SvPV_nolen(sv), sv_len(sv));
440             }
441             else {
442                 syck_emit_scalar(e, OBJOF("string"), SCALAR_QUOTED, 0, 0, 0, "", 0);
443             }
444             break;
445         }
446         case SVt_IV:
447         case SVt_NV: {
448             if (sv_len(sv) > 0) {
449                 syck_emit_scalar(e, OBJOF("string"), SCALAR_NUMBER, 0, 0, 0, SvPV_nolen(sv), sv_len(sv));
450             }
451             else {
452                 syck_emit_scalar(e, OBJOF("string"), SCALAR_QUOTED, 0, 0, 0, "", 0);
453             }
454             break;
455         }
456         case SVt_PV:
457         case SVt_PVMG:
458         case SVt_PVBM:
459         case SVt_PVLV: {
460             if (sv_len(sv) > 0) {
461                 if (SvUTF8(sv)) {
462                     enum scalar_style old_s = e->style;
463                     e->style = SCALAR_UTF8;
464                     syck_emit_scalar(e, OBJOF("string"), SCALAR_STRING, 0, 0, 0, SvPV_nolen(sv), sv_len(sv));
465                     e->style = old_s;
466                 }
467                 else {
468                     syck_emit_scalar(e, OBJOF("string"), SCALAR_STRING, 0, 0, 0, SvPV_nolen(sv), sv_len(sv));
469                 }
470             }
471             else {
472                 syck_emit_scalar(e, OBJOF("string"), SCALAR_QUOTED, 0, 0, 0, "", 0);
473             }
474             break;
475         }
476         case SVt_RV: {
477             perl_syck_emitter_handler(e, (st_data_t)SvRV(sv));
478             break;
479         }
480         case SVt_PVAV: {
481             syck_emit_seq(e, OBJOF("array"), SEQ_NONE);
482             *tag = '\0';
483             len = av_len((AV*)sv) + 1;
484             for (i = 0; i < len; i++) {
485                 SV** sav = av_fetch((AV*)sv, i, 0);
486                 syck_emit_item( e, (st_data_t)(*sav) );
487             }
488             syck_emit_end(e);
489             return;
490         }
491         case SVt_PVHV: {
492             syck_emit_map(e, OBJOF("hash"), MAP_NONE);
493             *tag = '\0';
494 #ifdef HAS_RESTRICTED_HASHES
495             len = HvTOTALKEYS((HV*)sv);
496 #else
497             len = HvKEYS((HV*)sv);
498 #endif
499             hv_iterinit((HV*)sv);
500             for (i = 0; i < len; i++) {
501 #ifdef HV_ITERNEXT_WANTPLACEHOLDERS
502                 HE *he = hv_iternext_flags((HV*)sv, HV_ITERNEXT_WANTPLACEHOLDERS);
503 #else
504                 HE *he = hv_iternext((HV*)sv);
505 #endif
506                 I32 keylen;
507                 SV *key = hv_iterkeysv(he);
508                 SV *val = hv_iterval((HV*)sv, he);
509                 syck_emit_item( e, (st_data_t)key );
510                 syck_emit_item( e, (st_data_t)val );
511             }
512             syck_emit_end(e);
513             return;
514         }
515         case SVt_PVCV: {
516             /* XXX TODO XXX */
517             syck_emit_scalar(e, OBJOF("string"), SCALAR_STRING, 0, 0, 0, SvPV_nolen(sv), sv_len(sv));
518             break;
519         }
520         case SVt_PVGV:
521         case SVt_PVFM: {
522             /* XXX TODO XXX */
523             syck_emit_scalar(e, OBJOF("string"), SCALAR_STRING, 0, 0, 0, SvPV_nolen(sv), sv_len(sv));
524             break;
525         }
526         case SVt_PVIO: {
527             syck_emit_scalar(e, OBJOF("string"), SCALAR_STRING, 0, 0, 0, SvPV_nolen(sv), sv_len(sv));
528             break;
529         }
530     }
531 cleanup:
532     *tag = '\0';
533 }
534
535 SV* Dump(SV *sv) {
536     struct emitter_xtra *bonus;
537     SV* out = newSVpvn("", 0);
538     SyckEmitter *emitter = syck_new_emitter();
539     SV *headless = GvSV(gv_fetchpv(form("%s::Headless", PACKAGE_NAME), TRUE, SVt_PV));
540     SV *unicode = GvSV(gv_fetchpv(form("%s::ImplicitUnicode", PACKAGE_NAME), TRUE, SVt_PV));
541
542     emitter->headless = SvTRUE(headless);
543     emitter->anchor_format = "%d";
544
545     bonus = emitter->bonus = S_ALLOC_N(struct emitter_xtra, 1);
546     bonus->port = out;
547     New(801, bonus->tag, 512, char);
548
549     syck_emitter_handler( emitter, perl_syck_emitter_handler );
550     syck_output_handler( emitter, perl_syck_output_handler );
551
552 #ifndef YAML_IS_JSON
553     perl_syck_mark_emitter( emitter, sv );
554 #endif
555
556     syck_emit( emitter, (st_data_t)sv );
557     syck_emitter_flush( emitter, 0 );
558     syck_free_emitter( emitter );
559
560     Safefree(bonus->tag);
561
562 #ifdef YAML_IS_JSON
563     if (SvCUR(out) > 0) {
564         perl_json_postprocess(out);
565     }
566 #endif
567
568     if (SvTRUE(unicode)) {
569         SvUTF8_on(out);
570     }
571     return out;
572 }
Note: See TracBrowser for help on using the browser.