File Coverage

blib/lib/Constant/Export/Lazy.pm

Criterion	Covered	Total	%
statement	139	140	99.2
branch	68	68	100.0
condition	20	26	76.9
subroutine	19	20	95.0
pod			n/a
total	246	254	96.8

package Constant::Export::Lazy;
BEGIN {
  $Constant::Export::Lazy::AUTHORITY = 'cpan:AVAR';
}
{
  $Constant::Export::Lazy::VERSION = '0.16';
}
use 5.006;
use strict;
use warnings;
use warnings FATAL => "recursion";

our $_CALL_SHOULD_ALIAS_FROM_TO  = {};

sub import {
    my ($class, %args) = @_;
    my $caller = caller;

    # Are we wrapping an existing import subroutine?
    my $wrap_existing_import = (
        exists $args{options}
        ? exists $args{options}->{wrap_existing_import}
          ? $args{options}->{wrap_existing_import}
          : undef
        : undef
    );
    my $existing_import;
    my $caller_import_name = $caller . '::import';

    # Sanity check whether we do or don't have an existing 'import'
    # sub with the wrap_existing_import option. Note that we
    # intentionally do *not* use the more simple:
    #
    #    my $has_import_already = $caller->can("import") ? 1 : 0;
    #
    # The reason for this is that if someone imports the UNIVERSAL
    # package every package will have an import routine according to
    # ->can().
    my $has_import_already = do { no strict 'refs'; no warnings 'once'; *{$caller_import_name}{CODE} } ? 1 : 0;
    {
        if ($wrap_existing_import) {
            die "PANIC: We need an existing 'import' with the wrap_existing_import option" unless $has_import_already;
            $existing_import = \&{$caller_import_name};
        } else {
            die "PANIC: We're trying to clobber an existing 'import' subroutine without having the 'wrap_existing_import' option" if $has_import_already;
        }
    }

    # Munge the %args we're given so users can be lazy and give sub {
    # ... } as the value for the constants, but internally we support
    # them being a HashRef with options for each one. Allows us to be
    # lazy later by flattening this whole thing now.
    my $normalized_args = _normalize_arguments(%args);
    my $constants = $normalized_args->{constants};

    # This is a callback that can be used to munge the import list, to
    # e.g. provide a facility to provide import tags.
    my $buildargs = (
        exists $args{options}
        ? exists $args{options}->{buildargs}
          ? $args{options}->{buildargs}
          : undef
        : undef
    );

    no strict 'refs';
    no warnings 'redefine'; # In case of $wrap_existing_import
    *{$caller_import_name} = sub {
        use strict;
        use warnings;

        my (undef, @gimme) = @_;
        my $pkg_importer = caller;

        my $ctx = bless {
            constants    => $constants,
            pkg_importer => $pkg_importer,

            # Note that when unpacking @_ above we threw away the
            # package we're imported as from the user's perspective
            # and are using our "real" calling package for $pkg_stash
            # instead.
            #
            # This is because if we have a My::Constants package as
            # $caller but someone subclasses My::Constants for
            # whatever reason as say My::Constants::Subclass we don't
            # want to be sticking generated subroutines in both the
            # My::Constants and My::Constants::Subclass namespaces.
            #
            # This is because we want to guarantee that we only ever
            # call each generator subroutine once, even in the face of
            # subclassing. Maybe I should lift this restriction or
            # make it an option, e.g. if you want to have a constant
            # for "when I was compiled" it would be useful if
            # subclassing actually re-generated constants.
            pkg_stash => $caller,

            # If we're not wrapping an existing import subroutine we
            # don't need to bend over backwards to support constants
            # generated by e.g. constant.pm, we know we've made all
            # the constants in the package to our liking.
            wrap_existing_import => $wrap_existing_import,
        } => 'Constant::Export::Lazy::Ctx';

        # We've been provided with a callback to be used to munge
        # whatever we actually got provided with in @gimme to a list
        # of constants, or if $wrap_existing_import is enabled any
        # leftover non-$gimme names it's going to handle.
        if ($buildargs) {
            my @overriden_gimme = $buildargs->(\@gimme, $constants);
            die "PANIC: We only support subs that return zero or one values with buildargs, yours returns " . @overriden_gimme . " values"
                if @overriden_gimme > 1;
            @gimme = @{$overriden_gimme[0]} if @overriden_gimme;
        }

        # Just doing ->call() like you would when you're using the API
        # will fleshen the constant, do this for all the constants
        # we've been requested to export.
        my @leftover_gimme;
        for my $gimme (@gimme) {
            if (exists $constants->{$gimme}) {
                # We only want to alias constants into the importer's
                # package if the constant is on the import list, not
                # if it's just needed within some $ctx->call() when
                # defining another constant.
                #
                # To disambiguate these two cases we maintain a
                # globally dynamically scoped variable with the
                # constants that have been requested, and we note
                # who've they've been requested by.
                local $_CALL_SHOULD_ALIAS_FROM_TO->{$pkg_importer}->{$gimme} = undef;

                $ctx->call($gimme);
            } elsif ($wrap_existing_import) {
                # We won't even die on $wrap_existing_import if that
                # importer doesn't know about this $gimme, but
                # hopefully they're just about to die with an error
                # similar to ours if they don't know about the
                # requested constant.
                push @leftover_gimme => $gimme;
            } else {
                die "PANIC: We don't have the constant '$gimme' to export to you";
            }
        }

        if ($wrap_existing_import and @leftover_gimme) {
            # Because if we want to eliminate a stack frame *AND* only
            # dispatch to this for some things we have to partition
            # the import list into shit we can handle and shit we
            # can't. The list of things we're making the function
            # we're overriding handle is @leftover_gimme.
            @_ = ($caller, @leftover_gimme);
            goto &$existing_import;
        }

        return;
    };

    return;
}

sub _normalize_arguments {
    my (%args) = @_;

    my %default_options = %{ $args{options} || {} };
    my $constants = $args{constants};
    my %new_constants;
    for my $constant_name (keys %$constants) {
        my $value = $constants->{$constant_name};
        if (ref $value eq 'CODE') {
            $new_constants{$constant_name} = {
                call    => $value,
                options => \%default_options,
            };
        } elsif (ref $value eq 'HASH') {
            $new_constants{$constant_name} = {
                call    => $value->{call},
                options => {
                    %default_options,
                    %{ $value->{options} || {} },
                },
            };
        } else {
            die sprintf "PANIC: The constant <$constant_name> has some value type we don't know about (ref = %s)",
                ref $value || 'Undef';
        }
    }

    $args{constants} = \%new_constants;

    return \%args;
}

our $_GETTING_VALUE_FOR_OVERRIDE = {};

sub Constant::Export::Lazy::Ctx::call {
    my ($ctx, $gimme) = @_;

    # Unpack our options
    my $pkg_importer         = $ctx->{pkg_importer};
    my $pkg_stash            = $ctx->{pkg_stash};
    my $constants            = $ctx->{constants};
    my $wrap_existing_import = $ctx->{wrap_existing_import};

    # Unless we're wrapping an existing import ->call($gimme) should
    # always be called with a $gimme that we know about.
    unless (exists $constants->{$gimme}) {
        die "PANIC: You're trying to get the value of an unknown constant ($gimme), and wrap_existing_import isn't set" unless $wrap_existing_import;
    }

    my ($private_name, $glob_name, $alias_as);
    my $make_private_glob_and_alias_name = sub {
        # Checking "exists $constants->{$gimme}" here to avoid
        # autovivification would be redundant since we won't call this
        # if $wrap_existing_import is true, otherwise
        # $constants->{$gimme} is guaranteed to exist. See the
        # assertion just a few lines above this code.
        #
        # If $wrap_existing_import is true and we're handling a
        # constant we don't know about we'll have called the import()
        # we're wrapping, or we're being called from ->call(), in
        # which case we won't be calling this sub unless
        # $constants->{$gimme} exists.
        $private_name = exists $constants->{$gimme}->{options}->{private_name_munger}
                             ? $constants->{$gimme}->{options}->{private_name_munger}->($gimme)
                             : $gimme;
        $private_name = defined $private_name ? $private_name : $gimme;
        $glob_name = "${pkg_stash}::${private_name}";
        $alias_as  = "${pkg_importer}::${gimme}";
        return;
    };

    my $value;
    if ($wrap_existing_import and not exists $constants->{$gimme}) {
        # This is in case $ctx->call() is used on a constant defined
        # by constant.pm. See the giant comment about constant.pm
        # below.
        if (my $code = $pkg_stash->can($gimme)) {
            my @value = $code->();
            die "PANIC: We only support subs that return one value with wrap_existing_import, $gimme returns " . @value . " values" if @value > 1;
            $value = $value[0];
        } else {
            die "PANIC: We're trying to fallback to a constant we don't know about under wrap_existing_import, but $gimme has no symbol table entry";
        }
    } elsif (do {
        # Check if this is a constant we've defined already, in which
        # case we can just return its value.
        #
        # If we got this far we know we're going to want to call
        # $make_private_glob_and_alias_name->(). It'll also be used by
        # the "else" branch below if we end up having to define this
        # constant.
        $make_private_glob_and_alias_name->();

        $pkg_stash->can($private_name);
    }) {
        # This is for constants that *we've* previously defined, we'll
        # always use our own $private_name.
        $value = $pkg_stash->can($private_name)->();
    } else {
        my $override = $constants->{$gimme}->{options}->{override};
        my $stash    = $constants->{$gimme}->{options}->{stash};

        # Only pass the stash around if we actually have it. Note that
        # "delete local $ctx->{stash}" is a feature new in 5.12.0, so
        # we can't use it. See
        # http://perldoc.perl.org/5.12.0/perldelta.html#delete-local
        local $ctx->{stash} = $stash;
        delete $ctx->{stash} unless ref $stash;

        my @overriden_value;
        my $source;
        if ($override and
            not (exists $_GETTING_VALUE_FOR_OVERRIDE->{$pkg_importer} and
                 exists $_GETTING_VALUE_FOR_OVERRIDE->{$pkg_importer}->{$gimme})) {
            local $_GETTING_VALUE_FOR_OVERRIDE->{$pkg_importer}->{$gimme} = undef;
            @overriden_value = $override->($ctx, $gimme);
        }
        if (@overriden_value) {
            die "PANIC: We should only get one value returned from the override callback" if @overriden_value > 1;

            # This whole single value as an array business is so we
            # can distinguish between "return;" meaning "I don't want
            # to override this" and "return undef;" meaning "I want to
            # override this, to undef".
            $source = 'override';
            $value = $overriden_value[0];
        } else {
            $source = 'callback';
            $value = $constants->{$gimme}->{call}->($ctx);
        }

        unless (exists $_GETTING_VALUE_FOR_OVERRIDE->{$pkg_importer} and
                exists $_GETTING_VALUE_FOR_OVERRIDE->{$pkg_importer}->{$gimme}) {
            # Instead of doing `sub () { $value }` we could also
            # use the following trick that constant.pm uses if
            # it's true that `$] > 5.009002`:
            #
            #     Internals::SvREADONLY($value, 1);
            #     my $stash = \%{"$pkg_stash::"};
            #     $stash->{$gimme} = \$value;
            #
            # This would save some space for perl when producing
            # these inline constants. The reason I'm not doing
            # this is basically because it looks like evil
            # sorcery, and I don't want to go through the hassle
            # of efficiently and portibly invalidating the MRO
            # cache (see $flush_mro in constant.pm).
            #
            # Relevant commits in perl.git:
            #
            #  * perl-5.005_02-225-g779c5bc - first core support
            #    for these kinds of constants in the optree.
            #
            # * perl-5.9.2-1966-ge040ff7 - first use in constant.pm.
            #
            # * perl-5.9.2-1981-ge1234d8 - first attempts to
            #   invalidate the method cache with
            #   Internals::inc_sub_generation()
            #
            # * perl-5.9.4-1684-ge1a479c -
            #   Internals::inc_sub_generation() in constant.pm
            #   replaced with mro::method_changed_in($pkg)
            #
            # * perl-5.9.4-1714-g41892db - Now unused
            #   Internals::inc_sub_generation() removed from the
            #   core.
            #
            # * v5.10.0-3508-gf7fd265 (and v5.10.0-3523-g81a8de7)
            #   - MRO cache is changed to be flushed after all
            #   constants are defined.
            #
            # * v5.19.2-130-g94d5c17, v5.19.2-132-g6f1b3ab,
            #   v5.19.2-133-g15635cb, v5.19.2-134-gf815dc1 -
            #   Father Chrysostomos making various list constant
            #   changes, backed out in v5.19.2-204-gf99a5f0 due to
            #   perl #119045:
            #   https://rt.perl.org/rt3/Public/Bug/Display.html?id=119045
            #
            # So basically it looks like a huge can of worms that
            # I don't want to touch now. So just create constants
            # in the more portable and idiot-proof way instead so
            # I don't have to duplicate all the logic in
            # constant.pm
            {
                # Make the disabling of strict have as small as scope
                # as possible.
                no strict 'refs';

                # Future-proof against changes in perl that might not
                # optimize the constant sub if $value is used
                # elsewhere, we're passing it to the $after function
                # just below. See the "Is it time to separate pad
                # names from SVs?" thread on perl5-porters.
                my $value_copy = $value;
                *$glob_name = sub () { $value_copy };
            }

            # Maybe we have a callback that wants to know when we define
            # our constants, e.g. for printing something out, keeping taps
            # of what constants we have etc.
            if (my $after = $constants->{$gimme}->{options}->{after}) {
                # Future-proof so we can do something clever with the
                # return value in the future if we want.
                my @ret = $after->($ctx, $gimme, $value, $source);
                die "PANIC: Don't return anything from 'after' routines" if @ret;
            }
        }
    }

    # So? What's this entire evil magic about?
    #
    # Early on in the history of this module I decided that everything
    # that needed to call or define a constant would just go through
    # $ctx->call($gimme), including things called via the import().
    #
    # This makes some parts of this module much simpler, since we
    # don't have e.g. a $ctx->call_and_intern($gimme) to define
    # constants for the first time, v.s. a
    # $ctx->get_interned_value($gimme). We just have one
    # $ctx->call($gimme) that DWYM. You just request a value, it does
    # the right thing, and you don't have to worry about it.
    #
    # However, we have to worry about the following cases:
    #
    # * Someone in "user" imports YourExporter::CONSTANT, we define
    #   YourExporter::CONSTANT and alias user::CONSTANT to it. Easy,
    #   this is the common case.
    #
    # * Ditto, but YourExporter::CONSTANT needs to get the value of
    #   YourExporter::CONSTANT_NESTED to define its own value, we want
    #   to export YourExporter::CONSTANT to user::CONSTANT but *NOT*
    #   YourExporter::CONSTANT_NESTED. We don't want to leak dependent
    #   constants like that.
    #
    # * The "user" imports YourExporter::CONSTANT, this in turns needs
    #   to call Some::Module::function() and Some::Module::function()
    #   needs YourExporter::UNRELATED_CONSTANT
    #
    # * When we're in the "override" callback for
    #   YourExporter::CONSTANT we don't want to intern
    #   YourExporter::CONSTANT, but if we call some unrelated
    #   YourExporter::ANOTHER_CONSTANT while in the override we want
    #   to intern (but not export!) that value.
    #
    # So to do all this we're tracking on a per importer/constant pair
    # basis who requested what during import()-time, and whether we're
    # currently in the scope of an "override" for a given constant.
    if (not (exists $_GETTING_VALUE_FOR_OVERRIDE->{$pkg_importer} and
             exists $_GETTING_VALUE_FOR_OVERRIDE->{$pkg_importer}->{$gimme}) and
        exists $_CALL_SHOULD_ALIAS_FROM_TO->{$pkg_importer} and
        exists $_CALL_SHOULD_ALIAS_FROM_TO->{$pkg_importer}->{$gimme}) {
        no strict 'refs';
        # Alias e.g. user::CONSTANT to YourExporter::CONSTANT (well,
        # actually YourExporter::$private_name)
        *$alias_as = \&$glob_name;
    }

    return $value;
}

sub Constant::Export::Lazy::Ctx::stash {
    my ($ctx) = @_;

    # We used to die here when no $ctx->{stash} existed, but that
    # makes e.g. having a global "after" callback tedious. Just return
    # undef instead so we can do things like:
    #
    #    if (defined(my $stash = $ctx->stash)) { ... }
    #
    return $ctx->{stash};
}

1;

__END__