[Bps-public-commit] RT-Extension-SLA branch, performance-stats, updated. 0.05-26-g54ba321
Ruslan Zakirov
ruz at bestpractical.com
Sat Mar 3 07:10:30 EST 2012
The branch, performance-stats has been updated
via 54ba321367ea3c2da470ce5ecd5b741c521f7d1a (commit)
via 7b866719b0177ba17679b97a9ae4af27a7c87e80 (commit)
via 29fe4afa5f0360a181ea58ed56bd7cfb9bbe965e (commit)
via a42c4542364c17db50af89fbedd7bcdb26e34e05 (commit)
via 829e21f62dd6eda2a524a4342fa2ce4ee88aae18 (commit)
via c69101bc2483016d27e2f67b27a1b08dcd47c217 (commit)
via e50a053923015a5b2fdfb423d9c4ebdb8b44fcde (commit)
via 7188f5a9a11dda5726fce513091f1584b113b6b2 (commit)
via 29a2506e35303d123c56940897b85f0da1097585 (commit)
via 97071707926e6e39eb1d7e0e8e20c20312f29ee9 (commit)
via d395d80579c2c2629702c0481416b6b694ce4bba (commit)
via 9464ca410c7a62d28ee5f8815f7e3bbbe73de168 (commit)
via 28ae2b1e9b97fe8b3cb54c508b15167c78b84e58 (commit)
via 8bc9891b4cdcea8656d4920b09357b0bb9d085e6 (commit)
via 6a435e124abacf9abae7e9a48e8b81955e07661a (commit)
via be4d67e034e19287764c3efae6abee1515845b6e (commit)
via 6521f63de54b5b4bd68bcc30972bb1fd7c84be3c (commit)
via 490c58f7e8ca0593207adb7999076b55077108bf (commit)
via d47b88ca97d5e6e378c86b7f9c0f45dc40c76a9d (commit)
from afb655c376a8816af5f4c85de10ff9aad9a766c8 (commit)
Summary of changes:
.gitignore | 9 +
Changes | 9 +
MANIFEST | 2 +-
META.yml | 9 +-
Makefile.PL | 2 +-
.../RT-Extension-SLA/Elements/Tabs/Privileged | 34 ++
.../RT-Extension-SLA/Ticket/Elements/Tabs/Default | 24 --
.../Tools/Reports/Elements/Tabs/Default | 12 -
html/Elements/SLA/ShowReportSummary | 114 +++++++
html/NoAuth/css/base/sla-table.css | 29 ++
html/Ticket/SLA.html | 26 +--
html/Tools/Reports/SLA.html | 61 ++--
inc/Module/AutoInstall.pm | 169 ++++++++--
inc/Module/Install.pm | 220 +++++++-----
inc/Module/Install/AutoInstall.pm | 42 ++-
inc/Module/Install/Base.pm | 47 ++--
inc/Module/Install/Can.pm | 14 +-
inc/Module/Install/Fetch.pm | 8 +-
inc/Module/Install/Include.pm | 8 +-
inc/Module/Install/Makefile.pm | 250 +++++++++++---
inc/Module/Install/Metadata.pm | 358 ++++++++++++++------
inc/Module/Install/RTx.pm | 52 +++-
inc/Module/Install/Win32.pm | 6 +-
inc/Module/Install/WriteAll.pm | 23 +-
lib/RT/Condition/SLA_RequireDefault.pm | 4 +-
lib/RT/Extension/SLA.pm | 30 ++-
lib/RT/Extension/SLA/Report.pm | 164 +++++-----
lib/RT/Extension/SLA/Summary.pm | 141 ++++++--
lib/RT/Extension/SLA/Test.pm | 39 +++
t/basics.t | 3 +-
t/business_hours.t | 23 +-
t/due.t | 26 +-
t/queue.t | 16 +-
t/reporting/basic.t | 153 +++++++--
t/starts.t | 25 +-
t/utils.pl | 11 -
36 files changed, 1507 insertions(+), 656 deletions(-)
create mode 100644 .gitignore
create mode 100644 html/Callbacks/RT-Extension-SLA/Elements/Tabs/Privileged
delete mode 100644 html/Callbacks/RT-Extension-SLA/Ticket/Elements/Tabs/Default
delete mode 100644 html/Callbacks/RT-Extension-SLA/Tools/Reports/Elements/Tabs/Default
create mode 100644 html/Elements/SLA/ShowReportSummary
create mode 100644 html/NoAuth/css/base/sla-table.css
create mode 100644 lib/RT/Extension/SLA/Test.pm
delete mode 100644 t/utils.pl
- Log -----------------------------------------------------------------
commit e50a053923015a5b2fdfb423d9c4ebdb8b44fcde
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Feb 29 01:31:40 2012 +0400
upgrade M::I
diff --git a/META.yml b/META.yml
index a894f6d..7a3e577 100644
--- a/META.yml
+++ b/META.yml
@@ -3,12 +3,13 @@ abstract: 'Service Level Agreements for RT'
author:
- 'Ruslan Zakirov <ruz at bestpractical.com>'
build_requires:
- ExtUtils::MakeMaker: 6.42
+ ExtUtils::MakeMaker: 6.59
Test::More: 0
configure_requires:
- ExtUtils::MakeMaker: 6.42
+ ExtUtils::MakeMaker: 6.59
distribution_type: module
-generated_by: 'Module::Install version 0.88'
+dynamic_config: 1
+generated_by: 'Module::Install version 1.05'
license: gpl2
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
diff --git a/inc/Module/AutoInstall.pm b/inc/Module/AutoInstall.pm
index 807fa7b..d516bae 100644
--- a/inc/Module/AutoInstall.pm
+++ b/inc/Module/AutoInstall.pm
@@ -3,11 +3,12 @@ package Module::AutoInstall;
use strict;
use Cwd ();
+use File::Spec ();
use ExtUtils::MakeMaker ();
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.03';
+ $VERSION = '1.05';
}
# special map on pre-defined feature sets
@@ -17,11 +18,14 @@ my %FeatureMap = (
);
# various lexical flags
-my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
+my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS );
my (
- $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps
+ $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps,
+ $UpgradeDeps
);
-my ( $PostambleActions, $PostambleUsed );
+my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps,
+ $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps,
+ $PostambleActionsListAllDeps, $PostambleUsed, $NoTest);
# See if it's a testing or non-interactive session
_accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN );
@@ -31,6 +35,10 @@ sub _accept_default {
$AcceptDefault = shift;
}
+sub _installdeps_target {
+ $InstallDepsTarget = shift;
+}
+
sub missing_modules {
return @Missing;
}
@@ -63,6 +71,11 @@ sub _init {
__PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
exit 0;
}
+ elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) {
+ $UpgradeDeps = 1;
+ __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
+ exit 0;
+ }
elsif ( $arg =~ /^--default(?:deps)?$/ ) {
$AcceptDefault = 1;
}
@@ -125,7 +138,7 @@ sub import {
# 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;
+ $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget;
while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
my ( @required, @tests, @skiptests );
@@ -175,7 +188,7 @@ sub import {
}
# XXX: check for conflicts and uninstalls(!) them.
- my $cur = _load($mod);
+ my $cur = _version_of($mod);
if (_version_cmp ($cur, $arg) >= 0)
{
print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
@@ -207,6 +220,7 @@ sub import {
$CheckOnly
or ($mandatory and $UnderCPAN)
or $AllDeps
+ or $InstallDepsTarget
or _prompt(
qq{==> Auto-install the }
. ( @required / 2 )
@@ -237,10 +251,17 @@ sub import {
}
}
- if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
+ if ( @Missing and not( $CheckOnly or $UnderCPAN) ) {
require Config;
- print
-"*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n";
+ my $make = $Config::Config{make};
+ if ($InstallDepsTarget) {
+ print
+"*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n";
+ }
+ else {
+ print
+"*** Dependencies will be installed the next time you type '$make'.\n";
+ }
# make an educated guess of whether we'll need root permission.
print " (You may need to do that as the 'root' user.)\n"
@@ -253,6 +274,8 @@ sub import {
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
+
+ return (@Existing, @Missing);
}
sub _running_under {
@@ -269,6 +292,10 @@ END_MESSAGE
sub _check_lock {
return unless @Missing or @_;
+ if ($ENV{PERL5_CPANM_IS_RUNNING}) {
+ return _running_under('cpanminus');
+ }
+
my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING};
if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
@@ -322,7 +349,7 @@ sub install {
while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
# grep out those already installed
- if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
+ if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
else {
@@ -330,6 +357,11 @@ sub install {
}
}
+ if ($UpgradeDeps) {
+ push @modules, @installed;
+ @installed = ();
+ }
+
return @installed unless @modules; # nothing to do
return @installed if _check_lock(); # defer to the CPAN shell
@@ -361,7 +393,7 @@ sub install {
# see if we have successfully installed them
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
- if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
+ if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
@@ -461,6 +493,11 @@ sub _cpanplus_config {
} else {
die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n";
}
+ push @config, 'prereqs', $value;
+ } elsif ( $key eq 'force' ) {
+ push @config, $key, $value;
+ } elsif ( $key eq 'notest' ) {
+ push @config, 'skiptest', $value;
} else {
die "*** Cannot convert option $key to CPANPLUS version.\n";
}
@@ -495,10 +532,14 @@ sub _install_cpan {
# set additional options
while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) {
( $args{$opt} = $arg, next )
- if $opt =~ /^force$/; # pseudo-option
+ if $opt =~ /^(?:force|notest)$/; # pseudo-option
$CPAN::Config->{$opt} = $arg;
}
+ if ($args{notest} && (not CPAN::Shell->can('notest'))) {
+ die "Your version of CPAN is too old to support the 'notest' pragma";
+ }
+
local $CPAN::Config->{prerequisites_policy} = 'follow';
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
@@ -517,8 +558,16 @@ sub _install_cpan {
delete $INC{$inc};
}
- my $rv = $args{force} ? CPAN::Shell->force( install => $pkg )
- : CPAN::Shell->install($pkg);
+ my $rv = do {
+ if ($args{force}) {
+ CPAN::Shell->force( install => $pkg )
+ } elsif ($args{notest}) {
+ CPAN::Shell->notest( install => $pkg )
+ } else {
+ CPAN::Shell->install($pkg)
+ }
+ };
+
$rv ||= eval {
$CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )
->{install}
@@ -573,7 +622,7 @@ sub _update_to {
my $ver = shift;
return
- if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade
+ if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade
if (
_prompt( "==> A newer version of $class ($ver) is required. Install?",
@@ -658,21 +707,48 @@ sub _can_write {
# load a module and return the version it reports
sub _load {
- my $mod = pop; # class/instance doesn't matter
+ my $mod = pop; # method/function doesn't matter
my $file = $mod;
-
$file =~ s|::|/|g;
$file .= '.pm';
-
local $@;
return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
}
+# report version without loading a module
+sub _version_of {
+ my $mod = pop; # method/function doesn't matter
+ my $file = $mod;
+ $file =~ s|::|/|g;
+ $file .= '.pm';
+ foreach my $dir ( @INC ) {
+ next if ref $dir;
+ my $path = File::Spec->catfile($dir, $file);
+ next unless -e $path;
+ require ExtUtils::MM_Unix;
+ return ExtUtils::MM_Unix->parse_version($path);
+ }
+ return undef;
+}
+
# Load CPAN.pm and it's configuration
sub _load_cpan {
- return if $CPAN::VERSION and not @_;
+ return if $CPAN::VERSION and $CPAN::Config and not @_;
require CPAN;
- if ( $CPAN::HandleConfig::VERSION ) {
+
+ # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to
+ # CPAN::HandleConfig->load. CPAN reports that the redirection
+ # is deprecated in a warning printed at the user.
+
+ # CPAN-1.81 expects CPAN::HandleConfig->load, does not have
+ # $CPAN::HandleConfig::VERSION but cannot handle
+ # CPAN::Config->load
+
+ # Which "versions expect CPAN::Config->load?
+
+ if ( $CPAN::HandleConfig::VERSION
+ || CPAN::HandleConfig->can('load')
+ ) {
# Newer versions of CPAN have a HandleConfig module
CPAN::HandleConfig->load;
} else {
@@ -748,6 +824,35 @@ sub _make_args {
: "\$(NOECHO) \$(NOOP)"
);
+ my $deps_list = join( ',', @Missing, @Existing );
+
+ $PostambleActionsUpgradeDeps =
+ "\$(PERL) $0 --config=$config --upgradedeps=$deps_list";
+
+ my $config_notest =
+ join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}),
+ 'notest', 1 )
+ if $Config;
+
+ $PostambleActionsNoTest = (
+ ($missing and not $UnderCPAN)
+ ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing"
+ : "\$(NOECHO) \$(NOOP)"
+ );
+
+ $PostambleActionsUpgradeDepsNoTest =
+ "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list";
+
+ $PostambleActionsListDeps =
+ '@$(PERL) -le "print for @ARGV" '
+ . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing);
+
+ my @all = (@Missing, @Existing);
+
+ $PostambleActionsListAllDeps =
+ '@$(PERL) -le "print for @ARGV" '
+ . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all);
+
return %args;
}
@@ -782,11 +887,15 @@ sub Write {
sub postamble {
$PostambleUsed = 1;
+ my $fragment;
- return <<"END_MAKE";
+ $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget;
config :: installdeps
\t\$(NOECHO) \$(NOOP)
+AUTO_INSTALL
+
+ $fragment .= <<"END_MAKE";
checkdeps ::
\t\$(PERL) $0 --checkdeps
@@ -794,12 +903,28 @@ checkdeps ::
installdeps ::
\t$PostambleActions
+installdeps_notest ::
+\t$PostambleActionsNoTest
+
+upgradedeps ::
+\t$PostambleActionsUpgradeDeps
+
+upgradedeps_notest ::
+\t$PostambleActionsUpgradeDepsNoTest
+
+listdeps ::
+\t$PostambleActionsListDeps
+
+listalldeps ::
+\t$PostambleActionsListAllDeps
+
END_MAKE
+ return $fragment;
}
1;
__END__
-#line 1056
+#line 1193
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index d39e460..4508d97 100644
--- a/inc/Module/Install.pm
+++ b/inc/Module/Install.pm
@@ -19,6 +19,9 @@ package Module::Install;
use 5.005;
use strict 'vars';
+use Cwd ();
+use File::Find ();
+use File::Path ();
use vars qw{$VERSION $MAIN};
BEGIN {
@@ -28,7 +31,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.88';
+ $VERSION = '1.05';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -38,18 +41,25 @@ BEGIN {
}
+sub import {
+ my $class = shift;
+ my $self = $class->new(@_);
+ my $who = $self->_caller;
-
-
-
-# Whether or not inc::Module::Install is actually loaded, the
-# $INC{inc/Module/Install.pm} is what will still get set as long as
-# the caller loaded module this in the documented manner.
-# If not set, the caller may NOT have loaded the bundled version, and thus
-# they may not have a MI version that works with the Makefile.PL. This would
-# result in false errors or unexpected behaviour. And we don't want that.
-my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
-unless ( $INC{$file} ) { die <<"END_DIE" }
+ #-------------------------------------------------------------
+ # all of the following checks should be included in import(),
+ # to allow "eval 'require Module::Install; 1' to test
+ # installation of Module::Install. (RT #51267)
+ #-------------------------------------------------------------
+
+ # Whether or not inc::Module::Install is actually loaded, the
+ # $INC{inc/Module/Install.pm} is what will still get set as long as
+ # the caller loaded module this in the documented manner.
+ # If not set, the caller may NOT have loaded the bundled version, and thus
+ # they may not have a MI version that works with the Makefile.PL. This would
+ # result in false errors or unexpected behaviour. And we don't want that.
+ my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
+ unless ( $INC{$file} ) { die <<"END_DIE" }
Please invoke ${\__PACKAGE__} with:
@@ -61,26 +71,28 @@ not:
END_DIE
-
-
-
-
-# If the script that is loading Module::Install is from the future,
-# then make will detect this and cause it to re-run over and over
-# again. This is bad. Rather than taking action to touch it (which
-# is unreliable on some platforms and requires write permissions)
-# for now we should catch this and refuse to run.
-if ( -f $0 ) {
- my $s = (stat($0))[9];
-
- # If the modification time is only slightly in the future,
- # sleep briefly to remove the problem.
- my $a = $s - time;
- if ( $a > 0 and $a < 5 ) { sleep 5 }
-
- # Too far in the future, throw an error.
- my $t = time;
- if ( $s > $t ) { die <<"END_DIE" }
+ # This reportedly fixes a rare Win32 UTC file time issue, but
+ # as this is a non-cross-platform XS module not in the core,
+ # we shouldn't really depend on it. See RT #24194 for detail.
+ # (Also, this module only supports Perl 5.6 and above).
+ eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
+
+ # If the script that is loading Module::Install is from the future,
+ # then make will detect this and cause it to re-run over and over
+ # again. This is bad. Rather than taking action to touch it (which
+ # is unreliable on some platforms and requires write permissions)
+ # for now we should catch this and refuse to run.
+ if ( -f $0 ) {
+ my $s = (stat($0))[9];
+
+ # If the modification time is only slightly in the future,
+ # sleep briefly to remove the problem.
+ my $a = $s - time;
+ if ( $a > 0 and $a < 5 ) { sleep 5 }
+
+ # Too far in the future, throw an error.
+ my $t = time;
+ if ( $s > $t ) { die <<"END_DIE" }
Your installer $0 has a modification time in the future ($s > $t).
@@ -89,15 +101,12 @@ This is known to create infinite loops in make.
Please correct this, then run $0 again.
END_DIE
-}
-
-
-
+ }
-# Build.PL was formerly supported, but no longer is due to excessive
-# difficulty in implementing every single feature twice.
-if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
+ # Build.PL was formerly supported, but no longer is due to excessive
+ # difficulty in implementing every single feature twice.
+ if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
Module::Install no longer supports Build.PL.
@@ -107,23 +116,42 @@ Please remove all Build.PL files and only use the Makefile.PL installer.
END_DIE
+ #-------------------------------------------------------------
+ # To save some more typing in Module::Install installers, every...
+ # use inc::Module::Install
+ # ...also acts as an implicit use strict.
+ $^H |= strict::bits(qw(refs subs vars));
+ #-------------------------------------------------------------
+ unless ( -f $self->{file} ) {
+ foreach my $key (keys %INC) {
+ delete $INC{$key} if $key =~ /Module\/Install/;
+ }
-# To save some more typing in Module::Install installers, every...
-# use inc::Module::Install
-# ...also acts as an implicit use strict.
-$^H |= strict::bits(qw(refs subs vars));
-
+ local $^W;
+ require "$self->{path}/$self->{dispatch}.pm";
+ File::Path::mkpath("$self->{prefix}/$self->{author}");
+ $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
+ $self->{admin}->init;
+ @_ = ($class, _self => $self);
+ goto &{"$self->{name}::import"};
+ }
+ local $^W;
+ *{"${who}::AUTOLOAD"} = $self->autoload;
+ $self->preload;
+ # Unregister loader and worker packages so subdirs can use them again
+ delete $INC{'inc/Module/Install.pm'};
+ delete $INC{'Module/Install.pm'};
+ # Save to the singleton
+ $MAIN = $self;
-use Cwd ();
-use File::Find ();
-use File::Path ();
-use FindBin;
+ return 1;
+}
sub autoload {
my $self = shift;
@@ -136,7 +164,21 @@ sub autoload {
# Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
- $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
+ unless ($$sym =~ s/([^:]+)$//) {
+ # XXX: it looks like we can't retrieve the missing function
+ # via $$sym (usually $main::AUTOLOAD) in this case.
+ # I'm still wondering if we should slurp Makefile.PL to
+ # get some context or not ...
+ my ($package, $file, $line) = caller;
+ die <<"EOT";
+Unknown function is found at $file line $line.
+Execution of $file aborted due to runtime errors.
+
+If you're a contributor to a project, you may need to install
+some Module::Install extensions from CPAN (or other repository).
+If you're a user of a module, please contact the author.
+EOT
+ }
my $method = $1;
if ( uc($method) eq $method ) {
# Do nothing
@@ -152,33 +194,6 @@ sub autoload {
};
}
-sub import {
- my $class = shift;
- my $self = $class->new(@_);
- my $who = $self->_caller;
-
- unless ( -f $self->{file} ) {
- require "$self->{path}/$self->{dispatch}.pm";
- File::Path::mkpath("$self->{prefix}/$self->{author}");
- $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
- $self->{admin}->init;
- @_ = ($class, _self => $self);
- goto &{"$self->{name}::import"};
- }
-
- *{"${who}::AUTOLOAD"} = $self->autoload;
- $self->preload;
-
- # Unregister loader and worker packages so subdirs can use them again
- delete $INC{"$self->{file}"};
- delete $INC{"$self->{path}.pm"};
-
- # Save to the singleton
- $MAIN = $self;
-
- return 1;
-}
-
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
@@ -204,6 +219,7 @@ sub preload {
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
+ local $^W;
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
@@ -214,12 +230,18 @@ sub preload {
sub new {
my ($class, %args) = @_;
+ delete $INC{'FindBin.pm'};
+ {
+ # to suppress the redefine warning
+ local $SIG{__WARN__} = sub {};
+ require FindBin;
+ }
+
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
delete $args{prefix};
}
-
return $args{_self} if $args{_self};
$args{dispatch} ||= 'Admin';
@@ -272,8 +294,10 @@ END_DIE
sub load_extensions {
my ($self, $path, $top) = @_;
+ my $should_reload = 0;
unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
+ $should_reload = 1;
}
foreach my $rv ( $self->find_extensions($path) ) {
@@ -281,12 +305,13 @@ sub load_extensions {
next if $self->{pathnames}{$pkg};
local $@;
- my $new = eval { require $file; $pkg->can('new') };
+ my $new = eval { local $^W; require $file; $pkg->can('new') };
unless ( $new ) {
warn $@ if $@;
next;
}
- $self->{pathnames}{$pkg} = delete $INC{$file};
+ $self->{pathnames}{$pkg} =
+ $should_reload ? delete $INC{$file} : $INC{$file};
push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
}
@@ -348,17 +373,24 @@ sub _caller {
return $call;
}
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _read {
local *FH;
- 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]): $!";
+ return $string;
+}
+END_NEW
+sub _read {
+ local *FH;
+ open( FH, "< $_[0]" ) or die "open($_[0]): $!";
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
+END_OLD
sub _readperl {
my $string = Module::Install::_read($_[0]);
@@ -379,18 +411,26 @@ sub _readpod {
return $string;
}
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _write {
local *FH;
- 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]): $!";
}
+ close FH or die "close($_[0]): $!";
+}
+END_NEW
+sub _write {
+ local *FH;
+ open( FH, "> $_[0]" ) or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
+END_OLD
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
@@ -411,7 +451,7 @@ sub _version ($) {
}
sub _cmp ($$) {
- _version($_[0]) <=> _version($_[1]);
+ _version($_[1]) <=> _version($_[2]);
}
# Cloned from Params::Util::_CLASS
@@ -427,4 +467,4 @@ sub _CLASS ($) {
1;
-# Copyright 2008 - 2009 Adam Kennedy.
+# Copyright 2008 - 2012 Adam Kennedy.
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
index 32f1423..405f161 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.88';
+ $VERSION = '1.05';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub AutoInstall { $_[0] }
@@ -37,12 +37,33 @@ sub auto_install {
$self->include('Module::AutoInstall');
require Module::AutoInstall;
- Module::AutoInstall->import(
+ my @features_require = Module::AutoInstall->import(
(@config ? (-config => \@config) : ()),
(@core ? (-core => \@core) : ()),
$self->features,
);
+ my %seen;
+ my @requires = map @$_, map @$_, grep ref, $self->requires;
+ while (my ($mod, $ver) = splice(@requires, 0, 2)) {
+ $seen{$mod}{$ver}++;
+ }
+ my @build_requires = map @$_, map @$_, grep ref, $self->build_requires;
+ while (my ($mod, $ver) = splice(@build_requires, 0, 2)) {
+ $seen{$mod}{$ver}++;
+ }
+ my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires;
+ while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) {
+ $seen{$mod}{$ver}++;
+ }
+
+ my @deduped;
+ while (my ($mod, $ver) = splice(@features_require, 0, 2)) {
+ push @deduped, $mod => $ver unless $seen{$mod}{$ver}++;
+ }
+
+ $self->requires(@deduped);
+
$self->makemaker_args( Module::AutoInstall::_make_args() );
my $class = ref($self);
@@ -52,6 +73,17 @@ sub auto_install {
);
}
+sub installdeps_target {
+ my ($self, @args) = @_;
+
+ $self->include('Module::AutoInstall');
+ require Module::AutoInstall;
+
+ Module::AutoInstall::_installdeps_target(1);
+
+ $self->auto_install(@args);
+}
+
sub auto_install_now {
my $self = shift;
$self->auto_install(@_);
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index c08b3f0..683088b 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.88';
+ $VERSION = '1.05';
}
# 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,16 +48,21 @@ sub admin {
Module::Install::Base::FakeAdmin->new;
}
-#line 114
+#line 106
sub is_admin {
- $_[0]->admin->VERSION;
+ ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin');
}
sub DESTROY {}
package Module::Install::Base::FakeAdmin;
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = $Module::Install::Base::VERSION;
+}
+
my $fake;
sub new {
@@ -83,4 +80,4 @@ BEGIN {
1;
-#line 162
+#line 159
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index fd64344..79932c5 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.88';
+ $VERSION = '1.05';
+ @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 e0acf6b..085a253 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.88';
+ $VERSION = '1.05';
+ @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 6324bd5..2dd69c9 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.88';
+ $VERSION = '1.05';
+ @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 3d10124..c3cbb2b 100644
--- a/inc/Module/Install/Makefile.pm
+++ b/inc/Module/Install/Makefile.pm
@@ -2,14 +2,15 @@
package Module::Install::Makefile;
use strict 'vars';
-use Module::Install::Base;
-use ExtUtils::MakeMaker ();
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
+use Fcntl qw/:flock :seek/;
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.88';
+ $VERSION = '1.05';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub Makefile { $_[0] }
@@ -25,8 +26,8 @@ sub prompt {
die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
}
- # In automated testing, always use defaults
- if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
+ # In automated testing or non-interactive session, always use defaults
+ if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
local $ENV{PERL_MM_USE_DEFAULT} = 1;
goto &ExtUtils::MakeMaker::prompt;
} else {
@@ -34,21 +35,112 @@ sub prompt {
}
}
+# Store a cleaned up version of the MakeMaker version,
+# since we need to behave differently in a variety of
+# ways based on the MM version.
+my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
+
+# If we are passed a param, do a "newer than" comparison.
+# Otherwise, just return the MakeMaker version.
+sub makemaker {
+ ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
+}
+
+# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
+# as we only need to know here whether the attribute is an array
+# or a hash or something else (which may or may not be appendable).
+my %makemaker_argtype = (
+ C => 'ARRAY',
+ CONFIG => 'ARRAY',
+# CONFIGURE => 'CODE', # ignore
+ DIR => 'ARRAY',
+ DL_FUNCS => 'HASH',
+ DL_VARS => 'ARRAY',
+ EXCLUDE_EXT => 'ARRAY',
+ EXE_FILES => 'ARRAY',
+ FUNCLIST => 'ARRAY',
+ H => 'ARRAY',
+ IMPORTS => 'HASH',
+ INCLUDE_EXT => 'ARRAY',
+ LIBS => 'ARRAY', # ignore ''
+ MAN1PODS => 'HASH',
+ MAN3PODS => 'HASH',
+ META_ADD => 'HASH',
+ META_MERGE => 'HASH',
+ PL_FILES => 'HASH',
+ PM => 'HASH',
+ PMLIBDIRS => 'ARRAY',
+ PMLIBPARENTDIRS => 'ARRAY',
+ PREREQ_PM => 'HASH',
+ CONFIGURE_REQUIRES => 'HASH',
+ SKIP => 'ARRAY',
+ TYPEMAPS => 'ARRAY',
+ XS => 'HASH',
+# VERSION => ['version',''], # ignore
+# _KEEP_AFTER_FLUSH => '',
+
+ clean => 'HASH',
+ depend => 'HASH',
+ dist => 'HASH',
+ dynamic_lib=> 'HASH',
+ linkext => 'HASH',
+ macro => 'HASH',
+ postamble => 'HASH',
+ realclean => 'HASH',
+ test => 'HASH',
+ tool_autosplit => 'HASH',
+
+ # special cases where you can use makemaker_append
+ CCFLAGS => 'APPENDABLE',
+ DEFINE => 'APPENDABLE',
+ INC => 'APPENDABLE',
+ LDDLFLAGS => 'APPENDABLE',
+ LDFROM => 'APPENDABLE',
+);
+
sub makemaker_args {
- my $self = shift;
+ my ($self, %new_args) = @_;
my $args = ( $self->{makemaker_args} ||= {} );
- %$args = ( %$args, @_ );
+ foreach my $key (keys %new_args) {
+ if ($makemaker_argtype{$key}) {
+ if ($makemaker_argtype{$key} eq 'ARRAY') {
+ $args->{$key} = [] unless defined $args->{$key};
+ unless (ref $args->{$key} eq 'ARRAY') {
+ $args->{$key} = [$args->{$key}]
+ }
+ push @{$args->{$key}},
+ ref $new_args{$key} eq 'ARRAY'
+ ? @{$new_args{$key}}
+ : $new_args{$key};
+ }
+ elsif ($makemaker_argtype{$key} eq 'HASH') {
+ $args->{$key} = {} unless defined $args->{$key};
+ foreach my $skey (keys %{ $new_args{$key} }) {
+ $args->{$key}{$skey} = $new_args{$key}{$skey};
+ }
+ }
+ elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
+ $self->makemaker_append($key => $new_args{$key});
+ }
+ }
+ else {
+ if (defined $args->{$key}) {
+ warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n};
+ }
+ $args->{$key} = $new_args{$key};
+ }
+ }
return $args;
}
# For mm args that take multiple space-seperated args,
# append an argument to the current list.
sub makemaker_append {
- my $self = sShift;
+ my $self = shift;
my $name = shift;
my $args = $self->makemaker_args;
- $args->{name} = defined $args->{$name}
- ? join( ' ', $args->{name}, @_ )
+ $args->{$name} = defined $args->{$name}
+ ? join( ' ', $args->{$name}, @_ )
: join( ' ', @_ );
}
@@ -89,25 +181,22 @@ sub inc {
$self->makemaker_args( INC => shift );
}
-my %test_dir = ();
-
sub _wanted_t {
- /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
}
sub tests_recursive {
my $self = shift;
- if ( $self->tests ) {
- die "tests_recursive will not work if tests are already defined";
- }
my $dir = shift || 't';
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
- %test_dir = ();
+ my %tests = map { $_ => 1 } split / /, ($self->tests || '');
require File::Find;
- File::Find::find( \&_wanted_t, $dir );
- $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
+ File::Find::find(
+ sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 },
+ $dir
+ );
+ $self->tests( join ' ', sort keys %tests );
}
sub write {
@@ -126,76 +215,136 @@ sub write {
require ExtUtils::MakeMaker;
if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
- # MakeMaker can complain about module versions that include
- # an underscore, even though its own version may contain one!
- # Hence the funny regexp to get rid of it. See RT #35800
- # for details.
- $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
- $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
+ # This previous attempted to inherit the version of
+ # ExtUtils::MakeMaker in use by the module author, but this
+ # was found to be untenable as some authors build releases
+ # using future dev versions of EU:MM that nobody else has.
+ # Instead, #toolchain suggests we use 6.59 which is the most
+ # stable version on CPAN at time of writing and is, to quote
+ # ribasushi, "not terminally fucked, > and tested enough".
+ # TODO: We will now need to maintain this over time to push
+ # the version up as new versions are released.
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 );
} else {
# Allow legacy-compatibility with 5.005 by depending on the
# most recent EU:MM that supported 5.005.
- $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
- $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 );
}
# Generate the MakeMaker params
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
$args->{NAME} = $self->module_name || $self->name;
- $args->{VERSION} = $self->version;
$args->{NAME} =~ s/-/::/g;
+ $args->{VERSION} = $self->version or die <<'EOT';
+ERROR: Can't determine distribution version. Please specify it
+explicitly via 'version' in Makefile.PL, or set a valid $VERSION
+in a module, and provide its file path via 'version_from' (or
+'all_from' if you prefer) in Makefile.PL.
+EOT
+
if ( $self->tests ) {
- $args->{test} = { TESTS => $self->tests };
+ my @tests = split ' ', $self->tests;
+ my %seen;
+ $args->{test} = {
+ TESTS => (join ' ', grep {!$seen{$_}++} @tests),
+ };
+ } elsif ( $Module::Install::ExtraTests::use_extratests ) {
+ # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness.
+ # So, just ignore our xt tests here.
+ } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
+ $args->{test} = {
+ TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
+ };
}
if ( $] >= 5.005 ) {
$args->{ABSTRACT} = $self->abstract;
- $args->{AUTHOR} = $self->author;
+ $args->{AUTHOR} = join ', ', @{$self->author || []};
}
- if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
- $args->{NO_META} = 1;
+ if ( $self->makemaker(6.10) ) {
+ $args->{NO_META} = 1;
+ #$args->{NO_MYMETA} = 1;
}
- if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
+ if ( $self->makemaker(6.17) and $self->sign ) {
$args->{SIGN} = 1;
}
unless ( $self->is_admin ) {
delete $args->{SIGN};
}
+ if ( $self->makemaker(6.31) and $self->license ) {
+ $args->{LICENSE} = $self->license;
+ }
- # Merge both kinds of requires into prereq_pm
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
- map { @$_ }
+ map { @$_ } # flatten [module => version]
map { @$_ }
grep $_,
- ($self->configure_requires, $self->build_requires, $self->requires)
+ ($self->requires)
);
# Remove any reference to perl, PREREQ_PM doesn't support it
delete $args->{PREREQ_PM}->{perl};
- # merge both kinds of requires into prereq_pm
- my $subdirs = ($args->{DIR} ||= []);
+ # Merge both kinds of requires into BUILD_REQUIRES
+ my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
+ %$build_prereq = ( %$build_prereq,
+ map { @$_ } # flatten [module => version]
+ map { @$_ }
+ grep $_,
+ ($self->configure_requires, $self->build_requires)
+ );
+
+ # Remove any reference to perl, BUILD_REQUIRES doesn't support it
+ delete $args->{BUILD_REQUIRES}->{perl};
+
+ # Delete bundled dists from prereq_pm, add it to Makefile DIR
+ my $subdirs = ($args->{DIR} || []);
if ($self->bundles) {
+ my %processed;
foreach my $bundle (@{ $self->bundles }) {
- my ($file, $dir) = @$bundle;
- push @$subdirs, $dir if -d $dir;
- delete $prereq->{$file};
+ my ($mod_name, $dist_dir) = @$bundle;
+ delete $prereq->{$mod_name};
+ $dist_dir = File::Basename::basename($dist_dir); # dir for building this module
+ if (not exists $processed{$dist_dir}) {
+ if (-d $dist_dir) {
+ # List as sub-directory to be processed by make
+ push @$subdirs, $dist_dir;
+ }
+ # Else do nothing: the module is already present on the system
+ $processed{$dist_dir} = undef;
+ }
}
}
+ unless ( $self->makemaker('6.55_03') ) {
+ %$prereq = (%$prereq,%$build_prereq);
+ delete $args->{BUILD_REQUIRES};
+ }
+
if ( my $perl_version = $self->perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
+
+ if ( $self->makemaker(6.48) ) {
+ $args->{MIN_PERL_VERSION} = $perl_version;
+ }
}
- $args->{INSTALLDIRS} = $self->installdirs;
+ if ($self->installdirs) {
+ warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS};
+ $args->{INSTALLDIRS} = $self->installdirs;
+ }
- my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
+ my %args = map {
+ ( $_ => $args->{$_} ) } grep {defined($args->{$_} )
+ } keys %$args;
my $user_preop = delete $args{dist}->{PREOP};
- if (my $preop = $self->admin->preop($user_preop)) {
+ if ( my $preop = $self->admin->preop($user_preop) ) {
foreach my $key ( keys %$preop ) {
$args{dist}->{$key} = $preop->{$key};
}
@@ -219,9 +368,9 @@ sub fix_up_makefile {
. ($self->postamble || '');
local *MAKEFILE;
- open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ eval { flock MAKEFILE, LOCK_EX };
my $makefile = do { local $/; <MAKEFILE> };
- close MAKEFILE or die $!;
$makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
$makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
@@ -241,7 +390,8 @@ sub fix_up_makefile {
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
- open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ seek MAKEFILE, 0, SEEK_SET;
+ truncate MAKEFILE, 0;
print MAKEFILE "$preamble$makefile$postamble" or die $!;
close MAKEFILE or die $!;
@@ -265,4 +415,4 @@ sub postamble {
__END__
-#line 394
+#line 544
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index 6fd221f..c863124 100644
--- a/inc/Module/Install/Metadata.pm
+++ b/inc/Module/Install/Metadata.pm
@@ -2,25 +2,23 @@
package Module::Install::Metadata;
use strict 'vars';
-use Module::Install::Base;
+use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.88';
- @ISA = qw{Module::Install::Base};
+ $VERSION = '1.05';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
}
my @boolean_keys = qw{
sign
- mymeta
};
my @scalar_keys = qw{
name
module_name
abstract
- author
version
distribution_type
tests
@@ -44,8 +42,11 @@ my @resource_keys = qw{
my @array_keys = qw{
keywords
+ author
};
+*authors = \&author;
+
sub Meta { shift }
sub Meta_BooleanKeys { @boolean_keys }
sub Meta_ScalarKeys { @scalar_keys }
@@ -150,15 +151,21 @@ sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub dynamic_config {
- my $self = shift;
- unless ( @_ ) {
- warn "You MUST provide an explicit true/false value to dynamic_config\n";
- return $self;
+ my $self = shift;
+ my $value = @_ ? shift : 1;
+ if ( $self->{values}->{dynamic_config} ) {
+ # Once dynamic we never change to static, for safety
+ return 0;
}
- $self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
+ $self->{values}->{dynamic_config} = $value ? 1 : 0;
return 1;
}
+# Convenience command
+sub static_config {
+ shift->dynamic_config(0);
+}
+
sub perl_version {
my $self = shift;
return $self->{values}->{perl_version} unless @_;
@@ -169,7 +176,7 @@ sub perl_version {
# Normalize the version
$version = $self->_perl_version($version);
- # We don't support the reall old versions
+ # We don't support the really old versions
unless ( $version >= 5.005 ) {
die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
}
@@ -177,43 +184,6 @@ sub perl_version {
$self->{values}->{perl_version} = $version;
}
-#Stolen from M::B
-my %license_urls = (
- perl => 'http://dev.perl.org/licenses/',
- apache => 'http://apache.org/licenses/LICENSE-2.0',
- artistic => 'http://opensource.org/licenses/artistic-license.php',
- artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
- lgpl => 'http://opensource.org/licenses/lgpl-license.php',
- lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
- lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
- bsd => 'http://opensource.org/licenses/bsd-license.php',
- gpl => 'http://opensource.org/licenses/gpl-license.php',
- gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
- gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
- mit => 'http://opensource.org/licenses/mit-license.php',
- mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
- open_source => undef,
- unrestricted => undef,
- restrictive => undef,
- unknown => undef,
-);
-
-sub license {
- my $self = shift;
- return $self->{values}->{license} unless @_;
- my $license = shift or die(
- 'Did not provide a value to license()'
- );
- $self->{values}->{license} = $license;
-
- # Automatically fill in license URLs
- if ( $license_urls{$license} ) {
- $self->resources( license => $license_urls{$license} );
- }
-
- return 1;
-}
-
sub all_from {
my ( $self, $file ) = @_;
@@ -231,6 +201,8 @@ sub all_from {
die("The path '$file' does not exist, or is not a file");
}
+ $self->{values}{all_from} = $file;
+
# Some methods pull from POD instead of code.
# If there is a matching .pod, use that instead
my $pod = $file;
@@ -241,7 +213,7 @@ sub all_from {
$self->name_from($file) unless $self->name;
$self->version_from($file) unless $self->version;
$self->perl_version_from($file) unless $self->perl_version;
- $self->author_from($pod) unless $self->author;
+ $self->author_from($pod) unless @{$self->author || []};
$self->license_from($pod) unless $self->license;
$self->abstract_from($pod) unless $self->abstract;
@@ -351,6 +323,9 @@ sub version_from {
require ExtUtils::MM_Unix;
my ( $self, $file ) = @_;
$self->version( ExtUtils::MM_Unix->parse_version($file) );
+
+ # for version integrity check
+ $self->makemaker_args( VERSION_FROM => $file );
}
sub abstract_from {
@@ -361,7 +336,7 @@ sub abstract_from {
{ DISTNAME => $self->name },
'ExtUtils::MM_Unix'
)->parse_abstract($file)
- );
+ );
}
# Add both distribution and module name
@@ -386,11 +361,10 @@ sub name_from {
}
}
-sub perl_version_from {
- my $self = shift;
+sub _extract_perl_version {
if (
- Module::Install::_read($_[0]) =~ m/
- ^
+ $_[0] =~ m/
+ ^\s*
(?:use|require) \s*
v?
([\d_\.]+)
@@ -399,6 +373,16 @@ sub perl_version_from {
) {
my $perl_version = $1;
$perl_version =~ s{_}{}g;
+ return $perl_version;
+ } else {
+ return;
+ }
+}
+
+sub perl_version_from {
+ my $self = shift;
+ my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
+ if ($perl_version) {
$self->perl_version($perl_version);
} else {
warn "Cannot determine perl version info from $_[0]\n";
@@ -418,59 +402,165 @@ sub author_from {
([^\n]*)
/ixms) {
my $author = $1 || $2;
- $author =~ s{E<lt>}{<}g;
- $author =~ s{E<gt>}{>}g;
+
+ # XXX: ugly but should work anyway...
+ if (eval "require Pod::Escapes; 1") {
+ # Pod::Escapes has a mapping table.
+ # It's in core of perl >= 5.9.3, and should be installed
+ # as one of the Pod::Simple's prereqs, which is a prereq
+ # of Pod::Text 3.x (see also below).
+ $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
+ {
+ defined $2
+ ? chr($2)
+ : defined $Pod::Escapes::Name2character_number{$1}
+ ? chr($Pod::Escapes::Name2character_number{$1})
+ : do {
+ warn "Unknown escape: E<$1>";
+ "E<$1>";
+ };
+ }gex;
+ }
+ elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
+ # Pod::Text < 3.0 has yet another mapping table,
+ # though the table name of 2.x and 1.x are different.
+ # (1.x is in core of Perl < 5.6, 2.x is in core of
+ # Perl < 5.9.3)
+ my $mapping = ($Pod::Text::VERSION < 2)
+ ? \%Pod::Text::HTML_Escapes
+ : \%Pod::Text::ESCAPES;
+ $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
+ {
+ defined $2
+ ? chr($2)
+ : defined $mapping->{$1}
+ ? $mapping->{$1}
+ : do {
+ warn "Unknown escape: E<$1>";
+ "E<$1>";
+ };
+ }gex;
+ }
+ else {
+ $author =~ s{E<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ }
$self->author($author);
} else {
warn "Cannot determine author info from $_[0]\n";
}
}
-sub license_from {
+#Stolen from M::B
+my %license_urls = (
+ perl => 'http://dev.perl.org/licenses/',
+ apache => 'http://apache.org/licenses/LICENSE-2.0',
+ apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
+ artistic => 'http://opensource.org/licenses/artistic-license.php',
+ artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
+ lgpl => 'http://opensource.org/licenses/lgpl-license.php',
+ lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
+ lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
+ bsd => 'http://opensource.org/licenses/bsd-license.php',
+ gpl => 'http://opensource.org/licenses/gpl-license.php',
+ gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
+ gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
+ mit => 'http://opensource.org/licenses/mit-license.php',
+ mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
+ open_source => undef,
+ unrestricted => undef,
+ restrictive => undef,
+ unknown => undef,
+);
+
+sub license {
my $self = shift;
- if (
- Module::Install::_read($_[0]) =~ m/
- (
- =head \d \s+
- (?:licen[cs]e|licensing|copyright|legal)\b
- .*?
- )
- (=head\\d.*|=cut.*|)
- \z
- /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,
- );
- while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
- $pattern =~ s{\s+}{\\s+}g;
- if ( $license_text =~ /\b$pattern\b/i ) {
- $self->license($license);
- return 1;
- }
+ return $self->{values}->{license} unless @_;
+ my $license = shift or die(
+ 'Did not provide a value to license()'
+ );
+ $license = __extract_license($license) || lc $license;
+ $self->{values}->{license} = $license;
+
+ # Automatically fill in license URLs
+ if ( $license_urls{$license} ) {
+ $self->resources( license => $license_urls{$license} );
+ }
+
+ return 1;
+}
+
+sub _extract_license {
+ my $pod = shift;
+ my $matched;
+ return __extract_license(
+ ($matched) = $pod =~ m/
+ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?)
+ (=head \d.*|=cut.*|)\z
+ /xms
+ ) || __extract_license(
+ ($matched) = $pod =~ m/
+ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?)
+ (=head \d.*|=cut.*|)\z
+ /xms
+ );
+}
+
+sub __extract_license {
+ my $license_text = shift or return;
+ my @phrases = (
+ '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1,
+ '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
+ 'Artistic and GPL' => '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,
+ 'GNU Free Documentation license' => 'unrestricted', 1,
+ 'GNU Affero General Public License' => 'open_source', 1,
+ '(?:Free)?BSD license' => 'bsd', 1,
+ 'Artistic license 2\.0' => 'artistic_2', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'Apache (?:Software )?license' => 'apache', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 1,
+ 'Mozilla Public License' => 'mozilla', 1,
+ 'Q Public License' => 'open_source', 1,
+ 'OpenSSL License' => 'unrestricted', 1,
+ 'SSLeay License' => 'unrestricted', 1,
+ 'zlib License' => 'open_source', 1,
+ 'proprietary' => 'proprietary', 0,
+ );
+ while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
+ $pattern =~ s#\s+#\\s+#gs;
+ if ( $license_text =~ /\b$pattern\b/i ) {
+ return $license;
}
}
+ return '';
+}
- warn "Cannot determine license info from $_[0]\n";
- return 'unknown';
+sub license_from {
+ my $self = shift;
+ if (my $license=_extract_license(Module::Install::_read($_[0]))) {
+ $self->license($license);
+ } else {
+ warn "Cannot determine license info from $_[0]\n";
+ return 'unknown';
+ }
}
sub _extract_bugtracker {
- my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g;
+ my @links = $_[0] =~ m#L<(
+ https?\Q://rt.cpan.org/\E[^>]+|
+ https?\Q://github.com/\E[\w_]+/[\w_]+/issues|
+ https?\Q://code.google.com/p/\E[\w_\-]+/issues/list
+ )>#gx;
my %links;
@links{@links}=();
@links=keys %links;
@@ -486,7 +576,7 @@ sub bugtracker_from {
return 0;
}
if ( @links > 1 ) {
- warn "Found more than on rt.cpan.org link in $_[0]\n";
+ warn "Found more than one bugtracker link in $_[0]\n";
return 0;
}
@@ -498,7 +588,7 @@ sub bugtracker_from {
sub requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
- my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
+ my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
@@ -506,6 +596,17 @@ 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)
@@ -516,33 +617,76 @@ sub _perl_version {
$v =~ s/(\.\d\d\d)000$/$1/;
$v =~ s/_.+$//;
if ( ref($v) ) {
- $v = $v + 0; # Numify
+ # Numify
+ $v = $v + 0;
}
return $v;
}
-
-
+sub add_metadata {
+ my $self = shift;
+ my %hash = @_;
+ for my $key (keys %hash) {
+ warn "add_metadata: $key is not prefixed with 'x_'.\n" .
+ "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
+ $self->{values}->{$key} = $hash{$key};
+ }
+}
######################################################################
-# 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 +702,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 +716,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/RTx.pm b/inc/Module/Install/RTx.pm
index 20a354b..73b9cda 100644
--- a/inc/Module/Install/RTx.pm
+++ b/inc/Module/Install/RTx.pm
@@ -8,7 +8,7 @@ no warnings 'once';
use Module::Install::Base;
use base 'Module::Install::Base';
-our $VERSION = '0.24';
+our $VERSION = '0.29';
use FindBin;
use File::Glob ();
@@ -42,15 +42,16 @@ sub RTx {
$INC{'RT.pm'} = "$RT::LocalPath/lib/RT.pm";
} else {
local @INC = (
- @INC,
$ENV{RTHOME} ? ( $ENV{RTHOME}, "$ENV{RTHOME}/lib" ) : (),
- map { ( "$_/rt3/lib", "$_/lib/rt3", "$_/lib" ) } grep $_,
- @prefixes
+ @INC,
+ map { ( "$_/rt4/lib", "$_/lib/rt4", "$_/rt3/lib", "$_/lib/rt3", "$_/lib" )
+ } grep $_, @prefixes
);
until ( eval { require RT; $RT::LocalPath } ) {
warn
"Cannot find the location of RT.pm that defines \$RT::LocalPath in: @INC\n";
- $_ = $self->prompt("Path to your RT.pm:") or exit;
+ $_ = $self->prompt("Path to directory containing your RT.pm:") or exit;
+ $_ =~ s/\/RT\.pm$//;
push @INC, $_, "$_/rt3/lib", "$_/lib/rt3", "$_/lib";
}
}
@@ -59,6 +60,7 @@ sub RTx {
my $local_lib_path = "$RT::LocalPath/lib";
print "Using RT configuration from $INC{'RT.pm'}:\n";
unshift @INC, "$RT::LocalPath/lib" if $RT::LocalPath;
+ unshift @INC, $lib_path;
$RT::LocalVarPath ||= $RT::VarPath;
$RT::LocalPoPath ||= $RT::LocalLexiconPath;
@@ -184,8 +186,46 @@ sub RTxInit {
die "Cannot load RT" unless $RT::Handle and $RT::DatabaseType;
}
+# stolen from RT::Handle so we work on 3.6 (cmp_versions came in with 3.8)
+{ my %word = (
+ a => -4,
+ alpha => -4,
+ b => -3,
+ beta => -3,
+ pre => -2,
+ rc => -1,
+ head => 9999,
+);
+sub cmp_version($$) {
+ my ($a, $b) = (@_);
+ my @a = grep defined, map { /^[0-9]+$/? $_ : /^[a-zA-Z]+$/? $word{$_}|| -10 : undef }
+ split /([^0-9]+)/, $a;
+ my @b = grep defined, map { /^[0-9]+$/? $_ : /^[a-zA-Z]+$/? $word{$_}|| -10 : undef }
+ split /([^0-9]+)/, $b;
+ @a > @b
+ ? push @b, (0) x (@a- at b)
+ : push @a, (0) x (@b- at a);
+ for ( my $i = 0; $i < @a; $i++ ) {
+ return $a[$i] <=> $b[$i] if $a[$i] <=> $b[$i];
+ }
+ return 0;
+}}
+sub requires_rt {
+ my ($self,$version) = @_;
+
+ # if we're exactly the same version as what we want, silently return
+ return if ($version eq $RT::VERSION);
+
+ my @sorted = sort cmp_version $version,$RT::VERSION;
+
+ if ($sorted[-1] eq $version) {
+ # should we die?
+ warn "\nWarning: prerequisite RT $version not found. Your installed version of RT ($RT::VERSION) is too old.\n\n";
+ }
+}
+
1;
__END__
-#line 302
+#line 348
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index d91b287..22c409a 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.88';
- @ISA = qw{Module::Install::Base};
+ $VERSION = '1.05';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index e82f5d3..6cd27da 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.88';
+ $VERSION = '1.05';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -26,7 +26,10 @@ sub WriteAll {
$self->check_nmake if $args{check_nmake};
unless ( $self->makemaker_args->{PL_FILES} ) {
- $self->makemaker_args( PL_FILES => {} );
+ # XXX: This still may be a bit over-defensive...
+ unless ($self->makemaker(6.25)) {
+ $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
+ }
}
# Until ExtUtils::MakeMaker support MYMETA.yml, make sure
@@ -41,8 +44,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;
}
commit c69101bc2483016d27e2f67b27a1b08dcd47c217
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Feb 29 01:32:12 2012 +0400
upgrade M::I
diff --git a/META.yml b/META.yml
index a1f0e45..ba07b23 100644
--- a/META.yml
+++ b/META.yml
@@ -3,12 +3,13 @@ abstract: 'Service Level Agreements for RT'
author:
- 'Ruslan Zakirov <ruz at bestpractical.com>'
build_requires:
- ExtUtils::MakeMaker: 6.42
+ ExtUtils::MakeMaker: 6.59
Test::More: 0
configure_requires:
- ExtUtils::MakeMaker: 6.42
+ ExtUtils::MakeMaker: 6.59
distribution_type: module
-generated_by: 'Module::Install version 1.01'
+dynamic_config: 1
+generated_by: 'Module::Install version 1.05'
license: gpl2
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
diff --git a/inc/Module/AutoInstall.pm b/inc/Module/AutoInstall.pm
index 60b90ea..d516bae 100644
--- a/inc/Module/AutoInstall.pm
+++ b/inc/Module/AutoInstall.pm
@@ -3,11 +3,12 @@ package Module::AutoInstall;
use strict;
use Cwd ();
+use File::Spec ();
use ExtUtils::MakeMaker ();
use vars qw{$VERSION};
BEGIN {
- $VERSION = '1.03';
+ $VERSION = '1.05';
}
# special map on pre-defined feature sets
@@ -17,11 +18,14 @@ my %FeatureMap = (
);
# various lexical flags
-my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
+my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS );
my (
- $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps
+ $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps,
+ $UpgradeDeps
);
-my ( $PostambleActions, $PostambleUsed );
+my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps,
+ $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps,
+ $PostambleActionsListAllDeps, $PostambleUsed, $NoTest);
# See if it's a testing or non-interactive session
_accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN );
@@ -31,6 +35,10 @@ sub _accept_default {
$AcceptDefault = shift;
}
+sub _installdeps_target {
+ $InstallDepsTarget = shift;
+}
+
sub missing_modules {
return @Missing;
}
@@ -63,6 +71,11 @@ sub _init {
__PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
exit 0;
}
+ elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) {
+ $UpgradeDeps = 1;
+ __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
+ exit 0;
+ }
elsif ( $arg =~ /^--default(?:deps)?$/ ) {
$AcceptDefault = 1;
}
@@ -125,7 +138,7 @@ sub import {
# 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;
+ $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget;
while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
my ( @required, @tests, @skiptests );
@@ -175,7 +188,7 @@ sub import {
}
# XXX: check for conflicts and uninstalls(!) them.
- my $cur = _load($mod);
+ my $cur = _version_of($mod);
if (_version_cmp ($cur, $arg) >= 0)
{
print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
@@ -207,6 +220,7 @@ sub import {
$CheckOnly
or ($mandatory and $UnderCPAN)
or $AllDeps
+ or $InstallDepsTarget
or _prompt(
qq{==> Auto-install the }
. ( @required / 2 )
@@ -237,10 +251,17 @@ sub import {
}
}
- if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
+ if ( @Missing and not( $CheckOnly or $UnderCPAN) ) {
require Config;
- print
-"*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n";
+ my $make = $Config::Config{make};
+ if ($InstallDepsTarget) {
+ print
+"*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n";
+ }
+ else {
+ print
+"*** Dependencies will be installed the next time you type '$make'.\n";
+ }
# make an educated guess of whether we'll need root permission.
print " (You may need to do that as the 'root' user.)\n"
@@ -271,6 +292,10 @@ END_MESSAGE
sub _check_lock {
return unless @Missing or @_;
+ if ($ENV{PERL5_CPANM_IS_RUNNING}) {
+ return _running_under('cpanminus');
+ }
+
my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING};
if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
@@ -324,7 +349,7 @@ sub install {
while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
# grep out those already installed
- if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
+ if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
else {
@@ -332,6 +357,11 @@ sub install {
}
}
+ if ($UpgradeDeps) {
+ push @modules, @installed;
+ @installed = ();
+ }
+
return @installed unless @modules; # nothing to do
return @installed if _check_lock(); # defer to the CPAN shell
@@ -363,7 +393,7 @@ sub install {
# see if we have successfully installed them
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
- if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
+ if ( _version_cmp( _version_of($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
@@ -463,6 +493,11 @@ sub _cpanplus_config {
} else {
die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n";
}
+ push @config, 'prereqs', $value;
+ } elsif ( $key eq 'force' ) {
+ push @config, $key, $value;
+ } elsif ( $key eq 'notest' ) {
+ push @config, 'skiptest', $value;
} else {
die "*** Cannot convert option $key to CPANPLUS version.\n";
}
@@ -497,10 +532,14 @@ sub _install_cpan {
# set additional options
while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) {
( $args{$opt} = $arg, next )
- if $opt =~ /^force$/; # pseudo-option
+ if $opt =~ /^(?:force|notest)$/; # pseudo-option
$CPAN::Config->{$opt} = $arg;
}
+ if ($args{notest} && (not CPAN::Shell->can('notest'))) {
+ die "Your version of CPAN is too old to support the 'notest' pragma";
+ }
+
local $CPAN::Config->{prerequisites_policy} = 'follow';
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
@@ -519,8 +558,16 @@ sub _install_cpan {
delete $INC{$inc};
}
- my $rv = $args{force} ? CPAN::Shell->force( install => $pkg )
- : CPAN::Shell->install($pkg);
+ my $rv = do {
+ if ($args{force}) {
+ CPAN::Shell->force( install => $pkg )
+ } elsif ($args{notest}) {
+ CPAN::Shell->notest( install => $pkg )
+ } else {
+ CPAN::Shell->install($pkg)
+ }
+ };
+
$rv ||= eval {
$CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )
->{install}
@@ -575,7 +622,7 @@ sub _update_to {
my $ver = shift;
return
- if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade
+ if _version_cmp( _version_of($class), $ver ) >= 0; # no need to upgrade
if (
_prompt( "==> A newer version of $class ($ver) is required. Install?",
@@ -660,16 +707,30 @@ sub _can_write {
# load a module and return the version it reports
sub _load {
- my $mod = pop; # class/instance doesn't matter
+ my $mod = pop; # method/function doesn't matter
my $file = $mod;
-
$file =~ s|::|/|g;
$file .= '.pm';
-
local $@;
return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
}
+# report version without loading a module
+sub _version_of {
+ my $mod = pop; # method/function doesn't matter
+ my $file = $mod;
+ $file =~ s|::|/|g;
+ $file .= '.pm';
+ foreach my $dir ( @INC ) {
+ next if ref $dir;
+ my $path = File::Spec->catfile($dir, $file);
+ next unless -e $path;
+ require ExtUtils::MM_Unix;
+ return ExtUtils::MM_Unix->parse_version($path);
+ }
+ return undef;
+}
+
# Load CPAN.pm and it's configuration
sub _load_cpan {
return if $CPAN::VERSION and $CPAN::Config and not @_;
@@ -763,6 +824,35 @@ sub _make_args {
: "\$(NOECHO) \$(NOOP)"
);
+ my $deps_list = join( ',', @Missing, @Existing );
+
+ $PostambleActionsUpgradeDeps =
+ "\$(PERL) $0 --config=$config --upgradedeps=$deps_list";
+
+ my $config_notest =
+ join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}),
+ 'notest', 1 )
+ if $Config;
+
+ $PostambleActionsNoTest = (
+ ($missing and not $UnderCPAN)
+ ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing"
+ : "\$(NOECHO) \$(NOOP)"
+ );
+
+ $PostambleActionsUpgradeDepsNoTest =
+ "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list";
+
+ $PostambleActionsListDeps =
+ '@$(PERL) -le "print for @ARGV" '
+ . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing);
+
+ my @all = (@Missing, @Existing);
+
+ $PostambleActionsListAllDeps =
+ '@$(PERL) -le "print for @ARGV" '
+ . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all);
+
return %args;
}
@@ -797,11 +887,15 @@ sub Write {
sub postamble {
$PostambleUsed = 1;
+ my $fragment;
- return <<"END_MAKE";
+ $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget;
config :: installdeps
\t\$(NOECHO) \$(NOOP)
+AUTO_INSTALL
+
+ $fragment .= <<"END_MAKE";
checkdeps ::
\t\$(PERL) $0 --checkdeps
@@ -809,12 +903,28 @@ checkdeps ::
installdeps ::
\t$PostambleActions
+installdeps_notest ::
+\t$PostambleActionsNoTest
+
+upgradedeps ::
+\t$PostambleActionsUpgradeDeps
+
+upgradedeps_notest ::
+\t$PostambleActionsUpgradeDepsNoTest
+
+listdeps ::
+\t$PostambleActionsListDeps
+
+listalldeps ::
+\t$PostambleActionsListAllDeps
+
END_MAKE
+ return $fragment;
}
1;
__END__
-#line 1071
+#line 1193
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index 74caf9c..4508d97 100644
--- a/inc/Module/Install.pm
+++ b/inc/Module/Install.pm
@@ -31,7 +31,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 = '1.01';
+ $VERSION = '1.05';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -451,7 +451,7 @@ sub _version ($) {
}
sub _cmp ($$) {
- _version($_[0]) <=> _version($_[1]);
+ _version($_[1]) <=> _version($_[2]);
}
# Cloned from Params::Util::_CLASS
@@ -467,4 +467,4 @@ sub _CLASS ($) {
1;
-# Copyright 2008 - 2011 Adam Kennedy.
+# Copyright 2008 - 2012 Adam Kennedy.
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
index bc3d172..405f161 100644
--- a/inc/Module/Install/AutoInstall.pm
+++ b/inc/Module/Install/AutoInstall.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.05';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -73,6 +73,17 @@ sub auto_install {
);
}
+sub installdeps_target {
+ my ($self, @args) = @_;
+
+ $self->include('Module::AutoInstall');
+ require Module::AutoInstall;
+
+ Module::AutoInstall::_installdeps_target(1);
+
+ $self->auto_install(@args);
+}
+
sub auto_install_now {
my $self = shift;
$self->auto_install(@_);
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index d3662c9..683088b 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 = '1.01';
+ $VERSION = '1.05';
}
# Suspend handler for "redefined" warnings
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index 276409a..79932c5 100644
--- a/inc/Module/Install/Can.pm
+++ b/inc/Module/Install/Can.pm
@@ -9,7 +9,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.05';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index 093cb7a..085a253 100644
--- a/inc/Module/Install/Fetch.pm
+++ b/inc/Module/Install/Fetch.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.05';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
index 90cc979..2dd69c9 100644
--- a/inc/Module/Install/Include.pm
+++ b/inc/Module/Install/Include.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.05';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index 4c71003..c3cbb2b 100644
--- a/inc/Module/Install/Makefile.pm
+++ b/inc/Module/Install/Makefile.pm
@@ -8,7 +8,7 @@ use Fcntl qw/:flock :seek/;
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.05';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -215,18 +215,22 @@ sub write {
require ExtUtils::MakeMaker;
if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
- # MakeMaker can complain about module versions that include
- # an underscore, even though its own version may contain one!
- # Hence the funny regexp to get rid of it. See RT #35800
- # for details.
- my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
- $self->build_requires( 'ExtUtils::MakeMaker' => $v );
- $self->configure_requires( 'ExtUtils::MakeMaker' => $v );
+ # This previous attempted to inherit the version of
+ # ExtUtils::MakeMaker in use by the module author, but this
+ # was found to be untenable as some authors build releases
+ # using future dev versions of EU:MM that nobody else has.
+ # Instead, #toolchain suggests we use 6.59 which is the most
+ # stable version on CPAN at time of writing and is, to quote
+ # ribasushi, "not terminally fucked, > and tested enough".
+ # TODO: We will now need to maintain this over time to push
+ # the version up as new versions are released.
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 );
} else {
# Allow legacy-compatibility with 5.005 by depending on the
# most recent EU:MM that supported 5.005.
- $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
- $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 );
}
# Generate the MakeMaker params
@@ -241,7 +245,6 @@ in a module, and provide its file path via 'version_from' (or
'all_from' if you prefer) in Makefile.PL.
EOT
- $DB::single = 1;
if ( $self->tests ) {
my @tests = split ' ', $self->tests;
my %seen;
@@ -412,4 +415,4 @@ sub postamble {
__END__
-#line 541
+#line 544
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index 3b01e09..c863124 100644
--- a/inc/Module/Install/Metadata.pm
+++ b/inc/Module/Install/Metadata.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.05';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -151,15 +151,21 @@ sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub dynamic_config {
- my $self = shift;
- unless ( @_ ) {
- warn "You MUST provide an explicit true/false value to dynamic_config\n";
- return $self;
+ my $self = shift;
+ my $value = @_ ? shift : 1;
+ if ( $self->{values}->{dynamic_config} ) {
+ # Once dynamic we never change to static, for safety
+ return 0;
}
- $self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
+ $self->{values}->{dynamic_config} = $value ? 1 : 0;
return 1;
}
+# Convenience command
+sub static_config {
+ shift->dynamic_config(0);
+}
+
sub perl_version {
my $self = shift;
return $self->{values}->{perl_version} unless @_;
@@ -170,7 +176,7 @@ sub perl_version {
# Normalize the version
$version = $self->_perl_version($version);
- # We don't support the reall old versions
+ # We don't support the really old versions
unless ( $version >= 5.005 ) {
die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
}
@@ -582,7 +588,7 @@ sub bugtracker_from {
sub requires_from {
my $self = shift;
my $content = Module::Install::_readperl($_[0]);
- my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
+ my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg;
while ( @requires ) {
my $module = shift @requires;
my $version = shift @requires;
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index 3139a63..22c409a 100644
--- a/inc/Module/Install/Win32.pm
+++ b/inc/Module/Install/Win32.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.05';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index 1f724a7..6cd27da 100644
--- a/inc/Module/Install/WriteAll.pm
+++ b/inc/Module/Install/WriteAll.pm
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '1.01';
+ $VERSION = '1.05';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
commit 829e21f62dd6eda2a524a4342fa2ce4ee88aae18
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Feb 29 01:32:45 2012 +0400
ignore MYMETA files
diff --git a/.gitignore b/.gitignore
index ef57f35..e1de4b0 100644
--- a/.gitignore
+++ b/.gitignore
@@ -6,3 +6,4 @@ pm_to_blib
blib/
t/tmp/
*.tar.gz
+MYMETA.*
commit a42c4542364c17db50af89fbedd7bcdb26e34e05
Merge: e50a053 829e21f
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Feb 29 01:37:25 2012 +0400
Merge branch 'master' into performance-stats
Conflicts:
MANIFEST
META.yml
lib/RT/Extension/SLA.pm
t/basics.t
diff --cc MANIFEST
index ad65521,62f670e..093a485
--- a/MANIFEST
+++ b/MANIFEST
@@@ -27,8 -23,7 +27,9 @@@ lib/RT/Condition/SLA_RequireDefault.p
lib/RT/Condition/SLA_RequireDueSet.pm
lib/RT/Condition/SLA_RequireStartsSet.pm
lib/RT/Extension/SLA.pm
+lib/RT/Extension/SLA/Report.pm
+ lib/RT/Extension/SLA/Test.pm
+lib/RT/Extension/SLA/Summary.pm
lib/RT/Queue_SLA.pm
Makefile.PL
MANIFEST This list of files
@@@ -37,6 -32,4 +38,5 @@@ t/basics.
t/business_hours.t
t/due.t
t/queue.t
+t/reporting/basic.t
t/starts.t
- t/utils.pl
diff --cc META.yml
index 7a3e577,ba07b23..f7f0230
--- a/META.yml
+++ b/META.yml
@@@ -26,4 -25,4 +26,4 @@@ requires
perl: 5.8.0
resources:
license: http://opensource.org/licenses/gpl-2.0.php
- version: 0.03_02
-version: 0.05
++version: 0.05_01
diff --cc lib/RT/Extension/SLA.pm
index e909e27,69cdb0e..b1d22c6
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@@ -4,7 -4,7 +4,7 @@@ use warnings
package RT::Extension::SLA;
- our $VERSION = '0.03_02';
-our $VERSION = '0.05';
++our $VERSION = '0.05_01';
=head1 NAME
diff --cc t/basics.t
index 08d6b46,f9e9ed7..e7eec96
--- a/t/basics.t
+++ b/t/basics.t
@@@ -3,11 -3,8 +3,10 @@@
use strict;
use warnings;
- use Test::More tests => 3;
-use RT::Extension::SLA::Test tests => 4, nodb => 1;
++use RT::Extension::SLA::Test tests => 6, nodb => 1;
use_ok 'RT::Extension::SLA';
+use_ok 'RT::Extension::SLA::Report';
+use_ok 'RT::Extension::SLA::Summary';
-
1;
commit 29fe4afa5f0360a181ea58ed56bd7cfb9bbe965e
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Feb 29 16:00:07 2012 +0400
subsitute vars in Test.pm, not in t/utils.pl
utils file is gone
diff --git a/Makefile.PL b/Makefile.PL
index 07119da..99c9689 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -21,7 +21,7 @@ substitute(
RT_BIN_PATH => $bin_path,
RT_SBIN_PATH => $sbin_path,
},
- qw(t/utils.pl),
+ qw(lib/RT/Extension/SLA/Test.pm),
);
WriteAll();
diff --git a/lib/RT/Extension/SLA/Test.pm b/lib/RT/Extension/SLA/Test.pm
index d28cf06..2ed3449 100644
--- a/lib/RT/Extension/SLA/Test.pm
+++ b/lib/RT/Extension/SLA/Test.pm
@@ -2,7 +2,7 @@ use strict;
use warnings;
### after: use lib qw(@RT_LIB_PATH@);
-use lib qw(/opt/rt3/local/lib /opt/rt3/lib);
+use lib qw(/opt/rt4/local/lib /opt/rt4/lib);
package RT::Extension::SLA::Test;
commit 7b866719b0177ba17679b97a9ae4af27a7c87e80
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Feb 29 16:01:06 2012 +0400
convert tests over Test.pm
diff --git a/t/reporting/basic.t b/t/reporting/basic.t
index 55befef..f152130 100644
--- a/t/reporting/basic.t
+++ b/t/reporting/basic.t
@@ -4,16 +4,8 @@ use strict;
use warnings;
use Test::MockTime qw(set_fixed_time);
-use Test::More tests => 72;
+use RT::Extension::SLA::Test tests => 6;
-require 't/utils.pl';
-
-use_ok 'RT';
-RT::LoadConfig();
-$RT::LogToScreen = $ENV{'TEST_VERBOSE'} ? 'debug': 'warning';
-RT::Init();
-
-use_ok 'RT::Ticket';
use_ok 'RT::Extension::SLA::Report';
my $root = RT::User->new( $RT::SystemUser );
commit 54ba321367ea3c2da470ce5ecd5b741c521f7d1a
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sat Mar 3 16:07:05 2012 +0400
rework SLA Reports
* port over 4.0 menu
* summary instead of detailed stats
* count replies by requestor, owner and other
* first response time stats
* response times stats for requestor, owner and other
* deadlines stats
diff --git a/html/Callbacks/RT-Extension-SLA/Elements/Tabs/Privileged b/html/Callbacks/RT-Extension-SLA/Elements/Tabs/Privileged
new file mode 100644
index 0000000..5bbcc46
--- /dev/null
+++ b/html/Callbacks/RT-Extension-SLA/Elements/Tabs/Privileged
@@ -0,0 +1,34 @@
+<%INIT>
+
+my $request_path = $HTML::Mason::Commands::r->path_info;
+
+if ( $request_path =~ m{^/Ticket/} ) {
+ if ( ( $m->request_args->{'id'} || '' ) =~ /^(\d+)$/ ) {
+ my $obj = RT::Ticket->new( $session{'CurrentUser'} );
+ $obj->Load($1);
+ return unless $obj->id;
+
+ return unless $obj->CurrentUserHasRight('SeeSLAReports');
+
+ PageMenu->child('actions')->child('sla_report' =>
+ path => "/Ticket/SLA.html?id=". $obj->id,
+ title => loc('SLA Report'),
+ );
+ }
+}
+
+#elsif ( $Query ||= $session{'CurrentSearchHash'}->{'Query'} ) {
+# $tabs->{"m"} = {
+# path => "Tools/Reports/SLA.html?". $m->comp( '/Elements/QueryString', Query => $Query ),
+# title => loc('Report SLA'),
+# };
+#}
+
+#return unless $session{'CurrentUser'}->PrincipalObj->HasRight(
+# Object => $RT::System, Right => 'SeeSLAReports',
+#);
+#$tabs->{'s'} = {
+# title => loc('Service Level Aggreements'),
+# path => 'Tools/Reports/SLA.html',
+#};
+</%INIT>
\ No newline at end of file
diff --git a/html/Callbacks/RT-Extension-SLA/Ticket/Elements/Tabs/Default b/html/Callbacks/RT-Extension-SLA/Ticket/Elements/Tabs/Default
deleted file mode 100644
index 76253a0..0000000
--- a/html/Callbacks/RT-Extension-SLA/Ticket/Elements/Tabs/Default
+++ /dev/null
@@ -1,24 +0,0 @@
-<%ARGS>
-$Query => undef
-$tabs => {}
-$Ticket => undef
-</%ARGS>
-<%INIT>
-
-return unless $session{'CurrentUser'}->PrincipalObj->HasRight(
- Object => $RT::System, Right => 'SeeSLAReports',
-);
-
-if ( $Ticket ) {
- $tabs->{'this'}->{"subtabs"}->{'_DA'} = {
- path => "Ticket/SLA.html?id=". $Ticket->id,
- title => loc('Report SLA'),
- };
-}
-elsif ( $Query ||= $session{'CurrentSearchHash'}->{'Query'} ) {
- $tabs->{"m"} = {
- path => "Tools/Reports/SLA.html?". $m->comp( '/Elements/QueryString', Query => $Query ),
- title => loc('Report SLA'),
- };
-}
-</%INIT>
diff --git a/html/Callbacks/RT-Extension-SLA/Tools/Reports/Elements/Tabs/Default b/html/Callbacks/RT-Extension-SLA/Tools/Reports/Elements/Tabs/Default
deleted file mode 100644
index d1f352c..0000000
--- a/html/Callbacks/RT-Extension-SLA/Tools/Reports/Elements/Tabs/Default
+++ /dev/null
@@ -1,12 +0,0 @@
-<%ARGS>
-$tabs => {}
-</%ARGS>
-<%INIT>
-return unless $session{'CurrentUser'}->PrincipalObj->HasRight(
- Object => $RT::System, Right => 'SeeSLAReports',
-);
-$tabs->{'s'} = {
- title => loc('Service Level Aggreements'),
- path => 'Tools/Reports/SLA.html',
-};
-</%INIT>
diff --git a/html/Elements/SLA/ShowReportSummary b/html/Elements/SLA/ShowReportSummary
new file mode 100644
index 0000000..f0e18ff
--- /dev/null
+++ b/html/Elements/SLA/ShowReportSummary
@@ -0,0 +1,114 @@
+<em>All replies by requestors, owners and other.</em>
+
+<table class="sla">
+<tbody>
+% foreach my $role (qw(requestor owner other)) {
+% my $v = $data->{'messages'}{ $role } or next;
+<tr><th><% loc($label{ $role }) %></th><td><% $v %></td></tr>
+% }
+</tbody>
+<tfoot>
+<tr><th><% loc($label{'*'}) %></th><td><% $data->{'messages'}{'*'} %></td></tr>
+</tfoot>
+</table>
+
+% if ( my $fr = $data->{'FirstResponse'} ) {
+<em>First response</em>
+% if ( $fr->{'count'} == 1 ) {
+<table class="sla"><tr><td><% $time_interval->( $fr->{'sum'} ) %></td></tr></table>
+% }
+% else {
+<table class="sla">
+<tbody>
+<tr><th><% loc('Min') %></th><td><% $time_interval->( $fr->{'min'} ) %></td></tr>
+<tr><th><% loc('Average') %></th><td><% $time_interval->( $fr->{'avg'} ) %></td></tr>
+<tr><th><% loc('Max') %></th><td><% $time_interval->( $fr->{'max'} ) %></td></tr>
+</tbody>
+</table>
+% }
+% }
+
+% if ( $data->{'Response'} ) {
+<em>Repsonse time to requestor and from requestor</em>
+<table class="sla">
+<thead>
+ <tr>
+ <th> </th>
+ <th><% loc('Count') %></th>
+ <th><% loc('Min') %></th>
+ <th><% loc('Average') %></th>
+ <th><% loc('Max') %></th>
+ <th><% loc('Sum') %></th>
+ </tr>
+</thead>
+<%PERL>
+my $render_row = sub {
+ my $role = shift;
+ my $data = shift;
+ my $res = '<tr>';
+ $res .= '<th>'. $eh->( loc( $label{ $role } ) ) .'</th>';
+ $res .= '<td>'. $eh->( $data->{'count'} ) .'</td>';
+ if ( $data->{'count'} > 1 ) {
+ foreach (qw(min avg max sum)) {
+ $res .= '<td>'. $eh->( $time_interval->( $data->{$_} ) ) .'</td>';
+ }
+ }
+ else {
+ $res .= '<td colspan="4">'. $eh->( $time_interval->( $data->{'sum'} ) ) .'</td>';
+ }
+ $res .= '</tr>';
+ return $res;
+};
+</%PERL>
+<tbody>
+% foreach my $role (qw(requestor owner other)) {
+% my $data = $data->{'Response'}{ $role } or next;
+<% $render_row->( $role, $data ) |n %>
+% }
+</tbody>
+% if ( my $totals = $data->{'Response'}{'*'} ) {
+<tfoot><% $render_row->( '*' => $totals ) |n %></tfoot>
+% }
+</table>
+% }
+
+% if ( my $dp = $data->{'deadlines'}{'passed'} ) {
+<em>Deadlines met</em>
+<table class="sla"><tr><td><% $dp %></td></tr></table>
+% }
+
+% if ( my $failed = $data->{'deadlines'}{'failed'} ) {
+<em>Missed deadlines</em>
+<table class="sla">
+<tbody>
+<tr><th><% loc('Count') %></th><td><% $failed->{'count'} %></td></tr>
+% if ( $failed->{'count'} > 1 ) {
+<tr><th><% loc('Min') %></th><td><% $time_interval->( $failed->{'min'} ) %></td></tr>
+<tr><th><% loc('Average') %></th><td><% $time_interval->( $failed->{'avg'} ) %></td></tr>
+<tr><th><% loc('Max') %></th><td><% $time_interval->( $failed->{'max'} ) %></td></tr>
+% }
+<tr><th><% loc('Sum') %></th><td><% $time_interval->( $failed->{'sum'} ) %></td></tr>
+</tbody>
+</table>
+% }
+
+<%ONCE>
+my $eh = sub { my $v = shift; RT::Interface::Web::EscapeUTF8( \$v ); return $v };
+my $time_interval = sub {
+ return RT::Date->new( $session{'CurrentUser'} )
+ ->DurationAsString( shift );
+};
+my %label = (
+ requestor => 'Requestors',
+ owner => 'Owners',
+ other => 'Other',
+ '*' => 'Total',
+);
+
+</%ONCE>
+<%ARGS>
+$Summary
+</%ARGS>
+<%INIT>
+my $data = $Summary->Result;
+</%INIT>
diff --git a/html/NoAuth/css/base/sla-table.css b/html/NoAuth/css/base/sla-table.css
new file mode 100644
index 0000000..cb51021
--- /dev/null
+++ b/html/NoAuth/css/base/sla-table.css
@@ -0,0 +1,29 @@
+table.sla {
+ max-width: 100%;
+ border-spacing: 0;
+ border-top: 1px solid #ddd;
+ border-right: 1px solid #ddd;
+ margin-bottom: 1em;
+ background: white;
+}
+table.sla th, table.sla td {
+ padding: 1em;
+ vertical-align: top;
+ border-left: 1px solid #ddd;
+ border-bottom: 1px solid #ddd;
+}
+table.sla td {
+ text-align: right;
+}
+table.sla tbody th, table.sla tfoot th {
+ text-align: right;
+}
+
+table.sla thead + tbody tr:first-child th,
+table.sla thead + tbody tr:first-child td,
+table.sla tbody + tbody tr:first-child th,
+table.sla tbody + tbody tr:first-child td,
+table.sla tbody + tfoot tr:first-child th,
+table.sla tbody + tfoot tr:first-child td {
+ border-top: 3px solid #ddd;
+}
diff --git a/html/Ticket/SLA.html b/html/Ticket/SLA.html
index 0cde6da..537510e 100644
--- a/html/Ticket/SLA.html
+++ b/html/Ticket/SLA.html
@@ -1,22 +1,9 @@
<& /Elements/Header, Title => $title &>
-<& /Ticket/Elements/Tabs,
- Ticket => $ticket,
- current_tab => "Ticket/SLA.html?id=$id",
- Title => $title,
-&>
+<& /Elements/Tabs &>
-<table>
-<tr><th>#</th><th>Description</th><th>Type</th><th>Owner</th><th>Failed</th><th>Shift</th></tr>
-% foreach my $stat ( @{ $report->Stats } ) {
-<tr>
-<td><% $stat->{transaction}->id %></td>
-<td><% $stat->{transaction}->Description %></td>
-<td><% $stat->{owner_act}? 'yes' : 'no' %></td>
-<td><% $stat->{failed}? 'yes' : 'no' %></td>
-<td><% $stat->{shift} %></td>
-</tr>
-% }
-</table>
+<&| /Widgets/TitleBox, title => loc('Summary') &>
+<& /Elements/SLA/ShowReportSummary, Summary => $summary &>
+</&>
<%ARGS>
$id => undef
@@ -40,7 +27,6 @@ $id = $ARGS{'id'} = $ticket->id;
my $title = loc("SLA performance on ticket #[_1]", $id);
use RT::Extension::SLA;
-my $report = RT::Extension::SLA->Report( $ticket );
-use Data::Dumper;
-$RT::Logger->crit( Dumper $report );
+my $report = RT::Extension::SLA->TicketReport( $ticket );
+my $summary = $report->Summary;
</%INIT>
diff --git a/html/Tools/Reports/SLA.html b/html/Tools/Reports/SLA.html
index ee2f6ae..038d06e 100644
--- a/html/Tools/Reports/SLA.html
+++ b/html/Tools/Reports/SLA.html
@@ -1,33 +1,24 @@
<& /Elements/Header, Title => $title &>
-<& /Tools/Reports/Elements/Tabs, current_tab => 'Tools/Reports/SLA.html', Title => $title &>
+<& /Elements/Tabs &>
+<&| /Widgets/TitleBox, title => loc('Summary') &>
+<form method="post" action="SLA.html">
<table>
-<tr>
-<th><% loc('Owner') %></th>
-% my @columns = $summary->Labels;
-% my $i = 0;
-% foreach ( map $_->[0], grep $i++%2, @columns ) {
-<th><% loc($_) %></th>
-% }
-</tr>
-
-% while ( my ($owner, $stats) = each %$result ) {
-% my $user = RT::User->new( $session{'CurrentUser'} );
-% $user->Load( $owner );
-<tr>
-<td><& /Elements/ShowUser, User => $user &></td>
-% my $i = 1;
-% foreach ( map $stats->{ $_ }, grep $i++%2, @columns ) {
-<td><% $_ || 0 %></td>
-% }
-</tr>
-% }
+ <tr>
+ <td class="label"><&|/l&>Query</&>:</td>
+ <td class="value"><textarea cols="60" rows="20" name="Query"><% $Query %></textarea></td>
+ </tr>
</table>
-<form method="post" action="SLA.html">
-<&|/l&>Query</&>:<textarea cols="60" rows="20" name="Query"><% $Query %></textarea>
-<& /Elements/Submit, Label => loc('Update report') &>
+<& /Elements/Submit, Label => loc('Update') &>
</form>
+</&>
+
+% if ( $summary ) {
+<&| /Widgets/TitleBox, title => loc('Summary') &>
+<& /Elements/SLA/ShowReportSummary, Summary => $summary &>
+</&>
+% }
<%ARGS>
$Query => undef
@@ -43,16 +34,16 @@ unless (
my $title = loc("Report on Service Level Agreements");
-use RT::Extension::SLA::Summary;
-my $summary = new RT::Extension::SLA::Summary;
-
-my $tickets = RT::Tickets->new( $session{'CurrentUser'} );
-$tickets->FromSQL( $Query );
-$tickets->OrderByCols( {FIELD => 'id', ORDER => 'ASC'} );
-while ( my $ticket = $tickets->Next ) {
- my $report = RT::Extension::SLA->Report( $ticket );
- $summary->AddReport( $report );
+my $summary;
+if ( $Query ) {
+ $summary = new RT::Extension::SLA::Summary;
+
+ my $tickets = RT::Tickets->new( $session{'CurrentUser'} );
+ $tickets->FromSQL( $Query );
+ $tickets->OrderByCols( {FIELD => 'id', ORDER => 'ASC'} );
+ while ( my $ticket = $tickets->Next ) {
+ $summary->AddReport( RT::Extension::SLA->TicketReport( $ticket ) );
+ }
+ $summary->Finalize;
}
-
-my $result = $summary->Result;
</%INIT>
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index b1d22c6..2b78673 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -3,9 +3,10 @@ use strict;
use warnings;
package RT::Extension::SLA;
-
our $VERSION = '0.05_01';
+use RT::Extension::SLA::Report;
+
=head1 NAME
RT::Extension::SLA - Service Level Agreements for RT
@@ -323,6 +324,8 @@ Just grant them ModifyCustomField right.
=cut
+push @{ scalar RT->Config->Get('CSSFiles') }, 'base/sla-table.css';
+
{
my $right = 'SeeSLAReports';
use RT::System;
@@ -398,6 +401,22 @@ sub Due {
return $res;
}
+sub SecondsBetween {
+ my $self = shift;
+ my %args = ( Level => undef, From => undef, To => undef, @_);
+ my ($from, $to) = @args{'From', 'To'};
+
+ my $sign = 1;
+ if ( $from > $to ) {
+ $sign = -1;
+ ($from, $to) = ($to, $from);
+ }
+
+ return $sign * ( $self->BusinessHours(
+ $RT::ServiceAgreements{'Levels'}{ $args{'Level'} }{'BusinessHours'}
+ )->between( $from, $to ) - 1 );
+}
+
sub Starts {
my $self = shift;
my %args = ( Level => undef, Time => undef, @_ );
@@ -450,7 +469,7 @@ sub GetDefaultServiceLevel {
return $RT::ServiceAgreements{'Default'};
}
-sub Report {
+sub TicketReport {
my $self = shift;
my $ticket = shift;
diff --git a/lib/RT/Extension/SLA/Report.pm b/lib/RT/Extension/SLA/Report.pm
index 94290cd..5ce96a8 100644
--- a/lib/RT/Extension/SLA/Report.pm
+++ b/lib/RT/Extension/SLA/Report.pm
@@ -13,7 +13,7 @@ sub new {
sub init {
my $self = shift;
my %args = (Ticket => undef, @_);
- $self->{'Ticket'} = $args{'Ticket'} || die "boo";
+ $self->{'Ticket'} = $args{'Ticket'} || die Carp::longmess( "boo" );
$self->{'State'} = {};
$self->{'Stats'} = [];
return $self;
@@ -23,11 +23,11 @@ sub Run {
my $self = shift;
my $txns = shift || $self->{'Ticket'}->Transactions;
- my $state = $self->State;
my $handler = $self->Handlers;
while ( my $txn = $txns->Next ) {
my ($type, $field) = ($txn->Type, $txn->Field);
+ $_ ||= '' foreach $type, $field;
my $h = $handler->{ $type };
unless ( $h ) {
@@ -41,19 +41,25 @@ sub Run {
$RT::Logger->debug( "Handling transaction #". $txn->id ." ($type, $field) of ticket #". $self->{'Ticket'}->id );
- $self->$h( Ticket => $self->{'Ticket'}, Transaction => $txn, State => $state );
+ $self->$h( Ticket => $self->{'Ticket'}, Transaction => $txn );
}
return $self;
}
sub State {
my $self = shift;
- return $self->{State};
+ return $self->{State} ||= {};
}
sub Stats {
my $self = shift;
- return $self->{Stats};
+ return $self->{Stats} ||= [];
+}
+
+sub Summary {
+ my $self = shift;
+ use RT::Extension::SLA::Summary;
+ return RT::Extension::SLA::Summary->new->AddReport( $self )->Finalize;
}
{ my $cache;
@@ -61,7 +67,7 @@ sub Handlers {
my $self = shift;
return $cache if $cache;
-
+
$cache = {
Create => 'OnCreate',
Set => {
@@ -78,9 +84,9 @@ sub Handlers {
sub OnCreate {
my $self = shift;
- my %args = ( Ticket => undef, Transaction => undef, State => undef, @_);
+ my %args = ( Ticket => undef, Transaction => undef, @_);
- my $state = $args{'State'};
+ my $state = $self->State;
%$state = ();
$state->{'level'} = $self->InitialServiceLevel( Ticket => $args{'Ticket'} );
$state->{'requestors'} = [ $self->InitialRequestors( Ticket => $args{'Ticket'} ) ];
@@ -90,9 +96,9 @@ sub OnCreate {
sub OnRequestorChange {
my $self = shift;
- my %args = ( Ticket => undef, Transaction => undef, State => undef, @_);
+ my %args = ( Ticket => undef, Transaction => undef, @_);
- my $requestors = $self->State->{'requestors'};
+ my $requestors = $self->State->{'requestors'} ||= [];
if ( $args{'Transaction'}->Type eq 'AddWatcher' ) {
push @$requestors, $args{'Transaction'}->NewValue;
}
@@ -104,89 +110,78 @@ sub OnRequestorChange {
sub OnServiceLevelChange {
my $self = shift;
- my %args = ( Ticket => undef, Transaction => undef, State => undef, @_);
+ my %args = ( Transaction => undef, @_);
$self->State->{'level'} = $args{'Transaction'}->NewValue;
}
sub OnResponse {
my $self = shift;
- my %args = ( Ticket => undef, Transaction => undef, State => undef, @_);
+ my %args = ( Transaction => undef, Create => 0, @_);
+ my $state = $self->State;
my $txn = $args{'Transaction'};
-# unless ( $args{'State'}->{'level'} ) {
-# $RT::Logger->debug('No service level -> ignore txn #'. $txn->id );
-# return;
-# }
-
- my $act = $args{'State'}->{'act'};
- if ( $self->IsRequestorsAct( $txn ) ) {
- if ( $act && $act->{'requestor'} ) {
- # several requestors' acts in a row don't move deadlines
- return;
- }
- $act ||= $args{'State'}->{'act'} = {};
-
- $act->{'requestor'} = 1;
- $act->{'acted'} = $txn->CreatedObj->Unix;
- } else {
- unless ( $act ) {
- $act = $args{'State'}->{'act'} = {};
- $act->{'requestor'} = 0;
- $act->{'acted'} = $txn->CreatedObj->Unix;
- return;
- }
- unless ( $act->{'requestor'} ) {
- # check keep in loop
- my $deadline = RT::Extension::SLA->Due(
- Type => 'KeepInLoop',
- Level => $args{'State'}->{'level'},
- Time => $args{'State'}->{'acted'},
- );
- unless ( defined $deadline ) {
- $RT::Logger->debug( "Multiple non-requestors replies in a raw, without keep in loop deadline");
- return;
+
+ my %stats = (
+ transaction => $txn->id,
+ owner => $state->{'owner'},
+ actor => $txn->Creator,
+ actor_role =>
+ $self->IsRequestorsAct( $txn ) ? 'requestor'
+ : $state->{'owner'} == $txn->Creator ? 'owner'
+ : 'other'
+ ,
+ acted_on => $txn->CreatedObj->Unix,
+ previous => $self->Stats->[-1],
+ );
+
+ unless ( $stats{'previous'} ) {
+ $stats{'type'} = 'Create';
+ }
+ elsif ( $stats{'actor_role'} eq 'requestor' ) {
+ if ( $stats{'previous'}{'actor_role'} eq 'requestor' ) {
+ $stats{'type'} = 'FollowUp';
+ $stats{'to'} = $stats{'previous'};
+ } else {
+ $stats{'type'} = 'Response';
+ my $tmp = $stats{'previous'};
+ while ( $tmp->{'previous'} && $tmp->{'previous'}{'actor_role'} ne 'requestor' ) {
+ $tmp = $tmp->{'previous'};
}
- # keep in loop
- my $failed = $txn->CreatedObj->Unix > $deadline? 1 : 0;
- my $owner = $args{'State'}->{'owner'} == $txn->Creator? 1 : 0;
- my $stat = {
- type => 'KeepInLoop',
- owner => $args{'State'}->{'owner'},
- failed => $failed,
- owner_act => $owner,
- transaction => $txn,
- actor => $txn->Creator,
- shift => $txn->CreatedObj->Unix - $deadline,
- };
- push @{ $self->Stats }, $stat;
+ $stats{'to'} = $tmp;
}
- else {
- # check response
- my $deadline = RT::Extension::SLA->Due(
- Type => 'Response',
- Level => $args{'State'}->{'level'},
- Time => $args{'State'}->{'act'}->{'acted'},
- );
- unless ( defined $deadline ) {
- $RT::Logger->debug( "Non-requestors' reply after requestors', without response deadline");
- return;
+ }
+ else {
+ if ( $stats{'previous'}{'actor_role'} ne 'requestor' ) {
+ $stats{'type'} = 'KeepInLoop';
+ $stats{'to'} = $stats{'previous'};
+ } else {
+ $stats{'type'} = 'Response';
+ my $tmp = $stats{'previous'};
+ while ( $tmp->{'previous'} && $tmp->{'previous'}{'actor_role'} eq 'requestor' ) {
+ $tmp = $tmp->{'previous'};
}
-
- # repsonse
- my $failed = $txn->CreatedObj->Unix > $deadline? 1 : 0;
- my $owner = $args{'State'}->{'owner'} == $txn->Creator? 1 : 0;
- my $stat = {
- type => 'Response',
- owner => $args{'State'}->{'owner'},
- failed => $failed,
- owner_act => $owner,
- transaction => $txn,
- actor => $txn->Creator,
- shift => ($txn->CreatedObj->Unix - $deadline),
- };
- push @{ $self->Stats }, $stat;
+ $stats{'to'} = $tmp;
}
+
+ $stats{'deadline'} = RT::Extension::SLA->Due(
+ Type => $stats{'type'},
+ Level => $state->{'level'},
+ Time => $stats{'to'}{'acted_on'},
+ );
+ $stats{'difference'} = RT::Extension::SLA->SecondsBetween(
+ Level => $state->{'level'},
+ From => $stats{'deadline'},
+ To => $stats{'acted_on'},
+ ) if defined $stats{'deadline'};
}
+
+ $stats{'time'} = RT::Extension::SLA->SecondsBetween(
+ Level => $state->{'level'},
+ From => $stats{'to'}{'acted_on'},
+ To => $stats{'acted_on'},
+ ) if $stats{'to'};
+
+ push @{ $self->Stats }, \%stats;
}
sub IsRequestorsAct {
@@ -197,10 +192,10 @@ sub IsRequestorsAct {
# owner is always treated as non-requestor
return 0 if $actor == $self->State->{'owner'};
- return 1 if grep $_ == $actor, @{ $self->State->{'requestors'} };
+ return 1 if grep $_ == $actor, @{ $self->State->{'requestors'} || [] };
# in case requestor is a group
- foreach my $id ( @{ $self->State->{'requestors'} } ){
+ foreach my $id ( @{ $self->State->{'requestors'} || [] } ){
my $cgm = RT::CachedGroupMember->new( $RT::SystemUser );
$cgm->LoadByCols( GroupId => $id, MemberId => $actor, Disabled => 0 );
return 1 if $cgm->id;
@@ -271,7 +266,8 @@ sub Transactions {
my $self = shift;
my %args = (Ticket => undef, Criteria => undef, Order => 'ASC', @_);
- my $txns = $args{'Ticket'}->Transactions;
+ my $txns = RT::Transactions->new( $args{'Ticket'}->CurrentUser );
+ $txns->LimitToTicket( $args{'Ticket'}->id );
my $clause = 'ByTypeAndField';
while ( my ($type, $field) = each %{ $args{'Criteria'} } ) {
diff --git a/lib/RT/Extension/SLA/Summary.pm b/lib/RT/Extension/SLA/Summary.pm
index a0dc52f..112f42a 100644
--- a/lib/RT/Extension/SLA/Summary.pm
+++ b/lib/RT/Extension/SLA/Summary.pm
@@ -20,61 +20,132 @@ sub Result {
return $self->{'Result'} ||= { };
}
-our @known_stats = (
- 'passed' => ['Passed', 'Replied before a deadline'],
- 'failed' => ['Failed', 'Replied after a deadline or not replied at all'],
- 'helped' => ['Helped', 'Helped another user to reach a deadline'],
- 'late help' => ['Helped (late)', 'Helped another user, however failed a deadline'],
- 'got help' => ['Got help', 'Got help from another user within a deadline'],
-);
-
-sub Labels {
- return @known_stats;
-}
-
sub AddReport {
my $self = shift;
my $report = shift;
my $new = $self->OnReport( $report );
+ return $self->MergeResults( $new ) if keys %{ $self->Result };
+ %{ $self->Result } = %$new;
+ return $self;
+}
- my $total = $self->Result;
- while ( my ($user, $stat) = each %$new ) {
- my $tmp = $total->{$user} ||= {};
- while ( my ($action, $count) = each %$stat ) {
- $tmp->{$action} += $count;
- }
- }
+sub Finalize {
+ my $self = shift;
+
+ my $res = $self->Result;
+ $res->{'messages'}{'*'} += $_ foreach values %{ $res->{'messages'} };
+
+ foreach my $type ( grep $res->{$_}, qw(KeepInLoop FollowUp Response) ) {
+ $self->MergeCountMinMaxSum( $_ => $res->{$type}{'*'} ||= {} )
+ foreach values %{ $res->{$type} };
+ $_->{'avg'} = $_->{'sum'}/$_->{'count'}
+ foreach grep $_->{'count'}, values %{ $res->{$type} };
+ }
+ foreach ( grep $_, $res->{'FirstResponse'}, $res->{'deadlines'}{'failed'} ) {
+ $_->{'avg'} = $_->{'sum'}/$_->{'count'};
+ }
return $self;
}
+# min, avg, max - initial response time
+# min, avg, max - response time
+# number of passed
+# number of failed
+# min, avg, max - past due time
+# responses by role
+
sub OnReport {
my $self = shift;
my $report = shift;
- my $res = {};
+ my %res;
foreach my $stat ( @{ $report->Stats } ) {
- if ( $stat->{'owner_act'} ) {
- my $owner = $res->{ $stat->{'owner'} } ||= { };
- if ( $stat->{'failed'} ) {
- $owner->{'failed'}++;
- } else {
- $owner->{'passed'}++;
+ $res{'messages'}{ $stat->{'actor_role'} }++;
+
+ $self->CountMinMaxSum(
+ $res{ $stat->{'type'} }{ $stat->{'actor_role'} } ||= {},
+ $stat->{'time'},
+ ) if $stat->{'time'};
+
+ if ( $stat->{'deadline'} ) {
+ if ( $stat->{'difference'} > 0 ) {
+ $self->CountMinMaxSum(
+ $res{'deadlines'}{'failed'} ||= {},
+ $stat->{'difference'},
+ );
}
- } else {
- my $owner = $res->{ $stat->{'owner'} } ||= { };
- my $actor = $res->{ $stat->{'actor'} } ||= { };
- if ( $stat->{'failed'} ) {
- $owner->{'failed'}++;
- $actor->{'late help'}++;
+ else {
+ $res{'deadlines'}{'passed'}++;
+ }
+ }
+ }
+
+ if ( $report->Stats->[0]{'actor_role'} eq 'requestor' ) {
+ my ($first_response) = (grep $_->{'actor_role'} ne 'requestor', @{ $report->Stats });
+ $self->CountMinMaxSum(
+ $res{'FirstResponse'} ||= {},
+ $first_response->{'time'},
+ ) if $first_response;
+ }
+
+ return \%res;
+}
+
+sub MergeResults {
+ my $self = shift;
+ my $src = shift;
+ my $dst = shift || $self->Result;
+
+
+ while ( my ($k, $v) = each %$src ) {
+ unless ( ref $v ) {
+ $dst->{$k} += $v;
+ }
+ elsif ( ref $v eq 'HASH' ) {
+ if ( exists $v->{'count'} ) {
+ $self->MergeCountMinMaxSum( $src, $dst );
+ $self->MergeResults(
+ { map { $_ => $v->{$_} } grep !/^(?:count|min|max|sum)$/, keys %$v },
+ $dst->{ $k }
+ );
} else {
- $owner->{'got help'}++;
- $actor->{'helped'}++;
+ $self->MergeResults( $v, $dst->{$k} );
}
}
+ else {
+ die "Don't know how to merge";
+ }
}
- return $res;
+ return $self;
+}
+
+sub CountMinMaxSum {
+ my $self = shift;
+ my $hash = shift || {};
+ my $value = shift;
+
+ $hash->{'count'}++;
+ $hash->{'min'} = $value if !defined $hash->{'min'} || $hash->{'min'} > $value;
+ $hash->{'max'} = $value if !defined $hash->{'max'} || $hash->{'max'} < $value;
+ $hash->{'sum'} += $value;
+ return $hash;
+}
+
+sub MergeCountMinMaxSum {
+ my $self = shift;
+ my $src = shift || {};
+ my $dst = shift;
+
+ $dst->{'count'} += $src->{'count'};
+ $dst->{'min'} = $src->{'min'}
+ if !defined $dst->{'min'} || $dst->{'min'} > $src->{'min'};
+ $dst->{'max'} = $src->{'max'}
+ if !defined $dst->{'max'} || $dst->{'max'} < $src->{'max'};
+ $dst->{'sum'} += $src->{'sum'};
+
+ return $self;
}
1;
diff --git a/t/basics.t b/t/basics.t
index e7eec96..2ab707b 100644
--- a/t/basics.t
+++ b/t/basics.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use RT::Extension::SLA::Test tests => 6, nodb => 1;
+use RT::Extension::SLA::Test tests => 3, nodb => 1;
use_ok 'RT::Extension::SLA';
use_ok 'RT::Extension::SLA::Report';
diff --git a/t/reporting/basic.t b/t/reporting/basic.t
index f152130..b4c3e8b 100644
--- a/t/reporting/basic.t
+++ b/t/reporting/basic.t
@@ -4,14 +4,18 @@ use strict;
use warnings;
use Test::MockTime qw(set_fixed_time);
-use RT::Extension::SLA::Test tests => 6;
+use RT::Extension::SLA::Test tests => 17;
use_ok 'RT::Extension::SLA::Report';
+use Data::Dumper;
+
my $root = RT::User->new( $RT::SystemUser );
$root->LoadByEmail('root at localhost');
ok $root->id, 'loaded root user';
+my $hour = 60*60;
+
diag '';
{
%RT::ServiceAgreements = (
@@ -29,8 +33,8 @@ diag '';
my $id;
{
my $ticket = RT::Ticket->new( $root );
- ($id) = $ticket->Create( Queue => 'General', Subject => 'xxx', Requestor => $root->id );
- ok $id, "created ticket #$id";
+ ($id, undef, my $msg) = $ticket->Create( Queue => 'General', Subject => 'xxx', Requestor => $root->id );
+ ok $id, "created ticket #$id" or diag "error: $msg";
is $ticket->FirstCustomFieldValue('SLA'), '2', 'default sla';
@@ -50,15 +54,56 @@ diag '';
my $ticket = RT::Ticket->new( $RT::SystemUser );
$ticket->Load( $id );
- my $report = RT::Extension::SLA::Report->new( Ticket => $ticket )->Run;
- is_deeply $report->Stats,
- [ {type => 'Response', owner => $RT::Nobody->id, owner_act => 0, failed => 0, shift => -3600 } ],
- 'correct stats'
- ;
+ test_ticket_report(
+ $ticket,
+ [
+ {
+ 'previous' => undef,
+ 'owner' => 6,
+ 'actor_role' => 'requestor',
+ 'transaction' => '24',
+ 'type' => 'Create',
+ 'acted_on' => 1241517600,
+ 'actor' => '12',
+ },
+ {
+ 'owner' => 6,
+ 'deadline' => 1241524800,
+ 'difference' => - $hour,
+ 'actor' => '1',
+ 'previous' => -1,
+ 'to' => -1,
+ 'time' => $hour,
+ 'actor_role' => 'other',
+ 'transaction' => '29',
+ 'type' => 'Response',
+ 'acted_on' => 1241521200
+ }
+ ],
+ {
+ 'messages' => { '*' => 2, 'other' => 1, 'requestor' => 1, },
+ 'Response' => {
+ 'other' => {
+ 'count' => 1,
+ 'min' => $hour, 'avg' => $hour, 'max' => $hour,
+ 'sum' => $hour,
+ },
+ '*' => {
+ 'count' => 1,
+ 'min' => $hour, 'avg' => $hour, 'max' => $hour,
+ 'sum' => $hour,
+ },
+ },
+ 'FirstResponse' => {
+ 'count' => 1,
+ 'min' => $hour, 'avg' => $hour, 'max' => $hour,
+ 'sum' => $hour,
+ },
+ 'deadlines' => { 'passed' => 1, failed => undef },
+ },
+ );
}
-
-diag '';
{
%RT::ServiceAgreements = (
Default => '2',
@@ -75,8 +120,8 @@ diag '';
my $id;
{
my $ticket = RT::Ticket->new( $root );
- ($id) = $ticket->Create( Queue => 'General', Subject => 'xxx', Requestor => $root->id );
- ok $id, "created ticket #$id";
+ ($id, undef, my $msg) = $ticket->Create( Queue => 'General', Subject => 'xxx', Requestor => $root->id );
+ ok $id, "created ticket #$id" or diag "error: $msg";
is $ticket->FirstCustomFieldValue('SLA'), '2', 'default sla';
@@ -84,7 +129,7 @@ diag '';
is $due, $time + 2*60*60, 'Due date is two hours from "now"';
}
- set_fixed_time('2009-05-05T11:00:00Z');
+ set_fixed_time('2009-05-05T13:00:00Z');
# non-requestor reply
{
@@ -96,11 +141,75 @@ diag '';
my $ticket = RT::Ticket->new( $RT::SystemUser );
$ticket->Load( $id );
- my $report = RT::Extension::SLA::Report->new( Ticket => $ticket )->Run;
- is_deeply $report->Stats,
- [ {type => 'Response', owner => $RT::Nobody->id, owner_act => 0, failed => 0, shift => -3600 } ],
- 'correct stats'
- ;
+ test_ticket_report(
+ $ticket,
+ [
+ {
+ 'previous' => undef,
+ 'owner' => 6,
+ 'actor_role' => 'requestor',
+ 'transaction' => '37',
+ 'type' => 'Create',
+ 'acted_on' => 1241517600,
+ 'actor' => '12',
+ },
+ {
+ 'owner' => 6,
+ 'deadline' => 1241524800,
+ 'difference' => $hour,
+ 'actor' => '1',
+ 'previous' => -1,
+ 'to' => -1,
+ 'time' => 3*$hour,
+ 'actor_role' => 'other',
+ 'transaction' => '42',
+ 'type' => 'Response',
+ 'acted_on' => 1241528400,
+ }
+ ],
+ {
+ 'messages' => { '*' => 2, 'other' => 1, 'requestor' => 1, },
+ 'Response' => {
+ 'other' => {
+ 'count' => 1,
+ 'min' => 3*$hour, 'avg' => 3*$hour, 'max' => 3*$hour,
+ 'sum' => 3*$hour,
+ },
+ '*' => {
+ 'count' => 1,
+ 'min' => 3*$hour, 'avg' => 3*$hour, 'max' => 3*$hour,
+ 'sum' => 3*$hour,
+ },
+ },
+ 'FirstResponse' => {
+ 'count' => 1,
+ 'min' => 3*$hour, 'avg' => 3*$hour, 'max' => 3*$hour,
+ 'sum' => 3*$hour,
+ },
+ 'deadlines' => { failed => {
+ 'count' => 1,
+ 'min' => $hour, 'avg' => $hour, 'max' => $hour,
+ 'sum' => $hour,
+ } },
+ },
+ );
}
+sub test_ticket_report {
+ my ($ticket, $exp_report, $exp_summary) = @_;
+
+ for ( my $i = 0; $i < @$exp_report; $i++ ) {
+ foreach ( grep $exp_report->[$i]{$_}, qw(to previous) ) {
+ $exp_report->[$i]{$_} = $exp_report->[ $i + $exp_report->[$i]{$_} ];
+ }
+ }
+
+ my $report = RT::Extension::SLA::Report->new( Ticket => $ticket )->Run;
+ is_deeply( $report->Stats, $exp_report, 'correct stats' )
+ or diag Dumper( $report->Stats );
+
+ my $summary = $report->Summary;
+ is_deeply( $summary->Result, $exp_summary, 'correct summary' )
+ or diag Dumper( $summary->Result );
+}
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list