annotate Lib/IMPL/Web/QueryHandler/JsonFormat.pm @ 186:6c0fee769b0c

IMPL::Web::View::TTControl tests, fixes
author cin
date Fri, 30 Mar 2012 16:40:34 +0400
parents d1676be8afcc
children 4d0e1962161c
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
119
8114aaa7feba Json format
wizard
parents:
diff changeset
1 use strict;
8114aaa7feba Json format
wizard
parents:
diff changeset
2 package IMPL::Transform::Json;
8114aaa7feba Json format
wizard
parents:
diff changeset
3
118
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
4 package IMPL::Web::QueryHandler::JsonFormat;
166
4267a2ac3d46 Added Class::Template,
wizard
parents: 140
diff changeset
5 use parent qw(IMPL::Web::QueryHandler);
118
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
6 use Error qw(:try);
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
7 use JSON;
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
8
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
9 sub Process {
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
10 my ($this,$action,$nextHandler) = @_;
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
11
119
8114aaa7feba Json format
wizard
parents:
diff changeset
12 my $result;
118
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
13
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
14 try {
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
15 $result = $nextHandler->();
119
8114aaa7feba Json format
wizard
parents:
diff changeset
16 $result = [$result] unless ref $result;
118
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
17 } otherwise {
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
18 my $err = shift;
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
19 $result = { error => $err };
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
20 };
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
21
173
aaab45153411 minor bugfixes
sourcer
parents: 166
diff changeset
22 my $t = new IMPL::Transform::Json($action->context->{json});
aaab45153411 minor bugfixes
sourcer
parents: 166
diff changeset
23
aaab45153411 minor bugfixes
sourcer
parents: 166
diff changeset
24 if ($action->context->{transactionType} and $action->context->{transactionType} eq 'form') {
aaab45153411 minor bugfixes
sourcer
parents: 166
diff changeset
25 delete @$result{qw(formData formSchema)};
aaab45153411 minor bugfixes
sourcer
parents: 166
diff changeset
26 my $errors = @$result{formErrors};
aaab45153411 minor bugfixes
sourcer
parents: 166
diff changeset
27
aaab45153411 minor bugfixes
sourcer
parents: 166
diff changeset
28 $result->{formErrors} = [ map $_->Message, @$errors ] if $errors;
aaab45153411 minor bugfixes
sourcer
parents: 166
diff changeset
29 }
aaab45153411 minor bugfixes
sourcer
parents: 166
diff changeset
30
118
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
31 $action->response->contentType('text/javascript');
119
8114aaa7feba Json format
wizard
parents:
diff changeset
32
118
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
33 my $hout = $action->response->streamBody;
119
8114aaa7feba Json format
wizard
parents:
diff changeset
34 print $hout to_json( $t->Transform($result), {pretty => 1} );
8114aaa7feba Json format
wizard
parents:
diff changeset
35 }
118
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
36
119
8114aaa7feba Json format
wizard
parents:
diff changeset
37 package IMPL::Transform::Json;
118
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
38
166
4267a2ac3d46 Added Class::Template,
wizard
parents: 140
diff changeset
39 use parent qw(IMPL::Transform);
118
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
40 use IMPL::Class::Property;
134
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
41 use IMPL::Class::Property::Direct;
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
42 use Scalar::Util qw(refaddr);
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
43
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
44 BEGIN {
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
45 private _direct property _visited => prop_none;
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
46 }
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
47
119
8114aaa7feba Json format
wizard
parents:
diff changeset
48 my %propListCache;
118
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
49
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
50 our %CTOR = (
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
51 'IMPL::Transform' => sub {
173
aaab45153411 minor bugfixes
sourcer
parents: 166
diff changeset
52 my $options = shift;
aaab45153411 minor bugfixes
sourcer
parents: 166
diff changeset
53 (
aaab45153411 minor bugfixes
sourcer
parents: 166
diff changeset
54 $options ? %{$options} : ()
aaab45153411 minor bugfixes
sourcer
parents: 166
diff changeset
55 ),
119
8114aaa7feba Json format
wizard
parents:
diff changeset
56 ARRAY => sub {
8114aaa7feba Json format
wizard
parents:
diff changeset
57 my ($this,$object) = @_;
8114aaa7feba Json format
wizard
parents:
diff changeset
58
8114aaa7feba Json format
wizard
parents:
diff changeset
59 return [
8114aaa7feba Json format
wizard
parents:
diff changeset
60 map { $this->Transform($_) } @$object
8114aaa7feba Json format
wizard
parents:
diff changeset
61 ];
8114aaa7feba Json format
wizard
parents:
diff changeset
62 },
8114aaa7feba Json format
wizard
parents:
diff changeset
63 HASH => sub {
8114aaa7feba Json format
wizard
parents:
diff changeset
64 my ($this,$object) = @_;
8114aaa7feba Json format
wizard
parents:
diff changeset
65
8114aaa7feba Json format
wizard
parents:
diff changeset
66 return {
8114aaa7feba Json format
wizard
parents:
diff changeset
67 map { $_, $this->Transform($object->{$_}) } keys %$object
8114aaa7feba Json format
wizard
parents:
diff changeset
68 };
8114aaa7feba Json format
wizard
parents:
diff changeset
69 },
8114aaa7feba Json format
wizard
parents:
diff changeset
70 'IMPL::Object::List' => sub {
8114aaa7feba Json format
wizard
parents:
diff changeset
71 my ($this,$object) = @_;
8114aaa7feba Json format
wizard
parents:
diff changeset
72
8114aaa7feba Json format
wizard
parents:
diff changeset
73 return [
8114aaa7feba Json format
wizard
parents:
diff changeset
74 map { $this->Transform($_) } @$object
8114aaa7feba Json format
wizard
parents:
diff changeset
75 ];
8114aaa7feba Json format
wizard
parents:
diff changeset
76 },
8114aaa7feba Json format
wizard
parents:
diff changeset
77 -plain => sub {
8114aaa7feba Json format
wizard
parents:
diff changeset
78 $_[1];
8114aaa7feba Json format
wizard
parents:
diff changeset
79 },
8114aaa7feba Json format
wizard
parents:
diff changeset
80 -default => sub {
8114aaa7feba Json format
wizard
parents:
diff changeset
81 my ($this,$object) = @_;
8114aaa7feba Json format
wizard
parents:
diff changeset
82
8114aaa7feba Json format
wizard
parents:
diff changeset
83 return "$object" unless $object->isa('IMPL::Object::Abstract');
8114aaa7feba Json format
wizard
parents:
diff changeset
84
128
08753833173d Fixed a error handling issue in JSON output: errors are correctly transfered
wizard
parents: 120
diff changeset
85 if ( $object->isa(typeof IMPL::Exception) ) {
08753833173d Fixed a error handling issue in JSON output: errors are correctly transfered
wizard
parents: 120
diff changeset
86 return {
08753833173d Fixed a error handling issue in JSON output: errors are correctly transfered
wizard
parents: 120
diff changeset
87 type => $object->typeof,
08753833173d Fixed a error handling issue in JSON output: errors are correctly transfered
wizard
parents: 120
diff changeset
88 message => $object->Message,
08753833173d Fixed a error handling issue in JSON output: errors are correctly transfered
wizard
parents: 120
diff changeset
89 arguments => $this->Transform(scalar $object->Args)
08753833173d Fixed a error handling issue in JSON output: errors are correctly transfered
wizard
parents: 120
diff changeset
90 };
08753833173d Fixed a error handling issue in JSON output: errors are correctly transfered
wizard
parents: 120
diff changeset
91 }
08753833173d Fixed a error handling issue in JSON output: errors are correctly transfered
wizard
parents: 120
diff changeset
92
119
8114aaa7feba Json format
wizard
parents:
diff changeset
93 my $propList = $propListCache{ref $object};
8114aaa7feba Json format
wizard
parents:
diff changeset
94 unless ( $propList ) {
8114aaa7feba Json format
wizard
parents:
diff changeset
95 my %props = map {
8114aaa7feba Json format
wizard
parents:
diff changeset
96 $_->Name, (ref $_->Mutators ? 0 : ($_->Mutators & prop_list))
8114aaa7feba Json format
wizard
parents:
diff changeset
97 } $object->get_meta('IMPL::Class::PropertyInfo',sub { $_->Access == IMPL::Class::Member::MOD_PUBLIC and $_->Name !~ /^_/}, 1 );
118
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
98
119
8114aaa7feba Json format
wizard
parents:
diff changeset
99 $propListCache{ref $object} = $propList = \%props;
118
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
100 }
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
101
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
102 return {
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
103 map {
119
8114aaa7feba Json format
wizard
parents:
diff changeset
104 $_, $propList->{$_} ? $this->Transform([$object->$_()]) : $this->Transform(scalar $object->$_());
8114aaa7feba Json format
wizard
parents:
diff changeset
105 } keys %$propList
118
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
106 };
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
107 }
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
108 }
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
109 );
79cdd6c86409 JSON support (experimental)
wizard
parents:
diff changeset
110
134
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
111 sub Transform {
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
112 my ($this,$object) = @_;
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
113
140
fb896377389f to_json and escape_string functions for the templates
wizard
parents: 134
diff changeset
114 # small hack to prevent cycling
fb896377389f to_json and escape_string functions for the templates
wizard
parents: 134
diff changeset
115
134
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
116 return $this->SUPER::Transform($object) unless ref $object;
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
117
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
118 if (exists $this->{$_visited}{refaddr $object}) {
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
119 return $this->{$_visited}{refaddr $object};
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
120 } else {
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
121 $this->{$_visited}{refaddr $object} = undef;
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
122 return $this->{$_visited}{refaddr $object} = $this->SUPER::Transform($object);
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
123 }
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
124 }
44977efed303 Significant performance optimizations
wizard
parents: 128
diff changeset
125
180
d1676be8afcc Перекодировка в utf-8
sourcer
parents: 173
diff changeset
126 1;