File Coverage

blib/lib/Class/Slot.pm

Criterion	Covered	Total	%
statement	196	213	92.0
branch	56	76	73.6
condition	13	21	61.9
subroutine	42	45	93.3
pod	0	6	0.0
total	307	361	85.0

package Class::Slot;
# ABSTRACT: Simple, efficient, comple-time class declaration
$Class::Slot::VERSION = '0.09';
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;
  }
}

sub is_runtime {
  unless ($LATE) {
    local $SIG{__WARN__} = sub{
      my $msg = shift;

      if ($msg =~ /Too late to run CHECK block/) {
        $LATE = 1;

        # When multiple packages are defined in a single file or top-level
        # string eval, they will generate a definition before CHECK is called.
        # If they refer to each other, one may call a method of the other
        # before the class' init has been called.
        #
        # To handle this case, we scan the %CLASS definitions for classes which
        # have been defined but not yet initialized - that is, they are in
        # %CLASS but the 'init' function hasn't been run yet (it deletes itself
        # when it completes) - and then run those classes' initializers.
        for my $class (keys %CLASS) {
          next unless exists $Class::Slot::CLASS{$class}{init};

          *{$class.'::new'} = sub {
            $Class::Slot::CLASS{$class}{init}->();
            goto $class->can('new');
          };
        }

        return;
      }

      CORE::warn($msg);
    };

    eval 'CHECK{ 1 }';
  }

  return $LATE;
}

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

  if (is_runtime() && !(ref *{$caller.'::slot'} eq 'CODE')) {
    *{$caller.'::slot'} = sub{
      unshift @_, 'Class::Slot';
      goto \&import;
    };
  }

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

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

    $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}->();
          }
        }

        my %slots = %{ $caller->get_slots };

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

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

        # Build delegate accessors
        my $delegates = join "\n", map{ _build_delegates($caller, $_) }
          keys %slots;

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

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

our \@SLOTS = qw($slots);

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

#-------------------------------------------------------------------------------
# Accessors
#-------------------------------------------------------------------------------
$acc

#-------------------------------------------------------------------------------
# Delegate accessors
#-------------------------------------------------------------------------------
$delegates};

        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 $@;
    }
  }

  if (defined $name) {
    # 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});
    }

    # Validate that delegate methods are defined as an array or hash ref
    if (exists $param{fwd}) {
      croak "delegate forwarding for $name must be expressed as an array ref or hash ref"
        if ref($param{fwd}) !~ /^(?:ARRAY)|(?:HASH)$/;

      if (ref $param{fwd} eq 'ARRAY') {
        my %tmp;
        $tmp{$_} = $_ for @{$param{fwd}};
        $param{fwd} = \%tmp;
      }
    }

    $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 fwd)) {
      $CLASS{$caller}{slot}{$name}{$_} = $param{$_}
        if exists $param{$_};
    }

    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;
  }
}

#-------------------------------------------------------------------------------
# Delegate methods
#-------------------------------------------------------------------------------
sub _build_delegates {
  my ($class, $name) = @_;
  my $slot = $class->get_slots($name);
  return '' unless exists $slot->{fwd};

  my $fwd   = $slot->{fwd};
  my $line  = qq{# line $slot->{line} "$slot->{file}"};
  my $ident = quote_identifier($name);
  my $code  = '';

  for (keys %$fwd) {
    my $local_method  = quote_identifier($_);
    my $remote_method = quote_identifier($fwd->{$_});
    $code .= "$line\nsub $local_method { shift->${ident}->${remote_method}(\@_) }";
  }

  return $code;
}

#-------------------------------------------------------------------------------
# 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.09';
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__