# vim:ts=4 sw=4
# ----------------------------------------------------------------------------------------------------
# Name : Class::STL::Utilities.pm
# Created : 22 February 2006
# Author : Mario Gaffiero (gaffie)
#
# Copyright 2006-2007 Mario Gaffiero.
#
# This file is part of Class::STL::Containers(TM).
#
# Class::STL::Containers is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; version 2 of the License.
#
# Class::STL::Containers is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Class::STL::Containers; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
# ----------------------------------------------------------------------------------------------------
# Modification History
# When Version Who What
# ----------------------------------------------------------------------------------------------------
# TO DO:
# ----------------------------------------------------------------------------------------------------
package Class::STL::Utilities;
require 5.005_62;
use strict;
use warnings;
use vars qw( $VERSION $BUILD @EXPORT_OK %EXPORT_TAGS );
use Exporter;
my @export_names = qw(
equal_to not_equal_to greater greater_equal less less_equal compare bind1st bind2nd
mem_fun ptr_fun ptr_fun_binary matches matches_ic logical_and logical_or
multiplies divides plus minus modulus not1 not2 negate not_null
);
@EXPORT_OK = (@export_names);
%EXPORT_TAGS = ( all => [@export_names] );
$VERSION = '0.18';
$BUILD = 'Thursday April 27 23:08:34 GMT 2006';
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities;
use vars qw( $AUTOLOAD );
sub AUTOLOAD
{
(my $func = $AUTOLOAD) =~ s/.*:://;
return Class::STL::Utilities::EqualTo->new(@_) if ($func eq 'equal_to');
return Class::STL::Utilities::NotEqualTo->new(@_) if ($func eq 'not_equal_to');
return Class::STL::Utilities::Greater->new(@_) if ($func eq 'greater');
return Class::STL::Utilities::GreaterEqual->new(@_) if ($func eq 'greater_equal');
return Class::STL::Utilities::Less->new(@_) if ($func eq 'less');
return Class::STL::Utilities::LessEqual->new(@_) if ($func eq 'less_equal');
return Class::STL::Utilities::Compare->new(@_) if ($func eq 'compare');
return Class::STL::Utilities::Matches->new(@_) if ($func eq 'matches');
return Class::STL::Utilities::MatchesIC->new(@_) if ($func eq 'matches_ic');
return Class::STL::Utilities::LogicalAnd->new(@_) if ($func eq 'logical_and');
return Class::STL::Utilities::LogicalOr->new(@_) if ($func eq 'logical_or');
return Class::STL::Utilities::Multiplies->new(@_) if ($func eq 'multiplies');
return Class::STL::Utilities::Divides->new(@_) if ($func eq 'divides');
return Class::STL::Utilities::Plus->new(@_) if ($func eq 'plus');
return Class::STL::Utilities::Minus->new(@_) if ($func eq 'minus');
return Class::STL::Utilities::Modulus->new(@_) if ($func eq 'modulus');
return Class::STL::Utilities::Binder1st->new(@_) if ($func eq 'bind1st');
return Class::STL::Utilities::Binder2nd->new(@_) if ($func eq 'bind2nd');
return Class::STL::Utilities::MemberFunction->new(@_) if ($func eq 'mem_fun');
return Class::STL::Utilities::PointerToUnaryFunction->new(@_)if ($func eq 'ptr_fun');
return Class::STL::Utilities::PointerToBinaryFunction->new(@_)if ($func eq 'ptr_fun_binary');
return Class::STL::Utilities::UnaryNegate->new(@_) if ($func eq 'not1');
return Class::STL::Utilities::BinaryNegate->new(@_) if ($func eq 'not2');
return Class::STL::Utilities::Negate->new(@_) if ($func eq 'negate');
return Class::STL::Utilities::NotNull->new(@_) if ($func eq 'not_null');
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::FunctionObject;
use Class::STL::ClassMembers qw(result_type);
use Class::STL::ClassMembers::Constructor;
sub function_operator
{
my $self = shift;
use Carp qw(confess);
confess "@{[ __PACKAGE__ ]} abstract class must be derived!\n";
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::FunctionObject::Generator;
use base qw(Class::STL::Utilities::FunctionObject);
sub function_operator
{
my $self = shift;
use Carp qw(confess);
confess "@{[ __PACKAGE__ ]} abstract class must be derived!\n";
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::FunctionObject::UnaryFunction;
use base qw(Class::STL::Utilities::FunctionObject);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
use Carp qw(confess);
confess "@{[ __PACKAGE__ ]} abstract class must be derived!\n";
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::FunctionObject::BinaryFunction;
use base qw(Class::STL::Utilities::FunctionObject);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
use Carp qw(confess);
confess "@{[ __PACKAGE__ ]} abstract class must be derived!\n";
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::FunctionObject::UnaryPredicate;
use base qw(Class::STL::Utilities::FunctionObject::UnaryFunction);
sub new_extra
{
my $self = shift;
$self->result_type('bool');
return $self;
}
sub function_operator
{
my $self = shift;
my $arg1 = shift;
use Carp qw(confess);
confess "@{[ __PACKAGE__ ]} abstract class must be derived!\n";
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::FunctionObject::BinaryPredicate;
use base qw(Class::STL::Utilities::FunctionObject::BinaryFunction);
sub new_extra
{
my $self = shift;
$self->result_type('bool');
return $self;
}
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
use Carp qw(confess);
confess "@{[ __PACKAGE__ ]} abstract class must be derived!\n";
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::MemberFunction;
use base qw(Class::STL::Utilities::FunctionObject);
use Class::STL::ClassMembers qw(function_name);
sub new
{
my $self = shift;
my $class = ref($self) || $self;
$self = $class->SUPER::new();
bless($self, $class);
$self->members_init(function_name => shift);
return $self;
}
sub function_operator
{
my $self = shift;
my $element = shift;
my $fname = $self->function_name();
return $element->$fname(@_);
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::PointerToUnaryFunction;
use base qw(Class::STL::Utilities::FunctionObject::UnaryFunction);
use Carp qw(confess);
use Class::STL::ClassMembers qw(function_name);
sub new
{
my $self = shift;
my $class = ref($self) || $self;
$self = $class->SUPER::new();
bless($self, $class);
$self->members_init(function_name => shift);
return $self->factory();
}
sub factory
{
my $self = shift;
our %__dynfun;
if (!exists($__dynfun{$self->function_name()}))
{
$__dynfun{$self->function_name()} = eval("
{
package Class::STL::Utilities::PointerToUnaryFunction::__@{[ $self->function_name() ]};
use base qw(Class::STL::Utilities::FunctionObject::UnaryFunction);
sub function_operator
{
my \$self = shift;
my \$arg = shift;
my \$tmp;
if (ref(\$arg) && \$arg->isa('Class::STL::Element'))
{
\$tmp = \$arg->clone();
\$tmp->data(@{[ $self->function_name() ]}(\$tmp->data()));
}
return \$tmp;
}
}
Class::STL::Utilities::PointerToUnaryFunction::__@{[ $self->function_name() ]}->new();
");
confess "**Error in eval for @{[ __PACKAGE__ ]} ptr_fun dynamic class creation:\n$@" if ($@);
}
return $__dynfun{$self->function_name()};
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::PointerToBinaryFunction;
use base qw(Class::STL::Utilities::FunctionObject::BinaryFunction);
use Carp qw(confess);
use Class::STL::ClassMembers qw(function_name);
sub new
{
my $self = shift;
my $class = ref($self) || $self;
$self = $class->SUPER::new();
bless($self, $class);
$self->members_init(function_name => shift);
return $self->factory();
}
sub factory
{
my $self = shift;
our %__dynfun;
if (!exists($__dynfun{$self->function_name()}))
{
$__dynfun{$self->function_name()} = eval("
{
package Class::STL::Utilities::PointerToBinaryFunction::__@{[ $self->function_name() ]};
use base qw(Class::STL::Utilities::FunctionObject::BinaryFunction);
sub function_operator
{
my \$self = shift;
my \$arg1 = shift;
my \$arg2 = shift;
my \$tmp;
if (ref(\$arg1) && \$arg1->isa('Class::STL::Element') && ref(\$arg2) && \$arg2->isa('Class::STL::Element'))
{
\$tmp = \$arg1->clone();
\$tmp->data(@{[ $self->function_name() ]}(\$arg1->data(), \$arg2->data()));
}
elsif (ref(\$arg2) && \$arg2->isa('Class::STL::Element'))
{
\$tmp = \$arg2->clone();
\$tmp->data(@{[ $self->function_name() ]}(\$arg1, \$arg2->data()));
}
elsif (ref(\$arg1) && \$arg1->isa('Class::STL::Element'))
{
\$tmp = \$arg1->clone();
\$tmp->data(@{[ $self->function_name() ]}(\$arg1->data(), \$arg2));
}
return \$tmp;
}
}
Class::STL::Utilities::PointerToBinaryFunction::__@{[ $self->function_name() ]}->new();
");
confess "**Error in eval for @{[ __PACKAGE__ ]} ptr_fun_binary dynamic class creation:\n$@" if ($@);
}
return $__dynfun{$self->function_name()};
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::UnaryNegate;
use base qw(Class::STL::Utilities::FunctionObject::UnaryPredicate);
use Class::STL::ClassMembers qw(predicate);
sub new
{
my $self = shift;
my $class = ref($self) || $self;
$self = $class->SUPER::new();
bless($self, $class);
$self->members_init(predicate => shift);
return $self;
}
sub function_operator
{
my $self = shift;
my $arg = shift;
return !($self->predicate()->function_operator($arg));
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::BinaryNegate;
use base qw(Class::STL::Utilities::FunctionObject::BinaryPredicate);
use Class::STL::ClassMembers qw(predicate);
sub new
{
my $self = shift;
my $class = ref($self) || $self;
$self = $class->SUPER::new();
bless($self, $class);
$self->members_init(predicate => shift);
return $self;
}
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
return !($self->predicate()->function_operator($arg1, $arg2));
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::Binder1st;
use base qw(Class::STL::Utilities::FunctionObject::UnaryFunction);
use Class::STL::ClassMembers qw(operation first_argument);
sub new
{
my $self = shift;
my $class = ref($self) || $self;
$self = $class->SUPER::new();
bless($self, $class);
$self->members_init(operation => shift, first_argument => shift);
return $self;
}
sub function_operator
{
my $self = shift;
my $arg = shift; # element object
return $self->operation()->function_operator($self->first_argument(), $arg);
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::Binder2nd;
use base qw(Class::STL::Utilities::FunctionObject::UnaryFunction);
use Class::STL::ClassMembers qw(operation second_argument);
sub new
{
my $self = shift;
my $class = ref($self) || $self;
$self = $class->SUPER::new();
bless($self, $class);
$self->members_init(operation => shift, second_argument => shift);
return $self;
}
sub function_operator
{
my $self = shift;
my $arg = shift; # element object
return $self->operation()->function_operator($arg, $self->second_argument());
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::EqualTo;
use base qw(Class::STL::Utilities::FunctionObject::BinaryPredicate);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
return
(ref($arg1) && $arg1->isa('Class::STL::Element') && ref($arg2) && $arg2->isa('Class::STL::Element'))
? $arg1->eq($arg2)
: (ref($arg2) && $arg2->isa('Class::STL::Element'))
? ($arg2->data_type() eq 'string') ? $arg1 eq $arg2->data() : $arg1 == $arg2->data()
: (ref($arg1) && $arg1->isa('Class::STL::Element'))
? ($arg1->data_type() eq 'string') ? $arg1->data() eq $arg2 : $arg1->data() == $arg2
: $arg1 == $arg2;
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::NotEqualTo;
use base qw(Class::STL::Utilities::FunctionObject::BinaryPredicate);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
return
(ref($arg1) && $arg1->isa('Class::STL::Element') && ref($arg2) && $arg2->isa('Class::STL::Element'))
? $arg1->ne($arg2)
: (ref($arg2) && $arg2->isa('Class::STL::Element'))
? ($arg2->data_type() eq 'string') ? $arg1 ne $arg2->data() : $arg1 != $arg2->data()
: (ref($arg1) && $arg1->isa('Class::STL::Element'))
? ($arg1->data_type() eq 'string') ? $arg1->data() ne $arg2 : $arg1->data() != $arg2
: $arg1 != $arg2;
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::NotNull;
use base qw(Class::STL::Utilities::FunctionObject::UnaryPredicate);
sub function_operator
{
my $self = shift;
my $arg = shift;
return defined($arg) && (ref($arg) || $arg != 0);
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::Greater;
use base qw(Class::STL::Utilities::FunctionObject::BinaryPredicate);
sub function_operator
{
my $self = shift;
my $arg1 = shift; # element or scalar
my $arg2 = shift; # element or scalar
return
(ref($arg1) && $arg1->isa('Class::STL::Element') && ref($arg2) && $arg2->isa('Class::STL::Element'))
? $arg1->gt($arg2)
: (ref($arg2) && $arg2->isa('Class::STL::Element'))
? ($arg2->data_type() eq 'string') ? $arg1 gt $arg2->data() : $arg1 > $arg2->data()
: (ref($arg1) && $arg1->isa('Class::STL::Element'))
? ($arg1->data_type() eq 'string') ? $arg1->data() gt $arg2 : $arg1->data() > $arg2
: $arg1 > $arg2;
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::GreaterEqual;
use base qw(Class::STL::Utilities::FunctionObject::BinaryPredicate);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
return
(ref($arg1) && $arg1->isa('Class::STL::Element') && ref($arg2) && $arg2->isa('Class::STL::Element'))
? $arg1->ge($arg2)
: (ref($arg2) && $arg2->isa('Class::STL::Element'))
? ($arg2->data_type() eq 'string') ? $arg1 ge $arg2->data() : $arg1 >= $arg2->data()
: (ref($arg1) && $arg1->isa('Class::STL::Element'))
? ($arg1->data_type() eq 'string') ? $arg1->data() ge $arg2 : $arg1->data() >= $arg2
: $arg1 >= $arg2;
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::Less;
use base qw(Class::STL::Utilities::FunctionObject::BinaryPredicate);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
return
(ref($arg1) && $arg1->isa('Class::STL::Element') && ref($arg2) && $arg2->isa('Class::STL::Element'))
? $arg1->lt($arg2)
: (ref($arg2) && $arg2->isa('Class::STL::Element'))
? ($arg2->data_type() eq 'string') ? $arg1 lt $arg2->data() : $arg1 < $arg2->data()
: (ref($arg1) && $arg1->isa('Class::STL::Element'))
? ($arg1->data_type() eq 'string') ? $arg1->data() lt $arg2 : $arg1->data() < $arg2
: $arg1 < $arg2;
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::LessEqual;
use base qw(Class::STL::Utilities::FunctionObject::BinaryPredicate);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
return
(ref($arg1) && $arg1->isa('Class::STL::Element') && ref($arg2) && $arg2->isa('Class::STL::Element'))
? $arg1->le($arg2)
: (ref($arg2) && $arg2->isa('Class::STL::Element'))
? ($arg2->data_type() eq 'string') ? $arg1 le $arg2->data() : $arg1 <= $arg2->data()
: (ref($arg1) && $arg1->isa('Class::STL::Element'))
? ($arg1->data_type() eq 'string') ? $arg1->data() le $arg2 : $arg1->data() <= $arg2
: $arg1 <= $arg2;
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::Compare;
use base qw(Class::STL::Utilities::FunctionObject::BinaryPredicate);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
return
(ref($arg1) && $arg1->isa('Class::STL::Element') && ref($arg2) && $arg2->isa('Class::STL::Element'))
? $arg1->cmp($arg2)
: (ref($arg2) && $arg2->isa('Class::STL::Element'))
? ($arg2->data_type() eq 'string') ? $arg1 cmp $arg2->data() : $arg1 <=> $arg2->data()
: (ref($arg1) && $arg1->isa('Class::STL::Element'))
? ($arg1->data_type() eq 'string') ? $arg1->data() cmp $arg2 : $arg1->data() <=> $arg2
: $arg1 <=> $arg2;
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::LogicalAnd;
use base qw(Class::STL::Utilities::FunctionObject::BinaryPredicate);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
return
(ref($arg1) && $arg1->isa('Class::STL::Element') && ref($arg2) && $arg2->isa('Class::STL::Element'))
? $arg1->and($arg2)
: (ref($arg2) && $arg2->isa('Class::STL::Element'))
? $arg1 && $arg2->data()
: (ref($arg1) && $arg1->isa('Class::STL::Element'))
? $arg1->data() && $arg2
: $arg1 && $arg2;
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::LogicalOr;
use base qw(Class::STL::Utilities::FunctionObject::BinaryPredicate);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
return
(ref($arg1) && $arg1->isa('Class::STL::Element') && ref($arg2) && $arg2->isa('Class::STL::Element'))
? $arg1->or($arg2)
: (ref($arg2) && $arg2->isa('Class::STL::Element'))
? $arg1 || $arg2->data()
: (ref($arg1) && $arg1->isa('Class::STL::Element'))
? $arg1->data() || $arg2
: $arg1 || $arg2;
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::Matches;
use base qw(Class::STL::Utilities::FunctionObject::BinaryPredicate);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
return
(ref($arg1) && $arg1->isa('Class::STL::Element') && ref($arg2) && $arg2->isa('Class::STL::Element'))
? $arg1->match($arg2)
: (ref($arg2) && $arg2->isa('Class::STL::Element'))
? $arg1 =~ /@{[ $arg2->data() ]}/
: (ref($arg1) && $arg1->isa('Class::STL::Element'))
? $arg1->data() =~ /@{[ $arg2 ]}/
: $arg1 =~ /$arg2/;
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::MatchesIC;
use base qw(Class::STL::Utilities::FunctionObject::BinaryPredicate);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
return
(ref($arg1) && $arg1->isa('Class::STL::Element') && ref($arg2) && $arg2->isa('Class::STL::Element'))
? $arg1->match_ic($arg2)
: (ref($arg2) && $arg2->isa('Class::STL::Element'))
? $arg1 =~ /@{[ $arg2->data() ]}/i
: (ref($arg1) && $arg1->isa('Class::STL::Element'))
? $arg1->data() =~ /@{[ $arg2 ]}/i
: $arg1 =~ /$arg2/i;
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::Multiplies;
use base qw(Class::STL::Utilities::FunctionObject::BinaryFunction);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
my $tmp;
if (ref($arg1) && $arg1->isa('Class::STL::Element') && ref($arg2) && $arg2->isa('Class::STL::Element'))
{
$tmp = $arg1->clone();
$tmp->mult($arg2);
}
elsif (ref($arg2) && $arg2->isa('Class::STL::Element'))
{
$tmp = $arg2->clone();
$tmp->data($tmp->data() * $arg1);
}
elsif (ref($arg1) && $arg1->isa('Class::STL::Element'))
{
$tmp = $arg1->clone();
$tmp->data($tmp->data() * $arg2);
}
return $tmp;
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::Plus;
use base qw(Class::STL::Utilities::FunctionObject::BinaryFunction);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
my $tmp;
if (ref($arg1) && $arg1->isa('Class::STL::Element') && ref($arg2) && $arg2->isa('Class::STL::Element'))
{
$tmp = $arg1->clone();
$tmp->add($arg2);
}
elsif (ref($arg2) && $arg2->isa('Class::STL::Element'))
{
$tmp = $arg2->clone();
$tmp->data($tmp->data() + $arg1);
}
elsif (ref($arg1) && $arg1->isa('Class::STL::Element'))
{
$tmp = $arg1->clone();
$tmp->data($tmp->data() + $arg2);
}
return $tmp;
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::Minus;
use base qw(Class::STL::Utilities::FunctionObject::BinaryFunction);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
my $tmp;
if (ref($arg1) && $arg1->isa('Class::STL::Element') && ref($arg2) && $arg2->isa('Class::STL::Element'))
{
$tmp = $arg1->clone();
$tmp->subtract($arg2);
}
elsif (ref($arg2) && $arg2->isa('Class::STL::Element'))
{
$tmp = $arg2->clone();
$tmp->data($arg1 - $arg2->data());
}
elsif (ref($arg1) && $arg1->isa('Class::STL::Element'))
{
$tmp = $arg1->clone();
$tmp->data($arg1->data() - $arg2);
}
return $tmp;
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::Modulus;
use base qw(Class::STL::Utilities::FunctionObject::BinaryFunction);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
my $tmp;
if (ref($arg1) && $arg1->isa('Class::STL::Element') && ref($arg2) && $arg2->isa('Class::STL::Element'))
{
$tmp = $arg1->clone();
$tmp->mod($arg2);
}
elsif (ref($arg2) && $arg2->isa('Class::STL::Element'))
{
$tmp = $arg2->clone();
$tmp->data($arg1 % $arg2->data());
}
elsif (ref($arg1) && $arg1->isa('Class::STL::Element'))
{
$tmp = $arg1->clone();
$tmp->data($arg1->data() % $arg2);
}
return $tmp;
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::Divides;
use base qw(Class::STL::Utilities::FunctionObject::BinaryFunction);
sub function_operator
{
my $self = shift;
my $arg1 = shift;
my $arg2 = shift;
my $tmp;
if (ref($arg1) && $arg1->isa('Class::STL::Element') && ref($arg2) && $arg2->isa('Class::STL::Element'))
{
$tmp = $arg1->clone();
$tmp->div($arg2);
}
elsif (ref($arg2) && $arg2->isa('Class::STL::Element'))
{
$tmp = $arg2->clone();
$tmp->data($arg1 / $arg2->data());
}
elsif (ref($arg1) && $arg1->isa('Class::STL::Element'))
{
$tmp = $arg1->clone();
$tmp->data($arg1->data() / $arg2);
}
return $tmp;
}
}
# ----------------------------------------------------------------------------------------------------
{
package Class::STL::Utilities::Negate;
use base qw(Class::STL::Utilities::FunctionObject::UnaryFunction);
sub function_operator
{
my $self = shift;
my $arg = shift;
my $tmp;
if (ref($arg) && $arg->isa('Class::STL::Element'))
{
$tmp = $arg->clone();
$tmp->neg();
}
else
{
$tmp = Class::STL::Element->new(data => -$arg, data_type => 'numeric');
}
return $tmp;
}
}
# ----------------------------------------------------------------------------------------------------
1;