1# -----------------------------------------------------------------------------
2# $Id: DefineHelper.pm 11254 2008-05-07 15:25:16Z topia $
3# -----------------------------------------------------------------------------
4# Define Helper Utilities
5# -----------------------------------------------------------------------------
6# copyright (C) 2004-2005 Topia <topia@clovery.jp>. all rights reserved.
7package Tiarra::Utils::DefineHelper;
8use strict;
9use warnings;
10use base qw(Tiarra::Utils::Core);
11our $ExportLevel = 0;
12
13# please do {
14#     Tiarra::Utils::DefineHelper->do_with_define_exportlevel(
15#         0,
16#         sub {
17#             Tiarra::Utils::DefineHelper->define_enum(qw(...));
18#         });
19# in define_*s' wrapper function.
20
21
22=head1 NAME
23
24Tiarra::Utils::DefineHelper - Tiarra misc Utility Functions: Define Helper
25
26=head1 SYNOPSIS
27
28  use Tiarra::Utils; # import master
29
30=head1 DESCRIPTION
31
32Tiarra::Utils is misc helper functions class. this class is implement define
33helpers. (accessors, proxys, ...)
34
35class splitting is maintainer issue only. please require/use Tiarra::Utils.
36
37all function is class method; please use package->method(...);
38
39maybe all functions can use with utils->...
40
41=head1 METHODS
42
43=over 4
44
45=cut
46
47=item define_function
48
49  utils->define_function($package, $code, @funcnames)
50
51define function with some package, code, funcnames.
52
53=over 4
54
55=item * $package
56
57package name. such as C<< utils->get_package($some_level) >>.
58
59=item * $code
60
61coderef(closure) of function. such as C<< sub { shift->foo_func('bar') } >>.
62
63=item * @funcnames
64
65function names to define.
66
67=back
68
69=cut
70
71sub define_function {
72    shift; #package
73    my $package = shift;
74    my $code = shift;
75    my $funcname;
76    no strict 'refs';
77    no warnings qw(redefine prototype);
78    foreach (@_) {
79	$funcname = $package.'::'.$_;
80	#undef *{$funcname};
81	*{$funcname} = $code;
82    }
83    undef;
84}
85
86sub _parse_attr_define {
87    shift; # drop
88    shift; # drop
89    my $value = shift;
90
91    if (ref($value) eq 'ARRAY') {
92	$value;
93    } else {
94	[$value, $value];
95    }
96}
97
98sub _define_attr_common {
99    my $pkg = shift;
100    my $type = shift;
101    my $class_method_p = shift;
102    my $call_pkg = $pkg->get_package(1);
103    foreach (@_) {
104	my ($funcname, $valname) = @{$pkg->_parse_attr_define($call_pkg, $_)};
105	$pkg->define_function(
106	    $call_pkg,
107	    $pkg->_generate_attr_closure($class_method_p, $type,
108					 "{$valname}", $funcname),
109	    $funcname);
110    }
111    undef;
112}
113
114=item define_attr_accessor
115
116  utils->define_attr_accessor($class_method_p, @defines)
117
118define attribute accessor.
119
120=over 4
121
122=item * $class_method_p
123
124these accessor is called as class method, pass true; otherwise false.
125
126=item * @defines
127
128accessor defines array.
129
130=over 4
131
132=item * scalar value ($valname)
133
134define ->$valname for accessor of ->{$valname}.
135
136=item * array ref value ([$funcname, $valname])
137
138define ->$funcname for accessor of ->{$valname}.
139
140=back
141
142=back
143
144=cut
145
146sub define_attr_accessor {
147    shift->_define_attr_common('accessor', @_);
148}
149
150=item define_attr_getter
151
152  utils->define_attr_getter($class_method_p, @defines)
153
154define attribute getter.
155
156all params is same as L</define_attr_accessor>, except s/accessor/getter/.
157
158=cut
159
160sub define_attr_getter {
161    shift->_define_attr_common('getter', @_);
162}
163
164sub _define_attr_hook_common {
165    my $pkg = shift;
166    my $type = shift;
167    my $class_method_p = shift;
168    my $hook = shift;
169    my $call_pkg = $pkg->get_package(1);
170    foreach (@_) {
171	my ($funcname, $valname) = @{$pkg->_parse_attr_define($call_pkg, $_)};
172	$pkg->define_function(
173	    $call_pkg,
174	    $pkg->_generate_attr_hooked_closure($class_method_p, $type,
175						"{$valname}", $hook, $funcname),
176	    $funcname);
177    }
178    undef;
179}
180
181sub _define_attr_translate_accessor {
182    shift->_define_attr_hook_common('translate', @_);
183}
184
185sub _define_attr_notify_accessor {
186    shift->_define_attr_hook_common('notify', @_);
187}
188
189sub _parse_array_attr_define {
190    shift; # drop
191    my $call_pkg = shift;
192
193    my $value = shift;
194    if (ref($value) eq 'ARRAY') {
195	$value;
196    } else {
197	my $funcname = $value;
198	my $index = uc($funcname);
199	$index = $call_pkg->$index;
200	[$funcname, $index];
201    }
202}
203
204sub _define_array_attr_common {
205    my $pkg = shift;
206    my $type = shift;
207    my $class_method_p = shift;
208    my $call_pkg = $pkg->get_package(1);
209    foreach (@_) {
210	my ($funcname, $index) =
211	    @{$pkg->_parse_array_attr_define($call_pkg, $_)};
212	$pkg->define_function(
213	    $call_pkg,
214	    $pkg->_generate_attr_closure($class_method_p, $type,
215					 "[$index]", $funcname),
216	    $funcname);
217    }
218    undef;
219}
220
221=item define_array_attr_accessor
222
223  utils->define_attr_accessor($class_method_p, @defines)
224
225define attribute accessor for array type object.
226
227=over 4
228
229=item * $class_method_p
230
231these accessor is called as class method, pass true; otherwise false.
232
233=item * @defines
234
235accessor defines array.
236
237=over 4
238
239=item * scalar value (value)
240
241define ->value for accessor of ->[VALUE].
242
243example: ->define_attr
244
245=item * array ref value ([$funcname, $valname])
246
247define ->$funcname for accessor of ->{$valname}.
248
249=back
250
251=back
252
253=cut
254
255sub define_array_attr_accessor {
256    shift->_define_array_attr_common('accessor', @_);
257}
258
259sub define_array_attr_getter {
260    shift->_define_array_attr_common('getter', @_);
261}
262
263sub _define_array_attr_hook_common {
264    my $pkg = shift;
265    my $type = shift;
266    my $class_method_p = shift;
267    my $hook = shift;
268    my $call_pkg = $pkg->get_package(1);
269    foreach (@_) {
270	my ($funcname, $index) =
271	    @{$pkg->_parse_array_attr_define($call_pkg, $_)};
272	$pkg->define_function(
273	    $call_pkg,
274	    $pkg->_generate_attr_hooked_closure($class_method_p, $type,
275						"[$index]", $hook, $funcname),
276	    $funcname);
277    }
278    undef;
279}
280
281sub define_array_attr_translate_accessor {
282    shift->_define_array_attr_hook_common('translate', @_);
283}
284
285sub define_array_attr_notify_accessor {
286    shift->_define_array_attr_hook_common('notify', @_);
287}
288
289sub define_attr_enum_accessor {
290    my $pkg = shift;
291    my $attr_name = shift;
292    my $match_type = shift || 'eq';
293    foreach (@_) {
294	my ($funcname, $value);
295	if (ref($_) eq 'ARRAY') {
296	    $funcname = $_->[0];
297	    $value = $_->[1];
298	} else {
299	    $funcname = $attr_name . '_' . $_;
300	    $value = $_;
301	}
302	$pkg->define_function(
303	    $pkg->get_package,
304	    eval '(sub {
305		 my $this = shift;
306		 $this->$attr_name($value) if defined shift;
307		 $this->$attr_name '.$match_type.' $value;
308	     })',
309	    $funcname);
310    }
311}
312
313sub define_proxy {
314    my $pkg = shift;
315    my $proxy_target_funcname = shift;
316    my $class_method_p = shift;
317    foreach (@_) {
318	my ($funcname, $proxyname);
319	if (ref($_) eq 'ARRAY') {
320	    $funcname = $_->[0];
321	    $proxyname = $_->[1];
322	} else {
323	    $funcname = $proxyname = $_;
324	}
325	$pkg->define_function(
326	    $pkg->get_package,
327	    ($class_method_p ? sub {
328		 shift->_this->$proxy_target_funcname->$proxyname(@_);
329	     } : sub {
330		 shift->$proxy_target_funcname->$proxyname(@_);
331	     }),
332	    $funcname);
333    }
334}
335
336sub define_enum {
337    # this function is deprecated.
338    # please use enum.pm instead.
339    my $pkg = shift;
340    my $i = 0;
341    foreach (@_) {
342	my (@funcnames);
343	if (ref($_) eq 'ARRAY') {
344	    @funcnames = @$_;
345	} else {
346	    @funcnames = $_;
347	}
348	my $j = $i;
349	$pkg->define_function(
350	    $pkg->get_package,
351	    sub () { $j; },
352	    @funcnames);
353	++$i;
354    }
355}
356
357sub get_package {
358    my $pkg = shift;
359    my $caller_level = shift || 0;
360    ($pkg->get_caller($caller_level + 1))[0];
361}
362
363sub get_caller {
364    my $pkg = shift;
365    my $caller_level = shift || 0;
366    caller($caller_level + 1 + $ExportLevel);
367}
368
369sub do_with_define_exportlevel {
370    my $pkg = shift;
371    my $level = shift || 0;
372
373    local $ExportLevel;
374    $ExportLevel += 3 + $level;
375    shift->(@_);
376}
377
378
379# generator
380sub _generate_attr_closure {
381    my $pkg = shift;
382    my $class_method_p = shift;
383    my $type = shift;
384    my $attr = shift;
385    my $funcname = shift;
386    # outside parentheses for context
387    my $str = join('',
388		   "\n# line 1 \"",
389		   (defined $funcname ? "->$funcname\: " : ''),
390		   "attr $type\"\n",
391		   '(sub',
392		   ({
393		       accessor => ' : lvalue',
394		       getter   => '',
395		   }->{$type}),
396		   ' {',
397		   ' die "too many args: @_" if $#_ >= ',
398		   ({
399		       accessor => '2',
400		       getter   => '1',
401		   }->{$type}),
402		   ';',
403		   ({
404		       accessor => ' my $this = shift',
405		       getter   => ' shift',
406		   }->{$type}),
407		   ($class_method_p ? '->_this' : ''),
408		   ({
409		       accessor => "; \$this->$attr = shift if \$#_ >= 0; \$this",
410		       getter   => '',
411		   }->{$type}),
412		   "->$attr;",
413		   ' })');
414    no strict 'refs';
415    no warnings;
416    eval $str ||
417	(print STDERR __PACKAGE__."/generator error: \n$str\n$@", undef);
418}
419
420sub _generate_attr_hooked_closure {
421    my $pkg = shift;
422    my $class_method_p = shift;
423    my $type = shift;
424    my $attr = shift;
425    my $update_hook = shift;
426    my $funcname = shift;
427    # outside parentheses for context
428    my $str = join('',
429		   "\n# line 1 \"",
430		   (defined $funcname ? "->$funcname\: " : ''),
431		   "attr $type\"\n",
432		   '(sub {',
433		   ' die "too many args: @_" if $#_ >= 2;',
434		   ' my $this = shift',
435		   ($class_method_p ? '->_this' : ''),
436		   ';',
437		   ' if ($#_ >=0) {',
438		   (sub {
439			if ($type eq 'translate') {
440			    '  '.$update_hook->('shift', "\$this->$attr");
441			} elsif ($type eq 'notify') {
442			    "  \$this->$attr = shift; $update_hook;";
443			}
444		    }->($type)),
445		   ' }',
446		   " \$this->$attr;",
447		   ' })');
448    no strict 'refs';
449    no warnings;
450    eval $str ||
451	(print STDERR __PACKAGE__."/generator error: \n$str\n$@", undef);
452}
453
4541;
455
456__END__
457=back
458
459=head1 SEE ALSO
460
461L<Tiarra::Utils>
462
463=head1 AUTHOR
464
465Topia E<lt>topia@clovery.jpE<gt>
466
467=head1 COPYRIGHT AND LICENSE
468
469Copyright (C) 2005 by Topia.
470
471This library is free software; you can redistribute it and/or modify
472it under the same terms as Perl itself, either Perl version 5.8.6 or,
473at your option, any later version of Perl 5 you may have available.
474
475=cut
476