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