File Coverage

blib/lib/Class/Declare/Hash.pm

Criterion	Covered	Total	%
statement	91	92	98.9
branch	25	32	78.1
condition	17	32	53.1
subroutine	7	7	100.0
pod	1	1	100.0
total	141	164	85.9

#!/usr/bin/perl -Tw

# $Id: Hash.pm 1518 2010-08-22 23:56:21Z ian $
package Class::Declare::Hash;

use strict;

=head1 NAME

Class::Declare::Hash - generate a hash of accessible attributes

=head1 SYNOPSIS

This module should not be used directly; it is a helper module for
L, providing the B routine.

=cut


use base  qw( Class::Declare     );
use vars  qw( $REVISION $VERSION );

  $REVISION = '$Revision: 1518 $';
  $VERSION  = '0.20';	# Class::Declare->VERSION;


=head1 DESCRIPTION

B adds a detailed B method to L,
allowing retrieval of an attribute/value hash representing a given
L derived object. This method is only installed (and indeed,
this module only compiled) if B is called on a
L-derived object or package.

=cut
{ # closure for hash() related methods and variables

  #
  # Closure variables
  #

  # references to subroutines that permit access to some of the
  # Class::Declare data structures use to marshal objects and classes
  my  $__GET_ATTRIBUTES__;  undef $__GET_ATTRIBUTES__;
  my  $__GET_VALUES__;      undef $__GET_VALUES__;
  my  $__GET_FRIENDS__;     undef $__GET_FRIENDS__;


  # __init__()
  #
  # __init__() is used to obtain references to anonymous subroutines that
  # give access to the %__ATTR__, %__FRIEND__ and %__DEFN__ hashes of
  # Class::Declare. See the comment in Class::Declare::hash() for an
  # explanation.
  sub __init__ : method
  {
    my  $class  = __PACKAGE__->class( shift );
    # what's our method name?
    my  $sub    = ( caller 1 )[ 3 ];

    # make the reference assignment (only if it hasn't been done
    # before)
    $__GET_ATTRIBUTES__ = $_[ 0 ] unless ( defined $__GET_ATTRIBUTES__ );
    $__GET_VALUES__     = $_[ 1 ] unless ( defined $__GET_VALUES__     );
    $__GET_FRIENDS__    = $_[ 2 ] unless ( defined $__GET_FRIENDS__    );

    1;  # that's all: hack complete :)
  }


  # %__REFERENCES__
  #
  # Store attribute references for showing equality in the hash.
  my  %__REFERENCES__;  undef %__REFERENCES__;

  # %__CALLER__
  #
  # Store the caller information for the original call to hash()
  my  %__CALLER__;      undef %__CALLER__;


  #
  # Closure methods
  #

  # $__permission__()
  #
  # For a given caller stack (as stored by $__save__() below) and target
  # object (passed in as the first argument), determine if we have a given
  # permission (e.g. public, private, protected, etc). Return true if we
  # do, false otherwise.
  #
  # NB: these routines have been lifted directly from Class::Declare.
  my  $__permission__ = sub { #  =>
      my  $type   = shift;  # the access control type
      my  $target = shift;  # the object of interest
      my  $class  = shift;  # the target class

      # NB: the target class is not necessarily the same class as the
      #     target since methods/attributes may be inherited, in which
      #     case they belong to a different class

      # we need to know the calling context for this permission test -
      # this will either be passed in as the third argument, or we can
      # take it from the original calling context

      # first, we must be certain that the target is derived from
      # Class::Declare
      return undef      unless ( UNIVERSAL::isa( $target          ,
                                                 'Class::Declare' ) );

      # if we're testing class or abstract attributes, then that's all we need
      return 1              if ( $type eq 'class'    );
      return 1              if ( $type eq 'abstract' );

      # if we're testing public attributes, then return true if this
      # is a reference to an object
      return ref( $target ) if ( $type eq 'public' );

      # OK, from here we're dealing with either restricted, protected,
      # static or private attributes

      # get the friends of the target class
      my  $friend = $__GET_FRIENDS__->( $class ) || {};

      # if the caller is not in the same or a derived package, or is
      # not a friend, then we can't proceed
      my  $caller = $__CALLER__{ package    };
      my  $sub    = $__CALLER__{ subroutine };
      return undef  unless (    UNIVERSAL::isa( $caller , $class  )
                             || UNIVERSAL::isa( $class  , $caller )
                             || $caller && exists $friend->{ $caller }
                             || $sub    && exists $friend->{ $sub    }
                           );

      # OK, if we're looking for restricted attributes we're done
      return 1              if ( $type eq 'restricted' );

      # if we're looking for protected attributes, then we need a
      # reference to return true
      return ref( $target ) if ( $type eq 'protected' );

      # if the class is the same as the defining class then we can
      # access static/private attributes, otherwise fail
      return undef    unless (            $class   eq  $caller
                               ||         $class->isa( $caller )
                               || exists $friend->{    $caller }
                               || exists $friend->{    $sub    } );

      # that's all we need to check for static attributes
      return 1              if ( $type eq 'static' );

      # otherwise, we need to make sure we have a reference for
      # private attributes
      return ref( $target ) if ( $type eq 'private' );

      return undef; # permission denied
    }; # $__permission__()


  # # $__save__()
  #
  # Save original calling state.
  my  $__save__ = sub { #
      # need to store the original caller stack so that hash()
      # can determined public(), private(), etc rights for the
      # calling routine/context
      $__CALLER__{ package    } = ( caller 1 )[ 0 ];
      $__CALLER__{ subroutine } = ( caller 2 )[ 3 ];

      # reset the references store
      undef %__REFERENCES__;
    }; # $__save__()


  # $__clear__()
  #
  # Clear original calling state.
  my  $__clear__  = sub {
      # clear the caller stack
      %__CALLER__ = ();

      # reset the references store
      undef %__REFERENCES__;
    }; # $__clear__()


  # $__hash__()
  #
  # Perform a recursive hash() expansion for a given value
  my  $__hash__;
      $__hash__   = sub { #  ,  ,
      my  $r          = shift;
      my  $depth      = shift;

      # if depth is zero, then return the value we have
      return $r       unless ( ! defined $depth || $depth > 0 );

      # if the value is undefined, then return undefined
      return undef    unless (   defined $r );

      # if we don't have a reference, then return the supplied value
      return $r       unless (       ref $r );

      # reduce the depth (if defined)
          $depth--        if (   defined $depth );

      # we have a reference value
      #   - if it's an object derived from Class::Declare, then we should
      #     call its hash() method and perform a recursive expansion
      #   - if it's an ARRAY or HASH, we should iterate through its values
      #     and attempt to expand them (if possible)
      foreach ( ref $r ) {
        # array
        /^ARRAY$/o  && do {
          my  $ref  = [];
          push @{ $ref } , scalar $__hash__->( $_ , $depth , @_ )
                                                        foreach ( @{ $r } );

          # return the generated array
          return $ref;
        };

        # hash
        /^HASH$/o   && do {
          my  $ref          = {};
          while ( my ( $k , $v ) = each %{ $r } ) {
              $ref->{ $k }  = $__hash__->( $v , $depth , @_ )
          }

          # return the generated hash
          return $ref;
        };

        # are we dealing with a Class::Declare object that supports the hash()
        # method?
        #   - if so, recurse through that
            UNIVERSAL::isa( $r , 'Class::Declare' )
        and UNIVERSAL::can( $r , 'hash'           )
        and return scalar $r->hash( @_ , depth => $depth );
      }

      # if we've made it this far, then simply return the value passed in
      return $r;
    };  # $__hash__()


# jump into the Class::Declare namespace to create the dump() routine
package Class::Declare;


# hash()
#
# Generate a textual representation of the object/class
sub hash : method
{
  my  $self   = Class::Declare->class( shift );
  my  $class  = ref( $self ) || $self;

  # OK, parse the arguments
  my  $_args  = $self->arguments( \@_ => { public     => undef ,
                                           private    => undef ,
                                           protected  => undef ,
                                           class      => undef ,
                                           static     => undef ,
                                           restricted => undef ,
                                           abstract   => undef ,
                                           depth      => undef ,
                                           backtrace  => 1     ,
                                           all        => 1     } );

  # have we been called from outside this file
  # i.e. is this a non-recursive call (first call)
  my  $outside  = ( caller )[ 1 ] ne __FILE__;

  # if we're called from outside this file (i.e. it's not an
  # internal recursive call to hash()) then make
  # note of the arguments and the context
    $__save__->( $self , $_args ) if ( $outside );

  # store the current depth limit
  my  $depth    = delete $_args->{ depth };

  # unset 'all' if any of the other arguments have been set
  ( $_args->{ $_ } )
    and delete $_args->{ all }
    and last
      foreach ( qw( public private protected  abstract
                    class  static  restricted          ) );

  # if we have asked for nothing, then return undef
  return undef    unless ( grep { defined }
                                map { $_args->{ $_ } }
                                    qw( public private protected  abstract
                                        class  static  restricted all      ) );

  # next, we need to check to ensure the user has permission to access the
  # specified attribute types for the given object
  #   - this test should only be done at the top level
  if ( $outside ) {
    # make sure we have permission to access the specified attribute types
    # or raise a fatal error (in keeping with the behaviour of
    # Class::Declare
    ( $__permission__->( $_ => $self => ref( $self ) || $self )
    # also, if we don't have a reference, then we should raise an error
    # if instance attributes have been requested
      && ( ref( $self ) || !/^public$/o
                        && !/^private$/o
                        && !/^protected$/o ) )
      or do {
        # find out where the call to dump() was made
        my  ( undef , $file , $line , $sub )  = caller 0;

        # die with an informative error message
        die "access to $_ attributes denied in call to "
            . "$sub() at $file line $line\n";
      } foreach ( grep { $_args->{ $_ } }
                       grep {    !/all/o
                              && !/backtrace/o
                            } keys %{ $_args } );
  }

  # determine the attribute types that may be returned/have been requested
  # NB: if required, as this is first calculated during the
  #     top-level call to hash()
  my  @types  = qw( abstract class  static  restricted
                             public private protected  );
      @types  = grep { $_args->{ $_ } } @types  unless ( $_args->{ all } );

  # generate the combined @ISA array for this class
  my  @isa  = ( $class );
  my  $i    = 0;
  while ( $i <= $#isa ) {
    no strict 'refs';

    my  $pkg  = $isa[ $i++ ]  or next;
    push @isa , @{ $pkg . '::ISA' };
  }
  # remove the duplicates and reverse
    @isa  = local %_ || grep { ! $_{ $_ }++ } reverse @isa;

  # construct the list of public, private, class, etc attributes
  # for this class (taking into account inheritance)
  my  %map; undef %map;
  ISA: foreach my $isa ( @isa ) {
    my  $ref  = $__GET_ATTRIBUTES__->( $isa )   or next ISA;

    while ( my ( $k , $v ) = each %{ $ref } ) {
      $map{ $_ }  = { type => $k , class => $isa }  for ( @{ $v } );
    }
  }
  # now build a reverse map of type to attribute
  my  %rmap;  undef %rmap;
  foreach my $attr ( keys %map ) {
    my  $type = $map{ $attr }->{ type };

    push @{ $rmap{ $type } } , $attr;
  }

  # define a map for determining if a given attribute may be accessed
  # through the given object/class
  # NB: this takes into account the class defining the attribute, not
  #     just the class/object trying to access it
  my  $perm = sub {
      my  $object = shift;
      my  $attr   = shift;

      # extract the attribute type and the class defining the
      # attribute
      my  ( $type , $class )  = map { $map{ $attr }->{ $_ } }
                                    qw( type class );

      return $__permission__->( $type => $object => $class );
    }; # $perm()

  # get the object/class hash for this target
  #   - if we have an object, simply pass the object
  #   - otherwise, if we have a class, loop through all classes in its
  #       @ISA array
  my  $hash = ( ref $self ) ? $__GET_VALUES__->( $self )
                            : { map { %{ $_ } }
                                    grep { defined }
                                         map { $__GET_VALUES__->( $_ ) }
                                             @isa
                              };

  # generate the return hash
  my  %rtn;   undef %rtn;

  HASH: foreach my $type ( grep { exists $rmap{ $_ } } @types ) {
    # print the attribute values we have access to
    ATTR: foreach my $attr ( sort grep { $perm->( $self => $_ ) }
                                       map { @{ $_ } }
                                           grep { defined }
                                                $rmap{ $type } ) {

      # what value do we have?
      my  $v            = $hash->{ $attr };

      # if this is a reference
      if ( ref $v ) {
        # if we have backtrace turned on, then check to see if we have
        # seen this reference before
        my  $r          = $__REFERENCES__{ $v };

        # if we've not seen this reference before, then we should attempt
        # to expand it
        unless ( defined $r ) {
          # if we have not reached our depth limit, then recurse if we need to
          #   - if the depth has not been given, then we descend as far
          #     as we can
          #   - NOTE: this is a change in default behaviour since v0.08
          if ( ! defined $depth || $depth > 0 ) {
            # generate the expansion of this value
            #   - decrement the depth count
            #$depth--      if ( defined $depth );
            $r          = $__hash__->( $v , $depth , %{ $_args } );
          }

          # if we don't have a reference, then use the original value
            $r        ||= $v;

          # the value we have now is all we are going to get for this
          # attribute, so make sure it's stored (if we have backtracing turned
          # on)
            $__REFERENCES__{ $v } =  $r     if ( $_args->{ backtrace } );
        }

        # use whatever expansion we have obtained
          $v            = $r;
      }

      # record the expansion for this attribute
          $rtn{ $attr } = $v;
    }
  }

  # if this is the final exit of hash() (i.e. this execution frame
  # corresponds to the original invocation of hash() and not an internal
  # recursive call, then we should clear the saved state information
    $__clear__->()    if ( $outside );

  # do we want a hash, or a has reference?
  return ( wantarray ) ? %rtn : \%rtn;
} # hash()

} # end hash() closure


=head1 SEE ALSO

L

=head1 AUTHOR

Ian Brayshaw, [e-mail]

=head1 COPYRIGHT AND LICENSE

Copyright 2003-2016 by Ian Brayshaw. All rights reserved.

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

############################################################################
1;  # end of module
__END__