1 |
commit: ae542435b657a9af7585b4e4a977d2ba3d5797fc |
2 |
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com> |
3 |
AuthorDate: Mon Oct 31 01:19:44 2011 +0000 |
4 |
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com> |
5 |
CommitDate: Mon Oct 31 02:45:48 2011 +0000 |
6 |
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=ae542435 |
7 |
|
8 |
overhauld and refactor deptree displayer |
9 |
|
10 |
--- |
11 |
scripts/lib/dep/handler/stdout.pm | 107 ++++++++++ |
12 |
scripts/lib/dep/module.pm | 34 ++++ |
13 |
scripts/lib/dep/provided.pm | 56 ++++++ |
14 |
scripts/lib/dep/specialvs.pm | 63 ++++++ |
15 |
scripts/lib/dep/wanted.pm | 40 ++++ |
16 |
scripts/lib/deptools.pm | 225 +++++++++++++++++++++ |
17 |
scripts/show_deptree.pl | 394 ++----------------------------------- |
18 |
7 files changed, 542 insertions(+), 377 deletions(-) |
19 |
|
20 |
diff --git a/scripts/lib/dep/handler/stdout.pm b/scripts/lib/dep/handler/stdout.pm |
21 |
new file mode 100644 |
22 |
index 0000000..a652da6 |
23 |
--- /dev/null |
24 |
+++ b/scripts/lib/dep/handler/stdout.pm |
25 |
@@ -0,0 +1,107 @@ |
26 |
+use strict; |
27 |
+use warnings; |
28 |
+ |
29 |
+package dep::handler::stdout; |
30 |
+ |
31 |
+# FILENAME: stdout.pm |
32 |
+# CREATED: 31/10/11 13:30:29 by Kent Fredric (kentnl) <kentfredric@×××××.com> |
33 |
+# ABSTRACT: Dispatch dependency information to STDOUT. |
34 |
+ |
35 |
+use Moose; |
36 |
+has 'indent' => ( is => 'rw' ); |
37 |
+has 'tail' => ( is => 'rw' ); |
38 |
+__PACKAGE__->meta->make_immutable; |
39 |
+ |
40 |
+sub begin_dep { |
41 |
+ my ( $self, $release, $module, $declaration ) = @_; |
42 |
+ $self->indent(" \e[1;92m*"); |
43 |
+ $self->tail(" \e[1;92m-\n\n"); |
44 |
+ my $wantstring = $self->_want_string( $release, $module, $declaration ); |
45 |
+ return *STDOUT->printf( "\e[1;93m%s\e[0m\n", $wantstring ); |
46 |
+} |
47 |
+ |
48 |
+sub evt_not_any { |
49 |
+ my ( $self, $module, $declaration ) = @_; |
50 |
+ return *STDOUT->printf( "%sWARNING: NO PROVIDER FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" ); |
51 |
+} |
52 |
+ |
53 |
+sub evt_multi { |
54 |
+ my ( $self, $module, $declaration ) = @_; |
55 |
+ $self->indent(" \e[1;91m*"); |
56 |
+ $self->tail(" \e[1;91m-\n\n"); |
57 |
+ |
58 |
+ return *STDOUT->printf( "%sWARNING: MULTIPLE PROVIDERS FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" ); |
59 |
+} |
60 |
+ |
61 |
+sub set_latest { |
62 |
+ my ( $self, $dep, $pkg ) = @_; |
63 |
+ return *STDOUT->printf( "%s\e[1;95m latest: %s => %s ( %s )\n", $self->indent, @{$dep}, $pkg ); |
64 |
+} |
65 |
+ |
66 |
+sub _want_string { |
67 |
+ my ( $self, $release, $module, $declaration ) = @_; |
68 |
+ return $release . " -> " . $declaration->[2] . " " . $declaration->[3] . " " . $self->_depstring( $module, $declaration ); |
69 |
+} |
70 |
+ |
71 |
+sub _depstring { |
72 |
+ my ( $self, $module, $declaration ) = @_; |
73 |
+ |
74 |
+ my $depstring = $module; |
75 |
+ |
76 |
+ if ( $declaration->[1] ne '0.0.0' ) { |
77 |
+ $depstring .= " " . $declaration->[0] . " ( " . $declaration->[1] . " ) "; |
78 |
+ } |
79 |
+ return $depstring; |
80 |
+} |
81 |
+ |
82 |
+sub _xwrap { |
83 |
+ my $self = shift; |
84 |
+ require Text::Wrap; |
85 |
+ local $Text::Wrap::break = qr/,/; |
86 |
+ local $Text::Wrap::overflow = 'huge'; |
87 |
+ local $Text::Wrap::columns = 128; |
88 |
+ $Text::Wrap::overflow = 'huge'; |
89 |
+ my $pre = " "; |
90 |
+ my $lines = Text::Wrap::wrap( $pre, $pre, @_ ); |
91 |
+ return $lines; |
92 |
+} |
93 |
+sub perl_dep { |
94 |
+ my ( $self, $module, $declaration , $pkg ) = @_ ; |
95 |
+ *STDOUT->printf("%s %s%s -> %s%s\n", $self->indent, "\e[1;94m", $module, "\e[0m\e[94m", $pkg ); |
96 |
+} |
97 |
+sub provider_group { |
98 |
+ my ( $self, $data ) = @_; |
99 |
+ |
100 |
+ my $want_string = $self->_want_string( $data->{release}, $data->{module}, $data->{declaration} ); |
101 |
+ my $depstring = $self->_depstring( $data->{module}, $data->{declaration} ); |
102 |
+ |
103 |
+ my $prefix = $depstring . ' in ' . $data->{provider}; |
104 |
+ |
105 |
+ my $lines = $self->_xwrap( join q[, ], @{ $data->{versions} } ); |
106 |
+ my (@slines) = split /$/m, $lines; |
107 |
+ $_ =~ s/[\r\n]*//m for @slines; |
108 |
+ |
109 |
+ *STDOUT->printf( " %s%s -> %s%s (%s)\n", "\e[1;92m", $depstring, "\e[0m\e[92m", $data->{provider}, $data->{gentoo_pkg} ); |
110 |
+ *STDOUT->printf( "%s newest: %s\e[0m\n", $self->indent, $data->{newest} ); |
111 |
+ *STDOUT->printf( "%s oldest: %s\e[0m\n", $self->indent, $data->{oldest} ); |
112 |
+ |
113 |
+ my $v = $data->{closest}; |
114 |
+ if ( not $data->{has_closest} ) { $v = 'undef' } |
115 |
+ |
116 |
+ *STDOUT->printf( "%s closest: %s\e[0m\n", $self->indent, $v ); |
117 |
+ |
118 |
+ for (@slines) { |
119 |
+ *STDOUT->printf( "%s %s%s -> %s%s\n", $self->indent, "\e[1;94m", $data->{provider}, "\e[0m\e[94m", $_ ); |
120 |
+ } |
121 |
+ |
122 |
+} |
123 |
+ |
124 |
+sub done { |
125 |
+ my ( $self, $module, $declaration ) = @_; |
126 |
+ return *STDOUT->print( $self->tail ); |
127 |
+} |
128 |
+ |
129 |
+no Moose; |
130 |
+__PACKAGE__->meta->make_immutable; |
131 |
+1; |
132 |
+ |
133 |
|
134 |
diff --git a/scripts/lib/dep/module.pm b/scripts/lib/dep/module.pm |
135 |
new file mode 100644 |
136 |
index 0000000..26f5fe6 |
137 |
--- /dev/null |
138 |
+++ b/scripts/lib/dep/module.pm |
139 |
@@ -0,0 +1,34 @@ |
140 |
+use strict; |
141 |
+use warnings; |
142 |
+ |
143 |
+package dep::module; |
144 |
+ |
145 |
+# FILENAME: module.pm |
146 |
+# CREATED: 31/10/11 13:44:00 by Kent Fredric (kentnl) <kentfredric@×××××.com> |
147 |
+# ABSTRACT: A dependency record for a single module |
148 |
+ |
149 |
+use Moose; |
150 |
+ |
151 |
+has 'name' => ( isa => "Str", required => 1, is => 'rw', ); |
152 |
+has 'version_string' => ( isa => 'Maybe[Str]', is => 'rw', init_arg => 'version', predicate => 'has_version_string' ); |
153 |
+has 'version' => ( is => 'rw', lazy_build => 1, init_arg => undef ); |
154 |
+has 'parent' => ( is => 'rw', required => 1, weak_ref => 1 ); |
155 |
+ |
156 |
+sub _build_version { |
157 |
+ require version; |
158 |
+ my $self = shift; |
159 |
+ return version->parse( $self->version_string ); |
160 |
+} |
161 |
+ |
162 |
+sub debug_string { |
163 |
+ my $self = shift; |
164 |
+ return sprintf '%s ( %s ) => %s', $self->parent->version, |
165 |
+ $self->parent->can_gv ? $self->parent->gv : 'undef', |
166 |
+ $self->has_version_string ? '"' . $self->version_string . '"' : 'undef'; |
167 |
+} |
168 |
+ |
169 |
+__PACKAGE__->meta->make_immutable; |
170 |
+ |
171 |
+no Moose; |
172 |
+1; |
173 |
+ |
174 |
|
175 |
diff --git a/scripts/lib/dep/provided.pm b/scripts/lib/dep/provided.pm |
176 |
new file mode 100644 |
177 |
index 0000000..19c058e |
178 |
--- /dev/null |
179 |
+++ b/scripts/lib/dep/provided.pm |
180 |
@@ -0,0 +1,56 @@ |
181 |
+use strict; |
182 |
+use warnings; |
183 |
+ |
184 |
+package dep::provided; |
185 |
+ |
186 |
+# FILENAME: provided.pm |
187 |
+# CREATED: 31/10/11 13:42:24 by Kent Fredric (kentnl) <kentfredric@×××××.com> |
188 |
+# ABSTRACT: repesents a provided package |
189 |
+ |
190 |
+use Moose; |
191 |
+require dep::module; |
192 |
+ |
193 |
+has 'distribution' => ( isa => 'Defined', is => 'rw', required => 1 ); |
194 |
+has 'version' => ( is => 'rw', required => 1 ); |
195 |
+has 'maturity' => ( is => 'rw', required => 1 ); |
196 |
+has 'status' => ( is => 'rw', required => 1 ); |
197 |
+has 'gv' => ( is => 'rw', lazy_build => 1 ); |
198 |
+has '_modules' => ( isa => 'ArrayRef', required => 1, init_arg => '_source.module', is => 'rw', ); |
199 |
+has 'modules' => ( isa => 'ArrayRef[dep::module]', lazy_build => 1, is => 'rw' ); |
200 |
+ |
201 |
+__PACKAGE__->meta->make_immutable; |
202 |
+ |
203 |
+sub _build_modules { |
204 |
+ my $self = shift; |
205 |
+ return [ map { dep::module->new( %{$_}, parent => $self ) } @{ $self->_modules } ]; |
206 |
+} |
207 |
+ |
208 |
+sub _build_gv { |
209 |
+ require Gentoo::PerlMod::Version; |
210 |
+ use Try::Tiny; |
211 |
+ my ($self) = @_; |
212 |
+ my $v; |
213 |
+ try { |
214 |
+ $v = Gentoo::PerlMod::Version::gentooize_version( $self->version, { lax => 1 } ); |
215 |
+ } |
216 |
+ catch { |
217 |
+ $v = undef; |
218 |
+ }; |
219 |
+ return $v; |
220 |
+} |
221 |
+ |
222 |
+sub can_gv { |
223 |
+ return defined $_[0]->gv; |
224 |
+} |
225 |
+ |
226 |
+sub is_dev { |
227 |
+ return $_[0]->maturity eq 'development'; |
228 |
+} |
229 |
+ |
230 |
+sub is_backpan { |
231 |
+ return $_[0]->status eq 'backpan'; |
232 |
+} |
233 |
+ |
234 |
+no Moose; |
235 |
+1; |
236 |
+ |
237 |
|
238 |
diff --git a/scripts/lib/dep/specialvs.pm b/scripts/lib/dep/specialvs.pm |
239 |
new file mode 100644 |
240 |
index 0000000..19b6ff5 |
241 |
--- /dev/null |
242 |
+++ b/scripts/lib/dep/specialvs.pm |
243 |
@@ -0,0 +1,63 @@ |
244 |
+use strict; |
245 |
+use warnings; |
246 |
+ |
247 |
+package dep::specialvs; |
248 |
+ |
249 |
+# FILENAME: specialvs.pm |
250 |
+# CREATED: 31/10/11 13:38:14 by Kent Fredric (kentnl) <kentfredric@×××××.com> |
251 |
+# ABSTRACT: Collect special version information about a dependency |
252 |
+ |
253 |
+use Moose; |
254 |
+ |
255 |
+has newest => ( isa => 'HashRef', default => sub { {} }, is => 'rw' ); |
256 |
+has newestx => ( isa => 'HashRef', default => sub { {} }, is => 'rw' ); |
257 |
+ |
258 |
+has oldest => ( isa => 'HashRef', default => sub { {} }, is => 'rw' ); |
259 |
+has oldestx => ( isa => 'HashRef', default => sub { {} }, is => 'rw' ); |
260 |
+ |
261 |
+has closest => ( isa => 'HashRef', default => sub { {} }, is => 'rw' ); |
262 |
+has closestx => ( isa => 'HashRef', default => sub { {} }, is => 'rw' ); |
263 |
+ |
264 |
+has latest => ( is => 'rw', predicate => 'has_latest' ); |
265 |
+has latestx => ( is => 'rw', predicate => 'has_latestx' ); |
266 |
+ |
267 |
+sub set_latest_mod { |
268 |
+ my ( $self, $provider, $mod ) = @_; |
269 |
+ return if $self->has_latest; |
270 |
+ $self->latest( [ $provider, $mod->debug_string ] ); |
271 |
+ $self->latestx( [ $provider, $mod ] ); |
272 |
+} |
273 |
+ |
274 |
+sub set_newest_mod { |
275 |
+ my ( $self, $key, $mod ) = @_; |
276 |
+ return if exists $self->newest->{$key}; |
277 |
+ $self->newest->{$key} = $mod->debug_string; |
278 |
+ $self->newestx->{$key} = $mod; |
279 |
+} |
280 |
+ |
281 |
+sub set_oldest_mod { |
282 |
+ my ( $self, $key, $mod ) = @_; |
283 |
+ |
284 |
+ $self->oldest->{$key} = $mod->debug_string; |
285 |
+ $self->oldestx->{$key} = $mod; |
286 |
+} |
287 |
+ |
288 |
+sub set_closest_mod { |
289 |
+ my ( $self, $key, $mod ) = @_; |
290 |
+ if ( not defined $self->closestx->{$key} ) { |
291 |
+ $self->closestx->{$key} = $mod; |
292 |
+ $self->closest->{$key} = $mod->debug_string; |
293 |
+ return; |
294 |
+ } |
295 |
+ if ( $self->closestx->{$key}->version >= $mod->version ) { |
296 |
+ $self->closestx->{$key} = $mod; |
297 |
+ $self->closest->{$key} = $mod->debug_string; |
298 |
+ } |
299 |
+ return; |
300 |
+} |
301 |
+ |
302 |
+__PACKAGE__->meta->make_immutable; |
303 |
+ |
304 |
+no Moose; |
305 |
+1; |
306 |
+ |
307 |
|
308 |
diff --git a/scripts/lib/dep/wanted.pm b/scripts/lib/dep/wanted.pm |
309 |
new file mode 100644 |
310 |
index 0000000..f2b13c6 |
311 |
--- /dev/null |
312 |
+++ b/scripts/lib/dep/wanted.pm |
313 |
@@ -0,0 +1,40 @@ |
314 |
+use strict; |
315 |
+use warnings; |
316 |
+ |
317 |
+package dep::wanted; |
318 |
+ |
319 |
+# FILENAME: wanted.pm |
320 |
+# CREATED: 31/10/11 13:45:03 by Kent Fredric (kentnl) <kentfredric@×××××.com> |
321 |
+# ABSTRACT: a record for something wanted to be a dep |
322 |
+ |
323 |
+use Moose; |
324 |
+has [qw( module version_string )] => ( isa => 'Str', is => 'rw', 'required' => 1 ); |
325 |
+has [qw( gentoo_version version )] => ( is => 'rw', lazy_build => 1 ); |
326 |
+ |
327 |
+sub _build_gentoo_version { |
328 |
+ my $self = shift; |
329 |
+ require Gentoo::PerlMod::Version; |
330 |
+ return Gentoo::PerlMod::Version::gentooize_version( $self->version_string ); |
331 |
+} |
332 |
+ |
333 |
+sub _build_version { |
334 |
+ my $self = shift; |
335 |
+ require version; |
336 |
+ return version->parse( $self->version_string ); |
337 |
+} |
338 |
+ |
339 |
+sub no_version_dep { |
340 |
+ return not defined $_[0]->version_string; |
341 |
+} |
342 |
+ |
343 |
+sub provides { |
344 |
+ require metacpan; |
345 |
+ my $self = shift; |
346 |
+ require dep::provided; |
347 |
+ return map { dep::provided->new( %{$_} ) } metacpan->find_dist_simple( $self->module ); |
348 |
+} |
349 |
+ |
350 |
+no Moose; |
351 |
+__PACKAGE__->meta->make_immutable; |
352 |
+1; |
353 |
+ |
354 |
|
355 |
diff --git a/scripts/lib/deptools.pm b/scripts/lib/deptools.pm |
356 |
new file mode 100644 |
357 |
index 0000000..a4cdc51 |
358 |
--- /dev/null |
359 |
+++ b/scripts/lib/deptools.pm |
360 |
@@ -0,0 +1,225 @@ |
361 |
+use 5.010000; |
362 |
+use strict; |
363 |
+use warnings; |
364 |
+ |
365 |
+package deptools; |
366 |
+ |
367 |
+# FILENAME: deptools.pm |
368 |
+# CREATED: 31/10/11 09:30:24 by Kent Fredric (kentnl) <kentfredric@×××××.com> |
369 |
+# ABSTRACT: Miscelanous bits for computing deps for Perl modules |
370 |
+ |
371 |
+sub virtual($) { return 'virtual/perl-' . shift } |
372 |
+sub lang($) { return 'dev-lang/' . shift } |
373 |
+ |
374 |
+sub _vmap_langs { |
375 |
+ return ( 'perl', 'perl_debug', ); |
376 |
+} |
377 |
+ |
378 |
+sub _vmap_perl_native { |
379 |
+ return ( |
380 |
+ 'Archive-Tar', 'Attribute-Handlers', 'AutoLoader', 'CGI', |
381 |
+ 'Class-ISA', 'Compress-Raw-Bzip2', 'Compress-Raw-Zlib', 'CPAN-Meta', |
382 |
+ 'CPAN-Meta-YAML', 'Data-Dumper', 'DB_File', 'Digest-MD5', |
383 |
+ 'Digest-SHA', 'Encode', 'ExtUtils-CBuilder', 'ExtUtils-Command', |
384 |
+ 'ExtUtils-Install', 'ExtUtils-MakeMaker', 'ExtUtils-Manifest', 'ExtUtils-ParseXS', |
385 |
+ 'File-Path', 'File-Temp', 'Filter', 'Getopt-Long', |
386 |
+ 'i18n-langtags', 'IO', 'IO-Compress', 'IO-Zlib', |
387 |
+ 'IPC-Cmd', 'JSON-PP', 'libnet', 'Locale-MakeText-Simple', |
388 |
+ 'Math-BigInt', 'Math-BigInt-FastCalc', 'Memoize', 'MIME-Base64', |
389 |
+ 'Module-Build', 'Module-CoreList', 'Module-Load', 'Module-Load-Conditional', |
390 |
+ 'Module-Loaded', 'Module-Metadata', 'Module-Pluggable', 'Package-Constants', |
391 |
+ 'Params-Check', 'parent', 'Parse-CPAN-Meta', 'Perl-OSType', |
392 |
+ 'Pod-Escapes', 'podlators', 'Pod-Simple', 'Safe', |
393 |
+ 'Scalar-List-Utils', 'Storable', 'Switch', 'Sys-Syslog', |
394 |
+ 'Term-ANSIColor', 'Test', 'Test-Harness', 'Test-Simple', |
395 |
+ 'Text-Balanced', 'Text-Tabs+Wrap', 'Thread-Queue', 'threads', |
396 |
+ 'Thread-Semaphore', 'threads-shared', 'Time-HiRes', 'Time-Local', |
397 |
+ 'Time-Piece', 'version', 'Version-Requirements', 'XSLoader', |
398 |
+ ); |
399 |
+} |
400 |
+ |
401 |
+sub _vmap_perl_strange { |
402 |
+ return ( |
403 |
+ 'Digest' => virtual 'digest-base', |
404 |
+ 'PathTools' => virtual 'File-Spec', |
405 |
+ 'Locale-MakeText' => virtual 'locale-maketext', |
406 |
+ 'Net-Ping' => virtual 'net-ping', |
407 |
+ 'Pod-Parser' => virtual 'PodParser', |
408 |
+ ); |
409 |
+} |
410 |
+ |
411 |
+sub _vmap_overlay_native { |
412 |
+ return ( |
413 |
+ 'Archive-Extract', 'B-Debug', 'B-Lint', 'constant', 'CPAN', |
414 |
+ 'CPANPLUS', 'CPANPLUS-Dist-Build', 'Devel-DProf', 'Devel-PPPort', 'Devel-SelfStubber', |
415 |
+ 'Dumpvalue', 'ExtUtils-Constant', 'ExtUtils-MakeMaker', 'File-Fetch', 'Filter-Simple', |
416 |
+ 'HTTP-Tiny', 'i18n-langtags', 'if', 'IPC-SysV', 'Log-Message', |
417 |
+ 'Log-Message-Simple', 'Math-Complex', 'Module-CoreList', 'NEXT', 'Object-Accessor', |
418 |
+ 'Pod-LaTeX', 'Pod-Perldoc', 'Pod-Plainer', 'SelfLoader', 'Term-UI', |
419 |
+ 'Unicode-Collate', 'Unicode-Normalize', |
420 |
+ ); |
421 |
+} |
422 |
+ |
423 |
+sub _vmap { |
424 |
+ return ( |
425 |
+ ( map { $_, lang $_ } _vmap_langs() ), |
426 |
+ ( map { $_, virtual $_ } _vmap_perl_native(), _vmap_overlay_native() ), |
427 |
+ _vmap_perl_strange(), |
428 |
+ ); |
429 |
+} |
430 |
+ |
431 |
+sub gentooize_pkg { |
432 |
+ my ( $pkg, $version ) = @_; |
433 |
+ state $vmap = { _vmap() }; |
434 |
+ my $outpkg = 'dev-perl/' . $pkg; |
435 |
+ if ( exists $vmap->{$pkg} ) { |
436 |
+ $outpkg = $vmap->{$pkg}; |
437 |
+ } |
438 |
+ if ( not $version or $version eq '0.0.0' ) { |
439 |
+ return $outpkg; |
440 |
+ } |
441 |
+ return '\\>=' . $outpkg . '-' . $version; |
442 |
+} |
443 |
+ |
444 |
+sub provider_map { |
445 |
+ |
446 |
+ require dep::wanted; |
447 |
+ my $wanted = dep::wanted->new( |
448 |
+ module => $_[0], |
449 |
+ version_string => $_[1], |
450 |
+ ); |
451 |
+ my @providers = $wanted->provides; |
452 |
+ |
453 |
+ my %moduleprov; |
454 |
+ |
455 |
+ require dep::specialvs; |
456 |
+ my $specialvs = dep::specialvs->new(); |
457 |
+ |
458 |
+ |
459 |
+ for my $provider (@providers) { |
460 |
+ |
461 |
+ next if $provider->is_backpan; |
462 |
+ next if $provider->is_dev; |
463 |
+ |
464 |
+ next unless $provider->can_gv; |
465 |
+ |
466 |
+ my @provided_matching_mods; |
467 |
+ for my $mod ( @{ $provider->modules } ) { |
468 |
+ |
469 |
+ next unless $mod->name eq $wanted->module; |
470 |
+ |
471 |
+ # specials |
472 |
+ $specialvs->set_latest_mod( $provider->distribution , $mod ); |
473 |
+ $specialvs->set_newest_mod( $provider->distribution, $mod ); |
474 |
+ $specialvs->set_oldest_mod( $provider->distribution, $mod ); |
475 |
+ |
476 |
+ if ( $wanted->no_version_dep or $mod->version >= $wanted->version ) { |
477 |
+ $specialvs->set_closest_mod( $provider->distribution, $mod ); |
478 |
+ } |
479 |
+ |
480 |
+ push @provided_matching_mods, $mod->debug_string |
481 |
+ if $mod->name eq $wanted->module; |
482 |
+ } |
483 |
+ $moduleprov{ $provider->distribution } //= []; |
484 |
+ push @{ $moduleprov{ $provider->distribution } }, @provided_matching_mods; |
485 |
+ } |
486 |
+ return \%moduleprov, $specialvs; |
487 |
+} |
488 |
+sub get_deps { |
489 |
+ my ($release) = shift; |
490 |
+ |
491 |
+ my ( $author, $distrelease ); |
492 |
+ |
493 |
+ $release =~ qr{^([^/]+)/(.*$)}; |
494 |
+ ( $author, $distrelease ) = ( "$1", "$2" ); |
495 |
+ require metacpan; |
496 |
+ return metacpan->find_release( $author, $distrelease ); |
497 |
+} |
498 |
+ |
499 |
+sub get_dep_phases { |
500 |
+ my ($release) = shift; |
501 |
+ my %phases; |
502 |
+ my %modules; |
503 |
+ my ( $result, ) = get_deps($release); |
504 |
+ for my $dep ( @{ $result->{dependency} } ) { |
505 |
+ my $phase = $dep->{phase}; |
506 |
+ my $module = $dep->{module}; |
507 |
+ my $required = ( $dep->{relationship} eq 'requires' ); |
508 |
+ |
509 |
+ next unless $required; |
510 |
+ next if $phase eq 'develop'; |
511 |
+ |
512 |
+ $phases{$phase} //= []; |
513 |
+ $modules{$module} //= []; |
514 |
+ |
515 |
+ require Gentoo::PerlMod::Version; |
516 |
+ my $v = Gentoo::PerlMod::Version::gentooize_version( $dep->{version}, { lax => 1 } ); |
517 |
+ |
518 |
+ push @{ $phases{$phase} }, [ $dep->{module}, $dep->{version}, $v, $dep->{relationship} ]; |
519 |
+ push @{ $modules{$module} }, [ $dep->{version}, $v, $dep->{phase}, $dep->{relationship} ]; |
520 |
+ } |
521 |
+ return { phases => \%phases, modules => \%modules }; |
522 |
+} |
523 |
+ |
524 |
+sub dispatch_dependency_handler { |
525 |
+ |
526 |
+ my ( $release, $module, $declaration, $feeder ) = @_; |
527 |
+ |
528 |
+ my ( $moduleprov, $specialvs ) = provider_map( $module, $declaration->[0] ); |
529 |
+ |
530 |
+ my $pc = scalar keys %$moduleprov; |
531 |
+ |
532 |
+ my $multi = ( $pc > 1 ); |
533 |
+ my $any = ( $pc > 0 ); |
534 |
+ |
535 |
+ $feeder->begin_dep( $release, $module, $declaration ); |
536 |
+ |
537 |
+ |
538 |
+ if( $module eq 'perl' ){ |
539 |
+ $feeder->perl_dep( $module, $declaration , gentooize_pkg( 'perl', $declaration->[1] )); |
540 |
+ return $feeder->done; |
541 |
+ } |
542 |
+ |
543 |
+ if ( not $any ) { $feeder->evt_not_any( $module, $declaration ); } |
544 |
+ |
545 |
+ if ($multi) { $feeder->evt_multi( $module, $declaration ); } |
546 |
+ |
547 |
+ #pp { |
548 |
+ # moduleprov => $moduleprov, |
549 |
+ # specialvs => $specialvs, |
550 |
+ # release => $release, |
551 |
+ # module => $module, |
552 |
+ # declaration => $declaration, |
553 |
+ # latest => $specialvs->latest, |
554 |
+ #}; |
555 |
+ if( $specialvs->has_latest ) { |
556 |
+ $feeder->set_latest( $specialvs->latest, |
557 |
+ gentooize_pkg( $specialvs->latest->[0], |
558 |
+ $declaration->[1] ) |
559 |
+ ); |
560 |
+ } |
561 |
+ |
562 |
+ for my $prov ( keys %{$moduleprov} ) { |
563 |
+ |
564 |
+ my $data = { |
565 |
+ release => $release, |
566 |
+ versions => $moduleprov->{$prov}, |
567 |
+ provider => $prov, |
568 |
+ gentoo_pkg => gentooize_pkg($prov), |
569 |
+ newest => $specialvs->newest->{$prov}, |
570 |
+ newestx => $specialvs->newestx->{$prov}, |
571 |
+ oldest => $specialvs->oldest->{$prov}, |
572 |
+ oldestx => $specialvs->oldestx->{$prov}, |
573 |
+ has_closest => exists $specialvs->closest->{$prov}, |
574 |
+ closest => $specialvs->closest->{$prov}, |
575 |
+ closestx => $specialvs->closestx->{$prov}, |
576 |
+ declaration => $declaration, |
577 |
+ module => $module, |
578 |
+ }; |
579 |
+ $feeder->provider_group($data); |
580 |
+ } |
581 |
+ $feeder->done( $module, $declaration ); |
582 |
+ |
583 |
+} |
584 |
+1; |
585 |
+ |
586 |
|
587 |
diff --git a/scripts/show_deptree.pl b/scripts/show_deptree.pl |
588 |
index e49728d..ef6d8e7 100755 |
589 |
--- a/scripts/show_deptree.pl |
590 |
+++ b/scripts/show_deptree.pl |
591 |
@@ -9,10 +9,7 @@ use warnings; |
592 |
use FindBin; |
593 |
use lib "$FindBin::Bin/lib"; |
594 |
use env::gentoo::perl_experimental; |
595 |
-use metacpan qw( mcpan ); |
596 |
use utf8; |
597 |
-use Gentoo::PerlMod::Version qw( gentooize_version ); |
598 |
-use Text::Wrap; |
599 |
|
600 |
my $flags; |
601 |
my $singleflags; |
602 |
@@ -37,389 +34,45 @@ if ( $flags->{help} or $singleflags->{h} ) { print help(); exit 0; } |
603 |
# |
604 |
# gen_ebuild.pl DOY/Moose-2.0301-TRIAL |
605 |
# |
606 |
-my ($release) = shift(@ARGV); |
607 |
- |
608 |
-*STDOUT->binmode(':utf8'); |
609 |
-*STDERR->binmode(':utf8'); |
610 |
- |
611 |
-my %phases; |
612 |
-my %modules; |
613 |
-my %providers; |
614 |
- |
615 |
-my $dep_phases = get_dep_phases($release); |
616 |
-%phases = %{ $dep_phases->{phases} }; |
617 |
-%modules = %{ $dep_phases->{modules} }; |
618 |
- |
619 |
-use Data::Dump qw( pp ); |
620 |
-use JSON qw( to_json encode_json ); |
621 |
-use Try::Tiny; |
622 |
-use version (); |
623 |
- |
624 |
-sub provider_map { |
625 |
- my ( $module, $version ) = @_; |
626 |
- my @providers = metacpan->find_dist_simple($module); |
627 |
- my %moduleprov; |
628 |
- |
629 |
- my %specialvs; |
630 |
- |
631 |
- my $wanted_version = version->parse($version); |
632 |
- |
633 |
- for my $provider (@providers) { |
634 |
- |
635 |
- #next if $provider->{status} eq 'backpan'; |
636 |
- next if $provider->{maturity} eq 'developer'; |
637 |
- |
638 |
- # pp $provider; |
639 |
- |
640 |
- my $dist = $provider->{distribution}; |
641 |
- my $distv = $provider->{version} // 'undef'; |
642 |
- my $gv = 'undef'; |
643 |
- if ( $distv ne 'undef' ) { |
644 |
- try { |
645 |
- $gv = gentooize_version( $distv, { lax => 1 } ); |
646 |
- } |
647 |
- catch { |
648 |
- $gv = '???'; |
649 |
- }; |
650 |
- } |
651 |
- |
652 |
- #next if $gv eq '???'; |
653 |
- |
654 |
- $moduleprov{$dist} //= []; |
655 |
- |
656 |
- my @provided_matching_mods; |
657 |
- for my $mod ( @{ $provider->{'_source.module'} } ) { |
658 |
- next unless $mod->{name} eq $module; |
659 |
- my $modv = $mod->{version} // 'undef'; |
660 |
- |
661 |
- my $got_version = version->parse( $mod->{version} ); |
662 |
- |
663 |
- my $dv = $distv; |
664 |
- $dv = sprintf "%s ( %s ) => \"%s\"", $distv, $gv, $modv; |
665 |
- |
666 |
- # specials |
667 |
- |
668 |
- $specialvs{newest} //= {}; |
669 |
- $specialvs{oldest} //= {}; |
670 |
- $specialvs{closest} //= {}; |
671 |
- $specialvs{closestx} //= {}; |
672 |
- $specialvs{latest} = [ $dist, $dv ] if not exists $specialvs{latest}; |
673 |
- $specialvs{newest}->{$dist} = $dv if not exists $specialvs{newest}->{$dist}; |
674 |
- $specialvs{oldest}->{$dist} = $dv; |
675 |
- |
676 |
- if ( not defined $version or $got_version >= $wanted_version ) { |
677 |
- |
678 |
- if ( not defined $specialvs{closestx}->{$dist} ) { |
679 |
- $specialvs{closestx}->{$dist} = $got_version; |
680 |
- $specialvs{closest}->{$dist} = $dv; |
681 |
- } |
682 |
- else { |
683 |
- if ( $specialvs{closestx}->{$dist} >= $got_version ) { |
684 |
- $specialvs{closestx}->{$dist} = $got_version; |
685 |
- $specialvs{closest}->{$dist} = $dv; |
686 |
- } |
687 |
- } |
688 |
- } |
689 |
- |
690 |
- # |
691 |
- |
692 |
- push @provided_matching_mods, $dv |
693 |
- if $mod->{name} eq $module; |
694 |
- } |
695 |
- push @{ $moduleprov{$dist} }, @provided_matching_mods; |
696 |
- } |
697 |
- return \%moduleprov, \%specialvs; |
698 |
-} |
699 |
- |
700 |
-sub handle_declaration { |
701 |
- my ( $release, $module, $declaration, $output ) = @_; |
702 |
- |
703 |
- my $depstring = $module; |
704 |
- if ( $declaration->[1] ne '0.0.0' ) { |
705 |
- $depstring .= " " . $declaration->[0] . " ( " . $declaration->[1] . " ) "; |
706 |
- } |
707 |
- |
708 |
- my $want_string = "$release -> " . $declaration->[2] . " " . $declaration->[3] . " " . $depstring; |
709 |
- |
710 |
- my ( $moduleprov, $specialvs ) = provider_map( $module, $declaration->[0] ); |
711 |
- |
712 |
- my $to_pkg = sub { |
713 |
- my $pkg = shift; |
714 |
- my $xpkg = gentooize_pkg($pkg); |
715 |
- if ( $declaration->[1] eq '0.0.0' ) { |
716 |
- return $xpkg; |
717 |
- } |
718 |
- return '\\>=' . $xpkg . '-' . $declaration->[1]; |
719 |
- }; |
720 |
- |
721 |
- my $pc = scalar keys %$moduleprov; |
722 |
- |
723 |
- my $multi = ( $pc > 1 ); |
724 |
- my $any = ( $pc > 0 ); |
725 |
- |
726 |
- $output->printf( "\e[1;93m%s\e[0m\n", $want_string ); |
727 |
- |
728 |
- if ( not $any ) { |
729 |
- return $output->printf( "%sWARNING: NO PROVIDER FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" ); |
730 |
- } |
731 |
- if ($multi) { |
732 |
- $output->printf( "%sWARNING: MULTIPLE PROVIDERS FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" ); |
733 |
- } |
734 |
- |
735 |
- my $indent = " \e[1;92m*"; |
736 |
- $indent = " \e[1;91m*" if $multi; |
737 |
- |
738 |
- $output->printf( |
739 |
- "%s\e[1;95m latest: %s => %s ( %s )\n", |
740 |
- $indent, |
741 |
- @{ $specialvs->{latest} }, |
742 |
- $to_pkg->( $specialvs->{latest}->[0] ) |
743 |
- ); |
744 |
- |
745 |
- for my $prov ( keys %{$moduleprov} ) { |
746 |
- my $prefix = $depstring . ' in ' . $prov; |
747 |
- my $lines = xwrap( join q[, ], @{ $moduleprov->{$prov} } ); |
748 |
- my (@slines) = split /$/m, $lines; |
749 |
- $_ =~ s/[\r\n]*//m for @slines; |
750 |
- $output->printf( " %s%s -> %s%s (%s)\n", "\e[1;92m", $depstring, "\e[0m\e[92m", $prov, gentooize_pkg($prov) ); |
751 |
- $output->printf( "%s newest: %s\e[0m\n", $indent, $specialvs->{newest}->{$prov} ); |
752 |
- $output->printf( "%s oldest: %s\e[0m\n", $indent, $specialvs->{oldest}->{$prov} ); |
753 |
- my $v = $specialvs->{closest}->{$prov}; |
754 |
- if ( not defined $v ) { $v = 'undef' } |
755 |
- $output->printf( "%s closest: %s\e[0m\n", $indent, $v ); |
756 |
- |
757 |
- for (@slines) { |
758 |
+sub help { |
759 |
+ return <<'EOF'; |
760 |
+gen_ebuild.pl |
761 |
|
762 |
- $output->printf( "%s %s%s -> %s%s\n", $indent, "\e[1;94m", $prov, "\e[0m\e[94m", $_ ); |
763 |
- } |
764 |
- } |
765 |
- if ($multi) { |
766 |
- $output->print(" \e[1;91m-\n\n"); |
767 |
- } |
768 |
- else { |
769 |
- $output->print(" \e[1;92m-\n\n"); |
770 |
- } |
771 |
+USAGE: |
772 |
|
773 |
-} |
774 |
+ show_deptree.pl DOY/Moose-2.0301-TRIAL |
775 |
|
776 |
-sub virtual($) { |
777 |
- my $i = shift; |
778 |
- return 'virtual/perl-' . $i; |
779 |
+EOF |
780 |
} |
781 |
+my ($release) = shift(@ARGV); |
782 |
|
783 |
-sub gentooize_pkg { |
784 |
- my $pkg = shift; |
785 |
- my %vmap = ( |
786 |
- 'perl' => 'dev-lang/perl', |
787 |
- 'perl_debug' => 'dev-lang/perl_debug', # doesn't actually exist |
788 |
- ( |
789 |
- map { $_, virtual $_ } |
790 |
- qw( |
791 |
- Archive-Tar |
792 |
- Attribute-Handlers |
793 |
- AutoLoader |
794 |
- CGI |
795 |
- Class-ISA |
796 |
- Compress-Raw-Bzip2 |
797 |
- Compress-Raw-Zlib |
798 |
- CPAN-Meta |
799 |
- CPAN-Meta-YAML |
800 |
- Data-Dumper |
801 |
- DB_File |
802 |
- Digest-MD5 |
803 |
- Digest-SHA |
804 |
- Encode |
805 |
- ExtUtils-CBuilder |
806 |
- ExtUtils-Command |
807 |
- ExtUtils-Install |
808 |
- ExtUtils-MakeMaker |
809 |
- ExtUtils-Manifest |
810 |
- ExtUtils-ParseXS |
811 |
- File-Path |
812 |
- File-Temp |
813 |
- Filter |
814 |
- Getopt-Long |
815 |
- i18n-langtags |
816 |
- IO |
817 |
- IO-Compress |
818 |
- IO-Zlib |
819 |
- IPC-Cmd |
820 |
- JSON-PP |
821 |
- libnet |
822 |
- Locale-MakeText-Simple |
823 |
- Math-BigInt |
824 |
- Math-BigInt-FastCalc |
825 |
- Memoize |
826 |
- MIME-Base64 |
827 |
- Module-Build |
828 |
- Module-CoreList |
829 |
- Module-Load |
830 |
- Module-Load-Conditional |
831 |
- Module-Loaded |
832 |
- Module-Metadata |
833 |
- Module-Pluggable |
834 |
- Package-Constants |
835 |
- Params-Check |
836 |
- parent |
837 |
- Parse-CPAN-Meta |
838 |
- Perl-OSType |
839 |
- Pod-Escapes |
840 |
- podlators |
841 |
- Pod-Simple |
842 |
- Safe |
843 |
- Scalar-List-Utils |
844 |
- Storable |
845 |
- Switch |
846 |
- Sys-Syslog |
847 |
- Term-ANSIColor |
848 |
- Test |
849 |
- Test-Harness |
850 |
- Test-Simple |
851 |
- Text-Balanced |
852 |
- Text-Tabs+Wrap |
853 |
- Thread-Queue |
854 |
- threads |
855 |
- Thread-Semaphore |
856 |
- threads-shared |
857 |
- Time-HiRes |
858 |
- Time-Local |
859 |
- Time-Piece |
860 |
- version |
861 |
- Version-Requirements |
862 |
- XSLoader |
863 |
- ) |
864 |
- ), |
865 |
- 'Digest' => virtual 'digest-base', |
866 |
- 'PathTools' => virtual 'File-Spec', |
867 |
- 'Locale-MakeText' => virtual 'locale-maketext', |
868 |
- 'Net-Ping' => virtual 'net-ping', |
869 |
- 'Pod-Parser' => virtual 'PodParser', |
870 |
- ## Overlay |
871 |
- ( |
872 |
- map { $_, virtual $_ } |
873 |
- qw( |
874 |
- Archive-Extract |
875 |
- B-Debug |
876 |
- B-Lint |
877 |
- constant |
878 |
- CPAN |
879 |
- CPANPLUS |
880 |
- CPANPLUS-Dist-Build |
881 |
- Devel-DProf |
882 |
- Devel-PPPort |
883 |
- Devel-SelfStubber |
884 |
- Dumpvalue |
885 |
- ExtUtils-Constant |
886 |
- ExtUtils-MakeMaker |
887 |
- File-Fetch |
888 |
- Filter-Simple |
889 |
- HTTP-Tiny |
890 |
- i18n-langtags |
891 |
- if |
892 |
- IPC-SysV |
893 |
- Log-Message |
894 |
- Log-Message-Simple |
895 |
- Math-Complex |
896 |
- Module-CoreList |
897 |
- NEXT |
898 |
- Object-Accessor |
899 |
- Pod-LaTeX |
900 |
- Pod-Perldoc |
901 |
- Pod-Plainer |
902 |
- SelfLoader |
903 |
- Term-UI |
904 |
- Unicode-Collate |
905 |
- Unicode-Normalize |
906 |
- ) |
907 |
- ), |
908 |
- ); |
909 |
+*STDOUT->binmode(':utf8'); |
910 |
+*STDERR->binmode(':utf8'); |
911 |
|
912 |
- if ( exists $vmap{$pkg} ) { |
913 |
- return $vmap{$pkg}; |
914 |
- } |
915 |
- return 'dev-perl/' . $pkg; |
916 |
-} |
917 |
+require deptools; |
918 |
+my $dep_phases = deptools::get_dep_phases($release); |
919 |
|
920 |
my @queue; |
921 |
|
922 |
-for my $module ( keys %modules ) { |
923 |
- for my $declaration ( @{ $modules{$module} } ) { |
924 |
+for my $module ( keys %{ $dep_phases->{modules} } ) { |
925 |
+ for my $declaration ( @{ $dep_phases->{modules}->{$module} } ) { |
926 |
push @queue, [ $module, $declaration ]; |
927 |
} |
928 |
} |
929 |
my @squeue = |
930 |
sort { $a->[1]->[2] cmp $b->[1]->[2] or $a->[1]->[3] cmp $b->[1]->[3] or $a->[0] cmp $b->[0] } @queue; |
931 |
|
932 |
+require dep::handler::stdout; |
933 |
+my $handler = dep::handler::stdout->new(); |
934 |
+ |
935 |
for my $qi (@squeue) { |
936 |
- handle_declaration( $release, @{$qi}, *STDOUT ); |
937 |
+ deptools::dispatch_dependency_handler( $release, @{$qi}, $handler ); |
938 |
} |
939 |
|
940 |
-use Data::Dump qw( pp ); |
941 |
-use JSON qw( to_json encode_json ); |
942 |
- |
943 |
#say pp( \%modules,);# { pretty => 1 } ); |
944 |
exit 1; |
945 |
|
946 |
-sub xwrap { |
947 |
- local $Text::Wrap::break = qr/,/; |
948 |
- local $Text::Wrap::overflow = 'huge'; |
949 |
- local $Text::Wrap::columns = 128; |
950 |
- $Text::Wrap::overflow = 'huge'; |
951 |
- my $pre = " "; |
952 |
- my $lines = wrap( $pre, $pre, @_ ); |
953 |
- return $lines; |
954 |
-} |
955 |
- |
956 |
-sub clines { |
957 |
- my ( $c, $prefix, $lines ) = @_; |
958 |
- $lines =~ s/^/$prefix>>$c/mg; |
959 |
- $lines =~ s/$/\e[0m/mg; |
960 |
- return $lines; |
961 |
-} |
962 |
- |
963 |
-sub get_dep_phases { |
964 |
- my ($release) = shift; |
965 |
- my %phases; |
966 |
- my %modules; |
967 |
- my ( $result, ) = get_deps($release); |
968 |
- for my $dep ( @{ $result->{dependency} } ) { |
969 |
- my $phase = $dep->{phase}; |
970 |
- my $module = $dep->{module}; |
971 |
- my $required = ( $dep->{relationship} eq 'requires' ); |
972 |
- |
973 |
- next unless $required; |
974 |
- next if $phase eq 'develop'; |
975 |
|
976 |
- $phases{$phase} //= []; |
977 |
- $modules{$module} //= []; |
978 |
- |
979 |
- my $v = gentooize_version( $dep->{version}, { lax => 1 } ); |
980 |
- |
981 |
- push @{ $phases{$phase} }, [ $dep->{module}, $dep->{version}, $v, $dep->{relationship} ]; |
982 |
- push @{ $modules{$module} }, [ $dep->{version}, $v, $dep->{phase}, $dep->{relationship} ]; |
983 |
- } |
984 |
- return { phases => \%phases, modules => \%modules }; |
985 |
-} |
986 |
- |
987 |
-sub to_curl { |
988 |
- my ( $target, $query ) = @_; |
989 |
- |
990 |
- my $query_json = to_json( $query, { pretty => 1 } ); |
991 |
- print 'curl -XPOST api.metacpan.org/v0/' . $target . '/_search -d \''; |
992 |
- print $query_json; |
993 |
- print qq{'\n}; |
994 |
- |
995 |
-} |
996 |
- |
997 |
-sub get_deps { |
998 |
- my ($release) = shift; |
999 |
- |
1000 |
- my ( $author, $distrelease ); |
1001 |
- |
1002 |
- $release =~ qr{^([^/]+)/(.*$)}; |
1003 |
- ( $author, $distrelease ) = ( "$1", "$2" ); |
1004 |
- return metacpan->find_release( $author, $distrelease ); |
1005 |
-} |
1006 |
|
1007 |
sub pkg_for_module { |
1008 |
my ($module) = shift; |
1009 |
@@ -432,17 +85,4 @@ sub gen_dep { |
1010 |
|
1011 |
} |
1012 |
|
1013 |
-sub help { |
1014 |
- return <<'EOF'; |
1015 |
-gen_ebuild.pl |
1016 |
- |
1017 |
-USAGE: |
1018 |
|
1019 |
- gen_ebuild.pl DOY/Moose-2.0301-TRIAL |
1020 |
- |
1021 |
- edit ./Moose-2.30.100_rc.ebuild |
1022 |
- |
1023 |
- done! |
1024 |
- |
1025 |
-EOF |
1026 |
-} |