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 CAVEATS
 290
 291 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.
 292 However, they will be installed when __TASK_PKG__ is, thus will be available when you actually use __TARGET_PKG__.
 293
 294 =head1 AUTHOR
 295
 296 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 297
 298 You can contact me by mail or on C<irc.perl.org> (vincent).
 299
 300 =head1 BUGS
 301
 302 Please report any bugs or feature requests to C<__BUG_EMAIL__>, or through the web interface at L<__BUG_QUEUE__>.
 303 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 304
 305 =head1 SUPPORT
 306
 307 You can find documentation for this module with the perldoc command.
 308
 309     perldoc __TASK_PKG__
 310
 311 =head1 COPYRIGHT & LICENSE
 312
 313 Copyright __YEARS__ Vincent Pit, all rights reserved.
 314
 315 This program is free software; you can redistribute it and/or modify it
 316 under the same terms as Perl itself.
 317
 318 =cut
 319
 320 1; # End of __TASK_PKG__
 321 TEMPLATE
 322  # ----------------------------------------------------------------------------
 323  'Makefile.PL' => <<'TEMPLATE',
 324 use __PERL_PREREQ__;
 325
 326 use strict;
 327 use warnings;
 328 use ExtUtils::MakeMaker;
 329
 330 my $dist = 'Task-Devel-Cover-Recommended';
 331
 332 (my $name = $dist) =~ s{-}{::}g;
 333
 334 (my $file = $dist) =~ s{-}{/}g;
 335 $file = "lib/$file.pm";
 336
 337 my $CONFIGURE_PREREQS = __CONFIGURE_PREREQS_PERL__;
 338
 339 my $BUILD_PREREQS = __BUILD_PREREQS_PERL__;
 340
 341 my $RUN_PREREQS = __RUN_PREREQS_PERL__;
 342
 343 my %META = (
 344  configure_requires => $CONFIGURE_PREREQS,
 345  build_requires     => $BUILD_PREREQS,
 346  dynamic_config     => 0,
 347  resources          => {
 348   bugtracker => "http://rt.cpan.org/NoAuth/ReportBug.html?Queue=$dist",
 349   homepage   => "http://search.cpan.org/dist/$dist/",
 350   license    => 'http://dev.perl.org/licenses/',
 351   repository => "http://git.profvince.com/?p=perl%2Fmodules%2F$dist.git",
 352  },
 353 );
 354
 355 WriteMakefile(
 356  NAME             => $name,
 357  AUTHOR           => 'Vincent Pit <perl@profvince.com>',
 358  LICENSE          => 'perl',
 359  VERSION_FROM     => $file,
 360  ABSTRACT_FROM    => $file,
 361  PL_FILES         => {},
 362  BUILD_REQUIRES   => $BUILD_PREREQS,
 363  PREREQ_PM        => $RUN_PREREQS,
 364  MIN_PERL_VERSION => '__PERL_PREREQ__',
 365  META_MERGE       => \%META,
 366  dist             => {
 367   PREOP    => "pod2text -u $file > \$(DISTVNAME)/README",
 368   COMPRESS => 'gzip -9f', SUFFIX => 'gz'
 369  },
 370  clean            => {
 371   FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt*"
 372  }
 373 );
 374 TEMPLATE
 375  # ----------------------------------------------------------------------------
 376  't/01-deps.t' => <<'TEMPLATE',
 377 #!perl
 378
 379 use strict;
 380 use warnings;
 381
 382 use Test::More;
 383
 384 my $TESTED_PREREQS = __TESTED_PREREQS__;
 385
 386 plan tests => keys(%$TESTED_PREREQS) + 1;
 387
 388 my @tests = map [ $_ => $TESTED_PREREQS->{$_} ], keys %$TESTED_PREREQS;
 389 push @tests, [ '__TARGET_PKG__' => '__TARGET_VERSION__' ];
 390
 391 for my $test (@tests) {
 392  my ($module, $version) = @$test;
 393  local $@;
 394  if ($version && $version !~ /^[0._]*$/) {
 395   eval "use $module $version ()";
 396   is $@, '', "$module v$version is available";
 397  } else {
 398   eval "use $module ()";
 399   is $@, '', "any version of $module is available";
 400  }
 401 }
 402 TEMPLATE
 403 );
 404
 405 my $valid_keys = join '|', keys %vars;
 406 $valid_keys    = qr/$valid_keys/;
 407
 408 for my $file (sort keys %templates) {
 409  my $template = $templates{$file};
 410  $template =~ s/\b__($valid_keys)__\b/$vars{$1}/go;
 411
 412  open my $fh, '>', $file;
 413  print $fh $template;
 414  close $fh;
 415 }