File Coverage

lib/Test/Classy/Base.pm

Criterion	Covered	Total	%
statement	198	202	98.0
branch	64	72	88.8
condition	6	10	60.0
subroutine	35	36	97.2
pod	6	6	100.0
total	309	326	94.7

package Test::Classy::Base;

use strict;
use warnings;
use base qw( Class::Data::Inheritable );
use Test::More ();
use Data::Dump;
use Class::Inspector;
use Encode;
use Term::Encoding;
use Test::Classy::Util;

my $ENCODE = eval { find_encoding(Term::Encoding::get_encoding()) };

sub import {
  my ($class, @flags)  = @_;
  my $caller = caller;

  if ( $class ne __PACKAGE__ ) {
    return unless grep { $_ eq 'base' } @flags;
  }

  no strict 'refs';
  push @{"$caller\::ISA"}, $class;

  # XXX: not sure why but $TODO refused to be exported well
  *{"$caller\::TODO"} = \$Test::More::TODO;

  foreach my $export ( @Test::More::EXPORT ) {
    next if $export =~ /^\W/;
    *{"$caller\::$export"} = \&{"Test::More\::$export"};
  }

  if ( grep { $_ eq 'ignore' or $_ eq 'ignore_me' } @flags ) {
    ${"$caller\::_ignore_me"} = 1;
  }

  if ( $class eq __PACKAGE__ ) {
    $caller->mk_classdata( _tests => {} );
    $caller->mk_classdata( _plan => 0 );
    $caller->mk_classdata( test_name => '' );
  }
}

sub MODIFY_CODE_ATTRIBUTES {
  my ($class, $code, @attrs) = @_;

  my %stash;
  foreach my $attr ( @attrs ) {
    if ( $attr eq 'Test' ) {
      $stash{plan} = 1;
    }
    elsif ( my ($dummy, $plan) = $attr =~ /^Tests?\((['"]?)(\d+|no_plan)\1\)$/ ) {
      $stash{plan} = $plan;
    }
    elsif ( my ($type, $dummy2, $reason) = $attr =~ /^(Skip|TODO)(?:\((['"]?)(.+)\)\2)?$/ ) {
      $stash{$type} = $reason;
    }
    else {
      $stash{$attr} = 1;
    }
  }
  return unless $stash{plan};

  if ( $stash{plan} eq 'no_plan' ) {
    Test::More::plan 'no_plan' unless Test::Classy::Util::_planned();
    $stash{plan} = 0;
  }

  $class->_plan( $class->_plan + $stash{plan} );

  $stash{code} = $code;

  # At this point, the name looks like CODE(...)
  # we'll make it human-readable later, with class inspection
  $class->_tests->{$code} = \%stash;

  return;
}

sub _limit {
  my ($class, @monikers) = @_;

  my $tests = $class->_tests;
  my $reason = 'limited by attributes';

LOOP:
  foreach my $name ( keys %{ $tests } ) {
    foreach my $moniker ( @monikers ) {
      next LOOP if exists $tests->{$name}->{$moniker};
    }
    $tests->{$name}->{Skip} = $reason;
  }
}

sub _should_be_ignored {
  my $class = shift;

  { no strict 'refs';
    if ( ${"$class\::_ignore_me"} ) {
      SKIP: {
        Test::More::skip 'a base class, not to test', $class->_plan;
      }
      return 1;
    }
  }
}

sub _find_symbols {
  my $class = shift;

  # to allow multibyte method names
  local $Class::Inspector::RE_IDENTIFIER = qr/.+/s;

  my $methods = Class::Inspector->methods($class, 'expanded');

  my %symbols;
  foreach my $entry ( @{ $methods } ) {
    $symbols{$entry->[3]} = $entry->[2];  # coderef to sub name
  }
  return %symbols;
}

sub _run_tests {
  my ($class, @args) = @_;

  return if $class->_should_be_ignored;

  my %sym = $class->_find_symbols;

  $class->test_name( undef );

  $class->initialize(@args);

  my $tests = $class->_tests;

  foreach my $name ( sort { $sym{$a} cmp $sym{$b} } grep { $sym{$_} } keys %{ $tests } ) {
    next if $sym{$name} =~ /^(?:initialize|finalize)$/;

    if ( my $reason = $class->_should_skip_this_class ) {
      SKIP: { Test::More::skip $class->message($reason), $tests->{$name}->{plan}; }
      next;
    }

    $class->_run_test( $tests->{$name}, $sym{$name}, @args );
  }

  $class->finalize(@args);
}

sub _run_test {
  my ($class, $test, $name, @args) = @_;

  $class->test_name( $name );
  $class->_clear_skip_flag;

  if ( exists $test->{TODO} ) {
    my $reason = defined $test->{TODO}
      ? $test->{TODO}
      : "$name is not implemented";

    if ( exists $test->{Skip} ) {  # todo skip
      TODO: {
        Test::More::todo_skip $class->message($reason), $test->{plan};
      }
    }
    else {
      TODO: {
        no strict 'refs';
        local ${"$class\::TODO"} = $class->message($reason); # perl 5.6.2 hates this

        $class->__run_test($test, @args);
      }
    }
    return;
  }
  elsif ( exists $test->{Skip} ) {
    my $reason = defined $test->{Skip}
      ? $test->{Skip}
      : "skipped $name";
    SKIP: { Test::More::skip $class->message($reason), $test->{plan}; }
    return;
  }

  $class->__run_test($test, @args);
}

sub __run_test {
  my ($class, $test, @args) = @_;

  my $current = Test::Classy::Util::_current_test();

  local $@;
  eval { $test->{code}($class, @args); };
  if ( $@ ) {
    my $done = Test::Classy::Util::_current_test() - $current;
    my $rest = $test->{plan} - $done;
    if ( $rest ) {
      if ( exists $test->{TODO} ) {
        my $reason = defined $test->{TODO}
          ? $test->{TODO}
          : 'not implemented';
        TODO: {
          Test::More::todo_skip( $class->message("$reason: $@"), $rest );
        }
      }
      else {
        for ( 1 .. $rest ) {
          Test::More::ok( 0, $class->message($@) );
        }
      }
    }
  }

  if ( my $reason = $class->_is_skipped ) {
    my $done = Test::Classy::Util::_current_test() - $current;
    my $rest = $test->{plan} - $done;
    if ( $rest ) {
      for ( 1 .. $rest ) {
        Test::More->builder->skip( $class->message($reason) );
      }
    }
  }
}

sub skip_this_class {
  my ($class, $reason) = @_;

  no strict 'refs';
  ${"$class\::_skip_this_class"} = $reason || 'for some reason';
}

*skip_the_rest = \&skip_this_class;

sub _should_skip_this_class {
  my $class = shift;

  no strict 'refs';
  return ${"$class\::_skip_this_class"};
}

sub skip_this_test {
  my ($class, $reason) = @_;

  no strict 'refs';
  ${"$class\::_skip_this_test"} = $reason || 'for some reason';
}

*abort_this_test = \&skip_this_test;

sub _clear_skip_flag {
  my $class = shift;

  no strict 'refs';
  ${"$class\::_skip_this_test"} = '';
}

sub _is_skipped {
  my $class = shift;

  no strict 'refs';
  return ${"$class\::_skip_this_test"};
}

sub dump {
  my $class = shift;
  Test::More::diag( Data::Dump::dump( @_ ) );
}

sub message {
  my ($class, $message) = @_;

  $message = $class->_prepend_class_name( $class->_prepend_test_name( $message ) );

  $message = $ENCODE->encode($message) if $ENCODE && $INC{'utf8.pm'};

  return $message;
}

sub _prepend_test_name {
  my ($class, $message) = @_;

  $message = '' unless defined $message;

  if ( my $name = $class->test_name ) {
    $name = decode_utf8($name) if $ENCODE && $INC{'utf8.pm'};
    $message = "$name: $message" unless $message =~ /\b$name\b/;
  }

  return $message;
}

sub _prepend_class_name {
  my ($class, $message) = @_;

  $message = '' unless defined $message;

  if ( my ($name) = $class =~ /(\w+)$/ ) {
    $message = "$name: $message" unless $message =~ /\b$name\b/;
  }

  return $message;
}

sub initialize {}
sub finalize {}

1;

__END__