#!/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> }; }