File Coverage

blib/lib/Bit/Vector/Overload.pm

Criterion	Covered	Total	%
statement	310	608	51.0
branch	96	296	32.4
condition	34	189	18.0
subroutine	45	56	80.4
pod			n/a
total	485	1149	42.2

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