File Coverage

blib/lib/Module/Faker/Dist.pm
Criterion Covered Total %
statement 194 214 90.6
branch 25 54 46.3
condition 14 23 60.8
subroutine 41 43 95.3
pod 5 9 55.5
total 279 343 81.3


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