File Coverage

blib/lib/Lexical/Hints.pm

Criterion	Covered	Total	%
statement	63	66	95.4
branch	15	22	68.1
condition	13	18	72.2
subroutine	12	13	92.3
pod	1	2	50.0
total	104	121	85.9

package Lexical::Hints;

use 5.010; use warnings;

our $VERSION = '0.000005';

# Track phase...
my $compiling;
BEGIN { $compiling = 1 }
CHECK { $compiling = 0 }


# Track lexical hints for each namespace...
my %LEXICAL_HINTS_FOR;


sub import {
    my ($package, $opt_ref) = @_;
    my $set_hint = $opt_ref->{set_hint} // 'set_hint';
    my $get_hint = $opt_ref->{get_hint} // 'get_hint';

    # Install API...
    my $caller = caller;
    no strict 'refs';
    *{$caller.'::'.$set_hint} = _gen_set_hint($set_hint);
    *{$caller.'::'.$get_hint} = \&get_hint;
}

sub _gen_set_hint {
    my ($set_hint) = @_;

    return sub {
        my $key = shift;
        my $value = shift;
        my $opts_ref = _unpack_opts( shift );

        # Who is setting this hint???
        my $hint_owner = caller;

        # Lexical hints can only be autovivified at compile-time...
        if ($compiling) {
            # Allocate a unique number for the scope currently being compiled...
            my $scope_ID = scalar @{ $LEXICAL_HINTS_FOR{$hint_owner} //= [] };

            # Save that info in the lexical scope curently being compiled...
            $^H{$hint_owner.'->'.$key} = $scope_ID;

            # Save the corresponding value internally...
            push @{$LEXICAL_HINTS_FOR{$hint_owner}}, $value;
        }

        # Pre-existing hints can still be updated at run-time...
        elsif (defined(my $scope_ID = ((caller $opts_ref->{up}+1)[10]//{})->{$hint_owner.'->'.$key})) {
            # Update the corresponding value internally...
            $LEXICAL_HINTS_FOR{$hint_owner}[$scope_ID] = $value;
        }

        # But non-existing hints can't be created at run-time...
        else {
            $value = ref($value) || qq{"$value"};
            _croak(
                "Cannot autovivify hint '$key' at runtime for $hint_owner\n",
                "in call to $set_hint()",
            );
        }

        return;
    }
}

sub get_hint {
    my $key      = shift;
    my $opts_ref = _unpack_opts( shift );

    # Who is retrieving this hint???
    my $hint_owner = caller;

    # Query the caller's scope...
    my $hints_hash = $compiling ? \%^H : (caller $opts_ref->{up}+1)[10];

    # Recover the appropriate scope ID...
    my $scope_ID = $hints_hash->{$hint_owner.'->'.$key};

    # No such hint --> undef...
    return undef if !defined $scope_ID;

    # Otherwise, recover the appropriate value...
    return $LEXICAL_HINTS_FOR{$hint_owner}[$scope_ID];
}

sub dump {
    my $opts_ref = _unpack_opts( shift );

    # Obtain dump of data...
    require Data::Dumper;
    my $dump = Data::Dumper::Dumper($compiling ? \%^H : (caller $opts_ref->{up})[10] // {});

    $dump = substr($dump,8,-2);
    $dump =~ s{[ ]{8}}{}gxms;

    # Return dump in non-void contexts...
    return $dump if defined wantarray;

    # Report to STDERR in void contexts...
    print {*STDERR} $dump, "\n";
}

sub _croak { require Carp; Carp::croak(@_); }
sub _carp  { require Carp; Carp::carp(@_);  }

sub _unpack_opts {
    my $opts_ref = shift // {};

    # Is it a valid hash ref???
    my $type = ref($opts_ref);
    _croak('Invalid option: expected hash ref, but was passed '
          . ( $type ? lc($type) . ' ref instead' : 'a scalar instead')
    ) if $type ne 'HASH';

    # Copy arg and insert default value, if necessary...
    $opts_ref = { up => 0, %{$opts_ref} };

    # Watch for misunderstandings...
    if ($compiling && $opts_ref->{'up'}) {
        _carp("Useless compile-time 'up' option ignored");
    }

    # Are there invalid options???
    my @unknown_opts = grep {$_ ne 'up'} keys %{$opts_ref};
    _croak('Unknown option'.(@unknown_opts==1?q{}:q{s}).": @unknown_opts")
        if @unknown_opts;

    # By this point, the options hash is cleansed...
    return $opts_ref;
}


1; # Magic true value required at end of module
__END__