File Coverage

blib/lib/DDC/Any.pm
Criterion Covered Total %
statement 83 93 89.2
branch 34 54 62.9
condition 11 26 42.3
subroutine 12 12 100.0
pod 0 4 0.0
total 140 189 74.0


line stmt bran cond sub pod time code
1             #-*- Mode: CPerl -*-
2              
3             ## File: DDC::Any.pm
4             ## Author: Bryan Jurish
5             ## Description:
6             ## + DDC Query utilities: wrap DDC::XS or DDC::PP
7             ##======================================================================
8              
9             package DDC::Any;
10 17     17   1662184 use DDC::Concordance;
  17         59  
  17         599  
11 17     17   108 use Carp qw(carp confess);
  17         34  
  17         781  
12 17     17   92 use strict;
  17         33  
  17         8488  
13              
14             our @ISA = qw();
15             our $VERSION = $DDC::Concordance::VERSION;
16              
17             ##======================================================================
18             ## Globals
19              
20             our $WHICH = undef;
21             our ($COMPILER);
22              
23             ##======================================================================
24             ## Overrides
25              
26             ## $CQuery = DDC::Any->parse($qstr)
27             ## + convenience wrapper, re-implemented here b/c it uses the __PACKAGE__ keyword
28             sub parse {
29 97 50   97 0 34296 shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
30 97 100       313 $COMPILER = DDC::Any::CQueryCompiler->new() if (!$COMPILER);
31 97         303 return $COMPILER->ParseQuery(@_);
32             }
33              
34             ## $version = DDC::Any->library_version()
35             ## + returns extended version string
36             sub library_version {
37 2 50   2 0 1715 return undef if (!defined($WHICH));
38 2         32 return "$WHICH / " . $WHICH->can('library_version')->();
39             }
40              
41              
42             ## $obj = DDC::Any::Object->new(@args)
43             ## + override calls "real" subclass new() method
44             package DDC::Any::Object;
45             sub new {
46 30     30   2501 my $that = shift;
47 30   33     193 my $class = ref($that)||$that;
48 30         218 $class =~ s/^DDC::Any::/${DDC::Any::WHICH}::/;
49 30         221 return $class->new(@_);
50             };
51              
52             ##======================================================================
53             ## Import
54             package DDC::Any;
55              
56             ##--------------------------------------------------------------
57             ## $bool = PACKAGE->have_xs()
58             ## + attempts to load DDC::XS, and returns true if it is available in a suitable version
59             our $MIN_XS_VERSION = 0.21;
60             sub have_xs {
61 12 50   12 0 705 shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
62 12 50   12   2154 eval "use DDC::XS;" if (!$INC{'DDC/XS.pm'});
  0         0  
  0         0  
  12         775  
63 12 50       109 return 0 if (!$INC{'DDC/XS.pm'});
64 0   0     0 (my $xs_version = ($DDC::XS::VERSION||0)) =~ s/[^0-9\.]//g;
65 0   0     0 return ($xs_version && $xs_version >= $MIN_XS_VERSION);
66             }
67              
68             ##--------------------------------------------------------------
69             ## \%dst_stash = mapstash($src,$dst,%opts)
70             ## + %opts:
71             ## inherit => $which ##-- tweak inheritance; (0:don't, >0:$dst ISA $src, <0:$src ISA $dst)
72             ## deep => $bool, ##-- walk package tree? (default: true)
73             ## ignore => $re, ##-- ignore fully qualified source-symbols matching $re (default:none)
74             sub mapstash {
75 11     11 0 82 my ($src0,$dst0,%opts) = @_;
76 11   50     64 my $inherit = $opts{inherit} || 0;
77 11 50       1333 my $deep = exists($opts{deep}) ? $opts{deep} : 1;
78 11         32 my $ignore = $opts{ignore};
79 11 50       5941 $ignore = qr{$ignore} if (!ref($ignore));
80 11         2761 my @queue = ([$src0,$dst0]);
81 17     17   133 no strict 'refs';
  17         39  
  17         12944  
82 11         1522 while (@queue) {
83 737         1505 my ($src,$dst) = @{shift @queue};
  737         1682  
84             #print STDERR "mapping $src -> $dst\n";
85 737         2736 my $src_stash = \%{"${src}::"};
  737         2116  
86 737         987 my $dst_stash = \%{"${dst}::"};
  737         1554  
87 737         4374 while (my ($src_sym,$src_glob)=each %$src_stash) {
88 8514 100 66     53473 if ($ignore && "${src}::${src_sym}" =~ $ignore) {
89             ##-- ignored
90 638         3428 next;
91             }
92 7876 100 66     25970 if ($deep && $src_sym =~ /::$/) {
    100          
93             ##-- sub-package
94 726         1953 $src_sym =~ s/::$//;
95 726         1002 $dst_stash->{"${src_sym}::"} = *{"${dst}::${src_sym}::"};
  726         3210  
96 726         4240 push(@queue, ["${src}::${src_sym}","${dst}::${src_sym}"]);
97             }
98             elsif ($src_sym eq 'ISA') {
99             ##-- copy inheritance
100 715         1022 @{"${dst}::ISA"} = map {(my $isa=$_)=~s/^\Q${src0}\E\b/${dst0}/; $isa} @{"${src}::ISA"};
  715         28844  
  693         4214  
  693         2239  
  715         2421  
101             }
102             else {
103             ##-- anything else: copy
104 6435         51776 $dst_stash->{$src_sym} = $src_glob;
105             }
106             }
107              
108 737 50       2212 if ($inherit > 0) {
    50          
109 0         0 push(@{"${dst}::ISA"}, $src); ##-- tweak inheritance: $dst ISA $src
  0         0  
110             } elsif ($inherit < 0) {
111 737         951 push(@{"${src}::ISA"}, $dst); ##-- tweak inheritance: $src ISA $dst
  737         34542  
112             }
113             }
114              
115 11         32 return \%{"${dst0}::"};
  11         63  
116             }
117              
118              
119             ##--------------------------------------------------------------
120             ## import guts
121              
122             ## $WHICH = PACKAGE->import(@requests)
123             sub import {
124 18     18   269 my $that = shift;
125              
126             ##-- parse user request
127 18         41 my $which = $WHICH;
128 18         97 my %alias = ('xs'=>'DDC::XS', pp=>'DDC::PP', any=>'', default=>'');
129 18         51 foreach (@_) {
130 11 50       107 if (/^:(\S+)$/i) {
131 11         54 $which = lc($1);
132 11 100       48 $which = $alias{$which} if (exists($alias{$which}));
133             }
134             }
135              
136             ##-- sanity check(s)
137 18 100       76 if ($which) {
138 11 100       2035 return $WHICH if ($which eq 'none'); ##-- don't map back-end (yet)
139 4 50       15 if ($WHICH) {
140 0 0       0 carp(__PACKAGE__ . "::import() cannot override current back-end '$WHICH' -- ignoring user request '$which'")
141             if ($WHICH ne $which);
142 0         0 return $WHICH;
143             }
144             }
145              
146             ##-- be safe anyways
147 11         31 undef $WHICH;
148 11         25 undef $COMPILER;
149              
150             ##-- load back-end
151 11 100 66     70 if (!$which || $which eq 'DDC::XS') {
152 7 50       30 if (!$that->have_xs()) {
153 7 50 50     63 die("DDC::Any::import(): failed to load DDC::XS back-end: $@") if (($which||'') eq 'DDC::XS');
154             } else {
155 0         0 $which = 'DDC::XS';
156             }
157             }
158 11 50 66     80 if (!$which || $which eq 'DDC::PP') {
159 11 100   10   951 eval "use DDC::PP;" if (!$INC{'DDC/PP.pm'});
  10         4409  
  10         42  
  10         282  
160 11 50       83 if (!$INC{'DDC/PP.pm'}) {
161 0 0 0     0 die("DDC::Any::import(): failed to load DDC::PP back-end: $@") if (($which||'') eq 'DDC::PP');
162             } else {
163 11         41 $which = 'DDC::PP';
164             }
165             }
166 11 50       52 die("DDC::Any::import(): failed to load any back-end") if (!$which);
167              
168             ##-- map back-end
169 11         32 $WHICH = $which;
170 11         636 mapstash($WHICH=>'DDC::Any', deep=>1, inherit=>-1, ignore=>qr{${WHICH}::(?:VERSION|COMPILER|parse|import|library_version|.*::new)$});
171 11         16339 return $WHICH;
172             }
173              
174              
175             1; ##-- be happy
176              
177             __END__