[Bps-public-commit] SD branch, config-gitlike, updated. d3ff5b53308276a700b6c74b910611c034df9c5e
jesse
jesse at bestpractical.com
Tue Jul 7 16:01:46 EDT 2009
The branch, config-gitlike has been updated
via d3ff5b53308276a700b6c74b910611c034df9c5e (commit)
from 82861066066ac51d8c947a5c128b5fbe1982ec9e (commit)
Summary of changes:
inc/Module/AutoInstall.pm | 88 +++++++++++++------
inc/Module/Install.pm | 6 +-
inc/Module/Install/AutoInstall.pm | 8 +-
inc/Module/Install/Base.pm | 40 ++++-----
inc/Module/Install/Can.pm | 14 ++--
inc/Module/Install/Fetch.pm | 8 +-
inc/Module/Install/Include.pm | 8 +-
inc/Module/Install/Makefile.pm | 10 +-
inc/Module/Install/Metadata.pm | 104 ++++++++++++++++-------
inc/Module/Install/Scripts.pm | 8 +-
inc/Module/Install/Share.pm | 8 +-
inc/Module/Install/Win32.pm | 6 +-
inc/Module/Install/WriteAll.pm | 18 +++-
lib/App/SD/Config.pm | 171 ++++++++++++++++++++++++++++++++++---
14 files changed, 363 insertions(+), 134 deletions(-)
- Log -----------------------------------------------------------------
commit d3ff5b53308276a700b6c74b910611c034df9c5e
Author: Jesse Vincent <jesse at bestpractical.com>
Date: Tue Jul 7 16:01:30 2009 -0400
Moved the old config upgrade code from prophet to sd
diff --git a/inc/Module/AutoInstall.pm b/inc/Module/AutoInstall.pm
index 739bc85..dfb8ef7 100644
--- a/inc/Module/AutoInstall.pm
+++ b/inc/Module/AutoInstall.pm
@@ -18,7 +18,9 @@ my %FeatureMap = (
# various lexical flags
my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
-my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly );
+my (
+ $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps
+);
my ( $PostambleActions, $PostambleUsed );
# See if it's a testing or non-interactive session
@@ -73,6 +75,9 @@ sub _init {
elsif ( $arg =~ /^--test(?:only)?$/ ) {
$TestOnly = 1;
}
+ elsif ( $arg =~ /^--all(?:deps)?$/ ) {
+ $AllDeps = 1;
+ }
}
}
@@ -115,7 +120,12 @@ sub import {
)[0]
);
- $UnderCPAN = _check_lock(1); # check for $UnderCPAN
+ # We want to know if we're under CPAN early to avoid prompting, but
+ # if we aren't going to try and install anything anyway then skip the
+ # check entirely since we don't want to have to load (and configure)
+ # an old CPAN just for a cosmetic message
+
+ $UnderCPAN = _check_lock(1) unless $SkipInstall;
while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
my ( @required, @tests, @skiptests );
@@ -165,15 +175,24 @@ sub import {
}
# XXX: check for conflicts and uninstalls(!) them.
- if (
- defined( my $cur = _version_check( _load($mod), $arg ||= 0 ) ) )
+ my $cur = _load($mod);
+ if (_version_cmp ($cur, $arg) >= 0)
{
print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
push @Existing, $mod => $arg;
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
else {
- print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
+ if (not defined $cur) # indeed missing
+ {
+ print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
+ }
+ else
+ {
+ # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above
+ print "too old. ($cur < $arg)\n";
+ }
+
push @required, $mod => $arg;
}
}
@@ -187,6 +206,7 @@ sub import {
and (
$CheckOnly
or ($mandatory and $UnderCPAN)
+ or $AllDeps
or _prompt(
qq{==> Auto-install the }
. ( @required / 2 )
@@ -235,21 +255,38 @@ sub import {
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
}
+sub _running_under {
+ my $thing = shift;
+ print <<"END_MESSAGE";
+*** Since we're running under ${thing}, I'll just let it take care
+ of the dependency's installation later.
+END_MESSAGE
+ return 1;
+}
+
# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
# if we are, then we simply let it taking care of our dependencies
sub _check_lock {
return unless @Missing or @_;
+ my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING};
+
if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
- print <<'END_MESSAGE';
+ return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS');
+ }
-*** Since we're running under CPANPLUS, I'll just let it take care
- of the dependency's installation later.
-END_MESSAGE
- return 1;
+ require CPAN;
+
+ if ($CPAN::VERSION > '1.89') {
+ if ($cpan_env) {
+ return _running_under('CPAN');
+ }
+ return; # CPAN.pm new enough, don't need to check further
}
- _load_cpan();
+ # last ditch attempt, this -will- configure CPAN, very sorry
+
+ _load_cpan(1); # force initialize even though it's already loaded
# Find the CPAN lock-file
my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" );
@@ -285,7 +322,7 @@ sub install {
while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
# grep out those already installed
- if ( defined( _version_check( _load($pkg), $ver ) ) ) {
+ if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
else {
@@ -324,7 +361,7 @@ sub install {
# see if we have successfully installed them
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
- if ( defined( _version_check( _load($pkg), $ver ) ) ) {
+ if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
@@ -379,7 +416,7 @@ sub _install_cpanplus {
my $success;
my $obj = $modtree->{$pkg};
- if ( $obj and defined( _version_check( $obj->{version}, $ver ) ) ) {
+ if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) {
my $pathname = $pkg;
$pathname =~ s/::/\\W/;
@@ -472,7 +509,7 @@ sub _install_cpan {
my $obj = CPAN::Shell->expand( Module => $pkg );
my $success = 0;
- if ( $obj and defined( _version_check( $obj->cpan_version, $ver ) ) ) {
+ if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) {
my $pathname = $pkg;
$pathname =~ s/::/\\W/;
@@ -536,7 +573,7 @@ sub _update_to {
my $ver = shift;
return
- if defined( _version_check( _load($class), $ver ) ); # no need to upgrade
+ if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade
if (
_prompt( "==> A newer version of $class ($ver) is required. Install?",
@@ -633,7 +670,7 @@ sub _load {
# Load CPAN.pm and it's configuration
sub _load_cpan {
- return if $CPAN::VERSION;
+ return if $CPAN::VERSION and $CPAN::Config and not @_;
require CPAN;
if ( $CPAN::HandleConfig::VERSION ) {
# Newer versions of CPAN have a HandleConfig module
@@ -645,9 +682,11 @@ sub _load_cpan {
}
# compare two versions, either use Sort::Versions or plain comparison
-sub _version_check {
+# return values same as <=>
+sub _version_cmp {
my ( $cur, $min ) = @_;
- return unless defined $cur;
+ return -1 unless defined $cur; # if 0 keep comparing
+ return 1 unless $min;
$cur =~ s/\s+$//;
@@ -658,16 +697,13 @@ sub _version_check {
) {
# use version.pm if it is installed.
- return (
- ( version->new($cur) >= version->new($min) ) ? $cur : undef );
+ return version->new($cur) <=> version->new($min);
}
elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) )
{
# use Sort::Versions as the sorting algorithm for a.b.c versions
- return ( ( Sort::Versions::versioncmp( $cur, $min ) != -1 )
- ? $cur
- : undef );
+ return Sort::Versions::versioncmp( $cur, $min );
}
warn "Cannot reliably compare non-decimal formatted versions.\n"
@@ -676,7 +712,7 @@ sub _version_check {
# plain comparison
local $^W = 0; # shuts off 'not numeric' bugs
- return ( $cur >= $min ? $cur : undef );
+ return $cur <=> $min;
}
# nothing; this usage is deprecated.
@@ -766,4 +802,4 @@ END_MAKE
__END__
-#line 1004
+#line 1056
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index 5b9ddbf..51eda5d 100644
--- a/inc/Module/Install.pm
+++ b/inc/Module/Install.pm
@@ -28,7 +28,7 @@ BEGIN {
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '0.85';
+ $VERSION = '0.91';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -353,7 +353,7 @@ sub _read {
if ( $] >= 5.006 ) {
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
} else {
- open( FH, "< $_[0]" ) or die "open($_[0]): $!";
+ open( FH, "< $_[0]" ) or die "open($_[0]): $!";
}
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
@@ -384,7 +384,7 @@ sub _write {
if ( $] >= 5.006 ) {
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
} else {
- open( FH, "> $_[0]" ) or die "open($_[0]): $!";
+ open( FH, "> $_[0]" ) or die "open($_[0]): $!";
}
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
index b7e92a5..58dd026 100644
--- a/inc/Module/Install/AutoInstall.pm
+++ b/inc/Module/Install/AutoInstall.pm
@@ -2,13 +2,13 @@
package Module::Install::AutoInstall;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '0.91';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub AutoInstall { $_[0] }
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index ac416c9..60a74d2 100644
--- a/inc/Module/Install/Base.pm
+++ b/inc/Module/Install/Base.pm
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '0.91';
}
# Suspend handler for "redefined" warnings
@@ -13,42 +13,34 @@ BEGIN {
$SIG{__WARN__} = sub { $w };
}
-### This is the ONLY module that shouldn't have strict on
-# use strict;
-
-#line 45
+#line 42
sub new {
- my ($class, %args) = @_;
-
- foreach my $method ( qw(call load) ) {
- next if defined &{"$class\::$method"};
- *{"$class\::$method"} = sub {
- shift()->_top->$method(@_);
- };
+ my $class = shift;
+ unless ( defined &{"${class}::call"} ) {
+ *{"${class}::call"} = sub { shift->_top->call(@_) };
}
-
- bless( \%args, $class );
+ unless ( defined &{"${class}::load"} ) {
+ *{"${class}::load"} = sub { shift->_top->load(@_) };
+ }
+ bless { @_ }, $class;
}
-#line 66
+#line 61
sub AUTOLOAD {
- my $self = shift;
local $@;
- my $autoload = eval {
- $self->_top->autoload
- } or return;
- goto &$autoload;
+ my $func = eval { shift->_top->autoload } or return;
+ goto &$func;
}
-#line 83
+#line 75
sub _top {
$_[0]->{_top};
}
-#line 98
+#line 90
sub admin {
$_[0]->_top->{admin}
@@ -56,7 +48,7 @@ sub admin {
Module::Install::Base::FakeAdmin->new;
}
-#line 114
+#line 106
sub is_admin {
$_[0]->admin->VERSION;
@@ -83,4 +75,4 @@ BEGIN {
1;
-#line 162
+#line 154
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index 3e2d523..e65e4f6 100644
--- a/inc/Module/Install/Can.pm
+++ b/inc/Module/Install/Can.pm
@@ -2,16 +2,16 @@
package Module::Install::Can;
use strict;
-use Module::Install::Base;
-use Config ();
-use File::Spec ();
-use ExtUtils::MakeMaker ();
+use Config ();
+use File::Spec ();
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '0.91';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
# check if we can load some module
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index 0a62208..05f2079 100644
--- a/inc/Module/Install/Fetch.pm
+++ b/inc/Module/Install/Fetch.pm
@@ -2,13 +2,13 @@
package Module::Install::Fetch;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '0.91';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub get_file {
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
index 92aad58..7e792e0 100644
--- a/inc/Module/Install/Include.pm
+++ b/inc/Module/Install/Include.pm
@@ -2,13 +2,13 @@
package Module::Install::Include;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '0.91';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub include {
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index 2b80f0f..98779db 100644
--- a/inc/Module/Install/Makefile.pm
+++ b/inc/Module/Install/Makefile.pm
@@ -2,14 +2,14 @@
package Module::Install::Makefile;
use strict 'vars';
-use Module::Install::Base;
-use ExtUtils::MakeMaker ();
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '0.91';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub Makefile { $_[0] }
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index ca16db7..653193d 100644
--- a/inc/Module/Install/Metadata.pm
+++ b/inc/Module/Install/Metadata.pm
@@ -2,18 +2,17 @@
package Module::Install::Metadata;
use strict 'vars';
-use Module::Install::Base;
+use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
- @ISA = qw{Module::Install::Base};
+ $VERSION = '0.91';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
}
my @boolean_keys = qw{
sign
- mymeta
};
my @scalar_keys = qw{
@@ -440,21 +439,21 @@ sub license_from {
/ixms ) {
my $license_text = $1;
my @phrases = (
- 'under the same (?:terms|license) as perl itself' => 'perl', 1,
- 'GNU general public license' => 'gpl', 1,
- 'GNU public license' => 'gpl', 1,
- 'GNU lesser general public license' => 'lgpl', 1,
- 'GNU lesser public license' => 'lgpl', 1,
- 'GNU library general public license' => 'lgpl', 1,
- 'GNU library public license' => 'lgpl', 1,
- 'BSD license' => 'bsd', 1,
- 'Artistic license' => 'artistic', 1,
- 'GPL' => 'gpl', 1,
- 'LGPL' => 'lgpl', 1,
- 'BSD' => 'bsd', 1,
- 'Artistic' => 'artistic', 1,
- 'MIT' => 'mit', 1,
- 'proprietary' => 'proprietary', 0,
+ 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1,
+ 'GNU general public license' => 'gpl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser general public license' => 'lgpl', 1,
+ 'GNU lesser public license' => 'lgpl', 1,
+ 'GNU library general public license' => 'lgpl', 1,
+ 'GNU library public license' => 'lgpl', 1,
+ 'BSD license' => 'bsd', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 1,
+ 'proprietary' => 'proprietary', 0,
);
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s{\s+}{\\s+}g;
@@ -506,17 +505,29 @@ sub requires_from {
}
}
+sub test_requires_from {
+ my $self = shift;
+ my $content = Module::Install::_readperl($_[0]);
+ my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
+ while ( @requires ) {
+ my $module = shift @requires;
+ my $version = shift @requires;
+ $self->test_requires( $module => $version );
+ }
+}
+
# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
my $v = $_[-1];
- $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
+ $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
$v =~ s/(\.\d\d\d)000$/$1/;
$v =~ s/_.+$//;
if ( ref($v) ) {
- $v = $v + 0; # Numify
+ # Numify
+ $v = $v + 0;
}
return $v;
}
@@ -526,23 +537,58 @@ sub _perl_version {
######################################################################
-# MYMETA.yml Support
+# MYMETA Support
sub WriteMyMeta {
die "WriteMyMeta has been deprecated";
}
-sub write_mymeta {
+sub write_mymeta_yaml {
my $self = shift;
-
- # If there's no existing META.yml there is nothing we can do
- return unless -f 'META.yml';
# We need YAML::Tiny to write the MYMETA.yml file
unless ( eval { require YAML::Tiny; 1; } ) {
return 1;
}
+ # Generate the data
+ my $meta = $self->_write_mymeta_data or return 1;
+
+ # Save as the MYMETA.yml file
+ print "Writing MYMETA.yml\n";
+ YAML::Tiny::DumpFile('MYMETA.yml', $meta);
+}
+
+sub write_mymeta_json {
+ my $self = shift;
+
+ # We need JSON to write the MYMETA.json file
+ unless ( eval { require JSON; 1; } ) {
+ return 1;
+ }
+
+ # Generate the data
+ my $meta = $self->_write_mymeta_data or return 1;
+
+ # Save as the MYMETA.yml file
+ print "Writing MYMETA.json\n";
+ Module::Install::_write(
+ 'MYMETA.json',
+ JSON->new->pretty(1)->canonical->encode($meta),
+ );
+}
+
+sub _write_mymeta_data {
+ my $self = shift;
+
+ # If there's no existing META.yml there is nothing we can do
+ return undef unless -f 'META.yml';
+
+ # We need Parse::CPAN::Meta to load the file
+ unless ( eval { require Parse::CPAN::Meta; 1; } ) {
+ return undef;
+ }
+
# Merge the perl version into the dependencies
my $val = $self->Meta->{values};
my $perl = delete $val->{perl_version};
@@ -558,7 +604,7 @@ sub write_mymeta {
}
# Load the advisory META.yml file
- my @yaml = YAML::Tiny::LoadFile('META.yml');
+ my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
my $meta = $yaml[0];
# Overwrite the non-configure dependency hashs
@@ -572,9 +618,7 @@ sub write_mymeta {
$meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
}
- # Save as the MYMETA.yml file
- print "Writing MYMETA.yml\n";
- YAML::Tiny::DumpFile('MYMETA.yml', $meta);
+ return $meta;
}
1;
diff --git a/inc/Module/Install/Scripts.pm b/inc/Module/Install/Scripts.pm
index 8aee44b..a1001f5 100644
--- a/inc/Module/Install/Scripts.pm
+++ b/inc/Module/Install/Scripts.pm
@@ -2,13 +2,13 @@
package Module::Install::Scripts;
use strict 'vars';
-use Module::Install::Base;
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '0.91';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub install_script {
diff --git a/inc/Module/Install/Share.pm b/inc/Module/Install/Share.pm
index 447a0c8..f7e877c 100644
--- a/inc/Module/Install/Share.pm
+++ b/inc/Module/Install/Share.pm
@@ -2,13 +2,13 @@
package Module::Install::Share;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '0.91';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub install_share {
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index c00da94..f2f99df 100644
--- a/inc/Module/Install/Win32.pm
+++ b/inc/Module/Install/Win32.pm
@@ -2,12 +2,12 @@
package Module::Install::Win32;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
- @ISA = qw{Module::Install::Base};
+ $VERSION = '0.91';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index df3900a..12471e5 100644
--- a/inc/Module/Install/WriteAll.pm
+++ b/inc/Module/Install/WriteAll.pm
@@ -2,11 +2,11 @@
package Module::Install::WriteAll;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '0.91';;
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -41,8 +41,18 @@ sub WriteAll {
# The Makefile write process adds a couple of dependencies,
# so write the META.yml files after the Makefile.
- $self->Meta->write if $args{meta};
- $self->Meta->write_mymeta if $self->mymeta;
+ if ( $args{meta} ) {
+ $self->Meta->write;
+ }
+
+ # Experimental support for MYMETA
+ if ( $ENV{X_MYMETA} ) {
+ if ( $ENV{X_MYMETA} eq 'JSON' ) {
+ $self->Meta->write_mymeta_json;
+ } else {
+ $self->Meta->write_mymeta_yaml;
+ }
+ }
return 1;
}
diff --git a/lib/App/SD/Config.pm b/lib/App/SD/Config.pm
index a05b37b..6d3832d 100644
--- a/lib/App/SD/Config.pm
+++ b/lib/App/SD/Config.pm
@@ -4,10 +4,11 @@ use File::Spec;
extends 'Prophet::Config';
-### XXX This class is for BACKCOMPAT ONLY! Eventually, we want to kill it
+{
+### XXX This code is for BACKCOMPAT ONLY! Eventually, we want to kill it
### completely.
-override _old_app_config_file => sub {
+sub _old_app_config_file {
my $self = shift;
# The order of preference for (OLD!) config files is:
@@ -16,20 +17,166 @@ override _old_app_config_file => sub {
# if we set PROPHET_APP_CONFIG here, it will mess up legit uses of the
# new config file setup
- $ENV{'OLD_PROPHET_APP_CONFIG'}
+ my $old_file
= $self->_file_if_exists($ENV{'SD_CONFIG'})
- || $self->_file_if_exists(
- File::Spec->catfile($self->app_handle->handle->fs_root => 'config'))
- || $self->_file_if_exists(
- # backcompat
- File::Spec->catfile($self->app_handle->handle->fs_root => 'prophetrc'))
- || $self->_file_if_exists(
- File::Spec->catfile($ENV{'HOME'}.'/.sdrc'))
+ || $self->_file_if_exists( File::Spec->catfile($self->app_handle->handle->fs_root => 'config'))
+ || $self->_file_if_exists( File::Spec->catfile($self->app_handle->handle->fs_root => 'prophetrc'))
+ || $self->_file_if_exists( File::Spec->catfile($ENV{'HOME'}.'/.sdrc'))
|| $ENV{'PROPHET_APP_CONFIG'} # don't overwrite with nothing
|| ''; # don't write undef
- $self->SUPER::_old_app_config_file(@_,
- config_env_var => 'OLD_PROPHET_APP_CONFIG');
+
+ return $self->_file_if_exists($old_file)
+ || $self->_file_if_exists( File::Spec->catfile( $ENV{'HOME'} => '.prophetrc' ))
+ || $self->_file_if_exists( File::Spec->catfile( $self->app_handle->handle->fs_root => 'config' )) ||
+ $self->_file_if_exists( File::Spec->catfile( $self->app_handle->handle->fs_root => 'prophetrc' )) ||
+ File::Spec->catfile( $self->app_handle->handle->fs_root => 'config' );
+}
+
+
+
+override load => sub {
+ my $self = shift;
+
+ Prophet::CLI->end_pager();
+
+ # Do backcompat stuff.
+ for my $file ( ($self->_old_app_config_file, $self->dir_file, $self->user_file, $self->global_file) ) {
+ my $content = -f $file ? Prophet::Util->slurp($file) : '[';
+
+ # config file is old
+
+ # Also "converts" empty files but that's fine. If it ever
+ # does happen, we get the positive benefit of writing the
+ # config format to it.
+ if ( $content !~ /\[/ ) {
+
+ $self->convert_ancient_config_file($file);
+ }
+
+ }
+
+ Prophet::CLI->start_pager();
+
+ # Do a regular load.
+ $self->SUPER::load(@_);
+};
+
+### XXX BACKCOMPAT ONLY! We eventually want to kill this hash, modifier and
+### the following methods.
+
+# None of these need to have values mucked with at all, just the keys
+# migrated from old to new.
+our %KEYS_CONVERSION_TABLE = (
+ 'email_address' => 'user.email-address',
+ 'default_group_ticket_list' => 'ticket.list.default-group',
+ 'default_sort_ticket_list' => 'ticket.list.default-sort',
+ 'summary_format_ticket' => 'ticket.summary-format',
+ 'default_summary_format' => 'record.summary-format',
+ 'common_ticket_props' => 'ticket.common-props',
+ 'disable_ticket_show_history_by_default' => 'ticket.show.disable-history',
+);
+
+
+
+sub convert_ancient_config_file {
+ my $self = shift;
+ my $file = shift;
+ print "Detected old format config file $file. Converting to ".
+ "new format... ";
+
+ # read in and parse old config
+ my $config = { _sources => {}, _aliases => {} };
+ $self->_load_old_config_from_file( $file, $config );
+ my $aliases = delete $config->{_aliases};
+ my $sources = delete $config->{_sources};
+
+ # new configuration will include a config format version #
+ my @config_to_set = ( {
+ key => 'core.config-format-version',
+ value => $self->FORMAT_VERSION,
+ } );
+
+ # convert its keys to new-style keys by comparing to a conversion
+ # table
+ for my $key ( keys %$config ) {
+ die "Unknown key '$key' in old format config file '$file'."
+ ." Remove it or ask\non irc.freenode.net #prophet if you"
+ ." think this is a bug.\n"
+ unless exists $KEYS_CONVERSION_TABLE{$key};
+ push @config_to_set, {
+ key => $KEYS_CONVERSION_TABLE{$key},
+ value => $config->{$key},
+ };
+ }
+ # convert its aliases
+ for my $alias ( keys %$aliases ) {
+ push @config_to_set, {
+ key => "alias.'$alias'",
+ value => $aliases->{$alias},
+ };
+ }
+ # convert its sources
+ for my $name ( keys %$sources ) {
+ my ($url, $uuid) = split(/ \| /, $sources->{$name}, 2);
+ push @config_to_set, {
+ key => "replica.'$name'.url",
+ value => $url,
+ }, {
+ key => "replica.'$name'.uuid",
+ value => $uuid,
+ };
+ }
+ # move the old config file to a backup
+ my $backup_file = $file;
+ unless ( $self->_deprecated_repo_config_names->{$file} ) {
+ $backup_file = "$file.bak";
+ rename $file, $backup_file;
+ }
+
+ # we want to write the new file to a supported filename if
+ # it's from a deprecated config name (replica/prophetrc)
+ $file = File::Spec->catfile( $self->app_handle->handle->fs_root, 'config' )
+ if $self->_deprecated_repo_config_names->{$file};
+
+ # write the new config file (with group_set)
+ $self->group_set( $file, \@config_to_set, 1);
+
+ # tell the user that we're done
+ print "done.\nOld config can be found at $backup_file; "
+ ,"new config is $file.\n\n";
+
+}
+
+sub _deprecated_repo_config_names {
+ my $self = shift;
+
+ my %filenames = ( File::Spec->catfile( $self->app_handle->handle->fs_root => 'prophetrc' ) => 1 );
+
+ return wantarray ? %filenames : \%filenames;
};
+sub _load_old_config_from_file {
+ my $self = shift;
+ my $file = shift;
+ my $config = shift || {};
+
+ for my $line (Prophet::Util->slurp($file) ) {
+ $line =~ s/\#.*$//; # strip comments
+ next unless ($line =~ /^(.*?)\s*=\s*(.*)$/);
+ my $key = $1;
+ my $val = $2;
+ if ($key =~ m!alias\s+(.+)!) {
+ $config->{_aliases}->{$1} = $val;
+ } elsif ($key =~ m!source\s+(.+)!) {
+ $config->{_sources}->{$1} = $val;
+ } else {
+ $config->{$key} = $val;
+ }
+ }
+ $config->{_aliases} ||= {}; # default aliases is null.
+ $config->{_sources} ||= {}; # default to no sources.
+}
+
+}
__PACKAGE__->meta->make_immutable;
no Any::Moose;
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list