Commit | Line | Data |
---|---|---|
bb4e9162 YST |
1 | package DistGen; |
2 | ||
3 | use strict; | |
4 | ||
7a827510 | 5 | use vars qw( $VERSION $VERBOSE @EXPORT_OK); |
bb4e9162 YST |
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; | |
7a827510 | 18 | use Data::Dumper; |
bb4e9162 | 19 | |
a314697d RS |
20 | BEGIN { |
21 | if( $^O eq 'VMS' ) { | |
22 | # For things like vmsify() | |
23 | require VMS::Filespec; | |
24 | VMS::Filespec->import; | |
25 | } | |
26 | } | |
7a827510 RGS |
27 | BEGIN { |
28 | require Exporter; | |
29 | *{import} = \&Exporter::import; | |
30 | @EXPORT_OK = qw( | |
31 | undent | |
32 | ); | |
33 | } | |
a314697d | 34 | |
bb4e9162 YST |
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 | ||
7a827510 RGS |
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 | } | |
bb4e9162 YST |
72 | |
73 | sub _gen_default_filedata { | |
74 | my $self = shift; | |
75 | ||
7a827510 RGS |
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; | |
bb4e9162 | 86 | |
7a827510 RGS |
87 | my \$builder = Module::Build->new( |
88 | module_name => '$self->{name}', | |
89 | license => 'perl', | |
90 | ); | |
bb4e9162 | 91 | |
7a827510 RGS |
92 | \$builder->create_build_script(); |
93 | --- | |
bb4e9162 YST |
94 | |
95 | my $module_filename = | |
96 | join( '/', ('lib', split(/::/, $self->{name})) ) . '.pm'; | |
97 | ||
98 | unless ( $self->{xs} ) { | |
7a827510 RGS |
99 | $self->$add_unless($module_filename, undent(<<" ---")); |
100 | package $self->{name}; | |
bb4e9162 | 101 | |
7a827510 RGS |
102 | use vars qw( \$VERSION ); |
103 | \$VERSION = '0.01'; | |
bb4e9162 | 104 | |
7a827510 | 105 | use strict; |
bb4e9162 | 106 | |
7a827510 | 107 | 1; |
bb4e9162 | 108 | |
7a827510 | 109 | __END__ |
bb4e9162 | 110 | |
7a827510 | 111 | =head1 NAME |
bb4e9162 | 112 | |
7a827510 | 113 | $self->{name} - Perl extension for blah blah blah |
bb4e9162 | 114 | |
7a827510 | 115 | =head1 DESCRIPTION |
bb4e9162 | 116 | |
7a827510 | 117 | Stub documentation for $self->{name}. |
bb4e9162 | 118 | |
7a827510 | 119 | =head1 AUTHOR |
bb4e9162 | 120 | |
7a827510 | 121 | A. U. Thor, a.u.thor\@a.galaxy.far.far.away |
bb4e9162 | 122 | |
7a827510 RGS |
123 | =cut |
124 | --- | |
bb4e9162 | 125 | |
7a827510 RGS |
126 | $self->$add_unless('t/basic.t', undent(<<" ---")); |
127 | use Test::More tests => 1; | |
128 | use strict; | |
bb4e9162 | 129 | |
7a827510 RGS |
130 | use $self->{name}; |
131 | ok 1; | |
132 | --- | |
bb4e9162 YST |
133 | |
134 | } else { | |
7a827510 RGS |
135 | $self->$add_unless($module_filename, undent(<<" ---")); |
136 | package $self->{name}; | |
bb4e9162 | 137 | |
7a827510 | 138 | \$VERSION = '0.01'; |
bb4e9162 | 139 | |
7a827510 RGS |
140 | require Exporter; |
141 | require DynaLoader; | |
bb4e9162 | 142 | |
7a827510 RGS |
143 | \@ISA = qw(Exporter DynaLoader); |
144 | \@EXPORT_OK = qw( okay ); | |
bb4e9162 | 145 | |
7a827510 | 146 | bootstrap $self->{name} \$VERSION; |
bb4e9162 | 147 | |
7a827510 | 148 | 1; |
bb4e9162 | 149 | |
7a827510 | 150 | __END__ |
bb4e9162 | 151 | |
7a827510 | 152 | =head1 NAME |
bb4e9162 | 153 | |
7a827510 | 154 | $self->{name} - Perl extension for blah blah blah |
bb4e9162 | 155 | |
7a827510 | 156 | =head1 DESCRIPTION |
bb4e9162 | 157 | |
7a827510 | 158 | Stub documentation for $self->{name}. |
bb4e9162 | 159 | |
7a827510 | 160 | =head1 AUTHOR |
bb4e9162 | 161 | |
7a827510 | 162 | A. U. Thor, a.u.thor\@a.galaxy.far.far.away |
bb4e9162 | 163 | |
7a827510 RGS |
164 | =cut |
165 | --- | |
bb4e9162 YST |
166 | |
167 | my $xs_filename = | |
168 | join( '/', ('lib', split(/::/, $self->{name})) ) . '.xs'; | |
7a827510 RGS |
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: | |
bb4e9162 YST |
188 | RETVAL |
189 | ||
7a827510 RGS |
190 | char * |
191 | version() | |
192 | CODE: | |
193 | RETVAL = VERSION; | |
194 | OUTPUT: | |
195 | RETVAL | |
196 | --- | |
bb4e9162 | 197 | |
7a827510 RGS |
198 | $self->$add_unless('t/basic.t', undent(<<" ---")); |
199 | use Test::More tests => 2; | |
200 | use strict; | |
bb4e9162 | 201 | |
7a827510 RGS |
202 | use $self->{name}; |
203 | ok 1; | |
204 | ||
205 | ok( $self->{name}::okay() eq 'ok' ); | |
206 | --- | |
bb4e9162 YST |
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 | ||
a314697d RS |
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 | } | |
bb4e9162 YST |
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; | |
a314697d | 361 | File::Path::rmtree( File::Spec->canonpath($self->dirname) ); |
bb4e9162 YST |
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 | ||
7a827510 RGS |
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 | ||
bb4e9162 YST |
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 | ||
7a827510 | 417 | =head1 SYNOPSIS |
bb4e9162 | 418 | |
7a827510 | 419 | use DistGen; |
bb4e9162 | 420 | |
7a827510 RGS |
421 | my $dist = DistGen->new(dir => $tmp); |
422 | ... | |
423 | $dist->add_file('t/some_test.t', $contents); | |
424 | ... | |
425 | $dist->regen; | |
bb4e9162 | 426 | |
7a827510 RGS |
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; | |
bb4e9162 YST |
434 | |
435 | =head1 API | |
436 | ||
bb4e9162 YST |
437 | =head2 Constructor |
438 | ||
439 | =head3 new() | |
440 | ||
7a827510 RGS |
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. | |
bb4e9162 YST |
451 | |
452 | =over | |
453 | ||
454 | =item name | |
455 | ||
456 | The name of the module this distribution represents. The default is | |
7a827510 RGS |
457 | 'Simple'. This should be a "Foo::Bar" (module) name, not a "Foo-Bar" |
458 | dist name. | |
bb4e9162 YST |
459 | |
460 | =item dir | |
461 | ||
7a827510 RGS |
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".) | |
bb4e9162 YST |
465 | |
466 | =item xs | |
467 | ||
7a827510 | 468 | If true, generates an XS based module. |
bb4e9162 YST |
469 | |
470 | =back | |
471 | ||
bb4e9162 YST |
472 | =head2 Manipulating the Distribution |
473 | ||
7a827510 | 474 | These methods immediately affect the filesystem. |
bb4e9162 | 475 | |
7a827510 | 476 | =head3 regen() |
bb4e9162 | 477 | |
7a827510 | 478 | Regenerate all missing or changed files. |
bb4e9162 | 479 | |
7a827510 | 480 | $dist->regen(clean => 1); |
bb4e9162 | 481 | |
7a827510 RGS |
482 | If the optional C<clean> argument is given, it also removes any |
483 | extraneous files that do not belong to the distribution. | |
bb4e9162 YST |
484 | |
485 | =head3 clean() | |
486 | ||
487 | Removes any files that are not part of the distribution. | |
488 | ||
7a827510 RGS |
489 | $dist->clean; |
490 | ||
491 | =begin TODO | |
492 | ||
493 | =head3 revert() | |
bb4e9162 YST |
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 | ||
7a827510 RGS |
499 | $dist->revert; |
500 | $dist->revert($filename); | |
501 | ||
502 | =end TODO | |
bb4e9162 | 503 | |
7a827510 | 504 | =head3 remove() |
bb4e9162 | 505 | |
7a827510 | 506 | Removes the entire distribution directory. |
bb4e9162 YST |
507 | |
508 | =head2 Editing Files | |
509 | ||
7a827510 | 510 | Note that C<$filename> should always be specified with unix-style paths, |
bb4e9162 YST |
511 | and are relative to the distribution root directory. Eg 'lib/Module.pm' |
512 | ||
7a827510 RGS |
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 ); | |
bb4e9162 | 520 | |
7a827510 | 521 | =head3 remove_file() |
bb4e9162 | 522 | |
7a827510 | 523 | Removes C<$filename> from the distribution. |
bb4e9162 | 524 | |
7a827510 | 525 | $dist->remove_file( $filename ); |
bb4e9162 | 526 | |
7a827510 | 527 | =head3 change_file() |
bb4e9162 YST |
528 | |
529 | Changes the contents of $filename to $content. No action is performed | |
530 | until the distribution is regenerated. | |
531 | ||
7a827510 | 532 | $dist->change_file( $filename, $content ); |
bb4e9162 YST |
533 | |
534 | =head2 Properties | |
535 | ||
536 | =head3 name() | |
537 | ||
538 | Returns the name of the distribution. | |
539 | ||
540 | =head3 dirname() | |
541 | ||
7a827510 RGS |
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 | )"; | |
bb4e9162 YST |
557 | |
558 | =cut | |
7a827510 RGS |
559 | |
560 | # vim:ts=2:sw=2:et:sta |