package t::TestPlagger;
use Config;
use FindBin;
use File::Basename;
use File::Spec;
use Test::Base -Base;
use URI::Escape ();
use Plagger;
use Remedie::Log;
use YAML::XS;
our @EXPORT = qw(test_requires test_requires_network test_requires_command test_plugin_deps
run_eval_expected run_eval_expected_with_capture
slurp_file file_contains file_doesnt_contain);
our($BaseDir, $BaseDirURI);
{
my @path = File::Spec->splitdir($FindBin::Bin);
while (defined(my $dir = pop @path)) {
if ($dir eq 't') {
$BaseDir = File::Spec->catfile(@path);
$BaseDirURI = join "/", map URI::Escape::uri_escape($_), @path;
last;
}
}
}
=item test_requires
Checks to see if the module can be loaded.
test_requires("Your::Momma");
test_requires("Your::Momma",3.141); # version 3.141 or later
If this fails rather than failing tests this B<skips all tests>.
=cut
sub test_requires() {
my($mod, $ver) = @_;
if ($ver) {
eval qq{use $mod $ver};
} else {
eval qq{use $mod};
}
if ($@) {
if ($@ =~ /^Can't locate/) {
plan skip_all => "Test requires module '$mod' but it's not found";
}
else {
plan skip_all => "$@";
}
}
}
=item has_network($spec)
Returns true if and only if the specified port can be established. The
spec should be of the form:
hostname:port
e.g.
plagger.org:80
This function always returns false immediatly without connecting to the
network if the enviroment varible C<NO_NETWORK> has been set.
=cut
sub has_network() {
my $host = shift;
return if $ENV{NO_NETWORK};
require IO::Socket::INET;
my $conn = IO::Socket::INET->new(PeerAddr => $host, Timeout => 15);
defined $conn;
}
=item test_requires_network
This function skips all tests if the network is not reachable, e.g.
# can I reach google's web site?
test_requires_network();
# can I reach plagger's web site?
test_requires_network("plagger.org")
# can I reach a different port?
test_requires_network("gmail.com:443");
=cut
sub test_requires_network() {
my $host = shift || 'www.google.com:80';
$host .= ":80" if $host !~ /:/;
unless (has_network($host)) {
plan skip_all => "Test requires network($host) which is not available now.";
}
}
=item test_requires_command($command)
This function skips all tests if the given command
doesn't exist in your path (i.e. in the dirs in the PATH enviroment
variable.)
=cut
sub test_requires_command() {
my $command = shift;
for my $path (split /$Config::Config{path_sep}/, $ENV{PATH}) {
if (-e File::Spec->catfile($path, $command) && -x _) {
return 1;
}
}
plan skip_all => "Test requires '$command' command but it's not found";
}
=item test_plugin_deps
This function skips all tests if the module's requirements
(modules, versions, platforms, bundles) aren't installed.
If you pass an argument then it will check the requirement
for that module:
# this will check the Foo-Bar.yaml file for deps
test_plugin_deps("Foo::Bar");
Called with no arguments it works out magically the name of
the plugin based on the directory the test file is located
in.
# in the Foo-Bar/wobble.t file
# this will check the Foo-Bar.yaml file for deps
test_plugin_deps();
The requirements are defined in YAML files located
in the C<deps> directory inside the Plagger directory. A typical
YAML file looks like this:
name: Publish::Speech::MacOSX
author: Ryo Okamoto
platform: darwin
depends:
Mac::Files: 0
Mac::Speech: 0
Or
name: Subscription::Bookmarks::Mozilla
author: youpy
bundles:
- Subscription::XPath
=cut
sub test_plugin_deps() {
my($mod, $no_warning) = @_;
$mod ||= File::Basename::basename($FindBin::Bin);
$mod =~ s!::!-!g;
my $file = File::Spec->catfile( $BaseDir, "deps", "$mod.yaml" );
unless (-e $file) {
# warn "Can't find deps file for $mod" unless $no_warning;
return;
}
my $meta = eval { YAML::XS::LoadFile($file) } or die "reading $file failed:\n$@";
if ($meta->{platform} && $meta->{platform} ne $^O) {
plan skip_all => "Test requires to be run on '$meta->{platform}'";
}
for my $plugin (@{ $meta->{bundles} || [] }) {
$plugin =~ s/::/-/g;
test_plugin_deps($plugin, 1);
}
while (my($mod, $ver) = each %{$meta->{depends} || {}}) {
test_requires($mod, $ver);
}
}
=item run_eval_expected
Add a new test run across all blocks to check that
the expected blocks can be evaled succesfully. During
these evaluations the expected input is availible from
C<$context>.
One extra test failure will happen per block that's expected
output throws an error when evaluated. No successes are
generated by this code, but the expected code may in
turn generate many sucesses or failures.
=cut
sub run_eval_expected {
run {
my $block = shift;
# context is being pulled out here so that
# the eval box can see it
my $context = $block->input; # it's not always true
eval $block->expected;
fail $@ if $@;
};
}
=item run_eval_expected_with_capture
Add new test run across all blocks to check that
the expected blocks can be evaled succesfully. During
these evaluations the expected input is availible from
C<$context>, and warnings created by the filters
are avalible from C<$warnings>.
=cut
sub run_eval_expected_with_capture {
filters_delay;
for my $block (blocks) {
# capture all the warnings from the filters
# this is often used in the tests as a way to find
# out what has happened (e.g. the Growl plugin)
my $warnings;
{
local $SIG{__WARN__} = sub { $warnings .= "@_" };
$block->run_filters;
}
# context is being pulled out here so that
# the eval box can see it
my $context = $block->input;
eval $block->expected;
fail $@ if $@;
}
}
=item slurp_file($filename)
Returns the contents of the file, as a single scalar
=cut
sub slurp_file() {
my $file = shift;
open my $fh, $file or return;
return join '', <$fh>;
}
=item file_contains($filename, $regexp)
Test if the file (specified by filename) matches the passed regexp.
=cut
sub file_contains() {
my($file, $pattern) = @_;
like slurp_file($file), $pattern;
}
=item file_doesnt_contains($filename, $regexp)
Test the file (specified by filename) doesnt matches the passed regexp.
If the file doesn't exist, this test will fail.
=cut
sub file_doesnt_contain() {
my($file, $pattern) = @_;
$pattern = qr/\Q$pattern\E/ unless ref $pattern;
my $content = slurp_file($file) or return fail("$file: $!");
unlike $content, $pattern;
}
package t::TestPlagger::Filter;
use Test::Base::Filter -base;
use File::Temp ();
=over
=item interpolate
Filter that replaces scalar values of the type
$foo
$foo::bar
With their actual values. But don't do backslash escaped things like
\$foo
Note that you can't do this either:
${foo}
Meaning you can't use $foo like so:
BAR$fooHELLO
=cut
sub interpolate {
my $stuff = shift;
# interpolate in $foo::bar to their values in the string
# (but not \$foo::bar)
$stuff =~ s/(?<!\\) # check there's no backslash before this
(\$[\w\:]+(?:[\{\[]\w+[\]\}])?) # look for a $var possibly with packages
/$1/eegx; # replace it with its value
$stuff =~ s/\\\$/\$/g; # turn the escaped \$ into $
$stuff;
}
=item config
Filter that configures plagger based on the YAML passed in.
=cut
sub config {
my $yaml = shift;
# replace $foo values with their actual values
$yaml = $self->interpolate($yaml);
# set sane defaults for testing
utf8::encode($yaml);
my $config = YAML::XS::Load($yaml);
$config->{global}->{log}->{level} ||= 'error' unless $ENV{TEST_VERBOSE};
$config->{global}->{assets_path} ||= File::Spec->catfile($t::TestPlagger::BaseDir, 'root');
$config->{global}->{cache}->{base} ||= File::Temp::tempdir(CLEANUP => 1);
Plagger->bootstrap(config => $config);
}
=item output_file
Reads the file who's filename is in $main::output and returns it (failing on problems)
=cut
sub output_file {
my $output = $main::output or die "\$main::output is undefined";
open my $fh, $output or return ::fail("$output: $!");
return join '', <$fh>;
}
1;
