File Coverage

blib/lib/Class/groups.pm

Criterion	Covered	Total	%
statement	77	82	93.9
branch	33	42	78.5
condition	18	23	78.2
subroutine	9	9	100.0
pod	1	1	100.0
total	138	157	87.9

package Class::groups ;
$VERSION = 2.41 ;
use 5.006_001 ;
use strict ;

# This file uses the "Perlish" coding style
# please read http://perl.4pro.net/perlish_coding_style.html

; use Class::props
; our @ISA = qw| Class::props |

; use Carp
; $Carp::Internal{+__PACKAGE__}++

; sub import
   { my $tool = shift
   ; $tool->add_to(scalar caller, @_)
   }

; sub add_to
   { my ( $tool, $pkg, @args ) = @_
   ; foreach my $group ( @args )
      { $group = { name => $group }
                 unless ref $group eq 'HASH'
      ; $$group{name} = [ $$group{name} ]
                        unless ref $$group{name} eq 'ARRAY'
      ; foreach my $n ( @{$$group{name}} )
         { if (  not(defined $$group{no_strict})
              && not(defined $$group{props})
              )
            { $$group{no_strict} = 1
            }
         ; my @group_props
         ; foreach my $prop ( @{$$group{props}} )
            { $prop = $tool->_init_prop_param( $prop )
            ; push @group_props, @{$$prop{name}}
            ; $$prop{group} = $n
            ; $tool->_add_prop($pkg, $prop )
            }
         ; no strict 'refs'
         ; my $init
         ; if ( @group_props )
            { ${$tool.'::PROPS'}{$pkg}{$n} = \@group_props
            ; $init = sub
                       { foreach my $p ( @{ ${$tool.'::PROPS'}
                                             {$_[1]}
                                             {$n}
                                          }
                                       )
                          { my $dummy = $_[0]->$p
                          }
                       ; foreach my $c ( @{$_[1].'::ISA'} )
                          { $init->($_[0], $c)
                          }
                       }
            }
         ; *{$pkg.'::'.$n}
           = sub
              { &{$$group{pre_process}} if defined $$group{pre_process}
              ; my $s = shift
              ; my $hash
                = $tool =~ /^Class/   ? \%{(ref $s||$s).'::'.$n}  # class
                : $tool =~ /^Package/ ? \%{$pkg.'::'.$n}          # package
                : ( $$s{$n} ||= {} )                              # object
              ; if (  ( my $def = $$group{default} )
                   && not keys %$hash
                   )
                 { my $dprops
                   =  ref $def eq 'HASH' && $def
                   || (ref $def eq 'CODE' || not ref $def) && $s->$def()
                 ; ref $dprops eq 'HASH' or croak
                   qq(Invalid "default" option for "$$group{name}[0]", died)
                 ; %$hash = %$dprops
                 }
              ; if ($init)
                 { $init->($s, ref($s)||$s)    # init defaults
                 ; undef $init
                 }
              ; my $data
              ; if ( @_ )
                 { if ( ref $_[0] eq 'HASH' ) # set
                    { $data = $_[0]
                    }
                   elsif ( @_ == 1 )          # get
                    { my @val
                    ; my @pro = ref $_[0] eq 'ARRAY' ? @{$_[0]} : $_[0]
                    ; foreach my $p ( @pro )
                       { if ( my $m = $s->can($p)
                              and grep /^$p$/, @group_props
                            )
                          { push @val, $s->$m
                          }
                         else
                          { if ( $$group{no_strict} )
                             { push @val, $$hash{$p}
                             }
                            else
                             { croak qq(No such property "$p", died)
                             }
                          }
                       }
                    ; return wantarray ? @val : $val[0]
                    }
                   elsif ( not ( @_ % 2 ) )  # set
                    { $data = { @_ }
                    }
                   else
                    { croak qq(Odd number of arguments for "$n", died)
                    }
                 ; while ( my ($p, $v) = each %$data )  # set
                    { if ( my $m = $s->can($p)
                           and grep /^$p$/, @group_props
                         )
                       { $s->$m($v)
                       }
                      else
                       { if ( $$group{no_strict} )
                          { $$hash{$p} = $v
                          }
                         else
                          { croak qq(No such property "$p", died)
                          }
                       }
                    }
                 }
              ; wantarray ? %$hash : $hash  # no argument
              }
         }
      }
   }



1 ;

__END__