File Coverage

blib/lib/JE/Object/Number.pm
Criterion Covered Total %
statement 102 114 89.4
branch 52 68 76.4
condition 20 37 54.0
subroutine 16 16 100.0
pod 3 3 100.0
total 193 238 81.0


line stmt bran cond sub pod time code
1             package JE::Object::Number;
2              
3             our $VERSION = '0.066';
4              
5              
6 101     101   20075 use strict;
  101         176  
  101         3431  
7 101     101   461 use warnings;
  101         174  
  101         3467  
8              
9 101     101   490 use constant inf => 9**9**9;
  101         167  
  101         8151  
10              
11             our @ISA = 'JE::Object';
12              
13 101     101   559 use Scalar::Util 'blessed';
  101         1580  
  101         194983  
14              
15             require JE::Code;
16             require JE::Number;
17             require JE::Object;
18             require JE::Object::Function;
19             require JE::String;
20              
21             import JE::Code 'add_line_number';
22             sub add_line_number;
23              
24             =head1 NAME
25              
26             JE::Object::Number - JavaScript Number object class
27              
28             =head1 SYNOPSIS
29              
30             use JE;
31             use JE::Object::Number;
32              
33             $j = new JE;
34              
35             $js_num_obj = new JE::Object::Number $j, 953.7;
36              
37             $perl_scalar = $js_num_obj->value;
38              
39             0 + $js_num_obj; # 953.7
40              
41             =head1 DESCRIPTION
42              
43             This class implements JavaScript Number objects for JE. The difference
44             between this and JE::Number is that that module implements
45             I number values, while this module implements the I
46              
47             =head1 METHODS
48              
49             See L for descriptions of most of the methods. Only what
50             is specific to JE::Object::Number is explained here.
51              
52             =over
53              
54             =cut
55              
56             sub new {
57 253     253 1 2607 my($class, $global, $val) = @_;
58 253   33     1564 my $self = $class->SUPER::new($global, {
59             prototype => $global->prototype_for('Number')
60             || $global->prop('Number')->prop('prototype')
61             });
62              
63 253 100 66     2792 $$$self{value} = defined blessed $val && $val->can('to_number')
64             ? $val->to_number->[0]
65             : JE::Number::_numify($val);
66 253         1121 $self;
67             }
68              
69              
70              
71              
72             =item value
73              
74             Returns a Perl scalar containing the number that the object holds.
75              
76             =cut
77              
78 8     8 1 397 sub value { $${$_[0]}{value} }
  8         50  
79              
80              
81              
82             =item class
83              
84             Returns the string 'Number'.
85              
86             =cut
87              
88 213     213 1 644 sub class { 'Number' }
89              
90              
91              
92             our @_digits = (0..9, 'a' .. 'z');
93              
94             sub _new_constructor {
95 17     17   39 my $global = shift;
96             my $f = JE::Object::Function->new({
97             name => 'Number',
98             scope => $global,
99             argnames => [qw/value/],
100             function => sub {
101 16 100   16   70 defined $_[0] ? $_[0]->to_number :
102             JE'Number->new($global, 0);
103             },
104             function_args => ['args'],
105             constructor => sub {
106 234     234   693 unshift @_, __PACKAGE__;
107 234         804 goto &new;
108             },
109 17         400 constructor_args => ['scope','args'],
110             });
111              
112             # The max according to ECMA-262 ≈ 1.7976931348623157e+308.
113             # The max I can get in Perl with a literal is 1.797693134862314659999e+308,
114             # probably as a result of perl bug #41202. Using ECMA’s maximum does not
115             # make sense in our case, anyway, as we are using perl’s (i.e., the sys-
116             # tem’s) floating point.
117             # So I am using routines borrowed from Data::Float to get what are the
118             # actual minimum and maximum values that we can handle.
119 17         171 $f->prop({
120             name => 'MAX_VALUE',
121             autoload => '
122             require "JE/Object/Number/maxvalue.pl";
123             $JE::Object::Number::max_finite
124             ',
125             dontenum => 1,
126             dontdel => 1,
127             readonly => 1,
128             });
129              
130 17         131 $f->prop({
131             name => 'MIN_VALUE',
132             autoload => '
133             require "JE/Object/Number/maxvalue.pl";
134             $JE::Object::Number::min_finite
135             ',
136             dontenum => 1,
137             dontdel => 1,
138             readonly => 1,
139             });
140              
141 17         95 $f->prop({
142             name => 'NaN',
143             value => JE::Number->new($global, 'nan'),
144             dontenum => 1,
145             dontdel => 1,
146             readonly => 1,
147             });
148              
149 17         89 $f->prop({
150             name => 'NEGATIVE_INFINITY',
151             value => JE::Number->new($global, '-inf'),
152             dontenum => 1,
153             dontdel => 1,
154             readonly => 1,
155             });
156              
157 17         87 $f->prop({
158             name => 'POSITIVE_INFINITY', # positively infinite
159             value => JE::Number->new($global, 'inf'),
160             dontenum => 1,
161             dontdel => 1,
162             readonly => 1,
163             });
164              
165 17         103 my $proto = bless $f->prop({
166             name => 'prototype',
167             dontenum => 1,
168             readonly => 1,
169             }), __PACKAGE__;
170 17         361 $global->prototype_for(Number=>$proto);
171              
172 17         1043 $$$proto{value} = 0;
173            
174             $proto->prop({
175             name => 'toString',
176             value => JE::Object::Function->new({
177             scope => $global,
178             name => 'toString',
179             argnames => ['radix'],
180             no_proto => 1,
181             function_args => ['this','args'],
182             function => sub {
183 15     15   24 my $self = shift;
184 15 100       48 die JE::Object::Error::TypeError->new(
185             $global, add_line_number
186             "Argument to " .
187             "Number.prototype.toString is not"
188             . " a " .
189             "Number object"
190             ) unless $self->class eq 'Number';
191              
192 12         23 my $radix = shift;
193 12 50 33     75 !defined $radix || $radix->id eq 'undef'
194             and return
195             $self->to_primitive->to_string;
196              
197 0 0 0     0 ($radix = $radix->to_number->value)
      0        
      0        
198             == 10 || $radix < 2 || $radix > 36 ||
199             $radix =~ /\./ and return $self->to_string;
200              
201 0 0       0 if ($radix == 2) {
    0          
    0          
202 0         0 return JE::String->new($global,
203             sprintf '%b', $self->value);
204             }
205             elsif($radix == 8) {
206 0         0 return JE::String->new($global,
207             sprintf '%o', $self->value);
208             }
209             elsif($radix == 16) {
210 0         0 return JE::String->new($global,
211             sprintf '%x', $self->value);
212             }
213              
214 0         0 my $num = $self->value;
215 0         0 my $result = '';
216 0         0 while($num >= 1) {
217 0         0 substr($result,0,0) =
218             $_digits[$num % $radix];
219 0         0 $num /= $radix;
220             }
221              
222 0         0 return JE::String->new($global, $result);
223             },
224 17         303 }),
225             dontenum => 1,
226             });
227              
228             $proto->prop({
229             name => 'toLocaleString',
230             value => JE::Object::Function->new({
231             scope => $global,
232             name => 'toLocaleString',
233             no_proto => 1,
234             function_args => ['this'],
235             function => sub {
236 3     3   4 my $self = shift;
237 3 50       10 die JE::Object::Error::TypeError->new(
238             $global, add_line_number
239             "Argument to " .
240             "Number.prototype.toLocaleString ".
241             "is not"
242             . " a " .
243             "Number object"
244             ) unless $self->class eq 'Number';
245              
246             # ~~~ locale stuff
247              
248 0         0 return JE::String->_new($global,
249             $self->value);
250             },
251 17         246 }),
252             dontenum => 1,
253             });
254             $proto->prop({
255             name => 'valueOf',
256             value => JE::Object::Function->new({
257             scope => $global,
258             name => 'valueOf',
259             no_proto => 1,
260             function_args => ['this'],
261             function => sub {
262 205     205   300 my $self = shift;
263 205 100       497 die JE::Object::Error::TypeError->new(
264             $global, add_line_number
265             "Argument to " .
266             "Number.prototype.valueOf is not"
267             . " a " .
268             "Number object"
269             ) unless $self->class eq 'Number';
270              
271             # We also deal with plain JE::Numbers here
272             return
273 202 100       1100 ref $self eq 'JE::Number'
274             ? $self
275             : JE::Number->new($global,$$$self{value});
276             },
277 17         227 }),
278             dontenum => 1,
279             });
280             $proto->prop({
281             name => 'toFixed',
282             value => JE::Object::Function->new({
283             scope => $global,
284             name => 'toFixed',
285             no_proto => 1,
286             argnames => ['fractionDigits'],
287             function_args => ['this','args'],
288             function => sub {
289 13     13   13 my $self = shift;
290 13 100       32 die JE::Object::Error::TypeError->new(
291             $global, add_line_number
292             "Argument to " .
293             "Number.prototype.toFixed is not"
294             . " a " .
295             "Number object"
296             ) unless $self->class eq 'Number';
297              
298 10         12 my $places = shift;
299 10 100       16 if(defined $places) {
300 8   100     19 $places = ($places = int $places->to_number) == $places && $places;
301             }
302 2         3 else { $places = 0 }
303              
304 10 50       20 $places < 0 and throw JE::Object::Error::RangeError->new($global,
305             "Invalid number of decimal places: $places " .
306             "(negative numbers not supported)"
307             );
308              
309 10         20 my $num = $self->value;
310 10 100       26 $num == $num or return JE::String->_new($global, 'NaN');
311              
312 9 100       24 abs $num >= 1000000000000000000000
313             and return JE::String->_new($global, $num);
314             # ~~~ if/when JE::Number::to_string is rewritten, make this use the same
315             # algorithm
316              
317             # Deal with numbers ending with 5. perl (in Snow Leopard at least) rounds
318             # 30.125 down, whereas ECMAScript says that it should round up. (15.7.4.5:
319             # ‘Let n be an integer for which the exact mathematical value of
320             # n ÷ 10^f – x is as close to zero as possible. If there are two such n,
321             # pick the larger n.’)
322 8 100       83 if((my $sprintfed = sprintf "%." . ($places+1) . 'f', $num) =~ /5\z/) {
323 2         9 (my $upper = $sprintfed) =~ s/\.?.\z//;
324 2         3 my $lower = $upper;
325 2         8 ++substr $upper,-1,1;
326 2 50       15 return JE::String->_new(
327             $global, $upper-$num <= $num-$lower ? $upper : $lower
328             );
329             }
330              
331 6         35 return JE::String->_new($global, sprintf "%.${places}f", $num);
332              
333             },
334 17         299 }),
335             dontenum => 1,
336             });
337             $proto->prop({
338             name => 'toExponential',
339             value => JE::Object::Function->new({
340             scope => $global,
341             name => 'toExponential',
342             no_proto => 1,
343             argnames => ['fractionDigits'],
344             function_args => ['this','args'],
345             function => sub {
346 18     18   37 my $self = shift;
347 18 100       51 die JE::Object::Error::TypeError->new(
348             $global, add_line_number
349             "Argument to " .
350             "Number.prototype. toExponential is not"
351             . " a " .
352             "Number object"
353             ) unless $self->class eq 'Number';
354              
355 15         37 my $num = $self->value;
356 15 100       42 $num == $num or return JE::String->_new($global, 'NaN');
357 14 100 100     52 abs $num == inf && return JE::String->_new($global,
358             ($num < 0 && '-') . 'Infinity');
359              
360 12         15 my $places = shift;
361 12 100       27 if(defined $places) {
362 6   100     16 $places
363             = 0+(($places = int $places->to_number) == $places) && $places;
364             }
365 6         10 else { $places = !1 }
366              
367 12 50       25 $places < 0 and throw JE::Object::Error::RangeError->new($global,
368             "Invalid number of decimal places: $places " .
369             "(negative numbers not supported)"
370             );
371              
372             # Deal with half-way rounding. See the note above in toFixed. It applies to
373             # toExponential as well (except that this is section 15.7.4.6).
374 12 100       142 if((my $sprintfed = sprintf "%." . ($places+1) . 'e', $num) =~ /5e/) {
375 3         23 (my $upper = $sprintfed) =~ s/\.?.(e.*)\z//;
376 3         6 my $lower = $upper;
377 3         11 ++substr $upper,-1,1;
378 3 50       38 (my $ret = ($upper-$num <= $num-$lower ? $upper : $lower) . $1)
379             =~ s/\.?0*e([+-])0*(?!\z)/e$1/; # convert 0.0000e+00 to 0e+0
380 3         13 return JE::String->_new(
381             $global, $ret
382             );
383             }
384              
385 9         54 my $result = sprintf "%"."."x!!length($places)."${places}e", $num;
386 9         81 $result =~ s/\.?0*e([+-])0*(?!\z)/e$1/; # convert 0.0000e+00 to 0e+0
387              
388 9         37 return JE::String->_new($global, $result);
389              
390             },
391 17         336 }),
392             dontenum => 1,
393             });
394              
395             $proto->prop({
396             name => 'toPrecision',
397             value => JE::Object::Function->new({
398             scope => $global,
399             name => 'toPrecision',
400             no_proto => 1,
401             argnames => ['precision'],
402             function_args => ['this','args'],
403             function => sub {
404 18     18   18 my $self = shift;
405 18 100       46 die JE::Object::Error::TypeError->new(
406             $global, add_line_number
407             "Argument to " .
408             "Number.prototype. toPrecision is not"
409             . " a " .
410             "Number object"
411             ) unless $self->class eq 'Number';
412              
413 15         28 my $num = $self->value;
414 15 100       36 $num == $num or return JE::String->_new($global, 'NaN');
415 14 100 100     43 abs $num == inf && return JE::String->_new($global,
416             ($num < 0 && '-') . 'Infinity');
417              
418 12         14 my $prec = shift;
419 12 100 66     35 if(!defined $prec || $prec->id eq 'undef') {
420 2         7 return JE::String->_new($global, $num);
421             # ~~~ if/when JE::Number::to_string is rewritten, make this use the same
422             # algorithm
423             }
424              
425 10   33     22 $prec = ($prec = int $prec->to_number) == $prec && $prec;
426              
427 10 50       18 $prec < 1 and throw JE::Object::Error::RangeError->new($global,
428             "Precision out of range: $prec " .
429             "(must be >= 1)"
430             );
431              
432              
433             # ~~~ Probably not the most efficient alrogithm. maybe I coould optimimse
434             # it later. OD yI have tot proooofrfreoad my aown tiyping.?
435              
436 10 100       18 if ($num == 0) {
437 2 100       8 $prec == 1 or $num = '0.' . '0' x ($prec-1);
438             }
439             else {
440 8         54 $num = sprintf "%.${prec}g", $num; # round it off
441 8         69 my($e) = sprintf "%.0e", $num, =~ /e(.*)/;
442 8 100 100     39 if($e < -6 || $e >= $prec) {
443 3         21 ($num = sprintf "%.".($prec-1)."e", $num)
444             =~ s/(?<=e[+-])0+(?!\z)//; # convert 0e+00 to 0e+0
445 3 50       15 $num =~ /\./ or $num =~ s/e/.e/;
446             }
447 5         22 else { $num = sprintf "%." . ($prec - 1 - $e) . 'f', $num }
448             }
449              
450 10         31 return JE::String->_new($global, $num);
451              
452             },
453 17         297 }),
454             dontenum => 1,
455             });
456              
457 17         198 $f;
458             }
459              
460             return "a true value";
461              
462             =back
463              
464             =head1 SEE ALSO
465              
466             =over 4
467              
468             =item JE
469              
470             =item JE::Types
471              
472             =item JE::Object
473              
474             =item JE::Number
475              
476             =back
477              
478             =cut