File Coverage

blib/lib/Module/CoreList/More.pm

Criterion	Covered	Total	%
statement	22	23	95.6
branch	2	2	100.0
condition			n/a
subroutine	13	13	100.0
pod	8	8	100.0
total	45	46	97.8

package Module::CoreList::More;

our $DATE = '2016-02-17'; # DATE
our $VERSION = '0.08'; # VERSION

use 5.010001;
use strict;
use warnings;

use Module::CoreList ();

sub _firstidx {
    my ($item, $ary) = @_;
    for (0..@$ary-1) {
       return $_ if $ary->[$_] eq $item;
    }
    -1;
}

# construct our own %delta from Module::CoreList's %delta. our version is a
# linear "linked list" (e.g. %delta{5.017} is a delta against %delta{5.016003}
# instead of %delta{5.016}. also, version numbers are cleaned (some versions in
# Module::CoreList has trailing whitespaces or alphas)

# the same for our own %released (version numbers in keys are canonicalized)

our @releases; # list of perl release versions, sorted by version
our @releases_by_date; # list of perl release versions, sorted by release date
our %delta;
our %released;
my %rel_orig_formats;
{
    # first let's only stored the canonical format of release versions
    # (Module::Core stores "5.01" as well as "5.010000"), for less headache
    # let's just store "5.010000"
    my %releases;
    for (sort keys %Module::CoreList::delta) {
        my $canonical = sprintf "%.6f", $_;
        next if $releases{$canonical};
        $releases{$canonical} = $Module::CoreList::delta{$_};
        $released{$canonical} = $Module::CoreList::released{$_};
        $rel_orig_formats{$canonical} = $_;
    }
    @releases = sort keys %releases;
    @releases_by_date = sort {$released{$a} cmp $released{$b}} keys %releases;

    for my $i (0..@releases-1) {
        my $reldelta = $releases{$releases[$i]};
        my $delta_from = $reldelta->{delta_from};
        my $changed = {};
        my $removed = {};
        # make sure that %delta will be linear "linked list" by release versions
        if ($delta_from && $delta_from != $releases[$i-1]) {
            $delta_from = sprintf "%.6f", $delta_from;
            my $i0 = _firstidx($delta_from, \@releases);
            #say "D: delta_from jumps from $delta_from (#$i0) -> $releases[$i] (#$i)";
            # accumulate changes between delta at releases #($i0+1) and #($i-1),
            # subtract them from delta at #($i)
            my $changed_between = {};
            my $removed_between = {};
            for my $j ($i0+1 .. $i-1) {
                my $reldelta_between = $releases{$releases[$j]};
                for (keys %{$reldelta_between->{changed}}) {
                    $changed_between->{$_} = $reldelta_between->{changed}{$_};
                    delete $removed_between->{$_};
                }
                for (keys %{$reldelta_between->{removed}}) {
                    $removed_between->{$_} = $reldelta_between->{removed}{$_};
                }
            }
            for (keys %{$reldelta->{changed}}) {
                next if exists($changed_between->{$_}) &&
                    !defined($changed_between->{$_}) && !defined($reldelta->{changed}{$_}) || # both undef
                    defined ($changed_between->{$_}) && defined ($reldelta->{changed}{$_}) && $changed_between->{$_} eq $reldelta->{changed}{$_}; # both defined & equal
                $changed->{$_} = $reldelta->{changed}{$_};
            }
            for (keys %{$reldelta->{removed}}) {
                next if $removed_between->{$_};
                $removed->{$_} = $reldelta->{removed}{$_};
            }
        } else {
            $changed = { %{$reldelta->{changed}} };
            $removed = { %{$reldelta->{removed} // {}} };
        }

        # clean version numbers
        for my $k (keys %$changed) {
            for ($changed->{$k}) {
                next unless defined;
                s/\s+$//; # eliminate trailing space
                # for "alpha" version, turn trailing junk such as letters to _
                # plus a number based on the first junk char
                s/([^.0-9_])[^.0-9_]*$/'_'.sprintf('%03d',ord $1)/e;
            }
        }
        $delta{$releases[$i]} = {
            changed => $changed,
            removed => $removed,
        };
    }
}

my $removed_from = sub {
    my ($order, $module) = splice @_,0,2;
    $module = shift if eval { $module->isa(__PACKAGE__) } && @_ > 0 && defined($_[0]) && $_[0] =~ /^\w/;

    for my $rel ($order eq 'date' ? @releases_by_date : @releases) {
        return $rel_orig_formats{$rel} if $delta{$rel}{removed}{$module};
    }

    return;
};

sub removed_from {
    $removed_from->('', @_);
}

sub removed_from_by_date {
    $removed_from->('date', @_);
}

my $first_release = sub {
    my ($order, $module) = splice @_,0,2;
    $module = shift if eval { $module->isa(__PACKAGE__) } && @_ > 0 && defined($_[0]) && $_[0] =~ /^\w/;

    for my $rel ($order eq 'date' ? @releases_by_date : @releases) {
        return $rel_orig_formats{$rel} if exists $delta{$rel}{changed}{$module};
    }

    return;
};

sub first_release {
    $first_release->('', @_);
}

sub first_release_by_date {
    $first_release->('date', @_);
}

my $is_core = sub {
    my $all = pop;
    my $module = shift;
    $module = shift if eval { $module->isa(__PACKAGE__) } && @_ > 0 && defined($_[0]) && $_[0] =~ /^\w/;
    my ($module_version, $perl_version);

    $module_version = shift if @_ > 0;
    $perl_version   = @_ > 0 ? shift : $];

    my $mod_exists = 0;
    my $mod_ver; # module version at each perl release, -1 means doesn't exist

  RELEASE:
    for my $rel (sort keys %delta) {
        last if $all && $rel > $perl_version; # this is the difference with is_still_core()

        my $reldelta = $delta{$rel};

        if ($rel > $perl_version) {
            if ($reldelta->{removed}{$module}) {
                $mod_exists = 0;
            } else {
                next;
            }
        }

        if (exists $reldelta->{changed}{$module}) {
            $mod_exists = 1;
            $mod_ver = $reldelta->{changed}{$module};
        } elsif ($reldelta->{removed}{$module}) {
            $mod_exists = 0;
        }
    }

    if ($mod_exists) {
        if (defined $module_version) {
            return 0 unless defined $mod_ver;
            return version->parse($mod_ver) >= version->parse($module_version) ? 1:0;
        }
        return 1;
    }
    return 0;
};

sub is_core { $is_core->(@_,1) }

sub is_still_core { $is_core->(@_,0) }

my $list_core_modules = sub {
    my $all = pop;
    my $class = shift if @_ && eval { $_[0]->isa(__PACKAGE__) };
    my $perl_version = @_ ? shift : $];

    my %added;
    my %removed;

  RELEASE:
    for my $rel (sort keys %delta) {
        last if $all && $rel > $perl_version; # this is the difference with list_still_core_modules()

        my $delta = $delta{$rel};

        next unless $delta->{changed};
        for my $mod (keys %{$delta->{changed}}) {
            # module has been removed between perl_version..latest, skip
            next if $removed{$mod};

            if (exists $added{$mod}) {
                # module has been added in a previous version, update first
                # version
                $added{$mod} = $delta->{changed}{$mod} if $rel <= $perl_version;
            } else {
                # module is first added after perl_version, skip
                next if $rel > $perl_version;

                $added{$mod} = $delta->{changed}{$mod};
            }
        }
        next unless $delta->{removed};
        for my $mod (keys %{$delta->{removed}}) {
            delete $added{$mod};
            # module has been removed between perl_version..latest, mark it
            $removed{$mod}++ if $rel >= $perl_version;
        }

    }
    %added;
};

sub list_core_modules { $list_core_modules->(@_,1) }

sub list_still_core_modules { $list_core_modules->(@_,0) }

1;

# ABSTRACT: More functions for Module::CoreList

__END__

=pod

=encoding UTF-8

=head1 NAME

Module::CoreList::More - More functions for Module::CoreList

=head1 VERSION

This document describes version 0.08 of Module::CoreList::More (from Perl distribution Module-CoreList-More), released on 2016-02-17.

=head1 SYNOPSIS

 use Module::CoreList::More;

 # true, this module has always been in core since specified perl release
 Module::CoreList::More->is_still_core("Benchmark", 5.010001);

 # false, since CGI is removed in perl 5.021000
 Module::CoreList::More->is_still_core("CGI");

 # false, never been in core
 Module::CoreList::More->is_still_core("Foo");

 my %modules = list_still_core_modules(5.010001);

=head1 DESCRIPTION

This module is my experiment for providing more functionality to (or related to)
L<Module::CoreList>. Some ideas include: faster functions, more querying
functions, more convenience functions. When I've got something stable and useful
to show for, I'll most probably suggest the appropriate additions to
Module::CoreList.

Below are random notes:

=head1 FUNCTIONS

These functions are not exported. They can be called as function (e.g.
C<Module::CoreList::More::is_still_core($name)> or as class method (e.g. C<<
Module::CoreList::More->is_still_core($name) >>.

=head2 first_release( MODULE )

Like Module::CoreList's version, but faster (see L</"BENCHMARK">).

=head2 first_release_by_date( MODULE )

Like Module::CoreList's version, but faster (see L</"BENCHMARK">).

=head2 removed_from( MODULE )

Like Module::CoreList's version, but faster (see L</"BENCHMARK">).

=head2 removed_from_by_date( MODULE )

Like Module::CoreList's version, but faster (see L</"BENCHMARK">).

=head2 is_core( MODULE, [ MODULE_VERSION, [ PERL_VERSION ] ] )

Like Module::CoreList's version, but faster (see L</"BENCHMARK">).

=head2 is_still_core( MODULE, [ MODULE_VERSION, [ PERL_VERSION ] ] )

Like C<is_core>, but will also check that from PERL_VERSION up to the latest
known version, MODULE has never been removed from core.

Note/idea: could also be implemented by adding a fourth argument
MAX_PERL_VERSION to C<is_core>, defaulting to the latest known version.

=head2 list_core_modules([ PERL_VERSION ]) => %modules

List modules that are in core at specified perl release.

=head2 list_still_core_modules([ PERL_VERSION ]) => %modules

List modules that are (still) in core from specified perl release to the latest.
Keys are module names, while values are versions of said modules in specified
perl release.

=head1 BENCHMARK

                                  Rate MC->removed_from(Foo) MC->removed_from(CGI) MCM->removed_from(Foo) MCM->removed_from(CGI)
 MC->removed_from(Foo)  153.77+-0.42/s                    --                -88.3%                 -99.7%                 -99.8%
 MC->removed_from(CGI)     1314.4+-4/s           754.8+-3.5%                    --                 -97.7%                 -98.0%
 MCM->removed_from(Foo)   57760+-280/s           37460+-210%             4294+-25%                     --                 -11.7%
 MCM->removed_from(CGI) 65407.3+-1.2/s           42440+-120%             4876+-15%           13.25+-0.55%                     --

                                            Rate MC->removed_from_by_date(Foo) MC->removed_from_by_date(CGI) MCM->removed_from_by_date(Foo) MCM->removed_from_by_date(CGI)
 MC->removed_from_by_date(Foo)    151.41+-0.25/s                            --                        -87.9%                         -99.7%                         -99.8%
 MC->removed_from_by_date(CGI)     1252.7+-1.7/s                   727.4+-1.8%                            --                         -97.9%                         -98.2%
 MCM->removed_from_by_date(Foo) 59798.3+-0.074/s                    39395+-64%                  4673.5+-6.5%                             --                         -13.6%
 MCM->removed_from_by_date(CGI)     69210+-120/s                   45610+-110%                     5424+-12%                    15.73+-0.2%                             --

                                  Rate MC->first_release(Foo) MC->first_release(CGI) MCM->first_release(Foo) MCM->first_release(CGI)
 MC->first_release(Foo)   154.7+-0.2/s                     --                 -87.0%                  -99.7%                 -100.0%
 MC->first_release(CGI)  1186.2+-2.3/s            666.8+-1.8%                     --                  -97.6%                  -99.7%
 MCM->first_release(Foo)   48641+-62/s             31342+-57%           4000.5+-9.4%                      --                  -88.2%
 MCM->first_release(CGI) 411020+-550/s           265590+-490%             34550+-80%               745+-1.6%                      --

                                           Rate MC->first_release_by_date(Foo) MC->first_release_by_date(CGI) MCM->first_release_by_date(Foo) MCM->first_release_by_date(CGI)
 MC->first_release_by_date(Foo)  155.92+-0.13/s                             --                         -82.9%                          -99.7%                         -100.0%
 MC->first_release_by_date(CGI)  913.53+-0.71/s                   485.9+-0.68%                             --                          -98.2%                          -99.8%
 MCM->first_release_by_date(Foo)    50483+-16/s                       32277.9%                        5426.2%                              --                          -87.7%
 MCM->first_release_by_date(CGI)  410590+-400/s                   263230+-340%                     44845+-56%                   713.32+-0.83%                              --

                              Rate MC->is_core(Foo) is_still_core(Foo) MCM->is_core(Foo)
 MC->is_core(Foo)   155.99+-0.14/s               --             -98.7%            -99.3%
 is_still_core(Foo) 11568.8+-3.6/s          7316.4%                 --            -50.9%
 MCM->is_core(Foo)     23562+-96/s       15005+-63%      103.66+-0.83%                --

                                  Rate MC->is_core(Benchmark) is_still_core(Benchmark) MCM->is_core(Benchmark)
 MC->is_core(Benchmark)   575.3+-1.3/s                     --                   -94.8%                  -97.4%
 is_still_core(Benchmark)  11053+-13/s             1821.3+-5%                       --                  -49.6%
 MCM->is_core(Benchmark)  21930+-130/s              3713+-24%               98.4+-1.2%                      --

                            Rate MC->is_core(CGI) is_still_core(CGI) MCM->is_core(CGI)
 MC->is_core(CGI)   680.4+-3.2/s               --             -93.9%            -96.9%
 is_still_core(CGI)  11098+-13/s     1531.1+-7.9%                 --            -49.1%
 MCM->is_core(CGI)   21818+-32/s        3107+-16%       96.59+-0.37%                --

                                             Rate list_still_core_modules(5.020002) list_core_modules(5.020002) list_still_core_modules(5.010001) list_core_modules(5.010001)
 list_still_core_modules(5.020002) 267.21+-0.69/s                                --                      -13.0%                            -18.6%                      -66.4%
 list_core_modules(5.020002)       307.07+-0.57/s                      14.92+-0.37%                          --                             -6.5%                      -61.4%
 list_still_core_modules(5.010001)  328.3+-0.53/s                      22.86+-0.37%                 6.91+-0.26%                                --                      -58.7%
 list_core_modules(5.010001)       795.53+-0.98/s                     197.71+-0.85%               159.07+-0.58%                     142.32+-0.49%                          --

=head1 SEE ALSO

L<Module::CoreList>

=head1 HOMEPAGE

Please visit the project's homepage at L<https://metacpan.org/release/Module-CoreList-More>.

=head1 SOURCE

Source repository is at L<https://github.com/perlancar/perl-Module-CoreList-More>.

=head1 BUGS

Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Module-CoreList-More>

When submitting a bug or request, please include a test-file or a
patch to an existing test-file that illustrates the bug or desired
feature.

=head1 AUTHOR

perlancar <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2016 by [e-mail].

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut