File Coverage

blib/lib/Plack/App/DAIA/Test/Suite.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

use strict;
use warnings;
package Plack::App::DAIA::Test::Suite;
#ABSTRACT: Test DAIA Servers via a test scripting language
our $VERSION = '0.55'; #VERSION
use base 'Test::Builder::Module';
our @EXPORT = qw(provedaia);

use Test::More;
use Plack::App::DAIA::Test;
use Scalar::Util qw(reftype blessed);
use Test::JSON::Entails;
use JSON;
use Carp;

sub provedaia {
    my ($suite, %args) = @_;

    my $test  = __PACKAGE__->builder;
    my @lines;

    if ( ref($suite) ) {
        croak 'usage: provedaia( $file | $glob | $string )'
            unless reftype($suite) eq 'GLOB' or blessed($suite) and $suite->isa('IO::File');
        @lines = <$suite>;
    } elsif ( $suite !~ qr{^https?://} and $suite !~ /[\r\n]/ ) {
        open (my $fh, '<', $suite) or croak "failed to open daia test suite $suite";
        @lines = <$fh>;
        close $fh;
    } else {
        @lines = split /\n/, $suite;
    }

    my $line = 0;
    my $comment = '';
    my $json = undef;
    my %vars = ( server => $args{server} );
    my @ids;
    @ids = @{$args{ids}} if $args{ids};

    my $run = sub {
        my $server = $vars{server} or return;
        $json ||= '{ }';
        my $server_name = $server;
        if ( $server !~ qr{^https?://}) {
            no warnings 'redefine'; # we may load the same twice
            $_ = Plack::Util::load_psgi($server);
            if ( ref($_) ) {
                diag("loaded PSGI from $server");
                $server = $_;
            } else {
                fail("failed to load PSGI from $server");
                return;
            }
        }
        foreach my $id (@ids) {
            my $test_name = "$server_name?id=$id";
            $comment =~ s/^\s+|\s+$//g;
            $test_name .= " ($comment)" if $comment ne '';
            local $Test::Builder::Level = $Test::Builder::Level + 2; # called 2 levels above
            my $test_json = $json;
            $vars{id} = $id;
            $test_json =~ s/\$([a-z]+)/defined $vars{$1} ? $vars{$1} : "\$$1"/emg;
            $test_json = decode_json($test_json);
            if (ref($server)) {
                test_daia_psgi $server, $id => $test_json, $test_name;
            } else {
                test_daia $server, $id => $test_json, $test_name;
            }
        }
    };

    foreach (@lines) {
        if ($args{end}) {
            $args{end} = 0 if /__END__/;
            next;
        }
        chomp;
        $comment = $1 if /^#(.*)/;
        s/^(#.*|\s+)$//; # empty line or comment
        $line++;

        if (defined $json) {
            $json .= $_;
            if ($_ eq '') {
                $run->();
                $json = undef;
                $comment = '';
            }
        } elsif ( $_ eq '' ) {
            next;
        } elsif( $_ =~ qr{^([a-z]+)\s*=\s*(.*)}i ) {
            $comment = '';
            my ($key, $value) = ($1,$2);
            if ($1 =~ /^id[s]?/) {
                @ids = $value eq '' ? () : ($value);
            } else {
                $vars{$key} = $value;
            }
            diag( "$key = $value" ) if $args{verbose};
        } elsif( $_ =~ qr/^\s*{/ ) {
            $json = $_;
        } else { # identifier
            $comment = '';
            push @ids, $_;
        }
    }
    $run->();
}

1;

__END__