root/JSON-Syck/trunk/perl_syck.h

Revision 1749 (checked in by miyagawa, 14 years ago)

0.03: ImplicitUnicode? option and tests

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