##---------------------------------------------------------------------------- ## Module Generic - ~/lib/Module/Generic/Boolean.pm ## Version v1.1.1 ## Copyright(c) 2022 DEGUEST Pte. Ltd. ## Author: Jacques Deguest <jack@deguest.jp> ## Created 2021/03/20 ## Modified 2022/08/05 ## All rights reserved ## ## This program is free software; you can redistribute it and/or modify it ## under the same terms as Perl itself. ##---------------------------------------------------------------------------- package Module::Generic::Boolean; BEGIN { use common::sense; use vars qw( $true $false ); use overload "0+" => sub{ ${$_[0]} }, "++" => sub{ $_[0] = ${$_[0]} + 1 }, "--" => sub{ $_[0] = ${$_[0]} - 1 }, fallback => 1; $true = do{ bless( \( my $dummy = 1 ) => 'Module::Generic::Boolean' ) }; $false = do{ bless( \( my $dummy = 0 ) => 'Module::Generic::Boolean' ) }; our( $VERSION ) = 'v1.1.1'; }; use strict; # require Module::Generic::Array; # require Module::Generic::Number; # require Module::Generic::Scalar; sub new { return( $_[1] ? $true : $false ); } # sub as_array { return( Module::Generic::Array->new( [ ${$_[0]} ] ) ); } sub as_array { require Module::Generic::Array; return( Module::Generic::Array->new( [ ${$_[0]} ] ) ); } # sub as_number { return( Module::Generic::Number->new( ${$_[0]} ) ); } sub as_number { require Module::Generic::Number; return( Module::Generic::Number->new( ${$_[0]} ) ); } # sub as_scalar { return( Module::Generic::Scalar->new( ${$_[0]} ) ); } sub as_scalar { require Module::Generic::Scalar; return( Module::Generic::Scalar->new( ${$_[0]} ) ); } sub defined { return(1); } sub true () { $true } sub false () { $false } sub is_bool ($) { UNIVERSAL::isa( $_[0], 'Module::Generic::Boolean' ) } sub is_true ($) { $_[0] && UNIVERSAL::isa( $_[0], 'Module::Generic::Boolean' ) } sub is_false ($) { !$_[0] && UNIVERSAL::isa( $_[0], 'Module::Generic::Boolean' ) } sub FREEZE { my $self = CORE::shift( @_ ); my $serialiser = CORE::shift( @_ ) // ''; my $class = CORE::ref( $self ); # Return an array reference rather than a list so this works with Sereal and CBOR # On or before Sereal version 4.023, Sereal did not support multiple values returned CORE::return( [$class, $$self] ) if( $serialiser eq 'Sereal' && Sereal::Encoder->VERSION <= version->parse( '4.023' ) ); # But Storable want a list with the first element being the serialised element CORE::return( $$self ); } sub STORABLE_freeze { CORE::return( CORE::shift->FREEZE( @_ ) ); } sub STORABLE_thaw { CORE::return( CORE::shift->THAW( @_ ) ); } # NOTE: CBOR will call the THAW method with the stored classname as first argument, the constant string CBOR as second argument, and all values returned by FREEZE as remaining arguments. # NOTE: Storable calls it with a blessed object it created followed with $cloning and any other arguments initially provided by STORABLE_freeze sub THAW { my( $self, undef, @args ) = @_; my( $class, $str ); if( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) { ( $class, $str ) = @{$args[0]}; } else { $class = CORE::ref( $self ) || $self; $str = CORE::shift( @args ); } # Storable pattern requires to modify the object it created rather than returning a new one if( CORE::ref( $self ) ) { $$self = $str; CORE::return( $self ); } else { CORE::return( $class->new( $str ) ); } } sub TO_JSON { # JSON does not check that the value is a proper true or false. It stupidly assumes this is a string # The only way to make it understand is to return a scalar ref of 1 or 0 # return( $_[0] ? 'true' : 'false' ); return( $_[0] ? \1 : \0 ); } 1; __END__