File Coverage

blib/lib/Math/RPN.pm
Criterion Covered Total %
statement 166 237 70.0
branch 140 180 77.7
condition 44 58 75.8
subroutine 7 7 100.0
pod 0 3 0.0
total 357 485 73.6


line stmt bran cond sub pod time code
1             package Math::RPN;
2              
3 2     2   51641 use 5.006;
  2         7  
  2         76  
4 2     2   9 use strict;
  2         5  
  2         55  
5 2     2   9 use warnings;
  2         7  
  2         58  
6 2     2   10 use vars qw($VERSION @ISA @EXPORT);
  2         3  
  2         5720  
7              
8             require Exporter;
9              
10             @ISA = qw(Exporter);
11             @EXPORT = qw( rpn );
12             $VERSION = '1.11';
13              
14             sub rpn {
15 144     144 0 68778 my $convr = join( ",", @_ ); # Get all the expressions
16 144         240 $convr =~ s/,,//g; # In case someone gave us extra ,'s
17 144         184 my @stack = ();
18 144         505 my @ops = split( /,/, $convr );
19 144         187 my $inbrace = 0;
20 144         153 my $bracexp = "";
21 144         150 my @completed = ();
22 144         295 while (@ops) {
23 796         1107 $_ = uc( shift(@ops) );
24 796         1194 s/\s+//g; # Eliminate unneeded spaces
25 796 100       1786 if ( $_ eq "{" ) {
    100          
26 20 100       38 if ($inbrace) {
27 1         7 logmsg(
28             'err',
29             "Cannot nest braces expr ",
30             join( ",", @completed ),
31             ",<<<$_>>>,", join( ",", @ops )
32             );
33 1         75 last;
34             }
35 19         19 $inbrace++;
36 19         37 $bracexp = "";
37 19         34 next;
38             }
39             elsif ( $_ eq "}" ) {
40 19 100       32 unless ($inbrace) {
41 1         6 logmsg(
42             'err',
43             "Unexpected Right Brace ",
44             join( ",", @completed ),
45             ",<<<$_>>>,", join( ",", @ops )
46             );
47 1         49 last;
48             }
49 18         19 $inbrace--;
50 18         61 $bracexp =~ s/,$//; # Strip trailing comma if any
51 18         50 push( @stack, $bracexp );
52 18         50 next;
53             }
54 757 100       1184 if ($inbrace) {
55 90         100 $bracexp .= $_ . ",";
56 90         145 next;
57             }
58              
59 667 100 66     25559 if ( $_ eq "+" || $_ eq "ADD" ) {
    100 66        
    100 66        
    100 66        
    100 100        
    100 100        
    100 66        
    100 100        
    100 100        
    100 100        
    100 66        
    100 66        
    100 33        
    100 33        
    100 66        
    100 66        
    100 66        
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
60 13 100       38 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
61 1         2 @stack = (undef);
62 1         2 last;
63             }
64 12         41 push( @stack, pop(@stack) + pop(@stack) );
65             }
66             elsif ( $_ eq "++" || $_ eq "INCR" ) {
67 15 50       29 unless ( stackcheck( 1, \@stack, \@completed, $_, \@ops ) ) {
68 0         0 @stack = (undef);
69 0         0 last;
70             }
71 15         25 push( @stack, pop(@stack) + 1 );
72             }
73             elsif ( $_ eq "-" || $_ eq "SUB" ) {
74 3 50       7 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
75 0         0 @stack = (undef);
76 0         0 last;
77             }
78 3         7 my $v1 = pop(@stack);
79 3         3 my $v2 = pop(@stack);
80 3         7 push( @stack, $v2 - $v1 );
81             }
82             elsif ( $_ eq "--" || $_ eq "DECR" ) {
83 15 50       41 unless ( stackcheck( 1, \@stack, \@completed, $_, \@ops ) ) {
84 0         0 @stack = (undef);
85 0         0 last;
86             }
87 15         32 push( @stack, pop(@stack) - 1 );
88             }
89             elsif ( $_ eq "\*" || $_ eq "MUL" ) {
90 42 50       98 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
91 0         0 @stack = (undef);
92 0         0 last;
93             }
94 42         98 push( @stack, pop(@stack) * pop(@stack) );
95             }
96             elsif ( $_ eq "\/" || $_ eq "DIV" ) {
97 15 50       45 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
98 0         0 @stack = (undef);
99 0         0 last;
100             }
101 15         21 my $v1 = pop(@stack);
102 15         18 my $v2 = pop(@stack);
103 15         28 push( @stack, $v2 / $v1 );
104             }
105             elsif ( $_ eq "%" || $_ eq "MOD" ) {
106 3 50       9 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
107 0         0 @stack = (undef);
108 0         0 last;
109             }
110 3         5 my $v1 = pop(@stack);
111 3         3 my $v2 = pop(@stack);
112 3         7 push( @stack, $v2 % $v1 );
113             }
114             elsif ( $_ eq "POW" ) {
115 3 50       7 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
116 0         0 @stack = (undef);
117 0         0 last;
118             }
119 3         4 my $v1 = pop(@stack);
120 3         4 my $v2 = pop(@stack);
121 3         5 push( @stack, $v2**$v1 );
122             }
123             elsif ( $_ eq "SQRT" ) {
124 3 50       5 unless ( stackcheck( 1, \@stack, \@completed, $_, \@ops ) ) {
125 0         0 @stack = (undef);
126 0         0 last;
127             }
128 3         12 push( @stack, sqrt( pop(@stack) ) );
129             }
130             elsif ( $_ eq "ABS" ) {
131 3 50       8 unless ( stackcheck( 1, \@stack, \@completed, $_, \@ops ) ) {
132 0         0 @stack = (undef);
133 0         0 last;
134             }
135 3         7 push( @stack, abs( pop(@stack) ) );
136             }
137             elsif ( $_ eq "&" || $_ eq "AND" ) {
138 6 50       22 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
139 0         0 @stack = (undef);
140 0         0 last;
141             }
142 6         15 my $v1 = int( pop(@stack) );
143 6         8 my $v2 = int( pop(@stack) );
144 6         14 push( @stack, ( $v1 & $v2 ) );
145             }
146             elsif ( $_ eq "|" || $_ eq "OR" ) {
147 6 50       16 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
148 0         0 @stack = (undef);
149 0         0 last;
150             }
151 6         18 push( @stack, ( int( pop(@stack) ) | int( pop(@stack) ) ) );
152             }
153             elsif ( $_ eq "XOR" ) {
154 24 50       102 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
155 0         0 @stack = (undef);
156 0         0 last;
157             }
158 24   100     114 push( @stack, ( int( pop(@stack) ) xor int( pop(@stack) ) ) );
159             }
160             elsif ( $_ eq "!" || $_ eq "NOT" ) {
161 6 50       15 unless ( stackcheck( 1, \@stack, \@completed, $_, \@ops ) ) {
162 0         0 @stack = (undef);
163 0         0 last;
164             }
165 6         17 push( @stack, !( int( pop(@stack) ) ) );
166             }
167             elsif ( $_ eq "~" ) {
168 9 50       25 unless ( stackcheck( 1, \@stack, \@completed, $_, \@ops ) ) {
169 0         0 @stack = (undef);
170 0         0 last;
171             }
172 9         20 push( @stack, ~( int( pop(@stack) ) ) );
173             }
174             elsif ( $_ eq "SIN" ) {
175 3 50       9 unless ( stackcheck( 1, \@stack, \@completed, $_, \@ops ) ) {
176 0         0 @stack = (undef);
177 0         0 last;
178             }
179 3         17 push( @stack, sin( pop(@stack) ) );
180             }
181             elsif ( $_ eq "COS" ) {
182 3 50       10 unless ( stackcheck( 1, \@stack, \@completed, $_, \@ops ) ) {
183 0         0 @stack = (undef);
184 0         0 last;
185             }
186 3         26 push( @stack, cos( pop(@stack) ) );
187             }
188             elsif ( $_ eq "TAN" ) {
189 3 50       11 unless ( stackcheck( 1, \@stack, \@completed, $_, \@ops ) ) {
190 0         0 @stack = (undef);
191 0         0 last;
192             }
193 3         5 my $v1 = pop(@stack);
194 3         26 push( @stack, ( sin($v1) / cos($v1) ) );
195             }
196             elsif ( $_ eq "LOG" ) {
197 3 50       14 unless ( stackcheck( 1, \@stack, \@completed, $_, \@ops ) ) {
198 0         0 @stack = (undef);
199 0         0 last;
200             }
201 3         16 push( @stack, log( pop(@stack) ) );
202             }
203             elsif ( $_ eq "EXP" ) {
204 3 50       11 unless ( stackcheck( 1, \@stack, \@completed, $_, \@ops ) ) {
205 0         0 @stack = (undef);
206 0         0 last;
207             }
208 3         22 push( @stack, exp( pop(@stack) ) );
209             }
210             elsif ( $_ eq "INT" ) {
211 3 50       9 unless ( stackcheck( 1, \@stack, \@completed, $_, \@ops ) ) {
212 0         0 @stack = (undef);
213 0         0 last;
214             }
215 3         8 push( @stack, int( pop(@stack) ) );
216             }
217             elsif ( $_ eq "<" || $_ eq "LT" ) {
218 6 50       19 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
219 0         0 @stack = (undef);
220 0         0 last;
221             }
222 6         11 my $v1 = pop(@stack);
223 6         9 my $v2 = pop(@stack);
224 6 100       18 push( @stack, ( $v2 < $v1 ? 1 : 0 ) );
225             }
226             elsif ( $_ eq "<=" || $_ eq "LE" ) {
227 9 50       27 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
228 0         0 @stack = (undef);
229 0         0 last;
230             }
231 9         16 my $v1 = pop(@stack);
232 9         10 my $v2 = pop(@stack);
233 9 100       28 push( @stack, ( $v2 <= $v1 ? 1 : 0 ) );
234             }
235             elsif ( $_ eq "=" || $_ eq "==" || $_ eq "EQ" ) {
236 0 0       0 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
237 0         0 @stack = (undef);
238 0         0 last;
239             }
240 0         0 my $v1 = pop(@stack);
241 0         0 my $v2 = pop(@stack);
242 0 0       0 push( @stack, ( $v2 == $v1 ? 1 : 0 ) );
243             }
244             elsif ( $_ eq ">=" || $_ eq "GT" ) {
245 9 50       30 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
246 0         0 @stack = (undef);
247 0         0 last;
248             }
249 9         15 my $v1 = pop(@stack);
250 9         11 my $v2 = pop(@stack);
251 9 100       29 push( @stack, ( $v2 > $v1 ? 1 : 0 ) );
252             }
253             elsif ( $_ eq ">" || $_ eq "GE" ) {
254 3 50       9 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
255 0         0 @stack = (undef);
256 0         0 last;
257             }
258 3         6 my $v1 = pop(@stack);
259 3         4 my $v2 = pop(@stack);
260 3 50       9 push( @stack, ( $v2 >= $v1 ? 1 : 0 ) );
261             }
262             elsif ( $_ eq "!=" || $_ eq "NE" ) {
263 6 50       17 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
264 0         0 @stack = (undef);
265 0         0 last;
266             }
267 6         11 my $v1 = pop(@stack);
268 6         7 my $v2 = pop(@stack);
269 6 100       25 push( @stack, ( $v2 != $v1 ? 1 : 0 ) );
270             }
271             elsif ( $_ eq "IF" ) {
272 36 50       3851 unless ( stackcheck( 3, \@stack, \@completed, $_, \@ops ) ) {
273 0         0 @stack = (undef);
274 0         0 last;
275             }
276 36         59 my $el = pop(@stack);
277 36         44 my $th = pop(@stack);
278 36         36 my $co = pop(@stack);
279 36 100       59 my $ve = ( $co ? $th : $el );
280 36 100       73 if ( $ve =~ /,/ ) {
281              
282             # Execute brace-enclosed expression
283 9         42 @stack = rpn( join( ",", @stack, $ve ) );
284             }
285             else {
286 27         46 push( @stack, $ve );
287             }
288             }
289             elsif ( $_ eq "DUP" ) {
290 9 50       19 unless ( stackcheck( 1, \@stack, \@completed, $_, \@ops ) ) {
291 0         0 @stack = (undef);
292 0         0 last;
293             }
294 9         11 my $v1 = pop(@stack);
295 9         13 push( @stack, $v1, $v1 );
296             }
297             elsif ( $_ eq "EXCH" ) {
298 6 50       17 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
299 0         0 @stack = (undef);
300 0         0 last;
301             }
302 6         9 my $v1 = pop(@stack);
303 6         8 my $v2 = pop(@stack);
304 6         12 push( @stack, $v1, $v2 );
305             }
306             elsif ( $_ eq "POP" ) {
307 6 100       21 unless ( stackcheck( 1, \@stack, \@completed, $_, \@ops ) ) {
308 1         3 @stack = (undef);
309 1         2 last;
310             }
311 5         7 pop(@stack);
312             }
313             elsif ( $_ eq "MIN" ) {
314 9 50       33 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
315 0         0 @stack = (undef);
316 0         0 last;
317             }
318 9         14 my $v1 = pop(@stack);
319 9         13 my $v2 = pop(@stack);
320 9 50       27 push( @stack, ( $v1 < $v2 ? $v1 : $v2 ) );
321             }
322             elsif ( $_ eq "MAX" ) {
323 15 50       37 unless ( stackcheck( 2, \@stack, \@completed, $_, \@ops ) ) {
324 0         0 @stack = (undef);
325 0         0 last;
326             }
327 15         25 my $v1 = pop(@stack);
328 15         19 my $v2 = pop(@stack);
329 15 100       39 push( @stack, ( $v1 > $v2 ? $v1 : $v2 ) );
330             }
331             elsif ( $_ eq "TIME" ) {
332 1         7 push( @stack, time() );
333             }
334             elsif ( $_ eq "RAND" ) {
335 1         3 push( @stack, rand() );
336             }
337             elsif ( $_ eq "LRAND" ) {
338 1 50       5 unless ( stackcheck( 1, \@stack, \@completed, $_, \@ops ) ) {
339 0         0 @stack = (undef);
340 0         0 last;
341             }
342 1         65 push( @stack, rand( pop(@stack) ) );
343             }
344             else {
345 366         605 push( @stack, $_ );
346             }
347              
348             # Record that we've completed the operation (for diagnostics).
349 665         1653 push( @completed, $_ );
350             }
351              
352             # OK... Expression executed, let's return the results.
353              
354 144 50 100     518 unless (@stack) {
    100          
355 0         0 @stack = (undef);
356 0         0 logmsg( 'err',
357             "Stack underflow for expr " . "$convr, no value at end." );
358             }
359             elsif ( $#stack > 0 && wantarray == 0 ) {
360 1         7 logmsg( 'warning',
361             "Extra values left on stack for "
362             . "expr $convr left "
363             . join( ",", @stack )
364             . " (right one used)." );
365             }
366 144 100       276 if (wantarray) {
367 54         224 return (@stack);
368             }
369             else {
370 90         303 return ( pop(@stack) );
371             }
372             }
373              
374             sub logmsg {
375 5     5 0 6 my $severity;
376             my $message;
377              
378 5 50       12 if ( scalar(@_) > 1 ) {
379 5         7 $severity = shift;
380             }
381             else {
382 0         0 $severity = "err"; # Default to LOG_ERR severity
383             }
384              
385 5         10 $message = join( "", @_ );
386 5         8 $message =~ s/\r/\\r/g;
387 5         6 $message =~ s/\n/\\n/g;
388 5         325 warn "$0 pid[$$]: $severity: $message at " . localtime() . "\n";
389             }
390              
391             sub stackcheck {
392 299     299 0 464 my ( $required, $sp, $completed, $current, $todo ) = @_;
393              
394 299         590 my @stack = @$sp;
395              
396 299 100       1067 if ( @stack < $required ) {
397 2         12 logmsg(
398             'err',
399             "Stack Underflow in ",
400             join( ",", (@$completed) ),
401             ",<<<$current>>>,", join( ",", (@$todo) )
402             );
403 2         123 return;
404             }
405 297         862 return scalar @stack;
406             }
407              
408             1;
409             __END__