Mercurial > pub > Impl
annotate Lib/IMPL/Transform.pm @ 210:6adaeb86945d
added IMPL::Web::AutoLocator
author | sergey |
---|---|
date | Tue, 29 May 2012 20:07:22 +0400 |
parents | e743a8481327 |
children | 292226770180 |
rev | line source |
---|---|
49 | 1 package IMPL::Transform; |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
2 use strict; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
3 |
166 | 4 use parent qw(IMPL::Object); |
49 | 5 |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
6 use IMPL::lang qw(:declare :constants); |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
7 |
49 | 8 use IMPL::Class::Property::Direct; |
9 | |
10 BEGIN { | |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
11 public _direct property templates => PROP_ALL; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
12 public _direct property default => PROP_ALL; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
13 public _direct property plain => PROP_ALL; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
14 private _direct property _cache => PROP_ALL; |
49 | 15 } |
16 | |
17 sub CTOR { | |
198 | 18 my $this = shift; |
19 my $args = @_ == 1 ? shift : { @_ }; | |
49 | 20 |
198 | 21 $this->{$plain} = delete $args->{-plain}; |
22 $this->{$default} = delete $args->{-default}; | |
49 | 23 |
198 | 24 $this->{$templates} = $args; |
49 | 25 } |
26 | |
27 sub Transform { | |
28 my ($this,$object,@args) = @_; | |
29 | |
30 if (not ref $object) { | |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
31 die new IMPL::Exception("There is no the template for a plain value in the transform") unless $this->{$plain}; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
32 my $template = $this->{$plain}; |
49 | 33 return $this->$template($object,@args); |
34 } else { | |
35 | |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
36 my $template = $this->MatchTemplate($object) || $this->default or die new IMPL::Transform::NoTransformException(ref $object); |
49 | 37 |
199
e743a8481327
Added REST support for forms (with only get and post methods)
sergey
parents:
198
diff
changeset
|
38 return $this->ProcessTemplate($template,$object,@args); |
49 | 39 } |
40 } | |
41 | |
42 sub MatchTemplate { | |
43 my ($this,$object) = @_; | |
44 my $class = $this->GetClassForObject( $object ); | |
45 | |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
46 if (my $t = $this->{$_cache}->{$class} ) { |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
47 return $t; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
48 } else { |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
49 $t = $this->{$templates}->{$class}; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
50 |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
51 return $this->{$_cache}->{$class} = $t if $t; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
52 |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
53 { |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
54 no strict 'refs'; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
55 |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
56 my @isa = @{"${class}::ISA"}; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
57 |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
58 while (@isa) { |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
59 my $sclass = shift @isa; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
60 |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
61 $t = $this->{$templates}->{$sclass}; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
62 |
198 | 63 #cache and return |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
64 return $this->{$_cache}->{$class} = $t if $t; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
65 |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
66 push @isa, @{"${sclass}::ISA"}; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
67 } |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
68 }; |
49 | 69 } |
70 } | |
71 | |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
72 sub ProcessTemplate { |
199
e743a8481327
Added REST support for forms (with only get and post methods)
sergey
parents:
198
diff
changeset
|
73 my ($this,$t,$obj,@args) = @_; |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
74 |
199
e743a8481327
Added REST support for forms (with only get and post methods)
sergey
parents:
198
diff
changeset
|
75 return $this->$t($obj,@args); |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
76 } |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
77 |
49 | 78 sub GetClassForObject { |
79 my ($this,$object) = @_; | |
80 | |
81 return ref $object; | |
82 } | |
83 | |
84 package IMPL::Transform::NoTransformException; | |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
85 use IMPL::declare { |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
86 base => { |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
87 'IMPL::Exception' => sub { 'No transformation', @_ } |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
88 } |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
89 }; |
49 | 90 |
91 1; | |
92 | |
93 __END__ | |
94 | |
95 =pod | |
96 | 96 |
97 =head1 NAME | |
98 | |
180 | 99 C<IMPL::Transform> - преобразование объектной структуры |
96 | 100 |
49 | 101 =head1 SYNOPSIS |
102 | |
96 | 103 =begin code |
104 | |
49 | 105 my $obj = new AnyObject; |
106 | |
107 my $t = new Transform ( | |
148
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
96
diff
changeset
|
108 SomeClass => sub { |
49 | 109 my ($this,$object) = @_; |
110 return new NewClass({ Name => $object->name, Document => $this->Transform($object->Data) }) | |
111 }, | |
112 DocClass => sub { | |
113 my ($this,$object) = @_; | |
114 return new DocPreview(Author => $object->Author, Text => $object->Data); | |
115 }, | |
116 -default => sub { | |
117 my ($this,$object) = @_; | |
118 return $object; | |
119 }, | |
120 -plain => sub { | |
121 my ($this,$object) = @_; | |
122 return $object; | |
123 } | |
124 ); | |
125 | |
126 my $result = $t->Transform($obj); | |
127 | |
96 | 128 =end code |
129 | |
49 | 130 =head1 DESCRIPTION |
131 | |
180 | 132 Преобразование одного объекта к другому, например даных к их представлению. |
49 | 133 |
134 =cut |