Acme-Damn

 view release on metacpan or  search on metacpan

Damn.pm  view on Meta::CPAN

*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

t/3aliases.t  view on Meta::CPAN

	my	$string	= "$ref";

	# bless the reference and the "unbless" it
		bless $ref;
		lives_ok  { $alias->( $ref ) } "$alias executes successfully";

	# make sure the stringification is correct
		ok( $ref eq $string , "$alias executes correctly" );
	
  # make sure the error message correctly reports the alias
		throws_ok { $alias->( $ref ) }
              "/can only $alias/" ,
		          "$alias exception thrown successfully";
}

t/4name.t  view on Meta::CPAN

                       expel proscribe recant renounce unbless ); }

# load Acme::Damn
use Acme::Damn @aliases;

foreach my $alias ( @aliases ) {
	no strict 'refs';

	# attempt to unbless a normal reference so that we can test the error
	# messages
		throws_ok { $alias->( [] ) } "/can only $alias/" ,
		                             "$alias exception thrown successfully";
}

t/5bad.t  view on Meta::CPAN

use strict;
use Test::More	tests => 3;
use Test::Exception;

# load Acme::Damn
use Acme::Damn;

# make sure Acme::Damn::import() dies if the unknown symbol has "bad"
# characters in it (i.e. non-word characters, such as ':')
foreach my $name ( qw( foo::bar foo-bar foo.bar ) ) {
  throws_ok { Acme::Damn->import( $name ) }
            "/Bad choice of symbol/" ,
            "$name exception thrown successfully";
}

t/6bless.t  view on Meta::CPAN

my  $scalar = 0;

# set the patterns for matching bless exceptions
my  $x      = qr/Can't bless non-reference value/;
my  $c      = qr/Modification of a read-only value attempted/;

# ensure the new bless() exhibits the same live/die behaviour as the
# built-in function
  dies_ok { eval "bless"   or die }      "bless() dies with no arguments";
  dies_ok { eval "bless()" or die }      "bless() dies with no arguments";
throws_ok { bless 1               } $x , "bless() dies with numerical argument";
throws_ok { bless '2'             } $x , "bless() dies with string argument";
throws_ok { bless *STDOUT         } $x , "bless() dies with glob argument";
throws_ok { bless undef           } $x , "bless() dies with undefined argument";
throws_ok { bless \1              } $c , "bless() dies with constant reference";
throws_ok { bless \'2'            } $c , "bless() dies with constant reference";
throws_ok { bless @array          } $x , "bless() dies with array variable";
throws_ok { bless %hash           } $x , "bless() dies with hash variable";
throws_ok { bless $scalar         } $x , "bless() dies with scalar variable";
 lives_ok { bless []              }      "bless() lives with array reference";
 lives_ok { bless {}              }      "bless() lives with hash reference";
 lives_ok { bless sub {}          }      "bless() lives with code reference";
 lives_ok { bless qr/./           }      "bless() lives with regex reference";
 lives_ok { bless \*STDOUT        }      "bless() lives with glob reference";

# ensure we can't bless into a reference
throws_ok { bless [] , [] } qr/Attempt to bless into a reference/
        , "bless() throws correct error with reference argument";


# ensure bless() works with a named package
#   - if the package name is '' then we default to 'main'
my  %try    = ( ''         => 'main'
              , 'main'     => 'main'
              , 'foo'      => 'foo'
              , 'foo::bar' => 'foo::bar'
              );
my  @try    = ( \$scalar