File Coverage

blib/lib/Module/Faker/Dist.pm
Criterion Covered Total %
statement 194 214 90.6
branch 27 56 48.2
condition 15 23 65.2
subroutine 41 43 95.3
pod 5 9 55.5
total 282 345 81.7


line stmt bran cond sub pod time code
1             package Module::Faker::Dist 0.025;
2             # ABSTRACT: a fake CPAN distribution
3              
4 8     8   566668 use Moose;
  8         3305895  
  8         51  
5              
6 8     8   68788 use Module::Faker::File;
  8         37  
  8         344  
7 8     8   3660 use Module::Faker::Heavy;
  8         20  
  8         270  
8 8     8   3623 use Module::Faker::Package;
  8         25  
  8         331  
9 8     8   3891 use Module::Faker::Module;
  8         39  
  8         293  
10              
11 8     8   3896 use Archive::Any::Create;
  8         95855  
  8         93  
12 8     8   3927 use CPAN::DistnameInfo;
  8         8162  
  8         95  
13 8     8   4096 use CPAN::Meta 2.130880; # github issue #9
  8         222495  
  8         71  
14 8     8   304 use CPAN::Meta::Converter;
  8         26  
  8         35  
15 8     8   3989 use CPAN::Meta::Merge;
  8         17730  
  8         88  
16 8     8   286 use CPAN::Meta::Requirements;
  8         20  
  8         70  
17 8     8   189 use Data::OptList ();
  8         19  
  8         146  
18 8     8   4521 use Encode qw( encode_utf8 );
  8         75358  
  8         614  
19 8     8   5663 use File::Temp ();
  8         142317  
  8         184  
20 8     8   58 use File::Path ();
  8         41  
  8         184  
21 8     8   56 use Parse::CPAN::Meta 1.4401;
  8         166  
  8         356  
22 8     8   3607 use Path::Class;
  8         156280  
  8         499  
23 8     8   5334 use Storable qw(dclone);
  8         25835  
  8         7339  
24              
25             #pod =head1 SYNOPSIS
26             #pod
27             #pod Building one dist at a time makes plenty of sense, so Module::Faker::Dist makes
28             #pod it easy. Building dists from definitions in files is also useful for doing
29             #pod things in bulk (see L<CPAN::Faker>), so there are a bunch of ways to build
30             #pod dists from a definition in a file.
31             #pod
32             #pod # Build from a META.yml or META.json file, or the delightful
33             #pod # AUTHOR_Foo-Bar-1.234.tar.gz.dist file, which can be zero bytes and gets
34             #pod # all the relevant data from the filename.
35             #pod my $dist = Module::Faker::Dist->from_file($filename);
36             #pod
37             #pod META files can contain a key called X_Module_Faker that contains attributes to
38             #pod use in constructing the dist. C<dist> files can contain anything you want, but
39             #pod the contents won't do a thing.
40             #pod
41             #pod You can use the C<new> method on Module::Faker::Dist, of course, but it's a bit
42             #pod of a pain. You might, instead, want to use C<from_struct>, which is very close
43             #pod to C<new>, but with more sugar.
44             #pod
45             #pod =cut
46              
47             #pod =attr name
48             #pod
49             #pod This is the name of the dist. It will usually look like C<Foo-Bar>.
50             #pod
51             #pod =attr version
52             #pod
53             #pod This is the version of the dist, usually some kind of versiony string like
54             #pod C<1.234> or maybe C<1.2.3>.
55             #pod
56             #pod =attr abstract
57             #pod
58             #pod The abstract! This is a short, pithy description of the distribution, usually
59             #pod less than a sentence.
60             #pod
61             #pod =attr release_status
62             #pod
63             #pod This is the dist's release status. (See L<CPAN::Meta::Spec>.) It defaults to
64             #pod C<stable> but C<unstable> and C<testing> are valid values.
65             #pod
66             #pod =cut
67              
68             my $DEFAULT_VERSION;
69              
70             # required by CPAN::Meta::Spec
71             has name => (is => 'ro', isa => 'Str', required => $DEFAULT_VERSION);
72             has version => (is => 'ro', isa => 'Maybe[Str]', default => '0.01');
73             has abstract => (is => 'ro', isa => 'Str', default => 'a great new dist');
74             has release_status => (is => 'ro', isa => 'Str', default => 'stable');
75              
76             #pod =attr cpan_author
77             #pod
78             #pod This is the PAUSE id of the author, like C<RJBS>.
79             #pod
80             #pod =attr archive_ext
81             #pod
82             #pod This is the extension of the archive to build, when you build an archive. This
83             #pod defaults to C<tar.gz>. C<zip> should work, but right now it doesn't. So
84             #pod probably stuck to C<tar.gz>. It would be cool to support more attributes in
85             #pod the future.
86             #pod
87             #pod =attr append
88             #pod
89             #pod This is an arrayref of hashrefs, each of which looks like:
90             #pod
91             #pod { file => $filename, content => $character_string }
92             #pod
93             #pod The content will be UTF-8 encoded and put into a file with the given name.
94             #pod
95             #pod This feature is a bit weird. Maybe it will go away eventually.
96             #pod
97             #pod =attr mtime
98             #pod
99             #pod If given, this is the epoch seconds to which to set the mtime of the generated
100             #pod file. This is useful in rare occasions.
101             #pod
102             #pod =cut
103              
104             # Module::Faker options
105             has cpan_author => (is => 'ro', isa => 'Maybe[Str]', default => 'LOCAL');
106             has archive_ext => (is => 'ro', isa => 'Str', default => 'tar.gz');
107             has append => (is => 'ro', isa => 'ArrayRef[HashRef]', default => sub {[]});
108             has mtime => (is => 'ro', isa => 'Int', predicate => 'has_mtime');
109              
110             #pod =attr x_authority
111             #pod
112             #pod This is the C<X_Authority> header that gets put into the META files.
113             #pod
114             #pod =cut
115              
116             has x_authority => (is => 'ro', isa => 'Str');
117              
118             #pod =attr license
119             #pod
120             #pod This is the meta spec license string for the distribution. It defaults to
121             #pod C<perl_5>.
122             #pod
123             #pod =cut
124              
125             has license => (
126             is => 'ro',
127             isa => 'ArrayRef[Str]',
128             default => sub { [ 'perl_5' ] },
129             );
130              
131             #pod =attr authors
132             #pod
133             #pod This is an array of strings who are used as the authors in the dist metadata.
134             #pod The default is:
135             #pod
136             #pod [ "AUTHOR <AUTHOR@cpan.local>" ]
137             #pod
138             #pod ...where C<AUTHOR> is the C<cpan_author> of the dist.
139             #pod
140             #pod =cut
141              
142             has authors => (
143             isa => 'ArrayRef[Str]',
144             lazy => 1,
145             traits => [ 'Array' ],
146             handles => { authors => 'elements' },
147             default => sub {
148             my ($self) = @_;
149             return [ sprintf '%s <%s@cpan.local>', ($self->cpan_author) x 2 ];
150             },
151             );
152              
153             #pod =attr include_provides_in_meta
154             #pod
155             #pod This is a bool. If true, the produced META files will include a C<provides>
156             #pod key based on the packages in the dist. It defaults to false, to match the
157             #pod most common behavior of dists in the wild.
158             #pod
159             #pod =cut
160              
161             has include_provides_in_meta => (
162             is => 'ro',
163             isa => 'Bool',
164             default => 0,
165             );
166              
167             #pod =attr provides
168             #pod
169             #pod This is a hashref that gets used as the C<provides> in the metadata.
170             #pod
171             #pod If no provided, it is built from the C<packages> provided in construction.
172             #pod
173             #pod If no packages were provided, for a dist named Foo-Bar, it defaults to:
174             #pod
175             #pod { 'Foo::Bar' => { version => $DIST_VERSION, file => "lib/Foo/Bar.pm" } }
176             #pod
177             #pod =cut
178              
179             has provides => (
180             is => 'ro',
181             isa => 'HashRef',
182             lazy_build => 1,
183             );
184              
185             sub _build_provides {
186 14     14   38 my ($self) = @_;
187              
188 14 50       454 if ($self->has_packages) {
189             return {
190 0 0       0 map {; $_->name => {
  0         0  
191             file => $_->in_file,
192             (defined $_->version ? (version => $_->version) : ()),
193             } } $self->packages
194             }
195             }
196              
197 14         366 my $pkg = __dist_to_pkg($self->name);
198             return {
199 14         382 $pkg => {
200             version => $self->version,
201             file => __pkg_to_file($pkg),
202             }
203             };
204             };
205              
206 21 100   21   758 sub __dor { defined $_[0] ? $_[0] : $_[1] }
207              
208             sub append_for {
209 56     56 0 139 my ($self, $filename) = @_;
210             return [
211             # YAML and JSON should both be in utf8 (if not plain ascii)
212 14         75 map { encode_utf8($_->{content}) }
213 30         95 grep { $filename eq $_->{file} }
214 56         106 @{ $self->append }
  56         1497  
215             ];
216             }
217              
218             #pod =attr archive_basename
219             #pod
220             #pod If written to disk, the archive will be written to...
221             #pod
222             #pod $dist->archive_basename . '.' . $dist->archive_ext
223             #pod
224             #pod The default is:
225             #pod
226             #pod $dist->name . '.' . ($dist->version // 'undef')
227             #pod
228             #pod =cut
229              
230             has archive_basename => (
231             is => 'ro',
232             isa => 'Str',
233             lazy => 1,
234             default => sub {
235             my ($self) = @_;
236             return sprintf '%s-%s', $self->name, __dor($self->version, 'undef');
237             },
238             );
239              
240             #pod =attr omitted_files
241             #pod
242             #pod If given, this is an arrayref of filenames that shouldn't be automatically
243             #pod generated and included.
244             #pod
245             #pod =cut
246              
247             has omitted_files => (
248             isa => 'ArrayRef[Str]',
249             traits => [ 'Array' ],
250             handles => { omitted_files => 'elements' },
251             lazy => 1,
252             default => sub { [] },
253             );
254              
255 14     14   35 sub __dist_to_pkg { my $str = shift; $str =~ s/-/::/g; return $str; }
  14         76  
  14         55  
256 18     18   41 sub __pkg_to_file { my $str = shift; $str =~ s{::}{/}g; return "lib/$str.pm"; }
  18         68  
  18         467  
257              
258             # This is stupid, but copes with MakeMaker wanting to have a module name as its
259             # NAME parameter. Ugh! -- rjbs, 2008-03-13
260             sub _pkgy_name {
261 20     20   2481 my $name = shift->name;
262 20         142 $name =~ s/-/::/g;
263              
264 20         225 return $name;
265             }
266              
267             #pod =attr packages
268             #pod
269             #pod This is an array of L<Module::Faker::Package> objects. It's built by
270             #pod C<provides> if needed, but you might want to look at using the
271             #pod C<L</from_struct>> method to set it up.
272             #pod
273             #pod =cut
274              
275             has packages => (
276             isa => 'Module::Faker::Type::Packages',
277             lazy => 1,
278             builder => '_build_packages',
279             traits => [ 'Array' ],
280             handles => { packages => 'elements' },
281             predicate => 'has_packages',
282             );
283              
284             sub _build_packages {
285 20     20   54 my ($self) = @_;
286              
287 20         541 my $provides = $self->provides;
288              
289             # do this dance so we don't autovivify X_Module_Faker in provides
290 20         92 my %package_order = map {;
291 40 100       226 $_ => (exists $provides->{$_}{X_Module_Faker} ? $provides->{$_}{X_Module_Faker}{order} : 0 )
292             } keys %$provides;
293              
294 20         56 my @pkg_names = do {
295 8     8   72 no warnings 'uninitialized';
  8         27  
  8         16698  
296 20         106 sort { $package_order{$a} <=> $package_order{$b} } keys %package_order;
  30         102  
297             };
298              
299 20         45 my @packages;
300 20         56 for my $name (@pkg_names) {
301             push @packages, Module::Faker::Package->new({
302             name => $name,
303             version => $provides->{$name}{version},
304             in_file => $provides->{$name}{file},
305 40 100       19320 ($provides->{$name}{style} ? (style => $provides->{$name}{style}) : ()),
306             });
307             }
308              
309 20         21105 return \@packages;
310             }
311              
312             #pod =method modules
313             #pod
314             #pod This produces and returns a list of L<Module::Faker::Module> objects,
315             #pod representing modules. Modules, if you're not as steeped in CPAN toolchain
316             #pod nonsense, are the C<.pm> files in which packages are defined.
317             #pod
318             #pod These are produced by combining the packages from C<L</packages>> into files
319             #pod based on their C<in_file> attributes.
320             #pod
321             #pod =cut
322              
323             sub modules {
324 40     40 1 83 my ($self) = @_;
325              
326 40         72 my %module;
327 40         1473 for my $pkg ($self->packages) {
328 80         2277 my $filename = $pkg->in_file;
329              
330 80   100     125 push @{ $module{ $filename } ||= [] }, $pkg;
  80         466  
331             }
332              
333             my @modules = map {
334 40         159 Module::Faker::Module->new({
335 52         14827 packages => $module{$_},
336             filename => $_,
337             append => $self->append_for($_)
338             });
339             } keys %module;
340              
341 40         50838 return @modules;
342             }
343              
344             sub _mk_container_path {
345 62     62   158 my ($self, $filename) = @_;
346              
347 62         451 my (@parts) = File::Spec->splitdir($filename);
348 62         150 my $leaf_filename = pop @parts;
349 62         6302 File::Path::mkpath(File::Spec->catdir(@parts));
350             }
351              
352             #pod =method C<make_dist_dir>
353             #pod
354             #pod my $directory_name = $dist->make_dist_dir(\%arg);
355             #pod
356             #pod This returns the name of a directory into which the dist's contents have been
357             #pod written. If a C<dir> argument is provided, the dist will be written to a
358             #pod directory beneath that dir. Otherwise, it will be written below a temporary
359             #pod directory.
360             #pod
361             #pod =cut
362              
363             sub make_dist_dir {
364 8     8 1 4446 my ($self, $arg) = @_;
365 8   100     36 $arg ||= {};
366              
367 8   66     57 my $dir = $arg->{dir} || File::Temp::tempdir;
368 8         1545 my $dist_dir = File::Spec->catdir($dir, $self->archive_basename);
369              
370 8         40 for my $file ($self->files) {
371 50         1717 my $fqfn = File::Spec->catfile($dist_dir, $file->filename);
372 50         220 $self->_mk_container_path($fqfn);
373              
374 50 50       3755 open my $fh, '>', $fqfn or die "couldn't open $fqfn for writing: $!";
375 50         461 print $fh $file->as_string;
376 50 50       2461 close $fh or die "error when closing $fqfn: $!";
377             }
378              
379 8         71 return $dist_dir;
380             }
381              
382             sub _author_dir_infix {
383 0     0   0 my ($self) = @_;
384              
385 0 0       0 Carp::croak "can't put archive in author dir with no author defined"
386             unless my $pauseid = $self->cpan_author;
387              
388             # Sorta like pow- pow- power-wheels! -- rjbs, 2008-03-14
389 0         0 my ($pa, $p) = $pauseid =~ /^((.).)/;
390 0         0 return ($p, $pa, $pauseid);
391             }
392              
393             sub archive_filename {
394 12     12 0 1916 my ($self, $arg) = @_;
395              
396 12         348 my $base = $self->archive_basename;
397 12         330 my $ext = $self->archive_ext;
398              
399             return File::Spec->catfile(
400 12 50       250 ($arg->{author_prefix} ? $self->_author_dir_infix : ()),
401             "$base.$ext",
402             );
403             }
404              
405             #pod =method make_archive
406             #pod
407             #pod my $archive_filename = $dist->make_archive(\%arg);
408             #pod
409             #pod This writes the dist archive file, like a tarball or zip file. If a C<dir>
410             #pod argument is given, it will be written in that directory. Otherwise, it will be
411             #pod written to a temporary directory. If the C<author_prefix> argument is given
412             #pod and true, it will be written under a hashed author dir, like:
413             #pod
414             #pod U/US/USERID/Foo-Bar-1.23.tar.gz
415             #pod
416             #pod =cut
417              
418             sub make_archive {
419 12     12 1 688 my ($self, $arg) = @_;
420 12   50     32 $arg ||= {};
421              
422 12   33     32 my $dir = $arg->{dir} || File::Temp::tempdir;
423              
424 12         77 my $archive = Archive::Any::Create->new;
425 12         425 my $container = $self->archive_basename;
426              
427 12         51 $archive->container($container);
428              
429 12         100 for my $file ($self->files) {
430 78         2336 $archive->add_file($file->filename, $file->as_string);
431             }
432              
433             my $archive_filename = File::Spec->catfile(
434             $dir,
435             $self->archive_filename({ author_prefix => $arg->{author_prefix} })
436 12         109 );
437              
438 12         84 $self->_mk_container_path($archive_filename);
439 12         96 $archive->write_file($archive_filename);
440 12 100       198274 utime time, $self->mtime, $archive_filename if $self->has_mtime;
441 12         124 return $archive_filename;
442             }
443              
444             sub files {
445 20     20 0 73 my ($self) = @_;
446 20         66 my @files = ($self->modules, $self->_extras, $self->_manifest_file);
447 20         50 for my $file (@{$self->append}) {
  20         543  
448 10 100       2356 next if grep { $_->filename eq $file->{file} } @files;
  62         1493  
449             push(@files,
450             $self->_file_class->new(
451             filename => $file->{file},
452             content => '',
453 4         17 append => $self->append_for($file->{file}),
454             ) );
455             }
456 20         2502 return @files;
457             }
458              
459 102     102   557 sub _file_class { 'Module::Faker::File' }
460              
461             around BUILDARGS => sub {
462             my ($orig, $self, @rest) = @_;
463             my $arg = $self->$orig(@rest);
464              
465             confess "can't supply both requires and prereqs"
466             if $arg->{prereqs} && $arg->{requires};
467              
468             if ($arg->{requires}) {
469             $arg->{prereqs} = {
470             runtime => { requires => delete $arg->{requires} }
471             };
472             }
473              
474             return $arg;
475             };
476              
477             sub BUILD {
478 23     23 0 49915 my ($self) = @_;
479 23         755 my $provides = $self->provides;
480              
481 23   66     235 $provides->{$_}{file} //= __pkg_to_file($_) for keys %$provides;
482             }
483              
484             has prereqs => (
485             is => 'ro',
486             isa => 'HashRef',
487             default => sub { {} },
488             );
489              
490             has _manifest_file => (
491             is => 'ro',
492             isa => 'Module::Faker::File',
493             lazy => 1,
494             default => sub {
495             my ($self) = @_;
496             my @files = ($self->modules, $self->_extras);
497              
498             return $self->_file_class->new({
499             filename => 'MANIFEST',
500             content => join("\n",
501             'MANIFEST',
502             map { $_->filename } @files
503             ),
504             });
505             },
506             );
507              
508             #pod =attr more_metadata
509             #pod
510             #pod This can be given as a hashref of data to merge into the CPAN::Meta files.
511             #pod
512             #pod =cut
513              
514             has more_metadata => (
515             is => 'ro',
516             isa => 'HashRef',
517             predicate => 'has_more_metadata',
518             );
519              
520             #pod =attr meta_munger
521             #pod
522             #pod If given, this is a coderef that's called just before the CPAN::Meta data for
523             #pod the dist is written to disk, an can be used to change things, especially into
524             #pod invalid data. It is expected to return the new content to serialize.
525             #pod
526             #pod It's called like this:
527             #pod
528             #pod $coderef->($struct, { format => $format, version => $version });
529             #pod
530             #pod ...where C<$struct> is the result of C<< $cpan_meta->as_struct >>.
531             #pod C<$version> is the version number of the target metafile. Normally, both
532             #pod version 1.4 and 2 are requested. C<$format> is either C<yaml> or C<json>.
533             #pod
534             #pod If the munger returns a string instead of a structure, it will be used as the
535             #pod content of the file being written. This lets you put all kinds of nonsense in
536             #pod those meta files. Have fun, go nuts!
537             #pod
538             #pod =cut
539              
540             has meta_munger => (
541             isa => 'CodeRef',
542             predicate => 'has_meta_munger',
543             traits => [ 'Code' ],
544             handles => { munge_meta => 'execute' },
545             );
546              
547             has _cpan_meta => (
548             is => 'ro',
549             isa => 'CPAN::Meta',
550             lazy_build => 1,
551             );
552              
553             sub _build__cpan_meta {
554 20     20   112 my ($self) = @_;
555 20         834 my $meta = {
556             'meta-spec' => { version => '2' },
557             dynamic_config => 0,
558             author => [ $self->authors ], # plural attribute that derefs
559             };
560             # required fields
561 20         73 for my $key ( qw/abstract license name release_status version/ ) {
562 100         2854 $meta->{$key} = $self->$key;
563             }
564             # optional fields
565 20         95 for my $key ( qw/prereqs x_authority/ ) {
566 40         1187 my $value = $self->$key;
567 40 100       189 $meta->{$key} = $value if $value;
568             }
569              
570 20 100 66     518 if ($self->provides && $self->include_provides_in_meta) {
571 1         27 $meta->{provides} = $self->provides;
572             }
573              
574 20         235 my $cpanmeta = CPAN::Meta->new( $meta, {lazy_validation => 1} );
575 20 50       28113 return $cpanmeta unless $self->has_more_metadata;
576              
577 0         0 return CPAN::Meta->new(
578             CPAN::Meta::Merge->new(default_version => 2)->merge(
579             $cpanmeta,
580             $self->more_metadata,
581             ),
582             { lazy_validation => 1 }
583             );
584             }
585              
586             has _extras => (
587             isa => 'ArrayRef[Module::Faker::File]',
588             lazy => 1,
589             traits => [ 'Array' ],
590             handles => { _extras => 'elements' },
591             default => sub {
592             my ($self) = @_;
593             my @files;
594              
595             for my $filename (qw(Makefile.PL t/00-nop.t)) {
596             next if grep { $_ eq $filename } $self->omitted_files;
597             push @files, $self->_file_class->new({
598             filename => $filename,
599             content => Module::Faker::Heavy->_render(
600             $filename,
601             { dist => $self },
602             ),
603             });
604             }
605              
606             unless ( grep { $_ eq 'META.json' } $self->omitted_files ) {
607             push @files, $self->_file_class->new({
608             filename => 'META.json',
609             content => $self->_meta_file_content(json => 2),
610             });
611             }
612              
613             unless ( grep { $_ eq 'META.yml' } $self->omitted_files ) {
614             push @files, $self->_file_class->new({
615             filename => 'META.yml',
616             content => $self->_meta_file_content(yaml => 1.4),
617             });
618             }
619              
620             return \@files;
621             },
622             );
623              
624             # This code is based on the code in CPAN::Meta v2.150010
625             # -- rjbs, 2019-04-28
626             sub _meta_file_content {
627 38     38   96 my ($self, $format, $version) = @_;
628              
629 38         1012 my $meta = $self->_cpan_meta;
630              
631 38         86 my $struct;
632 38 100       183 if ($meta->meta_spec_version ne $version) {
633 18         863 $struct = CPAN::Meta::Converter->new($meta->as_struct)
634             ->convert(version => $version);
635             } else {
636 20         935 $struct = $meta->as_struct;
637             }
638              
639 38 50       28097 if ($self->has_meta_munger) {
640             # Is that dclone() paranoia? Maybe. -- rjbs, 2019-04-28
641 0         0 $struct = $self->munge_meta(
642             dclone($struct),
643             {
644             format => $format,
645             version => $version
646             },
647             );
648              
649 0 0       0 return $struct unless ref $struct;
650             }
651              
652 38         112 my ($data, $backend);
653 38 100       216 if ($format eq 'json') {
    50          
654 20         121 $backend = Parse::CPAN::Meta->json_backend();
655 20         62513 local $struct->{x_serialization_backend} = sprintf '%s version %s',
656             $backend, $backend->VERSION;
657 20         164 $data = $backend->new->pretty->canonical->encode($struct);
658             } elsif ($format eq 'yaml') {
659 18         102 $backend = Parse::CPAN::Meta->yaml_backend();
660 18         6978 local $struct->{x_serialization_backend} = sprintf '%s version %s',
661             $backend, $backend->VERSION;
662 8     8   73 $data = eval { no strict 'refs'; &{"$backend\::Dump"}($struct) };
  8         22  
  8         6602  
  18         81  
  18         50  
  18         133  
663 18 50       12798 if ( $@ ) {
664 0 0       0 croak($backend->can('errstr') ? $backend->errstr : $@);
665             }
666             } else {
667 0         0 confess "unknown meta format: $format"
668             }
669              
670 38         18359 return $data;
671             }
672              
673             #pod =method from_file
674             #pod
675             #pod my $dist = Module::Faker::Dist->from_file($filename);
676             #pod
677             #pod Given a filename with dist configuration, this builds the dist described by the
678             #pod file.
679             #pod
680             #pod Given a file ending in C<yaml> or C<yml> or C<json>, it's treated as a
681             #pod CPAN::Meta file and interpreted as such. The key C<X_Module_Faker> can be
682             #pod present to provide attributes that don't match data found in a meta file.
683             #pod
684             #pod Given a file ending in C<dist>, all the configuration comes from the filename,
685             #pod which should look like this:
686             #pod
687             #pod AUTHOR_Dist-Name-1.234.tar.gz.dist
688             #pod
689             #pod =cut
690              
691             # TODO: make this a registry -- rjbs, 2008-03-12
692             my %HANDLER_FOR = (
693             yaml => '_from_meta_file',
694             yml => '_from_meta_file',
695             json => '_from_meta_file',
696             dist => '_from_distnameinfo'
697             );
698              
699             sub from_file {
700 22     22 1 125772 my ($self, $filename) = @_;
701              
702 22         157 my ($ext) = $filename =~ /.*\.(.+?)\z/;
703              
704             Carp::croak "don't know how to handle file $filename"
705 22 50 33     214 unless $ext and my $method = $HANDLER_FOR{$ext};
706              
707 22         108 $self->$method($filename);
708             }
709              
710             sub _from_distnameinfo {
711 2     2   5 my ($self, $filename) = @_;
712 2         14 $filename = file($filename)->basename;
713 2         408 $filename =~ s/\.dist$//;
714              
715 2         9 my ($author, $path) = split /_/, $filename, 2;
716              
717 2         43 my $dni = CPAN::DistnameInfo->new($path);
718              
719 2         192 return $self->new({
720             name => $dni->dist,
721             version => $dni->version,
722             abstract => sprintf('the %s dist', $dni->dist),
723             archive_ext => $dni->extension,
724             cpan_author => $author,
725             });
726             }
727              
728             sub _from_meta_file {
729 20     20   63 my ($self, $filename) = @_;
730              
731 20         157 my $data = Parse::CPAN::Meta->load_file($filename);
732 20   100     113805 my $extra = (delete $data->{X_Module_Faker}) || {};
733 20         333 my $dist = $self->new({ %$data, %$extra });
734             }
735              
736             sub _flat_prereqs {
737 20     20   3371 my ($self) = @_;
738 20         876 my $prereqs = $self->_cpan_meta->effective_prereqs;
739 20         3356 my $req = CPAN::Meta::Requirements->new;
740 20         360 for my $phase ( qw/runtime build test/ ) {
741 60         3270 $req->add_requirements( $prereqs->requirements_for( $phase, 'requires' ) );
742             }
743 20         1264 return %{ $req->as_string_hash };
  20         83  
744             }
745              
746             #pod =method from_struct
747             #pod
748             #pod my $dist = Module::Faker::Dist->from_struct(\%arg);
749             #pod
750             #pod This is sugar over C<new>, working like this:
751             #pod
752             #pod =for :list
753             #pod * packages version defaults to the dist version unless specified
754             #pod * packages for dist Foo-Bar defaults to Foo::Bar unless specified
755             #pod * if specified, packages is an L<optlist|Data::OptList>
756             #pod
757             #pod =cut
758              
759             sub from_struct {
760 0     0 1   my ($self, $arg) = @_;
761              
762 0 0         my $version = exists $arg->{version} ? $arg->{version} : $DEFAULT_VERSION;
763              
764             my $specs = Data::OptList::mkopt(
765             ! exists $arg->{packages} ? [ __dist_to_pkg($arg->{name}) ]
766             : ref $arg->{packages} ? $arg->{packages}
767 0 0         : defined $arg->{packages} ? [ $arg->{packages} ]
    0          
    0          
768             : ()
769             );
770              
771 0           my @packages;
772 0           for my $spec (@$specs) {
773 0 0         my %spec = $spec->[1] ? %{ $spec->[1] } : ();
  0            
774              
775             push @packages, Module::Faker::Package->new({
776             name => $spec->[0],
777             in_file => __pkg_to_file($spec->[0]), # to be overridden below if needed
778             %spec,
779 0 0         version => (exists $spec{version} ? $spec{version} : $version),
780             });
781             }
782              
783 0           return $self->new({
784             %$arg,
785             version => $version,
786             packages => \@packages,
787             });
788             }
789              
790             1;
791              
792             # vim: ts=2 sts=2 sw=2 et:
793              
794             __END__
795              
796             =pod
797              
798             =encoding UTF-8
799              
800             =head1 NAME
801              
802             Module::Faker::Dist - a fake CPAN distribution
803              
804             =head1 VERSION
805              
806             version 0.025
807              
808             =head1 SYNOPSIS
809              
810             Building one dist at a time makes plenty of sense, so Module::Faker::Dist makes
811             it easy. Building dists from definitions in files is also useful for doing
812             things in bulk (see L<CPAN::Faker>), so there are a bunch of ways to build
813             dists from a definition in a file.
814              
815             # Build from a META.yml or META.json file, or the delightful
816             # AUTHOR_Foo-Bar-1.234.tar.gz.dist file, which can be zero bytes and gets
817             # all the relevant data from the filename.
818             my $dist = Module::Faker::Dist->from_file($filename);
819              
820             META files can contain a key called X_Module_Faker that contains attributes to
821             use in constructing the dist. C<dist> files can contain anything you want, but
822             the contents won't do a thing.
823              
824             You can use the C<new> method on Module::Faker::Dist, of course, but it's a bit
825             of a pain. You might, instead, want to use C<from_struct>, which is very close
826             to C<new>, but with more sugar.
827              
828             =head1 PERL VERSION
829              
830             This module should work on any version of perl still receiving updates from
831             the Perl 5 Porters. This means it should work on any version of perl released
832             in the last two to three years. (That is, if the most recently released
833             version is v5.40, then this module should work on both v5.40 and v5.38.)
834              
835             Although it may work on older versions of perl, no guarantee is made that the
836             minimum required version will not be increased. The version may be increased
837             for any reason, and there is no promise that patches will be accepted to lower
838             the minimum required perl.
839              
840             =head1 ATTRIBUTES
841              
842             =head2 name
843              
844             This is the name of the dist. It will usually look like C<Foo-Bar>.
845              
846             =head2 version
847              
848             This is the version of the dist, usually some kind of versiony string like
849             C<1.234> or maybe C<1.2.3>.
850              
851             =head2 abstract
852              
853             The abstract! This is a short, pithy description of the distribution, usually
854             less than a sentence.
855              
856             =head2 release_status
857              
858             This is the dist's release status. (See L<CPAN::Meta::Spec>.) It defaults to
859             C<stable> but C<unstable> and C<testing> are valid values.
860              
861             =head2 cpan_author
862              
863             This is the PAUSE id of the author, like C<RJBS>.
864              
865             =head2 archive_ext
866              
867             This is the extension of the archive to build, when you build an archive. This
868             defaults to C<tar.gz>. C<zip> should work, but right now it doesn't. So
869             probably stuck to C<tar.gz>. It would be cool to support more attributes in
870             the future.
871              
872             =head2 append
873              
874             This is an arrayref of hashrefs, each of which looks like:
875              
876             { file => $filename, content => $character_string }
877              
878             The content will be UTF-8 encoded and put into a file with the given name.
879              
880             This feature is a bit weird. Maybe it will go away eventually.
881              
882             =head2 mtime
883              
884             If given, this is the epoch seconds to which to set the mtime of the generated
885             file. This is useful in rare occasions.
886              
887             =head2 x_authority
888              
889             This is the C<X_Authority> header that gets put into the META files.
890              
891             =head2 license
892              
893             This is the meta spec license string for the distribution. It defaults to
894             C<perl_5>.
895              
896             =head2 authors
897              
898             This is an array of strings who are used as the authors in the dist metadata.
899             The default is:
900              
901             [ "AUTHOR <AUTHOR@cpan.local>" ]
902              
903             ...where C<AUTHOR> is the C<cpan_author> of the dist.
904              
905             =head2 include_provides_in_meta
906              
907             This is a bool. If true, the produced META files will include a C<provides>
908             key based on the packages in the dist. It defaults to false, to match the
909             most common behavior of dists in the wild.
910              
911             =head2 provides
912              
913             This is a hashref that gets used as the C<provides> in the metadata.
914              
915             If no provided, it is built from the C<packages> provided in construction.
916              
917             If no packages were provided, for a dist named Foo-Bar, it defaults to:
918              
919             { 'Foo::Bar' => { version => $DIST_VERSION, file => "lib/Foo/Bar.pm" } }
920              
921             =head2 archive_basename
922              
923             If written to disk, the archive will be written to...
924              
925             $dist->archive_basename . '.' . $dist->archive_ext
926              
927             The default is:
928              
929             $dist->name . '.' . ($dist->version // 'undef')
930              
931             =head2 omitted_files
932              
933             If given, this is an arrayref of filenames that shouldn't be automatically
934             generated and included.
935              
936             =head2 packages
937              
938             This is an array of L<Module::Faker::Package> objects. It's built by
939             C<provides> if needed, but you might want to look at using the
940             C<L</from_struct>> method to set it up.
941              
942             =head2 more_metadata
943              
944             This can be given as a hashref of data to merge into the CPAN::Meta files.
945              
946             =head2 meta_munger
947              
948             If given, this is a coderef that's called just before the CPAN::Meta data for
949             the dist is written to disk, an can be used to change things, especially into
950             invalid data. It is expected to return the new content to serialize.
951              
952             It's called like this:
953              
954             $coderef->($struct, { format => $format, version => $version });
955              
956             ...where C<$struct> is the result of C<< $cpan_meta->as_struct >>.
957             C<$version> is the version number of the target metafile. Normally, both
958             version 1.4 and 2 are requested. C<$format> is either C<yaml> or C<json>.
959              
960             If the munger returns a string instead of a structure, it will be used as the
961             content of the file being written. This lets you put all kinds of nonsense in
962             those meta files. Have fun, go nuts!
963              
964             =head1 METHODS
965              
966             =head2 modules
967              
968             This produces and returns a list of L<Module::Faker::Module> objects,
969             representing modules. Modules, if you're not as steeped in CPAN toolchain
970             nonsense, are the C<.pm> files in which packages are defined.
971              
972             These are produced by combining the packages from C<L</packages>> into files
973             based on their C<in_file> attributes.
974              
975             =head2 C<make_dist_dir>
976              
977             my $directory_name = $dist->make_dist_dir(\%arg);
978              
979             This returns the name of a directory into which the dist's contents have been
980             written. If a C<dir> argument is provided, the dist will be written to a
981             directory beneath that dir. Otherwise, it will be written below a temporary
982             directory.
983              
984             =head2 make_archive
985              
986             my $archive_filename = $dist->make_archive(\%arg);
987              
988             This writes the dist archive file, like a tarball or zip file. If a C<dir>
989             argument is given, it will be written in that directory. Otherwise, it will be
990             written to a temporary directory. If the C<author_prefix> argument is given
991             and true, it will be written under a hashed author dir, like:
992              
993             U/US/USERID/Foo-Bar-1.23.tar.gz
994              
995             =head2 from_file
996              
997             my $dist = Module::Faker::Dist->from_file($filename);
998              
999             Given a filename with dist configuration, this builds the dist described by the
1000             file.
1001              
1002             Given a file ending in C<yaml> or C<yml> or C<json>, it's treated as a
1003             CPAN::Meta file and interpreted as such. The key C<X_Module_Faker> can be
1004             present to provide attributes that don't match data found in a meta file.
1005              
1006             Given a file ending in C<dist>, all the configuration comes from the filename,
1007             which should look like this:
1008              
1009             AUTHOR_Dist-Name-1.234.tar.gz.dist
1010              
1011             =head2 from_struct
1012              
1013             my $dist = Module::Faker::Dist->from_struct(\%arg);
1014              
1015             This is sugar over C<new>, working like this:
1016              
1017             =over 4
1018              
1019             =item *
1020              
1021             packages version defaults to the dist version unless specified
1022              
1023             =item *
1024              
1025             packages for dist Foo-Bar defaults to Foo::Bar unless specified
1026              
1027             =item *
1028              
1029             if specified, packages is an L<optlist|Data::OptList>
1030              
1031             =back
1032              
1033             =head1 AUTHOR
1034              
1035             Ricardo Signes <cpan@semiotic.systems>
1036              
1037             =head1 COPYRIGHT AND LICENSE
1038              
1039             This software is copyright (c) 2008 by Ricardo Signes.
1040              
1041             This is free software; you can redistribute it and/or modify it under
1042             the same terms as the Perl 5 programming language system itself.
1043              
1044             =cut