File Coverage

blib/lib/Class/Slot.pm

Criterion	Covered	Total	%
statement	159	182	87.3
branch	46	68	67.6
condition	11	21	52.3
subroutine	34	38	89.4
pod	0	5	0.0
total	250	314	79.6

package Class::Slot;
# ABSTRACT: Simple, efficient, comple-time class declaration
$Class::Slot::VERSION = '0.07';
use strict;
use warnings;

no strict 'refs';
no warnings 'redefine';

use Scalar::Util qw(refaddr);
use Filter::Simple;
use Carp;

our $DEBUG_ALL = $ENV{CLASS_SLOT_DEBUG}; # Enable debugging for all classes
our %DEBUG;                              # Enable debugging for individual classes
our $XS;                                 # Class::XSAccessor support
our $LATE;                               # Set to true in INIT to trigger run-time over compile-time behavior
our %CLASS;                              # Class slot data
our %TYPE;                               # Stores type objects outside of %CLASS for easier printf debugging
our %C3;                                 # Enable breadth-first resolution for individual classes

BEGIN {
  $DEBUG_ALL = $ENV{CLASS_SLOT_DEBUG} ? 1 : 0;

  if ($ENV{CLASS_SLOT_NO_XS}) {
    $XS = 0;
  } else {
    eval 'use Class::XSAccessor';
    $XS = $@ ? 0 : 1;
  }
}

INIT {
  $LATE = 1;
}

sub import {
  my $class = shift;
  my $name  = shift || return;
  my ($caller, $file, $line) = caller;

  # Handle special parameters
  if ($name eq '-debugall') {
    $DEBUG_ALL = 1;
    return;
  }

  if ($name eq '-debug') {
    $DEBUG{$caller} = 1;
    return;
  }

  if ($name =~ /^c3$/i) {
    $C3{$caller} = 1;
    return;
  }

  # Suss out slot parameters
  my ($type, %param) = (@_ % 2 == 0)
    ? (undef, @_)
    : @_;

  $type = Class::Slot::AnonType->new($type)
    if ref $type eq 'CODE';

  croak "slot ${name}'s type is invalid"
    if defined $type
    && !ref $type
    && !$type->can('can_be_inlined')
    && !$type->can('inline_check')
    && !$type->can('check');

  # Ensure that the default value is valid if the type is set
  if (exists $param{def} && $type) {
    croak "default value for $name is not a valid $type"
      unless $type->check(ref $param{def} eq 'CODE' ? $param{def}->() : $param{def});
  }

  # Initialize slot storage
  unless (exists $CLASS{$caller}) {
    $C3{$caller} ||= 0;

    $CLASS{$caller} = {
      slot  => {}, # slot definitions
      slots => [], # list of slot names

      # Generate initialization code for the class itself. Because all slots
      # are not yet known, this will be executed in a CHECK block at compile
      # time. If the class is being generated after CHECK (such as from a
      # string eval), it will be lazily evaluated the first time 'new' is
      # called on the class.

      init => sub{
        # Ensure any accessor methods defined by $caller's parent class(es)
        # have been built.
        for (@{ $caller . '::ISA' }) {
          if (exists $CLASS{$_} && defined $CLASS{$_}{init}) {
            $CLASS{$_}{init}->();
          }
        }

        # Build constructor
        my $ctor = _build_ctor($caller);

        # Build accessors
        my $acc = join "\n", map{ _build_accessor($caller, $_) } keys %{ $caller->get_slots };

        # Build @SLOTS
        my $slots = join ' ', map{ quote_identifier($_) }
          sort keys %{ $caller->get_slots };

        my $pkg  = qq{package $caller;
no warnings 'redefine';
no Class::Slot;
use Carp;

our \@SLOTS = qw($slots);

#-------------------------------------------------------------------------------
# Constructor
#-------------------------------------------------------------------------------
$ctor

#-------------------------------------------------------------------------------
# Accessors
#-------------------------------------------------------------------------------
$acc};

        if ($DEBUG_ALL || $DEBUG{$caller}) {
          print "\n";
          print "================================================================================\n";
          print "# slot generated the following code:\n";
          print "================================================================================\n";
          print "$pkg\n";
          print "================================================================================\n";
          print "# end of slot-generated code\n";
          print "================================================================================\n";
          print "\n";
        }

        # Install into calling package
        eval $pkg;
        $@ && die $@;

        delete $CLASS{$caller}{init};
      },
    };

    # Whereas with a run-time eval the definitions of all slots are not yet
    # known and CHECK is not available, so methods may be installed on the
    # first call to 'new'.
    if ($LATE) {
      *{$caller . '::new'} = sub {
        $Class::Slot::CLASS{$caller}{init}->();
        goto $caller->can('new');
      };
    }
    # Compile-time generation allows use of CHECK to install our methods once
    # the entire class has been loaded.
    else {
      eval qq{
# line $line "$file"
CHECK {
  \$Class::Slot::CLASS{'$caller'}{init}->()
    if exists \$Class::Slot::CLASS{'$caller'}{init};
}
};

      $@ && die $@;
    }
  }

  $CLASS{$caller}{slot}{$name} = {
    pkg  => $caller,
    file => $file,
    line => $line,
  };

  if (defined $type) {
    my $addr = refaddr $type;
    $CLASS{$caller}{slot}{$name}{type} = $addr;
    $TYPE{$addr} = $type;
  }

  for (qw(def req rw)) {
    $CLASS{$caller}{slot}{$name}{$_} = $param{$_}
      if exists $param{$_};
  }

  *{ $caller . '::get_slots' } = \&get_slots;

  push @{ $CLASS{$caller}{slots} }, $name;
}

#-------------------------------------------------------------------------------
# Constructor
#-------------------------------------------------------------------------------
sub _build_ctor {
  my $class = shift;

  my $code = qq{sub new \{
  my \$class = shift;
};

  my $has_parents = @{ $class . '::ISA' };

  # Look for constructor in inheritence change
  my $can_ctor = 0;
  for (@{ $class . '::ISA' }) {
    if ($_->can('new')) {
      $can_ctor = 1;
      last;
    }
  }

  if ($can_ctor) {
    $code .= "  my \$self = \$class->SUPER::new(\@_);\n";
  } else {
    $code .= "  my \$self = bless { \@_ }, \$class;\n";
  }

  $code .= qq{
  # Skip type validation when called as a SUPER method from a recognized child class' constructor.
  return \$self if ref(\$self) ne '$class' && exists \$Class::Slot::CLASS{ref(\$self)};
};

  my $slots = $class->get_slots;

  for my $name (keys %$slots) {
    my $slot  = $slots->{$name};
    my $line  = qq{# line $slot->{line} "$slot->{file}"};
    my $req   = $slot->{req};
    my $def   = $slot->{def};
    my $type  = $TYPE{$slot->{type}} if exists $slot->{type};
    my $ident = quote_identifier($name);

    if ($req && !defined $def) {
      $code .= "\n$line\n  croak '$ident is a required field' unless exists \$self->{'$ident'};\n";
    }

    if ($type) {
      my $addr = refaddr $type;
      my $check = $type->can_be_inlined
        ? $type->inline_check("\$self->{'$ident'}")
        : "\$Class::Slot::TYPE{'$addr'}->check(\$self->{'$ident'})";

      $code .= qq{$line
  croak '${class}::$ident did not pass validation as type $type' unless !exists \$self->{'$ident'} || $check;

};
    }

    if (defined $def) {
      $code .= "$line\n  \$self->{'$ident'} = ";
      $code .= (ref $def eq 'CODE')
        ? "\$CLASS{'$class'}{slot}{'$ident'}{def}->(\$self)"
        : "\$CLASS{'$class'}{slot}{'$ident'}{def}";

      $code .= " unless exists \$self->{'$ident'};\n";
    }
  }

  $code .= "  \$self;\n}\n";

  return $code;
}

#-------------------------------------------------------------------------------
# Slot data
#-------------------------------------------------------------------------------
sub get_mro {
  my @todo = ( $_[0] );
  my %seen;
  my @mro;

  while (my $class = shift @todo) {
    next if $seen{$class};
    $seen{$class} = 1;

    if (@{$class . '::ISA'}) {
      if ($C3{$class}) {
        push @todo, @{$class . '::ISA'};
      } else {
        unshift @todo, @{$class . '::ISA'};
      }
    }

    push @mro, $class;
  }

  return @mro;
}

sub get_slots {
  my ($class, $name) = @_;
  my @mro = get_mro $class;
  my %slots;

  for my $class (@mro) {
    next unless exists $CLASS{$class};

    my @slots = defined $name ? ($name) : @{$CLASS{$class}{slots}};

    for my $slot (@slots) {
      if (!exists $slots{$slot}) {
        $slots{$slot} = $CLASS{$class}{slot}{$slot};
      }
      else {
        for my $cfg (qw(rw req def line file)) {
          if (!exists $slots{$slot}{$cfg} && exists $CLASS{$class}{slot}{$slot}{$cfg}) {
            $slots{$slot}{$cfg} = $CLASS{$class}{slot}{$slot}{$cfg};
          }
        }

        if (!exists $slots{$slot}{type} && exists $CLASS{$class}{slot}{$slot}{type}) {
          $slots{$slot}{type} = $TYPE{$CLASS{$class}{slot}{$slot}{type}};
        }
      }
    }
  }

  if (defined $name) {
    return $slots{$name};
  } else {
    return \%slots;
  }
}

#-------------------------------------------------------------------------------
# Accessors
#-------------------------------------------------------------------------------
sub _build_accessor {
  my ($class, $name) = @_;
  return $class->get_slots($name)->{'rw'}
    ? _build_setter($class, $name)
    : _build_getter($class, $name);
}

#-------------------------------------------------------------------------------
# Read-only accessor
#-------------------------------------------------------------------------------
sub _build_getter {
  my ($class, $name) = @_;
  if ($XS) {
    return _build_getter_xs($class, $name);
  } else {
    return _build_getter_pp($class, $name);
  }
}

sub _build_getter_xs {
  my ($class, $name) = @_;
  my $ident = quote_identifier($name);
  return "use Class::XSAccessor getters => {'$ident' => '$ident'}, replace => 1, class => '$class';\n";
}

sub _build_getter_pp {
  my ($class, $name) = @_;
  my $ident = quote_identifier($name);
  my $slot  = $class->get_slots($name);
  my $line  = qq{# line $slot->{line} "$slot->{file}"};
  return qq{sub $ident \{
$line
  croak "${class}::$ident is protected" if \@_ > 1;
  return \$_[0]->{'$ident'} if defined wantarray;
\}
};
}

#-------------------------------------------------------------------------------
# Read-write accessor
#-------------------------------------------------------------------------------
sub _build_setter {
  my ($class, $name) = @_;
  if ($XS && !$class->get_slots($name)->{type}) {
    return _build_setter_xs($class, $name);
  } else {
    return _build_setter_pp($class, $name);
  }
}

sub _build_setter_xs {
  my ($class, $name) = @_;
  my $ident = quote_identifier($name);
  return "use Class::XSAccessor accessors => {'$ident' => '$ident'}, replace => 1, class => '$class';\n";
}

sub _build_setter_pp {
  my ($class, $name) = @_;
  my $slot  = $class->get_slots($name);
  my $line  = qq{# line $slot->{line} "$slot->{file}"};
  my $type  = $TYPE{$slot->{type}} if $slot->{type};
  my $ident = quote_identifier($name);

  my $code = "sub $ident {\n  if (\@_ > 1) {";

  if ($type) {
    my $addr = refaddr $type;
    my $check = $type->can_be_inlined
      ? $type->inline_check('$_[1]')
      : "\$Class::Slot::TYPE{'$addr'}->check(\$_[1])";

      $code .= qq{
$line
    croak '${class}::$ident did not pass validation as type $type' unless $check;
};
  }

  $code .= qq{    \$_[0]->{'$ident'} = \$_[1];
  \}

  return \$_[0]->{'$ident'} if defined wantarray;
\}
};
}

#-------------------------------------------------------------------------------
# Helpers
#-------------------------------------------------------------------------------
sub quote_identifier {
  my $ident = shift;
  $ident =~ s/([^a-zA-Z0-9_]+)/_/g;
  return $ident;
}

sub install_sub {
  my ($class, $name, $code) = @_;
  my $caller = caller;
  my $sym = $class . '::' . quote_identifier($name);

  *{$sym} = sub {
    eval qq{
package $class;
sub $name \{
$code
\}
package $caller;
    };

    $@ && die $@;
    goto $class->can($name);
  };
}

sub install_method {
  my ($class, $name, $code) = @_;
  install_sub($class, $name, "  my \$self = shift;\n$code");
}

#-------------------------------------------------------------------------------
# Source filter:
#   * 'use slot' -> 'use Class::Slot'
#   * 'slot'     -> 'use Class::Slot'
#   * 'slot::'   -> 'Class::Slot::'
#-------------------------------------------------------------------------------
FILTER {
  s/\buse slot\b/use Class::Slot/g;
  s/\bslot::/Class::Slot::/g;
  s/^\s*slot\b/use Class::Slot/gsm;
};

1;


package Class::Slot::AnonType;
$Class::Slot::AnonType::VERSION = '0.07';
use strict;
use warnings;
use Carp;

use overload
  '""' => sub{ '(anon code type)' };

sub new {
  my ($class, $code) = @_;
  bless $code, $class;
}

sub can_be_inlined { 0 }
sub inline_check { croak 'not supported' }

sub check {
  my $self = shift;
  $self->(shift);
}

1;

__END__