The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;

chdir 't';
use lib 'lib';

use Test::More tests => 14;
use Test::Exception;

END
{
    unless ($ENV{TEST_DEBUG})
    {
        1 while unlink(qw( foo bar filename some_file ));
    }
}

my $module = 'Pod::ToDemo';
use_ok( $module ) or exit;

throws_ok { Pod::ToDemo::write_demo() } qr/^Usage:/,
    'write_demo() should die with Usage error without a filename';

throws_ok { Pod::ToDemo::write_demo( 'base.t' ) }
    qr/Cowardly refusing to overwrite 'base.t'/,
    '... or with overwriting error if destination file exists';

Pod::ToDemo::write_demo( 'bar', 'here is more text' );
ok( -e 'bar', '... and should write file if everything is sane' );

my $text = slurp( 'bar' );

is( $text, 'here is more text', '... writing demo file accurately' );

use_ok( 'DemoUser' );
ok( ! -e 'foo',
    'defined caller() check should protect against accidental usage' );

my $flag = 0;
Pod::ToDemo->import( sub { $flag++ } );
diag( "import() should import a passed sub into the caller's namespace" );
can_ok( __PACKAGE__, 'import' );
__PACKAGE__->import();
ok( $flag, '... the correct sub' );

package Foo;

Pod::ToDemo->import( 'This is more text' );
__PACKAGE__->import( 'filename' );

package main;

my $exists = -e 'filename';
ok( $exists, 'default import() should write to the pased-in filename' );

$text      = ::slurp( 'filename' );
like( $text, qr/^#!\Q$^X\E/,                  '... with a Perl header' );
like( $text, qr/use strict;.+use warnings;/s, '... strictures and warnings' );
like( $text, qr/..This is more text/s,        '... and the given text' );

SKIP:
{
    my @commands = ( $^X, '-Ilib', '-MDemoUser=some_file', '-e 1' );
    skip( "Couldn't execute subprocess: (@commands)", 1 )
        if system @commands;
    ok( -e 'some_file', 'executing in separate process should work' )
        or diag( "Hmm: (@commands): $!" );
}

sub slurp
{
    my $filename = shift;
    open( my $file, $filename ) or die "Cannot read demo $filename: $!\n";
    return scalar do { local $/; <$file> };
}