File Coverage

blib/lib/Devel/Deprecations/Environmental.pm

Criterion	Covered	Total	%
statement	59	62	95.1
branch	27	30	90.0
condition	16	16	100.0
subroutine	9	9	100.0
pod			n/a
total	111	117	94.8

package Devel::Deprecations::Environmental;

use strict;
use warnings;

use Devel::Deprecations::Environmental::MicroDateTime;
use Module::Load ();
use Scalar::Util qw(blessed);

our $VERSION = '1.100';

=head1 NAME

Devel::Deprecations::Environmental - deprecations for your code's surroundings

=head1 DESCRIPTION

A framework for managing deprecations of the environment in which your code runs

=head1 SYNOPSIS

This will load the Devel::Deprecations::Environmental::Plugin::Int32 plugin and emit a
warning if running on a 32 bit system:

    use Devel::Deprecations::Environmental qw(Int32);

This will start warning about an impending deprecation on the 1st of February
2023, upgrade that to a warning about being unsupported on the 1st of February
2024, and upgrade that to a fatal error on the 1st of February 2025:

    use Devel::Deprecations::Environmental
        Int32 => {
            warn_from        => '2023-02-01',
            unsupported_from => '2024-02-01',
            fatal_from       => '2025-02-01',
        };

This will always warn about 32 bit perl or a really old perl:

    use Devel::Deprecations::Environmental
        OldPerl => { older_than => '5.14.0', },
        'Int32';

=head1 INCOMPATIBLE CHANGES

Version 1.000 used L for parsing times provided as
strings. This was removed in 1.100 as it had an unreasonable number of
dependencies. As a result we now only support a subset of ISO 8601 formats,
namely the sensible ones:

=over

=item YYYY-MM-DD

=item YYYY-MM-DD HH:MM:SS

=item YYYY-MM-DDTHH:MM:SS

=back

You can still pass in a DateTime object if you wish, and so can use
DateTime::Format::ISO8601 yourself to construct them from some crazy
involving week numbers if you really want.

=head1 DEPRECATION ARGUMENTS

Each deprecation has a name, which can be optionally followed by a hash-ref of
arguments. All deprecations automatically support:

=over

=item warn_from

The time at which to start emitting warnings about an impending deprecation.
Defaults to the moment of creation, C<'1970-01-01'> (in general the accepted
date format is YYYY-MM-DD followed by an optional space or letter T and
HH:MM:SS). You can also provide this as a L object.

This must be before any of C or C which are
specified.

=item unsupported_from

The time at which to start warning harder, when something is no longer
supported. Defaults to C, meaning "don't do this".

This must be before C if that is specified.

=item fatal_from

The time after which the code should just C. Defaults to C,
meaning "don't do this".

=back

Of those three only the most severe will be emitted.

Arguments with names beginning with an underscore are reserved for internal
use. Plugins can support any other arguments they wish.

=head1 CONTENT OF WARNINGS / FATAL ERRORS

The pseudo-variables C<$date>, C<$filename>, C<$line>, and C<$reason> will be
interpolated.

C<$date> will be C or C (using
whichever is earlier) if one of those is configured.

C<$filename> and C<$line> will tell you the file and line on which
C is loaded.

C<$reason> is defined in the plugin's C method.

=head2 Initial warning

C

=head2 "Unsupported" warning

C

=head2 Fatal error

C

=cut

sub import {
    my $class = shift;
    my @args = @_;
    if($class eq __PACKAGE__) {
        # when loading Devel::Deprecations::Environmental itself ...
        while(@args) {
            my $plugin = 'Devel::Deprecations::Environmental::Plugin::'.shift(@args);
            my $plugin_args = ref($args[0]) ? shift(@args) : {};
            $plugin_args->{_source} = {
                filename => (caller(0))[1],
                line     => (caller(0))[2]
            };

            Module::Load::load($plugin);
            my @errors = ();
            push @errors, "doesn't inherit from ".__PACKAGE__
                unless($plugin->isa(__PACKAGE__));
            push @errors, "doesn't implement 'reason()'"
                unless($plugin->can('reason'));
            push @errors, "doesn't implement 'is_deprecated()'"
                unless($plugin->can('is_deprecated'));
            die(join("\n",
                __PACKAGE__.": plugin $plugin doesn't implement all it needs to",
                map { "  $_" } @errors
            )."\n")
                if(@errors);
            $plugin->import($plugin_args);
        }
    } else {
        # when called on a subclass ...
        my $args = $args[0];
        $args->{warn_from} ||= '1970-01-01';
        my %_froms = (
            map {
                $_ => blessed($args->{$_})
                    ? $args->{$_}
                    : Devel::Deprecations::Environmental::MicroDateTime->parse_datetime($args->{$_})
            } grep {
                exists($args->{$_})
            } qw(warn_from unsupported_from fatal_from)
        );
        delete($args->{$_}) foreach(qw(warn_from unsupported_from fatal_from));

        my $now = Devel::Deprecations::Environmental::MicroDateTime->now();

        # if any param is a DateTime we need to upgrade all of them so comparisons work
        if(
            grep { blessed($_) eq 'DateTime' }
            map { $_froms{$_} }
            grep { exists($_froms{$_}) }
            qw(fatal_from unsupported_from warn_from)
        ) {
            $now = DateTime->from_epoch(epoch => $now->epoch());
            $_froms{$_} = DateTime->from_epoch(epoch => $_froms{$_}->epoch())
                foreach(grep { exists($_froms{$_}) && blessed($_froms{$_}) ne 'DateTime' } qw(fatal_from unsupported_from warn_from));
        }

        # check that warn/unsupported/fatal are ordered correctly in time
        foreach my $pair (
            [qw(warn_from        unsupported_from)],
            [qw(warn_from        fatal_from)],
            [qw(unsupported_from fatal_from)],
        ) {
            if(
                exists($_froms{$pair->[0]}) && exists($_froms{$pair->[1]}) &&
                !($_froms{$pair->[0]} < $_froms{$pair->[1]})
            ) {
                die(sprintf("%s: %s must be before %s\n", __PACKAGE__, @{$pair}));
            }
        }

        if($class->is_deprecated($args)) {
            my $reason = $class->reason($args);

            if($_froms{fatal_from} && $_froms{fatal_from} < $now) {
                die(_fatal_msg(
                    %{$args->{_source}},
                    reason => $reason
                ));
            } elsif($_froms{unsupported_from} && $_froms{unsupported_from} < $now) {
                warn(_unsupported_msg(
                    %{$args->{_source}},
                    reason => $reason
                ));
            } elsif($_froms{warn_from} < $now) { # warn_from always exists!
                warn(_warn_msg(
                    %{$args->{_source}},
                    reason => $reason,
                    date   => (
                        sort { $a <=> $b }
                        map  { $_froms{$_} }
                        grep { $_froms{$_} }
                        qw(unsupported_from fatal_from)
                    )[0] || undef
                ));
            }
        }
    }
}

sub _fatal_msg {
    my %args = @_;
    return "Unsupported! In $args{filename} on line $args{line}: $args{reason}\n";
}

sub _unsupported_msg { return _fatal_msg(@_); }

sub _warn_msg {
    my %args = @_;
    return "Deprecation warning! ".
           ($args{date} ? 'From '.$args{date}->iso8601().': ' : '').
           "In $args{filename} on line $args{line}: $args{reason}\n";
}

=head1 FUNCTIONS

There are no public functions or methods, everything is done when the
module is loaded (specifically, when its C method is called)
with all specific deprecations handled by plugins.

=head1 WRITING YOUR OWN PLUGINS

The C namespace is yours to play in, except
for the C namespace.

A plugin should inherit from C, and implement the following
methods, which will be called as class methods. Failure to define either of
them will result in fatal errors. They will be passed the arguments hash-ref
(with C, C, and C removed):

=over

=item reason

Returns a brief string explaining the deprecation. For example "32 bit
integers" or "Perl too old".

=item is_deprecated

This should return true or false for whether the environment matches the
deprecation or not.

=back

=head1 FEEDBACK

I welcome feedback about my code, including constructive criticism, bug
reports, documentation improvements, and feature requests. The best bug reports
include files that I can add to the test suite, which fail with the current
code in my git repo and will pass once I've fixed the bug

Feature requests are far more likely to get implemented if you submit a patch
yourself, preferably with tests.

=head1 SOURCE CODE REPOSITORY

L

=head1 SEE ALSO

L - for deprecating parts of your own code as opposed
to parts of the environment your code is running in;

=head1 AUTHOR, LICENCE and COPYRIGHT

Copyright 2023 David Cantrell EFE

This software is free-as-in-speech software, and may be used, distributed, and
modified under the terms of either the GNU General Public Licence version 2 or
the Artistic Licence. It's up to you which one you use. The full text of the
licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively.

=head1 CONSPIRACY

This module is also free-as-in-mason software.

=cut

1;