File Coverage

blib/lib/CPAN/SQLite/Util.pm
Criterion Covered Total %
statement 44 80 55.0
branch 7 28 25.0
condition 3 19 15.7
subroutine 13 19 68.4
pod 1 6 16.6
total 68 152 44.7


line stmt bran cond sub pod time code
1             # $Id: Util.pm 82 2020-05-30 06:14:27Z stro $
2              
3             package CPAN::SQLite::Util;
4 9     9   157306 use strict;
  9         41  
  9         310  
5 9     9   48 use warnings;
  9         16  
  9         411  
6              
7             our $VERSION = '0.218';
8              
9 9     9   1051 use English qw/-no_match_vars/;
  9         7603  
  9         64  
10              
11 9     9   7375 use parent 'Exporter';
  9         2804  
  9         58  
12             our (@EXPORT_OK, %modes, $table_id, $query_info, $mode_info, $full_id);
13             @EXPORT_OK = qw($repositories %modes
14             vcmp $table_id $query_info $mode_info $full_id
15             has_hash_data has_array_data
16             download print_debug);
17              
18             make_ids();
19              
20             $mode_info = {
21             module => {
22             id => 'mod_id',
23             table => 'mods',
24             name => 'mod_name',
25             text => 'mod_abs',
26             },
27             dist => {
28             id => 'dist_id',
29             table => 'dists',
30             name => 'dist_name',
31             text => 'dist_abs',
32             },
33             author => {
34             id => 'auth_id',
35             table => 'auths',
36             name => 'cpanid',
37             text => 'fullname',
38             },
39             };
40              
41             %modes = map { $_ => 1 } keys %$mode_info;
42              
43             $query_info = {
44             module => { mode => 'module', type => 'name' },
45             mod_id => { mode => 'module', type => 'id' },
46             dist => { mode => 'dist', type => 'name' },
47             dist_id => { mode => 'dist', type => 'id' },
48             cpanid => { mode => 'author', type => 'name' },
49             author => { mode => 'author', type => 'name' },
50             auth_id => { mode => 'author', type => 'id' },
51             };
52              
53             sub make_ids {
54 9     9 0 23 my @tables = qw(mods dists auths);
55 9         22 foreach my $table (@tables) {
56 27         195 (my $id = $table) =~ s!(\w+)s$!$1_id!;
57 27         84 $table_id->{$table} = $id;
58 27         93 $full_id->{$id} = $table . '.' . $id;
59             }
60 9         51 return;
61             }
62              
63             #my $num_re = qr{^0*\.\d+$};
64             #sub vcmp {
65             # my ($v1, $v2) = @_;
66             # return unless (defined $v1 and defined $v2);
67             # if ($v1 =~ /$num_re/ and $v2 =~ /$num_re/) {
68             # return $v1 <=> $v2;
69             # }
70             # return Sort::Versions::versioncmp($v1, $v2);
71             #}
72              
73             sub has_hash_data {
74 9     9 0 20 my $data = shift;
75 9 50 33     49 return unless (defined $data and ref($data) eq 'HASH');
76 9 50       74 return (scalar keys %$data > 0) ? 1 : 0;
77             }
78              
79             sub has_array_data {
80 0     0 0 0 my $data = shift;
81 0 0 0     0 return unless (defined $data and ref($data) eq 'ARRAY');
82 0 0       0 return (scalar @$data > 0) ? 1 : 0;
83             }
84              
85             sub download {
86 3999     3999 0 1200178 my ($cpanid, $dist_file) = @_;
87 3999 50 33     13326 return unless ($cpanid and $dist_file);
88 3999         35114 (my $fullid = $cpanid) =~ s!^(\w)(\w)(.*)!$1/$1$2/$1$2$3!;
89 3999         11172 my $download = $fullid . '/' . $dist_file;
90 3999         11746 return $download;
91             }
92              
93             sub print_debug {
94 98 50   98 0 397 return unless $ENV{CPAN_SQLITE_DEBUG};
95 0         0 $CPAN::FrontEnd->myprint(@_);
96             }
97              
98             sub vcmp {
99 13     13 1 31 my ($v1, $v2) = @_;
100 13         33 return CPAN::SQLite::Version->vcmp($v1, $v2);
101             }
102              
103             # This is borrowed essentially verbatim from CPAN::Version
104             # It's included here so as to not demand a CPAN.pm upgrade
105              
106             package CPAN::SQLite::Version;
107              
108 9     9   5391 use strict;
  9         42  
  9         303  
109             our $VERSION = '0.218';
110 9     9   55 no warnings;
  9         17  
  9         3650  
111              
112             # CPAN::Version::vcmp courtesy Jost Krieger
113             sub vcmp {
114 13     13   23 my ($self, $l, $r) = @_;
115              
116 13 50       27 return 0 if $l eq $r; # short circuit for quicker success
117              
118 13         25 for ($l, $r) {
119 26 50       60 next unless tr/.// > 1;
120 0         0 s/^v?/v/;
121 0         0 1 while s/\.0+(\d)/.$1/;
122             }
123 13 50       33 if ($l =~ /^v/ <=> $r =~ /^v/) {
124 0         0 for ($l, $r) {
125 0 0       0 next if /^v/;
126 0         0 $_ = $self->float2vv($_);
127             }
128             }
129              
130             return (
131 13   33     146 ($l ne "undef") <=> ($r ne "undef")
132             || ($] >= 5.006
133             && $l =~ /^v/
134             && $r =~ /^v/
135             && $self->vstring($l) cmp $self->vstring($r))
136             || $l <=> $r
137             || $l cmp $r
138             );
139             }
140              
141             sub vgt {
142 0     0     my ($self, $l, $r) = @_;
143 0           return $self->vcmp($l, $r) > 0;
144             }
145              
146             sub vlt {
147 0     0     my ($self, $l, $r) = @_;
148 0           return 0 + ($self->vcmp($l, $r) < 0);
149             }
150              
151             sub vstring {
152 0     0     my ($self, $n) = @_;
153 0 0         $n =~ s/^v//
154             or die "CPAN::Search::Lite::Version::vstring() called with invalid arg [$n]";
155             {
156 9     9   76 no warnings;
  9         28  
  9         3998  
  0            
157 0           return pack "U*", split /\./, $n;
158             }
159             }
160              
161             # vv => visible vstring
162             sub float2vv {
163 0     0     my ($self, $n) = @_;
164 0           my ($rev) = int($n);
165 0   0       $rev ||= 0;
166 0           my ($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
167             # architecture influence
168 0   0       $mantissa ||= 0;
169 0           $mantissa .= "0" while length($mantissa) % 3;
170 0           my $ret = "v" . $rev;
171              
172 0           while ($mantissa) {
173 0 0         $mantissa =~ s/(\d{1,3})//
174             or die "Panic: length>0 but not a digit? mantissa[$mantissa]";
175 0           $ret .= "." . int($1);
176             }
177              
178             # warn "n[$n]ret[$ret]";
179 0           return $ret;
180             }
181              
182             sub readable {
183 0     0     my ($self, $n) = @_;
184 0           $n =~ /^([\w\-\+\.]+)/;
185              
186 0 0 0       return $1 if defined $1 && length($1) > 0;
187              
188             # if the first user reaches version v43, he will be treated as "+".
189             # We'll have to decide about a new rule here then, depending on what
190             # will be the prevailing versioning behavior then.
191              
192 0 0         if ($] < 5.006) { # or whenever v-strings were introduced
193             # we get them wrong anyway, whatever we do, because 5.005 will
194             # have already interpreted 0.2.4 to be "0.24". So even if he
195             # indexer sends us something like "v0.2.4" we compare wrongly.
196              
197             # And if they say v1.2, then the old perl takes it as "v12"
198              
199 0           warn("Suspicious version string seen [$n]\n");
200 0           return $n;
201             }
202 0           my $better = sprintf "v%vd", $n;
203 0           return $better;
204             }
205              
206             1;
207              
208             __END__