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