File Coverage

blib/lib/Sidef/Object/Object.pm
Criterion Covered Total %
statement 21 225 9.3
branch 0 144 0.0
condition 0 53 0.0
subroutine 7 43 16.2
pod 19 21 90.4
total 47 486 9.6


line stmt bran cond sub pod time code
1             package Sidef::Object::Object {
2              
3 1     1   441 use 5.016;
  1         5  
4 1     1   9 use Scalar::Util qw();
  1         2  
  1         22  
5              
6 1     1   14 use Sidef;
  1         3  
  1         39  
7 1     1   9 use Sidef::Types::Bool::Bool;
  1         2  
  1         698  
8              
9             use overload
10 1         28 q{~~} => \&{__PACKAGE__ . '::' . '~~'},
11             q{bool} => sub {
12 0 0   0   0 if (defined(my $sub = UNIVERSAL::can($_[0], 'to_b'))) {
13 0         0 @_ = ($_[0]);
14 0         0 goto $sub;
15             }
16 0         0 $_[0];
17             },
18             q{0+} => sub {
19 0 0   0   0 if (defined(my $sub = UNIVERSAL::can($_[0], 'to_n'))) {
20 0         0 @_ = ($_[0]);
21 0         0 goto $sub;
22             }
23 0         0 $_[0];
24             },
25             q{""} => sub {
26 0 0   0   0 if (defined(my $sub = UNIVERSAL::can($_[0], 'to_s'))) {
27 0         0 @_ = ($_[0]);
28 0         0 goto $sub;
29             }
30 0         0 $_[0];
31             },
32             q{cmp} => sub {
33 0     0   0 my ($obj1, $obj2, $swapped) = @_;
34              
35 0 0 0     0 if ( ref($obj1) eq ref($obj2)
      0        
36             and ref($obj1) ne 'Sidef::Types::Number::Number'
37             and Scalar::Util::refaddr($obj1) == Scalar::Util::refaddr($obj2)) {
38 0         0 return 0;
39             }
40              
41 0 0       0 if ($swapped) {
42 0         0 ($obj1, $obj2) = ($obj2, $obj1);
43             }
44              
45 0 0 0     0 if ( CORE::ref($obj1) && UNIVERSAL::isa($obj1, CORE::ref($obj2))
      0        
      0        
46             or CORE::ref($obj2) && UNIVERSAL::isa($obj2, CORE::ref($obj1))) {
47 0 0       0 if (defined(my $sub = UNIVERSAL::can($obj1, '<=>'))) {
48 0         0 @_ = ($obj1, $obj2);
49 0         0 goto $sub;
50             }
51             }
52              
53             #<<<
54 0 0       0 (CORE::ref($obj1) ? Scalar::Util::refaddr($obj1) : ('-inf' + 0)) <=>
    0          
55             (CORE::ref($obj2) ? Scalar::Util::refaddr($obj2) : ('-inf' + 0));
56             #>>>
57             },
58             q{eq} => sub {
59 0     0   0 my ($obj1, $obj2) = @_;
60              
61 0 0 0     0 if ( ref($obj1) eq ref($obj2)
      0        
62             and ref($obj1) ne 'Sidef::Types::Number::Number'
63             and Scalar::Util::refaddr($obj1) == Scalar::Util::refaddr($obj2)) {
64 0         0 return 1;
65             }
66              
67             #<<<
68             (
69 0 0 0     0 UNIVERSAL::isa($obj1, CORE::ref($obj2) || return 0) ||
      0        
      0        
70             UNIVERSAL::isa($obj2, CORE::ref($obj1) || return 0)
71             ) || return 0;
72             #>>>
73              
74 0 0       0 if (defined(my $sub = UNIVERSAL::can($obj1, '=='))) {
75 0         0 @_ = ($obj1, $obj2);
76 0         0 goto $sub;
77             }
78              
79 0         0 !CORE::int($obj1 cmp $obj2);
80 1     1   9 };
  1         3  
  1         3  
81              
82             sub new {
83 0     0 1   bless {}, __PACKAGE__;
84             }
85              
86             sub say {
87 0 0   0 1   (CORE::say @_)
88             ? (Sidef::Types::Bool::Bool::TRUE)
89             : (Sidef::Types::Bool::Bool::FALSE);
90             }
91              
92             *println = \&say;
93              
94             sub print {
95 0 0   0 1   (CORE::print @_)
96             ? (Sidef::Types::Bool::Bool::TRUE)
97             : (Sidef::Types::Bool::Bool::FALSE);
98             }
99              
100             sub lazy {
101 0     0 1   my ($self) = @_;
102 0           Sidef::Object::Lazy->new(obj => $self);
103             }
104              
105             sub method {
106 0     0 1   my ($self, $method, @args) = @_;
107 0           Sidef::Object::LazyMethod->new({obj => $self, method => "$method", args => \@args});
108             }
109              
110             sub object_id {
111 0     0 0   my ($self) = @_;
112 0           Sidef::Types::Number::Number->new(Scalar::Util::refaddr($self));
113             }
114              
115             *refaddr = \&object_id;
116              
117             sub object_type {
118 0     0 0   my ($self) = @_;
119 0           Sidef::Types::String::String->new(Scalar::Util::reftype($self));
120             }
121              
122             *reftype = \&object_type;
123              
124             sub class {
125 0     0 1   my ($obj) = @_;
126 0   0       my $ref = CORE::ref($obj) || $obj;
127              
128 0           my $rindex = rindex($ref, '::');
129 0 0         Sidef::Types::String::String->new($rindex == -1 ? $ref : substr($ref, $rindex + 2));
130             }
131              
132             sub ref {
133 0     0 1   my ($obj) = @_;
134 0   0       Sidef::Types::String::String->new(CORE::ref($obj) || $obj);
135             }
136              
137             sub bless {
138 0     0 1   my ($obj, $arg) = @_;
139 0   0       CORE::bless($arg, (CORE::ref($obj) || $obj));
140             }
141              
142             sub clone {
143 0     0 1   my ($obj) = @_;
144              
145 0           my $class = CORE::ref($obj);
146 0           my $reftype = Scalar::Util::reftype($obj);
147              
148 0 0         if ($reftype eq 'HASH') {
    0          
149 0           CORE::bless {%$obj}, $class;
150             }
151             elsif ($reftype eq 'ARRAY') {
152 0           CORE::bless [@$obj], $class;
153             }
154             else {
155 0           $obj;
156             }
157             }
158              
159             sub dclone {
160 0     0 1   my %addr; # keeps track of cloned objects
161              
162             sub {
163 0     0     my ($obj, $reftype) = @_;
164              
165 0           my $refaddr = Scalar::Util::refaddr($obj);
166              
167             exists($addr{$refaddr})
168 0 0         and return $addr{$refaddr};
169              
170 0           my $class = Scalar::Util::blessed($obj);
171              
172 0 0 0       if (defined($class) and not UNIVERSAL::isa($class, 'Sidef::Object::Object')) {
173 0           $addr{$refaddr} = $obj;
174 0           return $obj;
175             }
176              
177 0 0         if ($reftype eq 'HASH') {
    0          
178 0 0         my $o = defined($class) ? CORE::bless({}, $class) : {};
179 0           $addr{$refaddr} = $o;
180             %$o = (
181             map {
182 0           my $v = $obj->{$_};
183 0           my $r = Scalar::Util::reftype($v);
184 0 0 0       ($_ => ($r eq 'HASH' || $r eq 'ARRAY' ? __SUB__->($v, $r) : $v))
185 0           } CORE::keys(%{$obj})
  0            
186             );
187 0           $o;
188             }
189             elsif ($reftype eq 'ARRAY') {
190 0 0         my $o = defined($class) ? CORE::bless([], $class) : [];
191 0           $addr{$refaddr} = $o;
192             @$o = (
193             map {
194 0           my $r = Scalar::Util::reftype($_);
195 0 0 0       $r eq 'ARRAY' || $r eq 'HASH' ? __SUB__->($_, $r) : $_
196 0           } @{$obj}
  0            
197             );
198 0           $o;
199             }
200             else {
201 0           $obj;
202             }
203             }
204 0           ->($_[0], Scalar::Util::reftype($_[0]));
205             }
206              
207             sub respond_to {
208 0     0 1   my ($self, $method) = @_;
209 0 0         UNIVERSAL::can($self, "$method")
210             ? (Sidef::Types::Bool::Bool::TRUE)
211             : (Sidef::Types::Bool::Bool::FALSE);
212             }
213              
214             sub is_a {
215 0     0 1   my ($self, $obj) = @_;
216 0 0         UNIVERSAL::isa($self, "$obj")
217             ? (Sidef::Types::Bool::Bool::TRUE)
218             : (Sidef::Types::Bool::Bool::FALSE);
219             }
220              
221             *is_an = \&is_a;
222             *kind_of = \&is_a;
223              
224             sub parent_classes {
225 0     0 1   my ($obj) = @_;
226              
227 1     1   1365 no strict 'refs';
  1         3  
  1         597  
228              
229 0           my %seen;
230             my $extract_parents;
231             $extract_parents = sub {
232 0     0     my ($ref) = @_;
233              
234 0           my @parents = @{${$ref . '::'}{ISA}};
  0            
  0            
235              
236 0 0         if (@parents) {
237 0           foreach my $parent (@parents) {
238 0 0         next if $seen{$parent}++;
239 0           push @parents, $extract_parents->($parent);
240             }
241             }
242              
243 0           @parents;
244 0           };
245              
246 0           Sidef::Types::Array::Array->new([map { Sidef::Types::String::String->new($_) } $extract_parents->(CORE::ref($obj))]);
  0            
247             }
248              
249             sub interpolate {
250 0     0 1   my $self = shift(@_);
251 0           $self->new(CORE::join('', @_));
252             }
253              
254             sub dump {
255 0     0 1   my %addr; # keep track of dumped objects
256              
257             my $sub = sub {
258 0     0     my ($obj) = @_;
259              
260 0           my $refaddr = Scalar::Util::refaddr($obj);
261              
262             exists($addr{$refaddr})
263 0 0         and return $addr{$refaddr};
264              
265 0 0         my $type = Sidef::normalize_type(CORE::ref($obj) ? CORE::ref($obj) : $obj);
266 0 0         Scalar::Util::reftype($obj) eq 'HASH' or return $type;
267 0           my @keys = CORE::sort CORE::keys(%{$obj});
  0            
268              
269 0           my $str = Sidef::Types::String::String->new($type . "(#`($refaddr)...)");
270 0           $addr{$refaddr} = $str;
271              
272             $$str = (
273             "$type(" . CORE::join(
274             ', ',
275             map {
276 0 0         my $str = UNIVERSAL::can($obj->{$_}, 'dump') ? $obj->{$_}->dump : "$obj->{$_}";
  0            
277 0           "$_: $str";
278             } @keys
279             )
280             . ')'
281             );
282              
283 0           $str;
284 0           };
285              
286 0           local *Sidef::Object::Object::dump = $sub;
287 0           $sub->($_[0]);
288             }
289              
290             {
291 1     1   9 no strict 'refs';
  1         2  
  1         1468  
292              
293             sub def_method {
294 0     0 1   my ($self, $name, $block) = @_;
295 0 0         *{(CORE::ref($self) ? CORE::ref($self) : $self) . '::' . $name} = sub {
296 0     0     $block->call(@_);
297 0           };
298 0           $self;
299             }
300              
301             sub undef_method {
302 0     0 1   my ($self, $name) = @_;
303 0 0         delete ${(CORE::ref($self) ? CORE::ref($self) : $self) . '::'}{$name};
  0            
304 0           $self;
305             }
306              
307             sub alias_method {
308 0     0 1   my ($self, $old, $new) = @_;
309              
310 0 0         my $ref = (CORE::ref($self) ? CORE::ref($self) : $self);
311 0           my $to = \&{$ref . '::' . $old};
  0            
312              
313 0 0         if (not defined &$to) {
314 0           die "[ERROR] Can't alias the nonexistent method '$old' as '$new'!";
315             }
316              
317 0           *{$ref . '::' . $new} = $to;
  0            
318             }
319              
320             sub methods {
321 0     0 1   my ($self) = @_;
322              
323 0           my %alias;
324             my %methods;
325 0           my $ref = CORE::ref($self);
326 0 0         foreach my $method (grep { $_ !~ /^[(_]/ and defined(&{$ref . '::' . $_}) } keys %{$ref . '::'}) {
  0            
  0            
  0            
327             $methods{$method} = (
328 0   0       $alias{\&{$ref . '::' . $method}} //=
  0            
329             Sidef::Object::LazyMethod->new(
330             {
331             obj => $self,
332             method => $method,
333             }
334             )
335             );
336             }
337              
338 0           Sidef::Types::Hash::Hash->new(%methods);
339             }
340              
341             # Logical AND
342             *{__PACKAGE__ . '::' . '&&'} = sub {
343 0 0   0     $_[0] ? $_[1] : $_[0];
344             };
345              
346             # Logical OR
347             *{__PACKAGE__ . '::' . '||'} = sub {
348 0 0   0     $_[0] ? $_[0] : $_[1];
349             };
350              
351             # Logical XOR
352             *{__PACKAGE__ . '::' . '^'} = sub {
353 0 0 0 0     ($_[0] xor $_[1])
354             ? (Sidef::Types::Bool::Bool::TRUE)
355             : (Sidef::Types::Bool::Bool::FALSE);
356             };
357              
358             # Defined-OR
359             *{__PACKAGE__ . '::' . '\\\\'} = sub {
360 0 0   0     defined($_[0]) ? $_[1] : $_[0];
361             };
362              
363             # Smart match operator
364             *{__PACKAGE__ . '::' . '~~'} = sub {
365 0     0     my ($first, $second, $swapped) = @_;
366              
367 0 0         if ($swapped) {
368 0           ($first, $second) = ($second, $first);
369             }
370              
371             # First is String
372 0 0         if (UNIVERSAL::isa($first, 'Sidef::Types::String::String')) {
373              
374             # String ~~ RangeString
375 0 0         if (UNIVERSAL::isa($second, 'Sidef::Types::Range::RangeString')) {
376 0           return $second->contains($first);
377             }
378              
379             # String ~~ String
380 0 0         if (CORE::ref($first) eq CORE::ref($second)) {
381 0           return $second->eq($first);
382             }
383             }
384              
385             # First is Number
386 0 0         if (UNIVERSAL::isa($first, 'Sidef::Types::Number::Number')) {
387              
388             # Number ~~ RangeNumber
389 0 0         if (UNIVERSAL::isa($second, 'Sidef::Types::Range::RangeNumber')) {
390 0           return $second->contains($first);
391             }
392             }
393              
394             # First is RangeNumber
395 0 0         if (UNIVERSAL::isa($first, 'Sidef::Types::Range::RangeNumber')) {
396              
397             # RangeNumber ~~ Number
398 0 0         if (UNIVERSAL::isa($second, 'Sidef::Types::Number::Number')) {
399 0           return $first->contains($second);
400             }
401             }
402              
403             # First is RangeString
404 0 0         if (UNIVERSAL::isa($first, 'Sidef::Types::Range::RangeString')) {
405              
406             # RangeString ~~ String
407 0 0         if (UNIVERSAL::isa($second, 'Sidef::Types::String::String')) {
408 0           return $first->contains($second);
409             }
410             }
411              
412             # First is Array
413 0 0         if (UNIVERSAL::isa($first, 'Sidef::Types::Array::Array')) {
414              
415             # Array ~~ Array
416 0 0         if (CORE::ref($first) eq CORE::ref($second)) {
417 0           return $first->eq($second);
418             }
419              
420             # Array ~~ Regex
421 0 0         if (UNIVERSAL::isa($second, 'Sidef::Types::Regex::Regex')) {
422 0           return $first->match($second);
423             }
424              
425             # Array ~~ Hash
426 0 0         if (UNIVERSAL::isa($second, 'Sidef::Types::Hash::Hash')) {
427 0           return $second->keys->contains_all($first);
428             }
429              
430             # Array ~~ Any
431 0 0         if (!UNIVERSAL::isa($second, 'Sidef::Types::Array::Array')) {
432 0           return $first->contains($second);
433             }
434             }
435              
436             # First is Hash
437 0 0         if (UNIVERSAL::isa($first, 'Sidef::Types::Hash::Hash')) {
438              
439             # Hash ~~ Array
440 0 0         if (UNIVERSAL::isa($second, 'Sidef::Types::Array::Array')) {
441 0           return $second->contains_all($first->keys);
442             }
443              
444             # Hash ~~ Hash
445 0 0         if (CORE::ref($first) eq CORE::ref($second)) {
446 0           return $second->eq($first->keys);
447             }
448              
449             # Hash ~~ Regex
450 0 0         if (UNIVERSAL::isa($second, 'Sidef::Types::Regex::Regex')) {
451 0           return $first->keys->match($second);
452             }
453              
454             # Hash ~~ Any
455 0 0         if (!UNIVERSAL::isa($second, 'Sidef::Types::Hash::Hash')) {
456 0           return $first->exists($second);
457             }
458             }
459              
460             # First is Regex
461 0 0         if (UNIVERSAL::isa($first, 'Sidef::Types::Regex::Regex')) {
462              
463             # Regex ~~ Regex
464 0 0         if (CORE::ref($first) eq CORE::ref($second)) {
465 0           return $first->eq($second);
466             }
467              
468             # Regex ~~ Array
469 0 0         if (UNIVERSAL::isa($second, 'Sidef::Types::Array::Array')) {
470 0           return $second->match($first);
471             }
472              
473             # Regex ~~ Hash
474 0 0         if (UNIVERSAL::isa($second, 'Sidef::Types::Hash::Hash')) {
475 0           return $second->keys->match($first);
476             }
477              
478             # Regex ~~ Any
479 0 0         if (!UNIVERSAL::isa($second, 'Sidef::Types::Regex::Regex')) {
480 0           return $first->match($second)->is_successful;
481             }
482             }
483              
484             # Second is Array
485 0 0         if (UNIVERSAL::isa($second, 'Sidef::Types::Array::Array')) {
486              
487             # Any ~~ Array
488 0           return $second->contains($first);
489             }
490              
491             # Second is Hash
492 0 0         if (UNIVERSAL::isa($second, 'Sidef::Types::Hash::Hash')) {
493              
494             # Any ~~ Hash
495 0           return $second->exists($first);
496             }
497              
498             # Second is Regex
499 0 0         if (UNIVERSAL::isa($second, 'Sidef::Types::Regex::Regex')) {
500 0           return $second->match($first)->is_successful;
501             }
502              
503 0           my $bool = $first eq $second;
504             #<<<
505 0 0         CORE::ref($bool) ? $bool : (
    0          
506             $bool ? Sidef::Types::Bool::Bool::TRUE
507             : Sidef::Types::Bool::Bool::FALSE
508             );
509             #>>>
510             };
511              
512             # Negation of smart match
513             *{__PACKAGE__ . '::' . '!~'} = sub {
514 0     0     state $method = '~~';
515 0           $_[0]->$method($_[1])->neg;
516             };
517             }
518             }
519              
520             1;