Commit | Line | Data |
bb4e9162 |
1 | package DistGen; |
2 | |
3 | use strict; |
4 | |
7a827510 |
5 | use vars qw( $VERSION $VERBOSE @EXPORT_OK); |
bb4e9162 |
6 | |
7 | $VERSION = '0.01'; |
8 | $VERBOSE = 0; |
9 | |
10 | |
738349a8 |
11 | use Carp; |
12 | |
bb4e9162 |
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; |
7a827510 |
20 | use Data::Dumper; |
bb4e9162 |
21 | |
a314697d |
22 | BEGIN { |
738349a8 |
23 | if( $^O eq 'VMS' ) { |
24 | # For things like vmsify() |
25 | require VMS::Filespec; |
26 | VMS::Filespec->import; |
27 | } |
a314697d |
28 | } |
7a827510 |
29 | BEGIN { |
30 | require Exporter; |
31 | *{import} = \&Exporter::import; |
32 | @EXPORT_OK = qw( |
33 | undent |
34 | ); |
35 | } |
a314697d |
36 | |
738349a8 |
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 | |
bb4e9162 |
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 | |
738349a8 |
61 | # So we can clean up later even if the caller chdir()s |
62 | $self->{dir} = File::Spec->rel2abs($self->{dir}); |
63 | |
bb4e9162 |
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 | |
bb4e9162 |
78 | sub _gen_default_filedata { |
79 | my $self = shift; |
80 | |
7a827510 |
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; |
bb4e9162 |
91 | |
7a827510 |
92 | my \$builder = Module::Build->new( |
93 | module_name => '$self->{name}', |
94 | license => 'perl', |
95 | ); |
bb4e9162 |
96 | |
7a827510 |
97 | \$builder->create_build_script(); |
98 | --- |
bb4e9162 |
99 | |
100 | my $module_filename = |
101 | join( '/', ('lib', split(/::/, $self->{name})) ) . '.pm'; |
102 | |
103 | unless ( $self->{xs} ) { |
7a827510 |
104 | $self->$add_unless($module_filename, undent(<<" ---")); |
105 | package $self->{name}; |
bb4e9162 |
106 | |
7a827510 |
107 | use vars qw( \$VERSION ); |
108 | \$VERSION = '0.01'; |
bb4e9162 |
109 | |
7a827510 |
110 | use strict; |
bb4e9162 |
111 | |
7a827510 |
112 | 1; |
bb4e9162 |
113 | |
7a827510 |
114 | __END__ |
bb4e9162 |
115 | |
7a827510 |
116 | =head1 NAME |
bb4e9162 |
117 | |
7a827510 |
118 | $self->{name} - Perl extension for blah blah blah |
bb4e9162 |
119 | |
7a827510 |
120 | =head1 DESCRIPTION |
bb4e9162 |
121 | |
7a827510 |
122 | Stub documentation for $self->{name}. |
bb4e9162 |
123 | |
7a827510 |
124 | =head1 AUTHOR |
bb4e9162 |
125 | |
7a827510 |
126 | A. U. Thor, a.u.thor\@a.galaxy.far.far.away |
bb4e9162 |
127 | |
7a827510 |
128 | =cut |
129 | --- |
bb4e9162 |
130 | |
7a827510 |
131 | $self->$add_unless('t/basic.t', undent(<<" ---")); |
132 | use Test::More tests => 1; |
133 | use strict; |
bb4e9162 |
134 | |
7a827510 |
135 | use $self->{name}; |
136 | ok 1; |
137 | --- |
bb4e9162 |
138 | |
139 | } else { |
7a827510 |
140 | $self->$add_unless($module_filename, undent(<<" ---")); |
141 | package $self->{name}; |
bb4e9162 |
142 | |
7a827510 |
143 | \$VERSION = '0.01'; |
bb4e9162 |
144 | |
7a827510 |
145 | require Exporter; |
146 | require DynaLoader; |
bb4e9162 |
147 | |
7a827510 |
148 | \@ISA = qw(Exporter DynaLoader); |
149 | \@EXPORT_OK = qw( okay ); |
bb4e9162 |
150 | |
7a827510 |
151 | bootstrap $self->{name} \$VERSION; |
bb4e9162 |
152 | |
7a827510 |
153 | 1; |
bb4e9162 |
154 | |
7a827510 |
155 | __END__ |
bb4e9162 |
156 | |
7a827510 |
157 | =head1 NAME |
bb4e9162 |
158 | |
7a827510 |
159 | $self->{name} - Perl extension for blah blah blah |
bb4e9162 |
160 | |
7a827510 |
161 | =head1 DESCRIPTION |
bb4e9162 |
162 | |
7a827510 |
163 | Stub documentation for $self->{name}. |
bb4e9162 |
164 | |
7a827510 |
165 | =head1 AUTHOR |
bb4e9162 |
166 | |
7a827510 |
167 | A. U. Thor, a.u.thor\@a.galaxy.far.far.away |
bb4e9162 |
168 | |
7a827510 |
169 | =cut |
170 | --- |
bb4e9162 |
171 | |
172 | my $xs_filename = |
173 | join( '/', ('lib', split(/::/, $self->{name})) ) . '.xs'; |
7a827510 |
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 | |
473d7a83 |
188 | const char * |
7a827510 |
189 | xs_version() |
190 | CODE: |
191 | RETVAL = XS_VERSION; |
192 | OUTPUT: |
bb4e9162 |
193 | RETVAL |
194 | |
473d7a83 |
195 | const char * |
7a827510 |
196 | version() |
197 | CODE: |
198 | RETVAL = VERSION; |
199 | OUTPUT: |
200 | RETVAL |
201 | --- |
bb4e9162 |
202 | |
738349a8 |
203 | # 5.6 is missing const char * in its typemap |
204 | $self->$add_unless('typemap', undent(<<" ---")); |
205 | const char * T_PV |
206 | --- |
207 | |
7a827510 |
208 | $self->$add_unless('t/basic.t', undent(<<" ---")); |
209 | use Test::More tests => 2; |
210 | use strict; |
bb4e9162 |
211 | |
7a827510 |
212 | use $self->{name}; |
213 | ok 1; |
214 | |
215 | ok( $self->{name}::okay() eq 'ok' ); |
216 | --- |
bb4e9162 |
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 | |
a314697d |
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 | } |
bb4e9162 |
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; |
738349a8 |
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); |
bb4e9162 |
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 | |
7a827510 |
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 | |
bb4e9162 |
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 | |
738349a8 |
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 | |
bb4e9162 |
447 | 1; |
448 | |
449 | __END__ |
450 | |
451 | |
452 | =head1 NAME |
453 | |
454 | DistGen - Creates simple distributions for testing. |
455 | |
7a827510 |
456 | =head1 SYNOPSIS |
bb4e9162 |
457 | |
7a827510 |
458 | use DistGen; |
bb4e9162 |
459 | |
7a827510 |
460 | my $dist = DistGen->new(dir => $tmp); |
461 | ... |
462 | $dist->add_file('t/some_test.t', $contents); |
463 | ... |
464 | $dist->regen; |
bb4e9162 |
465 | |
7a827510 |
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; |
bb4e9162 |
473 | |
474 | =head1 API |
475 | |
bb4e9162 |
476 | =head2 Constructor |
477 | |
478 | =head3 new() |
479 | |
7a827510 |
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. |
bb4e9162 |
490 | |
491 | =over |
492 | |
493 | =item name |
494 | |
495 | The name of the module this distribution represents. The default is |
7a827510 |
496 | 'Simple'. This should be a "Foo::Bar" (module) name, not a "Foo-Bar" |
497 | dist name. |
bb4e9162 |
498 | |
499 | =item dir |
500 | |
7a827510 |
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".) |
bb4e9162 |
504 | |
505 | =item xs |
506 | |
7a827510 |
507 | If true, generates an XS based module. |
bb4e9162 |
508 | |
509 | =back |
510 | |
bb4e9162 |
511 | =head2 Manipulating the Distribution |
512 | |
7a827510 |
513 | These methods immediately affect the filesystem. |
bb4e9162 |
514 | |
7a827510 |
515 | =head3 regen() |
bb4e9162 |
516 | |
7a827510 |
517 | Regenerate all missing or changed files. |
bb4e9162 |
518 | |
7a827510 |
519 | $dist->regen(clean => 1); |
bb4e9162 |
520 | |
7a827510 |
521 | If the optional C<clean> argument is given, it also removes any |
522 | extraneous files that do not belong to the distribution. |
bb4e9162 |
523 | |
738349a8 |
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 | |
bb4e9162 |
537 | =head3 clean() |
538 | |
539 | Removes any files that are not part of the distribution. |
540 | |
7a827510 |
541 | $dist->clean; |
542 | |
543 | =begin TODO |
544 | |
545 | =head3 revert() |
bb4e9162 |
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 | |
7a827510 |
551 | $dist->revert; |
552 | $dist->revert($filename); |
553 | |
554 | =end TODO |
bb4e9162 |
555 | |
7a827510 |
556 | =head3 remove() |
bb4e9162 |
557 | |
7a827510 |
558 | Removes the entire distribution directory. |
bb4e9162 |
559 | |
560 | =head2 Editing Files |
561 | |
7a827510 |
562 | Note that C<$filename> should always be specified with unix-style paths, |
bb4e9162 |
563 | and are relative to the distribution root directory. Eg 'lib/Module.pm' |
564 | |
7a827510 |
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 ); |
bb4e9162 |
572 | |
7a827510 |
573 | =head3 remove_file() |
bb4e9162 |
574 | |
7a827510 |
575 | Removes C<$filename> from the distribution. |
bb4e9162 |
576 | |
7a827510 |
577 | $dist->remove_file( $filename ); |
bb4e9162 |
578 | |
7a827510 |
579 | =head3 change_file() |
bb4e9162 |
580 | |
581 | Changes the contents of $filename to $content. No action is performed |
582 | until the distribution is regenerated. |
583 | |
7a827510 |
584 | $dist->change_file( $filename, $content ); |
bb4e9162 |
585 | |
586 | =head2 Properties |
587 | |
588 | =head3 name() |
589 | |
590 | Returns the name of the distribution. |
591 | |
592 | =head3 dirname() |
593 | |
7a827510 |
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 | )"; |
bb4e9162 |
609 | |
610 | =cut |
7a827510 |
611 | |
612 | # vim:ts=2:sw=2:et:sta |