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