package Bit
::Vector
::Overload
;
use vars
qw(@ISA @EXPORT @EXPORT_OK $VERSION);
@ISA = qw(Exporter Bit::Vector);
use Carp
::Clan
'^Bit::Vector\b';
'.=' => '_assign_concat',
'<<=' => '_assign_shift_left',
'>>=' => '_assign_shift_right',
'&=' => '_assign_intersection',
'^=' => '_assign_exclusive_or',
'cmp' => '_lexicompare', # also enables lt, le, gt, ge, eq, ne
'>=' => '_greater_equal',
# 0 = Scalar Input: 0 = Bit Index (default)
# 1 = Operator Semantics: 0 = Set Ops (default)
# Affected Operators: "+" "-" "*"
# 2 = String Output: 0 = to_Hex() (default)
croak
('Usage: $oldconfig = Bit::Vector->Configuration( [ $newconfig ] );');
$result = "Scalar Input = ";
if ($CONFIG[0] == 4) { $result .= "Enumeration"; }
elsif ($CONFIG[0] == 3) { $result .= "Decimal"; }
elsif ($CONFIG[0] == 2) { $result .= "Binary"; }
elsif ($CONFIG[0] == 1) { $result .= "Hexadecimal"; }
else { $result .= "Bit Index"; }
$result .= "\nOperator Semantics = ";
if ($CONFIG[1] == 1) { $result .= "Arithmetic Operators"; }
else { $result .= "Set Operators"; }
$result .= "\nString Output = ";
if ($CONFIG[2] == 3) { $result .= "Enumeration"; }
elsif ($CONFIG[2] == 2) { $result .= "Decimal"; }
elsif ($CONFIG[2] == 1) { $result .= "Binary"; }
else { $result .= "Hexadecimal"; }
@commands = split(/[,;:|\/\n&+-]/, $_[0]);
foreach $assignment (@commands)
if ($assignment =~ /^\s*$/) { } # ignore empty lines
elsif ($assignment =~ /^([A-Za-z\s]+)=([A-Za-z\s]+)$/)
if ($which =~ /\bscalar|\binput|\bin\b/i) { $m0 = 1; }
if ($which =~ /\boperator|\bsemantic|\bops\b/i) { $m1 = 1; }
if ($which =~ /\bstring|\boutput|\bout\b/i) { $m2 = 1; }
if ($value =~ /\bbit\b|\bindex|\bindice/i) { $m0 = 1; }
if ($value =~ /\bhex/i) { $m1 = 1; }
if ($value =~ /\bbin/i) { $m2 = 1; }
if ($value =~ /\bdec/i) { $m3 = 1; }
if ($value =~ /\benum/i) { $m4 = 1; }
if ($m0 && !$m1 && !$m2 && !$m3 && !$m4) { $CONFIG[0] = 0; }
elsif (!$m0 && $m1 && !$m2 && !$m3 && !$m4) { $CONFIG[0] = 1; }
elsif (!$m0 && !$m1 && $m2 && !$m3 && !$m4) { $CONFIG[0] = 2; }
elsif (!$m0 && !$m1 && !$m2 && $m3 && !$m4) { $CONFIG[0] = 3; }
elsif (!$m0 && !$m1 && !$m2 && !$m3 && $m4) { $CONFIG[0] = 4; }
elsif (!$m0 && $m1 && !$m2)
if ($value =~ /\bset\b/i) { $m0 = 1; }
if ($value =~ /\barithmetic/i) { $m1 = 1; }
if ($m0 && !$m1) { $CONFIG[1] = 0; }
elsif (!$m0 && $m1) { $CONFIG[1] = 1; }
elsif (!$m0 && !$m1 && $m2)
if ($value =~ /\bhex/i) { $m0 = 1; }
if ($value =~ /\bbin/i) { $m1 = 1; }
if ($value =~ /\bdec/i) { $m2 = 1; }
if ($value =~ /\benum/i) { $m3 = 1; }
if ($m0 && !$m1 && !$m2 && !$m3) { $CONFIG[2] = 0; }
elsif (!$m0 && $m1 && !$m2 && !$m3) { $CONFIG[2] = 1; }
elsif (!$m0 && !$m1 && $m2 && !$m3) { $CONFIG[2] = 2; }
elsif (!$m0 && !$m1 && !$m2 && $m3) { $CONFIG[2] = 3; }
croak
('configuration string syntax error');
$text =~ s!^(?:Bit::Vector::)?[a-zA-Z0-9_]+\(\):\s*!!i;
elsif ($code == 1) { $text = 'illegal operand type'; }
elsif ($code == 2) { $text = 'illegal reversed operands'; }
else { croak
('unexpected internal error - please contact author'); }
$text .= " in overloaded ";
if (length($name) > 5) { $text .= "$name operation"; }
else { $text .= "'$name' operator"; }
my($vector,$scalar) = @_;
if ($CONFIG[0] == 4) { $vector->from_Enum($scalar); }
elsif ($CONFIG[0] == 3) { $vector->from_Dec ($scalar); }
elsif ($CONFIG[0] == 2) { $vector->from_Bin ($scalar); }
elsif ($CONFIG[0] == 1) { $vector->from_Hex ($scalar); }
else { $vector->Bit_On ($scalar); }
if ($CONFIG[2] == 3) { return( $vector->to_Enum() ); }
elsif ($CONFIG[2] == 2) { return( $vector->to_Dec () ); }
elsif ($CONFIG[2] == 1) { return( $vector->to_Bin () ); }
else { return( $vector->to_Hex () ); }
my($object,$argument,$flag,$name,$build) = @_;
if ((defined $argument) && ref($argument) && (ref($argument) !~ /^[A-Z]+$/))
if ($build && (defined $flag))
$operand = $argument->Clone();
else { $operand = $argument; }
if ($@
) { &_error
($name,0); }
elsif ((defined $argument) && (!ref($argument)))
$operand = $object->Shadow();
&_vectorize_
($operand,$argument);
if ($@
) { &_error
($name,0); }
else { &_error
($name,1); }
my($argument,$flag,$name) = @_;
if ((defined $argument) && (!ref($argument)))
if ((defined $flag) && $flag) { &_error
($name,2); }
else { &_error
($name,1); }
my($name) = 'string interpolation';
$result = &_scalarize_
($vector);
if ($@
) { &_error
($name,0); }
my($name) = 'boolean test';
$result = $object->is_empty();
if ($@
) { &_error
($name,0); }
my($name) = 'negated boolean test';
$result = $object->is_empty();
if ($@
) { &_error
($name,0); }
$result = $object->Shadow();
$result->Complement($object);
if ($@
) { &_error
($name,0); }
my($name) = 'unary minus';
$result = $object->Shadow();
$result->Negate($object);
if ($@
) { &_error
($name,0); }
$result = $object->Shadow();
$result->Absolute($object);
$result = $object->Norm();
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$name .= '=' unless (defined $flag);
if ((defined $argument) && ref($argument) && (ref($argument) !~ /^[A-Z]+$/))
if ($flag) { $result = $argument->Concat($object); }
else { $result = $object->Concat($argument); }
$object->Interval_Substitute($argument,0,0,0,$argument->Size());
if ($@
) { &_error
($name,0); }
elsif ((defined $argument) && (!ref($argument)))
if ($flag) { $result = $argument . &_scalarize_
($object); }
else { $result = &_scalarize_
($object) . $argument; }
if ($CONFIG[0] == 2) { $result = $object->new( length($argument) ); }
elsif ($CONFIG[0] == 1) { $result = $object->new( length($argument) << 2 ); }
else { $result = $object->Shadow(); }
&_vectorize_
($result,$argument);
$object->Interval_Substitute($result,0,0,0,$result->Size());
if ($@
) { &_error
($name,0); }
else { &_error
($name,1); }
sub _xerox
# (in Brazil, a photocopy is called a "xerox")
my($object,$argument,$flag) = @_;
$name .= '=' unless (defined $flag);
&_check_operand
($argument,$flag,$name);
$result = $object->new($size * $argument);
$result->Resize($size * $argument);
for ( ; $index < $argument; $index++, $offset += $size )
$result->Interval_Copy($object,$offset,0,$size);
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$name .= '=' unless (defined $flag);
&_check_operand
($argument,$flag,$name);
$result = $object->Clone();
$result->Insert(0,$argument);
# $result->Move_Left($argument);
# $object->Move_Left($argument);
$object->Insert(0,$argument);
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$name .= '=' unless (defined $flag);
&_check_operand
($argument,$flag,$name);
$result = $object->Clone();
$result->Delete(0,$argument);
# $result->Move_Right($argument);
# $object->Move_Right($argument);
$object->Delete(0,$argument);
if ($@
) { &_error
($name,0); }
my($object,$operand,$flag) = @_;
$operand->Union($object,$operand);
$object->Union($object,$operand);
my($object,$argument,$flag) = @_;
$name .= '=' unless (defined $flag);
$operand = &_fetch_operand
($object,$argument,$flag,$name,1);
$operand = &_union_
($object,$operand,$flag);
if ($@
) { &_error
($name,0); }
my($object,$operand,$flag) = @_;
$operand->Intersection($object,$operand);
$object->Intersection($object,$operand);
my($object,$argument,$flag) = @_;
$name .= '=' unless (defined $flag);
$operand = &_fetch_operand
($object,$argument,$flag,$name,1);
$operand = &_intersection_
($object,$operand,$flag);
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$name .= '=' unless (defined $flag);
$operand = &_fetch_operand
($object,$argument,$flag,$name,1);
$operand->ExclusiveOr($object,$operand);
$object->ExclusiveOr($object,$operand);
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$name .= '=' unless (defined $flag);
$operand = &_fetch_operand
($object,$argument,$flag,$name,1);
$operand->add($object,$operand,0);
$object->add($object,$operand,0);
$operand = &_union_
($object,$operand,$flag);
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$name .= '=' unless (defined $flag);
$operand = &_fetch_operand
($object,$argument,$flag,$name,1);
if ($flag) { $operand->subtract($operand,$object,0); }
else { $operand->subtract($object,$operand,0); }
$object->subtract($object,$operand,0);
if ($flag) { $operand->Difference($operand,$object); }
else { $operand->Difference($object,$operand); }
$object->Difference($object,$operand);
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$name .= '=' unless (defined $flag);
$operand = &_fetch_operand
($object,$argument,$flag,$name,1);
$operand->Multiply($object,$operand);
$object->Multiply($object,$operand);
$operand = &_intersection_
($object,$operand,$flag);
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$name .= '=' unless (defined $flag);
$operand = &_fetch_operand
($object,$argument,$flag,$name,1);
$temp = $object->Shadow();
if ($flag) { $operand->Divide($operand,$object,$temp); }
else { $operand->Divide($object,$operand,$temp); }
$object->Divide($object,$operand,$temp);
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$name .= '=' unless (defined $flag);
$operand = &_fetch_operand
($object,$argument,$flag,$name,1);
$temp = $object->Shadow();
if ($flag) { $temp->Divide($operand,$object,$operand); }
else { $temp->Divide($object,$operand,$operand); }
$temp->Divide($object,$operand,$object);
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$name .= '=' unless (defined $flag);
$operand = &_fetch_operand
($object,$argument,$flag,$name,0);
$result = $object->Shadow();
if ($flag) { $result->Power($operand,$object); }
else { $result->Power($object,$operand); }
$object->Power($object,$operand);
if ($@
) { &_error
($name,0); }
my($object,$argument) = @_;
return( &_concat
($object,$argument,undef) );
my($object,$argument) = @_;
return( &_xerox
($object,$argument,undef) );
my($object,$argument) = @_;
return( &_shift_left
($object,$argument,undef) );
my($object,$argument) = @_;
return( &_shift_right
($object,$argument,undef) );
my($object,$argument) = @_;
return( &_union
($object,$argument,undef) );
my($object,$argument) = @_;
return( &_intersection
($object,$argument,undef) );
my($object,$argument) = @_;
return( &_exclusive_or
($object,$argument,undef) );
my($object,$argument) = @_;
return( &_add
($object,$argument,undef) );
my($object,$argument) = @_;
return( &_sub
($object,$argument,undef) );
my($object,$argument) = @_;
return( &_mul
($object,$argument,undef) );
my($object,$argument) = @_;
return( &_div
($object,$argument,undef) );
my($object,$argument) = @_;
return( &_mod
($object,$argument,undef) );
my($object,$argument) = @_;
return( &_pow
($object,$argument,undef) );
$result = $object->increment();
if ($@
) { &_error
($name,0); }
$result = $object->decrement();
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$operand = &_fetch_operand
($object,$argument,$flag,$name,0);
if ((defined $flag) && $flag)
$result = $operand->Lexicompare($object);
$result = $object->Lexicompare($operand);
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$operand = &_fetch_operand
($object,$argument,$flag,$name,0);
if ((defined $flag) && $flag)
$result = $operand->Compare($object);
$result = $object->Compare($operand);
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$operand = &_fetch_operand
($object,$argument,$flag,$name,0);
$result = $object->equal($operand);
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$operand = &_fetch_operand
($object,$argument,$flag,$name,0);
$result = $object->equal($operand);
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$operand = &_fetch_operand
($object,$argument,$flag,$name,0);
if ((defined $flag) && $flag)
$result = ($operand->Compare($object) < 0);
$result = ($object->Compare($operand) < 0);
if ((defined $flag) && $flag)
$result = ((!$operand->equal($object)) &&
($operand->subset($object)));
$result = ((!$object->equal($operand)) &&
($object->subset($operand)));
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$operand = &_fetch_operand
($object,$argument,$flag,$name,0);
if ((defined $flag) && $flag)
$result = ($operand->Compare($object) <= 0);
$result = ($object->Compare($operand) <= 0);
if ((defined $flag) && $flag)
$result = $operand->subset($object);
$result = $object->subset($operand);
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$operand = &_fetch_operand
($object,$argument,$flag,$name,0);
if ((defined $flag) && $flag)
$result = ($operand->Compare($object) > 0);
$result = ($object->Compare($operand) > 0);
if ((defined $flag) && $flag)
$result = ((!$object->equal($operand)) &&
($object->subset($operand)));
$result = ((!$operand->equal($object)) &&
($operand->subset($object)));
if ($@
) { &_error
($name,0); }
my($object,$argument,$flag) = @_;
$operand = &_fetch_operand
($object,$argument,$flag,$name,0);
if ((defined $flag) && $flag)
$result = ($operand->Compare($object) >= 0);
$result = ($object->Compare($operand) >= 0);
if ((defined $flag) && $flag)
$result = $object->subset($operand);
$result = $operand->subset($object);
if ($@
) { &_error
($name,0); }
my($name) = 'automatic duplication';
$result = $object->Clone();
if ($@
) { &_error
($name,0); }