* [gentoo-commits] proj/perl-overlay:master commit in: scripts/, scripts/lib/dep/handler/stdout/
@ 2012-02-26 2:33 Kent Fredric
0 siblings, 0 replies; 2+ messages in thread
From: Kent Fredric @ 2012-02-26 2:33 UTC (permalink / raw
To: gentoo-commits
commit: f425f8c63cced5fcac32e7c7d1367b2655a93201
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Sun Feb 26 01:49:24 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Sun Feb 26 02:26:00 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=f425f8c6
[scripts/gen_ebuild.pl] Improve non-debug mode tracing, remove warning errors, show deps early, skip resolving recommended deps as we dont codify them at present anyway
---
scripts/gen_ebuild.pl | 46 +++++++++++----
scripts/lib/dep/handler/stdout/simple.pm | 93 ++++++++++++++++++++++++++++++
2 files changed, 126 insertions(+), 13 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index ab0dc2d..2d9d1e5 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -17,7 +17,7 @@ my $flags;
my $singleflags;
@ARGV = grep { defined } map {
- $_ =~ /^--(\w+)/
+ $_ =~ /^--(.+)/
? do { $flags->{$1}++; undef }
: do {
$_ =~ /^-(\w+)/
@@ -26,6 +26,11 @@ my $singleflags;
}
} @ARGV;
+for my $k ( keys %{$flags} ) {
+ if ( $k =~ /^([^=]+)=(.*$)/ ) {
+ $flags->{$1} = $2;
+ }
+}
if ( $flags->{help} or $singleflags->{h} ) { print help(); exit 0; }
# FILENAME: show_deptree.pl
@@ -74,11 +79,22 @@ if ( not $release_info ) {
die "Cannot find $release on MetaCPAN";
}
my $dep_phases = deptools::get_dep_phases($release);
+pp( $dep_phases->{phases} );
+#warn "Found $#{$dep_phases} phases";
my @queue;
for my $module ( keys %{ $dep_phases->{modules} } ) {
for my $declaration ( @{ $dep_phases->{modules}->{$module} } ) {
+ if ( $declaration->[3] eq 'recommends' ) {
+ warn "skipped dep on recommended module $module";
+ next;
+ }
+ if ( $declaration->[3] eq 'suggests' ) {
+ warn "skipped dep on suggested module $module";
+ next;
+ }
+
push @queue, [ $module, $declaration ];
}
}
@@ -88,21 +104,25 @@ my @squeue =
require dep::handler::bashcode;
my $handler;
+my $hc = 'dep::handler::stdout::simple';
-if ( defined $flags->{debug} and ( $flags->{debug} ne "1" or $flags->{debug} ne "2" ) ) {
- $flags->{debug} = 1;
+if ( defined $flags->{debug} ) {
+ if ( $flags->{debug} eq "1" ) {
+ $hc = 'dep::handler::stdout::terse';
+ }
+ elsif ( $flags->{debug} eq "2" ) {
+ $hc = 'dep::handler::stdout';
+ }
+ else {
+ $hc = 'dep::handler::stdout::terse';
+ }
}
-if ( $flags->{debug} == 1 ) {
- require dep::handler::stdout::terse;
- $handler = dep::handler::stdout::terse->new();
-}
-if ( $flags->{debug} == 2 ) {
- require dep::handler::stdout;
- $handler = dep::handler::stdout->new();
-}
+require Class::Load;
+Class::Load::load_class($hc);
+$handler = $hc->new();
-my $handler2 = dep::handler::bashcode->new( ( $flags->{debug} ? ( debug => 1 ) : () ), debug_handler => $handler, );
+my $handler2 = dep::handler::bashcode->new( debug => 1, debug_handler => $handler, );
for my $qi (@squeue) {
deptools::dispatch_dependency_handler( $release, @{$qi}, $handler2 );
@@ -136,7 +156,7 @@ if ( not defined $release_info->{abstract} ) {
}
else {
my $abstract = $release_info->{abstract};
- $abstract =~ s/'/'\\''/g; # ' => '\''
+ $abstract =~ s/'/'\\''/g; # ' => '\''
$fh->say( 'DESCRIPTION=\'' . $abstract . '\'' );
}
diff --git a/scripts/lib/dep/handler/stdout/simple.pm b/scripts/lib/dep/handler/stdout/simple.pm
new file mode 100644
index 0000000..ab55b86
--- /dev/null
+++ b/scripts/lib/dep/handler/stdout/simple.pm
@@ -0,0 +1,93 @@
+use strict;
+use warnings;
+
+package dep::handler::stdout::simple;
+
+# FILENAME: simple.pm
+# CREATED: 31/10/11 13:30:29 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: Dispatch terse dependency information to STDOUT.
+
+use Moose;
+#extends 'dep::handler::stdout::terse';
+has 'indent' => ( is => 'rw' );
+has 'tail' => ( is => 'rw' );
+__PACKAGE__->meta->make_immutable;
+
+sub begin_dep {
+ my ( $self, $release, $module, $declaration ) = @_;
+ return *STDOUT->print("\n\n" . $self->_want_string( $release, $module, $declaration ) . "\n");
+}
+
+sub evt_not_any {
+ my ( $self, $module, $declaration ) = @_;
+ return *STDOUT->print(" No provider found for $module : @$declaration\n");
+}
+
+sub evt_multi {
+ my ( $self, $module, $declaration ) = @_;
+ return *STDOUT->print(" Multiple Providers found for " . $self->_want_string( "", $module, $declaration) . "\n");
+}
+
+sub set_latest {
+ my ( $self, $dep, $pkg ) = @_;
+ return *STDOUT->print(" Latest: @{$dep} => ${pkg}\n");
+}
+
+sub _want_string {
+ my ( $self, $release, $module, $declaration ) = @_;
+ return $release . " -> " . $declaration->[2] . " " . $declaration->[3] . " -> " . $self->_depstring( $module, $declaration );
+}
+
+sub _depstring {
+ my ( $self, $module, $declaration ) = @_;
+
+ my $depstring = $module;
+
+ if ( $declaration->[1] ne '0.0.0' ) {
+ $depstring .= " " . $declaration->[0] . " ( " . $declaration->[1] . " ) ";
+ }
+ return $depstring;
+}
+
+sub _xwrap {
+ my $self = shift;
+ require Text::Wrap;
+ local $Text::Wrap::break = qr/,/;
+ local $Text::Wrap::overflow = 'huge';
+ local $Text::Wrap::columns = 128;
+ $Text::Wrap::overflow = 'huge';
+ my $pre = " ";
+ my $lines = Text::Wrap::wrap( $pre, $pre, @_ );
+ return $lines;
+}
+sub perl_dep {
+ my ( $self, $module, $declaration , $pkg ) = @_ ;
+ *STDOUT->print(" -> $module : @{$declaration} via $pkg\n");
+}
+sub provider_group {
+ my ( $self, $data ) = @_;
+
+ my $want_string = $self->_want_string( $data->{release}, $data->{module}, $data->{declaration} );
+ my $depstring = $self->_depstring( $data->{module}, $data->{declaration} );
+
+ *STDOUT->printf( " %s -> %s (%s)\n", $depstring, $data->{provider}, $data->{gentoo_pkg} );
+ #*STDOUT->printf( "%s newest: %s\e[0m\n", $self->indent, $data->{newest} );
+ #*STDOUT->printf( "%s oldest: %s\e[0m\n", $self->indent, $data->{oldest} );
+
+ my $v = $data->{closest};
+ if ( not $data->{has_closest} ) { $v = 'undef' }
+
+ *STDOUT->print( " closest: $v\n" );
+
+
+}
+
+sub done {
+ my ( $self, $module, $declaration ) = @_;
+ return *STDOUT->print( $self->tail );
+}
+
+no Moose;
+__PACKAGE__->meta->make_immutable;
+1;
+
^ permalink raw reply related [flat|nested] 2+ messages in thread* [gentoo-commits] proj/perl-overlay:master commit in: scripts/, scripts/lib/dep/handler/stdout/
@ 2012-02-24 7:13 Kent Fredric
0 siblings, 0 replies; 2+ messages in thread
From: Kent Fredric @ 2012-02-24 7:13 UTC (permalink / raw
To: gentoo-commits
commit: 2c4ec68dc60147117f86aac0565e5df9d020d798
Author: Kent Fredric <kentfredric <AT> gmail <DOT> com>
AuthorDate: Thu Feb 23 19:50:55 2012 +0000
Commit: Kent Fredric <kentfredric <AT> gmail <DOT> com>
CommitDate: Thu Feb 23 19:50:55 2012 +0000
URL: http://git.overlays.gentoo.org/gitweb/?p=proj/perl-overlay.git;a=commit;h=2c4ec68d
[scripts/gen_ebuild.pl] Improve --help data, add a terse debug tracer to get better feedback while it runs
---
scripts/gen_ebuild.pl | 108 +++++++++++++++++++-----------
scripts/lib/dep/handler/stdout/terse.pm | 108 +++++++++++++++++++++++++++++++
2 files changed, 176 insertions(+), 40 deletions(-)
diff --git a/scripts/gen_ebuild.pl b/scripts/gen_ebuild.pl
index e8635b6..fe14365 100755
--- a/scripts/gen_ebuild.pl
+++ b/scripts/gen_ebuild.pl
@@ -42,8 +42,23 @@ gen_ebuild.pl
USAGE:
- show_deptree.pl DOY/Moose-2.0301-TRIAL
+ gen_ebuild.pl DOY/Moose-2.0301-TRIAL
+ exports:
+ WWW_MECH_DEBUG=1 for basic internal http tracing
+ WWW_MECH_DEBUG=2 for full response content output
+ WWW_MECH_NOCACHE=1 to disable caching
+
+ parameters:
+
+ --debug=1
+ Verbose tracing.
+
+ --debug=2
+ Even More verbose tracing.
+
+ --dumphandler
+ Print the full resolution map
EOF
}
my ($release) = shift(@ARGV);
@@ -70,10 +85,23 @@ for my $module ( keys %{ $dep_phases->{modules} } ) {
my @squeue =
sort { $a->[1]->[2] cmp $b->[1]->[2] or $a->[1]->[3] cmp $b->[1]->[3] or $a->[0] cmp $b->[0] } @queue;
-require dep::handler::stdout;
require dep::handler::bashcode;
-my $handler = dep::handler::stdout->new();
+my $handler;
+
+if ( defined $flags->{debug} and $flags->{debug} ne "1" or $flags->{debug} ne "2" ) {
+ $flags->{debug} = 1;
+}
+
+if ( $flags->{debug} == 1 ) {
+ require dep::handler::stdout::terse;
+ $handler = dep::handler::stdout::terse->new();
+}
+if ( $flags->{debug} == 2 ) {
+ require dep::handler::stdout;
+ $handler = dep::handler::stdout->new();
+}
+
my $handler2 = dep::handler::bashcode->new( ( $flags->{debug} ? ( debug => 1 ) : () ), debug_handler => $handler, );
for my $qi (@squeue) {
@@ -145,66 +173,73 @@ if ( $handler2->has_tdeps ) {
else {
$fh->say('IUSE=""');
}
-
-pp($handler2);
+if ( $flags->{dumphandler} ) {
+ pp($handler2);
+}
if ( $handler2->has_cdeps ) {
- $fh->say('perl_meta_configure() {');
+ my @lines;
for my $dep ( @{ $handler2->cdeps } ) {
- $fh->say( "\t# " . $dep->{dep} );
+ push @lines, '# ' . $dep->{dep};
if ( not defined $dep->{install} ) {
- $fh->say( "\t#echo unresolved");
+ push @lines, '#echo unresolved';
warn "cdep " . $dep->{dep} . " was not resolved to a dependency";
- } else {
- $fh->say( "\techo " . $dep->{install} );
+ }
+ else {
+ push @lines, 'echo ' . $dep->{install};
}
}
- $fh->say('}');
push @{$depends}, '$(perl_meta_configure)';
+ $fh->say( gen_func( 'perl_meta_configure', @lines ) );
+
}
if ( $handler2->has_bdeps ) {
- $fh->say('perl_meta_build() {');
- for my $dep ( @{ $handler2->bdeps } ) {
- $fh->say( "\t# " . $dep->{dep} );
+ my @lines;
+ for my $dep ( @{ $handler2->bdeps } ) {
+ push @lines, '# ' . $dep->{dep};
if ( not defined $dep->{install} ) {
- $fh->say( "\t#echo unresolved");
+ push @lines, '#echo unresolved';
warn "bdep " . $dep->{dep} . " was not resolved to a dependency";
- } else {
- $fh->say( "\techo " . $dep->{install} );
+ }
+ else {
+ push @lines, 'echo ' . $dep->{install};
}
}
- $fh->say('}');
+ $fh->say( gen_func( 'perl_meta_build', @lines ) );
push @{$depends}, '$(perl_meta_build)';
}
if ( $handler2->has_rdeps ) {
- $fh->say('perl_meta_runtime() {');
+ my @lines;
for my $dep ( @{ $handler2->rdeps } ) {
- $fh->say( "\t# " . $dep->{dep} );
+ push @lines, '# ' . $dep->{dep};
if ( not defined $dep->{install} ) {
- $fh->say( "\t#echo unresolved");
+ push @lines, '#echo unresolved';
warn "rdep: " . $dep->{dep} . " was not resolved to a dependency";
- } else {
- $fh->say( "\techo " . $dep->{install} );
+ }
+ else {
+ push @lines, 'echo ' . $dep->{install};
}
}
- $fh->say('}');
+ $fh->say( gen_func( 'perl_meta_runtime', @lines ) );
push @{$depends}, '$(perl_meta_runtime)';
push @{$rdepends}, '$(perl_meta_runtime)';
}
if ( $handler2->has_tdeps ) {
- $fh->say('perl_meta_test() {');
+ my @lines;
for my $dep ( @{ $handler2->tdeps } ) {
- $fh->say( "\t# " . $dep->{dep} );
+ push @lines, '# ' . $dep->{dep};
+
if ( not defined $dep->{install} ) {
- $fh->say( "\t#echo unresolved");
+ push @lines, '#echo unresolved';
warn "tdep: " . $dep->{dep} . " was not resolved to a dependency";
- } else {
- $fh->say( "\techo " . $dep->{install} );
+ }
+ else {
+ push @lines, 'echo ' . $dep->{install};
}
}
- $fh->say('}');
+ $fh->say( gen_func( 'perl_meta_test', @lines ) );
push @{$depends}, 'test? ( $(perl_meta_test) )';
}
@@ -215,14 +250,7 @@ $fh->say("SRC_TEST=\"do\"");
#say pp( \%modules,);# { pretty => 1 } );
exit 1;
-sub pkg_for_module {
- my ($module) = shift;
-
+sub gen_func {
+ my ( $name, @body ) = @_;
+ return join( q{\n}, $name . '() {', ( map { "\t" . $_ } @body ), '}' );
}
-
-sub gen_dep {
- state $template = qq{\t# %s%s\n\techo %s\n};
- my ( $module, $version ) = @_;
-
-}
-
diff --git a/scripts/lib/dep/handler/stdout/terse.pm b/scripts/lib/dep/handler/stdout/terse.pm
new file mode 100644
index 0000000..729de66
--- /dev/null
+++ b/scripts/lib/dep/handler/stdout/terse.pm
@@ -0,0 +1,108 @@
+use strict;
+use warnings;
+
+package dep::handler::stdout::terse;
+
+# FILENAME: terse.pm
+# CREATED: 31/10/11 13:30:29 by Kent Fredric (kentnl) <kentfredric@gmail.com>
+# ABSTRACT: Dispatch terse dependency information to STDOUT.
+
+use Moose;
+#extends 'dep::handler::stdout::terse';
+has 'indent' => ( is => 'rw' );
+has 'tail' => ( is => 'rw' );
+__PACKAGE__->meta->make_immutable;
+
+sub begin_dep {
+ my ( $self, $release, $module, $declaration ) = @_;
+ $self->indent(" \e[1;92m*");
+ $self->tail(" \e[1;92m-\n\n");
+ my $wantstring = $self->_want_string( $release, $module, $declaration );
+ return *STDOUT->printf( "\e[1;93m%s\e[0m\n", $wantstring );
+}
+
+sub evt_not_any {
+ my ( $self, $module, $declaration ) = @_;
+ return *STDOUT->printf( "%sWARNING: NO PROVIDER FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" );
+}
+
+sub evt_multi {
+ my ( $self, $module, $declaration ) = @_;
+ $self->indent(" \e[1;91m*");
+ $self->tail(" \e[1;91m-\n\n");
+
+ return *STDOUT->printf( "%sWARNING: MULTIPLE PROVIDERS FOUND FOR \"%s\"%s\n", "\e[1;91m", $module, "\e[0m" );
+}
+
+sub set_latest {
+ my ( $self, $dep, $pkg ) = @_;
+ return *STDOUT->printf( "%s\e[1;95m latest: %s => %s ( %s )\n", $self->indent, @{$dep}, $pkg );
+}
+
+sub _want_string {
+ my ( $self, $release, $module, $declaration ) = @_;
+ return $release . " -> " . $declaration->[2] . " " . $declaration->[3] . " " . $self->_depstring( $module, $declaration );
+}
+
+sub _depstring {
+ my ( $self, $module, $declaration ) = @_;
+
+ my $depstring = $module;
+
+ if ( $declaration->[1] ne '0.0.0' ) {
+ $depstring .= " " . $declaration->[0] . " ( " . $declaration->[1] . " ) ";
+ }
+ return $depstring;
+}
+
+sub _xwrap {
+ my $self = shift;
+ require Text::Wrap;
+ local $Text::Wrap::break = qr/,/;
+ local $Text::Wrap::overflow = 'huge';
+ local $Text::Wrap::columns = 128;
+ $Text::Wrap::overflow = 'huge';
+ my $pre = " ";
+ my $lines = Text::Wrap::wrap( $pre, $pre, @_ );
+ return $lines;
+}
+sub perl_dep {
+ my ( $self, $module, $declaration , $pkg ) = @_ ;
+ *STDOUT->printf("%s %s%s -> %s%s\n", $self->indent, "\e[1;94m", $module, "\e[0m\e[94m", $pkg );
+}
+sub provider_group {
+ my ( $self, $data ) = @_;
+
+ my $want_string = $self->_want_string( $data->{release}, $data->{module}, $data->{declaration} );
+ my $depstring = $self->_depstring( $data->{module}, $data->{declaration} );
+
+ my $prefix = $depstring . ' in ' . $data->{provider};
+
+ my $lines = $self->_xwrap( join q[, ], @{ $data->{versions} } );
+ my (@slines) = split /$/m, $lines;
+ $_ =~ s/[\r\n]*//m for @slines;
+
+ *STDOUT->printf( " %s%s -> %s%s (%s)\n", "\e[1;92m", $depstring, "\e[0m\e[92m", $data->{provider}, $data->{gentoo_pkg} );
+ #*STDOUT->printf( "%s newest: %s\e[0m\n", $self->indent, $data->{newest} );
+ #*STDOUT->printf( "%s oldest: %s\e[0m\n", $self->indent, $data->{oldest} );
+
+ my $v = $data->{closest};
+ if ( not $data->{has_closest} ) { $v = 'undef' }
+
+ #*STDOUT->printf( "%s closest: %s\e[0m\n", $self->indent, $v );
+
+ for (@slines) {
+ #*STDOUT->printf( "%s %s%s -> %s%s\n", $self->indent, "\e[1;94m", $data->{provider}, "\e[0m\e[94m", $_ );
+ }
+
+}
+
+sub done {
+ my ( $self, $module, $declaration ) = @_;
+ return *STDOUT->print( $self->tail );
+}
+
+no Moose;
+__PACKAGE__->meta->make_immutable;
+1;
+
^ permalink raw reply related [flat|nested] 2+ messages in thread
end of thread, other threads:[~2012-02-26 2:33 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2012-02-26 2:33 [gentoo-commits] proj/perl-overlay:master commit in: scripts/, scripts/lib/dep/handler/stdout/ Kent Fredric
-- strict thread matches above, loose matches on Subject: below --
2012-02-24 7:13 Kent Fredric
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox