cpan/Module-Build/t/extend.t

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use lib 't/lib';
   5 use MBTest tests => 64;
   6
   7 blib_load('Module::Build');
   8
   9 my $tmp = MBTest->tmpdir;
  10
  11 use DistGen;
  12 my $dist = DistGen->new( dir => $tmp );
  13 $dist->regen;
  14
  15 $dist->chdir_in;
  16
  17 #########################
  18
  19 # Here we make sure actions are only called once per dispatch()
  20 $::x = 0;
  21 my $mb = Module::Build->subclass
  22   (
  23    code => "sub ACTION_loop { die 'recursed' if \$::x++; shift->depends_on('loop'); }"
  24   )->new( module_name => $dist->name );
  25 ok $mb;
  26
  27 $mb->dispatch('loop');
  28 ok $::x;
  29
  30 $mb->dispatch('realclean');
  31
  32 # Make sure the subclass can be subclassed
  33 my $build2class = ref($mb)->subclass
  34   (
  35    code => "sub ACTION_loop2 {}",
  36    class => 'MBB',
  37   );
  38 can_ok( $build2class, 'ACTION_loop' );
  39 can_ok( $build2class, 'ACTION_loop2' );
  40
  41
  42 { # Make sure globbing works in filenames
  43   $dist->add_file( 'script', <<'---' );
  44 #!perl -w
  45 print "Hello, World!\n";
  46 ---
  47   $dist->regen;
  48
  49   $mb->test_files('*t*');
  50   my $files = $mb->test_files;
  51   ok  grep {$_ eq 'script'}    @$files;
  52   my $t_basic_t = File::Spec->catfile('t', 'basic.t');
  53   $t_basic_t = VMS::Filespec::vmsify($t_basic_t) if $^O eq 'VMS';
  54   ok  grep {$_ eq $t_basic_t} @$files;
  55   ok !grep {$_ eq 'Build.PL' } @$files;
  56
  57   # Make sure order is preserved
  58   $mb->test_files('foo', 'bar');
  59   $files = $mb->test_files;
  60   is @$files, 2;
  61   is $files->[0], 'foo';
  62   is $files->[1], 'bar';
  63
  64   $dist->remove_file( 'script' );
  65   $dist->regen( clean => 1 );
  66 }
  67
  68
  69 {
  70   # Make sure we can add new kinds of stuff to the build sequence
  71
  72   $dist->add_file( 'test.foo', "content\n" );
  73   $dist->regen;
  74
  75   my $mb = Module::Build->new( module_name => $dist->name,
  76                                foo_files => {'test.foo', 'lib/test.foo'} );
  77   ok $mb;
  78
  79   $mb->add_build_element('foo');
  80   $mb->add_build_element('foo');
  81   is_deeply $mb->build_elements, [qw(PL support pm xs share_dir pod script foo)],
  82       'The foo element should be in build_elements only once';
  83
  84   $mb->dispatch('build');
  85   ok -e File::Spec->catfile($mb->blib, 'lib', 'test.foo');
  86
  87   $mb->dispatch('realclean');
  88
  89   # revert distribution to a pristine state
  90   $dist->remove_file( 'test.foo' );
  91   $dist->regen( clean => 1 );
  92 }
  93
  94
  95 {
  96   package MBSub;
  97   use Test::More;
  98   use vars qw($VERSION @ISA);
  99   @ISA = qw(Module::Build);
 100   $VERSION = 0.01;
 101
 102   # Add a new property.
 103   ok(__PACKAGE__->add_property('foo'));
 104   # Add a new property with a default value.
 105   ok(__PACKAGE__->add_property('bar', 'hey'));
 106   # Add a hash property.
 107   ok(__PACKAGE__->add_property('hash', {}));
 108
 109
 110   # Catch an exception adding an existing property.
 111   eval { __PACKAGE__->add_property('module_name')};
 112   like "$@", qr/already exists/;
 113 }
 114
 115 {
 116   package MBSub2;
 117   use Test::More;
 118   use vars qw($VERSION @ISA);
 119   @ISA = qw(Module::Build);
 120   $VERSION = 0.01;
 121
 122   # Add a new property with a different default value than MBSub has.
 123   ok(__PACKAGE__->add_property('bar', 'yow'));
 124 }
 125
 126
 127 {
 128   ok my $mb = MBSub->new( module_name => $dist->name );
 129   isa_ok $mb, 'Module::Build';
 130   isa_ok $mb, 'MBSub';
 131   ok $mb->valid_property('foo');
 132   can_ok $mb, 'module_name';
 133
 134   # Check foo property.
 135   can_ok $mb, 'foo';
 136   ok ! $mb->foo;
 137   ok $mb->foo(1);
 138   ok $mb->foo;
 139
 140   # Check bar property.
 141   can_ok $mb, 'bar';
 142   is $mb->bar, 'hey';
 143   ok $mb->bar('you');
 144   is $mb->bar, 'you';
 145
 146   # Check hash property.
 147   ok $mb = MBSub->new(
 148                        module_name => $dist->name,
 149                        hash        => { foo => 'bar', bin => 'foo'}
 150                      );
 151
 152   can_ok $mb, 'hash';
 153   isa_ok $mb->hash, 'HASH';
 154   is $mb->hash->{foo}, 'bar';
 155   is $mb->hash->{bin}, 'foo';
 156
 157   # Check hash property passed via the command-line.
 158   {
 159     local @ARGV = (
 160                    '--hash', 'foo=bar',
 161                    '--hash', 'bin=foo',
 162                   );
 163     ok $mb = MBSub->new( module_name => $dist->name );
 164   }
 165
 166   can_ok $mb, 'hash';
 167   isa_ok $mb->hash, 'HASH';
 168   is $mb->hash->{foo}, 'bar';
 169   is $mb->hash->{bin}, 'foo';
 170
 171   # Make sure that a different subclass with the same named property has a
 172   # different default.
 173   ok $mb = MBSub2->new( module_name => $dist->name );
 174   isa_ok $mb, 'Module::Build';
 175   isa_ok $mb, 'MBSub2';
 176   ok $mb->valid_property('bar');
 177   can_ok $mb, 'bar';
 178   is $mb->bar, 'yow';
 179 }
 180
 181 {
 182   # Test the meta_add and meta_merge stuff
 183   ok my $mb = Module::Build->new(
 184                                   module_name => $dist->name,
 185                                   license => 'perl',
 186                                   meta_add => {foo => 'bar'},
 187                                   conflicts => {'Foo::Barxx' => 0},
 188                                 );
 189   my $data = $mb->get_metadata;
 190   is $data->{foo}, 'bar';
 191
 192   $mb->meta_merge(foo => 'baz');
 193   $data = $mb->get_metadata;
 194   is $data->{foo}, 'baz';
 195
 196   $mb->meta_merge(conflicts => {'Foo::Fooxx' => 0});
 197   $data = $mb->get_metadata;
 198   is_deeply $data->{conflicts}, {'Foo::Barxx' => 0, 'Foo::Fooxx' => 0};
 199
 200   $mb->meta_add(conflicts => {'Foo::Bazxx' => 0});
 201   $data = $mb->get_metadata;
 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