1 2############################################################################### 3## ## 4## Copyright (c) 2000 - 2013 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 12package Bit::Vector::Overload; 13 14use strict; 15use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); 16 17use Bit::Vector; 18 19require Exporter; 20 21@ISA = qw(Exporter Bit::Vector); 22 23@EXPORT = qw(); 24 25@EXPORT_OK = qw(); 26 27$VERSION = '7.4'; 28 29package Bit::Vector; 30 31use Carp::Clan '^Bit::Vector\b'; 32 33use 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 103sub 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 205sub _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 227sub _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 238sub _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 248sub _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 278sub _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 289sub _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 303sub _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 317sub _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 331sub _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 346sub _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 361sub _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 383sub _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 433sub _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 469sub _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 496sub _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 523sub _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 539sub _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 555sub _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 571sub _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 587sub _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 611sub _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 642sub _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 683sub _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 714sub _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 741sub _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 768sub _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 794sub _assign_concat 795{ 796 my($object,$argument) = @_; 797 798 return( &_concat($object,$argument,undef) ); 799} 800 801sub _assign_xerox 802{ 803 my($object,$argument) = @_; 804 805 return( &_xerox($object,$argument,undef) ); 806} 807 808sub _assign_shift_left 809{ 810 my($object,$argument) = @_; 811 812 return( &_shift_left($object,$argument,undef) ); 813} 814 815sub _assign_shift_right 816{ 817 my($object,$argument) = @_; 818 819 return( &_shift_right($object,$argument,undef) ); 820} 821 822sub _assign_union 823{ 824 my($object,$argument) = @_; 825 826 return( &_union($object,$argument,undef) ); 827} 828 829sub _assign_intersection 830{ 831 my($object,$argument) = @_; 832 833 return( &_intersection($object,$argument,undef) ); 834} 835 836sub _assign_exclusive_or 837{ 838 my($object,$argument) = @_; 839 840 return( &_exclusive_or($object,$argument,undef) ); 841} 842 843sub _assign_add 844{ 845 my($object,$argument) = @_; 846 847 return( &_add($object,$argument,undef) ); 848} 849 850sub _assign_sub 851{ 852 my($object,$argument) = @_; 853 854 return( &_sub($object,$argument,undef) ); 855} 856 857sub _assign_mul 858{ 859 my($object,$argument) = @_; 860 861 return( &_mul($object,$argument,undef) ); 862} 863 864sub _assign_div 865{ 866 my($object,$argument) = @_; 867 868 return( &_div($object,$argument,undef) ); 869} 870 871sub _assign_mod 872{ 873 my($object,$argument) = @_; 874 875 return( &_mod($object,$argument,undef) ); 876} 877 878sub _assign_pow 879{ 880 my($object,$argument) = @_; 881 882 return( &_pow($object,$argument,undef) ); 883} 884 885sub _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 899sub _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 913sub _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 936sub _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 959sub _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 975sub _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 991sub _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 1030sub _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 1067sub _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 1106sub _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 1143sub _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 11571; 1158 1159__END__ 1160 1161