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 %prereqs = (
  99  configure => {
 100   'ExtUtils::MakeMaker' => '0',
 101  },
 102  build => {
 103   'ExtUtils::MakeMaker' => '0',
 104   'Test::More'          => '0',
 105  },
 106  perl => '5',
 107 );
 108
 109 for my $eumm_phase (keys %eumm_phases) {
 110  my $prereqs = $prereqs{$eumm_phase} ||= { };
 111  my $skip    = $prereq_skip{$eumm_phase};
 112
 113  for my $meta_phase (@{$eumm_phases{$eumm_phase}}) {
 114
 115   for my $type (qw<requires recommends>) {
 116    my $phase_prereqs = $meta->{prereqs}{$meta_phase}{$type};
 117    next unless $phase_prereqs;
 118
 119    while (my ($module, $version) = each %$phase_prereqs) {
 120     next if $skip->{$module};
 121
 122     if ($module eq 'perl') {
 123      if (not $prereqs{perl} or $prereqs{perl} < $version) {
 124       $prereqs{perl} = $version;
 125      }
 126     } elsif (not exists $prereqs->{$module} or
 127              version->parse($prereqs->{$module}) < version->parse($version)) {
 128      $prereqs->{$module} = $version;
 129     }
 130    }
 131   }
 132  }
 133 }
 134
 135 (my $target_pkg = $target_dist) =~ s/-/::/g;
 136 my $task_pkg    = "Task::${target_pkg}::Recommended";
 137 (my $task_file  = "lib/$task_pkg.pm") =~ s{::}{/}g;
 138 my $years       = join ',', $first_year .. ((gmtime)[5] + 1900);
 139
 140 my $old_task_version = '0.0.0';
 141 if (-e $task_file) {
 142  open my $old_fh, '<', $task_file;
 143  while (<$old_fh>) {
 144   if (/our\s*\$VERSION\s*=\s*(.*);/) {
 145    $old_task_version = $1;
 146    $old_task_version =~ s/^(['"])(.*)\1$/$2/;
 147   }
 148  }
 149  close $old_fh;
 150 }
 151 my ($old_task_revision) = $old_task_version =~ /([0-9]+)$/;
 152
 153 my $new_task_version  = version->parse($target_version)->normal;
 154 my $new_task_revision = $old_task_revision;
 155 if (!$opts{n}
 156    and version->parse($new_task_version) <= version->parse($old_task_version)) {
 157  ++$new_task_revision;
 158 }
 159 if (($target_version =~ tr/.//) < 2) {
 160  my @components     = split /\./, $new_task_version;
 161  $components[2]     = $new_task_revision;
 162  $new_task_version  = join '.', @components;
 163 } else {
 164  $new_task_version .= ".$new_task_revision";
 165 }
 166
 167 (my $bug_queue = $task_pkg) =~ s/::/-/g;
 168 my $bug_email  = "bug-\L$bug_queue\E at rt.cpan.org";
 169 $bug_queue     = "http://rt.cpan.org/NoAuth/ReportBug.html?Queue=$bug_queue";
 170
 171 sub deplist_to_pod {
 172  my @deplist = @_;
 173  return 'None.' unless @deplist;
 174
 175  my $pod = "=over 4\n\n";
 176  while (@deplist) {
 177   my ($module, $version) = splice @deplist, 0, 2;
 178   my $X = $module eq 'perl' ? 'C' : 'L';
 179   $pod .= "=item *\n\n$X<$module>";
 180   $pod .= " $version" if $version;
 181   $pod .= "\n\n";
 182   if (my $desc = $prereq_desc{$module}) {
 183    1 while chomp $desc;
 184    $pod .= "$desc\n\n";
 185   }
 186  }
 187  $pod .= '=back';
 188
 189  return $pod;
 190 }
 191
 192 sub deplist_to_perl {
 193  my @deplist = @_;
 194  return '{ }' unless @deplist;
 195
 196  my $len = List::Util::max(
 197   map length, @deplist[grep not($_ % 2), 0 .. $#deplist ]
 198  );
 199
 200  my $perl = "{\n";
 201  while (@deplist) {
 202   my ($module, $version) = splice @deplist, 0, 2;
 203   my $pad = $len + 1 - length $module;
 204   $perl  .= sprintf " '%s'%*s=> '%s',\n", $module, $pad, ' ', $version;
 205  }
 206  $perl .= '}';
 207
 208  return $perl;
 209 }
 210
 211 sub sorthr ($) {
 212  my $hr = shift;
 213  map { $_ => $hr->{$_} } sort keys %$hr;
 214 }
 215
 216 # Make sure no package FOO statement appears in this file.
 217 my $package_statement = join ' ', 'package',
 218                                    $task_pkg;
 219
 220 my %vars = (
 221  TARGET_PKG             => $target_pkg,
 222  TARGET_VERSION         => $target_version,
 223  TASK_PKG               => $task_pkg,
 224  PACKAGE_TASK_PKG       => $package_statement,
 225  TASK_VERSION           => $new_task_version,
 226  PERL_PREREQ            => $prereqs{perl},
 227  CONFIGURE_PREREQS_POD  => deplist_to_pod(sorthr $prereqs{configure}),
 228  BUILD_PREREQS_POD      => deplist_to_pod(sorthr $prereqs{build}),
 229  RUN_PREREQS_POD        => deplist_to_pod(
 230   $target_pkg => $target_version,
 231   'perl'      => $prereqs{perl},
 232   sorthr $prereqs{run}
 233  ),
 234  CONFIGURE_PREREQS_PERL => deplist_to_perl(sorthr $prereqs{configure}),
 235  BUILD_PREREQS_PERL     => deplist_to_perl(sorthr $prereqs{build}),
 236  RUN_PREREQS_PERL       => deplist_to_perl(
 237   sorthr $prereqs{run},
 238   $target_pkg => $target_version,
 239  ),
 240  TESTED_PREREQS         => deplist_to_perl(sorthr $prereqs{run}),
 241  BUG_EMAIL              => $bug_email,
 242  BUG_QUEUE              => $bug_queue,
 243  YEARS                  => $years,
 244 );
 245
 246 my %templates = (
 247  $task_file => <<'TEMPLATE',
 248 __PACKAGE_TASK_PKG__;
 249
 250 use strict;
 251 use warnings;
 252
 253 =head1 NAME
 254
 255 __TASK_PKG__ - Install __TARGET_PKG__ and its recommended dependencies.
 256
 257 =head1 VERSION
 258
 259 Version __TASK_VERSION__
 260
 261 =cut
 262
 263 our $VERSION = '__TASK_VERSION__';
 264
 265 =head1 SYNOPSIS
 266
 267     $ cpan __TASK_PKG__
 268     $ cpanp -i __TASK_PKG__
 269     $ cpanm __TASK_PKG__
 270
 271 =head1 DESCRIPTION
 272
 273 This task module lets you easily install L<__TARGET_PKG__> __TARGET_VERSION__ and all its recommended dependencies.
 274
 275 =head1 DEPENDENCIES
 276
 277 =head2 Configure-time dependencies
 278
 279 __CONFIGURE_PREREQS_POD__
 280
 281 =head2 Build-time and test-time dependencies
 282
 283 __BUILD_PREREQS_POD__
 284
 285 =head2 Run-time dependencies
 286
 287 __RUN_PREREQS_POD__
 288
 289 =head1 AUTHOR
 290
 291 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 292
 293 You can contact me by mail or on C<irc.perl.org> (vincent).
 294
 295 =head1 BUGS
 296
 297 Please report any bugs or feature requests to C<__BUG_EMAIL__>, or through the web interface at L<__BUG_QUEUE__>.
 298 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 299
 300 =head1 SUPPORT
 301
 302 You can find documentation for this module with the perldoc command.
 303
 304     perldoc __TASK_PKG__
 305
 306 =head1 COPYRIGHT & LICENSE
 307
 308 Copyright __YEARS__ Vincent Pit, all rights reserved.
 309
 310 This program is free software; you can redistribute it and/or modify it
 311 under the same terms as Perl itself.
 312
 313 =cut
 314
 315 1; # End of __TASK_PKG__
 316 TEMPLATE
 317  # ----------------------------------------------------------------------------
 318  'Makefile.PL' => <<'TEMPLATE',
 319 use __PERL_PREREQ__;
 320
 321 use strict;
 322 use warnings;
 323 use ExtUtils::MakeMaker;
 324
 325 my $dist = 'Task-Devel-Cover-Recommended';
 326
 327 (my $name = $dist) =~ s{-}{::}g;
 328
 329 (my $file = $dist) =~ s{-}{/}g;
 330 $file = "lib/$file.pm";
 331
 332 my $CONFIGURE_PREREQS = __CONFIGURE_PREREQS_PERL__;
 333
 334 my $BUILD_PREREQS = __BUILD_PREREQS_PERL__;
 335
 336 my $RUN_PREREQS = __RUN_PREREQS_PERL__;
 337
 338 my %META = (
 339  configure_requires => $CONFIGURE_PREREQS,
 340  build_requires     => $BUILD_PREREQS,
 341  dynamic_config     => 0,
 342  resources          => {
 343   bugtracker => "http://rt.cpan.org/NoAuth/ReportBug.html?Queue=$dist",
 344   homepage   => "http://search.cpan.org/dist/$dist/",
 345   license    => 'http://dev.perl.org/licenses/',
 346   repository => "http://git.profvince.com/?p=perl%2Fmodules%2F$dist.git",
 347  },
 348 );
 349
 350 WriteMakefile(
 351  NAME             => $name,
 352  AUTHOR           => 'Vincent Pit <perl@profvince.com>',
 353  LICENSE          => 'perl',
 354  VERSION_FROM     => $file,
 355  ABSTRACT_FROM    => $file,
 356  PL_FILES         => {},
 357  PREREQ_PM        => $RUN_PREREQS,
 358  MIN_PERL_VERSION => '__PERL_PREREQ__',
 359  META_MERGE       => \%META,
 360  dist             => {
 361   PREOP    => "pod2text -u $file > \$(DISTVNAME)/README",
 362   COMPRESS => 'gzip -9f', SUFFIX => 'gz'
 363  },
 364  clean            => {
 365   FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt*"
 366  }
 367 );
 368 TEMPLATE
 369  # ----------------------------------------------------------------------------
 370  't/01-deps.t' => <<'TEMPLATE',
 371 #!perl
 372
 373 use strict;
 374 use warnings;
 375
 376 use Test::More;
 377
 378 my $TESTED_PREREQS = __TESTED_PREREQS__;
 379
 380 plan tests => keys(%$TESTED_PREREQS) + 1;
 381
 382 my @tests = map [ $_ => $TESTED_PREREQS->{$_} ], keys %$TESTED_PREREQS;
 383 push @tests, [ '__TARGET_PKG__' => '__TARGET_VERSION__' ];
 384
 385 for my $test (@tests) {
 386  my ($module, $version) = @$test;
 387  local $@;
 388  if ($version && $version !~ /^[0._]*$/) {
 389   eval "use $module $version ()";
 390   is $@, '', "$module v$version is available";
 391  } else {
 392   eval "use $module ()";
 393   is $@, '', "any version of $module is available";
 394  }
 395 }
 396 TEMPLATE
 397 );
 398
 399 my $valid_keys = join '|', keys %vars;
 400 $valid_keys    = qr/$valid_keys/;
 401
 402 for my $file (sort keys %templates) {
 403  my $template = $templates{$file};
 404  $template =~ s/\b__($valid_keys)__\b/$vars{$1}/go;
 405
 406  open my $fh, '>', $file;
 407  print $fh $template;
 408  close $fh;
 409 }