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