File Coverage

blib/lib/Scalar/Properties.pm

Criterion	Covered	Total	%
statement	160	175	91.4
branch	41	70	58.5
condition	12	14	85.7
subroutine	57	62	91.9
pod	54	54	100.0
total	324	375	86.4

use 5.008;
use strict;
use warnings;

package Scalar::Properties;
our $VERSION = '1.100860';
# ABSTRACT: Run-time properties on scalar variables
use overload
  q{""} => \&value,
  bool  => \&is_true,
  '+'   => \&plus,
  '-'   => \&minus,
  '*'   => \×,
  '/'   => \÷,
  '%'   => \&modulo,
  '**'  => \&exp,
  '<=>' => \&numcmp,
  'cmp' => \&cmp,

  # the following would be autogenerated from 'cmp', but
  # we want to make the methods available explicitly, along
  # with case-insensitive versions
  'eq' => \&eq,
  'ne' => \&ne,
  'lt' => \<,
  'gt' => \>,
  'le' => \&le,
  'ge' => \≥

sub import {
    my $pkg  = shift;
    my @defs = qw/integer float binary q qr/;
    my @req;
    @_ = ':all' unless @_;
    for my $key (@_) {
        if ($key eq ':all') {
            @req = @defs;
        } else {
            die __PACKAGE__ . " does not export '$key'"
              unless grep /^$key$/ => @defs;
            push @req => $key;
        }
    }
    overload::constant map { $_ => \&handle } @req;

    # also manually export some routines
    my $callpkg = caller(1);
    no strict 'refs';
    *{"$callpkg\::$_"} = \&{"$pkg\::$_"} for qw/pass_on passed_on get_pass_on/;
}

# object's hash keys that aren't properties (apart from those starting with
# and underscore, which are private anyway)
our %NON_PROPS = map { $_ => 1 } our @NON_PROPS = qw/true/;

# property propagation
sub pass_on {
    our %PASS_ON = map { $_ => 1 } our @PASS_ON = @_;
}
sub passed_on { our %PASS_ON; exists $PASS_ON{ +shift } }
sub get_pass_on { our @PASS_ON }

sub get_props {

    # get a list of the value's properties
    my $self = shift;
    our %NON_PROPS;
    return grep { !(/^_/ || exists $NON_PROPS{$_}) } keys %$self;
}

sub del_prop {

    # delete one or more properties
    my $self = shift;
    our %NON_PROPS;
    for my $prop (@_) {
        die "$prop is private, not a property"
          if substr($prop, 0, 1) eq '_';
        die "$prop cannot be deleted" if exists $NON_PROPS{$prop};
        delete $self->{$prop};
    }
}

sub del_all_props {
    my $self  = shift;
    my @props = $self->get_props;
    delete $self->{$_} for @props;
}

sub handle {

    # create a new overloaded object
    my ($orig, $interp, $context, $sub, @prop) = @_;
    my $self = bless {
        _value   => $orig,
        _interp  => $interp,
        _context => $context,
        true     => ($orig) ? 1 : 0,
      },
      __PACKAGE__;

    # propagate properties marked as such via pass_on from
    # participating overloaded values passed in @prop
    for my $val (grep { ref $_ eq __PACKAGE__ } @prop) {
        for my $prop ($val->get_props) {
            $self->{$prop} = $val->{$prop} if passed_on($prop);
        }
    }
    return $self;
}

sub create {

    # take a value and a list of participating values and create
    # a new object from them by filling in the gaps that handle()
    # expects with defaults. As seen from handle(), the participating
    # values (i.e., the values that the first arg was derived from)
    # are passed so that properties can be properly propagated
    my ($val, @props) = @_;
    handle($val, $val, '', sub { }, @props);
}

# call this as a sub, not a method as it also takes unblessed scalars
# anything not of this package is stringified to give any potential
# other overloading a chance to get at it's actual value
sub value {

    # my $v = ref $_[0] eq __PACKAGE__ ? $_[0]->{_value} : "$_[0]";
    # $v =~ s/\\n/\n/gs;  # no idea why newlines become literal '\n'
    my $v = ref $_[0] eq __PACKAGE__ ? $_[0]->{_interp} : "$_[0]";
    return $v;
}

# ==================== Generated methods ====================
# Generate some string, numeric and boolean methods
sub gen_meth {
    my $template = shift;
    while (my ($name, $op) = splice(@_, 0, 2)) {
        (my $code = $template) =~ s/NAME/$name/g;
        $code =~ s/OP/$op/g;
        eval $code;
        die "Internal error: $@" if $@;
    }
}
my $binop = 'sub NAME {
    my($n, $m) = @_[0,1];
    ($m, $n) = ($n, $m) if($_[2]);
    create(value($n) OP value($m), $n, $m)
}';
gen_meth $binop, qw!
  plus     +
  minus    -
  times    *
  divide   /
  modulo   %
  exp      **
  numcmp   <=>
  cmp      cmp
  eq       eq
  ne       ne
  lt       lt
  gt       gt
  le       le
  ge       ge
  concat   .
  append   .
  !;

# needs 'CORE::lc', otherwise 'Ambiguous call resolved as CORE::lc()'
my $bool_i = 'sub NAME {
    create( CORE::lc(value($_[0])) OP CORE::lc(value($_[1])), @_[0,1] )
}';
gen_meth $bool_i, qw!
  eqi      eq
  nei      ne
  lti      lt
  gti      gt
  lei      le
  gei      ge
  !;
my $func = 'sub NAME {
    create(OP(value($_[0])), $_[0])
}';
gen_meth $func, qw!
  abs      abs
  length   CORE::length
  size     CORE::length
  uc       uc
  ucfirst  ucfirst
  lc       lc
  lcfirst  lcfirst
  hex      hex
  oct      oct
  !;

# ==================== Miscellaneous Numeric methods ====================
sub zero { create($_[0] == 0, $_[0]) }

# ==================== Miscellaneous Boolean methods ====================
sub is_true  { $_[0]->{true} }
sub is_false { !$_[0]->{true} }

sub true {
    my $self = shift;
    $self->{true} = @_ ? shift : 1;
    return $self;
}
sub false { $_[0]->true(0) }

# ==================== Miscellaneous String methods ====================
sub reverse { create(scalar reverse(value($_[0])), $_[0]) }
sub swapcase { my $s = shift; $s =~ y/A-Za-z/a-zA-Z/; return create($s) }

# $foo->split(/PATTERN/, LIMIT)
sub split {
    my ($orig, $pat, $limit) = @_;
    $limit ||= 0;
    $pat = qr/\s+/ unless ref($pat) eq 'Regexp';

    # The following should work:
    #   map { create($_, $orig) } split $pat => value($orig), $limit;
    # But there seems to be a bug in split
    # (cf. p5p: 'Bug report: split splits on wrong pattern')
    my @el;
    eval '@el = split $pat => value($orig), $limit;';
    die $@ if $@;
    return map { create($_, $orig) } @el;
}

# ==================== Code-execution methods ====================
sub times_do {
    my ($self, $sub) = @_;
    die 'times_do() method expected a coderef' unless ref $sub eq 'CODE';
    for my $i (1 .. $self) {
        $sub->($i);
    }
}

sub do_upto_step {
    my ($self, $limit, $step, $sub) = @_;
    die 'expected last arg to be a coderef'
      unless ref $sub eq 'CODE';

    # for my $i ($self..$limit) { $sub->($i); }
    my $i = $self;
    while ($i <= $limit) {
        $sub->($i);
        $i += $step;
    }
}

sub do_downto_step {
    my ($self, $limit, $step, $sub) = @_;
    die 'expected last arg to be a coderef'
      unless ref $sub eq 'CODE';
    my $i = $self;
    while ($i >= $limit) {
        $sub->($i);
        $i -= $step;
    }
}
sub do_upto { do_upto_step($_[0], $_[1], 1, $_[2]) }
sub do_downto { do_downto_step($_[0], $_[1], 1, $_[2]) }

sub AUTOLOAD {
    my $self = shift;
    (my $prop = our $AUTOLOAD) =~ s/.*:://;
    return if $prop eq 'DESTROY' || substr($prop, 0, 1) eq '_';

    # $x->is_foo or $x->has_foo will return true if 'foo' is
    # a hash key with a true value
    return defined $self->{ substr($prop, 4) }
      && $self->{ substr($prop, 4) }
      if substr($prop, 0, 4) eq 'has_';
    return defined $self->{ substr($prop, 3) }
      && $self->{ substr($prop, 3) }
      if substr($prop, 0, 3) eq 'is_';
    if (@_) {
        $self->{$prop} = shift;
        return $self;
    }
    return $self->{$prop};
}
1;


__END__