1use 5.008; 2use strict; 3use warnings; 4 5package Class::Accessor::Complex; 6our $VERSION = '1.100880'; 7 8# ABSTRACT: Arrays, hashes, booleans, integers, sets and more 9use Carp qw(carp croak cluck); 10use Data::Miscellany 'flatten'; 11use List::MoreUtils 'uniq'; 12use parent qw(Class::Accessor Class::Accessor::Installer); 13 14sub mk_new { 15 my ($self, @args) = @_; 16 my $class = ref $self || $self; 17 @args = ('new') unless @args; 18 for my $name (@args) { 19 $self->install_accessor( 20 name => $name, 21 code => sub { 22 local $DB::sub = local *__ANON__ = "${class}::${name}" 23 if defined &DB::DB && !$Devel::DProf::VERSION; 24 25 # don't use $class, as that's already defined above 26 my $this_class = shift; 27 my $self = ref($this_class) ? $this_class : bless {}, 28 $this_class; 29 my %args = 30 (scalar(@_ == 1) && ref($_[0]) eq 'HASH') 31 ? %{ $_[0] } 32 : @_; 33 $self->$_($args{$_}) for keys %args; 34 $self->init(%args) if $self->can('init'); 35 $self; 36 }, 37 ); 38 $self->document_accessor( 39 name => $name, 40 purpose => <<'EODOC', 41Creates and returns a new object. The constructor will accept as arguments a 42list of pairs, from component name to initial value. For each pair, the named 43component is initialized by calling the method of the same name with the given 44value. If called with a single hash reference, it is dereferenced and its 45key/value pairs are set as described before. 46EODOC 47 examples => [ 48 "my \$obj = $class->$name;", 49 "my \$obj = $class->$name(\%args);", 50 ], 51 ); 52 } 53 $self; # for chaining 54} 55 56sub mk_singleton { 57 my ($self, @args) = @_; 58 my $class = ref $self || $self; 59 @args = ('new') unless @args; 60 my $singleton; 61 for my $name (@args) { 62 $self->install_accessor( 63 name => $name, 64 code => sub { 65 local $DB::sub = local *__ANON__ = "${class}::${name}" 66 if defined &DB::DB && !$Devel::DProf::VERSION; 67 return $singleton if defined $singleton; 68 69 # don't use $class, as that's already defined above 70 my $this_class = shift; 71 $singleton = 72 ref($this_class) 73 ? $this_class 74 : bless {}, $this_class; 75 my %args = 76 (scalar(@_ == 1) && ref($_[0]) eq 'HASH') 77 ? %{ $_[0] } 78 : @_; 79 $singleton->$_($args{$_}) for keys %args; 80 $singleton->init(%args) if $singleton->can('init'); 81 $singleton; 82 }, 83 ); 84 $self->document_accessor( 85 name => $name, 86 purpose => <<'EODOC', 87Creates and returns a new object. The object will be a singleton, so repeated 88calls to the constructor will always return the same object. The constructor 89will accept as arguments a list of pairs, from component name to initial 90value. For each pair, the named component is initialized by calling the 91method of the same name with the given value. If called with a single hash 92reference, it is dereferenced and its key/value pairs are set as described 93before. 94EODOC 95 examples => [ 96 "my \$obj = $class->$name;", 97 "my \$obj = $class->$name(\%args);", 98 ], 99 ); 100 } 101 $self; # for chaining 102} 103 104sub mk_scalar_accessors { 105 my ($self, @fields) = @_; 106 my $class = ref $self || $self; 107 for my $field (@fields) { 108 $self->install_accessor( 109 name => $field, 110 code => sub { 111 local $DB::sub = local *__ANON__ = "${class}::${field}" 112 if defined &DB::DB && !$Devel::DProf::VERSION; 113 return $_[0]->{$field} if @_ == 1; 114 $_[0]->{$field} = $_[1]; 115 }, 116 ); 117 $self->document_accessor( 118 name => $field, 119 purpose => <<'EODOC', 120A basic getter/setter method. If called without an argument, it returns the 121value. If called with a single argument, it sets the value. 122EODOC 123 examples => 124 [ "my \$value = \$obj->$field;", "\$obj->$field(\$value);", ], 125 ); 126 my @clear_methods = uniq "clear_${field}", "${field}_clear"; 127 for my $name (@clear_methods) { 128 $self->install_accessor( 129 name => $name, 130 code => sub { 131 local $DB::sub = local *__ANON__ = "${class}::${name}" 132 if defined &DB::DB && !$Devel::DProf::VERSION; 133 $_[0]->{$field} = undef; 134 }, 135 ); 136 } 137 $self->document_accessor( 138 name => \@clear_methods, 139 purpose => 'Clears the value.', 140 examples => ["\$obj->$clear_methods[0];"], 141 belongs_to => $field, 142 ); 143 } 144 $self; # for chaining 145} 146 147sub mk_class_scalar_accessors { 148 my ($self, @fields) = @_; 149 my $class = ref $self || $self; 150 for my $field (@fields) { 151 my $scalar; 152 $self->install_accessor( 153 name => $field, 154 code => sub { 155 local $DB::sub = local *__ANON__ = "${class}::${field}" 156 if defined &DB::DB && !$Devel::DProf::VERSION; 157 return $scalar if @_ == 1; 158 $scalar = $_[1]; 159 }, 160 ); 161 $self->document_accessor( 162 name => $field, 163 purpose => <<'EODOC', 164A basic getter/setter method. This is a class variable, so it is shared 165between all instances of this class. Changing it in one object will change it 166for all other objects as well. If called without an argument, it returns the 167value. If called with a single argument, it sets the value. 168EODOC 169 examples => 170 [ "my \$value = \$obj->$field;", "\$obj->$field(\$value);", ], 171 ); 172 my @clear_methods = uniq "clear_${field}", "${field}_clear"; 173 for my $name (@clear_methods) { 174 $self->install_accessor( 175 name => $name, 176 code => sub { 177 local $DB::sub = local *__ANON__ = "${class}::${name}" 178 if defined &DB::DB && !$Devel::DProf::VERSION; 179 $scalar = undef; 180 }, 181 ); 182 } 183 $self->document_accessor( 184 name => \@clear_methods, 185 purpose => <<'EODOC', 186Clears the value. Since this is a class variable, the value will be undefined 187for all instances of this class. 188EODOC 189 example => "\$obj->$clear_methods[0];", 190 belongs_to => $field, 191 ); 192 } 193 $self; # for chaining 194} 195 196sub mk_concat_accessors { 197 my ($self, @args) = @_; 198 my $class = ref $self || $self; 199 for my $arg (@args) { 200 201 # defaults 202 my $field = $arg; 203 my $join = ''; 204 if (ref $arg eq 'ARRAY') { 205 ($field, $join) = @$arg; 206 } 207 $self->install_accessor( 208 name => $field, 209 code => sub { 210 local $DB::sub = local *__ANON__ = "${class}::${field}" 211 if defined &DB::DB && !$Devel::DProf::VERSION; 212 my ($self, $text) = @_; 213 if (defined $text) { 214 if (defined $self->{$field}) { 215 $self->{$field} = $self->{$field} . $join . $text; 216 } else { 217 $self->{$field} = $text; 218 } 219 } 220 return $self->{$field}; 221 }, 222 ); 223 $self->document_accessor( 224 name => $field, 225 226 # FIXME use the current value of $join in the docs 227 purpose => <<'EODOC', 228A getter/setter method. If called without an argument, it returns the 229value. If called with a single argument, it appends to the current value. 230EODOC 231 examples => 232 [ "my \$value = \$obj->$field;", "\$obj->$field(\$value);", ], 233 ); 234 my @clear_methods = uniq "clear_${field}", "${field}_clear"; 235 for my $name (@clear_methods) { 236 $self->install_accessor( 237 name => $name, 238 code => sub { 239 local $DB::sub = local *__ANON__ = "${class}::${name}" 240 if defined &DB::DB && !$Devel::DProf::VERSION; 241 $_[0]->{$field} = undef; 242 }, 243 ); 244 } 245 $self->document_accessor( 246 name => \@clear_methods, 247 purpose => <<'EODOC', 248Clears the value. 249EODOC 250 example => "\$obj->$clear_methods[0];", 251 belongs_to => $field, 252 ); 253 } 254 $self; # for chaining 255} 256 257sub mk_array_accessors { 258 my ($self, @fields) = @_; 259 my $class = ref $self || $self; 260 for my $field (@fields) { 261 $self->install_accessor( 262 name => $field, 263 code => sub { 264 local $DB::sub = local *__ANON__ = "${class}::${field}" 265 if defined &DB::DB && !$Devel::DProf::VERSION; 266 my ($self, @list) = @_; 267 defined $self->{$field} or $self->{$field} = []; 268 @{ $self->{$field} } = 269 map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @list 270 if @list; 271 wantarray ? @{ $self->{$field} } : $self->{$field}; 272 }, 273 ); 274 $self->document_accessor( 275 name => $field, 276 purpose => <<'EODOC', 277Get or set the array values. If called without arguments, it returns the 278array in list context, or a reference to the array in scalar context. If 279called with arguments, it expands array references found therein and sets the 280values. 281EODOC 282 examples => [ 283 "my \@values = \$obj->$field;", 284 "my \$array_ref = \$obj->$field;", 285 "\$obj->$field(\@values);", 286 "\$obj->$field(\$array_ref);", 287 ], 288 ); 289 my @push_methods = uniq "push_${field}", "${field}_push"; 290 for my $name (@push_methods) { 291 $self->install_accessor( 292 name => $name, 293 code => sub { 294 local $DB::sub = local *__ANON__ = "${class}::${name}" 295 if defined &DB::DB && !$Devel::DProf::VERSION; 296 my $self = shift; 297 push @{ $self->{$field} } => @_; 298 }, 299 ); 300 } 301 $self->document_accessor( 302 name => \@push_methods, 303 belongs_to => $field, 304 purpose => 'Pushes elements onto the end of the array.', 305 examples => ["\$obj->$push_methods[0](\@values);"], 306 ); 307 my @pop_methods = uniq "pop_${field}", "${field}_pop"; 308 for my $name (@pop_methods) { 309 $self->install_accessor( 310 name => $name, 311 code => sub { 312 local $DB::sub = local *__ANON__ = "${class}::${name}" 313 if defined &DB::DB && !$Devel::DProf::VERSION; 314 pop @{ $_[0]->{$field} }; 315 }, 316 ); 317 } 318 $self->document_accessor( 319 name => \@pop_methods, 320 purpose => <<'EODOC', 321Pops the last element off the array, returning it. 322EODOC 323 examples => ["my \$value = \$obj->$pop_methods[0];"], 324 belongs_to => $field, 325 ); 326 my @unshift_methods = uniq "unshift_${field}", "${field}_unshift"; 327 for my $name (@unshift_methods) { 328 $self->install_accessor( 329 name => $name, 330 code => sub { 331 local $DB::sub = local *__ANON__ = "${class}::${name}" 332 if defined &DB::DB && !$Devel::DProf::VERSION; 333 my $self = shift; 334 unshift @{ $self->{$field} } => @_; 335 }, 336 ); 337 } 338 $self->document_accessor( 339 name => \@unshift_methods, 340 purpose => <<'EODOC', 341Unshifts elements onto the beginning of the array. 342EODOC 343 examples => ["\$obj->$unshift_methods[0](\@values);"], 344 belongs_to => $field, 345 ); 346 my @shift_methods = uniq "shift_${field}", "${field}_shift"; 347 for my $name (@shift_methods) { 348 $self->install_accessor( 349 name => $name, 350 code => sub { 351 local $DB::sub = local *__ANON__ = "${class}::${name}" 352 if defined &DB::DB && !$Devel::DProf::VERSION; 353 shift @{ $_[0]->{$field} }; 354 }, 355 ); 356 } 357 $self->document_accessor( 358 name => \@shift_methods, 359 purpose => <<'EODOC', 360Shifts the first element off the array, returning it. 361EODOC 362 examples => ["my \$value = \$obj->$shift_methods[0];"], 363 belongs_to => $field, 364 ); 365 my @clear_methods = uniq "clear_${field}", "${field}_clear"; 366 for my $name (@clear_methods) { 367 $self->install_accessor( 368 name => $name, 369 code => sub { 370 local $DB::sub = local *__ANON__ = "${class}::${name}" 371 if defined &DB::DB && !$Devel::DProf::VERSION; 372 $_[0]->{$field} = []; 373 }, 374 ); 375 } 376 $self->document_accessor( 377 name => \@clear_methods, 378 purpose => <<'EODOC', 379Deletes all elements from the array. 380EODOC 381 examples => ["\$obj->$clear_methods[0];"], 382 belongs_to => $field, 383 ); 384 my @count_methods = uniq "count_${field}", "${field}_count"; 385 for my $name (@count_methods) { 386 $self->install_accessor( 387 name => $name, 388 code => sub { 389 local $DB::sub = local *__ANON__ = "${class}::${name}" 390 if defined &DB::DB && !$Devel::DProf::VERSION; 391 exists $_[0]->{$field} ? scalar @{ $_[0]->{$field} } : 0; 392 }, 393 ); 394 } 395 $self->document_accessor( 396 name => \@count_methods, 397 purpose => <<'EODOC', 398Returns the number of elements in the array. 399EODOC 400 examples => ["my \$count = \$obj->$count_methods[0];"], 401 belongs_to => $field, 402 ); 403 my @splice_methods = uniq "splice_${field}", "${field}_splice"; 404 for my $name (@splice_methods) { 405 $self->install_accessor( 406 name => $name, 407 code => sub { 408 local $DB::sub = local *__ANON__ = "${class}::${name}" 409 if defined &DB::DB && !$Devel::DProf::VERSION; 410 my ($self, $offset, $len, @list) = @_; 411 splice(@{ $self->{$field} }, $offset, $len, @list); 412 }, 413 ); 414 } 415 $self->document_accessor( 416 name => \@splice_methods, 417 purpose => <<'EODOC', 418Takes three arguments: An offset, a length and a list. 419 420Removes the elements designated by the offset and the length from the array, 421and replaces them with the elements of the list, if any. In list context, 422returns the elements removed from the array. In scalar context, returns the 423last element removed, or C<undef> if no elements are removed. The array grows 424or shrinks as necessary. If the offset is negative then it starts that far 425from the end of the array. If the length is omitted, removes everything from 426the offset onward. If the length is negative, removes the elements from the 427offset onward except for -length elements at the end of the array. If both the 428offset and the length are omitted, removes everything. If the offset is past 429the end of the array, it issues a warning, and splices at the end of the 430array. 431EODOC 432 examples => [ 433 "\$obj->$splice_methods[0](2, 1, \$x, \$y);", 434 "\$obj->$splice_methods[0](-1);", 435 "\$obj->$splice_methods[0](0, -1);", 436 ], 437 belongs_to => $field, 438 ); 439 my @index_methods = uniq "index_${field}", "${field}_index"; 440 for my $name (@index_methods) { 441 $self->install_accessor( 442 name => $name, 443 code => sub { 444 local $DB::sub = local *__ANON__ = "${class}::${name}" 445 if defined &DB::DB && !$Devel::DProf::VERSION; 446 my ($self, @indices) = @_; 447 my @result = map { $self->{$field}[$_] } @indices; 448 return $result[0] if @indices == 1; 449 wantarray ? @result : \@result; 450 }, 451 ); 452 } 453 $self->document_accessor( 454 name => \@index_methods, 455 purpose => <<'EODOC', 456Takes a list of indices and returns the elements indicated by those indices. 457If only one index is given, the corresponding array element is returned. If 458several indices are given, the result is returned as an array in list context 459or as an array reference in scalar context. 460EODOC 461 examples => [ 462 "my \$element = \$obj->$index_methods[0](3);", 463 "my \@elements = \$obj->$index_methods[0](\@indices);", 464 "my \$array_ref = \$obj->$index_methods[0](\@indices);", 465 ], 466 belongs_to => $field, 467 ); 468 my @set_methods = uniq "set_${field}", "${field}_set"; 469 for my $name (@set_methods) { 470 $self->install_accessor( 471 name => $name, 472 code => sub { 473 local $DB::sub = local *__ANON__ = "${class}::${$name}" 474 if defined &DB::DB && !$Devel::DProf::VERSION; 475 my $self = shift; 476 my @args = @_; 477 croak 478"${class}::${field}_set expects an even number of fields\n" 479 if @args % 2; 480 while (my ($index, $value) = splice @args, 0, 2) { 481 $self->{$field}->[$index] = $value; 482 } 483 return @_ / 2; 484 }, 485 ); 486 } 487 $self->document_accessor( 488 name => \@set_methods, 489 purpose => <<'EODOC', 490Takes a list of index/value pairs and for each pair it sets the array element 491at the indicated index to the indicated value. Returns the number of elements 492that have been set. 493EODOC 494 examples => ["\$obj->$set_methods[0](1 => \$x, 5 => \$y);"], 495 belongs_to => $field, 496 ); 497 } 498 $self; # for chaining 499} 500 501sub mk_class_array_accessors { 502 my ($self, @fields) = @_; 503 my $class = ref $self || $self; 504 for my $field (@fields) { 505 my @array; 506 $self->install_accessor( 507 name => $field, 508 code => sub { 509 local $DB::sub = local *__ANON__ = "${class}::${field}" 510 if defined &DB::DB && !$Devel::DProf::VERSION; 511 my ($self, @list) = @_; 512 @array = map { ref $_ eq 'ARRAY' ? @$_ : ($_) } @list 513 if @list; 514 wantarray ? @array : \@array; 515 }, 516 ); 517 $self->document_accessor( 518 name => $field, 519 purpose => <<'EODOC', 520Get or set the array values. If called without an arguments, it returns the 521array in list context, or a reference to the array in scalar context. If 522called with arguments, it expands array references found therein and sets the 523values. 524 525This is a class variable, so it is shared between all instances of this class. 526Changing it in one object will change it for all other objects as well. 527EODOC 528 examples => [ 529 "my \@values = \$obj->$field;", 530 "my \$array_ref = \$obj->$field;", 531 "\$obj->$field(\@values);", 532 "\$obj->$field(\$array_ref);", 533 ], 534 ); 535 my @push_methods = uniq "push_${field}", "${field}_push"; 536 for my $name (@push_methods) { 537 $self->install_accessor( 538 name => $name, 539 code => sub { 540 local $DB::sub = local *__ANON__ = "${class}::${name}" 541 if defined &DB::DB && !$Devel::DProf::VERSION; 542 my $self = shift; 543 push @array => @_; 544 }, 545 ); 546 } 547 $self->document_accessor( 548 name => \@push_methods, 549 purpose => <<'EODOC', 550Pushes elements onto the end of the array. Since this is a class variable, the 551value will be changed for all instances of this class. 552EODOC 553 examples => ["\$obj->$push_methods[0](\@values);"], 554 belongs_to => $field, 555 ); 556 my @pop_methods = uniq "pop_${field}", "${field}_pop"; 557 for my $name (@pop_methods) { 558 $self->install_accessor( 559 name => $name, 560 code => sub { 561 local $DB::sub = local *__ANON__ = "${class}::${name}" 562 if defined &DB::DB && !$Devel::DProf::VERSION; 563 pop @array; 564 }, 565 ); 566 } 567 $self->document_accessor( 568 name => \@pop_methods, 569 purpose => <<'EODOC', 570Pops the last element off the array, returning it. Since this is a class 571variable, the value will be changed for all instances of this class. 572EODOC 573 examples => ["my \$value = \$obj->$pop_methods[0];"], 574 belongs_to => $field, 575 ); 576 my @field_methods = uniq "unshift_${field}", "${field}_unshift"; 577 for my $name (@field_methods) { 578 $self->install_accessor( 579 name => $name, 580 code => sub { 581 local $DB::sub = local *__ANON__ = "${class}::${name}" 582 if defined &DB::DB && !$Devel::DProf::VERSION; 583 my $self = shift; 584 unshift @array => @_; 585 }, 586 ); 587 } 588 $self->document_accessor( 589 name => \@field_methods, 590 purpose => <<'EODOC', 591Unshifts elements onto the beginning of the array. Since this is a class 592variable, the value will be changed for all instances of this class. 593EODOC 594 examples => ["\$obj->$field_methods[0](\@values);"], 595 belongs_to => $field, 596 ); 597 my @shift_methods = uniq "shift_${field}", "${field}_shift"; 598 for my $name (@shift_methods) { 599 $self->install_accessor( 600 name => $name, 601 code => sub { 602 local $DB::sub = local *__ANON__ = "${class}::${name}" 603 if defined &DB::DB && !$Devel::DProf::VERSION; 604 shift @array; 605 }, 606 ); 607 } 608 $self->document_accessor( 609 name => \@shift_methods, 610 purpose => <<'EODOC', 611Shifts the first element off the array, returning it. Since this is a class 612variable, the value will be changed for all instances of this class. 613EODOC 614 examples => ["my \$value = \$obj->$shift_methods[0];"], 615 belongs_to => $field, 616 ); 617 my @clear_methods = uniq "clear_${field}", "${field}_clear"; 618 for my $name (@clear_methods) { 619 $self->install_accessor( 620 name => $name, 621 code => sub { 622 local $DB::sub = local *__ANON__ = "${class}::${name}" 623 if defined &DB::DB && !$Devel::DProf::VERSION; 624 @array = (); 625 }, 626 ); 627 } 628 $self->document_accessor( 629 name => \@clear_methods, 630 purpose => <<'EODOC', 631Deletes all elements from the array. Since this is a class variable, the value 632will be changed for all instances of this class. 633EODOC 634 examples => ["\$obj->$clear_methods[0];"], 635 belongs_to => $field, 636 ); 637 my @count_methods = uniq "count_${field}", "${field}_count"; 638 for my $name (@count_methods) { 639 $self->install_accessor( 640 name => $name, 641 code => sub { 642 local $DB::sub = local *__ANON__ = "${class}::${name}" 643 if defined &DB::DB && !$Devel::DProf::VERSION; 644 scalar @array; 645 }, 646 ); 647 } 648 $self->document_accessor( 649 name => \@count_methods, 650 purpose => <<'EODOC', 651Returns the number of elements in the array. Since this is a class variable, 652the value will be changed for all instances of this class. 653EODOC 654 examples => ["my \$count = \$obj->$count_methods[0];"], 655 belongs_to => $field, 656 ); 657 my @splice_methods = uniq "splice_${field}", "${field}_splice"; 658 for my $name (@splice_methods) { 659 $self->install_accessor( 660 name => $name, 661 code => sub { 662 local $DB::sub = local *__ANON__ = "${class}::${name}" 663 if defined &DB::DB && !$Devel::DProf::VERSION; 664 my ($self, $offset, $len, @list) = @_; 665 splice(@array, $offset, $len, @list); 666 }, 667 ); 668 } 669 $self->document_accessor( 670 name => \@splice_methods, 671 purpose => <<'EODOC', 672Takes three arguments: An offset, a length and a list. 673 674Removes the elements designated by the offset and the length from the array, 675and replaces them with the elements of the list, if any. In list context, 676returns the elements removed from the array. In scalar context, returns the 677last element removed, or C<undef> if no elements are removed. The array grows 678or shrinks as necessary. If the offset is negative then it starts that far 679from the end of the array. If the length is omitted, removes everything from 680the offset onward. If the length is negative, removes the elements from the 681offset onward except for -length elements at the end of the array. If both the 682offset and the length are omitted, removes everything. If the offset is past 683the end of the array, it issues a warning, and splices at the end of the 684array. 685 686Since this is a class variable, the value will be changed for all instances of 687this class. 688EODOC 689 examples => [ 690 "\$obj->$splice_methods[0](2, 1, \$x, \$y);", 691 "\$obj->$splice_methods[0](-1);", 692 "\$obj->$splice_methods[0](0, -1);", 693 ], 694 belongs_to => $field, 695 ); 696 my @index_methods = uniq "index_${field}", "${field}_index"; 697 for my $name (@index_methods) { 698 $self->install_accessor( 699 name => $name, 700 code => sub { 701 local $DB::sub = local *__ANON__ = "${class}::${name}" 702 if defined &DB::DB && !$Devel::DProf::VERSION; 703 my ($self, @indices) = @_; 704 my @result = map { $array[$_] } @indices; 705 return $result[0] if @indices == 1; 706 wantarray ? @result : \@result; 707 }, 708 ); 709 } 710 $self->document_accessor( 711 name => \@index_methods, 712 purpose => <<'EODOC', 713Takes a list of indices and returns the elements indicated by those indices. 714If only one index is given, the corresponding array element is returned. If 715several indices are given, the result is returned as an array in list context 716or as an array reference in scalar context. 717 718Since this is a class variable, the value will be changed for all instances of 719this class. 720EODOC 721 examples => [ 722 "my \$element = \$obj->$index_methods[0](3);", 723 "my \@elements = \$obj->$index_methods[0](\@indices);", 724 "my \$array_ref = \$obj->$index_methods[0](\@indices);", 725 ], 726 belongs_to => $field, 727 ); 728 my @set_methods = uniq "set_${field}", "${field}_set"; 729 for my $name (@set_methods) { 730 $self->install_accessor( 731 name => $name, 732 code => sub { 733 local $DB::sub = local *__ANON__ = "${class}::${name}" 734 if defined &DB::DB && !$Devel::DProf::VERSION; 735 my $self = shift; 736 my @args = @_; 737 croak 738"${class}::${field}_set expects an even number of fields\n" 739 if @args % 2; 740 while (my ($index, $value) = splice @args, 0, 2) { 741 $array[$index] = $value; 742 } 743 return @_ / 2; 744 }, 745 ); 746 } 747 $self->document_accessor( 748 name => \@set_methods, 749 purpose => <<'EODOC', 750Takes a list of index/value pairs and for each pair it sets the array element 751at the indicated index to the indicated value. Returns the number of elements 752that have been set. Since this is a class variable, the value will be changed 753for all instances of this class. 754EODOC 755 examples => ["\$obj->$set_methods[0](1 => \$x, 5 => \$y);"], 756 belongs_to => $field, 757 ); 758 } 759 $self; # for chaining 760} 761 762sub mk_hash_accessors { 763 my ($self, @fields) = @_; 764 my $class = ref $self || $self; 765 for my $field (@fields) { 766 $self->install_accessor( 767 name => $field, 768 code => sub { 769 local $DB::sub = local *__ANON__ = "${class}::${field}" 770 if defined &DB::DB && !$Devel::DProf::VERSION; 771 my ($self, @list) = @_; 772 defined $self->{$field} or $self->{$field} = {}; 773 if (scalar @list == 1) { 774 my ($key) = @list; 775 if (my $type = ref $key) { 776 if ($type eq 'ARRAY') { 777 return @{ $self->{$field} }{@$key}; 778 } elsif ($type eq 'HASH') { 779 while (my ($subkey, $value) = each %$key) { 780 $self->{$field}{$subkey} = $value; 781 } 782 return wantarray 783 ? %{ $self->{$field} } 784 : $self->{$field}; 785 } else { 786 cluck 787 "Unrecognized ref type for hash method: $type."; 788 } 789 } else { 790 return $self->{$field}{$key}; 791 } 792 } else { 793 while (1) { 794 my $key = shift @list; 795 defined $key or last; 796 my $value = shift @list; 797 defined $value or carp "No value for key $key."; 798 $self->{$field}{$key} = $value; 799 } 800 return wantarray ? %{ $self->{$field} } : $self->{$field}; 801 } 802 }, 803 ); 804 $self->document_accessor( 805 name => $field, 806 purpose => <<'EODOC', 807Get or set the hash values. If called without arguments, it returns the hash 808in list context, or a reference to the hash in scalar context. If called 809with a list of key/value pairs, it sets each key to its corresponding value, 810then returns the hash as described before. 811 812If called with exactly one key, it returns the corresponding value. 813 814If called with exactly one array reference, it returns an array whose elements 815are the values corresponding to the keys in the argument array, in the same 816order. The resulting list is returned as an array in list context, or a 817reference to the array in scalar context. 818 819If called with exactly one hash reference, it updates the hash with the given 820key/value pairs, then returns the hash in list context, or a reference to the 821hash in scalar context. 822EODOC 823 examples => [ 824 "my \%hash = \$obj->$field;", 825 "my \$hash_ref = \$obj->$field;", 826 "my \$value = \$obj->$field(\$key);", 827 "my \@values = \$obj->$field([ qw(foo bar) ]);", 828 "\$obj->$field(\%other_hash);", 829 "\$obj->$field(foo => 23, bar => 42);", 830 ], 831 ); 832 my @clear_methods = uniq "clear_${field}", "${field}_clear"; 833 for my $name (@clear_methods) { 834 $self->install_accessor( 835 name => $name, 836 code => sub { 837 local $DB::sub = local *__ANON__ = "${class}::${name}" 838 if defined &DB::DB && !$Devel::DProf::VERSION; 839 my $self = shift; 840 $self->{$field} = {}; 841 }, 842 ); 843 } 844 $self->document_accessor( 845 name => \@clear_methods, 846 purpose => <<'EODOC', 847Deletes all keys and values from the hash. 848EODOC 849 examples => ["\$obj->$clear_methods[0];"], 850 belongs_to => $field, 851 ); 852 my @keys_methods = uniq "keys_${field}", "${field}_keys"; 853 for my $name (@keys_methods) { 854 $self->install_accessor( 855 name => $name, 856 code => sub { 857 local $DB::sub = local *__ANON__ = "${class}::${name}" 858 if defined &DB::DB && !$Devel::DProf::VERSION; 859 keys %{ $_[0]->{$field} }; 860 }, 861 ); 862 } 863 $self->document_accessor( 864 name => \@keys_methods, 865 purpose => <<'EODOC', 866Returns a list of all hash keys in no particular order. 867EODOC 868 examples => ["my \@keys = \$obj->$keys_methods[0];"], 869 belongs_to => $field, 870 ); 871 my @count_methods = uniq "count_${field}", "${field}_count"; 872 for my $name (@count_methods) { 873 $self->install_accessor( 874 name => $name, 875 code => sub { 876 local $DB::sub = local *__ANON__ = "${class}::${name}" 877 if defined &DB::DB && !$Devel::DProf::VERSION; 878 scalar keys %{ $_[0]->{$field} }; 879 }, 880 ); 881 } 882 $self->document_accessor( 883 name => \@count_methods, 884 purpose => <<'EODOC', 885Returns the number of keys in the hash. 886EODOC 887 examples => ["my \$count = \$obj->$count_methods[0];"], 888 belongs_to => $field, 889 ); 890 my @values_methods = uniq "values_${field}", "${field}_values"; 891 for my $name (@values_methods) { 892 $self->install_accessor( 893 name => $name, 894 code => sub { 895 local $DB::sub = local *__ANON__ = "${class}::${name}" 896 if defined &DB::DB && !$Devel::DProf::VERSION; 897 values %{ $_[0]->{$field} }; 898 }, 899 ); 900 } 901 $self->document_accessor( 902 name => \@values_methods, 903 purpose => <<'EODOC', 904Returns a list of all hash values in no particular order. 905EODOC 906 examples => ["my \@values = \$obj->$values_methods[0];"], 907 belongs_to => $field, 908 ); 909 my @exists_methods = uniq "exists_${field}", "${field}_exists"; 910 for my $name (@exists_methods) { 911 $self->install_accessor( 912 name => $name, 913 code => sub { 914 local $DB::sub = local *__ANON__ = "${class}::${name}" 915 if defined &DB::DB && !$Devel::DProf::VERSION; 916 my ($self, $key) = @_; 917 exists $self->{$field} && exists $self->{$field}{$key}; 918 }, 919 ); 920 } 921 $self->document_accessor( 922 name => \@exists_methods, 923 purpose => <<'EODOC', 924Takes a key and returns a true value if the key exists in the hash, and a 925false value otherwise. 926EODOC 927 examples => ["if (\$obj->$exists_methods[0](\$key)) { ... }"], 928 belongs_to => $field, 929 ); 930 my @delete_methods = uniq "delete_${field}", "${field}_delete"; 931 for my $name (@delete_methods) { 932 $self->install_accessor( 933 name => $name, 934 code => sub { 935 local $DB::sub = local *__ANON__ = "${class}::${name}" 936 if defined &DB::DB && !$Devel::DProf::VERSION; 937 my ($self, @keys) = @_; 938 delete @{ $self->{$field} }{@keys}; 939 }, 940 ); 941 } 942 $self->document_accessor( 943 name => \@delete_methods, 944 purpose => 945 'Takes a list of keys and deletes those keys from the hash.', 946 examples => ["\$obj->$delete_methods[0](\@keys);"], 947 belongs_to => $field, 948 ); 949 } 950 $self; # for chaining 951} 952 953sub mk_class_hash_accessors { 954 my ($self, @fields) = @_; 955 my $class = ref $self || $self; 956 for my $field (@fields) { 957 my %hash; 958 $self->install_accessor( 959 name => $field, 960 code => sub { 961 local $DB::sub = local *__ANON__ = "${class}::${field}" 962 if defined &DB::DB && !$Devel::DProf::VERSION; 963 my ($self, @list) = @_; 964 if (scalar @list == 1) { 965 my ($key) = @list; 966 return $hash{$key} unless ref $key; 967 return @hash{@$key} if ref $key eq 'ARRAY'; 968 if (ref($key) eq 'HASH') { 969 %hash = (%hash, %$key); 970 return wantarray ? %hash : \%hash; 971 } 972 973 # not a scalar, array or hash... 974 cluck sprintf 975 'Not a recognized ref type for static hash [%s]', 976 ref($key); 977 } else { 978 while (1) { 979 my $key = shift @list; 980 defined $key or last; 981 my $value = shift @list; 982 defined $value or carp "No value for key $key."; 983 $hash{$key} = $value; 984 } 985 return wantarray ? %hash : \%hash; 986 } 987 }, 988 ); 989 $self->document_accessor( 990 name => $field, 991 purpose => <<'EODOC', 992Get or set the hash values. If called without arguments, it returns the hash 993in list context, or a reference to the hash in scalar context. If called 994with a list of key/value pairs, it sets each key to its corresponding value, 995then returns the hash as described before. 996 997If called with exactly one key, it returns the corresponding value. 998 999If called with exactly one array reference, it returns an array whose elements 1000are the values corresponding to the keys in the argument array, in the same 1001order. The resulting list is returned as an array in list context, or a 1002reference to the array in scalar context. 1003 1004If called with exactly one hash reference, it updates the hash with the given 1005key/value pairs, then returns the hash in list context, or a reference to the 1006hash in scalar context. 1007 1008This is a class variable, so it is shared between all instances of this class. 1009Changing it in one object will change it for all other objects as well. 1010EODOC 1011 examples => [ 1012 "my \%hash = \$obj->$field;", 1013 "my \$hash_ref = \$obj->$field;", 1014 "my \$value = \$obj->$field(\$key);", 1015 "my \@values = \$obj->$field([ qw(foo bar) ]);", 1016 "\$obj->$field(\%other_hash);", 1017 "\$obj->$field(foo => 23, bar => 42);", 1018 ], 1019 ); 1020 my @clear_methods = uniq "clear_${field}", "${field}_clear"; 1021 for my $name (@clear_methods) { 1022 $self->install_accessor( 1023 name => $name, 1024 code => sub { 1025 local $DB::sub = local *__ANON__ = "${class}::${name}" 1026 if defined &DB::DB && !$Devel::DProf::VERSION; 1027 %hash = (); 1028 }, 1029 ); 1030 } 1031 $self->document_accessor( 1032 name => \@clear_methods, 1033 purpose => <<'EODOC', 1034Deletes all keys and values from the hash. Since this is a class variable, the 1035value will be changed for all instances of this class. 1036EODOC 1037 examples => ["\$obj->$clear_methods[0];"], 1038 ); 1039 my @keys_methods = uniq "keys_${field}", "${field}_keys"; 1040 for my $name (@keys_methods) { 1041 $self->install_accessor( 1042 name => $name, 1043 code => sub { 1044 local $DB::sub = local *__ANON__ = "${class}::${name}" 1045 if defined &DB::DB && !$Devel::DProf::VERSION; 1046 keys %hash; 1047 }, 1048 ); 1049 } 1050 $self->document_accessor( 1051 name => \@keys_methods, 1052 purpose => <<'EODOC', 1053Returns a list of all hash keys in no particular order. Since this is a class 1054variable, the value will be changed for all instances of this class. 1055EODOC 1056 examples => ["my \@keys = \$obj->$keys_methods[0];"], 1057 belongs_to => $field, 1058 ); 1059 my @values_methods = uniq "values_${field}", "${field}_values"; 1060 for my $name (@values_methods) { 1061 $self->install_accessor( 1062 name => $name, 1063 code => sub { 1064 local $DB::sub = local *__ANON__ = "${class}::${name}" 1065 if defined &DB::DB && !$Devel::DProf::VERSION; 1066 values %hash; 1067 }, 1068 ); 1069 } 1070 $self->document_accessor( 1071 name => \@values_methods, 1072 purpose => <<'EODOC', 1073Returns a list of all hash values in no particular order. Since this is a 1074class variable, the value will be changed for all instances of this class. 1075EODOC 1076 examples => ["my \@values = \$obj->$values_methods[0];"], 1077 belongs_to => $field, 1078 ); 1079 my @exists_methods = uniq "exists_${field}", "${field}_exists"; 1080 for my $name (@exists_methods) { 1081 $self->install_accessor( 1082 name => $name, 1083 code => sub { 1084 local $DB::sub = local *__ANON__ = "${class}::${name}" 1085 if defined &DB::DB && !$Devel::DProf::VERSION; 1086 exists $hash{ $_[1] }; 1087 }, 1088 ); 1089 } 1090 $self->document_accessor( 1091 name => \@exists_methods, 1092 purpose => <<'EODOC', 1093Takes a key and returns a true value if the key exists in the hash, and a 1094false value otherwise. Since this is a class variable, the value will be 1095changed for all instances of this class. 1096EODOC 1097 examples => ["if (\$obj->$exists_methods[0](\$key)) { ... }"], 1098 belongs_to => $field, 1099 ); 1100 my @delete_methods = uniq "delete_${field}", "${field}_delete"; 1101 for my $name (@delete_methods) { 1102 $self->install_accessor( 1103 name => $name, 1104 code => sub { 1105 local $DB::sub = local *__ANON__ = "${class}::${name}" 1106 if defined &DB::DB && !$Devel::DProf::VERSION; 1107 my ($self, @keys) = @_; 1108 delete @hash{@keys}; 1109 }, 1110 ); 1111 } 1112 $self->document_accessor( 1113 name => \@delete_methods, 1114 purpose => <<'EODOC', 1115Takes a list of keys and deletes those keys from the hash. Since this is a 1116class variable, the value will be changed for all instances of this class. 1117EODOC 1118 examples => ["\$obj->$delete_methods[0](\@keys);"], 1119 belongs_to => $field, 1120 ); 1121 } 1122 $self; # for chaining 1123} 1124 1125sub mk_abstract_accessors { 1126 my ($self, @fields) = @_; 1127 my $class = ref $self || $self; 1128 for my $field (@fields) { 1129 $self->install_accessor( 1130 name => $field, 1131 code => sub { 1132 local $DB::sub = local *__ANON__ = "${class}::${field}" 1133 if defined &DB::DB && !$Devel::DProf::VERSION; 1134 my $method = "${class}::${field}"; 1135 eval "require Error::Hierarchy::Internal::AbstractMethod"; 1136 if ($@) { 1137 1138 # Error::Hierarchy not installed? 1139 die sprintf "called abstract method [%s]", $method; 1140 } else { 1141 1142 # need to pass method because caller() still doesn't see the 1143 # anonymously named sub's name 1144 throw Error::Hierarchy::Internal::AbstractMethod( 1145 method => $method,); 1146 } 1147 } 1148 ); 1149 } 1150 $self; # for chaining 1151} 1152 1153sub mk_boolean_accessors { 1154 my ($self, @fields) = @_; 1155 my $class = ref $self || $self; 1156 for my $field (@fields) { 1157 $self->install_accessor( 1158 name => $field, 1159 code => sub { 1160 local $DB::sub = local *__ANON__ = "${class}::${field}" 1161 if defined &DB::DB && !$Devel::DProf::VERSION; 1162 return $_[0]->{$field} if @_ == 1; 1163 $_[0]->{$field} = $_[1] ? 1 : 0; # normalize 1164 }, 1165 ); 1166 $self->document_accessor( 1167 name => $field, 1168 purpose => <<'EODOC', 1169If called without an argument, returns the boolean value (0 or 1). If called 1170with an argument, it normalizes it to the boolean value. That is, the values 11710, undef and the empty string become 0; everything else becomes 1. 1172EODOC 1173 examples => 1174 [ "\$obj->$field(\$value);", "my \$value = \$obj->$field;", ], 1175 ); 1176 my @set_methods = uniq "set_${field}", "${field}_set"; 1177 for my $name (@set_methods) { 1178 $self->install_accessor( 1179 name => $name, 1180 code => sub { 1181 local $DB::sub = local *__ANON__ = "${class}::${name}" 1182 if defined &DB::DB && !$Devel::DProf::VERSION; 1183 $_[0]->{$field} = 1; 1184 }, 1185 ); 1186 } 1187 $self->document_accessor( 1188 name => \@set_methods, 1189 purpose => 'Sets the boolean value to 1.', 1190 examples => ["\$obj->$set_methods[0];"], 1191 belongs_to => $field, 1192 ); 1193 my @clear_methods = uniq "clear_${field}", "${field}_clear"; 1194 for my $name (@clear_methods) { 1195 $self->install_accessor( 1196 name => $name, 1197 code => sub { 1198 local $DB::sub = local *__ANON__ = "${class}::${name}" 1199 if defined &DB::DB && !$Devel::DProf::VERSION; 1200 $_[0]->{$field} = 0; 1201 }, 1202 ); 1203 } 1204 $self->document_accessor( 1205 name => \@clear_methods, 1206 purpose => 'Clears the boolean value by setting it to 0.', 1207 examples => ["\$obj->$clear_methods[0];"], 1208 belongs_to => $field, 1209 ); 1210 } 1211 $self; # for chaining 1212} 1213 1214sub mk_integer_accessors { 1215 my ($self, @fields) = @_; 1216 my $class = ref $self || $self; 1217 for my $field (@fields) { 1218 $self->install_accessor( 1219 name => $field, 1220 code => sub { 1221 local $DB::sub = local *__ANON__ = "${class}::${field}" 1222 if defined &DB::DB && !$Devel::DProf::VERSION; 1223 my $self = shift; 1224 return $self->{$field} || 0 unless @_; 1225 $self->{$field} = shift; 1226 }, 1227 ); 1228 $self->document_accessor( 1229 name => $field, 1230 purpose => <<'EODOC', 1231A basic getter/setter method. If called without an argument, it returns the 1232value, or 0 if there is no previous value. If called with a single argument, 1233it sets the value. 1234EODOC 1235 examples => 1236 [ "\$obj->$field(\$value);", "my \$value = \$obj->$field;", ], 1237 ); 1238 my @reset_methods = uniq "reset_${field}", "${field}_reset"; 1239 for my $name (@reset_methods) { 1240 $self->install_accessor( 1241 name => $name, 1242 code => sub { 1243 local $DB::sub = local *__ANON__ = "${class}::${name}" 1244 if defined &DB::DB && !$Devel::DProf::VERSION; 1245 $_[0]->{$field} = 0; 1246 }, 1247 ); 1248 } 1249 $self->document_accessor( 1250 name => \@reset_methods, 1251 purpose => 'Resets the value to 0.', 1252 examples => ["\$obj->$reset_methods[0];"], 1253 belongs_to => $field, 1254 ); 1255 my @inc_methods = uniq "inc_${field}", "${field}_inc"; 1256 for my $name (@inc_methods) { 1257 $self->install_accessor( 1258 name => $name, 1259 code => sub { 1260 local $DB::sub = local *__ANON__ = "${class}::${name}" 1261 if defined &DB::DB && !$Devel::DProf::VERSION; 1262 $_[0]->{$field}++; 1263 }, 1264 ); 1265 } 1266 $self->document_accessor( 1267 name => \@inc_methods, 1268 purpose => 'Increases the value by 1.', 1269 examples => ["\$obj->$inc_methods[0];"], 1270 belongs_to => $field, 1271 ); 1272 my @dec_methods = uniq "dec_${field}", "${field}_dec"; 1273 for my $name (@dec_methods) { 1274 $self->install_accessor( 1275 name => $name, 1276 code => sub { 1277 local $DB::sub = local *__ANON__ = "${class}::${name}" 1278 if defined &DB::DB && !$Devel::DProf::VERSION; 1279 $_[0]->{$field}--; 1280 }, 1281 ); 1282 } 1283 $self->document_accessor( 1284 name => \@dec_methods, 1285 purpose => 'Decreases the value by 1.', 1286 examples => ["\$obj->$dec_methods[0];"], 1287 belongs_to => $field, 1288 ); 1289 } 1290 $self; # for chaining 1291} 1292 1293sub mk_set_accessors { 1294 my ($self, @fields) = @_; 1295 my $class = ref $self || $self; 1296 for my $field (@fields) { 1297 my $insert_method = "${field}_insert"; 1298 my $elements_method = "${field}_elements"; 1299 $self->install_accessor( 1300 name => $field, 1301 code => sub { 1302 local $DB::sub = local *__ANON__ = "${class}::${field}" 1303 if defined &DB::DB && !$Devel::DProf::VERSION; 1304 my $self = shift; 1305 if (@_) { 1306 $self->$insert_method(@_); 1307 } else { 1308 $self->$elements_method; 1309 } 1310 }, 1311 ); 1312 $self->document_accessor( 1313 name => $field, 1314 purpose => <<'EODOC', 1315A set is like an array except that each element can occur only one. It is, 1316however, not ordered. If called with a list of arguments, it adds those 1317elements to the set. If the first argument is an array reference, the values 1318contained therein are added to the set. If called without arguments, it 1319returns the elements of the set. 1320EODOC 1321 examples => [ 1322 "my \@elements = \$obj->$field;", 1323 "\$obj->$field(\@elements);", 1324 ], 1325 ); 1326 my @insert_methods = uniq "insert_${field}", $insert_method; 1327 for my $name (@insert_methods) { 1328 $self->install_accessor( 1329 name => $name, 1330 code => sub { 1331 local $DB::sub = local *__ANON__ = "${class}::${name}" 1332 if defined &DB::DB && !$Devel::DProf::VERSION; 1333 my $self = shift; 1334 $self->{$field}{$_}++ for flatten(@_); 1335 }, 1336 ); 1337 } 1338 $self->document_accessor( 1339 name => \@insert_methods, 1340 purpose => <<'EODOC', 1341If called with a list of arguments, it adds those elements to the set. If the 1342first argument is an array reference, the values contained therein are added 1343to the set. 1344EODOC 1345 examples => ["\$obj->$insert_methods[0](\@elements);"], 1346 belongs_to => $field, 1347 ); 1348 my @elements_methods = uniq "elements_${field}", $elements_method; 1349 for my $name (@elements_methods) { 1350 $self->install_accessor( 1351 name => $name, 1352 code => sub { 1353 local $DB::sub = local *__ANON__ = "${class}::${name}" 1354 if defined &DB::DB && !$Devel::DProf::VERSION; 1355 my $self = shift; 1356 $self->{$field} ||= {}; 1357 keys %{ $self->{$field} }; 1358 }, 1359 ); 1360 } 1361 $self->document_accessor( 1362 name => \@elements_methods, 1363 purpose => 'Returns the elements of the set.', 1364 examples => ["my \@elements = \$obj->$elements_methods[0];"], 1365 belongs_to => $field, 1366 ); 1367 my @delete_methods = uniq "delete_${field}", "${field}_delete"; 1368 for my $name (@delete_methods) { 1369 $self->install_accessor( 1370 name => $name, 1371 code => sub { 1372 local $DB::sub = local *__ANON__ = "${class}::${name}" 1373 if defined &DB::DB && !$Devel::DProf::VERSION; 1374 my $self = shift; 1375 delete $self->{$field}{$_} for @_; 1376 }, 1377 ); 1378 } 1379 $self->document_accessor( 1380 name => \@delete_methods, 1381 purpose => <<'EODOC', 1382If called with a list of values, it deletes those elements from the set. 1383EODOC 1384 examples => ["\$obj->$delete_methods[0](\@elements);"], 1385 belongs_to => $field, 1386 ); 1387 my @clear_methods = uniq "clear_${field}", "${field}_clear"; 1388 for my $name (@clear_methods) { 1389 $self->install_accessor( 1390 name => $name, 1391 code => sub { 1392 local $DB::sub = local *__ANON__ = "${class}::${name}" 1393 if defined &DB::DB && !$Devel::DProf::VERSION; 1394 $_[0]->{$field} = {}; 1395 }, 1396 ); 1397 } 1398 $self->document_accessor( 1399 name => \@clear_methods, 1400 purpose => 'Deletes all elements from the set.', 1401 examples => ["\$obj->$clear_methods[0];"], 1402 belongs_to => $field, 1403 ); 1404 my @contains_methods = uniq "contains_${field}", "${field}_contains"; 1405 for my $name (@contains_methods) { 1406 $self->install_accessor( 1407 name => $name, 1408 code => sub { 1409 local $DB::sub = local *__ANON__ = "${class}::${name}" 1410 if defined &DB::DB && !$Devel::DProf::VERSION; 1411 my ($self, $key) = @_; 1412 return unless defined $key; 1413 exists $self->{$field}{$key}; 1414 }, 1415 ); 1416 } 1417 $self->document_accessor( 1418 name => \@contains_methods, 1419 purpose => <<'EODOC', 1420Takes a single key and returns a boolean value indicating whether that key is 1421an element of the set. 1422EODOC 1423 examples => ["if (\$obj->$contains_methods[0](\$element)) { ... }"], 1424 , 1425 belongs_to => $field, 1426 ); 1427 my @is_empty_methods = uniq "is_empty_${field}", "${field}_is_empty"; 1428 for my $name (@is_empty_methods) { 1429 $self->install_accessor( 1430 name => $name, 1431 code => sub { 1432 local $DB::sub = local *__ANON__ = "${class}::${name}" 1433 if defined &DB::DB && !$Devel::DProf::VERSION; 1434 my $self = shift; 1435 keys %{ $self->{$field} || {} } == 0; 1436 }, 1437 ); 1438 } 1439 $self->document_accessor( 1440 name => \@is_empty_methods, 1441 purpose => 1442'Returns a boolean value indicating whether the set is empty of not.', 1443 examples => ["\$obj->$is_empty_methods[0];"], 1444 belongs_to => $field, 1445 ); 1446 my @size_methods = uniq "size_${field}", "${field}_size"; 1447 for my $name (@size_methods) { 1448 $self->install_accessor( 1449 name => $name, 1450 code => sub { 1451 local $DB::sub = local *__ANON__ = "${class}::${name}" 1452 if defined &DB::DB && !$Devel::DProf::VERSION; 1453 my $self = shift; 1454 scalar keys %{ $self->{$field} || {} }; 1455 }, 1456 ); 1457 } 1458 $self->document_accessor( 1459 name => \@size_methods, 1460 purpose => 'Returns the number of elements in the set.', 1461 examples => ["my \$size = \$obj->$size_methods[0];"], 1462 belongs_to => $field, 1463 ); 1464 } 1465 $self; # for chaining 1466} 1467 1468sub mk_object_accessors { 1469 my ($self, @args) = @_; 1470 my $class = ref $self || $self; 1471 while (@args) { 1472 my $type = shift @args; 1473 my $list = shift @args or die "No slot names for $class"; 1474 1475 # Allow a list of hashrefs. 1476 my @list = ref($list) eq 'ARRAY' ? @$list : ($list); 1477 for my $obj_def (@list) { 1478 my ($name, @composites); 1479 if (!ref $obj_def) { 1480 $name = $obj_def; 1481 } else { 1482 $name = $obj_def->{slot}; 1483 my $composites = $obj_def->{comp_mthds}; 1484 @composites = 1485 ref($composites) eq 'ARRAY' ? @$composites 1486 : defined $composites ? ($composites) 1487 : (); 1488 } 1489 for my $meth (@composites) { 1490 $self->install_accessor( 1491 name => $meth, 1492 code => sub { 1493 local $DB::sub = local *__ANON__ = "${class}::{$meth}" 1494 if defined &DB::DB && !$Devel::DProf::VERSION; 1495 my ($self, @args) = @_; 1496 $self->$name()->$meth(@args); 1497 }, 1498 ); 1499 $self->document_accessor( 1500 name => $meth, 1501 purpose => <<EODOC, 1502Calls $meth() with the given arguments on the object stored in the $name slot. 1503If there is no such object, a new $type object is constructed - no arguments 1504are passed to the constructor - and stored in the $name slot before forwarding 1505$meth() onto it. 1506EODOC 1507 examples => [ "\$obj->$meth(\@args);", "\$obj->$meth;", ], 1508 ); 1509 } 1510 $self->install_accessor( 1511 name => $name, 1512 code => sub { 1513 local $DB::sub = local *__ANON__ = "${class}::${name}" 1514 if defined &DB::DB && !$Devel::DProf::VERSION; 1515 my ($self, @args) = @_; 1516 if (ref($args[0]) && UNIVERSAL::isa($args[0], $type)) { 1517 $self->{$name} = $args[0]; 1518 } else { 1519 defined $self->{$name} 1520 or $self->{$name} = $type->new(@args); 1521 } 1522 $self->{$name}; 1523 }, 1524 ); 1525 $self->document_accessor( 1526 name => $name, 1527 purpose => <<EODOC, 1528If called with an argument object of type $type it sets the object; further 1529arguments are discarded. If called with arguments but the first argument is 1530not an object of type $type, a new object of type $type is constructed and the 1531arguments are passed to the constructor. 1532 1533If called without arguments, it returns the $type object stored in this slot; 1534if there is no such object, a new $type object is constructed - no arguments 1535are passed to the constructor in this case - and stored in the $name slot 1536before returning it. 1537EODOC 1538 examples => [ 1539 "my \$object = \$obj->$name;", "\$obj->$name(\$object);", 1540 "\$obj->$name(\@args);", 1541 ], 1542 ); 1543 my @clear_methods = uniq "clear_${name}", "${name}_clear"; 1544 for my $meth (@clear_methods) { 1545 $self->install_accessor( 1546 name => $meth, 1547 code => sub { 1548 local $DB::sub = local *__ANON__ = "${class}::${meth}" 1549 if defined &DB::DB && !$Devel::DProf::VERSION; 1550 delete $_[0]->{$name}; 1551 }, 1552 ); 1553 } 1554 $self->document_accessor( 1555 name => \@clear_methods, 1556 purpose => 'Deletes the object.', 1557 examples => "\$obj->$clear_methods[0];", 1558 belongs_to => $name, 1559 ); 1560 } 1561 } 1562 $self; # for chaining 1563} 1564 1565sub mk_forward_accessors { 1566 my ($self, %args) = @_; 1567 my $class = ref $self || $self; 1568 while (my ($slot, $methods) = each %args) { 1569 my @methods = ref $methods eq 'ARRAY' ? @$methods : ($methods); 1570 for my $field (@methods) { 1571 $self->install_accessor( 1572 name => $field, 1573 code => sub { 1574 local $DB::sub = local *__ANON__ = "${class}::${field}" 1575 if defined &DB::DB && !$Devel::DProf::VERSION; 1576 my ($self, @args) = @_; 1577 $self->$slot()->$field(@args); 1578 }, 1579 ); 1580 $self->document_accessor( 1581 name => $field, 1582 purpose => <<EODOC, 1583Calls $field() with the given arguments on the object stored in the $slot 1584slot. 1585EODOC 1586 examples => [ "\$obj->$field(\@args);", "\$obj->$field;", ], 1587 ); 1588 } 1589 } 1590 $self; # for chaining 1591} 15921; 1593 1594 1595__END__ 1596=pod 1597 1598=head1 NAME 1599 1600Class::Accessor::Complex - Arrays, hashes, booleans, integers, sets and more 1601 1602=head1 VERSION 1603 1604version 1.100880 1605 1606=head1 SYNOPSIS 1607 1608 package MyClass; 1609 use base 'Class::Accessor::Complex'; 1610 __PACKAGE__ 1611 ->mk_new 1612 ->mk_array_accessors(qw(an_array)) 1613 ->mk_hash_accessors(qw(a_hash)) 1614 ->mk_integer_accessors(qw(an_integer)) 1615 ->mk_class_hash_accessors(qw(a_hash)) 1616 ->mk_set_accessors(qw(testset)) 1617 ->mk_object_accessors('Some::Foo' => { 1618 slot => 'an_object', 1619 comp_mthds => [ qw(do_this do_that) ] 1620 }); 1621 1622=head1 DESCRIPTION 1623 1624This module generates accessors for your class in the same spirit as 1625L<Class::Accessor> does. While the latter deals with accessors for scalar 1626values, this module provides accessor makers for arrays, hashes, integers, 1627booleans, sets and more. 1628 1629As seen in the synopsis, you can chain calls to the accessor makers. Also, 1630because this module inherits from L<Class::Accessor>, you can put a call 1631to one of its accessor makers at the end of the chain. 1632 1633The accessor generators also generate documentation ready to be used with 1634L<Sub::Documentation>. 1635 1636=head1 METHODS 1637 1638=head2 mk_new 1639 1640Takes an array of strings as its argument. If no argument is given, it uses 1641C<new> as the default. For each string it creates a constructor of that name. 1642The constructor accepts named arguments - that is, a hash - and will set the 1643hash values on the accessor methods denoted by the keys. For example, 1644 1645 package MyClass; 1646 use base 'Class::Accessor::Complex'; 1647 __PACKAGE__->mk_new; 1648 1649 package main; 1650 use MyClass; 1651 1652 my $o = MyClass->new(foo => 12, bar => [ 1..5 ]); 1653 1654is the same as 1655 1656 my $o = MyClass->new; 1657 $o->foo(12); 1658 $o->bar([1..5]); 1659 1660The constructor will also call an C<init()> method, if there is one. 1661 1662=head2 mk_singleton 1663 1664Takes an array of strings as its argument. If no argument is given, it uses 1665C<new> as the default. For each string it creates a constructor of that name. 1666 1667This constructor only ever returns a single instance of the class. That is, 1668after the first call, repeated calls to this constructor return the 1669I<same> instance. Note that the instance is instantiated at the time of 1670the first call, not before. Any arguments are treated as for C<mk_new()>. 1671Naturally, C<init()> and any initializer methods are called only by the 1672first invocation of this method. 1673 1674=head2 mk_scalar_accessors 1675 1676Takes an array of strings as its argument. For each string it creates methods 1677as described below, where C<*> denotes the slot name. 1678 1679=over 4 1680 1681=item C<*> 1682 1683This method can store a value in a slot and retrieve that value. If it 1684receives an argument, it sets the value. Only the first argument is used, 1685subsequent arguments are ignored. If called without a value, the method 1686retrieves the value from the slot. 1687 1688=item C<*_clear>, C<clear_*> 1689 1690Clears the value by setting it to undef. 1691 1692=back 1693 1694=head2 mk_class_scalar_accessors 1695 1696Takes an array of strings as its argument. For each string it creates methods 1697like those generated with C<mk_scalar_accessors()>, except that it is a class 1698scalar, i.e. shared by all instances of the class. 1699 1700=head2 mk_concat_accessors 1701 1702Takes an array of strings as its argument. For each string it creates methods 1703as described below, where C<*> denotes the slot name. 1704 1705=over 4 1706 1707=item C<*> 1708 1709Like C<mk_scalar_accessors()>, but passing a value to the accessor doesn't 1710clear out the original value, but instead concatenates the new value to the 1711existing one. Thus, this kind of accessor is only good for plain scalars. 1712 1713=item C<*_clear>, C<clear_*> 1714 1715Clears the value by setting it to undef. 1716 1717=back 1718 1719=head2 mk_array_accessors 1720 1721Takes an array of strings as its argument. For each string it creates methods 1722as described below, where C<*> denotes the slot name. 1723 1724=over 4 1725 1726=item C<*> 1727 1728This method returns the list of values stored in the slot. If any arguments 1729are provided to this method, they I<replace> the current list contents. In an 1730array context it returns the values as an array and in a scalar context as a 1731reference to the array. Note that this reference is currently a direct 1732reference to the storage; changes to the storage will affect the contents of 1733the reference, and vice-versa. This behaviour is not guaranteed; caveat 1734emptor. 1735 1736=item C<*_push>, C<push_*> 1737 1738Pushes the given elements onto the end of the array. Like perl's C<push()>. 1739 1740=item C<*_pop>, C<pop_*> 1741 1742Pops one element off the end of the array. Like perl's C<pop()>. 1743 1744=item C<*_shift>, C<shift_*> 1745 1746Shifts one element off the beginning of the array. Like perl's C<shift()>. 1747 1748=item C<*_unshift>, C<unshift_*> 1749 1750Unshifts the given elements onto the beginning of the array. Like perl's 1751C<unshift()>. 1752 1753=item C<*_splice>, C<splice_*> 1754 1755Takes an offset, a length and a replacement list. The arguments and behaviour 1756are exactly like perl's C<splice()>. 1757 1758=item C<*_clear>, C<clear_*> 1759 1760Deletes all elements of the array. 1761 1762=item C<*_count>, C<count_*> 1763 1764Returns the number of elements in the array. 1765 1766=item C<*_set>, C<set_*> 1767 1768Takes a list, treated as pairs of index => value; each given index is 1769set to the corresponding value. No return. 1770 1771=item C<*_index>, C<index_*> 1772 1773Takes a list of indices and returns a list of the corresponding values. This is like an array slice. 1774 1775=back 1776 1777=head2 mk_class_array_accessors 1778 1779Takes an array of strings as its argument. For each string it creates methods 1780like those generated with C<mk_array_accessors()>, except that it is a class 1781hash, i.e. shared by all instances of the class. 1782 1783=head2 mk_hash_accessors 1784 1785Takes an array of strings as its argument. For each string it creates methods 1786as described below, where C<*> denotes the slot name. 1787 1788=over 4 1789 1790=item C<*> 1791 1792Called with no arguments returns the hash stored in the slot, as a hash 1793in a list context or as a reference in a scalar context. 1794 1795Called with one simple scalar argument it treats the argument as a key 1796and returns the value stored under that key. 1797 1798Called with one array (list) reference argument, the array elements 1799are considered to be be keys of the hash. x returns the list of values 1800stored under those keys (also known as a I<hash slice>.) 1801 1802Called with one hash reference argument, the keys and values of the 1803hash are added to the hash. 1804 1805Called with more than one argument, treats them as a series of key/value 1806pairs and adds them to the hash. 1807 1808=item C<*_keys>, C<keys_*> 1809 1810Returns the keys of the hash. 1811 1812=item C<*_count>, C<count_*> 1813 1814Returns the number of keys in the hash. 1815 1816=item C<*_values>, C<values_*> 1817 1818Returns the list of values. 1819 1820=item C<*_exists>, C<exists_*> 1821 1822Takes a single key and returns whether that key exists in the hash. 1823 1824=item C<*_delete>, C<delete_*> 1825 1826Takes a list and deletes each key from the hash. 1827 1828=item C<*_clear>, C<clear_*> 1829 1830Resets the hash to empty. 1831 1832=back 1833 1834=head2 mk_class_hash_accessors 1835 1836Takes an array of strings as its argument. For each string it creates methods 1837like those generated with C<mk_hash_accessors()>, except that it is a class 1838hash, i.e. shared by all instances of the class. 1839 1840=head2 mk_abstract_accessors 1841 1842Takes an array of strings as its argument. For each string it creates methods 1843as described below, where C<*> denotes the slot name. 1844 1845=over 4 1846 1847=item C<*> 1848 1849When called, it either dies (if L<Error::Hierarchy> is not installed) or 1850throws an exception of type L<Error::Hierarchy::Internal::AbstractMethod> (if 1851it is installed). 1852 1853=back 1854 1855=head2 mk_boolean_accessors 1856 1857Takes an array of strings as its argument. For each string it creates methods 1858as described below, where C<*> denotes the slot name. 1859 1860=over 4 1861 1862=item C<*> 1863 1864If given a true value - in the Perl sense, i.e. anything except C<undef>, C<0> 1865or the empty string - it sets the slot's value to C<1>, otherwise to C<0>. If 1866no argument is given, it returns the slot's value. 1867 1868=item C<*_set>, C<set_*> 1869 1870Sets the slot's value to C<1>. 1871 1872=item C<*_clear>, C<clear_*> 1873 1874Sets the slot's value to C<0>. 1875 1876=back 1877 1878=head2 mk_integer_accessors 1879 1880 __PACKAGE__->mk_integer_accessors(qw(some_counter other_index)); 1881 1882Takes a list of accessor base names (simple strings). For each string it 1883creates methods as described below, where C<*> denotes the accessor base name. 1884 1885=over 4 1886 1887=item C<*> 1888 1889A basic getter/setter that stores an integer value. Actually, it can store any 1890value, but when read back, it returns 0 if the value is undef. 1891 1892=item C<*_reset>, C<reset_*> 1893 1894Resets the slot's value to 0. 1895 1896=item C<*_inc>, C<inc_*> 1897 1898Increments the value, then returns it. 1899 1900=item C<*_dec>, C<dec_*> 1901 1902Decrements the value, then returns it. 1903 1904=back 1905 1906Example: 1907 1908 package Foo; 1909 1910 use base 'Class::Accessor::Complex'; 1911 __PACKAGE__->mk_integer_accessors(qw(score)); 1912 1913Then: 1914 1915 my $obj = Foo->new(score => 150); 1916 my $x = $obj->score_inc; # is now 151 1917 $obj->score_reset; # is now 0 1918 1919=head2 mk_set_accessors 1920 1921Takes an array of strings as its argument. For each string it creates methods 1922as described below, where C<*> denotes the slot name. 1923 1924A set is different from a list in that it can contain every value only once 1925and there is no order on the elements (similar to hash keys, for example). 1926 1927=over 4 1928 1929=item C<*> 1930 1931If called without arguments, it returns the elements in the set. If called 1932with arguments, it puts those elements into the set. As such, it is a wrapper 1933over C<*_insert()> and C<*_elements()>. 1934 1935=item C<*_insert>, C<insert_*> 1936 1937Inserts the given elements (arguments) into the set. If you pass an array 1938reference as the first argument, it is being dereferenced and used instead. 1939 1940=item C<*_elements>, C<elements_*> 1941 1942Returns the elements in the set. 1943 1944=item C<*_delete>, C<delete_*> 1945 1946Removes the given elements from the list. The order in which the elements are 1947returned is not guaranteed. 1948 1949=item C<*_clear>, C<clear_*> 1950 1951Empties the set. 1952 1953=item C<*_contains>, C<contains_*> 1954 1955Given an element, it returns whether the set contains the element. 1956 1957=item C<*_is_empty>, C<is_empty_*> 1958 1959Returns whether or not the set is empty. 1960 1961=item C<*_size>, C<size_*> 1962 1963Returns the number of elements in the set. 1964 1965=back 1966 1967=head2 mk_object_accessors 1968 1969 MyClass->mk_object_accessors( 1970 'Foo' => 'phooey', 1971 'Bar' => [ qw(bar1 bar2 bar3) ], 1972 'Baz' => { 1973 slot => 'foo', 1974 comp_mthds => [ qw(bar baz) ] 1975 }, 1976 'Fob' => [ 1977 { 1978 slot => 'dog', 1979 comp_mthds => 'bark', 1980 }, 1981 { 1982 slot => 'cat', 1983 comp_mthds => 'miaow', 1984 }, 1985 ], 1986 ); 1987 1988The main argument should be a reference to an array. The array should contain 1989pairs of class => sub-argument pairs. The sub-arguments parsed thus: 1990 1991=over 4 1992 1993=item Hash Reference 1994 1995See C<Baz> above. The hash should contain the following keys: 1996 1997=over 4 1998 1999=item C<slot> 2000 2001The name of the instance attribute (slot). 2002 2003=item C<comp_mthds> 2004 2005A string or array reference, naming the methods that will be forwarded 2006directly to the object in the slot. 2007 2008=back 2009 2010=item Array Reference 2011 2012As for C<String>, for each member of the array. Also works if each member is a 2013hash reference (see C<Fob> above). 2014 2015=item String 2016 2017The name of the instance attribute (slot). 2018 2019=back 2020 2021For each slot C<x>, with forwarding methods C<y()> and C<z()>, the following 2022methods are created: 2023 2024=over 4 2025 2026=item C<x> 2027 2028A get/set method, see C<*> below. 2029 2030=item C<y> 2031 2032Forwarded onto the object in slot C<x>, which is auto-created via C<new()> if 2033necessary. The C<new()>, if called, is called without arguments. 2034 2035=item C<z> 2036 2037As for C<y>. 2038 2039=back 2040 2041So, using the example above, a method, C<foo()>, is created, which can get and 2042set the value of those objects in slot C<foo>, which will generally contain an 2043object of class C<Baz>. Two additional methods are created named C<bar()> and 2044C<baz()> which result in a call to the C<bar()> and C<baz()> methods on the 2045C<Baz> object stored in slot C<foo>. 2046 2047Apart from the forwarding methods described above, C<mk_object_accessors()> 2048creates methods as described below, where C<*> denotes the slot name. 2049 2050=over 4 2051 2052=item C<*> 2053 2054If the accessor is supplied with an object of an appropriate type, will set 2055set the slot to that value. Else, if the slot has no value, then an object is 2056created by calling C<new()> on the appropriate class, passing in any supplied 2057arguments. 2058 2059The stored object is then returned. 2060 2061=item C<*_clear>, C<clear_*> 2062 2063Removes the object from the accessor. 2064 2065=back 2066 2067=head2 mk_forward_accessors 2068 2069 __PACKAGE__->mk_forward_accessors( 2070 comp1 => 'method1', 2071 comp2 => [ qw(method2 method3) ], 2072 ); 2073 2074Takes a hash of mappings as its arguments. Each hash value is expected to be 2075either a string or an array reference. For each hash value an accessor is 2076created and forwarded to the accessor denoted by its associated hash key. 2077 2078In the example above, a call to C<method1()> will be forwarded onto 2079C<comp1()>, and calls to C<method2()> and C<method3()> will be forwarded onto 2080C<comp2()>. 2081 2082=head1 INSTALLATION 2083 2084See perlmodinstall for information and options on installing Perl modules. 2085 2086=head1 BUGS AND LIMITATIONS 2087 2088No bugs have been reported. 2089 2090Please report any bugs or feature requests through the web interface at 2091L<http://rt.cpan.org/Public/Dist/Display.html?Name=Class-Accessor-Complex>. 2092 2093=head1 AVAILABILITY 2094 2095The latest version of this module is available from the Comprehensive Perl 2096Archive Network (CPAN). Visit L<http://www.perl.com/CPAN/> to find a CPAN 2097site near you, or see 2098L<http://search.cpan.org/dist/Class-Accessor-Complex/>. 2099 2100The development version lives at 2101L<http://github.com/hanekomu/Class-Accessor-Complex/>. 2102Instead of sending patches, please fork this project using the standard git 2103and github infrastructure. 2104 2105=head1 AUTHOR 2106 2107 Marcel Gruenauer <marcel@cpan.org> 2108 2109=head1 COPYRIGHT AND LICENSE 2110 2111This software is copyright (c) 2007 by Marcel Gruenauer. 2112 2113This is free software; you can redistribute it and/or modify it under 2114the same terms as the Perl 5 programming language system itself. 2115 2116=cut 2117 2118