annotate _test/test_transform.pl @ 223:edf011437be8

updated resources schema
author sergey
date Tue, 28 Aug 2012 17:29:42 +0400
parents
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
223
edf011437be8 updated resources schema
sergey
parents:
diff changeset
1 use strict;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
2 package Person;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
3 use IMPL::lang qw(:declare);
edf011437be8 updated resources schema
sergey
parents:
diff changeset
4 use IMPL::declare {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
5 base => [
edf011437be8 updated resources schema
sergey
parents:
diff changeset
6 'IMPL::Object' => undef,
edf011437be8 updated resources schema
sergey
parents:
diff changeset
7 'IMPL::Object::Autofill' => '@_'
edf011437be8 updated resources schema
sergey
parents:
diff changeset
8 ]
edf011437be8 updated resources schema
sergey
parents:
diff changeset
9 };
edf011437be8 updated resources schema
sergey
parents:
diff changeset
10
edf011437be8 updated resources schema
sergey
parents:
diff changeset
11 BEGIN {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
12 public property name => PROP_ALL;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
13 public property age => PROP_ALL;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
14 public property addresses => PROP_ALL | PROP_LIST;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
15 }
edf011437be8 updated resources schema
sergey
parents:
diff changeset
16
edf011437be8 updated resources schema
sergey
parents:
diff changeset
17 package Address;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
18 use IMPL::lang qw(:declare);
edf011437be8 updated resources schema
sergey
parents:
diff changeset
19 use IMPL::declare {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
20 base => [
edf011437be8 updated resources schema
sergey
parents:
diff changeset
21 'IMPL::Object' => undef,
edf011437be8 updated resources schema
sergey
parents:
diff changeset
22 'IMPL::Object::Autofill' => '@_'
edf011437be8 updated resources schema
sergey
parents:
diff changeset
23 ]
edf011437be8 updated resources schema
sergey
parents:
diff changeset
24 };
edf011437be8 updated resources schema
sergey
parents:
diff changeset
25
edf011437be8 updated resources schema
sergey
parents:
diff changeset
26 BEGIN {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
27 public property country => PROP_ALL;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
28 public property city => PROP_ALL;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
29 }
edf011437be8 updated resources schema
sergey
parents:
diff changeset
30
edf011437be8 updated resources schema
sergey
parents:
diff changeset
31 package main;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
32
edf011437be8 updated resources schema
sergey
parents:
diff changeset
33 my $data = {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
34 name => 'Peter',
edf011437be8 updated resources schema
sergey
parents:
diff changeset
35 age => '99',
edf011437be8 updated resources schema
sergey
parents:
diff changeset
36 addresses => {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
37 address => [
edf011437be8 updated resources schema
sergey
parents:
diff changeset
38 {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
39 country => 'Airot',
edf011437be8 updated resources schema
sergey
parents:
diff changeset
40 city => 'Torhiq',
edf011437be8 updated resources schema
sergey
parents:
diff changeset
41 street => 'avenu1'
edf011437be8 updated resources schema
sergey
parents:
diff changeset
42 },
edf011437be8 updated resources schema
sergey
parents:
diff changeset
43 {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
44 country => 'Olkson',
edf011437be8 updated resources schema
sergey
parents:
diff changeset
45 city => 'Zoxs',
edf011437be8 updated resources schema
sergey
parents:
diff changeset
46 street => 'av2'
edf011437be8 updated resources schema
sergey
parents:
diff changeset
47 }
edf011437be8 updated resources schema
sergey
parents:
diff changeset
48 ]
edf011437be8 updated resources schema
sergey
parents:
diff changeset
49 }
edf011437be8 updated resources schema
sergey
parents:
diff changeset
50 };
edf011437be8 updated resources schema
sergey
parents:
diff changeset
51
edf011437be8 updated resources schema
sergey
parents:
diff changeset
52 use Carp qw(confess);
edf011437be8 updated resources schema
sergey
parents:
diff changeset
53
edf011437be8 updated resources schema
sergey
parents:
diff changeset
54 sub Rule(&) {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
55 my ($block) = @_;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
56
edf011437be8 updated resources schema
sergey
parents:
diff changeset
57 return sub {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
58 local $_ = shift;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
59 $block->();
edf011437be8 updated resources schema
sergey
parents:
diff changeset
60 }
edf011437be8 updated resources schema
sergey
parents:
diff changeset
61 }
edf011437be8 updated resources schema
sergey
parents:
diff changeset
62
edf011437be8 updated resources schema
sergey
parents:
diff changeset
63 sub Inspect($$) {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
64 my ($path,$block) = @_;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
65 my $data = $_;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
66
edf011437be8 updated resources schema
sergey
parents:
diff changeset
67 foreach my $name (@$path) {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
68 $data = ref $data ? $data->{$name} : undef;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
69 print "$name = $data\n";
edf011437be8 updated resources schema
sergey
parents:
diff changeset
70 }
edf011437be8 updated resources schema
sergey
parents:
diff changeset
71
edf011437be8 updated resources schema
sergey
parents:
diff changeset
72 local $_ = $data;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
73 $block->($data);
edf011437be8 updated resources schema
sergey
parents:
diff changeset
74 }
edf011437be8 updated resources schema
sergey
parents:
diff changeset
75
edf011437be8 updated resources schema
sergey
parents:
diff changeset
76 sub Required(@);
edf011437be8 updated resources schema
sergey
parents:
diff changeset
77
edf011437be8 updated resources schema
sergey
parents:
diff changeset
78 sub Required(@) {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
79 if(@_) {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
80 Inspect([@_],Rule { Required });
edf011437be8 updated resources schema
sergey
parents:
diff changeset
81 } else {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
82 confess "required" unless $_;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
83 }
edf011437be8 updated resources schema
sergey
parents:
diff changeset
84 }
edf011437be8 updated resources schema
sergey
parents:
diff changeset
85
edf011437be8 updated resources schema
sergey
parents:
diff changeset
86 sub Regexp($) {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
87 my $rx = shift;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
88 die "Regular expression doesn't match" unless m/$rx/;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
89 }
edf011437be8 updated resources schema
sergey
parents:
diff changeset
90
edf011437be8 updated resources schema
sergey
parents:
diff changeset
91 my $validate = Rule {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
92 Required('name');
edf011437be8 updated resources schema
sergey
parents:
diff changeset
93
edf011437be8 updated resources schema
sergey
parents:
diff changeset
94 Inspect ['age'] => Rule {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
95 Regexp(qr/^\d+$/);
edf011437be8 updated resources schema
sergey
parents:
diff changeset
96 die "invalid person age" unless $_ > 0 && $_ < 200;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
97 };
edf011437be8 updated resources schema
sergey
parents:
diff changeset
98
edf011437be8 updated resources schema
sergey
parents:
diff changeset
99 Inspect ['addresses', 'address'] => Rule {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
100 Required;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
101 foreach(@{$_}) {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
102 Required('street');
edf011437be8 updated resources schema
sergey
parents:
diff changeset
103 }
edf011437be8 updated resources schema
sergey
parents:
diff changeset
104 }
edf011437be8 updated resources schema
sergey
parents:
diff changeset
105 };
edf011437be8 updated resources schema
sergey
parents:
diff changeset
106
edf011437be8 updated resources schema
sergey
parents:
diff changeset
107 $validate->($data);
edf011437be8 updated resources schema
sergey
parents:
diff changeset
108
edf011437be8 updated resources schema
sergey
parents:
diff changeset
109 my ($person) =
edf011437be8 updated resources schema
sergey
parents:
diff changeset
110 map {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
111 Person->new(
edf011437be8 updated resources schema
sergey
parents:
diff changeset
112 name => $_->{name},
edf011437be8 updated resources schema
sergey
parents:
diff changeset
113 age => $_->{age},
edf011437be8 updated resources schema
sergey
parents:
diff changeset
114 addresses => [
edf011437be8 updated resources schema
sergey
parents:
diff changeset
115 map {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
116 Address->new(
edf011437be8 updated resources schema
sergey
parents:
diff changeset
117 country => $_->{country},
edf011437be8 updated resources schema
sergey
parents:
diff changeset
118 city => $_->{city}
edf011437be8 updated resources schema
sergey
parents:
diff changeset
119 )
edf011437be8 updated resources schema
sergey
parents:
diff changeset
120 } as_list( $_->{addresses}{address} )
edf011437be8 updated resources schema
sergey
parents:
diff changeset
121 ]
edf011437be8 updated resources schema
sergey
parents:
diff changeset
122 )
edf011437be8 updated resources schema
sergey
parents:
diff changeset
123 } $data;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
124
edf011437be8 updated resources schema
sergey
parents:
diff changeset
125 use Data::Dumper;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
126 print Dumper($person);
edf011437be8 updated resources schema
sergey
parents:
diff changeset
127
edf011437be8 updated resources schema
sergey
parents:
diff changeset
128 sub as_list {
edf011437be8 updated resources schema
sergey
parents:
diff changeset
129 return @{ $_[0] } if ref $_[0] eq 'ARRAY';
edf011437be8 updated resources schema
sergey
parents:
diff changeset
130 return @_;
edf011437be8 updated resources schema
sergey
parents:
diff changeset
131 }