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