|
0
|
1 package IMPL::Transform;
|
|
7
|
2 use base qw(IMPL::Object);
|
|
0
|
3
|
|
|
4 use IMPL::Class::Property;
|
|
|
5 use IMPL::Class::Property::Direct;
|
|
|
6
|
|
|
7 BEGIN {
|
|
|
8 protected _direct property Templates => prop_all;
|
|
|
9 protected _direct property Default => prop_all;
|
|
|
10 protected _direct property Plain => prop_all;
|
|
|
11 }
|
|
|
12
|
|
7
|
13 sub CTOR {
|
|
|
14 my ($this,%args) = @_;
|
|
|
15
|
|
|
16 $this->{$Plain} = delete $args{-plain};
|
|
|
17 $this->{$Default} = delete $args{-default};
|
|
|
18
|
|
|
19 $this->{$Templates} = \%args;
|
|
|
20 }
|
|
0
|
21
|
|
|
22 sub Transform {
|
|
38
|
23 my ($this,$object,@args) = @_;
|
|
0
|
24
|
|
|
25 if (not ref $object) {
|
|
|
26 die new IMPL::Exception("There is no the template for a plain value in the transform") unless $this->{$Plain};
|
|
|
27 my $template = $this->{$Plain};
|
|
38
|
28 return $this->$template($object,@args);
|
|
0
|
29 } else {
|
|
|
30
|
|
|
31 my $template = $this->MatchTemplate($object) || $this->Default or die new IMPL::Transform::NoTransformException(ref $object);
|
|
|
32
|
|
38
|
33 return $this->$template($object,@args);
|
|
0
|
34 }
|
|
|
35 }
|
|
|
36
|
|
|
37 sub MatchTemplate {
|
|
|
38 my ($this,$object) = @_;
|
|
38
|
39 my $class = $this->GetClassForObject( $object );
|
|
0
|
40
|
|
|
41 foreach my $tClass ( keys %{$this->Templates || {}} ) {
|
|
|
42 return $this->Templates->{$tClass} if ($tClass eq $class);
|
|
|
43 }
|
|
|
44 }
|
|
|
45
|
|
38
|
46 sub GetClassForObject {
|
|
|
47 my ($this,$object) = @_;
|
|
|
48
|
|
|
49 return ref $object;
|
|
|
50 }
|
|
|
51
|
|
0
|
52 package IMPL::Transform::NoTransformException;
|
|
|
53 use base qw(IMPL::Exception);
|
|
|
54
|
|
44
|
55 our %CTOR = (
|
|
|
56 'IMPL::Exception' => sub { 'No transformation', @_ }
|
|
|
57 );
|
|
|
58
|
|
0
|
59 1;
|
|
|
60
|
|
|
61 __END__
|
|
|
62
|
|
|
63 =pod
|
|
|
64 =head1 SYNOPSIS
|
|
|
65
|
|
|
66 my $obj = new AnyObject;
|
|
|
67
|
|
|
68 my $t = new Transform (
|
|
|
69 AnyClass => sub {
|
|
|
70 my ($this,$object) = @_;
|
|
|
71 return new NewClass({ Name => $object->name, Document => $this->Transform($object->Data) })
|
|
|
72 },
|
|
|
73 DocClass => sub {
|
|
|
74 my ($this,$object) = @_;
|
|
|
75 return new DocPreview(Author => $object->Author, Text => $object->Data);
|
|
7
|
76 },
|
|
|
77 -default => sub {
|
|
|
78 my ($this,$object) = @_;
|
|
|
79 return $object;
|
|
|
80 },
|
|
|
81 -plain => sub {
|
|
|
82 my ($this,$object) = @_;
|
|
|
83 return $object;
|
|
0
|
84 }
|
|
|
85 );
|
|
|
86
|
|
7
|
87 my $result = $t->Transform($obj);
|
|
|
88
|
|
38
|
89 =head1 DESCRIPTION
|
|
|
90
|
|
|
91 , .
|
|
0
|
92
|
|
|
93 =cut |
