RE: type checks

Interesting.  I’d not used “B” before, so doing a little reading on that was fun, plus seeing how you had used it.

Question: why did you have “is_ok” return 2 and 3, rather than just 1?  Obvs doesn’t hurt, but I ask in case I’ve missed something subtle.

Cheers,

Claude.


From: sisyphus <[email protected]>
Sent: Saturday, June 3, 2023 2:11 PM
To: [email protected]
Cc: [email protected]
Subject: Re: type checks

Just for fun, I've written the following which is essentially the way that I would go about meeting the OP's requirements (as I understand them).
It's a file that needs to be named NumOnly.pm and, to be usable, it needs to be in a location where it is found - eg in the "Math" folder of one of the directories listed in perl's @INC.

Have a play with it if you're interested - and I'll answer questions as best I can, as they arise.
It hasn't been rigorously tested, and may require further modification.
I've overloaded only +, -, *, /, <=>, and "" operations.
Other overloaded operations can easily be added. See 'perldoc overload' for a full list of overloadable operations.
Note that there's a very basic demo at the bottom of the file that's intended as a starter.

##############################################################
package Math::NumOnly;
use strict;
use warnings;
use B;

use overload
'+'    => \&oload_add,
'-'    => \&oload_sub,
'*'    => \&oload_mul,
'/'    => \&oload_div,
'<=>'   => \&oload_spaceship,
'""'   => \&oload_stringify,
;

sub new {
  shift if(!ref($_[0]) && $_[0] eq "Math::NumOnly"); # 'new' has been called as a method

  my $ok = is_ok($_[0]);
  die "Bad argument (or no argument) given to new" unless $ok;

  if($ok == 1) {
    # return a copy of the given Math::NumOnly object
    my $ret = shift;
    return $ret;
  }

  # given arg must be a valid IV or NV
  my %h = ('val' => shift);
  return bless(\%h, 'Math::NumOnly');
}

  my %flags;
  {
    no strict 'refs';
    for my $flag (qw(
      SVf_IOK
      SVf_NOK
      SVf_POK
              )) {
      if (defined &{'B::'.$flag}) {
       $flags{$flag} = &{'B::'.$flag};
      }
    }
  }

sub oload_add {
  die "Wrong number of arguments given to oload_add()"
    if @_ > 3;

  my $ok = is_ok($_[1]); # check that 2nd arg is suitable.
  die "Bad argument given to oload_add" unless $ok;

  if($ok == 1) {
    return Math::NumOnly->new($_[0]->{val} + $_[1]->{val});
  }

  return Math::NumOnly->new($_[0]->{val} + $_[1]);
}

sub oload_mul {
  die "Wrong number of arguments given to oload_mul()"
    if @_ > 3;

  my $ok = is_ok($_[1]); # check that 2nd arg is suitable.
  die "Bad argument given to oload_mul" unless $ok;

  if($ok == 1) {
    return Math::NumOnly->new($_[0]->{val} * $_[1]->{val});
  }

  return Math::NumOnly->new($_[0]->{val} * $_[1]);
}

sub oload_sub {
  die "Wrong number of arguments given to oload_sub()"
    if @_ > 3;

  my $ok = is_ok($_[1]); # check that 2nd arg is suitable.
  die "Bad argument given to oload_sub" unless $ok;

  my $third_arg = $_[2];

  if($ok == 1) {
    if($third_arg) {
      return Math::NumOnly->new($_[1]->{val} - $_[0]->{val});
    }
    return Math::NumOnly->new($_[0]->{val} - $_[1]->{val});
  }

  if($third_arg) {
    return Math::NumOnly->new($_[1] - $_[0]->{val});
  }
  return Math::NumOnly->new($_[0]->{val} - $_[1]);
}

sub oload_div {
  die "Wrong number of arguments given to oload_div()"
    if @_ > 3;

  my $ok = is_ok($_[1]); # check that 2nd arg is suitable.
  die "Bad argument given to oload_div" unless $ok;

  my $third_arg = $_[2];

  if($ok == 1) {
    if($third_arg) {
      return Math::NumOnly->new($_[1]->{val} / $_[0]->{val});
    }
    return Math::NumOnly->new($_[0]->{val} / $_[1]->{val});
  }

  if($third_arg) {
    return Math::NumOnly->new($_[1] / $_[0]->{val});
  }
  return Math::NumOnly->new($_[0]->{val} / $_[1]);
}

sub oload_stringify {
  my $self = shift;
  return $self->{val};
}

sub oload_spaceship {
  die "Wrong number of arguments given to oload_spaceship()"
    if @_ > 3;

  my $ok = is_ok($_[1]); # check that 2nd arg is suitable.
  die "Bad argument given to oload_spaceship" unless $ok;

  my $third_arg = $_[2];

  if($ok == 1) {
    if($third_arg) {
      return Math::NumOnly->new($_[1]->{val} <=> $_[0]->{val});
    }
    return Math::NumOnly->new($_[0]->{val} <=> $_[1]->{val});
  }

  if($third_arg) {
    return Math::NumOnly->new($_[1] <=> $_[0]->{val});
  }
  return Math::NumOnly->new($_[0]->{val} <=> $_[1]);
}


sub is_ok {
  return 0 unless defined $_[0];
  return 1 if ref($_[0]) =~ /Math::NumOnly/;
  my $flags = flags($_[0]);
  return 0 if $flags =~ /SVf_POK/;
  return 2 if $flags =~ /SVf_IOK/;
  return 3 if $flags =~ /SVf_NOK/;
  return 0;
}

sub flags {
  my $flags = B::svref_2object(\($_[0]))->FLAGS;
  join ' ', sort grep $flags & $flags{$_}, keys %flags;
}

1;

__END__

## Demo:

use strict;
use warnings;
use Math::NumOnly;

my $op = Math::NumOnly->new(123); # Won't accept anything that's not either
                                  # a number or another Math::NumOnly object.
#$op += '29';                     # Would be a fatal error
$op += 29;                        # $op is now 152
print $op, "\n";
$op += Math::NumOnly->new(38);    # $op is now 190
print $op, "\n";
$op /= 6;                         # $op is now 31.666...67
print $op, "\n";
my $op2 = 6 * $op;                # $op2 is 190
print $op2, "\n";
print $op <=> $op, "\n";          # prints 0
print $op <=> $op2, "\n";         # prints -1
print $op2 <=> $op, "\n";         # prints  1
##############################################################

Cheers,
Rob