Beta Shell v2.0

File Manager

Name	Size	Perms	Modified	Actions
[ .. / .. ]
Properties.pm	16.1 KB	-rw-r--r--	2010-03-27 15:06:10	Edit Del
Editing: Properties.pm (16.1 KB)

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,
  '*'   => \&times,
  '/'   => \&divide,
  '%'   => \&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' => \&lt,
  'gt' => \&gt,
  'le' => \&le,
  'ge' => \&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__
=pod

=for stopwords abs eqi gei gti lei lti oct swapcase

=head1 NAME

Scalar::Properties - Run-time properties on scalar variables

=head1 VERSION

version 1.100860

=head1 SYNOPSIS

  use Scalar::Properties;
  my $val = 0->true;
    if ($val && $val == 0) {
    print "yup, its true alright...\n";
  }

  my @text = (
    'hello world'->greeting(1),
    'forget it',
    'hi there'->greeting(1),
  );
  print grep { $_->is_greeting } @text;

  my $l =  'hello world'->length;

=head1 DESCRIPTION

Scalar::Properties attempts to make Perl more object-oriented by
taking an idea from Ruby: Everything you manipulate is an object,
and the results of those manipulations are objects themselves.

  'hello world'->length
  (-1234)->abs
  "oh my god, it's full of properties"->index('g')

The first example asks a string to calculate its length. The second
example asks a number to calculate its absolute value. And the
third example asks a string to find the index of the letter 'g'.

Using this module you can have run-time properties on initialized
scalar variables and literal values. The word 'properties' is used
in the Perl 6 sense: out-of-band data, little sticky notes that
are attached to the value. While attributes (as in Perl 5's attribute
pragma, and see the C<Attribute::*> family of modules) are handled
at compile-time, properties are handled at run-time.

Internally properties are implemented by making their values into
objects with overloaded operators. The actual properties are then
simply hash entries.

Most properties are simply notes you attach to the value, but some
may have deeper meaning. For example, the C<true> and C<false>
properties plays a role in boolean context, as the first example
of the Synopsis shows.

Properties can also be propagated between values. For details, see
the EXPORTS section below. Here is an example why this might be
desirable:

  pass_on('approximate');
  my $pi = 3->approximate(1);
  my $circ = 2 * $rad * $pi;

  # now $circ->approximate indicates that this value was derived
  # from approximate values

Please don't use properties whose name start with an underscore;
these are reserved for internal use.

You can set and query properties like this:

=over 4

=item C<$var-E<gt>myprop(1)>

sets the property to a true value. 

=item C<$var-E<gt>myprop(0)>

sets the property to a false value. Note that this doesn't delete
the property (to do so, use the C<del_props> method described
below).

=item C<$var-E<gt>is_myprop>, C<$var-E<gt>has_myprop>

returns a true value if the property is set (i.e., defined and has
a true value). The two alternate interfaces are provided to make
querying attributes sound more natural. For example:

  $foo->is_approximate;
  $bar->has_history;

=back

Values thus made into objects also expose various utility methods.
All of those methods (unless noted otherwise) return the result as
an overloaded value ready to take properties and method calls
itself, and don't modify the original value.

=head1 METHODS

=head2 get_props

Get a list of names of the value's properties.

=head2 del_props(LIST)

Deletes one or more properties from the value. This is different
than setting the property value to zero.

=head2 del_all_props

Deletes all of the value's properties.

=head2 plus(EXPR)

Returns the value that is the sum of the value whose method has
been called and the argument value. This method also overloads
addition, so:

  $a = 7 + 2;
  $a = 7->plus(2);    # the same

=head2 minus(EXPR)

Returns the value that is the the value whose method has been called
minus the argument value. This method also overloads subtraction.

=head2 times(EXPR)

Returns the value that is the the value whose method has been called
times the argument value. This method also overloads multiplication.

=head2 divide(EXPR)

Returns the value that is the the value whose method has been called
divided by the argument value. This method also overloads division.

=head2 modulo(EXPR)

Returns the value that is the the value whose method has been called
modulo the argument value. This method also overloads the modulo
operator.

=head2 exp(EXPR)

Returns the value that is the the value whose method has been called
powered by the argument value. This method also overloads the
exponentiation operator.

=head2 abs

Returns the absolute of the value.

=head2 zero

Returns a boolean value indicating whether the value is equal to 0.

=head2 length

Returns the result of the built-in C<length> function applied to
the value.

=head2 size

Same as C<length()>.

=head2 reverse

Returns the reverse string of the value.

=head2 uc

Returns the result of the built-in function C<uc()> applied to the value.

=head2 ucfirst

Returns the result of the built-in function C<ucfirst()> applied to the value.

=head2 lc

Returns the result of the built-in function C<lc()> applied to the value.

=head2 lcfirst

Returns the result of the built-in function C<lcfirst()> applied to the value.

=head2 hex

Returns the result of the built-in function C<hex()> applied to the value.

=head2 oct

Returns the result of the built-in function C<oct()> applied to the value.

=head2 concat(EXPR)

Returns the result of the argument expression appended to the
value.

=head2 append(EXPR)

Same as C<concat(EXPR)>.

=head2 swapcase

Returns a version of the value with every character's case reversed,
i.e. a lowercase character becomes uppercase and vice versa.

=head2 split /PATTERN/, LIMIT

Returns a list of overloaded values that is the result of splitting
(according to the built-in C<split> function) the value along the
pattern, into a number of values up to the limit.

=head2 numcmp(EXPR)

Returns the (overloaded) value of the numerical three-way comparison.
This method also overloads the C<E<lt>=E<gt>> operator.

=head2 cmp(EXPR)

Returns the (overloaded) value of the alphabetical three-way
comparison.  This method also overloads the C<cmp> operator.

=head2 eq(EXPR)

Return the (overloaded) boolean value of the C<eq> string comparison. This
method also overloads that operators.

=head2 ne(EXPR)

Return the (overloaded) boolean value of the C<ne> string comparison. This
method also overloads that operators.

=head2 lt(EXPR)

Return the (overloaded) boolean value of the C<lt> string comparison. This
method also overloads that operators.

=head2 gt(EXPR)

Return the (overloaded) boolean value of the C<gt> string comparison. This
method also overloads that operators.

=head2 le(EXPR)

Return the (overloaded) boolean value of the C<le> string comparison. This
method also overloads that operators.

=head2 ge(EXPR)

Return the (overloaded) boolean value of the C<ge> string comparison. This
method also overloads that operators.

=head2 eqi

Same as C<eq()>, but is case-insensitive.

=head2 nei>

Same as C<ne()>, but is case-insensitive.

=head2 lti

Same as C<lt()>, but is case-insensitive.

=head2 gti

Same as C<gt()>, but is case-insensitive.

=head2 lei

Same as C<le()>, but is case-insensitive.

=head2 gei

Same as C<ge()>, but is case-insensitive.

=head2 is_true

Returns whether the (overloaded) boolean status of the value is true.

=head2 is_false

Returns whether the (overloaded) boolean status of the value is false.

=head2 create

FIXME

=head2 del_prop

FIXME

=head2 do_downto

FIXME

=head2 do_downto_step

FIXME

=head2 do_upto

FIXME

=head2 do_upto_step

FIXME

=head2 false

FIXME

=head2 gen_meth

FIXME

=head2 handle

FIXME

=head2 times_do

FIXME

=head2 true

FIXME

=head2 value

FIXME

=head1 FUNCTIONS

=head2 pass_on(LIST)

Sets (replaces) the list of properties that are passed on. There
is only one such list for the whole mechanism. The whole property
interface is experimental, but this one in particular is likely to
change in the future. This function is exported automatically.

=head2 passed_on(STRING)

Tests whether a property is passed on and returns a boolean value. This
function is exported automatically.

=head2 get_pass_on

Returns a list of names of properties that are passed on. This function is
exported automatically.

=head1 INSTALLATION

See perlmodinstall for information and options on installing Perl modules.

=head1 BUGS AND LIMITATIONS

No bugs have been reported.

Please report any bugs or feature requests through the web interface at
L<http://rt.cpan.org/Public/Dist/Display.html?Name=Scalar-Properties>.

=head1 AVAILABILITY

The latest version of this module is available from the Comprehensive Perl
Archive Network (CPAN). Visit L<http://www.perl.com/CPAN/> to find a CPAN
site near you, or see
L<http://search.cpan.org/dist/Scalar-Properties/>.

The development version lives at
L<http://github.com/hanekomu/Scalar-Properties/>.
Instead of sending patches, please fork this project using the standard git
and github infrastructure.

=head1 AUTHOR

  Marcel Gruenauer <marcel@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2001 by Marcel Gruenauer.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut