view release on metacpan or  search on metacpan

lib/Attribute/GlobalEnable.pm  view on Meta::CPAN

package Attribute::GlobalEnable;

our $VERSION = '0.1';

use strict;
use warnings;
use Attribute::Handlers;
use Carp qw( croak );
use base qw( Exporter );
use Time::HiRes qw( time );


## hold the switch settings for each module, method etc. (see above)
my $ENABLE_CHK      = {};

## set the hash for the Debug attribute and the key for the hash ##
my $ENABLE_ATTR     = {};

## hold flag definitions.
my $ENABLE_FLAG     = {};

## hold our current package (our sub-package name really)
my $PACKAGE         = '';

## mark this as true once we've automatically loaded all the stuff.  It's
## once true, other packages that load this module will ONLY get the 
## symbols exported.
my $DONE_INIT       = 0;



##
## import is an auto sub... happens when you... well... import.  In our case
## it automatically exports our attribute functionality to the properr places.
## The first time it runs should be when it is initialized.  After this
## initialization process, it will only export the proper symbols (checks
## $DONE_INIT).
##
## this should return true if it is successfull... it should bail otherwise.
sub import {
  return _export_my_attribute_symbols() if $DONE_INIT;
  my $class = shift();
  croak "Must specify some arguments." if not @_;
  my $args  = {@_};

  ## set the package to the caller
  $PACKAGE = caller();
  croak "Must sub-package ".$PACKAGE if not $PACKAGE or $PACKAGE eq __PACKAGE__;

  ## make sure our sub-packaged module is using the exporter
  _export_the_exporter_to( $PACKAGE ) or die "Bad exporting exporter";

  ## check to make sure ENABLE_CHK exists, and is a hashref ##
  if ( not $args->{ENABLE_CHK} or ref $args->{ENABLE_CHK} ne 'HASH' ) {
    croak "ENABLE_CHK needs to be set with a hash ref for this module "
      ."to be used.";
  }

  ## build the enabled attributes and store internally
  _check_and_build_enable_attr($args) or die "bad ENABLE_ATTR";

  ## handle the flags array and store internally.
  _check_and_build_enable_flags($args) or die "Bad ENABLE_FLAGS";

  ## convert the checks from the passed in hash to our internal hash ##
  _build_enable_chks($args) or die "Bad ENABLE_CHK";

  ## build and export the attribute functions
  _build_attr_exports() or die "Bad build ATTR exports";

  ## export the proper subs to the package that init'd this ##
  _export_my_attribute_symbols();

  return $DONE_INIT++;
}





sub _export_the_exporter_to {
  my $package = shift();

  my $eval_str = "{ package $package; use Exporter; use base qw( Exporter ); }";
  eval $eval_str;
  _eval_die($eval_str, $@) if $@;

  return 1;
}




sub _build_attr_exports {
  ## set the proper attribute functions to point to our internal handler ##
  foreach my $attribute ( keys %$ENABLE_ATTR ) {

    ## set the attribute function to our internal one ##
    my $eval_str = "sub UNIVERSAL::$attribute : ATTR(CODE) { return "
      . __PACKAGE__ ."::My_attr_handler(\@_) }";

    eval $eval_str;
    _eval_die( $eval_str, $@) if $@;

    ## set exporting for each attribute as well so that we can get imported
    ## $attributes as function calls.
    $eval_str = "push \@${PACKAGE}::EXPORT_OK, \$attribute; "

lib/Attribute/GlobalEnable.pm  view on Meta::CPAN

}


sub _is_attribute_on {
  my $attribute = shift();
  my $package   = shift();
  my $chk       = shift();
  my $debug_str = $ENABLE_ATTR->{$attribute};

  ## if ALL debugging is on or if package specific debugging is on
  ## or if function specific debugging is on.
  my $debug_level = 0;
  if ( $ENABLE_CHK->{$attribute}->{"ALL_$debug_str"} ) {
    $debug_level = $ENABLE_CHK->{$attribute}->{"ALL_$debug_str"};
  } elsif ( $ENABLE_CHK->{$attribute}->{"${debug_str}_$chk"} ) {
    $debug_level = $ENABLE_CHK->{$attribute}->{"${debug_str}_$chk"};
  } elsif ( $ENABLE_CHK->{$attribute}->{"${debug_str}_$package"} ) {
    $debug_level = $ENABLE_CHK->{$attribute}->{"${debug_str}_$package"};
  }

  return $debug_level;
}


##
## this is a basic method for generating the wrapped debug sub.
## it's looking for the debug_$debug_level subroutine.  It'll crap out
## if it can't find it.  It starts looking for whatever level it's set at,
## and walks down one by one till it finds an applicable debug sub. 
sub _generate_attr_sub {
  my $debug_level = pop @_;
  my $attribute   = $_[3];

  while ( $debug_level ) {
    my $debug_sub = join( "_", "attr${attribute}", $debug_level--);
    return $PACKAGE->$debug_sub( @_ ) if $PACKAGE->can( $debug_sub );
  }

  ## crap out if we reach here cause there's no debug level for this ##
  die "I couldn't find a debug level at or below the one set.";
}


##
## this handles the static function calls that are exported to each package
## that wishes to use them.  It checks to see if the proper flags are set
## for it do run the user built function.  if not, it does nothing.
sub my_static_handler {
  my $attribute   = shift();
  my $flag        = shift();

  ## checks to see if this debug level is set by a flag being passed in.  If
  ## the flag doesn't exist in our flags hash, then we can assume that
  ## the flag variable isn't actually a flag, and is probably part of the
  ## debug arguments... so put it back onto our args list.
  my $debug_level = _is_flag_on($attribute, $flag);
  if( not defined $debug_level ) {
    unshift( @_, $flag ) if not defined $debug_level;
  }

  my $full_package = (caller(2))[3];

  my $caller_sub_name     = '';
  GET_PROPER_PACKAGE_NAME: {
    my @packages     = split /::/, $full_package;
    pop @packages;
    $caller_sub_name = join '::', @packages;
  }

  $debug_level = _is_attribute_on(
    $attribute,
    $full_package,
    $caller_sub_name
  ) if not $debug_level;

  return if not $debug_level;


  ## we've got our debug level at this point, but we need to make sure that
  ## there is an associated debug sub that matches the level.  If not, then
  ## we'll skip down till we find one.
  my $executable;
  while ( $debug_level ) {
    $executable = $PACKAGE->can( "our${attribute}_". $debug_level--);
    last if defined $executable;
  }

  return if not defined $executable;
      
  return &$executable(@_);
}


sub _is_flag_on {
  my $attribute = shift();
  my $flag      = shift() or return undef;

  return undef if not defined $ENABLE_FLAG->{$attribute}->{$flag};

  return $ENABLE_CHK->{$attribute}->{$ENABLE_ATTR->{$attribute} . "_$flag"} || 0;
}



##
##
## EEE  OOOO FFFF
##
##

=pod

=head1 NAME

Attribute::GlobalEnable - Enable Attrubutes and flags globally across all code.

=head1 SYNOPSIS

  package Attribute::GlobalEnable::MyPackage;
  
  use Attibute::GlobalEnable(