File Coverage

blib/lib/JE/String.pm
Criterion Covered Total %
statement 65 72 90.2
branch 25 30 83.3
condition 10 15 66.6
subroutine 28 30 93.3
pod 0 20 0.0
total 128 167 76.6


line stmt bran cond sub pod time code
1             package JE::String;
2              
3             our $VERSION = '0.065';
4              
5              
6 101     101   31703 use strict;
  101         141  
  101         3228  
7 101     101   413 use warnings; no warnings 'utf8';
  101     101   120  
  101         2180  
  101         338  
  101         121  
  101         3442  
8              
9 101         468 use overload fallback => 1,
10             '""' => 'value',
11             # cmp => sub { "$_[0]" cmp $_[1] }
12 101     101   1347 ;
  101         875  
13              
14 101     101   5581 use Carp;
  101         163  
  101         5769  
15 101     101   451 use Scalar::Util qw 'blessed tainted';
  101         129  
  101         5177  
16              
17 101     101   526 use Exporter 5.57 'import';
  101         2434  
  101         56488  
18             our @EXPORT_OK = qw'surrogify desurrogify';
19              
20             require JE::Object::String;
21             require JE::Boolean;
22             require JE::Number;
23              
24              
25             # Internals:
26             # bless [ $utf16_string, $unicode_string, $global_object], 'JE::String';
27             # Either of the first two slots may be empty. It will be filled in
28             # on demand.
29              
30              
31             sub new {
32 19012     19012 0 27641 my($class, $global, $val) = @_;
33 19012 50       53324 defined blessed $global
34             or croak "First argument to JE::String->new is not an object";
35              
36 19012         19920 my $self;
37 19012 50 33     49388 if(defined blessed $val and $val->can('to_string')) {
38 0         0 $self = bless [$val->to_string->[0],undef,$global], $class;
39             }
40             else {
41 19012         54934 $self = bless [undef,$val, $global], $class;
42             }
43 19012         59020 $self;
44             }
45              
46             sub _new { # ~~~ Should we document this and make it public? The problem
47             # with it is that it has no error-checking whatsoever, and
48             # can consequently make JS do weird things. (Maybe it’s OK,
49             # since I doubt any code would choke on a charCodeAt result
50             # > 0xffff.)
51 47682 100   47682   232904 bless [defined $_[2] ? $_[2] : '',undef,$_[1]], $_[0];
52             }
53              
54             sub prop {
55             # ~~~ Make prop simply return the value if the prototype has that
56             # property.
57 390     390 0 470 my $self = shift;
58              
59 390 100       839 if ($_[0] eq 'length') {
60 13 100       129 return JE::Number->new($$self[2], length (
61             defined $$self[0] ? $$self[0] :
62             ($$self[0]=surrogify($$self[1]))
63             ));
64             }
65              
66 377         998 $$self[2]->prototype_for('String')->prop(@_);
67             }
68              
69             sub keys {
70 0     0 0 0 my $self = shift;
71 0         0 $$self[2]->prototype_for('String')->keys;}
72              
73             sub delete {
74 0     0 0 0 return $_[1] ne 'length'
75             }
76              
77             sub method {
78 1     1 0 2 my $self = shift;
79 1         29 $$self[2]->prototype_for('String')->prop(shift)->apply(
80             $self,$$self[2]->upgrade(@_)
81             );
82             }
83              
84              
85             sub value {
86 29770 100   29770 0 1729728 defined $_[0][1] ? $_[0][1] : ($_[0][1] = desurrogify($_[0][0]));
87             }
88             *TO_JSON=*value;
89              
90             sub value16 {
91 41101 100   41101 0 226902 defined $_[0][0] ? $_[0][0] : ($_[0][0] = surrogify($_[0][1]));
92             }
93              
94              
95 19975     19975 0 59496 sub typeof { 'string' }
96 1195     1195 0 2193 sub id { 'str:' . $_[0]->value16 }
97 80     80 0 768 sub class { 'String' }
98 675     675 0 1864 sub primitive { 1 }
99              
100 26019     26019 0 40229 sub to_primitive { $_[0] }
101 29456     29456 0 104422 sub to_string { $_[0] }
102             # $_[0][2] is the global obj
103 130 100   130 0 1606 sub to_boolean { JE::Boolean->new( $_[0][2],
104             length defined $_[0][0]
105             ? $_[0][0] : $_[0][1]
106             ) }
107 7     7 0 181 sub to_object { JE::Object::String->new($_[0][2], shift) }
108              
109 99     99   10430 our $s = qr.[\p{Zs}\s\ck\x{2028}\x{2029}]*.;
  99         12546  
  99         1693  
110              
111             sub to_number {
112 844     844 0 19300 my $value = (my $self = shift)->[0];
113 844 100       2002 defined $value or $value = $$self[1];
114 844 100       8748 JE::Number->new($self->[2],
    100          
    100          
115             $value =~ /^$s
116             (
117             [+-]?
118             (?:
119             (?=[0-9]|\.[0-9]) [0-9]* (?:\.[0-9]*)?
120             (?:[Ee][+-]?[0-9]+)?
121             |
122             Infinity
123             )
124             $s
125             )?
126             \z
127             /ox ? defined $1 ? $value : 0 :
128             $value =~ /^$s 0[Xx] ([A-Fa-f0-9]+) $s\z/ox ? hex $1 :
129             'NaN'
130             );
131             }
132              
133 2     2 0 8 sub global { $_[0][2] }
134              
135             sub taint {
136 1     1 0 1 my $self = shift;
137 1 50 33     15 tainted $self->[0] || tainted $self->[1] and return $self;
138 0         0 my $alter_ego = [@$self];
139 0 0       0 $alter_ego->[defined $alter_ego->[0] ? 0 : 1] .= shift();
140 0         0 return bless $alter_ego, ref $self;
141             }
142              
143              
144             sub desurrogify($) {
145 45892     45892 0 59931 my $ret = shift;
146 45892         42336 my($ord1, $ord2);
147 45892         125150 for(my $n = 0; $n < length $ret; ++$n) { # really slow
148 1866486 100 100     4295180 ($ord1 = ord substr $ret,$n,1) >= 0xd800 and
      100        
      66        
149             $ord1 <= 0xdbff and
150             ($ord2 = ord substr $ret,$n+1,1) >= 0xdc00 and
151             $ord2 <= 0xdfff and
152             substr($ret,$n,2) =
153             chr 0x10000 + ($ord1 - 0xD800) * 0x400 + ($ord2 - 0xDC00);
154             }
155              
156             # In perl 5.8.8, if there is a sub on the call stack that was
157             # triggered by the overloading mechanism when the object with the
158             # overloaded operator was passed as the only argument to 'die',
159             # then the following substitution magically calls that subroutine
160             # again with the same arguments, thereby causing infinite
161             # recursion:
162             #
163             # $ret =~ s/([\x{d800}-\x{dbff}])([\x{dc00}-\x{dfff}])/
164             # chr 0x10000 + (ord($1) - 0xD800) * 0x400 +
165             # (ord($2) - 0xDC00)
166             # /ge;
167             #
168             # 5.9.4 still has this bug.
169              
170 45892         222716 $ret;
171             }
172              
173             sub surrogify($) {
174 511     511 0 831 my $ret = shift;
175              
176 101     101   1559061 no warnings 'utf8';
  101         711  
  101         10372  
177              
178 511         56157 $ret =~ s<([^\0-\x{ffff}])><
179 8         254 chr((ord($1) - 0x10000) / 0x400 + 0xD800)
180             . chr((ord($1) - 0x10000) % 0x400 + 0xDC00)
181             >eg;
182 511         1792 $ret;
183             }
184              
185              
186             1;
187             __END__