|
| 1 | +use strict; use warnings; |
| 2 | +package boolean; |
| 3 | +our $VERSION = '0.46'; |
| 4 | + |
| 5 | +my ($true, $false); |
| 6 | + |
| 7 | +use overload |
| 8 | + '""' => sub { ${$_[0]} }, |
| 9 | + '!' => sub { ${$_[0]} ? $false : $true }, |
| 10 | + fallback => 1; |
| 11 | + |
| 12 | +use base 'Exporter'; |
| 13 | +@boolean::EXPORT = qw(true false boolean); |
| 14 | +@boolean::EXPORT_OK = qw(isTrue isFalse isBoolean); |
| 15 | +%boolean::EXPORT_TAGS = ( |
| 16 | + all => [@boolean::EXPORT, @boolean::EXPORT_OK], |
| 17 | + test => [qw(isTrue isFalse isBoolean)], |
| 18 | +); |
| 19 | + |
| 20 | +sub import { |
| 21 | + my @options = grep $_ ne '-truth', @_; |
| 22 | + $_[0]->truth if @options != @_; |
| 23 | + @_ = @options; |
| 24 | + goto &Exporter::import; |
| 25 | +} |
| 26 | + |
| 27 | +my ($true_val, $false_val, $bool_vals); |
| 28 | + |
| 29 | +BEGIN { |
| 30 | + my $t = 1; |
| 31 | + my $f = 0; |
| 32 | + $true = do {bless \$t, 'boolean'}; |
| 33 | + $false = do {bless \$f, 'boolean'}; |
| 34 | + |
| 35 | + $true_val = overload::StrVal($true); |
| 36 | + $false_val = overload::StrVal($false); |
| 37 | + $bool_vals = {$true_val => 1, $false_val => 1}; |
| 38 | +} |
| 39 | + |
| 40 | +# refaddrs change on thread spawn, so CLONE fixes them up |
| 41 | +sub CLONE { |
| 42 | + $true_val = overload::StrVal($true); |
| 43 | + $false_val = overload::StrVal($false); |
| 44 | + $bool_vals = {$true_val => 1, $false_val => 1}; |
| 45 | +} |
| 46 | + |
| 47 | +sub true() { $true } |
| 48 | +sub false() { $false } |
| 49 | +sub boolean($) { |
| 50 | + die "Not enough arguments for boolean::boolean" if scalar(@_) == 0; |
| 51 | + die "Too many arguments for boolean::boolean" if scalar(@_) > 1; |
| 52 | + return not(defined $_[0]) ? false : |
| 53 | + "$_[0]" ? $true : $false; |
| 54 | +} |
| 55 | +sub isTrue($) { |
| 56 | + not(defined $_[0]) ? false : |
| 57 | + (overload::StrVal($_[0]) eq $true_val) ? true : false; |
| 58 | +} |
| 59 | +sub isFalse($) { |
| 60 | + not(defined $_[0]) ? false : |
| 61 | + (overload::StrVal($_[0]) eq $false_val) ? true : false; |
| 62 | +} |
| 63 | +sub isBoolean($) { |
| 64 | + not(defined $_[0]) ? false : |
| 65 | + (exists $bool_vals->{overload::StrVal($_[0])}) ? true : false; |
| 66 | +} |
| 67 | + |
| 68 | +sub truth { |
| 69 | + die "-truth not supported on Perl 5.22 or later" if $] >= 5.021005; |
| 70 | + # enable modifying true and false |
| 71 | + &Internals::SvREADONLY( \ !!0, 0); |
| 72 | + &Internals::SvREADONLY( \ !!1, 0); |
| 73 | + # turn perl internal booleans into blessed booleans: |
| 74 | + ${ \ !!0 } = $false; |
| 75 | + ${ \ !!1 } = $true; |
| 76 | + # make true and false read-only again |
| 77 | + &Internals::SvREADONLY( \ !!0, 1); |
| 78 | + &Internals::SvREADONLY( \ !!1, 1); |
| 79 | +} |
| 80 | + |
| 81 | +sub TO_JSON { ${$_[0]} ? \1 : \0 } |
| 82 | + |
| 83 | +1; |
0 commit comments