/bin/cpanorg_perl_releases
http://github.com/perlorg/cpanorg · Perl · 164 lines · 102 code · 43 blank · 19 comment · 12 complexity · 9b9a239d95b07b397272ad5afa4034cc MD5 · raw file
- #!/usr/bin/env perl
- use strict;
- use warnings;
- # Work out the earliest and latest of each version of Perl
- # save as seperate json files
- use JSON ();
- use LWP::Simple qw(get);
- use File::Slurp qw(read_file);
- my $json = JSON->new->pretty;
- # Fetch all perl versions on cpan, perl_testing seperated out
- # will exit if the data has not changed
- my ( $perl_versions, $perl_testing ) = fetch_perl_version_data();
- $perl_versions = sort_versions($perl_versions);
- # Earliest
- {
- # Reverse to get earliest first
- my $earliest_per_version
- = extract_first_per_version_in_list( [ reverse @{$perl_versions} ] );
- my $earliest = sort_versions( [ values %{$earliest_per_version} ] );
- print_file( "perl_versions_earliest.json", $json->encode($earliest) );
- }
- # Latest
- {
- # List ordered with latest first
- my $latest_per_version
- = extract_first_per_version_in_list($perl_versions);
- my $latest = sort_versions( [ values %{$latest_per_version} ] );
- $latest->[0]->{latest} = 'true';
- print_file( "perl_version_latest_stable.json",
- $json->encode( $latest->[0] ) );
- # Add the latest test so people know what's coming
- # only if:
- # - not of the same version as the latest release
- # - larger number than the previous release (fix for security releases)
- unshift @$latest, $perl_testing->[0]
- if ( $perl_testing->[0]->{version_number} ne
- $latest->[0]->{version_number} )
- && (
- $perl_testing->[0]->{version_minor} > $latest->[0]->{version_minor} );
- print_file( "perl_versions_latest.json", $json->encode($latest) );
- }
- sub print_file {
- my ( $file, $data ) = @_;
- open my $fh, ">:utf8", "data/$file"
- or die "Could not open data/$file: $!";
- print $fh $data;
- close $fh;
- }
- sub sort_versions {
- my $list = shift;
- my @sorted = sort {
- $b->{version_major} <=> $a->{version_major}
- || int( $b->{version_minor} ) <=> int( $a->{version_minor} )
- || $b->{version_iota} <=> $a->{version_iota}
- } @{$list};
- return \@sorted;
- }
- sub extract_first_per_version_in_list {
- my $versions = shift;
- my $lookup = {};
- foreach my $version ( @{$versions} ) {
- my $minor_version = $version->{version_major} . '.'
- . int( $version->{version_minor} );
- $lookup->{$minor_version} = $version
- unless $lookup->{$minor_version};
- }
- return $lookup;
- }
- sub fetch_perl_version_data {
- my $perl_dist_url = "http://search.cpan.org/api/dist/perl";
- my $filename = 'perl_version_all.json';
- # See what we have on disk
- my $disk_json = '';
- $disk_json = read_file("data/$filename")
- if -r "data/$filename";
- my $cpan_json = get($perl_dist_url);
- die "Unable to fetch $perl_dist_url" unless $cpan_json;
- if ( $cpan_json eq $disk_json ) {
- # Data has not changed so don't need to do anything
- exit;
- } else {
- # Save for next fetch
- print_file( $filename, $cpan_json );
- }
- my $data = eval { $json->decode($cpan_json) };
- if ( my $err = $@ ) {
- die "$err: [$cpan_json]";
- }
- my @perls;
- my @testing;
- foreach my $module ( @{ $data->{releases} } ) {
- next unless $module->{authorized} eq 'true';
- my $version = $module->{version};
- $version =~ s/-(?:RC|TRIAL)\d+$//;
- $module->{version_number} = $version;
- my ( $major, $minor, $iota ) = split( '[\._]', $version );
- $module->{version_major} = $major;
- $module->{version_minor} = int($minor);
- $module->{version_iota} = int( $iota || '0' );
- # Do not trust the API as it gets it wrong
- delete $module->{latest};
- $module->{type}
- = $module->{status} eq 'testing'
- ? 'Devel'
- : 'Maint';
- # TODO: Ask - please add some validation logic here
- # so that on live it checks this exists
- my $zip_file = $module->{distvname} . '.tar.gz';
- $module->{zip_file} = $zip_file;
- $module->{url} = "http://www.cpan.org/src/5.0/" . $module->{zip_file};
- ( $module->{released_date}, $module->{released_time} )
- = split( 'T', $module->{released} );
- next if $major < 5;
- if ( $module->{status} eq 'stable' ) {
- push @perls, $module;
- } else {
- push @testing, $module;
- }
- }
- return \@perls, \@testing;
- }