Dogcows Code - chaz/p5-Return-Type-Lexical/blob - lib/Return/Type/Lexical.pm

   1 package Return::Type::Lexical;
   2 # ABSTRACT: Same thing as Return::Type, but lexical
   3
   4 use 5.008;
   5 use warnings;
   6 use strict;
   7
   8 use parent 'Return::Type';
   9
  10 our $VERSION = '0.002'; # VERSION
  11
  12 sub import {
  13     my ($class, %args) = @_;
  14     $^H{'Return::Type::Lexical/in_effect'} = exists $args{check} && !$args{check} ? 0 : 1;
  15 }
  16
  17 sub unimport {
  18     $^H{'Return::Type::Lexical/in_effect'} = 0;
  19 }
  20
  21 sub _in_effect {
  22     my ($level) = @_;
  23     $level = 0 if !defined $level;
  24     my $hinthash = (caller($level))[10];
  25     my $in_effect = $hinthash->{'Return::Type::Lexical/in_effect'};
  26     return !defined $in_effect || $in_effect;
  27 }
  28
  29 # XXX This is kind of janky. It relies upon Return::Type using Attribute::Handlers, and it assumes
  30 # some internal Attribute::Handlers behavior. If it proves to be too fragile, we may need to copy
  31 # the Return::Type code to here. Or make Return::Type lexical if that can be done without breaking
  32 # backward-compatibility.
  33 my $handler;
  34 BEGIN {
  35     $handler = $UNIVERSAL::{ReturnType};
  36     delete $UNIVERSAL::{ReturnType};
  37     delete $UNIVERSAL::{_ATTR_CODE_ReturnType};
  38 }
  39 sub UNIVERSAL::ReturnType :ATTR(CODE,BEGIN) {
  40     my $in_effect = _in_effect(4);
  41     return if !$in_effect;
  42
  43     return $handler->(@_);
  44 }
  45
  46 1;
  47
  48 __END__
  49
  50 =pod
  51
  52 =encoding UTF-8
  53
  54 =head1 NAME
  55
  56 Return::Type::Lexical - Same thing as Return::Type, but lexical
  57
  58 =head1 VERSION
  59
  60 version 0.002
  61
  62 =head1 SYNOPSIS
  63
  64     use Return::Type::Lexical;
  65     use Types::Standard qw(Int);
  66
  67     sub foo :ReturnType(Int) { return "not an int" }
  68
  69     {
  70         no Return::Type::Lexical;
  71         sub bar :ReturnType(Int) { return "not an int" }
  72     }
  73
  74     my $foo = foo();    # throws an error
  75     my $bar = bar();    # returns "not an int"
  76
  77     # Can also be used with Devel::StrictMode to only perform
  78     # type checks in strict mode:
  79
  80     use Devel::StrictMode;
  81     use Return::Type::Lexical check => STRICT;
  82
  83 =head1 DESCRIPTION
  84
  85 This module works just like L<Return::Type>, but type-checking can be enabled and disabled within
  86 lexical scopes.
  87
  88 There is no runtime penalty when type-checking is disabled.
  89
  90 =head1 METHODS
  91
  92 =head2 import
  93
  94 The C<check> attribute can be used to set whether or not types are checked.
  95
  96 =head1 BUGS
  97
  98 Please report any bugs or feature requests on the bugtracker website
  99 L<https://github.com/chazmcgarvey/Return-Type-Lexical/issues>
 100
 101 When submitting a bug or request, please include a test-file or a
 102 patch to an existing test-file that illustrates the bug or desired
 103 feature.
 104
 105 =head1 AUTHOR
 106
 107 Charles McGarvey <chazmcgarvey@brokenzipper.com>
 108
 109 =head1 COPYRIGHT AND LICENSE
 110
 111 This software is copyright (c) 2020 by Charles McGarvey.
 112
 113 This is free software; you can redistribute it and/or modify it under
 114 the same terms as the Perl 5 programming language system itself.
 115
 116 =cut