File Coverage

blib/lib/Module/Faker/Dist.pm
Criterion Covered Total %
statement 201 226 88.9
branch 27 56 48.2
condition 15 23 65.2
subroutine 43 46 93.4
pod 5 9 55.5
total 291 360 80.8


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