Perl Singleton Objects

Perl Singleton Objects.pl

use feature ":5.14";

use Scalar::Util qw{refaddr };

package BarSingleton;
my $this;

sub new {
    if ( !$this ) {
        $this = bless {}, shift;
    }
    return $this;
}

package foo;

use overload q{""} => sub {
    use Data::Dumper::Concise;
    return Dumper @_;
    },
    q{+} => sub {
    my ( $a1, $a2 ) = ( $_[0]->{number}, $_[1]->{number} );
    if ( looks_like_number( $a1 . '' ) and looks_like_number( $a2 . '' ) ) {
        return $a1 + $a2;
    }
    return;
    };

sub AUTOLOAD {
    $shellcommand = $AUTOLOAD;
    $shellcommand =~ s/^.*:://;
    given ($shellcommand) {
        when (/DESTROY/) {
            say " ............";
            return;
        }
        when (/looks_like_number/) {
            use Scalar::Util qw/looks_like_number/;
            looks_like_number(@_);
        }
        default {
            my $e;
            {
                local $@;
                eval { system("$shellcommand @_") };
                $e = $@ if $@;
            }
            die if $e;
        }
    }

}

sub new {
    $self   = shift;
    $class  = {};
    $number = shift;
    if ( looks_like_number($number) ) {
        $class->{number} = $number;
    }
    return bless $class, $self;
}
sub DESTROY {
  say "  bye ";
}

package main;
printf " %d  \n\n\n", foo->new(1) + foo->new(2);

printf " %s  \n", foo->new(4);

foo->dir("c:\\");
say " Shell Ok ";

if ( refaddr( BarSingleton->new ) eq refaddr( BarSingleton->new ) ) {
    say " Singleton OK ";
}