File Coverage

blib/lib/Class/Member/GLOB.pm

Criterion	Covered	Total	%
statement	77	82	93.9
branch	17	22	77.2
condition	2	3	66.6
subroutine	14	15	93.3
pod			n/a
total	110	122	90.1

package Class::Member::GLOB;

use strict;
our $VERSION='1.6';

use Carp 'confess';
use IO::Handle;

my $get_class_members;
$get_class_members=sub {
  my $pack=$_[0];
  no strict 'refs';
  my %cm;
  @cm{@{$pack.'::CLASS_MEMBERS'}}=();
  foreach my $p (@{$pack.'::ISA'}) {
    @cm{$get_class_members->($p)}=();
  }
  return keys %cm;
};

sub import {
  my $pack=shift;
  ($pack)=caller;

  my $getset=sub : lvalue {
    my $I=shift;
    my $what=shift;
    unless( UNIVERSAL::isa( $I, 'GLOB' ) ) {
      confess "$pack\::$what must be called as instance method\n";
    }
    $what=$pack.'::'.$what;
    if( $#_>=0 ) {
      ${*$I}{$what}=shift;
    }
    ${*$I}{$what};
  };

  my $new=sub {
    my $parent=shift;
    my $class=ref($parent) || $parent;

    my $I=bless IO::Handle->new=>$class;
    my %o=@_;
    my @CLASS_MEMBERS=$get_class_members->($class);

    if( ref($parent) ) {		# inherit first
      foreach my $m (@CLASS_MEMBERS) {
	$I->$m=$parent->$m;
      }
    }

    # then override with named parameters
    foreach my $m (@CLASS_MEMBERS) {
      $I->$m=$o{$m} if( exists $o{$m} );
    }

    my $init=$I->can('I N I T');
    if( $init ) {
      $init=$init->();
      $I->$init;
    }

    return $I;
  };

  foreach my $name (@_) {
    if( $name=~/^-(.*)/ ) {	# reserved name, aka option
      my $o=$1;
      if( $o eq 'CLASS_MEMBERS' ) {
	local $_;
	no strict 'refs';
	*{$pack.'::CLASS_MEMBERS'}=[grep {!/^-/} @_];
      } elsif( $o=~/^NEW=(.+)/ ) {
	no strict 'refs';
	*{$pack.'::'.$1}=$new;
      } elsif( $o eq 'NEW' ) {
	no strict 'refs';
	*{$pack.'::new'}=$new;
      } elsif( $o=~/^INIT=(.+)/ ) {
	no strict 'refs';
	my $init="$1";
	*{$pack.'::I N I T'}=sub(){$init};
      } elsif( $o eq 'INIT' ) {
	no strict 'refs';
	*{$pack.'::I N I T'}=sub(){"init"};
      }
    } else {
      no strict 'refs';
      *{$pack.'::'.$name}=sub:lvalue {
	my $I=shift;
	&{$getset}( $I, $name, @_ );
      };
    }
  }
}

1;

__END__