[Bps-public-commit] RT-Extension-SLA branch, master, updated. be4d67e034e19287764c3efae6abee1515845b6e
Ruslan Zakirov
ruz at bestpractical.com
Thu Jun 2 18:06:52 EDT 2011
The branch, master has been updated
via be4d67e034e19287764c3efae6abee1515845b6e (commit)
via 6521f63de54b5b4bd68bcc30972bb1fd7c84be3c (commit)
via 490c58f7e8ca0593207adb7999076b55077108bf (commit)
via d47b88ca97d5e6e378c86b7f9c0f45dc40c76a9d (commit)
via 289bfdd1d3885e74a8baee05f200133e780abb58 (commit)
via 03ccbb48e834f2977e9c1c80755070de101cba9b (commit)
from e2bd1d9ed9d626d8c7f2c9635ca7aa0a504a06e4 (commit)
Summary of changes:
.gitignore | 7 +
Changes | 4 +
MANIFEST | 7 -
META.yml | 5 +-
.../RT-Extension-SLA/Ticket/Elements/Tabs/Default | 24 --
.../Tools/Reports/Elements/Tabs/Default | 12 -
html/Ticket/SLA.html | 46 ---
html/Tools/Reports/SLA.html | 58 ----
inc/Module/AutoInstall.pm | 21 +-
inc/Module/Install.pm | 218 ++++++++-----
inc/Module/Install/AutoInstall.pm | 31 ++-
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 | 237 +++++++++++---
inc/Module/Install/Metadata.pm | 338 ++++++++++++++------
inc/Module/Install/RTx.pm | 52 +++-
inc/Module/Install/Win32.pm | 6 +-
inc/Module/Install/WriteAll.pm | 23 +-
lib/RT/Extension/SLA.pm | 53 +---
lib/RT/Extension/SLA/Report.pm | 323 -------------------
lib/RT/Extension/SLA/Summary.pm | 80 -----
t/basics.t | 4 +-
t/reporting/basic.t | 114 -------
25 files changed, 729 insertions(+), 1011 deletions(-)
create mode 100644 .gitignore
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
delete mode 100644 html/Ticket/SLA.html
delete mode 100644 html/Tools/Reports/SLA.html
delete mode 100644 lib/RT/Extension/SLA/Report.pm
delete mode 100644 lib/RT/Extension/SLA/Summary.pm
delete mode 100644 t/reporting/basic.t
- Log -----------------------------------------------------------------
commit 03ccbb48e834f2977e9c1c80755070de101cba9b
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri Jun 3 01:31:44 2011 +0400
Revert to version 0.03
diff --git a/MANIFEST b/MANIFEST
index ad65521..22c271a 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,9 +1,5 @@
Changes
etc/initialdata
-html/Callbacks/RT-Extension-SLA/Ticket/Elements/Tabs/Default
-html/Callbacks/RT-Extension-SLA/Tools/Reports/Elements/Tabs/Default
-html/Ticket/SLA.html
-html/Tools/Reports/SLA.html
inc/Module/AutoInstall.pm
inc/Module/Install.pm
inc/Module/Install/AutoInstall.pm
@@ -27,8 +23,6 @@ lib/RT/Condition/SLA_RequireDefault.pm
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/Summary.pm
lib/RT/Queue_SLA.pm
Makefile.PL
MANIFEST This list of files
@@ -37,6 +31,5 @@ t/basics.t
t/business_hours.t
t/due.t
t/queue.t
-t/reporting/basic.t
t/starts.t
t/utils.pl
diff --git a/META.yml b/META.yml
index a894f6d..c96930b 100644
--- a/META.yml
+++ b/META.yml
@@ -8,7 +8,7 @@ build_requires:
configure_requires:
ExtUtils::MakeMaker: 6.42
distribution_type: module
-generated_by: 'Module::Install version 0.88'
+generated_by: 'Module::Install version 0.85'
license: gpl2
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -17,7 +17,6 @@ name: RT-Extension-SLA
no_index:
directory:
- etc
- - html
- inc
- t
requires:
@@ -25,4 +24,4 @@ requires:
perl: 5.8.0
resources:
license: http://opensource.org/licenses/gpl-2.0.php
-version: 0.03_02
+version: 0.03
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/Ticket/SLA.html b/html/Ticket/SLA.html
deleted file mode 100644
index 0cde6da..0000000
--- a/html/Ticket/SLA.html
+++ /dev/null
@@ -1,46 +0,0 @@
-<& /Elements/Header, Title => $title &>
-<& /Ticket/Elements/Tabs,
- Ticket => $ticket,
- current_tab => "Ticket/SLA.html?id=$id",
- Title => $title,
-&>
-
-<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>
-
-<%ARGS>
-$id => undef
-</%ARGS>
-<%INIT>
-
-unless (
- $session{'CurrentUser'}->PrincipalObj->HasRight(
- Object => $RT::System, Right => 'SeeSLAReports',
- )
-) {
- Abort("You're not allowed to see SLA reports.");
-}
-
-my $ticket = LoadTicket($id);
-unless ($ticket->CurrentUserHasRight('ShowTicket')) {
- Abort("No permission to view ticket");
-}
-$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 );
-</%INIT>
diff --git a/html/Tools/Reports/SLA.html b/html/Tools/Reports/SLA.html
deleted file mode 100644
index ee2f6ae..0000000
--- a/html/Tools/Reports/SLA.html
+++ /dev/null
@@ -1,58 +0,0 @@
-<& /Elements/Header, Title => $title &>
-<& /Tools/Reports/Elements/Tabs, current_tab => 'Tools/Reports/SLA.html', Title => $title &>
-
-<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>
-% }
-</table>
-
-<form method="post" action="SLA.html">
-<&|/l&>Query</&>:<textarea cols="60" rows="20" name="Query"><% $Query %></textarea>
-<& /Elements/Submit, Label => loc('Update report') &>
-</form>
-
-<%ARGS>
-$Query => undef
-</%ARGS>
-<%INIT>
-unless (
- $session{'CurrentUser'}->PrincipalObj->HasRight(
- Object => $RT::System, Right => 'SeeSLAReports',
- )
-) {
- Abort("You're not allowed to see SLA reports.");
-}
-
-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 $result = $summary->Result;
-</%INIT>
diff --git a/inc/Module/AutoInstall.pm b/inc/Module/AutoInstall.pm
index 807fa7b..739bc85 100644
--- a/inc/Module/AutoInstall.pm
+++ b/inc/Module/AutoInstall.pm
@@ -18,9 +18,7 @@ my %FeatureMap = (
# various lexical flags
my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
-my (
- $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps
-);
+my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly );
my ( $PostambleActions, $PostambleUsed );
# See if it's a testing or non-interactive session
@@ -75,9 +73,6 @@ sub _init {
elsif ( $arg =~ /^--test(?:only)?$/ ) {
$TestOnly = 1;
}
- elsif ( $arg =~ /^--all(?:deps)?$/ ) {
- $AllDeps = 1;
- }
}
}
@@ -120,12 +115,7 @@ sub import {
)[0]
);
- # We want to know if we're under CPAN early to avoid prompting, but
- # if we aren't going to try and install anything anyway then skip the
- # check entirely since we don't want to have to load (and configure)
- # an old CPAN just for a cosmetic message
-
- $UnderCPAN = _check_lock(1) unless $SkipInstall;
+ $UnderCPAN = _check_lock(1); # check for $UnderCPAN
while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
my ( @required, @tests, @skiptests );
@@ -175,24 +165,15 @@ sub import {
}
# XXX: check for conflicts and uninstalls(!) them.
- my $cur = _load($mod);
- if (_version_cmp ($cur, $arg) >= 0)
+ if (
+ defined( my $cur = _version_check( _load($mod), $arg ||= 0 ) ) )
{
print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
push @Existing, $mod => $arg;
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
else {
- if (not defined $cur) # indeed missing
- {
- print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
- }
- else
- {
- # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above
- print "too old. ($cur < $arg)\n";
- }
-
+ print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
push @required, $mod => $arg;
}
}
@@ -206,7 +187,6 @@ sub import {
and (
$CheckOnly
or ($mandatory and $UnderCPAN)
- or $AllDeps
or _prompt(
qq{==> Auto-install the }
. ( @required / 2 )
@@ -255,38 +235,21 @@ sub import {
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
}
-sub _running_under {
- my $thing = shift;
- print <<"END_MESSAGE";
-*** Since we're running under ${thing}, I'll just let it take care
- of the dependency's installation later.
-END_MESSAGE
- return 1;
-}
-
# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
# if we are, then we simply let it taking care of our dependencies
sub _check_lock {
return unless @Missing or @_;
- my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING};
-
if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
- return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS');
- }
-
- require CPAN;
+ print <<'END_MESSAGE';
- if ($CPAN::VERSION > '1.89') {
- if ($cpan_env) {
- return _running_under('CPAN');
- }
- return; # CPAN.pm new enough, don't need to check further
+*** Since we're running under CPANPLUS, I'll just let it take care
+ of the dependency's installation later.
+END_MESSAGE
+ return 1;
}
- # last ditch attempt, this -will- configure CPAN, very sorry
-
- _load_cpan(1); # force initialize even though it's already loaded
+ _load_cpan();
# Find the CPAN lock-file
my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" );
@@ -322,7 +285,7 @@ sub install {
while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
# grep out those already installed
- if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
+ if ( defined( _version_check( _load($pkg), $ver ) ) ) {
push @installed, $pkg;
}
else {
@@ -361,7 +324,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 ( defined( _version_check( _load($pkg), $ver ) ) ) {
push @installed, $pkg;
}
elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
@@ -416,7 +379,7 @@ sub _install_cpanplus {
my $success;
my $obj = $modtree->{$pkg};
- if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) {
+ if ( $obj and defined( _version_check( $obj->{version}, $ver ) ) ) {
my $pathname = $pkg;
$pathname =~ s/::/\\W/;
@@ -509,7 +472,7 @@ sub _install_cpan {
my $obj = CPAN::Shell->expand( Module => $pkg );
my $success = 0;
- if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) {
+ if ( $obj and defined( _version_check( $obj->cpan_version, $ver ) ) ) {
my $pathname = $pkg;
$pathname =~ s/::/\\W/;
@@ -573,7 +536,7 @@ sub _update_to {
my $ver = shift;
return
- if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade
+ if defined( _version_check( _load($class), $ver ) ); # no need to upgrade
if (
_prompt( "==> A newer version of $class ($ver) is required. Install?",
@@ -670,7 +633,7 @@ sub _load {
# Load CPAN.pm and it's configuration
sub _load_cpan {
- return if $CPAN::VERSION and not @_;
+ return if $CPAN::VERSION;
require CPAN;
if ( $CPAN::HandleConfig::VERSION ) {
# Newer versions of CPAN have a HandleConfig module
@@ -682,11 +645,9 @@ sub _load_cpan {
}
# compare two versions, either use Sort::Versions or plain comparison
-# return values same as <=>
-sub _version_cmp {
+sub _version_check {
my ( $cur, $min ) = @_;
- return -1 unless defined $cur; # if 0 keep comparing
- return 1 unless $min;
+ return unless defined $cur;
$cur =~ s/\s+$//;
@@ -697,13 +658,16 @@ sub _version_cmp {
) {
# use version.pm if it is installed.
- return version->new($cur) <=> version->new($min);
+ return (
+ ( version->new($cur) >= version->new($min) ) ? $cur : undef );
}
elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) )
{
# use Sort::Versions as the sorting algorithm for a.b.c versions
- return Sort::Versions::versioncmp( $cur, $min );
+ return ( ( Sort::Versions::versioncmp( $cur, $min ) != -1 )
+ ? $cur
+ : undef );
}
warn "Cannot reliably compare non-decimal formatted versions.\n"
@@ -712,7 +676,7 @@ sub _version_cmp {
# plain comparison
local $^W = 0; # shuts off 'not numeric' bugs
- return $cur <=> $min;
+ return ( $cur >= $min ? $cur : undef );
}
# nothing; this usage is deprecated.
@@ -802,4 +766,4 @@ END_MAKE
__END__
-#line 1056
+#line 1004
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index d39e460..5b9ddbf 100644
--- a/inc/Module/Install.pm
+++ b/inc/Module/Install.pm
@@ -28,7 +28,7 @@ BEGIN {
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '0.88';
+ $VERSION = '0.85';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -353,7 +353,7 @@ sub _read {
if ( $] >= 5.006 ) {
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
} else {
- open( FH, "< $_[0]" ) or die "open($_[0]): $!";
+ open( FH, "< $_[0]" ) or die "open($_[0]): $!";
}
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
@@ -384,7 +384,7 @@ sub _write {
if ( $] >= 5.006 ) {
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
} else {
- open( FH, "> $_[0]" ) or die "open($_[0]): $!";
+ open( FH, "> $_[0]" ) or die "open($_[0]): $!";
}
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
index 32f1423..b7e92a5 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 $ISCORE @ISA};
BEGIN {
- $VERSION = '0.88';
+ $VERSION = '0.85';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index c08b3f0..ac416c9 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 = '0.85';
}
# Suspend handler for "redefined" warnings
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index fd64344..3e2d523 100644
--- a/inc/Module/Install/Can.pm
+++ b/inc/Module/Install/Can.pm
@@ -9,7 +9,7 @@ use ExtUtils::MakeMaker ();
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.88';
+ $VERSION = '0.85';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index e0acf6b..0a62208 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 $ISCORE @ISA};
BEGIN {
- $VERSION = '0.88';
+ $VERSION = '0.85';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
index 6324bd5..92aad58 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 $ISCORE @ISA};
BEGIN {
- $VERSION = '0.88';
+ $VERSION = '0.85';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index 3d10124..2b80f0f 100644
--- a/inc/Module/Install/Makefile.pm
+++ b/inc/Module/Install/Makefile.pm
@@ -7,7 +7,7 @@ use ExtUtils::MakeMaker ();
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.88';
+ $VERSION = '0.85';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index 6fd221f..ca16db7 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 = '0.88';
+ $VERSION = '0.85';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -511,7 +511,7 @@ sub requires_from {
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
my $v = $_[-1];
- $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
+ $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
$v =~ s/(\.\d\d\d)000$/$1/;
$v =~ s/_.+$//;
@@ -534,7 +534,7 @@ sub WriteMyMeta {
sub write_mymeta {
my $self = shift;
-
+
# If there's no existing META.yml there is nothing we can do
return unless -f 'META.yml';
@@ -574,7 +574,7 @@ sub write_mymeta {
# Save as the MYMETA.yml file
print "Writing MYMETA.yml\n";
- YAML::Tiny::DumpFile('MYMETA.yml', $meta);
+ YAML::Tiny::DumpFile('MYMETA.yml', $meta);
}
1;
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index d91b287..c00da94 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 = '0.88';
+ $VERSION = '0.85';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index e82f5d3..df3900a 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 = '0.88';
+ $VERSION = '0.85';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
diff --git a/lib/RT/Action/SLA.pm b/lib/RT/Action/SLA.pm
index fa12211..4991da0 100644
--- a/lib/RT/Action/SLA.pm
+++ b/lib/RT/Action/SLA.pm
@@ -4,7 +4,7 @@ use warnings;
package RT::Action::SLA;
-use base qw(RT::Extension::SLA RT::Action);
+use base qw(RT::Extension::SLA RT::Action::Generic);
=head1 NAME
diff --git a/lib/RT/Condition/SLA.pm b/lib/RT/Condition/SLA.pm
index cada30b..cb9f261 100644
--- a/lib/RT/Condition/SLA.pm
+++ b/lib/RT/Condition/SLA.pm
@@ -3,7 +3,7 @@ use strict;
use warnings;
package RT::Condition::SLA;
-use base qw(RT::Extension::SLA RT::Condition);
+use base qw(RT::Extension::SLA RT::Condition::Generic);
=head1 SLAIsApplied
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index e909e27..919365e 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -4,7 +4,7 @@ use warnings;
package RT::Extension::SLA;
-our $VERSION = '0.03_02';
+our $VERSION = '0.03';
=head1 NAME
@@ -14,14 +14,6 @@ RT::Extension::SLA - Service Level Agreements for RT
RT extension to implement automated due dates using service levels.
-=head1 UPGRADING
-
-On upgrade you shouldn't run 'make initdb'.
-
-If you were using 0.02 or older version of this extension with
-RT 3.8.1 then you have to uninstall that manually. List of files
-you can find in the MANIFEST.
-
=head1 INSTALL
=over 4
@@ -53,7 +45,7 @@ There is no WebUI in the current version. Almost everything is
controlled in the RT's config using option C<%RT::ServiceAgreements>
and C<%RT::ServiceBusinessHours>. For example:
- Set( %ServiceAgreements,
+ %RT::ServiceAgreements = (
Default => '4h',
QueueDefault => {
'Incident' => '2h',
@@ -256,7 +248,7 @@ of requests that came into the system during the last night.
In the config you can set one or more work schedules. Use the following
format:
- Set( %ServiceBusinessHours,
+ %RT::ServiceBusinessHours = (
'Default' => {
... description ...
},
@@ -282,7 +274,7 @@ hours.
then %RT::ServiceBusinessHours should have the corresponding definition:
- Set( %ServiceBusinessHours,
+ %RT::ServiceBusinessHours = (
'work just in Monday' => {
1 => { Name => 'Monday', Start => '9:00', End => '18:00' },
},
@@ -294,14 +286,14 @@ Default Business Hours setting is in $RT::ServiceBusinessHours{'Default'}.
In the config you can set per queue defaults, using:
- Set( %ServiceAgreements,
+ %RT::ServiceAgreements = (
Default => 'global default level of service',
QueueDefault => {
'queue name' => 'default value for this queue',
...
},
...
- );
+ };
=head2 Access control
@@ -316,14 +308,6 @@ Just grant them ModifyCustomField right.
=cut
-{
- my $right = 'SeeSLAReports';
- use RT::System;
- $RT::System::Rights->{$right} = 'See service level performance reports';
- use RT::ACE;
- $RT::ACE::LOWERCASERIGHTNAMES{ lc $right } = $right;
-}
-
sub BusinessHours {
my $self = shift;
my $name = shift || 'Default';
@@ -443,28 +427,7 @@ sub GetDefaultServiceLevel {
return $RT::ServiceAgreements{'Default'};
}
-sub Report {
- my $self = shift;
- my $ticket = shift;
-
- require RT::Extension::SLA::Report;
- return RT::Extension::SLA::Report->new( Ticket => $ticket )->Run;
-}
-
-=head1 TODO and CAVEATS
-
- * [not implemented] KeepInLoop and Response deadlines need adjusting. For example
- KeepInLoop is 2h and Response is 2h as well. Owner replies at point 0, deadline
- is 2h, at 1h requestor replies with anything -> deadline is moved according to
- response deadline to 3h when it must stay at 2h waiting for KeepInLoop follow up
- from owner and then move to another KeepInLoop deadline at 4h.
-
- * [not implemented] Manually entered Due date should be treated as Resolve deadline.
- We should store it and use later, so this module can be used for projects. For
- example: Response 4 hours, KeepInLoop 1 day, Resolve 5 b.days; these are defaults,
- but any manual change to Due date changes Resolve deadline.
-
- * [not implemented] WebUI
+=head1 TODO
* [implemented, TODO: tests for options in the config] default SLA for queues
@@ -474,21 +437,23 @@ sub Report {
something else). So people would be able to handle tickets in the right
order using Due dates.
+ * [not implemented] WebUI
+
=head1 DESIGN
=head2 Classes
Actions are subclasses of L<RT::Action::SLA> class that is subclass of
-L<RT::Extension::SLA> and L<RT::Action> classes.
+L<RT::Extension::SLA> and L<RT::Action::Generic> classes.
Conditions are subclasses of L<RT::Condition::SLA> class that is subclass of
-L<RT::Extension::SLA> and L<RT::Condition> classes.
+L<RT::Extension::SLA> and L<RT::Condition::Generic> classes.
L<RT::Extension::SLA> is a base class for all classes in the extension,
it provides access to config, generates L<Business::Hours> objects, and
other things useful for whole extension. As this class is the base for
all actions and conditions then we MUST avoid adding methods which overload
-methods in 'RT::{Condition,Action}' RT's modules.
+methods in 'RT::{Condition,Action}::Generic' RT's modules.
=head1 NOTES
diff --git a/lib/RT/Extension/SLA/Report.pm b/lib/RT/Extension/SLA/Report.pm
deleted file mode 100644
index 94290cd..0000000
--- a/lib/RT/Extension/SLA/Report.pm
+++ /dev/null
@@ -1,323 +0,0 @@
-use 5.8.0;
-use strict;
-use warnings;
-
-package RT::Extension::SLA::Report;
-
-sub new {
- my $proto = shift;
- my $self = bless {}, ref($proto)||$proto;
- return $self->init( @_ );
-}
-
-sub init {
- my $self = shift;
- my %args = (Ticket => undef, @_);
- $self->{'Ticket'} = $args{'Ticket'} || die "boo";
- $self->{'State'} = {};
- $self->{'Stats'} = [];
- return $self;
-}
-
-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);
-
- my $h = $handler->{ $type };
- unless ( $h ) {
- $RT::Logger->debug( "No handler for $type transaction, skipping" );
- } elsif ( ref $h ) {
- unless ( $h = $h->{ $field } ) {
- $RT::Logger->debug( "No handler for ($type, $field) transaction, skipping" );
- }
- }
- next unless $h;
-
- $RT::Logger->debug( "Handling transaction #". $txn->id ." ($type, $field) of ticket #". $self->{'Ticket'}->id );
-
- $self->$h( Ticket => $self->{'Ticket'}, Transaction => $txn, State => $state );
- }
- return $self;
-}
-
-sub State {
- my $self = shift;
- return $self->{State};
-}
-
-sub Stats {
- my $self = shift;
- return $self->{Stats};
-}
-
-{ my $cache;
-sub Handlers {
- my $self = shift;
-
- return $cache if $cache;
-
- $cache = {
- Create => 'OnCreate',
- Set => {
- Owner => 'OnOwnerChange',
- },
- Correspond => 'OnResponse',
- CustomField => { map { $_->id => 'OnServiceLevelChange' } $self->ServiceLevelCustomFields },
- AddWatcher => { Requestor => 'OnRequestorChange' },
- DelWatcher => { Requestor => 'OnRequestorChange' },
- };
-
- return $cache;
-} }
-
-sub OnCreate {
- my $self = shift;
- my %args = ( Ticket => undef, Transaction => undef, State => undef, @_);
-
- my $state = $args{'State'};
- %$state = ();
- $state->{'level'} = $self->InitialServiceLevel( Ticket => $args{'Ticket'} );
- $state->{'requestors'} = [ $self->InitialRequestors( Ticket => $args{'Ticket'} ) ];
- $state->{'owner'} = $self->InitialOwner( Ticket => $args{'Ticket'} );
- return $self->OnResponse( %args );
-}
-
-sub OnRequestorChange {
- my $self = shift;
- my %args = ( Ticket => undef, Transaction => undef, State => undef, @_);
-
- my $requestors = $self->State->{'requestors'};
- if ( $args{'Transaction'}->Type eq 'AddWatcher' ) {
- push @$requestors, $args{'Transaction'}->NewValue;
- }
- else {
- my $id = $args{'Transaction'}->OldValue;
- @$requestors = grep $_ != $id, @$requestors;
- }
-}
-
-sub OnServiceLevelChange {
- my $self = shift;
- my %args = ( Ticket => undef, Transaction => undef, State => undef, @_);
- $self->State->{'level'} = $args{'Transaction'}->NewValue;
-}
-
-sub OnResponse {
- my $self = shift;
- my %args = ( Ticket => undef, Transaction => undef, State => undef, @_);
-
- 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;
- }
- # 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;
- }
- 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;
- }
-
- # 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;
- }
- }
-}
-
-sub IsRequestorsAct {
- my $self = shift;
- my $txn = shift;
-
- my $actor = $txn->Creator;
-
- # owner is always treated as non-requestor
- return 0 if $actor == $self->State->{'owner'};
- return 1 if grep $_ == $actor, @{ $self->State->{'requestors'} };
-
- # in case requestor is a group
- 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;
- }
- return 0;
-}
-
-sub InitialServiceLevel {
- my $self = shift;
- my %args = @_;
-
- return $self->InitialValue(
- Ticket => $args{'Ticket'},
- Current => $args{'Ticket'}->FirstCustomFieldValue('SLA'),
- Criteria => { CustomField => [ map $_->id, $self->ServiceLevelCustomFields ] },
- );
-}
-
-sub InitialRequestors {
- my $self = shift;
- my %args = @_;
-
- my @current = map $_->MemberId, @{ $args{'Ticket'}->Requestors->MembersObj->ItemsArrayRef };
-
- my $txns = $self->Transactions(
- Ticket => $args{'Ticket'},
- Order => 'DESC',
- Criteria => { 'AddWatcher' => 'Requestor', DelWatcher => 'Requestor' },
- );
- while ( my $txn = $txns->Next ) {
- if ( $txn->Type eq 'AddWatcher' ) {
- my $id = $txn->NewValue;
- @current = grep $_ != $id, @current;
- }
- else {
- push @current, $txn->OldValue;
- }
- }
-
- return @current;
-}
-
-sub InitialOwner {
- my $self = shift;
- my %args = (Ticket => undef, @_);
- return $self->InitialValue(
- %args,
- Current => $args{'Ticket'}->Owner,
- Criteria => { 'Set', 'Owner' },
- );
-}
-
-sub InitialValue {
- my $self = shift;
- my %args = ( Ticket => undef, Current => undef, Criteria => {}, @_ );
-
- my $txns = $self->Transactions( %args );
- if ( my $first_change = $txns->First ) {
- # intial value is old value of the first change
- return $first_change->OldValue;
- }
-
- # no change -> initial value is the current
- return $args{'Current'};
-}
-
-sub Transactions {
- my $self = shift;
- my %args = (Ticket => undef, Criteria => undef, Order => 'ASC', @_);
-
- my $txns = $args{'Ticket'}->Transactions;
-
- my $clause = 'ByTypeAndField';
- while ( my ($type, $field) = each %{ $args{'Criteria'} } ) {
- $txns->_OpenParen( $clause );
- $txns->Limit(
- ENTRYAGGREGATOR => 'OR',
- SUBCLAUSE => $clause,
- FIELD => 'Type',
- VALUE => $type,
- );
- if ( $field ) {
- my $tmp = ref $field? $field : [$field];
- $txns->_OpenParen( $clause );
- my $first = 1;
- foreach my $value ( @$tmp ) {
- $txns->Limit(
- SUBCLAUSE => $clause,
- ENTRYAGGREGATOR => $first? 'AND' : 'OR',
- FIELD => 'Field',
- VALUE => $value,
- );
- $first = 0;
- }
- $txns->_CloseParen( $clause );
- }
- $txns->_CloseParen( $clause );
- }
- $txns->OrderByCols(
- { FIELD => 'Created', ORDER => $args{'Order'} },
- { FIELD => 'id', ORDER => $args{'Order'} },
- );
-
- return $txns;
-}
-
-{ my @cache = ();
-sub ServiceLevelCustomFields {
- my $self = shift;
- return @cache if @cache;
-
- my $cfs = RT::CustomFields->new( $RT::SystemUser );
- $cfs->Limit( FIELD => 'Name', VALUE => 'SLA' );
- $cfs->Limit( FIELD => 'LookupType', VALUE => RT::Ticket->CustomFieldLookupType );
- # XXX: limit to applied custom fields only
-
- return @cache = @{ $cfs->ItemsArrayRef };
-} }
-
-1;
diff --git a/lib/RT/Extension/SLA/Summary.pm b/lib/RT/Extension/SLA/Summary.pm
deleted file mode 100644
index a0dc52f..0000000
--- a/lib/RT/Extension/SLA/Summary.pm
+++ /dev/null
@@ -1,80 +0,0 @@
-use 5.8.0;
-use strict;
-use warnings;
-
-package RT::Extension::SLA::Summary;
-
-sub new {
- my $proto = shift;
- my $self = bless {}, ref($proto)||$proto;
- return $self->init( @_ );
-}
-
-sub init {
- my $self = shift;
- return $self;
-}
-
-sub Result {
- my $self = shift;
- 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 );
-
- my $total = $self->Result;
- while ( my ($user, $stat) = each %$new ) {
- my $tmp = $total->{$user} ||= {};
- while ( my ($action, $count) = each %$stat ) {
- $tmp->{$action} += $count;
- }
- }
-
- return $self;
-}
-
-sub OnReport {
- my $self = shift;
- my $report = shift;
-
- my $res = {};
- foreach my $stat ( @{ $report->Stats } ) {
- if ( $stat->{'owner_act'} ) {
- my $owner = $res->{ $stat->{'owner'} } ||= { };
- if ( $stat->{'failed'} ) {
- $owner->{'failed'}++;
- } else {
- $owner->{'passed'}++;
- }
- } else {
- my $owner = $res->{ $stat->{'owner'} } ||= { };
- my $actor = $res->{ $stat->{'actor'} } ||= { };
- if ( $stat->{'failed'} ) {
- $owner->{'failed'}++;
- $actor->{'late help'}++;
- } else {
- $owner->{'got help'}++;
- $actor->{'helped'}++;
- }
- }
- }
- return $res;
-}
-
-1;
diff --git a/t/basics.t b/t/basics.t
index 08d6b46..8d73e46 100644
--- a/t/basics.t
+++ b/t/basics.t
@@ -3,11 +3,9 @@
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More tests => 1;
use_ok 'RT::Extension::SLA';
-use_ok 'RT::Extension::SLA::Report';
-use_ok 'RT::Extension::SLA::Summary';
1;
diff --git a/t/reporting/basic.t b/t/reporting/basic.t
deleted file mode 100644
index 55befef..0000000
--- a/t/reporting/basic.t
+++ /dev/null
@@ -1,114 +0,0 @@
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-use Test::MockTime qw(set_fixed_time);
-
-use Test::More tests => 72;
-
-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 );
-$root->LoadByEmail('root at localhost');
-ok $root->id, 'loaded root user';
-
-diag '';
-{
- %RT::ServiceAgreements = (
- Default => '2',
- Levels => {
- '2' => { Response => { RealMinutes => 60*2 } },
- },
- );
-
- set_fixed_time('2009-05-05T10:00:00Z');
-
- my $time = time;
-
- # requestor creates
- my $id;
- {
- my $ticket = RT::Ticket->new( $root );
- ($id) = $ticket->Create( Queue => 'General', Subject => 'xxx', Requestor => $root->id );
- ok $id, "created ticket #$id";
-
- is $ticket->FirstCustomFieldValue('SLA'), '2', 'default sla';
-
- my $due = $ticket->DueObj->Unix;
- is $due, $time + 2*60*60, 'Due date is two hours from "now"';
- }
-
- set_fixed_time('2009-05-05T11:00:00Z');
-
- # non-requestor reply
- {
- my $ticket = RT::Ticket->new( $RT::SystemUser );
- $ticket->Load( $id );
- ok $ticket->id, "loaded ticket #$id";
- $ticket->Correspond( Content => 'we are working on this.' );
- }
-
- 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'
- ;
-}
-
-
-diag '';
-{
- %RT::ServiceAgreements = (
- Default => '2',
- Levels => {
- '2' => { Response => { RealMinutes => 60*2 } },
- },
- );
-
- set_fixed_time('2009-05-05T10:00:00Z');
-
- my $time = time;
-
- # requestor creates
- my $id;
- {
- my $ticket = RT::Ticket->new( $root );
- ($id) = $ticket->Create( Queue => 'General', Subject => 'xxx', Requestor => $root->id );
- ok $id, "created ticket #$id";
-
- is $ticket->FirstCustomFieldValue('SLA'), '2', 'default sla';
-
- my $due = $ticket->DueObj->Unix;
- is $due, $time + 2*60*60, 'Due date is two hours from "now"';
- }
-
- set_fixed_time('2009-05-05T11:00:00Z');
-
- # non-requestor reply
- {
- my $ticket = RT::Ticket->new( $RT::SystemUser );
- $ticket->Load( $id );
- ok $ticket->id, "loaded ticket #$id";
- $ticket->Correspond( Content => 'we are working on this.' );
- }
-
- 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'
- ;
-}
-
-
commit 289bfdd1d3885e74a8baee05f200133e780abb58
Author: sunnavy <sunnavy at bestpractical.com>
Date: Thu Apr 14 05:30:52 2011 +0000
::Generic is gone in rt4
diff --git a/lib/RT/Action/SLA.pm b/lib/RT/Action/SLA.pm
index 4991da0..fa12211 100644
--- a/lib/RT/Action/SLA.pm
+++ b/lib/RT/Action/SLA.pm
@@ -4,7 +4,7 @@ use warnings;
package RT::Action::SLA;
-use base qw(RT::Extension::SLA RT::Action::Generic);
+use base qw(RT::Extension::SLA RT::Action);
=head1 NAME
diff --git a/lib/RT/Condition/SLA.pm b/lib/RT/Condition/SLA.pm
index cb9f261..cada30b 100644
--- a/lib/RT/Condition/SLA.pm
+++ b/lib/RT/Condition/SLA.pm
@@ -3,7 +3,7 @@ use strict;
use warnings;
package RT::Condition::SLA;
-use base qw(RT::Extension::SLA RT::Condition::Generic);
+use base qw(RT::Extension::SLA RT::Condition);
=head1 SLAIsApplied
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 919365e..1b51c6b 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -444,16 +444,16 @@ sub GetDefaultServiceLevel {
=head2 Classes
Actions are subclasses of L<RT::Action::SLA> class that is subclass of
-L<RT::Extension::SLA> and L<RT::Action::Generic> classes.
+L<RT::Extension::SLA> and L<RT::Action> classes.
Conditions are subclasses of L<RT::Condition::SLA> class that is subclass of
-L<RT::Extension::SLA> and L<RT::Condition::Generic> classes.
+L<RT::Extension::SLA> and L<RT::Condition> classes.
L<RT::Extension::SLA> is a base class for all classes in the extension,
it provides access to config, generates L<Business::Hours> objects, and
other things useful for whole extension. As this class is the base for
all actions and conditions then we MUST avoid adding methods which overload
-methods in 'RT::{Condition,Action}::Generic' RT's modules.
+methods in 'RT::{Condition,Action}' RT's modules.
=head1 NOTES
commit d47b88ca97d5e6e378c86b7f9c0f45dc40c76a9d
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri Jun 3 01:53:47 2011 +0400
gitignore
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..210eea6
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,7 @@
+*.old
+*.bak
+*~
+Makefile
+pm_to_blib
+blib/
+
commit 490c58f7e8ca0593207adb7999076b55077108bf
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri Jun 3 01:57:49 2011 +0400
update M::I
diff --git a/META.yml b/META.yml
index c96930b..0e7173c 100644
--- a/META.yml
+++ b/META.yml
@@ -8,7 +8,7 @@ build_requires:
configure_requires:
ExtUtils::MakeMaker: 6.42
distribution_type: module
-generated_by: 'Module::Install version 0.85'
+generated_by: 'Module::Install version 1.01'
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 739bc85..60b90ea 100644
--- a/inc/Module/AutoInstall.pm
+++ b/inc/Module/AutoInstall.pm
@@ -18,7 +18,9 @@ my %FeatureMap = (
# various lexical flags
my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
-my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly );
+my (
+ $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps
+);
my ( $PostambleActions, $PostambleUsed );
# See if it's a testing or non-interactive session
@@ -73,6 +75,9 @@ sub _init {
elsif ( $arg =~ /^--test(?:only)?$/ ) {
$TestOnly = 1;
}
+ elsif ( $arg =~ /^--all(?:deps)?$/ ) {
+ $AllDeps = 1;
+ }
}
}
@@ -115,7 +120,12 @@ sub import {
)[0]
);
- $UnderCPAN = _check_lock(1); # check for $UnderCPAN
+ # We want to know if we're under CPAN early to avoid prompting, but
+ # if we aren't going to try and install anything anyway then skip the
+ # check entirely since we don't want to have to load (and configure)
+ # an old CPAN just for a cosmetic message
+
+ $UnderCPAN = _check_lock(1) unless $SkipInstall;
while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
my ( @required, @tests, @skiptests );
@@ -165,15 +175,24 @@ sub import {
}
# XXX: check for conflicts and uninstalls(!) them.
- if (
- defined( my $cur = _version_check( _load($mod), $arg ||= 0 ) ) )
+ my $cur = _load($mod);
+ if (_version_cmp ($cur, $arg) >= 0)
{
print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
push @Existing, $mod => $arg;
$DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
}
else {
- print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
+ if (not defined $cur) # indeed missing
+ {
+ print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
+ }
+ else
+ {
+ # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above
+ print "too old. ($cur < $arg)\n";
+ }
+
push @required, $mod => $arg;
}
}
@@ -187,6 +206,7 @@ sub import {
and (
$CheckOnly
or ($mandatory and $UnderCPAN)
+ or $AllDeps
or _prompt(
qq{==> Auto-install the }
. ( @required / 2 )
@@ -233,6 +253,17 @@ sub import {
# import to main::
no strict 'refs';
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
+
+ return (@Existing, @Missing);
+}
+
+sub _running_under {
+ my $thing = shift;
+ print <<"END_MESSAGE";
+*** Since we're running under ${thing}, I'll just let it take care
+ of the dependency's installation later.
+END_MESSAGE
+ return 1;
}
# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
@@ -240,16 +271,24 @@ sub import {
sub _check_lock {
return unless @Missing or @_;
+ my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING};
+
if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
- print <<'END_MESSAGE';
+ return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS');
+ }
-*** Since we're running under CPANPLUS, I'll just let it take care
- of the dependency's installation later.
-END_MESSAGE
- return 1;
+ require CPAN;
+
+ if ($CPAN::VERSION > '1.89') {
+ if ($cpan_env) {
+ return _running_under('CPAN');
+ }
+ return; # CPAN.pm new enough, don't need to check further
}
- _load_cpan();
+ # last ditch attempt, this -will- configure CPAN, very sorry
+
+ _load_cpan(1); # force initialize even though it's already loaded
# Find the CPAN lock-file
my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" );
@@ -285,7 +324,7 @@ sub install {
while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
# grep out those already installed
- if ( defined( _version_check( _load($pkg), $ver ) ) ) {
+ if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
else {
@@ -324,7 +363,7 @@ sub install {
# see if we have successfully installed them
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
- if ( defined( _version_check( _load($pkg), $ver ) ) ) {
+ if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
@@ -379,7 +418,7 @@ sub _install_cpanplus {
my $success;
my $obj = $modtree->{$pkg};
- if ( $obj and defined( _version_check( $obj->{version}, $ver ) ) ) {
+ if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) {
my $pathname = $pkg;
$pathname =~ s/::/\\W/;
@@ -472,7 +511,7 @@ sub _install_cpan {
my $obj = CPAN::Shell->expand( Module => $pkg );
my $success = 0;
- if ( $obj and defined( _version_check( $obj->cpan_version, $ver ) ) ) {
+ if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) {
my $pathname = $pkg;
$pathname =~ s/::/\\W/;
@@ -536,7 +575,7 @@ sub _update_to {
my $ver = shift;
return
- if defined( _version_check( _load($class), $ver ) ); # no need to upgrade
+ if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade
if (
_prompt( "==> A newer version of $class ($ver) is required. Install?",
@@ -633,9 +672,22 @@ sub _load {
# Load CPAN.pm and it's configuration
sub _load_cpan {
- return if $CPAN::VERSION;
+ return if $CPAN::VERSION and $CPAN::Config and not @_;
require CPAN;
- if ( $CPAN::HandleConfig::VERSION ) {
+
+ # 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 {
@@ -645,9 +697,11 @@ sub _load_cpan {
}
# compare two versions, either use Sort::Versions or plain comparison
-sub _version_check {
+# return values same as <=>
+sub _version_cmp {
my ( $cur, $min ) = @_;
- return unless defined $cur;
+ return -1 unless defined $cur; # if 0 keep comparing
+ return 1 unless $min;
$cur =~ s/\s+$//;
@@ -658,16 +712,13 @@ sub _version_check {
) {
# use version.pm if it is installed.
- return (
- ( version->new($cur) >= version->new($min) ) ? $cur : undef );
+ return version->new($cur) <=> version->new($min);
}
elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) )
{
# use Sort::Versions as the sorting algorithm for a.b.c versions
- return ( ( Sort::Versions::versioncmp( $cur, $min ) != -1 )
- ? $cur
- : undef );
+ return Sort::Versions::versioncmp( $cur, $min );
}
warn "Cannot reliably compare non-decimal formatted versions.\n"
@@ -676,7 +727,7 @@ sub _version_check {
# plain comparison
local $^W = 0; # shuts off 'not numeric' bugs
- return ( $cur >= $min ? $cur : undef );
+ return $cur <=> $min;
}
# nothing; this usage is deprecated.
@@ -766,4 +817,4 @@ END_MAKE
__END__
-#line 1004
+#line 1071
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index 5b9ddbf..74caf9c 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.85';
+ $VERSION = '1.01';
# 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).
@@ -427,4 +467,4 @@ sub _CLASS ($) {
1;
-# Copyright 2008 - 2009 Adam Kennedy.
+# Copyright 2008 - 2011 Adam Kennedy.
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
index b7e92a5..bc3d172 100644
--- a/inc/Module/Install/AutoInstall.pm
+++ b/inc/Module/Install/AutoInstall.pm
@@ -2,13 +2,13 @@
package Module::Install::AutoInstall;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '1.01';
+ @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);
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index ac416c9..d3662c9 100644
--- a/inc/Module/Install/Base.pm
+++ b/inc/Module/Install/Base.pm
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '1.01';
}
# 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 3e2d523..276409a 100644
--- a/inc/Module/Install/Can.pm
+++ b/inc/Module/Install/Can.pm
@@ -2,16 +2,16 @@
package Module::Install::Can;
use strict;
-use Module::Install::Base;
-use Config ();
-use File::Spec ();
-use ExtUtils::MakeMaker ();
+use Config ();
+use File::Spec ();
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '1.01';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
# check if we can load some module
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index 0a62208..093cb7a 100644
--- a/inc/Module/Install/Fetch.pm
+++ b/inc/Module/Install/Fetch.pm
@@ -2,13 +2,13 @@
package Module::Install::Fetch;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '1.01';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub get_file {
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
index 92aad58..90cc979 100644
--- a/inc/Module/Install/Include.pm
+++ b/inc/Module/Install/Include.pm
@@ -2,13 +2,13 @@
package Module::Install::Include;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '1.01';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub include {
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index 2b80f0f..4c71003 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.85';
+ $VERSION = '1.01';
+ @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 {
@@ -130,12 +219,13 @@ sub write {
# 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+)/ );
+ my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
+ $self->build_requires( 'ExtUtils::MakeMaker' => $v );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => $v );
} 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->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
}
@@ -143,59 +233,115 @@ sub write {
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
+
+ $DB::single = 1;
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 +365,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 +387,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 +412,4 @@ sub postamble {
__END__
-#line 394
+#line 541
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index ca16db7..3b01e09 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.85';
- @ISA = qw{Module::Install::Base};
+ $VERSION = '1.01';
+ @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 }
@@ -177,43 +178,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 +195,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 +207,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 +317,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 +330,7 @@ sub abstract_from {
{ DISTNAME => $self->name },
'ExtUtils::MM_Unix'
)->parse_abstract($file)
- );
+ );
}
# Add both distribution and module name
@@ -386,11 +355,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 +367,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 +396,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 +570,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;
}
@@ -506,43 +590,97 @@ sub requires_from {
}
}
+sub test_requires_from {
+ my $self = shift;
+ my $content = Module::Install::_readperl($_[0]);
+ my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
+ while ( @requires ) {
+ my $module = shift @requires;
+ my $version = shift @requires;
+ $self->test_requires( $module => $version );
+ }
+}
+
# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
my $v = $_[-1];
- $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
+ $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
$v =~ s/(\.\d\d\d)000$/$1/;
$v =~ s/_.+$//;
if ( ref($v) ) {
- $v = $v + 0; # Numify
+ # Numify
+ $v = $v + 0;
}
return $v;
}
-
-
+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 +696,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 +710,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 c00da94..3139a63 100644
--- a/inc/Module/Install/Win32.pm
+++ b/inc/Module/Install/Win32.pm
@@ -2,12 +2,12 @@
package Module::Install::Win32;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
- @ISA = qw{Module::Install::Base};
+ $VERSION = '1.01';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
}
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index df3900a..1f724a7 100644
--- a/inc/Module/Install/WriteAll.pm
+++ b/inc/Module/Install/WriteAll.pm
@@ -2,11 +2,11 @@
package Module::Install::WriteAll;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '1.01';
@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 6521f63de54b5b4bd68bcc30972bb1fd7c84be3c
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri Jun 3 02:02:43 2011 +0400
changelog
diff --git a/Changes b/Changes
index b111776..4fcd83d 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,7 @@
+0.04 Fri Jun 3 02:02:15 MSD 2011
+
+ * RT 4.0 compatibility fix
+
0.03 Mon Apr 20 23:25:03 +0400 2009
* Add KeepInLoop option
commit be4d67e034e19287764c3efae6abee1515845b6e
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri Jun 3 02:05:26 2011 +0400
bump version, 0.04
diff --git a/META.yml b/META.yml
index 0e7173c..b797e27 100644
--- a/META.yml
+++ b/META.yml
@@ -24,4 +24,4 @@ requires:
perl: 5.8.0
resources:
license: http://opensource.org/licenses/gpl-2.0.php
-version: 0.03
+version: 0.04
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 1b51c6b..2a0f8bd 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -4,7 +4,7 @@ use warnings;
package RT::Extension::SLA;
-our $VERSION = '0.03';
+our $VERSION = '0.04';
=head1 NAME
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list