Test::DataDriven::Plugin - when Test::Base is not enough

Test-DataDriven documentation Contained in the Test-DataDriven distribution.

Index

Code Index:

NAME

Top

Test::DataDriven::Plugin - when Test::Base is not enough

SYNOPSIS

Top

See Test::DataDriven

METHODS

Top

test_name

  my $test_name = test_name();

This function is exported by default. The test name is "$block - $action - $section".b

register

    __PACKAGE__->register;

This method must be called by every Test::DataDriven::Plugin subclass in order to register the section handlers with Test::DataDriven.

begin, run, end

Dispatch to the subroutines registered with attributes Begin(), Run(), End(), passing as parameters the block object, section name and the section data.

BUGS

Top

Needs more documentation and examples.

AUTHOR

Top

Mattia Barbon <mbarbon@cpan.org>

LICENSE

Top

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

Test-DataDriven documentation Contained in the Test-DataDriven distribution. 
package Test::DataDriven::Plugin;


use strict;
use warnings;

use Class::Spiffy -base;
use Test::DataDriven ();

our @EXPORT = qw(test_name);

my %attributes;
my %dispatch;


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

    foreach ( @attrs ) {
        /^(?:Begin|Run|End|Endc|Filter)\s*(?:$|\()/ ?
          push @known, $_ : push @unknown, $_;
    }

    $attributes{$class}{$code} = [ $code, \@known ];

    return @unknown;
}

our $test_name;


sub test_name() { $test_name }

sub _parse {
    my( @attributes ) = @_;

    return map  { m/^(\w+)\(\s*(\w+)\s*\)/ or die $_;
                  [ lc( $1 ), $2 ]
                  }
                @attributes;
}


sub _apply_filter {
    my( $self, $filter, @value ) = @_;
    local $_;
    # cut'n'pasted from Test::Base (this sucks)
    $Test::Base::Filter::arguments =
      $filter =~ s/=(.*)$// ? $1 : undef;
    my $function = "main::$filter";
    no strict 'refs';
    if (defined &$function) {
        $_ = join '', @value;
        @value = &$function(@value);
        if (not(@value) or
            @value == 1 and $value[0] =~ /\A(\d+|)\z/
           ) {
            @value = ($_);
        }
    }
    else {
        my $filter_object = $self->blocks_object->filter_class->new;
        die "Can't find a function or method for '$filter' filter\n"
          unless $filter_object->can($filter);
        $filter_object->current_block($self);
        @value = $filter_object->$filter(@value);
    }

    return @value;
}

sub register {
    my( $self, $pluggable ) = @_;
    my $class = ref( $self ) || $self;
    my @attributes = values %{$attributes{$class}};
    my %keys;

    foreach my $attr ( @attributes ) {
        my( $sub, $attrs ) = @$attr;
        my @parsed = _parse @$attrs;
        # filter subroutines
        if( @parsed == 1 && $parsed[0][0] eq 'filter' ) {
            no strict 'refs';
            *{'main::' . $parsed[0][1]} = $sub;
            next;
        }
        # handle per-subroutine filters
        foreach my $h ( grep $_->[0] eq 'filter', reverse @parsed ) {
            my( $oldsub, $filter ) = ( $sub, $h->[1] );
            $sub = sub {
                my( $block, $section, @a ) = @_;
                @a = _apply_filter( $block, $filter, @a );
                &$oldsub( $block, $section, @a );
            };
        }
        # handle begin/run/end
        foreach my $h ( grep $_->[0] ne 'filter', @parsed ) {
            $keys{$h->[1]} = 1;
            push @{$dispatch{$class}{$h->[0]}{$h->[1]}}, $sub;
        }
    }

    $pluggable ||= 'Test::DataDriven';
    foreach my $key ( keys %keys ) {
        $pluggable->register( plugin => $self,
                              tag    => $key,
                              );
    }
}

sub _dispatch {
    my( $act, $self, $block, $section, @a ) = @_;
    my $class = ref( $self ) || $self;

    return unless    exists $dispatch{$class}
                  && exists $dispatch{$class}{$act}
                  && exists $dispatch{$class}{$act}{$section};

    local $Test::Builder::Level = 1;
    local $test_name = join ' - ', $block->name, $act, $section;

    my $run_one = 0;
    foreach my $sub ( @{$dispatch{$class}{$act}{$section}} ) {
        &$sub( $block, $section, @a );
        $run_one = 1;
    }

    return $run_one;
}


sub begin { _dispatch( 'begin', @_ ); }
sub run { _dispatch( 'run', @_ ); }
sub end { _dispatch( 'end', @_ ); }

sub endc {
    my( $self, $block, $section, @v ) = @_;

    _dispatch( 'endc', @_ );
    _serialize_back( @_ );
}

my %started;

sub _serialize_back {
    my( $self, $block, $section, @v ) = @_;
    my $create_fh = Test::DataDriven->_create_fh;

    print $create_fh "=== ", $block->name, "\n" unless $started{$block};
    if( defined $block->description && $block->description ne $block->name ) {
        print $create_fh $block->description , "\n" ;
    }
    print $create_fh "--- ", $section;
    my $filters = $block->_section_map->{$section}{filters};
    if( $filters ) {
        print $create_fh ' ', $filters;
    }
    print $create_fh "\n";
    print $create_fh $block->original_values->{$section};

    $started{$block} = 1;
}


1;