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