5 use vars qw( $VERSION $VERBOSE @EXPORT_OK);
14 use File::Basename ();
29 # For things like vmsify()
30 require VMS::Filespec;
31 VMS::Filespec->import;
36 if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
37 $unix_rpt = VMS::Feature::current("filename_unix_report");
38 $vms_efs_case = VMS::Feature::current("efs_case_preserve");
40 my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
41 $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
42 my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || '';
43 $vms_efs_case = $efs_case =~ /^[ET1]/i;
45 $vms_mode = 0 if $unix_rpt;
46 $vms_lower_case = 0 if $vms_efs_case;
51 *{import} = \&Exporter::import;
60 my ($space) = $string =~ m/^(\s+)/;
61 $string =~ s/^$space//gm;
67 # OS/2 has "current directory per disk", undeletable;
68 # doing chdir() to another disk won't change cur-dir of initial disk...
69 chdir('/') if $^O eq 'os2';
73 ########################################################################
75 END { chdir_all(MBTest->original_cwd); }
78 my $self = bless {}, shift;
86 $options{name} ||= 'Simple';
87 $options{dir} = File::Spec->rel2abs(
88 defined $options{dir} ? $options{dir} : MBTest->tmpdir
99 tie %{$self->{filedata}}, 'Tie::CPHash';
101 tie %{$self->{pending}{change}}, 'Tie::CPHash';
103 # start with a fresh, empty directory
104 if ( -d $self->dirname ) {
105 warn "Warning: Removing existing directory '@{[$self->dirname]}'\n";
106 File::Path::rmtree( $self->dirname );
108 File::Path::mkpath( $self->dirname );
110 $self->_gen_default_filedata();
117 $self->chdir_original if($self->did_chdir);
118 File::Path::rmtree( $self->dirname );
123 my ($self, $file) = @_;
124 if ( defined $file ) {
125 delete $self->{filedata}{$file};
126 delete $self->{pending}{$_}{$file} for qw/change remove/;
129 delete $self->{filedata}{$_} for keys %{ $self->{filedata} };
130 for my $pend ( qw/change remove/ ) {
131 delete $self->{pending}{$pend}{$_} for keys %{ $self->{pending}{$pend} };
134 $self->_gen_default_filedata;
137 sub _gen_default_filedata {
140 # TODO maybe a public method like this (but with a better name?)
141 my $add_unless = sub {
143 my ($member, $data) = @_;
144 $self->add_file($member, $data) unless($self->{filedata}{$member});
147 if ( ! $self->{inc} ) {
148 $self->$add_unless('Build.PL', undent(<<" ---"));
152 my \$builder = Module::Build->new(
153 module_name => '$self->{name}',
157 \$builder->create_build_script();
161 $self->$add_unless('Build.PL', undent(<<" ---"));
163 use inc::latest 'Module::Build';
165 my \$builder = Module::Build->new(
166 module_name => '$self->{name}',
170 \$builder->create_build_script();
174 my $module_filename =
175 join( '/', ('lib', split(/::/, $self->{name})) ) . '.pm';
177 unless ( $self->{xs} ) {
178 $self->$add_unless($module_filename, undent(<<" ---"));
179 package $self->{name};
181 use vars qw( \$VERSION );
192 $self->{name} - Perl extension for blah blah blah
196 Stub documentation for $self->{name}.
200 A. U. Thor, a.u.thor\@a.galaxy.far.far.away
205 $self->$add_unless('t/basic.t', undent(<<" ---"));
206 use Test::More tests => 1;
214 $self->$add_unless($module_filename, undent(<<" ---"));
215 package $self->{name};
222 \@ISA = qw(Exporter DynaLoader);
223 \@EXPORT_OK = qw( okay );
225 bootstrap $self->{name} \$VERSION;
233 $self->{name} - Perl extension for blah blah blah
237 Stub documentation for $self->{name}.
241 A. U. Thor, a.u.thor\@a.galaxy.far.far.away
247 join( '/', ('lib', split(/::/, $self->{name})) ) . '.xs';
248 $self->$add_unless($xs_filename, undent(<<" ---"));
253 MODULE = $self->{name} PACKAGE = $self->{name}
258 RETVAL = newSVpv( "ok", 0 );
277 # 5.6 is missing const char * in its typemap
278 $self->$add_unless('typemap', undent(<<" ---"));
282 $self->$add_unless('t/basic.t', undent(<<" ---"));
283 use Test::More tests => 2;
289 ok( $self->{name}::okay() eq 'ok' );
296 my $manifest = shift;
298 my $fh = IO::File->new( ">$manifest" ) or do {
299 die "Can't write '$manifest'\n";
302 my @files = ( 'MANIFEST', keys %{$self->{filedata}} );
303 my $data = join( "\n", sort @files ) . "\n";
307 $self->{filedata}{MANIFEST} = $data;
308 $self->{pending}{change}{MANIFEST} = 1;
311 sub name { shift()->{name} }
315 my $dist = $self->{distdir} || join( '-', split( /::/, $self->{name} ) );
316 return File::Spec->catdir( $self->{dir}, $dist );
321 my $filename = shift;
322 return File::Spec->catfile( split( /\//, $filename ) );
329 my $dist_dirname = $self->dirname;
331 if ( $opts{clean} ) {
332 $self->clean() if -d $dist_dirname;
334 # TODO: This might leave dangling directories; e.g. if the removed file
335 # is 'lib/Simple/Simon.pm', the directory 'lib/Simple' will be left
336 # even if there are no files left in it. However, clean() will remove it.
337 my @files = keys %{$self->{pending}{remove}};
338 foreach my $file ( @files ) {
339 my $real_filename = $self->_real_filename( $file );
340 my $fullname = File::Spec->catfile( $dist_dirname, $real_filename );
341 if ( -e $fullname ) {
342 1 while unlink( $fullname );
344 print "Unlinking pending file '$file'\n" if $VERBOSE;
345 delete( $self->{pending}{remove}{$file} );
349 foreach my $file ( keys( %{$self->{filedata}} ) ) {
350 my $real_filename = $self->_real_filename( $file );
351 my $fullname = File::Spec->catfile( $dist_dirname, $real_filename );
353 if ( ! -e $fullname ||
354 ( -e $fullname && $self->{pending}{change}{$file} ) ) {
356 print "Changed file '$file'.\n" if $VERBOSE;
358 my $dirname = File::Basename::dirname( $fullname );
359 unless ( -d $dirname ) {
360 File::Path::mkpath( $dirname ) or do {
361 die "Can't create '$dirname'\n";
365 if ( -e $fullname ) {
366 1 while unlink( $fullname );
369 my $fh = IO::File->new(">$fullname") or do {
370 die "Can't write '$fullname'\n";
372 print $fh $self->{filedata}{$file};
376 delete( $self->{pending}{change}{$file} );
379 my $manifest = File::Spec->catfile( $dist_dirname, 'MANIFEST' );
380 unless ( $self->{no_manifest} ) {
381 if ( -e $manifest ) {
382 1 while unlink( $manifest );
384 $self->_gen_manifest( $manifest );
392 my $here = Cwd::abs_path();
393 my $there = File::Spec->rel2abs( $self->dirname() );
396 chdir( $there ) or die "Can't change directory to '$there'\n";
398 die "Distribution not found in '$there'\n";
402 tie %names, 'Tie::CPHash';
403 foreach my $file ( keys %{$self->{filedata}} ) {
404 my $filename = $self->_real_filename( $file );
405 $filename = lc($filename) if $vms_lower_case;
406 my $dirname = File::Basename::dirname( $filename );
408 $names{$filename} = 0;
410 print "Splitting '$dirname'\n" if $VERBOSE;
411 my @dirs = File::Spec->splitdir( $dirname );
413 my $dir = ( scalar(@dirs) == 1
415 : File::Spec->catdir( @dirs ) );
417 print "Setting directory name '$dir' in \%names\n" if $VERBOSE;
424 File::Find::finddepth( sub {
425 my $name = File::Spec->canonpath( $File::Find::name );
430 $name = vmspath($name) if -d $name;
434 $name = File::Spec->rel2abs($name) if $name eq File::Spec->curdir();
437 if ( not exists $names{$name} ) {
438 print "Removing '$name'\n" if $VERBOSE;
439 File::Path::rmtree( $_ );
441 }, ($^O eq 'VMS' ? './' : File::Spec->curdir) );
449 $self->change_file( @_ );
455 unless ( exists $self->{filedata}{$file} ) {
456 warn "Can't remove '$file': It does not exist.\n" if $VERBOSE;
458 delete( $self->{filedata}{$file} );
459 $self->{pending}{remove}{$file} = 1;
463 sub change_build_pl {
464 my ($self, @opts) = @_;
466 my $opts = ref $opts[0] eq 'HASH' ? $opts[0] : { @opts };
468 local $Data::Dumper::Terse = 1;
469 (my $args = Dumper($opts)) =~ s/^\s*\{|\}\s*$//g;
471 $self->change_file( 'Build.PL', undent(<<" ---") );
474 my \$b = Module::Build->new(
475 # Some CPANPLUS::Dist::Build versions need to allow mismatches
476 # On logic: thanks to Module::Install, CPAN.pm must set both keys, but
477 # CPANPLUS sets only the one
478 allow_mb_mismatch => (
479 \$ENV{PERL5_CPANPLUS_IS_RUNNING} && ! \$ENV{PERL5_CPAN_IS_RUNNING} ? 1 : 0
483 \$b->create_build_script();
492 $self->{filedata}{$file} = $data;
493 $self->{pending}{change}{$file} = 1;
500 exists($self->{filedata}{$file}) or croak("no such entry: '$file'");
501 return $self->{filedata}{$file};
506 $self->{original_dir} ||= Cwd::cwd; # only once!
507 my $dir = $self->dirname;
508 chdir($dir) or die "Can't chdir to '$dir': $!";
511 ########################################################################
513 sub did_chdir { exists shift()->{original_dir} }
515 ########################################################################
520 my $dir = delete $self->{original_dir};
521 chdir_all($dir) or die "Can't chdir to '$dir': $!";
524 ########################################################################
526 sub new_from_context {
527 my ($self, @args) = @_;
528 require Module::Build;
529 return Module::Build->new_from_context( quiet => 1, @args );
533 my ($self, @args) = @_;
534 require Module::Build;
535 return Module::Build->run_perl_script('Build.PL', [], [@args])
539 my ($self, @args) = @_;
540 require Module::Build;
541 my $build_script = $^O eq 'VMS' ? 'Build.com' : 'Build';
542 return Module::Build->run_perl_script($build_script, [], [@args])
552 DistGen - Creates simple distributions for testing.
558 # create distribution and prepare to test
559 my $dist = DistGen->new(name => 'Foo::Bar');
562 # change distribution files
563 $dist->add_file('t/some_test.t', $contents);
564 $dist->change_file('MANIFEST.SKIP', $new_contents);
565 $dist->remove_file('t/some_test.t');
568 # undo changes and clean up extraneous files
572 # exercise the command-line interface
573 $dist->run_build_pl();
574 $dist->run_build('test');
576 # start over as a new distribution
577 $dist->reset( name => 'Foo::Bar', xs => 1 );
582 A DistGen object manages a set of files in a distribution directory.
584 The C<new()> constructor initializes the object and creates an empty
585 directory for the distribution. It does not create files or chdir into
586 the directory. The C<reset()> method re-initializes the object in a
587 new directory with new parameters. It also does not create files or change
588 the current directory.
590 Some methods only define the target state of the distribution. They do B<not>
591 make any changes to the filesystem:
599 Other methods then change the filesystem to match the target state of
606 Other methods are provided for a convenience during testing. The
607 most important is the one to enter the distribution directory:
611 Additional methods portably encapsulate running Build.PL and Build:
622 Create a new object and an empty directory to hold the distribution's files.
623 If no C<dir> option is provided, it defaults to MBTest->tmpdir, which sets
624 a different temp directory for Perl core testing and CPAN testing.
626 The C<new> method does not write any files -- see L</regen()> below.
628 my $dist = DistGen->new(
630 dir => MBTest->tmpdir,
635 The parameters are as follows.
641 The name of the module this distribution represents. The default is
642 'Simple'. This should be a "Foo::Bar" (module) name, not a "Foo-Bar"
647 The (parent) directory in which to create the distribution directory. The
648 distribution will be created under this according to C<distdir> parameter
649 below. Defaults to a temporary directory.
651 $dist = DistGen->new( dir => '/tmp/MB-test' );
654 # distribution files have been created in /tmp/MB-test/Simple
658 The name of the distribution directory to create. Defaults to the dist form of
659 C<name>, e.g. 'Foo-Bar' if C<name> is 'Foo::Bar'.
663 If true, generates an XS based module.
667 If true, C<regen()> will not create a MANIFEST file.
671 The following files are added as part of the default distribution:
674 lib/Simple.pm # based on name parameter
677 If an XS module is generated, Simple.pm and basic.t are different and
678 the following files are also added:
681 lib/Simple.xs # based on name parameter
685 The C<reset> method re-initializes the object as if it were generated
686 from a fresh call to C<new>. It takes the same optional parameters as C<new>.
688 $dist->reset( name => 'Foo::Bar', xs => 0 );
690 =head2 Adding and editing files
692 Note that C<$filename> should always be specified with unix-style paths,
693 and are relative to the distribution root directory, e.g. C<lib/Module.pm>.
695 No changes are made to the filesystem until the distribution is regenerated.
699 Add a $filename containing $content to the distribution.
701 $dist->add_file( $filename, $content );
705 Changes the contents of $filename to $content. No action is performed
706 until the distribution is regenerated.
708 $dist->change_file( $filename, $content );
710 =head3 change_build_pl()
712 A wrapper around change_file specifically for setting Build.PL. Instead
713 of file C<$content>, it takes a hash-ref of Module::Build constructor
716 $dist->change_build_pl(
718 module_name => $dist->name,
719 dist_version => '3.14159265',
727 Retrieves the target contents of C<$filename>.
729 $content = $dist->get_file( $filename );
733 Removes C<$filename> from the distribution.
735 $dist->remove_file( $filename );
739 Returns the object to its initial state, or given a $filename it returns that
740 file to its initial state if it is one of the built-in files.
743 $dist->revert($filename);
745 =head2 Changing the distribution directory
747 These methods immediately affect the filesystem.
751 Regenerate all missing or changed files. Also deletes any files
752 flagged for removal with remove_file().
754 $dist->regen(clean => 1);
756 If the optional C<clean> argument is given, it also calls C<clean>. These
757 can also be chained like this, instead:
763 Removes any files that are not part of the distribution.
769 Changes back to the original directory and removes the distribution
770 directory (but not the temporary directory set during C<new()>).
772 $dist = DistGen->new->chdir->regen;
773 # ... do some testing ...
775 $dist->remove->chdir_in->regen;
776 # ... do more testing ...
778 This is like a more aggressive form of C<clean>. Generally, calling C<clean>
779 and C<regen> should be sufficient.
781 =head2 Changing directories
785 Change directory into the dist root.
789 =head3 chdir_original
791 Returns to whatever directory you were in before chdir_in() (regardless
794 $dist->chdir_original;
796 =head2 Command-line helpers
798 These use Module::Build->run_perl_script() to ensure that Build.PL or Build are
799 run in a separate process using the current perl interpreter. (Module::Build
800 is loaded on demand). They also ensure appropriate naming for operating
801 systems that require a suffix for Build.
805 Runs Build.PL using the current perl interpreter. Any arguments are
806 passed on the command line.
808 $dist->run_build_pl('--quiet');
812 Runs Build using the current perl interpreter. Any arguments are
813 passed on the command line.
815 $dist->run_build(qw/test --verbose/);
821 Returns the name of the distribution.
823 $dist->name: # e.g. Foo::Bar
827 Returns the directory where the distribution is created.
829 $dist->dirname; # e.g. t/_tmp/Simple
835 Removes leading whitespace from a multi-line string according to the
836 amount of whitespace on the first line.
838 my $string = undent(" foo(\n bar => 'baz'\n )");
845 # vim:ts=2:sw=2:et:sta