Mercurial > pub > Impl
annotate Lib/IMPL/Transform.pm @ 197:6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
IMPL::Transform now admires object inheritance while searching for the transformation
Added HTTP some exceptions
IMPL::Web::Application::RestResource almost implemented
| author | sergey |
|---|---|
| date | Thu, 19 Apr 2012 02:10:02 +0400 |
| parents | d1676be8afcc |
| children | 2ffe6f661605 |
| 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 { | |
| 18 my ($this,%args) = @_; | |
| 19 | |
|
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
20 $this->{$plain} = delete $args{-plain}; |
|
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
21 $this->{$default} = delete $args{-default}; |
| 49 | 22 |
|
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
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 |
|
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
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"}; |
|
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
56 |
|
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 |
|
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
62 return $this->{$_cache}->{$class} = $t if $t; |
|
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
63 |
|
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
64 push @isa, @{"${sclass}::ISA"}; |
|
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 }; |
| 49 | 67 } |
| 68 } | |
| 69 | |
|
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
70 sub ProcessTemplate { |
|
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
71 my ($this,$t,$obj,$args) = @_; |
|
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
72 |
|
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
73 return $this->$t($obj,@$args); |
|
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
74 } |
|
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
75 |
| 49 | 76 sub GetClassForObject { |
| 77 my ($this,$object) = @_; | |
| 78 | |
| 79 return ref $object; | |
| 80 } | |
| 81 | |
| 82 package IMPL::Transform::NoTransformException; | |
|
197
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
83 use IMPL::declare { |
|
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
84 base => { |
|
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
85 'IMPL::Exception' => sub { 'No transformation', @_ } |
|
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
86 } |
|
6b1dda998839
Added IMPL::declare, IMPL::require, to simplify module definitions
sergey
parents:
180
diff
changeset
|
87 }; |
| 49 | 88 |
| 89 1; | |
| 90 | |
| 91 __END__ | |
| 92 | |
| 93 =pod | |
| 96 | 94 |
| 95 =head1 NAME | |
| 96 | |
| 180 | 97 C<IMPL::Transform> - преобразование объектной структуры |
| 96 | 98 |
| 49 | 99 =head1 SYNOPSIS |
| 100 | |
| 96 | 101 =begin code |
| 102 | |
| 49 | 103 my $obj = new AnyObject; |
| 104 | |
| 105 my $t = new Transform ( | |
|
148
e6447ad85cb4
DOM objects now have a schema and schemaSource properties
wizard
parents:
96
diff
changeset
|
106 SomeClass => sub { |
| 49 | 107 my ($this,$object) = @_; |
| 108 return new NewClass({ Name => $object->name, Document => $this->Transform($object->Data) }) | |
| 109 }, | |
| 110 DocClass => sub { | |
| 111 my ($this,$object) = @_; | |
| 112 return new DocPreview(Author => $object->Author, Text => $object->Data); | |
| 113 }, | |
| 114 -default => sub { | |
| 115 my ($this,$object) = @_; | |
| 116 return $object; | |
| 117 }, | |
| 118 -plain => sub { | |
| 119 my ($this,$object) = @_; | |
| 120 return $object; | |
| 121 } | |
| 122 ); | |
| 123 | |
| 124 my $result = $t->Transform($obj); | |
| 125 | |
| 96 | 126 =end code |
| 127 | |
| 49 | 128 =head1 DESCRIPTION |
| 129 | |
| 180 | 130 Преобразование одного объекта к другому, например даных к их представлению. |
| 49 | 131 |
| 132 =cut |