samples/generate.pl

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use autodie;
   7 use version;
   8
   9 use Archive::Extract;
  10 use Cwd;
  11 use File::Fetch;
  12 use File::Spec;
  13 use File::Temp 0.19;
  14 use Getopt::Std;
  15 use List::Util;
  16 use Parse::CPAN::Meta;
  17
  18 use File::HomeDir;
  19 use Parse::CPAN::Packages::Fast;
  20
  21 my $target_dist = 'Devel-Cover';
  22 my $first_year  = 2012;
  23 my $cpan_mirror = 'http://www.cpan.org';
  24 my %prereq_skip = (
  25  'run' => {
  26   'Perl::Tidy'        => 1,
  27   'Test::Differences' => 1,
  28  },
  29 );
  30 my %prereq_desc = (
  31  'PPI::HTML' => 'Devel::Cover lets you optionally pick between L<PPI::HTML> and L<Perl::Tidy>, but it will only use the former if both are installed.',
  32 );
  33
  34 my %opts;
  35 getopts 'n' => \%opts;
  36
  37 sub get_latest_dist {
  38  my $dist = shift;
  39
  40  my $home = File::HomeDir->my_home;
  41  my $pkgs = File::Spec->catfile($home, qw<.cpanplus 02packages.details.txt.gz>);
  42  my $pcp  = Parse::CPAN::Packages::Fast->new($pkgs);
  43
  44  my $d = $pcp->latest_distribution($dist);
  45  die "Could not find distribution '$dist' on the CPAN" unless $d;
  46
  47  return $d;
  48 }
  49
  50 sub get_dist_meta {
  51  my $d = shift;
  52
  53  $cpan_mirror =~s{/+$}{}g;
  54  my $cpanid   = $d->cpanid;
  55  my ($cp, $c) = $cpanid =~ /^((.).)/;
  56  my $uri      = join '/', $cpan_mirror, 'authors', 'id', $c, $cp, $cpanid,
  57                           $d->filename;
  58
  59  my $tmp_dir     = File::Temp->newdir;
  60  # Force symlinks resolution
  61  my $tmp_dirname = Cwd::abs_path($tmp_dir->dirname);
  62
  63  my $ff      = File::Fetch->new(uri => $uri);
  64  my $archive = $ff->fetch(to => $tmp_dirname);
  65  die $ff->error unless $archive;
  66
  67  my $ae = Archive::Extract->new(archive => $archive);
  68  $ae->extract(to => $tmp_dirname) or die $ae->error;
  69
  70  my $files = {
  71   map { File::Spec->catfile($tmp_dirname, $_) => 1 }
  72    @{$ae->files}
  73  };
  74  my $abs_extract_path = Cwd::abs_path($ae->extract_path);
  75  my @meta_candidates  = map File::Spec->catfile($abs_extract_path, $_),
  76                          qw<META.json META.yml>;
  77  my $meta_file;
  78  for my $file (@meta_candidates) {
  79   if ($files->{$file}) {
  80    $meta_file = $file;
  81    last;
  82   }
  83  }
  84  die 'No META file for ' . $d->distvname . "\n" unless $meta_file;
  85
  86  return Parse::CPAN::Meta->load_file($meta_file);
  87 }
  88
  89 my $latest_target  = get_latest_dist($target_dist);
  90 my $target_version = $latest_target->version;
  91 my $meta           = get_dist_meta($latest_target);
  92
  93 my %eumm_phases = (
  94  configure => [ qw<configure>  ],
  95  build     => [ qw<build test> ],
  96  run       => [ qw<runtime>    ],
  97 );
  98 my %meta_phase_relationships = (
  99  configure => [ qw<requires>                     ],
 100  build     => [ qw<requires>                     ],
 101  test      => [ qw<requires>                     ],
 102  runtime   => [ qw<requires recommends suggests> ],
 103 );
 104
 105 my %prereqs = (
 106  configure => {
 107   'ExtUtils::MakeMaker' => '0',
 108  },
 109  build => {
 110   'ExtUtils::MakeMaker' => '0',
 111   'Test::More'          => '0',
 112  },
 113  perl => '5',
 114 );
 115
 116 for my $eumm_phase (keys %eumm_phases) {
 117  my $prereqs = $prereqs{$eumm_phase} ||= { };
 118  my $skip    = $prereq_skip{$eumm_phase};
 119
 120  for my $meta_phase (@{$eumm_phases{$eumm_phase}}) {
 121
 122   for my $type (@{$meta_phase_relationships{$meta_phase}}) {
 123    my $phase_prereqs = $meta->{prereqs}{$meta_phase}{$type};
 124    next unless $phase_prereqs;
 125
 126    while (my ($module, $version) = each %$phase_prereqs) {
 127     next if $skip->{$module};
 128
 129     if ($module eq 'perl') {
 130      if (not $prereqs{perl} or $prereqs{perl} < $version) {
 131       $prereqs{perl} = $version;
 132      }
 133     } elsif (not exists $prereqs->{$module} or
 134              version->parse($prereqs->{$module}) < version->parse($version)) {
 135      $prereqs->{$module} = $version;
 136     }
 137    }
 138   }
 139  }
 140 }
 141
 142 (my $target_pkg = $target_dist) =~ s/-/::/g;
 143 my $task_pkg    = "Task::${target_pkg}::Recommended";
 144 (my $task_file  = "lib/$task_pkg.pm") =~ s{::}{/}g;
 145 my $years       = join ',', $first_year .. ((gmtime)[5] + 1900);
 146
 147 my $old_task_version = '0.0.0';
 148 if (-e $task_file) {
 149  open my $old_fh, '<', $task_file;
 150  while (<$old_fh>) {
 151   if (/our\s*\$VERSION\s*=\s*(.*);/) {
 152    $old_task_version = $1;
 153    $old_task_version =~ s/^(['"])(.*)\1$/$2/;
 154   }
 155  }
 156  close $old_fh;
 157 }
 158 my ($old_task_revision) = $old_task_version =~ /([0-9]+)$/;
 159
 160 my $new_task_version  = version->parse($target_version)->normal;
 161 my $new_task_revision = $old_task_revision;
 162 if (!$opts{n}
 163    and version->parse($new_task_version) <= version->parse($old_task_version)) {
 164  ++$new_task_revision;
 165 }
 166 if (($target_version =~ tr/.//) < 2) {
 167  my @components     = split /\./, $new_task_version;
 168  $components[2]     = $new_task_revision;
 169  $new_task_version  = join '.', @components;
 170 } else {
 171  $new_task_version .= ".$new_task_revision";
 172 }
 173
 174 (my $bug_queue = $task_pkg) =~ s/::/-/g;
 175 my $bug_email  = "bug-\L$bug_queue\E at rt.cpan.org";
 176 $bug_queue     = "http://rt.cpan.org/NoAuth/ReportBug.html?Queue=$bug_queue";
 177
 178 sub deplist_to_pod {
 179  my @deplist = @_;
 180  return 'None.' unless @deplist;
 181
 182  my $pod = "=over 4\n\n";
 183  while (@deplist) {
 184   my ($module, $version) = splice @deplist, 0, 2;
 185   my $X = $module eq 'perl' ? 'C' : 'L';
 186   $pod .= "=item *\n\n$X<$module>";
 187   $pod .= " $version" if $version;
 188   $pod .= "\n\n";
 189   if (my $desc = $prereq_desc{$module}) {
 190    1 while chomp $desc;
 191    $pod .= "$desc\n\n";
 192   }
 193  }
 194  $pod .= '=back';
 195
 196  return $pod;
 197 }
 198
 199 sub deplist_to_perl {
 200  my @deplist = @_;
 201  return '{ }' unless @deplist;
 202
 203  my $len = List::Util::max(
 204   map length, @deplist[grep not($_ % 2), 0 .. $#deplist]
 205  );
 206
 207  my $perl = "{\n";
 208  while (@deplist) {
 209   my ($module, $version) = splice @deplist, 0, 2;
 210   my $pad = $len + 1 - length $module;
 211   $perl  .= sprintf " '%s'%*s=> '%s',\n", $module, $pad, ' ', $version;
 212  }
 213  $perl .= '}';
 214
 215  return $perl;
 216 }
 217
 218 sub sorthr ($) {
 219  my $hr = shift;
 220  map { $_ => $hr->{$_} } sort keys %$hr;
 221 }
 222
 223 # Make sure no package FOO statement appears in this file.
 224 my $package_statement = join ' ', 'package',
 225                                    $task_pkg;
 226
 227 my %vars = (
 228  TARGET_PKG             => $target_pkg,
 229  TARGET_VERSION         => $target_version,
 230  TASK_PKG               => $task_pkg,
 231  PACKAGE_TASK_PKG       => $package_statement,
 232  TASK_VERSION           => $new_task_version,
 233  PERL_PREREQ            => $prereqs{perl},
 234  CONFIGURE_PREREQS_POD  => deplist_to_pod(sorthr $prereqs{configure}),
 235  BUILD_PREREQS_POD      => deplist_to_pod(sorthr $prereqs{build}),
 236  RUN_PREREQS_POD        => deplist_to_pod(
 237   $target_pkg => $target_version,
 238   'perl'      => $prereqs{perl},
 239   sorthr $prereqs{run}
 240  ),
 241  CONFIGURE_PREREQS_PERL => deplist_to_perl(sorthr $prereqs{configure}),
 242  BUILD_PREREQS_PERL     => deplist_to_perl(sorthr $prereqs{build}),
 243  RUN_PREREQS_PERL       => deplist_to_perl(
 244   sorthr $prereqs{run},
 245   $target_pkg => $target_version,
 246  ),
 247  TESTED_PREREQS         => deplist_to_perl(sorthr $prereqs{run}),
 248  BUG_EMAIL              => $bug_email,
 249  BUG_QUEUE              => $bug_queue,
 250  YEARS                  => $years,
 251 );
 252
 253 my %templates = (
 254  $task_file => <<'TEMPLATE',
 255 __PACKAGE_TASK_PKG__;
 256
 257 use strict;
 258 use warnings;
 259
 260 \=head1 NAME
 261
 262 __TASK_PKG__ - Install __TARGET_PKG__ and its recommended dependencies.
 263
 264 \=head1 VERSION
 265
 266 Version __TASK_VERSION__
 267
 268 \=cut
 269
 270 our $VERSION = '__TASK_VERSION__';
 271
 272 \=head1 SYNOPSIS
 273
 274     $ cpan __TASK_PKG__
 275     $ cpanp -i __TASK_PKG__
 276     $ cpanm __TASK_PKG__
 277
 278 \=head1 DESCRIPTION
 279
 280 This task module lets you easily install L<__TARGET_PKG__> __TARGET_VERSION__ and all its recommended dependencies.
 281
 282 \=head1 DEPENDENCIES
 283
 284 \=head2 Configure-time dependencies
 285
 286 __CONFIGURE_PREREQS_POD__
 287
 288 \=head2 Build-time and test-time dependencies
 289
 290 __BUILD_PREREQS_POD__
 291
 292 \=head2 Run-time dependencies
 293
 294 __RUN_PREREQS_POD__
 295
 296 \=head1 CAVEATS
 297
 298 Note that run-time dependencies that are only recommended by __TARGET_PKG__ may not yet be installed at the time __TARGET_PKG__ is tested, as there is no explicit dependency link between them and in that case most CPAN clients default to install prerequisites in alphabetic order.
 299 However, they will be installed when __TASK_PKG__ is, thus will be available when you actually use __TARGET_PKG__.
 300
 301 \=head1 AUTHOR
 302
 303 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 304
 305 You can contact me by mail or on C<irc.perl.org> (vincent).
 306
 307 \=head1 BUGS
 308
 309 Please report any bugs or feature requests to C<__BUG_EMAIL__>, or through the web interface at L<__BUG_QUEUE__>.
 310 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 311
 312 \=head1 SUPPORT
 313
 314 You can find documentation for this module with the perldoc command.
 315
 316     perldoc __TASK_PKG__
 317
 318 \=head1 COPYRIGHT & LICENSE
 319
 320 Copyright __YEARS__ Vincent Pit, all rights reserved.
 321
 322 This program is free software; you can redistribute it and/or modify it
 323 under the same terms as Perl itself.
 324
 325 \=cut
 326
 327 1; # End of __TASK_PKG__
 328 TEMPLATE
 329  # ----------------------------------------------------------------------------
 330  'Makefile.PL' => <<'TEMPLATE',
 331 use __PERL_PREREQ__;
 332
 333 use strict;
 334 use warnings;
 335 use ExtUtils::MakeMaker;
 336
 337 my $dist = 'Task-Devel-Cover-Recommended';
 338
 339 (my $name = $dist) =~ s{-}{::}g;
 340
 341 (my $file = $dist) =~ s{-}{/}g;
 342 $file = "lib/$file.pm";
 343
 344 my $CONFIGURE_PREREQS = __CONFIGURE_PREREQS_PERL__;
 345
 346 my $BUILD_PREREQS = __BUILD_PREREQS_PERL__;
 347
 348 my $RUN_PREREQS = __RUN_PREREQS_PERL__;
 349
 350 my %META = (
 351  configure_requires => $CONFIGURE_PREREQS,
 352  build_requires     => $BUILD_PREREQS,
 353  dynamic_config     => 0,
 354  resources          => {
 355   bugtracker => "http://rt.cpan.org/NoAuth/ReportBug.html?Queue=$dist",
 356   homepage   => "http://search.cpan.org/dist/$dist/",
 357   license    => 'http://dev.perl.org/licenses/',
 358   repository => "http://git.profvince.com/?p=perl%2Fmodules%2F$dist.git",
 359  },
 360 );
 361
 362 WriteMakefile(
 363  NAME             => $name,
 364  AUTHOR           => 'Vincent Pit <perl@profvince.com>',
 365  LICENSE          => 'perl',
 366  VERSION_FROM     => $file,
 367  ABSTRACT_FROM    => $file,
 368  PL_FILES         => {},
 369  BUILD_REQUIRES   => $BUILD_PREREQS,
 370  PREREQ_PM        => $RUN_PREREQS,
 371  MIN_PERL_VERSION => '__PERL_PREREQ__',
 372  META_MERGE       => \%META,
 373  dist             => {
 374   PREOP    => "pod2text -u $file > \$(DISTVNAME)/README",
 375   COMPRESS => 'gzip -9f', SUFFIX => 'gz'
 376  },
 377  clean            => {
 378   FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt*"
 379  }
 380 );
 381 TEMPLATE
 382  # ----------------------------------------------------------------------------
 383  't/01-deps.t' => <<'TEMPLATE',
 384 #!perl
 385
 386 use strict;
 387 use warnings;
 388
 389 use Test::More;
 390
 391 my $TESTED_PREREQS = __TESTED_PREREQS__;
 392
 393 plan tests => keys(%$TESTED_PREREQS) + 1;
 394
 395 my @tests = map [ $_ => $TESTED_PREREQS->{$_} ], keys %$TESTED_PREREQS;
 396 push @tests, [ '__TARGET_PKG__' => '__TARGET_VERSION__' ];
 397
 398 for my $test (@tests) {
 399  my ($module, $version) = @$test;
 400  local $@;
 401  if ($version && $version !~ /^[0._]*$/) {
 402   eval "use $module $version ()";
 403   is $@, '', "$module v$version is available";
 404  } else {
 405   eval "use $module ()";
 406   is $@, '', "any version of $module is available";
 407  }
 408 }
 409 TEMPLATE
 410 );
 411
 412 $templates{$task_file} =~ s/^\\=/=/mg;
 413
 414 my $valid_keys = join '|', keys %vars;
 415 $valid_keys    = qr/$valid_keys/;
 416
 417 for my $file (sort keys %templates) {
 418  my $template = $templates{$file};
 419  $template =~ s/\b__($valid_keys)__\b/$vars{$1}/go;
 420
 421  open my $fh, '>', $file;
 422  print $fh $template;
 423  close $fh;
 424 }