overload.pm

SinFP是一种新的识别对方计算机操作系统类型的工具

###############################################################################
##                                                                           ##
##    Copyright (c) 2000 - 2004 by Steffen Beyer.                            ##
##    All rights reserved.                                                   ##
##                                                                           ##
##    This package is free software; you can redistribute it                 ##
##    and/or modify it under the same terms as Perl itself.                  ##
##                                                                           ##
###############################################################################

package Bit::Vector::Overload;

use strict;
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);

use Bit::Vector;

require Exporter;

@ISA = qw(Exporter Bit::Vector);

@EXPORT = qw();

@EXPORT_OK = qw();

$VERSION = '6.4';

package Bit::Vector;

use Carp::Clan '^Bit::Vector\b';

use overload
      '""' => '_stringify',
    'bool' => '_boolean',
       '!' => '_not_boolean',
       '~' => '_complement',
     'neg' => '_negate',
     'abs' => '_absolute',
       '.' => '_concat',
       'x' => '_xerox',
      '<<' => '_shift_left',
      '>>' => '_shift_right',
       '|' => '_union',
       '&' => '_intersection',
       '^' => '_exclusive_or',
       '+' => '_add',
       '-' => '_sub',
       '*' => '_mul',
       '/' => '_div',
       '%' => '_mod',
      '**' => '_pow',
      '.=' => '_assign_concat',
      'x=' => '_assign_xerox',
     '<<=' => '_assign_shift_left',
     '>>=' => '_assign_shift_right',
      '|=' => '_assign_union',
      '&=' => '_assign_intersection',
      '^=' => '_assign_exclusive_or',
      '+=' => '_assign_add',
      '-=' => '_assign_sub',
      '*=' => '_assign_mul',
      '/=' => '_assign_div',
      '%=' => '_assign_mod',
     '**=' => '_assign_pow',
      '++' => '_increment',
      '--' => '_decrement',
     'cmp' => '_lexicompare',  #  also enables lt, le, gt, ge, eq, ne
     '<=>' => '_compare',
      '==' => '_equal',
      '!=' => '_not_equal',
       '<' => '_less_than',
      '<=' => '_less_equal',
       '>' => '_greater_than',
      '>=' => '_greater_equal',
       '=' => '_clone',
'fallback' =>   undef;

$CONFIG[0] = 0;
$CONFIG[1] = 0;
$CONFIG[2] = 0;

#  Configuration:
#
#  0 = Scalar Input:        0 = Bit Index  (default)
#                           1 = from_Hex
#                           2 = from_Bin
#                           3 = from_Dec
#                           4 = from_Enum
#
#  1 = Operator Semantics:  0 = Set Ops    (default)
#                           1 = Arithmetic Ops
#
#      Affected Operators:  "+"  "-"  "*"
#                           "<"  "<="  ">"  ">="
#                           "abs"
#
#  2 = String Output:       0 = to_Hex()   (default)
#                           1 = to_Bin()
#                           2 = to_Dec()
#                           3 = to_Enum()

sub Configuration
{
    my(@commands);
    my($assignment);
    my($which,$value);
    my($m0,$m1,$m2,$m3,$m4);
    my($result);
    my($ok);

    if (@_ > 2)
    {
        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"; }
    shift if (@_ > 0);
    if (@_ > 0)
    {
        $ok = 1;
        @commands = split(/[,;:|\/\n&+-]/, $_[0]);
        foreach $assignment (@commands)
        {
            if    ($assignment =~ /^\s*$/) { }  #  ignore empty lines
            elsif ($assignment =~ /^([A-Za-z\s]+)=([A-Za-z\s]+)$/)
            {
                $which = $1;
                $value = $2;
                $m0 = 0;
                $m1 = 0;
                $m2 = 0;
                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    ($m0 && !$m1 && !$m2)
                {
                    $m0 = 0;
                    $m1 = 0;
                    $m2 = 0;
                    $m3 = 0;
                    $m4 = 0;
                    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; }
                    else                                        { $ok = 0; last; }
                }
                elsif (!$m0 && $m1 && !$m2)
                {
                    $m0 = 0;
                    $m1 = 0;
                    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; }
                    else                { $ok = 0; last; }
                }
                elsif (!$m0 && !$m1 && $m2)
                {
                    $m0 = 0;
                    $m1 = 0;
                    $m2 = 0;
                    $m3 = 0;
                    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; }
                    else                                { $ok = 0; last; }
                }
                else { $ok = 0; last; }
            }
            else { $ok = 0; last; }
        }
        unless ($ok)
        {
            croak('configuration string syntax error');
        }
    }
    return($result);
}

sub _error
{
    my($name,$code) = @_;
    my($text);

    if ($code == 0)
    {
        $text = $@;
        $text =~ s!\s+! !g;
        $text =~ s!\s+at\s.*$!!;
        $text =~ s!^(?:Bit::Vector::)?[a-zA-Z0-9_]+\(\):\s*!!i;
        $text =~ s!\s+$!!;
    }
    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"; }
    croak($text);
}

sub _vectorize_
{
    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); }
}

sub _scalarize_
{
    my($vector) = @_;

    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 () ); }
}

sub _fetch_operand
{
    my($object,$argument,$flag,$name,$build) = @_;
    my($operand);

    if ((defined $argument) && ref($argument) && (ref($argument) !~ /^[A-Z]+$/))
    {
        eval
        {
            if ($build && (defined $flag))
            {
                $operand = $argument->Clone();
            }
            else { $operand = $argument; }
        };
        if ($@) { &_error($name,0); }
    }
    elsif ((defined $argument) && (!ref($argument)))
    {
        eval
        {
            $operand = $object->Shadow();
            &_vectorize_($operand,$argument);
        };
        if ($@) { &_error($name,0); }
    }
    else { &_error($name,1); }
    return($operand);
}

sub _check_operand
{
    my($argument,$flag,$name) = @_;

    if ((defined $argument) && (!ref($argument)))
    {
        if ((defined $flag) && $flag) { &_error($name,2); }
    }
    else { &_error($name,1); }
}

sub _stringify
{
    my($vector) = @_;
    my($name) = 'string interpolation';
    my($result);

    eval
    {
        $result = &_scalarize_($vector);
    };
    if ($@) { &_error($name,0); }
    return($result);
}

sub _boolean
{
    my($object) = @_;
    my($name) = 'boolean test';
    my($result);

    eval
    {
        $result = $object->is_empty();
    };
    if ($@) { &_error($name,0); }
    return(! $result);
}

sub _not_boolean
{
    my($object) = @_;
    my($name) = 'negated boolean test';
    my($result);

    eval
    {
        $result = $object->is_empty();
    };
    if ($@) { &_error($name,0); }
    return($result);
}

sub _complement
{
    my($object) = @_;
    my($name) = '~';
    my($result);

    eval
    {
        $result = $object->Shadow();
        $result->Complement($object);
    };
    if ($@) { &_error($name,0); }
    return($result);
}

sub _negate
{
    my($object) = @_;
    my($name) = 'unary minus';
    my($result);

    eval
    {
        $result = $object->Shadow();
        $result->Negate($object);
    };
    if ($@) { &_error($name,0); }
    return($result);
}

sub _absolute
{
    my($object) = @_;
    my($name) = 'abs()';
    my($result);

    eval
    {
        if ($CONFIG[1] == 1)
        {
            $result = $object->Shadow();
            $result->Absolute($object);
        }
        else
        {
            $result = $object->Norm();
        }
    };
    if ($@) { &_error($name,0); }
    return($result);
}

sub _concat
{
    my($object,$argument,$flag) = @_;
    my($name) = '.';
    my($result);

    $name .= '=' unless (defined $flag);
    if ((defined $argument) && ref($argument) && (ref($argument) !~ /^[A-Z]+$/))
    {
        eval
        {
            if (defined $flag)
            {
                if ($flag) { $result = $argument->Concat($object); }
                else       { $result = $object->Concat($argument); }
            }
            else
            {
                $object->Interval_Substitute($argument,0,0,0,$argument->Size());
                $result = $object;
            }
        };
        if ($@) { &_error($name,0); }
        return($result);
    }
    elsif ((defined $argument) && (!ref($argument)))
    {
        eval
        {
            if (defined $flag)
            {
                if ($flag) { $result = $argument . &_scalarize_($object); }
                else       { $result = &_scalarize_($object) . $argument; }
            }
            else
            {
                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());
                $result = $object;
            }
        };
        if ($@) { &_error($name,0); }
        return($result);
    }
    else { &_error($name,1); }
}

sub _xerox  #  (in Brazil, a photocopy is called a "xerox")
{
    my($object,$argument,$flag) = @_;
    my($name) = 'x';
    my($result);
    my($offset);
    my($index);
    my($size);

    $name .= '=' unless (defined $flag);
    &_check_operand($argument,$flag,$name);
    eval
    {
        $size = $object->Size();
        if (defined $flag)
        {
            $result = $object->new($size * $argument);
            $offset = 0;
            $index = 0;
        }
        else
        {
            $result = $object;
            $result->Resize($size * $argument);
            $offset = $size;
            $index = 1;
        }
        for ( ; $index < $argument; $index++, $offset += $size )
        {
            $result->Interval_Copy($object,$offset,0,$size);
        }
    };
    if ($@) { &_error($name,0); }
    return($result);
}

sub _shift_left
{
    my($object,$argument,$flag) = @_;
    my($name) = '<<';
    my($result);

    $name .= '=' unless (defined $flag);
    &_check_operand($argument,$flag,$name);
    eval
    {
        if (defined $flag)
        {
            $result = $object->Clone();
            $result->Insert(0,$argument);
#           $result->Move_Left($argument);
        }
        else
        {
#           $object->Move_Left($argument);
            $object->Insert(0,$argument);
            $result = $object;
        }
    };
    if ($@) { &_error($name,0); }
    return($result);
}

sub _shift_right
{
    my($object,$argument,$flag) = @_;
    my($name) = '>>';
    my($result);

    $name .= '=' unless (defined $flag);
    &_check_operand($argument,$flag,$name);
    eval
    {
        if (defined $flag)
        {
            $result = $object->Clone();
            $result->Delete(0,$argument);
#           $result->Move_Right($argument);
        }
        else
        {
#           $object->Move_Right($argument);
            $object->Delete(0,$argument);
            $result = $object;
        }
    };
    if ($@) { &_error($name,0); }
    return($result);
}

sub _union_
{
    my($object,$operand,$flag) = @_;

    if (defined $flag)
    {
        $operand->Union($object,$operand);
        return($operand);
    }
    else
    {
        $object->Union($object,$operand);
        return($object);
    }
}

sub _union
{
    my($object,$argument,$flag) = @_;
    my($name) = '|';
    my($operand);

    $name .= '=' unless (defined $flag);
    $operand = &_fetch_operand($object,$argument,$flag,$name,1);
    eval
    {
        $operand = &_union_($object,$operand,$flag);
    };
    if ($@) { &_error($name,0); }
    return($operand);
}

sub _intersection_
{
    my($object,$operand,$flag) = @_;

    if (defined $flag)
    {
        $operand->Intersection($object,$operand);
        return($operand);
    }
    else
    {
        $object->Intersection($object,$operand);
        return($object);
    }
}

sub _intersection
{
    my($object,$argument,$flag) = @_;
    my($name) = '&';
    my($operand);

    $name .= '=' unless (defined $flag);
    $operand = &_fetch_operand($object,$argument,$flag,$name,1);
    eval
    {
        $operand = &_intersection_($object,$operand,$flag);