home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Overload.pm < prev    next >
Encoding:
Perl POD Document  |  2002-09-28  |  26.7 KB  |  1,161 lines
  1.  
  2. ###############################################################################
  3. ##                                                                           ##
  4. ##    Copyright (c) 2000 - 2002 by Steffen Beyer.                            ##
  5. ##    All rights reserved.                                                   ##
  6. ##                                                                           ##
  7. ##    This package is free software; you can redistribute it                 ##
  8. ##    and/or modify it under the same terms as Perl itself.                  ##
  9. ##                                                                           ##
  10. ###############################################################################
  11.  
  12. package Bit::Vector::Overload;
  13.  
  14. use strict;
  15. use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
  16.  
  17. use Bit::Vector;
  18.  
  19. require Exporter;
  20.  
  21. @ISA = qw(Exporter Bit::Vector);
  22.  
  23. @EXPORT = qw();
  24.  
  25. @EXPORT_OK = qw();
  26.  
  27. $VERSION = '6.3';
  28.  
  29. package Bit::Vector;
  30.  
  31. use Carp::Clan '^Bit::Vector\b';
  32.  
  33. use overload
  34.       '""' => '_stringify',
  35.     'bool' => '_boolean',
  36.        '!' => '_not_boolean',
  37.        '~' => '_complement',
  38.      'neg' => '_negate',
  39.      'abs' => '_absolute',
  40.        '.' => '_concat',
  41.        'x' => '_xerox',
  42.       '<<' => '_shift_left',
  43.       '>>' => '_shift_right',
  44.        '|' => '_union',
  45.        '&' => '_intersection',
  46.        '^' => '_exclusive_or',
  47.        '+' => '_add',
  48.        '-' => '_sub',
  49.        '*' => '_mul',
  50.        '/' => '_div',
  51.        '%' => '_mod',
  52.       '**' => '_pow',
  53.       '.=' => '_assign_concat',
  54.       'x=' => '_assign_xerox',
  55.      '<<=' => '_assign_shift_left',
  56.      '>>=' => '_assign_shift_right',
  57.       '|=' => '_assign_union',
  58.       '&=' => '_assign_intersection',
  59.       '^=' => '_assign_exclusive_or',
  60.       '+=' => '_assign_add',
  61.       '-=' => '_assign_sub',
  62.       '*=' => '_assign_mul',
  63.       '/=' => '_assign_div',
  64.       '%=' => '_assign_mod',
  65.      '**=' => '_assign_pow',
  66.       '++' => '_increment',
  67.       '--' => '_decrement',
  68.      'cmp' => '_lexicompare',  #  also enables lt, le, gt, ge, eq, ne
  69.      '<=>' => '_compare',
  70.       '==' => '_equal',
  71.       '!=' => '_not_equal',
  72.        '<' => '_less_than',
  73.       '<=' => '_less_equal',
  74.        '>' => '_greater_than',
  75.       '>=' => '_greater_equal',
  76.        '=' => '_clone',
  77. 'fallback' =>   undef;
  78.  
  79. $CONFIG[0] = 0;
  80. $CONFIG[1] = 0;
  81. $CONFIG[2] = 0;
  82.  
  83. #  Configuration:
  84. #
  85. #  0 = Scalar Input:        0 = Bit Index  (default)
  86. #                           1 = from_Hex
  87. #                           2 = from_Bin
  88. #                           3 = from_Dec
  89. #                           4 = from_Enum
  90. #
  91. #  1 = Operator Semantics:  0 = Set Ops    (default)
  92. #                           1 = Arithmetic Ops
  93. #
  94. #      Affected Operators:  "+"  "-"  "*"
  95. #                           "<"  "<="  ">"  ">="
  96. #                           "abs"
  97. #
  98. #  2 = String Output:       0 = to_Hex()   (default)
  99. #                           1 = to_Bin()
  100. #                           2 = to_Dec()
  101. #                           3 = to_Enum()
  102.  
  103. sub Configuration
  104. {
  105.     my(@commands);
  106.     my($assignment);
  107.     my($which,$value);
  108.     my($m0,$m1,$m2,$m3,$m4);
  109.     my($result);
  110.     my($ok);
  111.  
  112.     if (@_ > 2)
  113.     {
  114.         croak('Usage: $oldconfig = Bit::Vector->Configuration( [ $newconfig ] );');
  115.     }
  116.     $result  =   "Scalar Input       = ";
  117.     if    ($CONFIG[0] == 4) { $result .= "Enumeration"; }
  118.     elsif ($CONFIG[0] == 3) { $result .= "Decimal"; }
  119.     elsif ($CONFIG[0] == 2) { $result .= "Binary"; }
  120.     elsif ($CONFIG[0] == 1) { $result .= "Hexadecimal"; }
  121.     else                    { $result .= "Bit Index"; }
  122.     $result .= "\nOperator Semantics = ";
  123.     if    ($CONFIG[1] == 1) { $result .= "Arithmetic Operators"; }
  124.     else                    { $result .= "Set Operators"; }
  125.     $result .= "\nString Output      = ";
  126.     if    ($CONFIG[2] == 3) { $result .= "Enumeration"; }
  127.     elsif ($CONFIG[2] == 2) { $result .= "Decimal"; }
  128.     elsif ($CONFIG[2] == 1) { $result .= "Binary"; }
  129.     else                    { $result .= "Hexadecimal"; }
  130.     shift if (@_ > 0);
  131.     if (@_ > 0)
  132.     {
  133.         $ok = 1;
  134.         @commands = split(/[,;:|\/\n&+-]/, $_[0]);
  135.         foreach $assignment (@commands)
  136.         {
  137.             if    ($assignment =~ /^\s*$/) { }  #  ignore empty lines
  138.             elsif ($assignment =~ /^([A-Za-z\s]+)=([A-Za-z\s]+)$/)
  139.             {
  140.                 $which = $1;
  141.                 $value = $2;
  142.                 $m0 = 0;
  143.                 $m1 = 0;
  144.                 $m2 = 0;
  145.                 if ($which =~ /\bscalar|\binput|\bin\b/i)       { $m0 = 1; }
  146.                 if ($which =~ /\boperator|\bsemantic|\bops\b/i) { $m1 = 1; }
  147.                 if ($which =~ /\bstring|\boutput|\bout\b/i)     { $m2 = 1; }
  148.                 if    ($m0 && !$m1 && !$m2)
  149.                 {
  150.                     $m0 = 0;
  151.                     $m1 = 0;
  152.                     $m2 = 0;
  153.                     $m3 = 0;
  154.                     $m4 = 0;
  155.                     if ($value =~ /\bbit\b|\bindex|\bindice/i) { $m0 = 1; }
  156.                     if ($value =~ /\bhex/i)                    { $m1 = 1; }
  157.                     if ($value =~ /\bbin/i)                    { $m2 = 1; }
  158.                     if ($value =~ /\bdec/i)                    { $m3 = 1; }
  159.                     if ($value =~ /\benum/i)                   { $m4 = 1; }
  160.                     if    ($m0 && !$m1 && !$m2 && !$m3 && !$m4) { $CONFIG[0] = 0; }
  161.                     elsif (!$m0 && $m1 && !$m2 && !$m3 && !$m4) { $CONFIG[0] = 1; }
  162.                     elsif (!$m0 && !$m1 && $m2 && !$m3 && !$m4) { $CONFIG[0] = 2; }
  163.                     elsif (!$m0 && !$m1 && !$m2 && $m3 && !$m4) { $CONFIG[0] = 3; }
  164.                     elsif (!$m0 && !$m1 && !$m2 && !$m3 && $m4) { $CONFIG[0] = 4; }
  165.                     else                                        { $ok = 0; last; }
  166.                 }
  167.                 elsif (!$m0 && $m1 && !$m2)
  168.                 {
  169.                     $m0 = 0;
  170.                     $m1 = 0;
  171.                     if ($value =~ /\bset\b/i)      { $m0 = 1; }
  172.                     if ($value =~ /\barithmetic/i) { $m1 = 1; }
  173.                     if    ($m0 && !$m1) { $CONFIG[1] = 0; }
  174.                     elsif (!$m0 && $m1) { $CONFIG[1] = 1; }
  175.                     else                { $ok = 0; last; }
  176.                 }
  177.                 elsif (!$m0 && !$m1 && $m2)
  178.                 {
  179.                     $m0 = 0;
  180.                     $m1 = 0;
  181.                     $m2 = 0;
  182.                     $m3 = 0;
  183.                     if ($value =~ /\bhex/i)  { $m0 = 1; }
  184.                     if ($value =~ /\bbin/i)  { $m1 = 1; }
  185.                     if ($value =~ /\bdec/i)  { $m2 = 1; }
  186.                     if ($value =~ /\benum/i) { $m3 = 1; }
  187.                     if    ($m0 && !$m1 && !$m2 && !$m3) { $CONFIG[2] = 0; }
  188.                     elsif (!$m0 && $m1 && !$m2 && !$m3) { $CONFIG[2] = 1; }
  189.                     elsif (!$m0 && !$m1 && $m2 && !$m3) { $CONFIG[2] = 2; }
  190.                     elsif (!$m0 && !$m1 && !$m2 && $m3) { $CONFIG[2] = 3; }
  191.                     else                                { $ok = 0; last; }
  192.                 }
  193.                 else { $ok = 0; last; }
  194.             }
  195.             else { $ok = 0; last; }
  196.         }
  197.         unless ($ok)
  198.         {
  199.             croak('configuration string syntax error');
  200.         }
  201.     }
  202.     return($result);
  203. }
  204.  
  205. sub _error
  206. {
  207.     my($name,$code) = @_;
  208.     my($text);
  209.  
  210.     if ($code == 0)
  211.     {
  212.         $text = $@;
  213.         $text =~ s!\s+! !g;
  214.         $text =~ s!\s+at\s.*$!!;
  215.         $text =~ s!^(?:Bit::Vector::)?[a-zA-Z0-9_]+\(\):\s*!!i;
  216.         $text =~ s!\s+$!!;
  217.     }
  218.     elsif ($code == 1) { $text = 'illegal operand type'; }
  219.     elsif ($code == 2) { $text = 'illegal reversed operands'; }
  220.     else               { croak('unexpected internal error - please contact author'); }
  221.     $text .= " in overloaded ";
  222.     if (length($name) > 5) { $text .= "$name operation";  }
  223.     else                   { $text .= "'$name' operator"; }
  224.     croak($text);
  225. }
  226.  
  227. sub _vectorize_
  228. {
  229.     my($vector,$scalar) = @_;
  230.  
  231.     if    ($CONFIG[0] == 4) { $vector->from_Enum($scalar); }
  232.     elsif ($CONFIG[0] == 3) { $vector->from_Dec ($scalar); }
  233.     elsif ($CONFIG[0] == 2) { $vector->from_Bin ($scalar); }
  234.     elsif ($CONFIG[0] == 1) { $vector->from_Hex ($scalar); }
  235.     else                    { $vector->Bit_On   ($scalar); }
  236. }
  237.  
  238. sub _scalarize_
  239. {
  240.     my($vector) = @_;
  241.  
  242.     if    ($CONFIG[2] == 3) { return( $vector->to_Enum() ); }
  243.     elsif ($CONFIG[2] == 2) { return( $vector->to_Dec () ); }
  244.     elsif ($CONFIG[2] == 1) { return( $vector->to_Bin () ); }
  245.     else                    { return( $vector->to_Hex () ); }
  246. }
  247.  
  248. sub _fetch_operand
  249. {
  250.     my($object,$argument,$flag,$name,$build) = @_;
  251.     my($operand);
  252.  
  253.     if ((defined $argument) && ref($argument) && (ref($argument) !~ /^[A-Z]+$/))
  254.     {
  255.         eval
  256.         {
  257.             if ($build && (defined $flag))
  258.             {
  259.                 $operand = $argument->Clone();
  260.             }
  261.             else { $operand = $argument; }
  262.         };
  263.         if ($@) { &_error($name,0); }
  264.     }
  265.     elsif ((defined $argument) && (!ref($argument)))
  266.     {
  267.         eval
  268.         {
  269.             $operand = $object->Shadow();
  270.             &_vectorize_($operand,$argument);
  271.         };
  272.         if ($@) { &_error($name,0); }
  273.     }
  274.     else { &_error($name,1); }
  275.     return($operand);
  276. }
  277.  
  278. sub _check_operand
  279. {
  280.     my($argument,$flag,$name) = @_;
  281.  
  282.     if ((defined $argument) && (!ref($argument)))
  283.     {
  284.         if ((defined $flag) && $flag) { &_error($name,2); }
  285.     }
  286.     else { &_error($name,1); }
  287. }
  288.  
  289. sub _stringify
  290. {
  291.     my($vector) = @_;
  292.     my($name) = 'string interpolation';
  293.     my($result);
  294.  
  295.     eval
  296.     {
  297.         $result = &_scalarize_($vector);
  298.     };
  299.     if ($@) { &_error($name,0); }
  300.     return($result);
  301. }
  302.  
  303. sub _boolean
  304. {
  305.     my($object) = @_;
  306.     my($name) = 'boolean test';
  307.     my($result);
  308.  
  309.     eval
  310.     {
  311.         $result = $object->is_empty();
  312.     };
  313.     if ($@) { &_error($name,0); }
  314.     return(! $result);
  315. }
  316.  
  317. sub _not_boolean
  318. {
  319.     my($object) = @_;
  320.     my($name) = 'negated boolean test';
  321.     my($result);
  322.  
  323.     eval
  324.     {
  325.         $result = $object->is_empty();
  326.     };
  327.     if ($@) { &_error($name,0); }
  328.     return($result);
  329. }
  330.  
  331. sub _complement
  332. {
  333.     my($object) = @_;
  334.     my($name) = '~';
  335.     my($result);
  336.  
  337.     eval
  338.     {
  339.         $result = $object->Shadow();
  340.         $result->Complement($object);
  341.     };
  342.     if ($@) { &_error($name,0); }
  343.     return($result);
  344. }
  345.  
  346. sub _negate
  347. {
  348.     my($object) = @_;
  349.     my($name) = 'unary minus';
  350.     my($result);
  351.  
  352.     eval
  353.     {
  354.         $result = $object->Shadow();
  355.         $result->Negate($object);
  356.     };
  357.     if ($@) { &_error($name,0); }
  358.     return($result);
  359. }
  360.  
  361. sub _absolute
  362. {
  363.     my($object) = @_;
  364.     my($name) = 'abs()';
  365.     my($result);
  366.  
  367.     eval
  368.     {
  369.         if ($CONFIG[1] == 1)
  370.         {
  371.             $result = $object->Shadow();
  372.             $result->Absolute($object);
  373.         }
  374.         else
  375.         {
  376.             $result = $object->Norm();
  377.         }
  378.     };
  379.     if ($@) { &_error($name,0); }
  380.     return($result);
  381. }
  382.  
  383. sub _concat
  384. {
  385.     my($object,$argument,$flag) = @_;
  386.     my($name) = '.';
  387.     my($result);
  388.  
  389.     $name .= '=' unless (defined $flag);
  390.     if ((defined $argument) && ref($argument) && (ref($argument) !~ /^[A-Z]+$/))
  391.     {
  392.         eval
  393.         {
  394.             if (defined $flag)
  395.             {
  396.                 if ($flag) { $result = $argument->Concat($object); }
  397.                 else       { $result = $object->Concat($argument); }
  398.             }
  399.             else
  400.             {
  401.                 $object->Interval_Substitute($argument,0,0,0,$argument->Size());
  402.                 $result = $object;
  403.             }
  404.         };
  405.         if ($@) { &_error($name,0); }
  406.         return($result);
  407.     }
  408.     elsif ((defined $argument) && (!ref($argument)))
  409.     {
  410.         eval
  411.         {
  412.             if (defined $flag)
  413.             {
  414.                 if ($flag) { $result = $argument . &_scalarize_($object); }
  415.                 else       { $result = &_scalarize_($object) . $argument; }
  416.             }
  417.             else
  418.             {
  419.                 if    ($CONFIG[0] == 2) { $result = $object->new( length($argument) ); }
  420.                 elsif ($CONFIG[0] == 1) { $result = $object->new( length($argument) << 2 ); }
  421.                 else                    { $result = $object->Shadow(); }
  422.                 &_vectorize_($result,$argument);
  423.                 $object->Interval_Substitute($result,0,0,0,$result->Size());
  424.                 $result = $object;
  425.             }
  426.         };
  427.         if ($@) { &_error($name,0); }
  428.         return($result);
  429.     }
  430.     else { &_error($name,1); }
  431. }
  432.  
  433. sub _xerox  #  (in Brazil, a photocopy is called a "xerox")
  434. {
  435.     my($object,$argument,$flag) = @_;
  436.     my($name) = 'x';
  437.     my($result);
  438.     my($offset);
  439.     my($index);
  440.     my($size);
  441.  
  442.     $name .= '=' unless (defined $flag);
  443.     &_check_operand($argument,$flag,$name);
  444.     eval
  445.     {
  446.         $size = $object->Size();
  447.         if (defined $flag)
  448.         {
  449.             $result = $object->new($size * $argument);
  450.             $offset = 0;
  451.             $index = 0;
  452.         }
  453.         else
  454.         {
  455.             $result = $object;
  456.             $result->Resize($size * $argument);
  457.             $offset = $size;
  458.             $index = 1;
  459.         }
  460.         for ( ; $index < $argument; $index++, $offset += $size )
  461.         {
  462.             $result->Interval_Copy($object,$offset,0,$size);
  463.         }
  464.     };
  465.     if ($@) { &_error($name,0); }
  466.     return($result);
  467. }
  468.  
  469. sub _shift_left
  470. {
  471.     my($object,$argument,$flag) = @_;
  472.     my($name) = '<<';
  473.     my($result);
  474.  
  475.     $name .= '=' unless (defined $flag);
  476.     &_check_operand($argument,$flag,$name);
  477.     eval
  478.     {
  479.         if (defined $flag)
  480.         {
  481.             $result = $object->Clone();
  482.             $result->Insert(0,$argument);
  483. #           $result->Move_Left($argument);
  484.         }
  485.         else
  486.         {
  487. #           $object->Move_Left($argument);
  488.             $object->Insert(0,$argument);
  489.             $result = $object;
  490.         }
  491.     };
  492.     if ($@) { &_error($name,0); }
  493.     return($result);
  494. }
  495.  
  496. sub _shift_right
  497. {
  498.     my($object,$argument,$flag) = @_;
  499.     my($name) = '>>';
  500.     my($result);
  501.  
  502.     $name .= '=' unless (defined $flag);
  503.     &_check_operand($argument,$flag,$name);
  504.     eval
  505.     {
  506.         if (defined $flag)
  507.         {
  508.             $result = $object->Clone();
  509.             $result->Delete(0,$argument);
  510. #           $result->Move_Right($argument);
  511.         }
  512.         else
  513.         {
  514. #           $object->Move_Right($argument);
  515.             $object->Delete(0,$argument);
  516.             $result = $object;
  517.         }
  518.     };
  519.     if ($@) { &_error($name,0); }
  520.     return($result);
  521. }
  522.  
  523. sub _union_
  524. {
  525.     my($object,$operand,$flag) = @_;
  526.  
  527.     if (defined $flag)
  528.     {
  529.         $operand->Union($object,$operand);
  530.         return($operand);
  531.     }
  532.     else
  533.     {
  534.         $object->Union($object,$operand);
  535.         return($object);
  536.     }
  537. }
  538.  
  539. sub _union
  540. {
  541.     my($object,$argument,$flag) = @_;
  542.     my($name) = '|';
  543.     my($operand);
  544.  
  545.     $name .= '=' unless (defined $flag);
  546.     $operand = &_fetch_operand($object,$argument,$flag,$name,1);
  547.     eval
  548.     {
  549.         $operand = &_union_($object,$operand,$flag);
  550.     };
  551.     if ($@) { &_error($name,0); }
  552.     return($operand);
  553. }
  554.  
  555. sub _intersection_
  556. {
  557.     my($object,$operand,$flag) = @_;
  558.  
  559.     if (defined $flag)
  560.     {
  561.         $operand->Intersection($object,$operand);
  562.         return($operand);
  563.     }
  564.     else
  565.     {
  566.         $object->Intersection($object,$operand);
  567.         return($object);
  568.     }
  569. }
  570.  
  571. sub _intersection
  572. {
  573.     my($object,$argument,$flag) = @_;
  574.     my($name) = '&';
  575.     my($operand);
  576.  
  577.     $name .= '=' unless (defined $flag);
  578.     $operand = &_fetch_operand($object,$argument,$flag,$name,1);
  579.     eval
  580.     {
  581.         $operand = &_intersection_($object,$operand,$flag);
  582.     };
  583.     if ($@) { &_error($name,0); }
  584.     return($operand);
  585. }
  586.  
  587. sub _exclusive_or
  588. {
  589.     my($object,$argument,$flag) = @_;
  590.     my($name) = '^';
  591.     my($operand);
  592.  
  593.     $name .= '=' unless (defined $flag);
  594.     $operand = &_fetch_operand($object,$argument,$flag,$name,1);
  595.     eval
  596.     {
  597.         if (defined $flag)
  598.         {
  599.             $operand->ExclusiveOr($object,$operand);
  600.         }
  601.         else
  602.         {
  603.             $object->ExclusiveOr($object,$operand);
  604.             $operand = $object;
  605.         }
  606.     };
  607.     if ($@) { &_error($name,0); }
  608.     return($operand);
  609. }
  610.  
  611. sub _add
  612. {
  613.     my($object,$argument,$flag) = @_;
  614.     my($name) = '+';
  615.     my($operand);
  616.  
  617.     $name .= '=' unless (defined $flag);
  618.     $operand = &_fetch_operand($object,$argument,$flag,$name,1);
  619.     eval
  620.     {
  621.         if ($CONFIG[1] == 1)
  622.         {
  623.             if (defined $flag)
  624.             {
  625.                 $operand->add($object,$operand,0);
  626.             }
  627.             else
  628.             {
  629.                 $object->add($object,$operand,0);
  630.                 $operand = $object;
  631.             }
  632.         }
  633.         else
  634.         {
  635.             $operand = &_union_($object,$operand,$flag);
  636.         }
  637.     };
  638.     if ($@) { &_error($name,0); }
  639.     return($operand);
  640. }
  641.  
  642. sub _sub
  643. {
  644.     my($object,$argument,$flag) = @_;
  645.     my($name) = '-';
  646.     my($operand);
  647.  
  648.     $name .= '=' unless (defined $flag);
  649.     $operand = &_fetch_operand($object,$argument,$flag,$name,1);
  650.     eval
  651.     {
  652.         if ($CONFIG[1] == 1)
  653.         {
  654.             if (defined $flag)
  655.             {
  656.                 if ($flag) { $operand->subtract($operand,$object,0); }
  657.                 else       { $operand->subtract($object,$operand,0); }
  658.             }
  659.             else
  660.             {
  661.                 $object->subtract($object,$operand,0);
  662.                 $operand = $object;
  663.             }
  664.         }
  665.         else
  666.         {
  667.             if (defined $flag)
  668.             {
  669.                 if ($flag) { $operand->Difference($operand,$object); }
  670.                 else       { $operand->Difference($object,$operand); }
  671.             }
  672.             else
  673.             {
  674.                 $object->Difference($object,$operand);
  675.                 $operand = $object;
  676.             }
  677.         }
  678.     };
  679.     if ($@) { &_error($name,0); }
  680.     return($operand);
  681. }
  682.  
  683. sub _mul
  684. {
  685.     my($object,$argument,$flag) = @_;
  686.     my($name) = '*';
  687.     my($operand);
  688.  
  689.     $name .= '=' unless (defined $flag);
  690.     $operand = &_fetch_operand($object,$argument,$flag,$name,1);
  691.     eval
  692.     {
  693.         if ($CONFIG[1] == 1)
  694.         {
  695.             if (defined $flag)
  696.             {
  697.                 $operand->Multiply($object,$operand);
  698.             }
  699.             else
  700.             {
  701.                 $object->Multiply($object,$operand);
  702.                 $operand = $object;
  703.             }
  704.         }
  705.         else
  706.         {
  707.             $operand = &_intersection_($object,$operand,$flag);
  708.         }
  709.     };
  710.     if ($@) { &_error($name,0); }
  711.     return($operand);
  712. }
  713.  
  714. sub _div
  715. {
  716.     my($object,$argument,$flag) = @_;
  717.     my($name) = '/';
  718.     my($operand);
  719.     my($temp);
  720.  
  721.     $name .= '=' unless (defined $flag);
  722.     $operand = &_fetch_operand($object,$argument,$flag,$name,1);
  723.     eval
  724.     {
  725.         $temp = $object->Shadow();
  726.         if (defined $flag)
  727.         {
  728.             if ($flag) { $operand->Divide($operand,$object,$temp); }
  729.             else       { $operand->Divide($object,$operand,$temp); }
  730.         }
  731.         else
  732.         {
  733.             $object->Divide($object,$operand,$temp);
  734.             $operand = $object;
  735.         }
  736.     };
  737.     if ($@) { &_error($name,0); }
  738.     return($operand);
  739. }
  740.  
  741. sub _mod
  742. {
  743.     my($object,$argument,$flag) = @_;
  744.     my($name) = '%';
  745.     my($operand);
  746.     my($temp);
  747.  
  748.     $name .= '=' unless (defined $flag);
  749.     $operand = &_fetch_operand($object,$argument,$flag,$name,1);
  750.     eval
  751.     {
  752.         $temp = $object->Shadow();
  753.         if (defined $flag)
  754.         {
  755.             if ($flag) { $temp->Divide($operand,$object,$operand); }
  756.             else       { $temp->Divide($object,$operand,$operand); }
  757.         }
  758.         else
  759.         {
  760.             $temp->Divide($object,$operand,$object);
  761.             $operand = $object;
  762.         }
  763.     };
  764.     if ($@) { &_error($name,0); }
  765.     return($operand);
  766. }
  767.  
  768. sub _pow
  769. {
  770.     my($object,$argument,$flag) = @_;
  771.     my($name) = '**';
  772.     my($operand,$result);
  773.  
  774.     $name .= '=' unless (defined $flag);
  775.     $operand = &_fetch_operand($object,$argument,$flag,$name,0);
  776.     eval
  777.     {
  778.         if (defined $flag)
  779.         {
  780.             $result = $object->Shadow();
  781.             if ($flag) { $result->Power($operand,$object); }
  782.             else       { $result->Power($object,$operand); }
  783.         }
  784.         else
  785.         {
  786.             $object->Power($object,$operand);
  787.             $result = $object;
  788.         }
  789.     };
  790.     if ($@) { &_error($name,0); }
  791.     return($result);
  792. }
  793.  
  794. sub _assign_concat
  795. {
  796.     my($object,$argument) = @_;
  797.  
  798.     return( &_concat($object,$argument,undef) );
  799. }
  800.  
  801. sub _assign_xerox
  802. {
  803.     my($object,$argument) = @_;
  804.  
  805.     return( &_xerox($object,$argument,undef) );
  806. }
  807.  
  808. sub _assign_shift_left
  809. {
  810.     my($object,$argument) = @_;
  811.  
  812.     return( &_shift_left($object,$argument,undef) );
  813. }
  814.  
  815. sub _assign_shift_right
  816. {
  817.     my($object,$argument) = @_;
  818.  
  819.     return( &_shift_right($object,$argument,undef) );
  820. }
  821.  
  822. sub _assign_union
  823. {
  824.     my($object,$argument) = @_;
  825.  
  826.     return( &_union($object,$argument,undef) );
  827. }
  828.  
  829. sub _assign_intersection
  830. {
  831.     my($object,$argument) = @_;
  832.  
  833.     return( &_intersection($object,$argument,undef) );
  834. }
  835.  
  836. sub _assign_exclusive_or
  837. {
  838.     my($object,$argument) = @_;
  839.  
  840.     return( &_exclusive_or($object,$argument,undef) );
  841. }
  842.  
  843. sub _assign_add
  844. {
  845.     my($object,$argument) = @_;
  846.  
  847.     return( &_add($object,$argument,undef) );
  848. }
  849.  
  850. sub _assign_sub
  851. {
  852.     my($object,$argument) = @_;
  853.  
  854.     return( &_sub($object,$argument,undef) );
  855. }
  856.  
  857. sub _assign_mul
  858. {
  859.     my($object,$argument) = @_;
  860.  
  861.     return( &_mul($object,$argument,undef) );
  862. }
  863.  
  864. sub _assign_div
  865. {
  866.     my($object,$argument) = @_;
  867.  
  868.     return( &_div($object,$argument,undef) );
  869. }
  870.  
  871. sub _assign_mod
  872. {
  873.     my($object,$argument) = @_;
  874.  
  875.     return( &_mod($object,$argument,undef) );
  876. }
  877.  
  878. sub _assign_pow
  879. {
  880.     my($object,$argument) = @_;
  881.  
  882.     return( &_pow($object,$argument,undef) );
  883. }
  884.  
  885. sub _increment
  886. {
  887.     my($object) = @_;
  888.     my($name) = '++';
  889.     my($result);
  890.  
  891.     eval
  892.     {
  893.         $result = $object->increment();
  894.     };
  895.     if ($@) { &_error($name,0); }
  896.     return($result);
  897. }
  898.  
  899. sub _decrement
  900. {
  901.     my($object) = @_;
  902.     my($name) = '--';
  903.     my($result);
  904.  
  905.     eval
  906.     {
  907.         $result = $object->decrement();
  908.     };
  909.     if ($@) { &_error($name,0); }
  910.     return($result);
  911. }
  912.  
  913. sub _lexicompare
  914. {
  915.     my($object,$argument,$flag) = @_;
  916.     my($name) = 'cmp';
  917.     my($operand);
  918.     my($result);
  919.  
  920.     $operand = &_fetch_operand($object,$argument,$flag,$name,0);
  921.     eval
  922.     {
  923.         if ((defined $flag) && $flag)
  924.         {
  925.             $result = $operand->Lexicompare($object);
  926.         }
  927.         else
  928.         {
  929.             $result = $object->Lexicompare($operand);
  930.         }
  931.     };
  932.     if ($@) { &_error($name,0); }
  933.     return($result);
  934. }
  935.  
  936. sub _compare
  937. {
  938.     my($object,$argument,$flag) = @_;
  939.     my($name) = '<=>';
  940.     my($operand);
  941.     my($result);
  942.  
  943.     $operand = &_fetch_operand($object,$argument,$flag,$name,0);
  944.     eval
  945.     {
  946.         if ((defined $flag) && $flag)
  947.         {
  948.             $result = $operand->Compare($object);
  949.         }
  950.         else
  951.         {
  952.             $result = $object->Compare($operand);
  953.         }
  954.     };
  955.     if ($@) { &_error($name,0); }
  956.     return($result);
  957. }
  958.  
  959. sub _equal
  960. {
  961.     my($object,$argument,$flag) = @_;
  962.     my($name) = '==';
  963.     my($operand);
  964.     my($result);
  965.  
  966.     $operand = &_fetch_operand($object,$argument,$flag,$name,0);
  967.     eval
  968.     {
  969.         $result = $object->equal($operand);
  970.     };
  971.     if ($@) { &_error($name,0); }
  972.     return($result);
  973. }
  974.  
  975. sub _not_equal
  976. {
  977.     my($object,$argument,$flag) = @_;
  978.     my($name) = '!=';
  979.     my($operand);
  980.     my($result);
  981.  
  982.     $operand = &_fetch_operand($object,$argument,$flag,$name,0);
  983.     eval
  984.     {
  985.         $result = $object->equal($operand);
  986.     };
  987.     if ($@) { &_error($name,0); }
  988.     return(! $result);
  989. }
  990.  
  991. sub _less_than
  992. {
  993.     my($object,$argument,$flag) = @_;
  994.     my($name) = '<';
  995.     my($operand);
  996.     my($result);
  997.  
  998.     $operand = &_fetch_operand($object,$argument,$flag,$name,0);
  999.     eval
  1000.     {
  1001.         if ($CONFIG[1] == 1)
  1002.         {
  1003.             if ((defined $flag) && $flag)
  1004.             {
  1005.                 $result = ($operand->Compare($object) < 0);
  1006.             }
  1007.             else
  1008.             {
  1009.                 $result = ($object->Compare($operand) < 0);
  1010.             }
  1011.         }
  1012.         else
  1013.         {
  1014.             if ((defined $flag) && $flag)
  1015.             {
  1016.                 $result = ((!$operand->equal($object)) &&
  1017.                             ($operand->subset($object)));
  1018.             }
  1019.             else
  1020.             {
  1021.                 $result = ((!$object->equal($operand)) &&
  1022.                             ($object->subset($operand)));
  1023.             }
  1024.         }
  1025.     };
  1026.     if ($@) { &_error($name,0); }
  1027.     return($result);
  1028. }
  1029.  
  1030. sub _less_equal
  1031. {
  1032.     my($object,$argument,$flag) = @_;
  1033.     my($name) = '<=';
  1034.     my($operand);
  1035.     my($result);
  1036.  
  1037.     $operand = &_fetch_operand($object,$argument,$flag,$name,0);
  1038.     eval
  1039.     {
  1040.         if ($CONFIG[1] == 1)
  1041.         {
  1042.             if ((defined $flag) && $flag)
  1043.             {
  1044.                 $result = ($operand->Compare($object) <= 0);
  1045.             }
  1046.             else
  1047.             {
  1048.                 $result = ($object->Compare($operand) <= 0);
  1049.             }
  1050.         }
  1051.         else
  1052.         {
  1053.             if ((defined $flag) && $flag)
  1054.             {
  1055.                 $result = $operand->subset($object);
  1056.             }
  1057.             else
  1058.             {
  1059.                 $result = $object->subset($operand);
  1060.             }
  1061.         }
  1062.     };
  1063.     if ($@) { &_error($name,0); }
  1064.     return($result);
  1065. }
  1066.  
  1067. sub _greater_than
  1068. {
  1069.     my($object,$argument,$flag) = @_;
  1070.     my($name) = '>';
  1071.     my($operand);
  1072.     my($result);
  1073.  
  1074.     $operand = &_fetch_operand($object,$argument,$flag,$name,0);
  1075.     eval
  1076.     {
  1077.         if ($CONFIG[1] == 1)
  1078.         {
  1079.             if ((defined $flag) && $flag)
  1080.             {
  1081.                 $result = ($operand->Compare($object) > 0);
  1082.             }
  1083.             else
  1084.             {
  1085.                 $result = ($object->Compare($operand) > 0);
  1086.             }
  1087.         }
  1088.         else
  1089.         {
  1090.             if ((defined $flag) && $flag)
  1091.             {
  1092.                 $result = ((!$object->equal($operand)) &&
  1093.                             ($object->subset($operand)));
  1094.             }
  1095.             else
  1096.             {
  1097.                 $result = ((!$operand->equal($object)) &&
  1098.                             ($operand->subset($object)));
  1099.             }
  1100.         }
  1101.     };
  1102.     if ($@) { &_error($name,0); }
  1103.     return($result);
  1104. }
  1105.  
  1106. sub _greater_equal
  1107. {
  1108.     my($object,$argument,$flag) = @_;
  1109.     my($name) = '>=';
  1110.     my($operand);
  1111.     my($result);
  1112.  
  1113.     $operand = &_fetch_operand($object,$argument,$flag,$name,0);
  1114.     eval
  1115.     {
  1116.         if ($CONFIG[1] == 1)
  1117.         {
  1118.             if ((defined $flag) && $flag)
  1119.             {
  1120.                 $result = ($operand->Compare($object) >= 0);
  1121.             }
  1122.             else
  1123.             {
  1124.                 $result = ($object->Compare($operand) >= 0);
  1125.             }
  1126.         }
  1127.         else
  1128.         {
  1129.             if ((defined $flag) && $flag)
  1130.             {
  1131.                 $result = $object->subset($operand);
  1132.             }
  1133.             else
  1134.             {
  1135.                 $result = $operand->subset($object);
  1136.             }
  1137.         }
  1138.     };
  1139.     if ($@) { &_error($name,0); }
  1140.     return($result);
  1141. }
  1142.  
  1143. sub _clone
  1144. {
  1145.     my($object) = @_;
  1146.     my($name) = 'automatic duplication';
  1147.     my($result);
  1148.  
  1149.     eval
  1150.     {
  1151.         $result = $object->Clone();
  1152.     };
  1153.     if ($@) { &_error($name,0); }
  1154.     return($result);
  1155. }
  1156.  
  1157. 1;
  1158.  
  1159. __END__
  1160.  
  1161.