/bin/cpanorg_perl_releases

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