root/JSON-Syck/trunk/perl_syck.h

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

merged YAML::Syck 0.24

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