Mercurial > pub > Impl
annotate Lib/IMPL/Transform.pm @ 284:f2a6bc5f3184
+IMPL::Object::InlineFactory: implement object factory as subroutine
author | sergey |
---|---|
date | Thu, 14 Feb 2013 19:14:02 +0400 |
parents | 4ddb27ff4a0b |
children |
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 |
236 | 6 use IMPL::lang qw(:declare); |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
7 |
49 | 8 |
9 BEGIN { | |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
10 public _direct property templates => PROP_ALL; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
11 public _direct property default => PROP_ALL; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
12 public _direct property plain => PROP_ALL; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
13 private _direct property _cache => PROP_ALL; |
49 | 14 } |
15 | |
16 sub CTOR { | |
198 | 17 my $this = shift; |
18 my $args = @_ == 1 ? shift : { @_ }; | |
49 | 19 |
198 | 20 $this->{$plain} = delete $args->{-plain}; |
21 $this->{$default} = delete $args->{-default}; | |
49 | 22 |
198 | 23 $this->{$templates} = $args; |
49 | 24 } |
25 | |
26 sub Transform { | |
27 my ($this,$object,@args) = @_; | |
28 | |
29 if (not ref $object) { | |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
30 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
|
31 my $template = $this->{$plain}; |
49 | 32 return $this->$template($object,@args); |
33 } else { | |
34 | |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
35 my $template = $this->MatchTemplate($object) || $this->default or die new IMPL::Transform::NoTransformException(ref $object); |
49 | 36 |
199
e743a8481327
Added REST support for forms (with only get and post methods)
sergey
parents:
198
diff
changeset
|
37 return $this->ProcessTemplate($template,$object,@args); |
49 | 38 } |
39 } | |
40 | |
41 sub MatchTemplate { | |
42 my ($this,$object) = @_; | |
43 my $class = $this->GetClassForObject( $object ); | |
44 | |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
45 if (my $t = $this->{$_cache}->{$class} ) { |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
46 return $t; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
47 } else { |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
48 $t = $this->{$templates}->{$class}; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
49 |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
50 return $this->{$_cache}->{$class} = $t if $t; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
51 |
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 no strict 'refs'; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
54 |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
55 my @isa = @{"${class}::ISA"}; |
212 | 56 |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
57 while (@isa) { |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
58 my $sclass = shift @isa; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
59 |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
60 $t = $this->{$templates}->{$sclass}; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
61 |
198 | 62 #cache and return |
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
63 return $this->{$_cache}->{$class} = $t if $t; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
64 |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
65 push @isa, @{"${sclass}::ISA"}; |
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
66 } |
243
cd2b1f121029
*TTView: fixed template selection based on the model type
sergey
parents:
236
diff
changeset
|
67 ; |
197
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 |