lib/Module/Build/t/lib/DistGen.pm

   1 package DistGen;
   2
   3 use strict;
   4
   5 use vars qw( $VERSION $VERBOSE @EXPORT_OK);
   6
   7 $VERSION = '0.01';
   8 $VERBOSE = 0;
   9
  10
  11 use Carp;
  12
  13 use Cwd ();
  14 use File::Basename ();
  15 use File::Find ();
  16 use File::Path ();
  17 use File::Spec ();
  18 use IO::File ();
  19 use Tie::CPHash;
  20 use Data::Dumper;
  21
  22 BEGIN {
  23   if( $^O eq 'VMS' ) {
  24     # For things like vmsify()
  25     require VMS::Filespec;
  26     VMS::Filespec->import;
  27   }
  28 }
  29 BEGIN {
  30   require Exporter;
  31   *{import} = \&Exporter::import;
  32   @EXPORT_OK = qw(
  33     undent
  34   );
  35 }
  36
  37 sub undent {
  38   my ($string) = @_;
  39
  40   my ($space) = $string =~ m/^(\s+)/;
  41   $string =~ s/^$space//gm;
  42
  43   return($string);
  44 }
  45 ########################################################################
  46
  47 sub new {
  48   my $package = shift;
  49   my %options = @_;
  50
  51   $options{name} ||= 'Simple';
  52   $options{dir}  ||= Cwd::cwd();
  53
  54   my %data = (
  55     skip_manifest => 0,
  56     xs            => 0,
  57     %options,
  58   );
  59   my $self = bless( \%data, $package );
  60
  61   # So we can clean up later even if the caller chdir()s
  62   $self->{dir} = File::Spec->rel2abs($self->{dir});
  63
  64   tie %{$self->{filedata}}, 'Tie::CPHash';
  65
  66   tie %{$self->{pending}{change}}, 'Tie::CPHash';
  67
  68   if ( -d $self->dirname ) {
  69     warn "Warning: Removing existing directory '@{[$self->dirname]}'\n";
  70     $self->remove;
  71   }
  72
  73   $self->_gen_default_filedata();
  74
  75   return $self;
  76 }
  77
  78 sub _gen_default_filedata {
  79   my $self = shift;
  80
  81   # TODO maybe a public method like this (but with a better name?)
  82   my $add_unless = sub {
  83     my $self = shift;
  84     my ($member, $data) = @_;
  85     $self->add_file($member, $data) unless($self->{filedata}{$member});
  86   };
  87
  88   $self->$add_unless('Build.PL', undent(<<"    ---"));
  89     use strict;
  90     use Module::Build;
  91
  92     my \$builder = Module::Build->new(
  93         module_name         => '$self->{name}',
  94         license             => 'perl',
  95     );
  96
  97     \$builder->create_build_script();
  98     ---
  99
 100   my $module_filename =
 101     join( '/', ('lib', split(/::/, $self->{name})) ) . '.pm';
 102
 103   unless ( $self->{xs} ) {
 104     $self->$add_unless($module_filename, undent(<<"      ---"));
 105       package $self->{name};
 106
 107       use vars qw( \$VERSION );
 108       \$VERSION = '0.01';
 109
 110       use strict;
 111
 112       1;
 113
 114       __END__
 115
 116       =head1 NAME
 117
 118       $self->{name} - Perl extension for blah blah blah
 119
 120       =head1 DESCRIPTION
 121
 122       Stub documentation for $self->{name}.
 123
 124       =head1 AUTHOR
 125
 126       A. U. Thor, a.u.thor\@a.galaxy.far.far.away
 127
 128       =cut
 129       ---
 130
 131   $self->$add_unless('t/basic.t', undent(<<"    ---"));
 132     use Test::More tests => 1;
 133     use strict;
 134
 135     use $self->{name};
 136     ok 1;
 137     ---
 138
 139   } else {
 140     $self->$add_unless($module_filename, undent(<<"      ---"));
 141       package $self->{name};
 142
 143       \$VERSION = '0.01';
 144
 145       require Exporter;
 146       require DynaLoader;
 147
 148       \@ISA = qw(Exporter DynaLoader);
 149       \@EXPORT_OK = qw( okay );
 150
 151       bootstrap $self->{name} \$VERSION;
 152
 153       1;
 154
 155       __END__
 156
 157       =head1 NAME
 158
 159       $self->{name} - Perl extension for blah blah blah
 160
 161       =head1 DESCRIPTION
 162
 163       Stub documentation for $self->{name}.
 164
 165       =head1 AUTHOR
 166
 167       A. U. Thor, a.u.thor\@a.galaxy.far.far.away
 168
 169       =cut
 170       ---
 171
 172     my $xs_filename =
 173       join( '/', ('lib', split(/::/, $self->{name})) ) . '.xs';
 174     $self->$add_unless($xs_filename, undent(<<"      ---"));
 175       #include "EXTERN.h"
 176       #include "perl.h"
 177       #include "XSUB.h"
 178
 179       MODULE = $self->{name}         PACKAGE = $self->{name}
 180
 181       SV *
 182       okay()
 183           CODE:
 184               RETVAL = newSVpv( "ok", 0 );
 185           OUTPUT:
 186               RETVAL
 187
 188       const char *
 189       xs_version()
 190           CODE:
 191         RETVAL = XS_VERSION;
 192           OUTPUT:
 193         RETVAL
 194
 195       const char *
 196       version()
 197           CODE:
 198         RETVAL = VERSION;
 199           OUTPUT:
 200         RETVAL
 201       ---
 202
 203   # 5.6 is missing const char * in its typemap
 204   $self->$add_unless('typemap', undent(<<"      ---"));
 205       const char *              T_PV
 206       ---
 207
 208   $self->$add_unless('t/basic.t', undent(<<"    ---"));
 209     use Test::More tests => 2;
 210     use strict;
 211
 212     use $self->{name};
 213     ok 1;
 214
 215     ok( $self->{name}::okay() eq 'ok' );
 216     ---
 217   }
 218 }
 219
 220 sub _gen_manifest {
 221   my $self     = shift;
 222   my $manifest = shift;
 223
 224   my $fh = IO::File->new( ">$manifest" ) or do {
 225     $self->remove();
 226     die "Can't write '$manifest'\n";
 227   };
 228
 229   my @files = ( 'MANIFEST', keys %{$self->{filedata}} );
 230   my $data = join( "\n", sort @files ) . "\n";
 231   print $fh $data;
 232   close( $fh );
 233
 234   $self->{filedata}{MANIFEST} = $data;
 235   $self->{pending}{change}{MANIFEST} = 1;
 236 }
 237
 238 sub name { shift()->{name} }
 239
 240 sub dirname {
 241   my $self = shift;
 242   my $dist = join( '-', split( /::/, $self->{name} ) );
 243   return File::Spec->catdir( $self->{dir}, $dist );
 244 }
 245
 246 sub _real_filename {
 247   my $self = shift;
 248   my $filename = shift;
 249   return File::Spec->catfile( split( /\//, $filename ) );
 250 }
 251
 252 sub regen {
 253   my $self = shift;
 254   my %opts = @_;
 255
 256   my $dist_dirname = $self->dirname;
 257
 258   if ( $opts{clean} ) {
 259     $self->clean() if -d $dist_dirname;
 260   } else {
 261     # TODO: This might leave dangling directories. Eg if the removed file
 262     # is 'lib/Simple/Simon.pm', The directory 'lib/Simple' will be left
 263     # even if there are no files left in it. However, clean() will remove it.
 264     my @files = keys %{$self->{pending}{remove}};
 265     foreach my $file ( @files ) {
 266       my $real_filename = $self->_real_filename( $file );
 267       my $fullname = File::Spec->catfile( $dist_dirname, $real_filename );
 268       if ( -e $fullname ) {
 269         1 while unlink( $fullname );
 270       }
 271       print "Unlinking pending file '$file'\n" if $VERBOSE;
 272       delete( $self->{pending}{remove}{$file} );
 273     }
 274   }
 275
 276   foreach my $file ( keys( %{$self->{filedata}} ) ) {
 277     my $real_filename = $self->_real_filename( $file );
 278     my $fullname = File::Spec->catfile( $dist_dirname, $real_filename );
 279
 280     if ( ! -e $fullname ||
 281          ( -e $fullname && $self->{pending}{change}{$file} ) ) {
 282
 283       print "Changed file '$file'.\n" if $VERBOSE;
 284
 285       my $dirname = File::Basename::dirname( $fullname );
 286       unless ( -d $dirname ) {
 287         File::Path::mkpath( $dirname ) or do {
 288           $self->remove();
 289           die "Can't create '$dirname'\n";
 290         };
 291       }
 292
 293       if ( -e $fullname ) {
 294         1 while unlink( $fullname );
 295       }
 296
 297       my $fh = IO::File->new(">$fullname") or do {
 298         $self->remove();
 299         die "Can't write '$fullname'\n";
 300       };
 301       print $fh $self->{filedata}{$file};
 302       close( $fh );
 303     }
 304
 305     delete( $self->{pending}{change}{$file} );
 306   }
 307
 308   my $manifest = File::Spec->catfile( $dist_dirname, 'MANIFEST' );
 309   unless ( $self->{skip_manifest} ) {
 310     if ( -e $manifest ) {
 311       1 while unlink( $manifest );
 312     }
 313     $self->_gen_manifest( $manifest );
 314   }
 315 }
 316
 317 sub clean {
 318   my $self = shift;
 319
 320   my $here  = Cwd::abs_path();
 321   my $there = File::Spec->rel2abs( $self->dirname() );
 322
 323   if ( -d $there ) {
 324     chdir( $there ) or die "Can't change directory to '$there'\n";
 325   } else {
 326     die "Distribution not found in '$there'\n";
 327   }
 328
 329   my %names;
 330   tie %names, 'Tie::CPHash';
 331   foreach my $file ( keys %{$self->{filedata}} ) {
 332     my $filename = $self->_real_filename( $file );
 333     my $dirname = File::Basename::dirname( $filename );
 334
 335     $names{$filename} = 0;
 336
 337     print "Splitting '$dirname'\n" if $VERBOSE;
 338     my @dirs = File::Spec->splitdir( $dirname );
 339     while ( @dirs ) {
 340       my $dir = ( scalar(@dirs) == 1
 341                   ? $dirname
 342                   : File::Spec->catdir( @dirs ) );
 343       if (length $dir) {
 344         print "Setting directory name '$dir' in \%names\n" if $VERBOSE;
 345         $names{$dir} = 0;
 346       }
 347       pop( @dirs );
 348     }
 349   }
 350
 351   File::Find::finddepth( sub {
 352     my $name = File::Spec->canonpath( $File::Find::name );
 353
 354     if ($^O eq 'VMS') {
 355         $name =~ s/\.\z//;
 356         $name = vmspath($name) if -d $name;
 357         $name = File::Spec->rel2abs($name) if $name eq File::Spec->curdir();
 358     }
 359
 360     if ( not exists $names{$name} ) {
 361       print "Removing '$name'\n" if $VERBOSE;
 362       File::Path::rmtree( $_ );
 363     }
 364   }, ($^O eq "VMS" ? './' : File::Spec->curdir) );
 365
 366   chdir( $here );
 367 }
 368
 369 sub remove {
 370   my $self = shift;
 371   croak("invalid usage -- remove()") if(@_);
 372   $self->chdir_original if($self->did_chdir);
 373   File::Path::rmtree( $self->dirname );
 374   # might as well check
 375   croak("\nthis test should have used chdir_in()") unless(Cwd::getcwd);
 376 }
 377
 378 sub revert {
 379   my $self = shift;
 380   die "Unimplemented.\n";
 381 }
 382
 383 sub add_file {
 384   my $self = shift;
 385   $self->change_file( @_ );
 386 }
 387
 388 sub remove_file {
 389   my $self = shift;
 390   my $file = shift;
 391   unless ( exists $self->{filedata}{$file} ) {
 392     warn "Can't remove '$file': It does not exist.\n" if $VERBOSE;
 393   }
 394   delete( $self->{filedata}{$file} );
 395   $self->{pending}{remove}{$file} = 1;
 396 }
 397
 398 sub change_build_pl {
 399   my ($self, $opts) = @_;
 400
 401   local $Data::Dumper::Terse = 1;
 402   (my $args = Dumper($opts)) =~ s/^\s*\{|\}\s*$//g;
 403
 404   $self->change_file( 'Build.PL', undent(<<"    ---") );
 405     use strict;
 406     use Module::Build;
 407     my \$b = Module::Build->new(
 408     $args
 409     );
 410     \$b->create_build_script();
 411     ---
 412 }
 413
 414 sub change_file {
 415   my $self = shift;
 416   my $file = shift;
 417   my $data = shift;
 418   $self->{filedata}{$file} = $data;
 419   $self->{pending}{change}{$file} = 1;
 420 }
 421
 422 sub chdir_in {
 423   my $self = shift;
 424
 425   $self->{original_dir} ||= Cwd::cwd; # only once
 426   my $dir = $self->dirname;
 427   chdir($dir) or die "Can't chdir to '$dir': $!";
 428 }
 429 ########################################################################
 430
 431 sub did_chdir {
 432   my $self = shift;
 433
 434   return exists($self->{original_dir});
 435 }
 436 ########################################################################
 437
 438 sub chdir_original {
 439   my $self = shift;
 440
 441   croak("never called chdir_in()") unless($self->{original_dir});
 442   my $dir = $self->{original_dir};
 443   chdir($dir) or die "Can't chdir to '$dir': $!";
 444 }
 445 ########################################################################
 446
 447 1;
 448
 449 __END__
 450
 451
 452 =head1 NAME
 453
 454 DistGen - Creates simple distributions for testing.
 455
 456 =head1 SYNOPSIS
 457
 458   use DistGen;
 459
 460   my $dist = DistGen->new(dir => $tmp);
 461   ...
 462   $dist->add_file('t/some_test.t', $contents);
 463   ...
 464   $dist->regen;
 465
 466   chdir($dist->dirname) or
 467     die "Cannot chdir to '@{[$dist->dirname]}': $!";
 468   ...
 469   $dist->clean;
 470   ...
 471   chdir($cwd) or die "cannot return to $cwd";
 472   $dist->remove;
 473
 474 =head1 API
 475
 476 =head2 Constructor
 477
 478 =head3 new()
 479
 480 Create a new object.  Does not write its contents (see L</regen()>.)
 481
 482   my $tmp = MBTest->tmpdir;
 483   my $dist = DistGen->new(
 484     name => 'Foo::Bar',
 485     dir  => $tmp,
 486     xs   => 1,
 487   );
 488
 489 The parameters are as follows.
 490
 491 =over
 492
 493 =item name
 494
 495 The name of the module this distribution represents. The default is
 496 'Simple'.  This should be a "Foo::Bar" (module) name, not a "Foo-Bar"
 497 dist name.
 498
 499 =item dir
 500
 501 The (parent) directory in which to create the distribution directory.
 502 The default is File::Spec->curdir.  The distribution will be created
 503 under this according to the "dist" form of C<name> (e.g. "Foo-Bar".)
 504
 505 =item xs
 506
 507 If true, generates an XS based module.
 508
 509 =back
 510
 511 =head2 Manipulating the Distribution
 512
 513 These methods immediately affect the filesystem.
 514
 515 =head3 regen()
 516
 517 Regenerate all missing or changed files.
 518
 519   $dist->regen(clean => 1);
 520
 521 If the optional C<clean> argument is given, it also removes any
 522 extraneous files that do not belong to the distribution.
 523
 524 =head2 chdir_in
 525
 526 Change directory into the dist root.
 527
 528   $dist->chdir_in;
 529
 530 =head2 chdir_original
 531
 532 Returns to whatever directory you were in before chdir_in() (regardless
 533 of the cwd.)
 534
 535   $dist->chdir_original;
 536
 537 =head3 clean()
 538
 539 Removes any files that are not part of the distribution.
 540
 541   $dist->clean;
 542
 543 =begin TODO
 544
 545 =head3 revert()
 546
 547 [Unimplemented] Returns the object to its initial state, or given a
 548 $filename it returns that file to it's initial state if it is one of
 549 the built-in files.
 550
 551   $dist->revert;
 552   $dist->revert($filename);
 553
 554 =end TODO
 555
 556 =head3 remove()
 557
 558 Removes the entire distribution directory.
 559
 560 =head2 Editing Files
 561
 562 Note that C<$filename> should always be specified with unix-style paths,
 563 and are relative to the distribution root directory. Eg 'lib/Module.pm'
 564
 565 No filesystem action is performed until the distribution is regenerated.
 566
 567 =head3 add_file()
 568
 569 Add a $filename containing $content to the distribution.
 570
 571   $dist->add_file( $filename, $content );
 572
 573 =head3 remove_file()
 574
 575 Removes C<$filename> from the distribution.
 576
 577   $dist->remove_file( $filename );
 578
 579 =head3 change_file()
 580
 581 Changes the contents of $filename to $content. No action is performed
 582 until the distribution is regenerated.
 583
 584   $dist->change_file( $filename, $content );
 585
 586 =head2 Properties
 587
 588 =head3 name()
 589
 590 Returns the name of the distribution.
 591
 592 =head3 dirname()
 593
 594 Returns the directory where the distribution is created.
 595
 596   $dist->dirname; # e.g. t/_tmp/Simple
 597
 598 =head2 Functions
 599
 600 =head3 undent()
 601
 602 Removes leading whitespace from a multi-line string according to the
 603 amount of whitespace on the first line.
 604
 605   my $string = undent("  foo(\n    bar => 'baz'\n  )");
 606   $string eq "foo(
 607     bar => 'baz'
 608   )";
 609
 610 =cut
 611
 612 # vim:ts=2:sw=2:et:sta