File Coverage

blib/lib/Class/Declare/Attributes.pm

Criterion	Covered	Total	%
statement	413	490	84.2
branch	17	30	56.6
condition	32	296	10.8
subroutine	122	151	80.7
pod	1	1	100.0
total	585	968	60.4

# $Revision: 1515 $
package Class::Declare::Attributes;

use 5.006;
use strict;
use warnings;
use attributes;

use Class::Declare  qw( :modifiers );
use File::Spec::Functions       qw();
use base qw( Class::Declare        );
use vars qw( $VERSION $REVISION    );

    $VERSION      = '0.10';
    $REVISION     = '$Revision: 1515 $';

# need to copy the export symbols from Class::Declare
# to permit Class::Declare::Attributes to provide attribute modifiers
    *EXPORT_OK    = *Class::Declare::EXPORT_OK;
    *EXPORT_TAGS  = *Class::Declare::EXPORT_TAGS;


# declare the 'attributes' helper routines
BEGIN {

  # define the attributes that are wrapped by this class
  my  %__ATTR__ = map { $_ => 1 } qw( abstract
                                      class
                                      restricted
                                      static
                                      public
                                      protected
                                      private    );

  # suppress the warnings surrounding the use of attributes that may be
  # reserved for future use
  #   - this is naughty ... oh, well ... can be changed if necessary
  #   - we want to suppress this warning without disabling all warnings
  #   - we previously set $^W to 0, but this is very heavy handed, so
  #     let's try the following
  $SIG{__WARN__}  = sub {
    # if we detect a violation caused by C::D::A, then suppress it,
    # otherwise let it through
    my  $pkg    = __PACKAGE__;
    ( $_[0] =~ /attribute may clash .+? reserved word: (\w+)/o ||
      $_[0] =~ /^Declaration of (\w+) .+? package $pkg .+? reserved word/o )
        # ensure the attribute belongs to C::D::A
        and ( $__ATTR__{ $1 } )
        and return 1; # do nothing

    # otherwise, return the standard warn() response
    warn $_[0];
  };  # $SIG{__WARN__}()


  # keep a log of calls made to set the attributes
  my  %__PKGS__ = ();
  my  %__DONE__ = ();


# MODIFY_CODE_ATTRIBUTES()
#
# Keep a reference of the and type of attribute for each method specified as
#
#     sub method : type { ... }
#
sub MODIFY_CODE_ATTRIBUTES
{
  my  ( $pkg , $ref , @attr )   = @_;

  # only consider the attributes that we know about
  my    @unknown;   undef @unknown;
  foreach my $attr ( @attr ) {
    # if this not an attribute we care about, then add it to the list of
    # attributes to return
    push @unknown , $attr
      and next                unless ( exists $__ATTR__{ $attr } );

    # have we already assigned one of our attributes to this target?
    #   - if we have, then we should raise an error
    if ( defined ( my $previous =  $__PKGS__{ $pkg }->{ $ref } ) ) {
      # if this reference has already been assigned one of our attributes,
      # then we have a problem if we are attempting to now assign a different
      # attribute
      #   - something declared with the same attribute twice is not a problem
      #     as we just ignore the subsequent assignment
      next              if ( $previous eq $attr );

      # two conflicting attribute assignments
      die "conflicting CODE attribute assignments of '$previous' "
        . "and '$attr' in $pkg";
    }

    # store this attribute assignment
    $__PKGS__{ $pkg }->{ $ref } = $attr;

    # assign the CORE 'method' attribute to this reference as well
    #   - each code reference assigned a Class::Declare::Attributes interface
    #     is also actually a method
            attributes::->import( CORE => $ref => 'method' );
  }

  # if we have any unknown attributes, then return them
  return @unknown         if ( @unknown );

  # otherwise, there's nothing more to do
  return;
} # MODIFY_CODE_ATTRIBUTES()


# FETCH_CODE_ATTRIBUTES()
#
# Return the type of attribute for the given package and reference
sub FETCH_CODE_ATTRIBUTES
{
  my  ( $pkg , $ref )   = @_;

  # if this is known package and reference, then return its attributes
  return $__PKGS__{ $pkg }->{ $ref };
} # FETCH_CODE_ATTRIBUTES()



# __init__()
#
# Initialise the code wrapping for Class::Declare-style methods
#   - this needs to be called either at INIT time or when declare() is called
#     to ensure dynamically loaded modules are handled correctly and the
#     strict() setting is obeyed
sub __init__
{
  my  $self   = __PACKAGE__->static( shift );
  my  @pkg    = ( defined $_[0] ) ? ( $_[0] ) : keys %__PKGS__;

  # iterate through the given package(s)
  foreach my $pkg ( @pkg ) {
    no strict 'refs';

    # do we have strict checking for this package on?
    my  $strict = $pkg->strict;

    # if we have strict checking off and we've seen this package before
    # then we should ensure we 'unnwrap' all wrapped routines
    unless ( $strict ) {
      if ( my $wrapped = delete $__DONE__{ $pkg } ) {
        while ( my ( $glob , $ref ) = each %{ $wrapped } ) {
          no warnings 'redefine';

          *{ $glob }  = $ref;
        }
      }

      # no point proceeding, since we don't have strict checking on
      return;
    }

    # iterate through the symbol tree of this package
    my  $pkg_   = $pkg . '::';
    my  @names  = keys %{ $pkg_ };
    foreach my $name ( @names ) {
      no warnings 'once';

      # if we don't have a normal symbol table entry, then skip
      #   - occasionally we will find a reference here not a GLOB
      my  $sym  = ${ $pkg_ }{ $name };
               ( ref $sym )                 and next;

      # if we don't have a CODE reference then we can't proceed
      my  $ref  = *{ $sym }{ CODE }           or next;
      my  @attr = grep { defined } attributes::get( $ref );

      # filter attributes that don't belong to the list fo C::D attributes
          @attr = grep { defined } grep { $__ATTR__{ $_ } } @attr;

      # if there are no attributes, then there's nothing to do
        ( @attr )                             or next;

      # extract the name of this subroutine
      my  $glob = $pkg_ . $name;

      # if we have strict access checking, then "wrap" this routine
      if ( $strict ) {
        no warnings 'redefine';

        my  $type   = $attr[0];
         *{ $glob } = sub { $pkg->$type( $_[0] , $glob ); goto $ref };

        # make note that this method has been wrapped
        #   - store the original CODE reference for this glob
        $__DONE__{ $pkg }->{ $glob }  = $ref;
      }
    }
  }
} # __init__()

} # BEGIN()


# require()
#
# Load the given class using Perl's require(), ensuring __init__() is called
# after the class has been successfully loaded. This is to ensure the correct
# subroutine wrappers are put in place.
#
# If the given class contains ';' then we assume that it's the string of the
# class rather than the filename, so we simply eval() that, rather than trying
# to load it from the filesystem.
sub require : class
{
  my  $self   = shift;
  # if there's no class then there's nothing to do
  my  $class  = shift                   or return undef;

  # do we have a file or the text of the class?
  if ( $class =~ m/;/o ) {
    # we assume we have the body of a class, so we just eval() it
    eval $class;

  # otherwise we have to load the file from disk
  } else {
    # convert the class into a file name
    my  $file   = File::Spec::Functions::catfile( split '::' , $class ) . '.pm';

    # attempt to load the file
    #   - return undef if there's a problem
    eval { require $file };
  }

  # if there were any problems, then we should fail
    ( $@ )                             and return undef;

  # if we've loaded this class, then ensure __init__() is called
      $self->__init__;

  1;  # everything is OK
} # require()


# for modules loaded by use(), ensure __init__() is called prior to code
# execution
INIT { __PACKAGE__->__init__ }


1;  # end of module
__END__