root/lang/perl/Class-Accessor-Complex/trunk/lib/Class/Accessor/Complex.pm @ 9742

Revision 9742, 64.3 kB (checked in by hanekomu, 6 years ago)

r6051@nbgr: marcel | 2008-04-18 16:20:38 +0200
lang/perl/Class-Accessor-Complex: initial commit

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