|
407
|
1 package IMPL::Transform;
|
|
|
2 use strict;
|
|
|
3
|
|
|
4 use parent qw(IMPL::Object);
|
|
|
5
|
|
|
6 use IMPL::lang qw(:declare);
|
|
|
7
|
|
|
8
|
|
|
9 BEGIN {
|
|
|
10 public _direct property templates => PROP_ALL;
|
|
|
11 public _direct property default => PROP_ALL;
|
|
|
12 public _direct property plain => PROP_ALL;
|
|
|
13 private _direct property _cache => PROP_ALL;
|
|
|
14 }
|
|
|
15
|
|
|
16 sub CTOR {
|
|
|
17 my $this = shift;
|
|
|
18 my $args = @_ == 1 ? shift : { @_ };
|
|
|
19
|
|
|
20 $this->{$plain} = delete $args->{-plain};
|
|
|
21 $this->{$default} = delete $args->{-default};
|
|
|
22
|
|
|
23 $this->{$templates} = $args;
|
|
|
24 }
|
|
|
25
|
|
|
26 sub Transform {
|
|
|
27 my ($this,$object,@args) = @_;
|
|
|
28
|
|
|
29 if (not ref $object) {
|
|
|
30 die new IMPL::Exception("There is no the template for a plain value in the transform") unless $this->{$plain};
|
|
|
31 my $template = $this->{$plain};
|
|
|
32 return $this->$template($object,@args);
|
|
|
33 } else {
|
|
|
34
|
|
|
35 my $template = $this->MatchTemplate($object) || $this->default or die new IMPL::Transform::NoTransformException(ref $object);
|
|
|
36
|
|
|
37 return $this->ProcessTemplate($template,$object,@args);
|
|
|
38 }
|
|
|
39 }
|
|
|
40
|
|
|
41 sub MatchTemplate {
|
|
|
42 my ($this,$object) = @_;
|
|
|
43 my $class = $this->GetClassForObject( $object );
|
|
|
44
|
|
|
45 if (my $t = $this->{$_cache}->{$class} ) {
|
|
|
46 return $t;
|
|
|
47 } else {
|
|
|
48 $t = $this->{$templates}->{$class};
|
|
|
49
|
|
|
50 return $this->{$_cache}->{$class} = $t if $t;
|
|
|
51
|
|
|
52 {
|
|
|
53 no strict 'refs';
|
|
|
54
|
|
|
55 my @isa = @{"${class}::ISA"};
|
|
|
56
|
|
|
57 while (@isa) {
|
|
|
58 my $sclass = shift @isa;
|
|
|
59
|
|
|
60 $t = $this->{$templates}->{$sclass};
|
|
|
61
|
|
|
62 #cache and return
|
|
|
63 return $this->{$_cache}->{$class} = $t if $t;
|
|
|
64
|
|
|
65 push @isa, @{"${sclass}::ISA"};
|
|
|
66 }
|
|
|
67 ;
|
|
|
68 };
|
|
|
69 }
|
|
|
70 }
|
|
|
71
|
|
|
72 sub ProcessTemplate {
|
|
|
73 my ($this,$t,$obj,@args) = @_;
|
|
|
74
|
|
|
75 return $this->$t($obj,@args);
|
|
|
76 }
|
|
|
77
|
|
|
78 sub GetClassForObject {
|
|
|
79 my ($this,$object) = @_;
|
|
|
80
|
|
|
81 return ref $object;
|
|
|
82 }
|
|
|
83
|
|
|
84 package IMPL::Transform::NoTransformException;
|
|
|
85 use IMPL::declare {
|
|
|
86 base => {
|
|
|
87 'IMPL::Exception' => sub { 'No transformation', @_ }
|
|
|
88 }
|
|
|
89 };
|
|
|
90
|
|
|
91 1;
|
|
|
92
|
|
|
93 __END__
|
|
|
94
|
|
|
95 =pod
|
|
|
96
|
|
|
97 =head1 NAME
|
|
|
98
|
|
|
99 C<IMPL::Transform> - преобразование объектной структуры
|
|
|
100
|
|
|
101 =head1 SYNOPSIS
|
|
|
102
|
|
|
103 =begin code
|
|
|
104
|
|
|
105 my $obj = new AnyObject;
|
|
|
106
|
|
|
107 my $t = new Transform (
|
|
|
108 SomeClass => sub {
|
|
|
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
|
|
|
128 =end code
|
|
|
129
|
|
|
130 =head1 DESCRIPTION
|
|
|
131
|
|
|
132 Преобразование одного объекта к другому, например даных к их представлению.
|
|
|
133
|
|
|
134 =cut
|
