Mercurial > pub > Impl

comparison lib/IMPL/Transform.pm @ 407:c6e90e02dd17 ref20150831

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
renamed Lib->lib
author cin
date Fri, 04 Sep 2015 19:40:23 +0300
parents
children
comparison
equal deleted inserted replaced
406:f23fcb19d3c1 407:c6e90e02dd17
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