view release on metacpan or  search on metacpan

lib/Object/Pad.pm  view on Meta::CPAN

sub _import_experimental
{
   shift;
   my ( $syms, @experiments ) = @_;

   my %enabled;

   my $i = 0;
   while( $i < @$syms ) {
      my $sym = $syms->[$i];

      if( $sym eq ":experimental" ) {
         carp "Enabling all Object::Pad experiments with an unqualified :experimental";
         $enabled{$_}++ for @experiments;
      }
      elsif( $sym =~ m/^:experimental\((.*)\)$/ ) {
         foreach my $tag ( split m/\s+/, $1 =~ s/^\s+|\s+$//gr ) {
            if( $tag eq ":all" ) {
               $enabled{$_}++ for @experiments;
            }
            else {
               $enabled{$tag}++;
            }
         }
      }
      else {
         $i++;
         next;
      }

      splice @$syms, $i, 1, ();
   }

   foreach ( @experiments ) {
      $^H{"Object::Pad/experimental($_)"}++ if delete $enabled{$_};
   }

   croak "Unrecognised :experimental features @{[ keys %enabled ]}" if keys %enabled;
}

sub _import_configuration
{
   shift;
   my ( $syms ) = @_;

   # Undocumented options, purely to support Feature::Compat::Class adjusting
   # the behaviour to closer match core's  use feature 'class'

   my $i = 0;
   while( $i < @$syms ) {
      my $sym = $syms->[$i];

      if( $sym =~ m/^:config\((.*)\)$/ ) {
         foreach my $opt ( split m/\s+/, $1 =~ s/^\s+|\s+$//gr ) {
            if( $opt =~ m/^(only_class_attrs|only_field_attrs)=(.*)$/ ) {
               # Store an entire sub-hash inside the hints hash. This won't
               # survive squashing into a COP for runtime but we only need it
               # during compile so that's OK
               my ( $name, $attrs ) = ( $1, $2 );
               $^H{"Object::Pad/configure($name)"} = { map { $_ => 1 } split m/,/, $attrs };
            }
            else {
               $^H{"Object::Pad/configure($opt)"}++
            }
         }
      }
      else {
         $i++;
         next;
      }

      splice @$syms, $i, 1, ();
   }
}

sub import_into
{
   my $class = shift;
   my $caller = shift;

   $class->_import_experimental( \@_, qw( init_expr mop custom_field_attr adjust_params composed_adjust inherit_field apply_phaser lexical_class ) );

   $class->_import_configuration( \@_ );

   my %syms = map { $_ => 1 } @_;

   # Default imports
   unless( %syms ) {
      $syms{$_}++ for qw( class role inherit apply method field has requires BUILD ADJUST APPLY );
   }

   delete $syms{$_} and $^H{"Object::Pad/$_"}++ for qw( class role inherit apply method field has requires BUILD ADJUST APPLY );

   croak "Unrecognised import symbols @{[ keys %syms ]}" if keys %syms;
}

# The universal base-class methods

sub Object::Pad::UNIVERSAL::BUILDARGS
{
   shift; # $class
   return @_;
}

# Back-compat wrapper
sub Object::Pad::MOP::SlotAttr::register
{
   shift; # $class
   croak "Object::Pad::MOP::SlotAttr->register is now removed; use Object::Pad::MOP::FieldAttr->register instead";
}

=head1 WITH OTHER MODULES

=head2 Syntax::Keyword::Dynamically

A cross-module integration test asserts that C<dynamically> works correctly
on object instance fields:

   use Object::Pad;
   use Syntax::Keyword::Dynamically;