Mercurial > pub > Impl
annotate Lib/IMPL/Web/QueryHandler/JsonFormat.pm @ 166:4267a2ac3d46
Added Class::Template,
Rewritten SQL::Schema
'use parent' directive instead of 'use base'
| author | wizard |
|---|---|
| date | Sat, 23 Apr 2011 23:12:06 +0400 |
| parents | fb896377389f |
| children | aaab45153411 |
| rev | line source |
|---|---|
| 119 | 1 use strict; |
| 2 package IMPL::Transform::Json; | |
| 3 | |
| 118 | 4 package IMPL::Web::QueryHandler::JsonFormat; |
| 166 | 5 use parent qw(IMPL::Web::QueryHandler); |
| 118 | 6 use Error qw(:try); |
| 7 use JSON; | |
| 8 | |
| 9 sub Process { | |
| 10 my ($this,$action,$nextHandler) = @_; | |
| 11 | |
| 119 | 12 my $result; |
| 13 my $t = new IMPL::Transform::Json; | |
| 118 | 14 |
| 15 try { | |
| 16 $result = $nextHandler->(); | |
| 119 | 17 $result = [$result] unless ref $result; |
| 118 | 18 } otherwise { |
| 19 my $err = shift; | |
| 20 $result = { error => $err }; | |
| 21 }; | |
| 22 | |
| 23 $action->response->contentType('text/javascript'); | |
| 119 | 24 |
| 118 | 25 my $hout = $action->response->streamBody; |
| 119 | 26 print $hout to_json( $t->Transform($result), {pretty => 1} ); |
| 27 } | |
| 118 | 28 |
| 119 | 29 package IMPL::Transform::Json; |
| 118 | 30 |
| 166 | 31 use parent qw(IMPL::Transform); |
| 118 | 32 use IMPL::Class::Property; |
| 134 | 33 use IMPL::Class::Property::Direct; |
| 34 use Scalar::Util qw(refaddr); | |
| 35 | |
| 36 BEGIN { | |
| 37 private _direct property _visited => prop_none; | |
| 38 } | |
| 39 | |
| 119 | 40 my %propListCache; |
| 118 | 41 |
| 42 our %CTOR = ( | |
| 43 'IMPL::Transform' => sub { | |
| 119 | 44 ARRAY => sub { |
| 45 my ($this,$object) = @_; | |
| 46 | |
| 47 return [ | |
| 48 map { $this->Transform($_) } @$object | |
| 49 ]; | |
| 50 }, | |
| 51 HASH => sub { | |
| 52 my ($this,$object) = @_; | |
| 53 | |
| 54 return { | |
| 55 map { $_, $this->Transform($object->{$_}) } keys %$object | |
| 56 }; | |
| 57 }, | |
| 58 'IMPL::Object::List' => sub { | |
| 59 my ($this,$object) = @_; | |
| 60 | |
| 61 return [ | |
| 62 map { $this->Transform($_) } @$object | |
| 63 ]; | |
| 64 }, | |
| 65 -plain => sub { | |
| 66 $_[1]; | |
| 67 }, | |
| 68 -default => sub { | |
| 69 my ($this,$object) = @_; | |
| 70 | |
| 71 return "$object" unless $object->isa('IMPL::Object::Abstract'); | |
| 72 | |
|
128
08753833173d
Fixed a error handling issue in JSON output: errors are correctly transfered
wizard
parents:
120
diff
changeset
|
73 if ( $object->isa(typeof IMPL::Exception) ) { |
|
08753833173d
Fixed a error handling issue in JSON output: errors are correctly transfered
wizard
parents:
120
diff
changeset
|
74 return { |
|
08753833173d
Fixed a error handling issue in JSON output: errors are correctly transfered
wizard
parents:
120
diff
changeset
|
75 type => $object->typeof, |
|
08753833173d
Fixed a error handling issue in JSON output: errors are correctly transfered
wizard
parents:
120
diff
changeset
|
76 message => $object->Message, |
|
08753833173d
Fixed a error handling issue in JSON output: errors are correctly transfered
wizard
parents:
120
diff
changeset
|
77 arguments => $this->Transform(scalar $object->Args) |
|
08753833173d
Fixed a error handling issue in JSON output: errors are correctly transfered
wizard
parents:
120
diff
changeset
|
78 }; |
|
08753833173d
Fixed a error handling issue in JSON output: errors are correctly transfered
wizard
parents:
120
diff
changeset
|
79 } |
|
08753833173d
Fixed a error handling issue in JSON output: errors are correctly transfered
wizard
parents:
120
diff
changeset
|
80 |
| 119 | 81 my $propList = $propListCache{ref $object}; |
| 82 unless ( $propList ) { | |
| 83 my %props = map { | |
| 84 $_->Name, (ref $_->Mutators ? 0 : ($_->Mutators & prop_list)) | |
| 85 } $object->get_meta('IMPL::Class::PropertyInfo',sub { $_->Access == IMPL::Class::Member::MOD_PUBLIC and $_->Name !~ /^_/}, 1 ); | |
| 118 | 86 |
| 119 | 87 $propListCache{ref $object} = $propList = \%props; |
| 118 | 88 } |
| 89 | |
| 90 return { | |
| 91 map { | |
| 119 | 92 $_, $propList->{$_} ? $this->Transform([$object->$_()]) : $this->Transform(scalar $object->$_()); |
| 93 } keys %$propList | |
| 118 | 94 }; |
| 95 } | |
| 96 } | |
| 97 ); | |
| 98 | |
| 134 | 99 sub Transform { |
| 100 my ($this,$object) = @_; | |
| 101 | |
|
140
fb896377389f
to_json and escape_string functions for the templates
wizard
parents:
134
diff
changeset
|
102 # small hack to prevent cycling |
|
fb896377389f
to_json and escape_string functions for the templates
wizard
parents:
134
diff
changeset
|
103 |
| 134 | 104 return $this->SUPER::Transform($object) unless ref $object; |
| 105 | |
| 106 if (exists $this->{$_visited}{refaddr $object}) { | |
| 107 return $this->{$_visited}{refaddr $object}; | |
| 108 } else { | |
| 109 $this->{$_visited}{refaddr $object} = undef; | |
| 110 return $this->{$_visited}{refaddr $object} = $this->SUPER::Transform($object); | |
| 111 } | |
| 112 } | |
| 113 | |
| 119 | 114 1; |