lib/Module/Build/t/extend.t

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use lib $ENV{PERL_CORE} ? '../lib/Module/Build/t/lib' : 't/lib';
   5 use MBTest tests => 65;
   6
   7 use Cwd ();
   8 my $cwd = Cwd::cwd;
   9 my $tmp = MBTest->tmpdir;
  10
  11 use DistGen;
  12 my $dist = DistGen->new( dir => $tmp );
  13 $dist->regen;
  14
  15 chdir( $dist->dirname ) or die "Can't chdir to '@{[$dist->dirname]}': $!";
  16
  17 #########################
  18
  19 use Module::Build;
  20 ok 1;
  21
  22 # Here we make sure actions are only called once per dispatch()
  23 $::x = 0;
  24 my $mb = Module::Build->subclass
  25   (
  26    code => "sub ACTION_loop { die 'recursed' if \$::x++; shift->depends_on('loop'); }"
  27   )->new( module_name => $dist->name );
  28 ok $mb;
  29
  30 $mb->dispatch('loop');
  31 ok $::x;
  32
  33 $mb->dispatch('realclean');
  34
  35 # Make sure the subclass can be subclassed
  36 my $build2class = ref($mb)->subclass
  37   (
  38    code => "sub ACTION_loop2 {}",
  39    class => 'MBB',
  40   );
  41 can_ok( $build2class, 'ACTION_loop' );
  42 can_ok( $build2class, 'ACTION_loop2' );
  43
  44
  45 { # Make sure globbing works in filenames
  46   $dist->add_file( 'script', <<'---' );
  47 #!perl -w
  48 print "Hello, World!\n";
  49 ---
  50   $dist->regen;
  51
  52   $mb->test_files('*t*');
  53   my $files = $mb->test_files;
  54   ok  grep {$_ eq 'script'}    @$files;
  55   ok  grep {$_ eq File::Spec->catfile('t', 'basic.t')} @$files;
  56   ok !grep {$_ eq 'Build.PL' } @$files;
  57
  58   # Make sure order is preserved
  59   $mb->test_files('foo', 'bar');
  60   $files = $mb->test_files;
  61   is @$files, 2;
  62   is $files->[0], 'foo';
  63   is $files->[1], 'bar';
  64
  65   $dist->remove_file( 'script' );
  66   $dist->regen( clean => 1 );
  67 }
  68
  69
  70 {
  71   # Make sure we can add new kinds of stuff to the build sequence
  72
  73   $dist->add_file( 'test.foo', "content\n" );
  74   $dist->regen;
  75
  76   my $mb = Module::Build->new( module_name => $dist->name,
  77                                foo_files => {'test.foo', 'lib/test.foo'} );
  78   ok $mb;
  79
  80   $mb->add_build_element('foo');
  81   $mb->add_build_element('foo');
  82   is_deeply $mb->build_elements, [qw(PL support pm xs pod script foo)],
  83       'The foo element should be in build_elements only once';
  84
  85   $mb->dispatch('build');
  86   ok -e File::Spec->catfile($mb->blib, 'lib', 'test.foo');
  87
  88   $mb->dispatch('realclean');
  89
  90   # revert distribution to a pristine state
  91   $dist->remove_file( 'test.foo' );
  92   $dist->regen( clean => 1 );
  93 }
  94
  95
  96 {
  97   package MBSub;
  98   use Test::More;
  99   use vars qw($VERSION @ISA);
 100   @ISA = qw(Module::Build);
 101   $VERSION = 0.01;
 102
 103   # Add a new property.
 104   ok(__PACKAGE__->add_property('foo'));
 105   # Add a new property with a default value.
 106   ok(__PACKAGE__->add_property('bar', 'hey'));
 107   # Add a hash property.
 108   ok(__PACKAGE__->add_property('hash', {}));
 109
 110
 111   # Catch an exception adding an existing property.
 112   eval { __PACKAGE__->add_property('module_name')};
 113   like "$@", qr/already exists/;
 114 }
 115
 116 {
 117   package MBSub2;
 118   use Test::More;
 119   use vars qw($VERSION @ISA);
 120   @ISA = qw(Module::Build);
 121   $VERSION = 0.01;
 122
 123   # Add a new property with a different default value than MBSub has.
 124   ok(__PACKAGE__->add_property('bar', 'yow'));
 125 }
 126
 127
 128 {
 129   ok my $mb = MBSub->new( module_name => $dist->name );
 130   isa_ok $mb, 'Module::Build';
 131   isa_ok $mb, 'MBSub';
 132   ok $mb->valid_property('foo');
 133   can_ok $mb, 'module_name';
 134
 135   # Check foo property.
 136   can_ok $mb, 'foo';
 137   ok ! $mb->foo;
 138   ok $mb->foo(1);
 139   ok $mb->foo;
 140
 141   # Check bar property.
 142   can_ok $mb, 'bar';
 143   is $mb->bar, 'hey';
 144   ok $mb->bar('you');
 145   is $mb->bar, 'you';
 146
 147   # Check hash property.
 148   ok $mb = MBSub->new(
 149                        module_name => $dist->name,
 150                        hash        => { foo => 'bar', bin => 'foo'}
 151                      );
 152
 153   can_ok $mb, 'hash';
 154   isa_ok $mb->hash, 'HASH';
 155   is $mb->hash->{foo}, 'bar';
 156   is $mb->hash->{bin}, 'foo';
 157
 158   # Check hash property passed via the command-line.
 159   {
 160     local @ARGV = (
 161                    '--hash', 'foo=bar',
 162                    '--hash', 'bin=foo',
 163                   );
 164     ok $mb = MBSub->new( module_name => $dist->name );
 165   }
 166
 167   can_ok $mb, 'hash';
 168   isa_ok $mb->hash, 'HASH';
 169   is $mb->hash->{foo}, 'bar';
 170   is $mb->hash->{bin}, 'foo';
 171
 172   # Make sure that a different subclass with the same named property has a
 173   # different default.
 174   ok $mb = MBSub2->new( module_name => $dist->name );
 175   isa_ok $mb, 'Module::Build';
 176   isa_ok $mb, 'MBSub2';
 177   ok $mb->valid_property('bar');
 178   can_ok $mb, 'bar';
 179   is $mb->bar, 'yow';
 180 }
 181
 182 {
 183   # Test the meta_add and meta_merge stuff
 184   ok my $mb = Module::Build->new(
 185                                   module_name => $dist->name,
 186                                   license => 'perl',
 187                                   meta_add => {foo => 'bar'},
 188                                   conflicts => {'Foo::Barxx' => 0},
 189                                 );
 190   my %data;
 191   $mb->prepare_metadata( \%data );
 192   is $data{foo}, 'bar';
 193
 194   $mb->meta_merge(foo => 'baz');
 195   $mb->prepare_metadata( \%data );
 196   is $data{foo}, 'baz';
 197
 198   $mb->meta_merge(conflicts => {'Foo::Fooxx' => 0});
 199   $mb->prepare_metadata( \%data );
 200   is_deeply $data{conflicts}, {'Foo::Barxx' => 0, 'Foo::Fooxx' => 0};
 201
 202   $mb->meta_add(conflicts => {'Foo::Bazxx' => 0});
 203   $mb->prepare_metadata( \%data );
 204   is_deeply $data{conflicts}, {'Foo::Bazxx' => 0, 'Foo::Fooxx' => 0};
 205 }
 206
 207 {
 208   # Test interactive prompting
 209
 210   my $ans;
 211   local $ENV{PERL_MM_USE_DEFAULT};
 212
 213   local $^W = 0;
 214   local *{Module::Build::_readline} = sub { 'y' };
 215
 216   ok my $mb = Module::Build->new(
 217                                   module_name => $dist->name,
 218                                   license => 'perl',
 219                                 );
 220
 221   eval{ $mb->prompt() };
 222   like $@, qr/called without a prompt/, 'prompt() requires a prompt';
 223
 224   eval{ $mb->y_n() };
 225   like $@, qr/called without a prompt/, 'y_n() requires a prompt';
 226
 227   eval{ $mb->y_n('Prompt?', 'invalid default') };
 228   like $@, qr/Invalid default/, "y_n() requires a default of 'y' or 'n'";
 229
 230
 231   $ENV{PERL_MM_USE_DEFAULT} = 1;
 232
 233   eval{ $mb->y_n('Is this a question?') };
 234   print "\n"; # fake <enter> because the prompt prints before the checks
 235   like $@, qr/ERROR:/,
 236        'Do not allow default-less y_n() for unattended builds';
 237
 238   eval{ $ans = $mb->prompt('Is this a question?') };
 239   print "\n"; # fake <enter> because the prompt prints before the checks
 240   like $@, qr/ERROR:/,
 241        'Do not allow default-less prompt() for unattended builds';
 242
 243
 244   # When running Test::Smoke under a cron job, STDIN will be closed which
 245   # will fool our _is_interactive() method causing various failures.
 246   {
 247     local *{Module::Build::_is_interactive} = sub { 1 };
 248
 249     $ENV{PERL_MM_USE_DEFAULT} = 0;
 250
 251     $ans = $mb->prompt('Is this a question?');
 252     print "\n"; # fake <enter> after input
 253     is $ans, 'y', "prompt() doesn't require default for interactive builds";
 254
 255     $ans = $mb->y_n('Say yes');
 256     print "\n"; # fake <enter> after input
 257     ok $ans, "y_n() doesn't require default for interactive build";
 258
 259
 260     # Test Defaults
 261     *{Module::Build::_readline} = sub { '' };
 262
 263     $ans = $mb->prompt("Is this a question");
 264     is $ans, '', "default for prompt() without a default is ''";
 265
 266     $ans = $mb->prompt("Is this a question", 'y');
 267     is $ans, 'y', "  prompt() with a default";
 268
 269     $ans = $mb->y_n("Is this a question", 'y');
 270     ok $ans, "  y_n() with a default";
 271
 272     my @ans = $mb->prompt("Is this a question", undef);
 273     is_deeply([@ans], [undef], "  prompt() with undef() default");
 274   }
 275
 276 }
 277
 278 # cleanup
 279 chdir( $cwd ) or die "Can''t chdir to '$cwd': $!";
 280 $dist->remove;
 281
 282 use File::Path;
 283 rmtree( $tmp );