annotate Lib/IMPL/Transform.pm @ 40:ac21a032e7a9

bnf parser in progress
author Sergey
date Thu, 10 Dec 2009 17:43:39 +0300
parents d660fb38b7cc
children 32d2350fccf9
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
0
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
1 package IMPL::Transform;
7
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
2 use base qw(IMPL::Object);
0
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
3
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
4 use IMPL::Class::Property;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
5 use IMPL::Class::Property::Direct;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
6
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
7 BEGIN {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
8 protected _direct property Templates => prop_all;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
9 protected _direct property Default => prop_all;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
10 protected _direct property Plain => prop_all;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
11 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
12
7
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
13 sub CTOR {
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
14 my ($this,%args) = @_;
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
15
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
16 $this->{$Plain} = delete $args{-plain};
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
17 $this->{$Default} = delete $args{-default};
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
18
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
19 $this->{$Templates} = \%args;
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
20 }
0
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
21
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
22 sub Transform {
38
d660fb38b7cc small fixes
Sergey
parents: 7
diff changeset
23 my ($this,$object,@args) = @_;
0
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
24
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
25 if (not ref $object) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
26 die new IMPL::Exception("There is no the template for a plain value in the transform") unless $this->{$Plain};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
27 my $template = $this->{$Plain};
38
d660fb38b7cc small fixes
Sergey
parents: 7
diff changeset
28 return $this->$template($object,@args);
0
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
29 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
30
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
31 my $template = $this->MatchTemplate($object) || $this->Default or die new IMPL::Transform::NoTransformException(ref $object);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
32
38
d660fb38b7cc small fixes
Sergey
parents: 7
diff changeset
33 return $this->$template($object,@args);
0
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
34 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
35 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
36
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
37 sub MatchTemplate {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
38 my ($this,$object) = @_;
38
d660fb38b7cc small fixes
Sergey
parents: 7
diff changeset
39 my $class = $this->GetClassForObject( $object );
0
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
40
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
41 foreach my $tClass ( keys %{$this->Templates || {}} ) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
42 return $this->Templates->{$tClass} if ($tClass eq $class);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
43 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
44 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
45
38
d660fb38b7cc small fixes
Sergey
parents: 7
diff changeset
46 sub GetClassForObject {
d660fb38b7cc small fixes
Sergey
parents: 7
diff changeset
47 my ($this,$object) = @_;
d660fb38b7cc small fixes
Sergey
parents: 7
diff changeset
48
d660fb38b7cc small fixes
Sergey
parents: 7
diff changeset
49 return ref $object;
d660fb38b7cc small fixes
Sergey
parents: 7
diff changeset
50 }
d660fb38b7cc small fixes
Sergey
parents: 7
diff changeset
51
0
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
52 package IMPL::Transform::NoTransformException;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
53 use base qw(IMPL::Exception);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
54
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
55 1;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
56
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
57 __END__
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
58
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
59 =pod
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
60 =head1 SYNOPSIS
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
61
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
62 my $obj = new AnyObject;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
63
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
64 my $t = new Transform (
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
65 AnyClass => sub {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
66 my ($this,$object) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
67 return new NewClass({ Name => $object->name, Document => $this->Transform($object->Data) })
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
68 },
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
69 DocClass => sub {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
70 my ($this,$object) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
71 return new DocPreview(Author => $object->Author, Text => $object->Data);
7
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
72 },
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
73 -default => sub {
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
74 my ($this,$object) = @_;
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
75 return $object;
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
76 },
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
77 -plain => sub {
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
78 my ($this,$object) = @_;
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
79 return $object;
0
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
80 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
81 );
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
82
7
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
83 my $result = $t->Transform($obj);
94d47b388442 Улучшены тесты
Sergey
parents: 0
diff changeset
84
38
d660fb38b7cc small fixes
Sergey
parents: 7
diff changeset
85 =head1 DESCRIPTION
d660fb38b7cc small fixes
Sergey
parents: 7
diff changeset
86
d660fb38b7cc small fixes
Sergey
parents: 7
diff changeset
87 , .
0
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
88
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
89 =cut