annotate Lib/IMPL/Web/QueryHandler/JsonFormat.pm @ 210:6adaeb86945d

added IMPL::Web::AutoLocator
author sergey
date Tue, 29 May 2012 20:07:22 +0400
parents 4d0e1962161c
children
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 {
194
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
10 my ($this,$action,$nextHandler) = @_;
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
11
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
12 my $result;
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
13
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
14 try {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
15 $result = $nextHandler->();
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
16 $result = [$result] unless ref $result;
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
17 } otherwise {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
18 my $err = shift;
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
19 $result = { error => $err };
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
20 };
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
21
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
22 my $t = new IMPL::Transform::Json($action->context->{json});
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
23
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
24 if ($action->context->{transactionType} and $action->context->{transactionType} eq 'form') {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
25 delete @$result{qw(formData formSchema)};
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
26 my $errors = @$result{formErrors};
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
27
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
28 $result->{formErrors} = [ map $_->Message, @$errors ] if $errors;
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
29 }
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
30
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
31 $action->response->contentType('text/javascript');
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
32
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
33 my $hout = $action->response->streamBody;
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
34 print $hout to_json( $t->Transform($result), {pretty => 1} );
119
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 {
194
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
45 private _direct property _visited => prop_none;
134
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 = (
194
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
51 'IMPL::Transform' => sub {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
52 my $options = shift;
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
53 (
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
54 $options ? %{$options} : ()
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
55 ),
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
56 ARRAY => sub {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
57 my ($this,$object) = @_;
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
58
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
59 return [
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
60 map { $this->Transform($_) } @$object
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
61 ];
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
62 },
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
63 HASH => sub {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
64 my ($this,$object) = @_;
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
65
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
66 return {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
67 map { $_, $this->Transform($object->{$_}) } keys %$object
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
68 };
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
69 },
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
70 'IMPL::Object::List' => sub {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
71 my ($this,$object) = @_;
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
72
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
73 return [
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
74 map { $this->Transform($_) } @$object
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
75 ];
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
76 },
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
77 -plain => sub {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
78 $_[1];
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
79 },
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
80 -default => sub {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
81 my ($this,$object) = @_;
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
82
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
83 return "$object" unless $object->isa('IMPL::Object::Abstract');
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
84
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
85 if ( $object->isa(typeof IMPL::Exception) ) {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
86 return {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
87 type => $object->typeof,
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
88 message => $object->Message,
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
89 arguments => $this->Transform(scalar $object->Args)
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
90 };
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
91 }
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
92
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
93 my $propList = $propListCache{ref $object};
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
94 unless ( $propList ) {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
95 my %props = map {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
96 $_->Name, (ref $_->Mutators ? 0 : ($_->Mutators & prop_list))
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
97 } $object->get_meta('IMPL::Class::PropertyInfo',sub { $_->Access == IMPL::Class::Member::MOD_PUBLIC and $_->Name !~ /^_/}, 1 );
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
98
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
99 $propListCache{ref $object} = $propList = \%props;
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
100 }
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
101
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
102 return {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
103 map {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
104 $_, $propList->{$_} ? $this->Transform([$object->$_()]) : $this->Transform(scalar $object->$_());
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
105 } keys %$propList
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
106 };
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
107 }
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
108 }
118
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 {
194
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
112 my ($this,$object) = @_;
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
113
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
114 # small hack to prevent cycling
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
115
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
116 return $this->SUPER::Transform($object) unless ref $object;
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
117
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
118 if (exists $this->{$_visited}{refaddr $object}) {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
119 return $this->{$_visited}{refaddr $object};
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
120 } else {
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
121 $this->{$_visited}{refaddr $object} = undef;
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
122 return $this->{$_visited}{refaddr $object} = $this->SUPER::Transform($object);
4d0e1962161c Replaced tabs with spaces
cin
parents: 180
diff changeset
123 }
134
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;