view release on metacpan or  search on metacpan

Damn.pm  view on Meta::CPAN

package Acme::Damn;

use 5.000;
use strict;
use warnings;

use Exporter;
use DynaLoader;

use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK );

  $VERSION    = '0.09';
  @ISA        = qw( Exporter DynaLoader );
  @EXPORT     = qw( damn                );
  @EXPORT_OK  = qw( bless               );

# ensure we aren't exposed to changes in inherited AUTOLOAD behaviour
*Acme::Damn::AUTOLOAD   = *DynaLoader::AUTOLOAD;


sub import
{
  my  $class    = shift;

  # check the unknown symbols to ensure they are 'safe'
  my  @bad      = grep { /\W/o } @_;
  if ( @bad ) {
    # throw an error message informing the user where the problem is
    my  ( undef, $file , $line )    = caller 0;

    die sprintf( "Bad choice of symbol name%s %s for import at %s line %s\n"
                 , ( @bad == 1 ) ? '' : 's'
                 , join( ', ' , map { qq|'$_'| } @bad ) , $file , $line );
  }

  # remove duplicates from the list of aliases, as well as those symbol
  # names listed in @EXPORT
  #   - we keep @EXPORT_OK in a separate list since they are optionally
  #     requested at use() time
  my  @aliases  = do {  local %_;
                              @_{ @_         } = undef;
                       delete @_{ @EXPORT    };
                         keys %_
                     };

  # 'import' the symbols into the host package
  #   - ensure 'EXPORT_OK' is correctly honoured
  my    %reserved   = map { $_ => 1 } @EXPORT , @EXPORT_OK;
  my    @reserved   = ();
  my  ( $pkg )      = caller 1;
  foreach my $alias ( @aliases ) {
    # if this alias is a reserved symbol as defined by @EXPORT et al.
    # then add it to the list of symbols to export
        $reserved{ $alias }
    and push @reserved , $alias
    and next;

    # otherwise, create an alias for 'damn'
    no strict 'refs';

    *{ $pkg . '::' . $alias } = sub {
        my    $ref                      = shift;
        my  ( undef , $file , $line )   = caller 1;

        # call damn() with the location of where this method was
        # originally called
        &{ __PACKAGE__ . '::damn' }( $ref , $alias , $file , $line );

        # NB: wanted to do something like
        #         goto \&{ __PACKAGE__ . '::damn' };
        #     having set the @_ array appropriately, but this caused a
        #     "Attempt to free unrefernced SV" error that I couldn't solve
        #     - I think it was to do with the @_ array
      };
  }

  # add the known symbols to @_