Commit | Line | Data |
36477c24 |
1 | package Class::Template; |
2 | require 5.000; |
3 | require Exporter; |
4 | |
5 | @ISA = qw(Exporter); |
6 | @EXPORT = qw(members struct); |
7 | use strict; |
8 | |
9 | # Template.pm --- struct/member template builder |
10 | # 12mar95 |
11 | # Dean Roehrich |
12 | # |
13 | # changes/bugs fixed since 28nov94 version: |
14 | # - podified |
15 | # changes/bugs fixed since 21nov94 version: |
16 | # - Fixed examples. |
17 | # changes/bugs fixed since 02sep94 version: |
18 | # - Moved to Class::Template. |
19 | # changes/bugs fixed since 20feb94 version: |
20 | # - Updated to be a more proper module. |
21 | # - Added "use strict". |
22 | # - Bug in build_methods, was using @var when @$var needed. |
23 | # - Now using my() rather than local(). |
24 | # |
25 | # Uses perl5 classes to create nested data types. |
26 | # This is offered as one implementation of Tom Christiansen's "structs.pl" |
27 | # idea. |
28 | |
29 | =head1 NAME |
30 | |
31 | Class::Template - struct/member template builder |
32 | |
b133f4ec |
33 | =head1 SYNOPSIS |
34 | |
35 | use Class::Template; |
36 | struct(name => { key1 => type1, key2 => type2 }); |
37 | |
38 | package Myobj; |
39 | use Class::Template; |
40 | members Myobj { key1 => type1, key2 => type2 }; |
41 | |
42 | =head1 DESCRIPTION |
43 | |
44 | This module uses perl5 classes to create nested data types. |
45 | |
36477c24 |
46 | =head1 EXAMPLES |
47 | |
2ae324a7 |
48 | =over |
49 | |
36477c24 |
50 | =item * Example 1 |
51 | |
52 | use Class::Template; |
53 | |
54 | struct( rusage => { |
55 | ru_utime => timeval, |
56 | ru_stime => timeval, |
57 | }); |
58 | |
59 | struct( timeval => [ |
60 | tv_secs => '$', |
61 | tv_usecs => '$', |
62 | ]); |
63 | |
64 | my $s = new rusage; |
65 | |
66 | =item * Example 2 |
67 | |
68 | package OBJ; |
69 | use Class::Template; |
70 | |
71 | members OBJ { |
72 | 'a' => '$', |
73 | 'b' => '$', |
74 | }; |
75 | |
76 | members OBJ2 { |
77 | 'd' => '@', |
78 | 'c' => '$', |
79 | }; |
80 | |
81 | package OBJ2; @ISA = (OBJ); |
82 | |
83 | sub new { |
84 | my $r = InitMembers( &OBJ::InitMembers() ); |
85 | bless $r; |
86 | } |
87 | |
2ae324a7 |
88 | =back |
89 | |
36477c24 |
90 | =head1 NOTES |
a6006777 |
91 | |
36477c24 |
92 | Use '%' if the member should point to an anonymous hash. Use '@' if the |
93 | member should point to an anonymous array. |
94 | |
95 | When using % and @ the method requires one argument for the key or index |
96 | into the hash or array. |
97 | |
98 | Prefix the %, @, or $ with '*' to indicate you want to retrieve pointers to |
99 | the values rather than the values themselves. |
100 | |
101 | =cut |
102 | |
103 | Var: { |
104 | $Class::Template::print = 0; |
105 | sub printem { $Class::Template::print++ } |
106 | } |
107 | |
108 | |
109 | sub struct { |
110 | my( $struct, $ref ) = @_; |
111 | my @methods = (); |
112 | my %refs = (); |
113 | my %arrays = (); |
114 | my %hashes = (); |
115 | my $out = ''; |
116 | |
117 | $out = "{\n package $struct;\n sub new {\n"; |
118 | parse_fields( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes, 0 ); |
119 | $out .= " bless \$r;\n }\n"; |
120 | build_methods( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes ); |
121 | $out .= "}\n1;\n"; |
122 | |
123 | ( $Class::Template::print ) ? print( $out ) : eval $out; |
124 | } |
125 | |
126 | sub members { |
127 | my( $pkg, $ref ) = @_; |
128 | my @methods = (); |
129 | my %refs = (); |
130 | my %arrays = (); |
131 | my %hashes = (); |
132 | my $out = ''; |
133 | |
134 | $out = "{\n package $pkg;\n sub InitMembers {\n"; |
135 | parse_fields( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes, 1 ); |
136 | $out .= " bless \$r;\n }\n"; |
137 | build_methods( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes ); |
138 | $out .= "}\n1;\n"; |
139 | |
140 | ( $Class::Template::print ) ? print( $out ) : eval $out; |
141 | } |
142 | |
143 | |
144 | sub parse_fields { |
145 | my( $ref, $out, $methods, $refs, $arrays, $hashes, $member ) = @_; |
146 | my $type = ref $ref; |
147 | my @keys; |
148 | my $val; |
149 | my $cnt = 0; |
150 | my $idx = 0; |
151 | my( $cmt, $n ); |
152 | |
153 | if( $type eq 'HASH' ){ |
154 | if( $member ){ |
155 | $$out .= " my(\$r) = \@_ ? shift : {};\n"; |
156 | } |
157 | else{ |
158 | $$out .= " my(\$r) = {};\n"; |
159 | } |
160 | @keys = keys %$ref; |
161 | foreach (@keys){ |
162 | $val = $ref->{$_}; |
163 | if( $val =~ /^\*(.)/ ){ |
164 | $refs->{$_}++; |
165 | $val = $1; |
166 | } |
167 | if( $val eq '@' ){ |
168 | $$out .= " \$r->{'$_'} = [];\n"; |
169 | $arrays->{$_}++; |
170 | } |
171 | elsif( $val eq '%' ){ |
172 | $$out .= " \$r->{'$_'} = {};\n"; |
173 | $hashes->{$_}++; |
174 | } |
175 | elsif( $val ne '$' ){ |
176 | $$out .= " \$r->{'$_'} = \&${val}::new();\n"; |
177 | } |
178 | else{ |
179 | $$out .= " \$r->{'$_'} = undef;\n"; |
180 | } |
181 | push( @$methods, $_ ); |
182 | } |
183 | } |
184 | elsif( $type eq 'ARRAY' ){ |
185 | if( $member ){ |
186 | $$out .= " my(\$r) = \@_ ? shift : [];\n"; |
187 | } |
188 | else{ |
189 | $$out .= " my(\$r) = [];\n"; |
190 | } |
191 | while( $idx < @$ref ){ |
192 | $n = $ref->[$idx]; |
193 | push( @$methods, $n ); |
194 | $val = $ref->[$idx+1]; |
195 | $cmt = "# $n"; |
196 | if( $val =~ /^\*(.)/ ){ |
197 | $refs->{$n}++; |
198 | $val = $1; |
199 | } |
200 | if( $val eq '@' ){ |
201 | $$out .= " \$r->[$cnt] = []; $cmt\n"; |
202 | $arrays->{$n}++; |
203 | } |
204 | elsif( $val eq '%' ){ |
205 | $$out .= " \$r->[$cnt] = {}; $cmt\n"; |
206 | $hashes->{$n}++; |
207 | } |
208 | elsif( $val ne '$' ){ |
209 | $$out .= " \$r->[$cnt] = \&${val}::new();\n"; |
210 | } |
211 | else{ |
212 | $$out .= " \$r->[$cnt] = undef; $cmt\n"; |
213 | } |
214 | ++$cnt; |
215 | $idx += 2; |
216 | } |
217 | } |
218 | } |
219 | |
220 | |
221 | sub build_methods { |
222 | my( $ref, $out, $methods, $refs, $arrays, $hashes ) = @_; |
223 | my $type = ref $ref; |
224 | my $elem = ''; |
225 | my $cnt = 0; |
226 | my( $pre, $pst, $cmt, $idx ); |
227 | |
228 | foreach (@$methods){ |
229 | $pre = $pst = $cmt = $idx = ''; |
230 | if( defined $refs->{$_} ){ |
231 | $pre = "\\("; |
232 | $pst = ")"; |
233 | $cmt = " # returns ref"; |
234 | } |
235 | $$out .= " sub $_ {$cmt\n my \$r = shift;\n"; |
236 | if( $type eq 'ARRAY' ){ |
237 | $elem = "[$cnt]"; |
238 | ++$cnt; |
239 | } |
240 | elsif( $type eq 'HASH' ){ |
241 | $elem = "{'$_'}"; |
242 | } |
243 | if( defined $arrays->{$_} ){ |
244 | $$out .= " my \$i;\n"; |
245 | $$out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; |
246 | $idx = "->[\$i]"; |
247 | } |
248 | elsif( defined $hashes->{$_} ){ |
249 | $$out .= " my \$i;\n"; |
250 | $$out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; |
251 | $idx = "->{\$i}"; |
252 | } |
253 | $$out .= " \@_ ? (\$r->$elem$idx = shift) : $pre\$r->$elem$idx$pst;\n"; |
254 | $$out .= " }\n"; |
255 | } |
256 | } |
257 | |
258 | 1; |