File Coverage

web/cgi-bin/yatt.lib/YATT/Util/Symbol.pm
Criterion Covered Total %
statement 56 66 84.8
branch 11 14 78.5
condition 1 3 33.3
subroutine 15 18 83.3
pod 0 9 0.0
total 83 110 75.4


line stmt bran cond sub pod time code
1             # -*- mode: perl; coding: utf-8 -*-
2             package YATT::Util::Symbol;
3 13     13   15735 use base qw(Exporter);
  13         24  
  13         1080  
4 13     13   70 use strict;
  13         26  
  13         349  
5 13     13   68 use warnings qw(FATAL all NONFATAL misc);
  13         24  
  13         1321  
6              
7             BEGIN {
8 13     13   57 our @EXPORT_OK = qw(class globref stash
9             fields_hash fields_hash_of_class
10             add_isa lift_isa_to
11             declare_alias
12             define_const
13             rebless_with
14             );
15 13         317 our @EXPORT = @EXPORT_OK;
16             }
17              
18 13     13   68 use Carp;
  13         24  
  13         961  
19 13     13   1269 use YATT::Util qw(numeric lsearch);
  13         23  
  13         1666  
20              
21             sub class {
22 18335 100   18335 0 150291 ref $_[0] || $_[0]
23             }
24              
25             sub globref {
26 18335     18335 0 34664 my ($thing, @name) = @_;
27 13     13   69 no strict 'refs';
  13         24  
  13         9565  
28 18335         19979 \*{join("::", class($thing), @name)};
  18335         31546  
29             }
30              
31             sub stash {
32 0         0 *{globref($_[0], '')}{HASH}
33 0     0 0 0 }
34              
35             sub declare_alias ($$) {
36 15     15 0 29 my ($name, $sub, $pack) = @_;
37 15   33     70 $pack ||= caller;
38 15         21 *{globref($pack, $name)} = $sub;
  15         24  
39             }
40              
41             sub define_const {
42 199     199 0 321 my ($name_or_glob, $value) = @_;
43 199 100       487 my $glob = ref $name_or_glob ? $name_or_glob : globref($name_or_glob);
44 199     0   1713 *$glob = sub () { $value };
  0         0  
45             }
46              
47             sub fields_hash_of_class {
48 17083     17083 0 19876 *{globref($_[0], 'FIELDS')}{HASH};
  17083         34661  
49             }
50              
51             *fields_hash = do {
52             if ($] >= 5.009) {
53             \&fields_hash_of_class;
54             } else {
55             sub { $_[0]->[0] }
56             }
57             };
58              
59             sub rebless_array_with {
60 0     0 0 0 my ($self, $newclass) = @_;
61 0         0 $self->[0] = fields_hash_of_class($newclass);
62 0         0 bless $self, $newclass;
63             }
64              
65             *rebless_with = do {
66             if ($] >= 5.009) {
67             require YATT::Util::SymbolHash;
68             \&YATT::Util::SymbolHash::rebless_hash_with;
69             } else {
70             \&rebless_array_with;
71             }
72             };
73              
74             sub add_isa {
75 169     169 0 498 my ($pack, $targetClass, @baseClass) = @_;
76 169         393 my $isa = globref($targetClass, 'ISA');
77 169         313 my @uniqBase;
78 169 50       241 if (my $array = *{$isa}{ARRAY}) {
  169         592  
79 169         375 foreach my $baseClass (@baseClass) {
80 169 100       521 next if $targetClass eq $baseClass;
81 167 50   6   1107 next if lsearch {$_ eq $baseClass} $array;
  6         33  
82 167         874 push @uniqBase, $baseClass;
83             }
84             } else {
85 0         0 *{$isa} = [];
  0         0  
86 0         0 @uniqBase = @baseClass;
87             }
88 169         359 push @{*{$isa}{ARRAY}}, @uniqBase;
  169         208  
  169         2427  
89             }
90              
91             sub lift_isa_to {
92 12     12 0 33 my ($new_parent, $child) = @_;
93 12         19 my $orig = *{globref($child, 'ISA')};
  12         32  
94 12         25 my $isa = *{$orig}{ARRAY};
  12         44  
95 12 50       40 *{$orig} = $isa = [] unless $isa;
  0         0  
96 12         29 my @orig = @$isa;
97             # croak "Multiple inheritance is not supported: $child isa @orig"
98             # if @orig > 1;
99              
100             # !!: *{$orig} = [$new_parent]; is not ok.
101 12         142 @$isa = $new_parent;
102              
103 12 100       304 return unless @orig;
104 3         10 add_isa(undef, $new_parent, @orig);
105             }
106              
107             1;