1package DistGen; 2 3use strict; 4 5use vars qw( $VERSION $VERBOSE @EXPORT_OK); 6 7$VERSION = '0.01'; 8$VERBOSE = 0; 9 10use Carp; 11 12use MBTest (); 13use Cwd (); 14use File::Basename (); 15use File::Find (); 16use File::Path (); 17use File::Spec (); 18use Tie::CPHash; 19use Data::Dumper; 20 21my $vms_mode; 22my $vms_lower_case; 23 24BEGIN { 25 $vms_mode = 0; 26 $vms_lower_case = 0; 27 if( $^O eq 'VMS' ) { 28 # For things like vmsify() 29 require VMS::Filespec; 30 VMS::Filespec->import; 31 $vms_mode = 1; 32 $vms_lower_case = 1; 33 my $vms_efs_case = 0; 34 my $unix_rpt = 0; 35 if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { 36 $unix_rpt = VMS::Feature::current("filename_unix_report"); 37 $vms_efs_case = VMS::Feature::current("efs_case_preserve"); 38 } else { 39 my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; 40 $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; 41 my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; 42 $vms_efs_case = $efs_case =~ /^[ET1]/i; 43 } 44 $vms_mode = 0 if $unix_rpt; 45 $vms_lower_case = 0 if $vms_efs_case; 46 } 47} 48BEGIN { 49 require Exporter; 50 *{import} = \&Exporter::import; 51 @EXPORT_OK = qw( 52 undent 53 ); 54} 55 56sub undent { 57 my ($string) = @_; 58 59 my ($space) = $string =~ m/^(\s+)/; 60 $string =~ s/^$space//gm; 61 62 return($string); 63} 64 65sub chdir_all ($) { 66 # OS/2 has "current directory per disk", undeletable; 67 # doing chdir() to another disk won't change cur-dir of initial disk... 68 chdir('/') if $^O eq 'os2'; 69 chdir shift; 70} 71 72######################################################################## 73 74END { chdir_all(MBTest->original_cwd); } 75 76sub new { 77 my $self = bless {}, shift; 78 $self->reset(@_); 79} 80 81sub reset { 82 my $self = shift; 83 my %options = @_; 84 85 $options{name} ||= 'Simple'; 86 $options{version} ||= q{'0.01'}; 87 $options{license} ||= 'perl'; 88 $options{dir} = File::Spec->rel2abs( 89 defined $options{dir} ? $options{dir} : MBTest->tmpdir 90 ); 91 92 my %data = ( 93 no_manifest => 0, 94 xs => 0, 95 inc => 0, 96 %options, 97 ); 98 %$self = %data; 99 100 tie %{$self->{filedata}}, 'Tie::CPHash'; 101 102 tie %{$self->{pending}{change}}, 'Tie::CPHash'; 103 104 # start with a fresh, empty directory 105 if ( -d $self->dirname ) { 106 warn "Warning: Removing existing directory '@{[$self->dirname]}'\n"; 107 File::Path::rmtree( $self->dirname ); 108 } 109 File::Path::mkpath( $self->dirname ); 110 111 $self->_gen_default_filedata(); 112 113 return $self; 114} 115 116sub remove { 117 my $self = shift; 118 $self->chdir_original if($self->did_chdir); 119 File::Path::rmtree( $self->dirname ); 120 return $self; 121} 122 123sub revert { 124 my ($self, $file) = @_; 125 if ( defined $file ) { 126 delete $self->{filedata}{$file}; 127 delete $self->{pending}{$_}{$file} for qw/change remove/; 128 } 129 else { 130 delete $self->{filedata}{$_} for keys %{ $self->{filedata} }; 131 for my $pend ( qw/change remove/ ) { 132 delete $self->{pending}{$pend}{$_} for keys %{ $self->{pending}{$pend} }; 133 } 134 } 135 $self->_gen_default_filedata; 136} 137 138sub _gen_default_filedata { 139 my $self = shift; 140 141 # TODO maybe a public method like this (but with a better name?) 142 my $add_unless = sub { 143 my $self = shift; 144 my ($member, $data) = @_; 145 $self->add_file($member, $data) unless($self->{filedata}{$member}); 146 }; 147 148 if ( ! $self->{inc} ) { 149 $self->$add_unless('Build.PL', undent(<<" ---")); 150 use strict; 151 use Module::Build; 152 153 my \$builder = Module::Build->new( 154 module_name => '$self->{name}', 155 license => '$self->{license}', 156 ); 157 158 \$builder->create_build_script(); 159 --- 160 } 161 else { 162 $self->$add_unless('Build.PL', undent(<<" ---")); 163 use strict; 164 use inc::latest 'Module::Build'; 165 166 my \$builder = Module::Build->new( 167 module_name => '$self->{name}', 168 license => '$self->{license}', 169 ); 170 171 \$builder->create_build_script(); 172 --- 173 } 174 175 my $module_filename = 176 join( '/', ('lib', split(/::/, $self->{name})) ) . '.pm'; 177 178 unless ( $self->{xs} ) { 179 $self->$add_unless($module_filename, undent(<<" ---")); 180 package $self->{name}; 181 182 use vars qw( \$VERSION ); 183 \$VERSION = $self->{version}; 184 185 use strict; 186 187 1; 188 189 __END__ 190 191 =head1 NAME 192 193 $self->{name} - Perl extension for blah blah blah 194 195 =head1 DESCRIPTION 196 197 Stub documentation for $self->{name}. 198 199 =head1 AUTHOR 200 201 A. U. Thor, a.u.thor\@a.galaxy.far.far.away 202 203 =cut 204 --- 205 206 $self->$add_unless('t/basic.t', undent(<<" ---")); 207 use Test::More tests => 1; 208 use strict; 209 210 use $self->{name}; 211 ok 1; 212 --- 213 214 } else { 215 $self->$add_unless($module_filename, undent(<<" ---")); 216 package $self->{name}; 217 218 \$VERSION = $self->{version}; 219 220 require Exporter; 221 require DynaLoader; 222 223 \@ISA = qw(Exporter DynaLoader); 224 \@EXPORT_OK = qw( okay ); 225 226 bootstrap $self->{name} \$VERSION; 227 228 1; 229 230 __END__ 231 232 =head1 NAME 233 234 $self->{name} - Perl extension for blah blah blah 235 236 =head1 DESCRIPTION 237 238 Stub documentation for $self->{name}. 239 240 =head1 AUTHOR 241 242 A. U. Thor, a.u.thor\@a.galaxy.far.far.away 243 244 =cut 245 --- 246 247 my $xs_filename = 248 join( '/', ('lib', split(/::/, $self->{name})) ) . '.xs'; 249 $self->$add_unless($xs_filename, undent(<<" ---")); 250 #include "EXTERN.h" 251 #include "perl.h" 252 #include "XSUB.h" 253 254 MODULE = $self->{name} PACKAGE = $self->{name} 255 256 SV * 257 okay() 258 CODE: 259 RETVAL = newSVpv( "ok", 0 ); 260 OUTPUT: 261 RETVAL 262 263 const char * 264 xs_version() 265 CODE: 266 RETVAL = XS_VERSION; 267 OUTPUT: 268 RETVAL 269 270 const char * 271 version() 272 CODE: 273 RETVAL = VERSION; 274 OUTPUT: 275 RETVAL 276 --- 277 278 # 5.6 is missing const char * in its typemap 279 $self->$add_unless('typemap', undent(<<" ---")); 280 const char *\tT_PV 281 --- 282 283 $self->$add_unless('t/basic.t', undent(<<" ---")); 284 use Test::More tests => 2; 285 use strict; 286 287 use $self->{name}; 288 ok 1; 289 290 ok( $self->{name}::okay() eq 'ok' ); 291 --- 292 } 293} 294 295sub _gen_manifest { 296 my $self = shift; 297 my $manifest = shift; 298 299 open(my $fh, '>', $manifest ) or do { 300 die "Can't write '$manifest'\n"; 301 }; 302 303 my @files = ( 'MANIFEST', keys %{$self->{filedata}} ); 304 my $data = join( "\n", sort @files ) . "\n"; 305 print $fh $data; 306 close( $fh ); 307 308 $self->{filedata}{MANIFEST} = $data; 309 $self->{pending}{change}{MANIFEST} = 1; 310} 311 312sub name { shift()->{name} } 313 314sub dirname { 315 my $self = shift; 316 my $dist = $self->{distdir} || join( '-', split( /::/, $self->{name} ) ); 317 return File::Spec->catdir( $self->{dir}, $dist ); 318} 319 320sub _real_filename { 321 my $self = shift; 322 my $filename = shift; 323 return File::Spec->catfile( split( /\//, $filename ) ); 324} 325 326sub regen { 327 my $self = shift; 328 my %opts = @_; 329 330 my $dist_dirname = $self->dirname; 331 332 if ( $opts{clean} ) { 333 $self->clean() if -d $dist_dirname; 334 } else { 335 # TODO: This might leave dangling directories; e.g. if the removed file 336 # is 'lib/Simple/Simon.pm', the directory 'lib/Simple' will be left 337 # even if there are no files left in it. However, clean() will remove it. 338 my @files = keys %{$self->{pending}{remove}}; 339 foreach my $file ( @files ) { 340 my $real_filename = $self->_real_filename( $file ); 341 my $fullname = File::Spec->catfile( $dist_dirname, $real_filename ); 342 if ( -e $fullname ) { 343 1 while unlink( $fullname ); 344 } 345 print "Unlinking pending file '$file'\n" if $VERBOSE; 346 delete( $self->{pending}{remove}{$file} ); 347 } 348 } 349 350 foreach my $file ( keys( %{$self->{filedata}} ) ) { 351 my $real_filename = $self->_real_filename( $file ); 352 my $fullname = File::Spec->catfile( $dist_dirname, $real_filename ); 353 354 if ( ! -e $fullname || 355 ( -e $fullname && $self->{pending}{change}{$file} ) ) { 356 357 print "Changed file '$file'.\n" if $VERBOSE; 358 359 my $dirname = File::Basename::dirname( $fullname ); 360 unless ( -d $dirname ) { 361 File::Path::mkpath( $dirname ) or do { 362 die "Can't create '$dirname'\n"; 363 }; 364 } 365 366 if ( -e $fullname ) { 367 1 while unlink( $fullname ); 368 } 369 370 open(my $fh, '>', $fullname) or do { 371 die "Can't write '$fullname'\n"; 372 }; 373 print $fh $self->{filedata}{$file}; 374 close( $fh ); 375 } 376 377 delete( $self->{pending}{change}{$file} ); 378 } 379 380 my $manifest = File::Spec->catfile( $dist_dirname, 'MANIFEST' ); 381 unless ( $self->{no_manifest} ) { 382 if ( -e $manifest ) { 383 1 while unlink( $manifest ); 384 } 385 $self->_gen_manifest( $manifest ); 386 } 387 return $self; 388} 389 390sub clean { 391 my $self = shift; 392 393 my $here = Cwd::abs_path(); 394 my $there = File::Spec->rel2abs( $self->dirname() ); 395 396 if ( -d $there ) { 397 chdir( $there ) or die "Can't change directory to '$there'\n"; 398 } else { 399 die "Distribution not found in '$there'\n"; 400 } 401 402 my %names; 403 tie %names, 'Tie::CPHash'; 404 foreach my $file ( keys %{$self->{filedata}} ) { 405 my $filename = $self->_real_filename( $file ); 406 $filename = lc($filename) if $vms_lower_case; 407 my $dirname = File::Basename::dirname( $filename ); 408 409 $names{$filename} = 0; 410 411 print "Splitting '$dirname'\n" if $VERBOSE; 412 my @dirs = File::Spec->splitdir( $dirname ); 413 while ( @dirs ) { 414 my $dir = ( scalar(@dirs) == 1 415 ? $dirname 416 : File::Spec->catdir( @dirs ) ); 417 if (length $dir) { 418 print "Setting directory name '$dir' in \%names\n" if $VERBOSE; 419 $names{$dir} = 0; 420 } 421 pop( @dirs ); 422 } 423 } 424 425 File::Find::finddepth( sub { 426 my $name = File::Spec->canonpath( $File::Find::name ); 427 428 if ($vms_mode) { 429 if ($name ne '.') { 430 $name =~ s/\.\z//; 431 $name = vmspath($name) if -d $name; 432 } 433 } 434 if ($^O eq 'VMS') { 435 $name = File::Spec->rel2abs($name) if $name eq File::Spec->curdir(); 436 } 437 438 if ( not exists $names{$name} ) { 439 print "Removing '$name'\n" if $VERBOSE; 440 File::Path::rmtree( $_ ); 441 } 442 }, ($^O eq 'VMS' ? './' : File::Spec->curdir) ); 443 444 chdir_all( $here ); 445 return $self; 446} 447 448sub add_file { 449 my $self = shift; 450 $self->change_file( @_ ); 451} 452 453sub remove_file { 454 my $self = shift; 455 my $file = shift; 456 unless ( exists $self->{filedata}{$file} ) { 457 warn "Can't remove '$file': It does not exist.\n" if $VERBOSE; 458 } 459 delete( $self->{filedata}{$file} ); 460 $self->{pending}{remove}{$file} = 1; 461 return $self; 462} 463 464sub change_build_pl { 465 my ($self, @opts) = @_; 466 467 my $opts = ref $opts[0] eq 'HASH' ? $opts[0] : { @opts }; 468 469 local $Data::Dumper::Terse = 1; 470 (my $args = Dumper($opts)) =~ s/^\s*\{|\}\s*$//g; 471 472 $self->change_file( 'Build.PL', undent(<<" ---") ); 473 use strict; 474 use Module::Build; 475 my \$b = Module::Build->new( 476 # Some CPANPLUS::Dist::Build versions need to allow mismatches 477 # On logic: thanks to Module::Install, CPAN.pm must set both keys, but 478 # CPANPLUS sets only the one 479 allow_mb_mismatch => ( 480 \$ENV{PERL5_CPANPLUS_IS_RUNNING} && ! \$ENV{PERL5_CPAN_IS_RUNNING} ? 1 : 0 481 ), 482 $args 483 ); 484 \$b->create_build_script(); 485 --- 486 return $self; 487} 488 489sub change_file { 490 my $self = shift; 491 my $file = shift; 492 my $data = shift; 493 $self->{filedata}{$file} = $data; 494 $self->{pending}{change}{$file} = 1; 495 return $self; 496} 497 498sub get_file { 499 my $self = shift; 500 my $file = shift; 501 exists($self->{filedata}{$file}) or croak("no such entry: '$file'"); 502 return $self->{filedata}{$file}; 503} 504 505sub chdir_in { 506 my $self = shift; 507 $self->{original_dir} ||= Cwd::cwd; # only once! 508 my $dir = $self->dirname; 509 chdir($dir) or die "Can't chdir to '$dir': $!"; 510 return $self; 511} 512######################################################################## 513 514sub did_chdir { exists shift()->{original_dir} } 515 516######################################################################## 517 518sub chdir_original { 519 my $self = shift; 520 521 my $dir = delete $self->{original_dir}; 522 chdir_all($dir) or die "Can't chdir to '$dir': $!"; 523 return $self; 524} 525######################################################################## 526 527sub new_from_context { 528 my ($self, @args) = @_; 529 require Module::Build; 530 return Module::Build->new_from_context( quiet => 1, @args ); 531} 532 533sub run_build_pl { 534 my ($self, @args) = @_; 535 require Module::Build; 536 return Module::Build->run_perl_script('Build.PL', [], [@args]) 537} 538 539sub run_build { 540 my ($self, @args) = @_; 541 require Module::Build; 542 my $build_script = $^O eq 'VMS' ? 'Build.com' : 'Build'; 543 return Module::Build->run_perl_script($build_script, [], [@args]) 544} 545 5461; 547 548__END__ 549 550 551=head1 NAME 552 553DistGen - Creates simple distributions for testing. 554 555=head1 SYNOPSIS 556 557 use DistGen; 558 559 # create distribution and prepare to test 560 my $dist = DistGen->new(name => 'Foo::Bar'); 561 $dist->chdir_in; 562 563 # change distribution files 564 $dist->add_file('t/some_test.t', $contents); 565 $dist->change_file('MANIFEST.SKIP', $new_contents); 566 $dist->remove_file('t/some_test.t'); 567 $dist->regen; 568 569 # undo changes and clean up extraneous files 570 $dist->revert; 571 $dist->clean; 572 573 # exercise the command-line interface 574 $dist->run_build_pl(); 575 $dist->run_build('test'); 576 577 # start over as a new distribution 578 $dist->reset( name => 'Foo::Bar', xs => 1 ); 579 $dist->chdir_in; 580 581=head1 USAGE 582 583A DistGen object manages a set of files in a distribution directory. 584 585The C<new()> constructor initializes the object and creates an empty 586directory for the distribution. It does not create files or chdir into 587the directory. The C<reset()> method re-initializes the object in a 588new directory with new parameters. It also does not create files or change 589the current directory. 590 591Some methods only define the target state of the distribution. They do B<not> 592make any changes to the filesystem: 593 594 add_file 595 change_file 596 change_build_pl 597 remove_file 598 revert 599 600Other methods then change the filesystem to match the target state of 601the distribution: 602 603 clean 604 regen 605 remove 606 607Other methods are provided for a convenience during testing. The 608most important is the one to enter the distribution directory: 609 610 chdir_in 611 612Additional methods portably encapsulate running Build.PL and Build: 613 614 run_build_pl 615 run_build 616 617=head1 API 618 619=head2 Constructors 620 621=head3 new() 622 623Create a new object and an empty directory to hold the distribution's files. 624If no C<dir> option is provided, it defaults to MBTest->tmpdir, which sets 625a different temp directory for Perl core testing and CPAN testing. 626 627The C<new> method does not write any files -- see L</regen()> below. 628 629 my $dist = DistGen->new( 630 name => 'Foo::Bar', 631 version => '0.01', 632 license => 'perl', 633 dir => MBTest->tmpdir, 634 xs => 1, 635 no_manifest => 0, 636 ); 637 638The parameters are as follows. 639 640=over 641 642=item name 643 644The name of the module this distribution represents. The default is 645'Simple'. This should be a "Foo::Bar" (module) name, not a "Foo-Bar" 646dist name. 647 648=item version 649 650The version string that will be set. (E.g. C<our $VERSION = 0.01>) 651Note -- to put this value in quotes, add those to the string. 652 653 version => q{'0.01_01'} 654 655=item license 656 657The license string that will be set in Build.PL. Defaults to 'perl'. 658 659=item dir 660 661The (parent) directory in which to create the distribution directory. The 662distribution will be created under this according to C<distdir> parameter 663below. Defaults to a temporary directory. 664 665 $dist = DistGen->new( dir => '/tmp/MB-test' ); 666 $dist->regen; 667 668 # distribution files have been created in /tmp/MB-test/Simple 669 670=item distdir 671 672The name of the distribution directory to create. Defaults to the dist form of 673C<name>, e.g. 'Foo-Bar' if C<name> is 'Foo::Bar'. 674 675=item xs 676 677If true, generates an XS based module. 678 679=item no_manifest 680 681If true, C<regen()> will not create a MANIFEST file. 682 683=back 684 685The following files are added as part of the default distribution: 686 687 Build.PL 688 lib/Simple.pm # based on name parameter 689 t/basic.t 690 691If an XS module is generated, Simple.pm and basic.t are different and 692the following files are also added: 693 694 typemap 695 lib/Simple.xs # based on name parameter 696 697=head3 reset() 698 699The C<reset> method re-initializes the object as if it were generated 700from a fresh call to C<new>. It takes the same optional parameters as C<new>. 701 702 $dist->reset( name => 'Foo::Bar', xs => 0 ); 703 704=head2 Adding and editing files 705 706Note that C<$filename> should always be specified with unix-style paths, 707and are relative to the distribution root directory, e.g. C<lib/Module.pm>. 708 709No changes are made to the filesystem until the distribution is regenerated. 710 711=head3 add_file() 712 713Add a $filename containing $content to the distribution. 714 715 $dist->add_file( $filename, $content ); 716 717=head3 change_file() 718 719Changes the contents of $filename to $content. No action is performed 720until the distribution is regenerated. 721 722 $dist->change_file( $filename, $content ); 723 724=head3 change_build_pl() 725 726A wrapper around change_file specifically for setting Build.PL. Instead 727of file C<$content>, it takes a hash-ref of Module::Build constructor 728arguments: 729 730 $dist->change_build_pl( 731 { 732 module_name => $dist->name, 733 dist_version => '3.14159265', 734 license => 'perl', 735 create_readme => 1, 736 } 737 ); 738 739=head3 get_file 740 741Retrieves the target contents of C<$filename>. 742 743 $content = $dist->get_file( $filename ); 744 745=head3 remove_file() 746 747Removes C<$filename> from the distribution. 748 749 $dist->remove_file( $filename ); 750 751=head3 revert() 752 753Returns the object to its initial state, or given a $filename it returns that 754file to its initial state if it is one of the built-in files. 755 756 $dist->revert; 757 $dist->revert($filename); 758 759=head2 Changing the distribution directory 760 761These methods immediately affect the filesystem. 762 763=head3 regen() 764 765Regenerate all missing or changed files. Also deletes any files 766flagged for removal with remove_file(). 767 768 $dist->regen(clean => 1); 769 770If the optional C<clean> argument is given, it also calls C<clean>. These 771can also be chained like this, instead: 772 773 $dist->clean->regen; 774 775=head3 clean() 776 777Removes any files that are not part of the distribution. 778 779 $dist->clean; 780 781=head3 remove() 782 783Changes back to the original directory and removes the distribution 784directory (but not the temporary directory set during C<new()>). 785 786 $dist = DistGen->new->chdir->regen; 787 # ... do some testing ... 788 789 $dist->remove->chdir_in->regen; 790 # ... do more testing ... 791 792This is like a more aggressive form of C<clean>. Generally, calling C<clean> 793and C<regen> should be sufficient. 794 795=head2 Changing directories 796 797=head3 chdir_in 798 799Change directory into the dist root. 800 801 $dist->chdir_in; 802 803=head3 chdir_original 804 805Returns to whatever directory you were in before chdir_in() (regardless 806of the cwd.) 807 808 $dist->chdir_original; 809 810=head2 Command-line helpers 811 812These use Module::Build->run_perl_script() to ensure that Build.PL or Build are 813run in a separate process using the current perl interpreter. (Module::Build 814is loaded on demand). They also ensure appropriate naming for operating 815systems that require a suffix for Build. 816 817=head3 run_build_pl 818 819Runs Build.PL using the current perl interpreter. Any arguments are 820passed on the command line. 821 822 $dist->run_build_pl('--quiet'); 823 824=head3 run_build 825 826Runs Build using the current perl interpreter. Any arguments are 827passed on the command line. 828 829 $dist->run_build(qw/test --verbose/); 830 831=head2 Properties 832 833=head3 name() 834 835Returns the name of the distribution. 836 837 $dist->name: # e.g. Foo::Bar 838 839=head3 dirname() 840 841Returns the directory where the distribution is created. 842 843 $dist->dirname; # e.g. t/_tmp/Simple 844 845=head2 Functions 846 847=head3 undent() 848 849Removes leading whitespace from a multi-line string according to the 850amount of whitespace on the first line. 851 852 my $string = undent(" foo(\n bar => 'baz'\n )"); 853 $string eq "foo( 854 bar => 'baz' 855 )"; 856 857=cut 858 859# vim:ts=2:sw=2:et:sta 860