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