/bin/cpanorg_perl_releases

http://github.com/perlorg/cpanorg · Perl · 164 lines · 102 code · 43 blank · 19 comment · 12 complexity · 9b9a239d95b07b397272ad5afa4034cc MD5 · raw file

  1. #!/usr/bin/env perl
  2. use strict;
  3. use warnings;
  4. # Work out the earliest and latest of each version of Perl
  5. # save as seperate json files
  6. use JSON ();
  7. use LWP::Simple qw(get);
  8. use File::Slurp qw(read_file);
  9. my $json = JSON->new->pretty;
  10. # Fetch all perl versions on cpan, perl_testing seperated out
  11. # will exit if the data has not changed
  12. my ( $perl_versions, $perl_testing ) = fetch_perl_version_data();
  13. $perl_versions = sort_versions($perl_versions);
  14. # Earliest
  15. {
  16. # Reverse to get earliest first
  17. my $earliest_per_version
  18. = extract_first_per_version_in_list( [ reverse @{$perl_versions} ] );
  19. my $earliest = sort_versions( [ values %{$earliest_per_version} ] );
  20. print_file( "perl_versions_earliest.json", $json->encode($earliest) );
  21. }
  22. # Latest
  23. {
  24. # List ordered with latest first
  25. my $latest_per_version
  26. = extract_first_per_version_in_list($perl_versions);
  27. my $latest = sort_versions( [ values %{$latest_per_version} ] );
  28. $latest->[0]->{latest} = 'true';
  29. print_file( "perl_version_latest_stable.json",
  30. $json->encode( $latest->[0] ) );
  31. # Add the latest test so people know what's coming
  32. # only if:
  33. # - not of the same version as the latest release
  34. # - larger number than the previous release (fix for security releases)
  35. unshift @$latest, $perl_testing->[0]
  36. if ( $perl_testing->[0]->{version_number} ne
  37. $latest->[0]->{version_number} )
  38. && (
  39. $perl_testing->[0]->{version_minor} > $latest->[0]->{version_minor} );
  40. print_file( "perl_versions_latest.json", $json->encode($latest) );
  41. }
  42. sub print_file {
  43. my ( $file, $data ) = @_;
  44. open my $fh, ">:utf8", "data/$file"
  45. or die "Could not open data/$file: $!";
  46. print $fh $data;
  47. close $fh;
  48. }
  49. sub sort_versions {
  50. my $list = shift;
  51. my @sorted = sort {
  52. $b->{version_major} <=> $a->{version_major}
  53. || int( $b->{version_minor} ) <=> int( $a->{version_minor} )
  54. || $b->{version_iota} <=> $a->{version_iota}
  55. } @{$list};
  56. return \@sorted;
  57. }
  58. sub extract_first_per_version_in_list {
  59. my $versions = shift;
  60. my $lookup = {};
  61. foreach my $version ( @{$versions} ) {
  62. my $minor_version = $version->{version_major} . '.'
  63. . int( $version->{version_minor} );
  64. $lookup->{$minor_version} = $version
  65. unless $lookup->{$minor_version};
  66. }
  67. return $lookup;
  68. }
  69. sub fetch_perl_version_data {
  70. my $perl_dist_url = "http://search.cpan.org/api/dist/perl";
  71. my $filename = 'perl_version_all.json';
  72. # See what we have on disk
  73. my $disk_json = '';
  74. $disk_json = read_file("data/$filename")
  75. if -r "data/$filename";
  76. my $cpan_json = get($perl_dist_url);
  77. die "Unable to fetch $perl_dist_url" unless $cpan_json;
  78. if ( $cpan_json eq $disk_json ) {
  79. # Data has not changed so don't need to do anything
  80. exit;
  81. } else {
  82. # Save for next fetch
  83. print_file( $filename, $cpan_json );
  84. }
  85. my $data = eval { $json->decode($cpan_json) };
  86. if ( my $err = $@ ) {
  87. die "$err: [$cpan_json]";
  88. }
  89. my @perls;
  90. my @testing;
  91. foreach my $module ( @{ $data->{releases} } ) {
  92. next unless $module->{authorized} eq 'true';
  93. my $version = $module->{version};
  94. $version =~ s/-(?:RC|TRIAL)\d+$//;
  95. $module->{version_number} = $version;
  96. my ( $major, $minor, $iota ) = split( '[\._]', $version );
  97. $module->{version_major} = $major;
  98. $module->{version_minor} = int($minor);
  99. $module->{version_iota} = int( $iota || '0' );
  100. # Do not trust the API as it gets it wrong
  101. delete $module->{latest};
  102. $module->{type}
  103. = $module->{status} eq 'testing'
  104. ? 'Devel'
  105. : 'Maint';
  106. # TODO: Ask - please add some validation logic here
  107. # so that on live it checks this exists
  108. my $zip_file = $module->{distvname} . '.tar.gz';
  109. $module->{zip_file} = $zip_file;
  110. $module->{url} = "http://www.cpan.org/src/5.0/" . $module->{zip_file};
  111. ( $module->{released_date}, $module->{released_time} )
  112. = split( 'T', $module->{released} );
  113. next if $major < 5;
  114. if ( $module->{status} eq 'stable' ) {
  115. push @perls, $module;
  116. } else {
  117. push @testing, $module;
  118. }
  119. }
  120. return \@perls, \@testing;
  121. }