[Bps-public-commit] RT-Extension-SLA branch, master, created. e2bd1d9ed9d626d8c7f2c9635ca7aa0a504a06e4
Ruslan Zakirov
ruz at bestpractical.com
Wed Apr 27 05:30:13 EDT 2011
The branch, master has been created
at e2bd1d9ed9d626d8c7f2c9635ca7aa0a504a06e4 (commit)
- Log -----------------------------------------------------------------
commit 71520c01a2b938c18abf9c377fa622196200f320
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue May 8 00:27:13 2007 +0000
Service Level Agreements extension for RT
commit 2d6f727e158f50bd7086bac274c04654c59cdd3a
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu May 10 21:54:05 2007 +0000
initial commit
diff --git a/lib/RT/Action/SLA.pm b/lib/RT/Action/SLA.pm
new file mode 100644
index 0000000..447d58e
--- /dev/null
+++ b/lib/RT/Action/SLA.pm
@@ -0,0 +1,11 @@
+
+use strict;
+use warnings;
+
+package RT::Action::SLA;
+
+sub SLA {
+
+}
+
+1;
diff --git a/lib/RT/Action/SLA/Set.pm b/lib/RT/Action/SLA/Set.pm
new file mode 100644
index 0000000..0b47a8d
--- /dev/null
+++ b/lib/RT/Action/SLA/Set.pm
@@ -0,0 +1,47 @@
+
+use strict;
+use warnings;
+
+package RT::Action::SLA::Set;
+
+use base qw(RT::Action::SLA);
+
+=head1 NAME
+
+RT::Action::SLA::Set - set default SLA value if it's not set
+
+=cut
+
+sub Prepare { return 1 }
+sub Commit {
+ my $self = shift;
+
+ return 1 if $self->TicketObj->FirstCustomFieldValue('SLA');
+
+ my $cf = RT::CustomField->new( $self->CurrentUser );
+ $cf->LoadByNameAndQueue( Queue => $self->TicketObj->Queue, Name => 'SLA' );
+ unless ( $cf->id ) {
+ $RT::Logger->warn("SLA scrip applied to a queue that has no SLA CF");
+ return 1;
+ }
+
+ my $SLAObj = $self->SLA;
+ my $sla = $SLAObj->SLA( $self->TransactionObj->CreatedObj->Unix );
+ unless ( $sla ) {
+ $RT::Logger->error("No default SLA for in hours or/and out of hours time");
+ return 0;
+ }
+
+ my ($status, $msg) = $self->TicketObj->AddCustomFieldValue(
+ Field => $cf->id,
+ Value => $sla,
+ );
+ unless ( $status ) {
+ $RT::Logger->error("Couldn't set SLA: $msg");
+ return 0;
+ }
+
+ return 1;
+};
+
+1;
diff --git a/lib/RT/Action/SLA/SetDue.pm b/lib/RT/Action/SLA/SetDue.pm
new file mode 100644
index 0000000..a491e20
--- /dev/null
+++ b/lib/RT/Action/SLA/SetDue.pm
@@ -0,0 +1,54 @@
+
+use strict;
+use warnings;
+
+package RT::Action::SLA::SetDue;
+
+use base qw(RT::Action::SLA);
+
+=head2 Prepare
+
+Checks if the ticket has service level defined.
+
+=cut
+
+sub Prepare {
+ my $self = shift;
+
+ unless ( $self->TicketObj->FirstCustomFieldValue('SLA') ) {
+ $RT::Logger->error('SLA::SetDue scrip has been applied to ticket #'
+ . $self->TicketObj->id . ' that has no SLA defined');
+ return 0;
+ }
+
+ return 1;
+}
+
+=head2 Commit
+
+Set the Due date accordingly to SLA.
+
+=cut
+
+sub Commit {
+ my $self = shift;
+
+ my $time = $self->TransactionObj->CreatedObj->Unix;
+
+ my $due = $SLAObj->Due( $time, $SLAObj->SLA( $time ) );
+
+ my $current_due = $self->TicketObj->DueObj->Unix;
+
+ if ( $current_due && $current_due > 0 && $current_due < $due ) {
+ $RT::Logger->debug("Ticket #". $self->TicketObj->id ." has due earlier than by SLA");
+ return 1;
+ }
+
+ my $date = RT::Date->new( $RT::SystemUser );
+ $date->Set( Format => 'unix', Value => $due );
+ $self->TicketObj->SetDue( $date->ISO );
+
+ return 1;
+}
+
+1;
diff --git a/lib/RT/Action/SLA/SetSLA.pm b/lib/RT/Action/SLA/SetSLA.pm
new file mode 100644
index 0000000..1489952
--- /dev/null
+++ b/lib/RT/Action/SLA/SetSLA.pm
@@ -0,0 +1,13 @@
+
+use strict;
+use warnings;
+
+package RT::Action::SLA::Set;
+
+sub Prepare {
+ return 1;
+}
+
+sub Commit {
+ return 1;
+}
diff --git a/lib/RT/Action/SLA/SetStarts.pm b/lib/RT/Action/SLA/SetStarts.pm
new file mode 100644
index 0000000..8899fcc
--- /dev/null
+++ b/lib/RT/Action/SLA/SetStarts.pm
@@ -0,0 +1,48 @@
+use strict;
+use warnings;
+
+package RT::Action::SLA::SetStarts;
+
+use base qw(RT::Action::SLA);
+
+=head2 Prepare
+
+Always run this action.
+
+=cut
+
+sub Prepare { return 1 }
+
+=head2 Commit
+
+Look up the SLA and set the Starts date accordingly unless it's allready set.
+
+=cut
+
+sub Commit {
+ my $self = shift;
+
+ my $ticket = $self->TicketObj;
+
+ # get out of here if have date set
+ return 1 $ticket->StartsObj->Unix > 0;
+
+ # XXX: we must use SLA to set starts
+ my $bizhours = RT::Estension::SLA::BusinessHours();
+
+ my $starts = $bizhours->first_after(
+ $self->TransactionObj->CreatedObj->Unix
+ );
+
+ my $date = RT::Date->new($RT::SystemUser);
+ $date->Set( Format => 'unix', Value => $starts );
+ my ($status, $msg) = $ticket->SetStarts( $date->ISO );
+ unless ( $status ) {
+ $RT::Logger->error("Couldn't set starts date: $msg");
+ return 0;
+ }
+
+ return 1;
+}
+
+1;
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
new file mode 100644
index 0000000..42a37ec
--- /dev/null
+++ b/lib/RT/Extension/SLA.pm
@@ -0,0 +1,93 @@
+use strict;
+use warnings;
+
+package RT::Extension::SLA;
+
+=head1 NAME
+
+RT::Extension::SLA - Service Level Agreements
+
+=head1 DESCRIPTION
+
+=head2 v0.01
+
+* we have one Business::Hours object
+* several agreement levels
+* options:
+** InHoursDefault - default service level ticket created during business hours, but only if level hasn't been set
+** OutOfHoursDefault - default service level ticket created during business hours, but only if level hasn't been set
+** Levels - each level has definition of agreements for Response and Resolve
+*** If you set a requirement for response then we set due date on create or as soon as user replies to some a in the feature, so due date means deadline for reply, as soon as somebody who is not a requestor replies we unset due
+*** if you set a requirement for resolve then we set due date on create to a point in the feature, so due date defines deadline for ticket resolving
+*** we should support situations when restrictions defined for reply and resolve, then we move due date according to reply deadlines, however when we reach resolve deadline we stop moving.
+
+*** each requirement is described by Business or Real time in terms of L<Business::SLA> module.
+
+so we'll have something like:
+%SLA => (
+ InHoursDefault => 'one real hour for reply',
+ OutOfHoursDefault => 'two business hours for reply',
+ Levels => {
+ 'one real hour for reply' => { Response => { RealMinutes => 60 } },
+ 'two business hours for reply' => { Response => { BusinessMinutes => 60*2 } },
+ '8 business hours for resolve' => { Resolve => { BusinessMinutes => 60*8 } },
+ 'two b-hours for reply and 3 real days for resolve' => {
+ Response => { BusinessMinutes => 60*2 },
+ Resolve => { RealMinutes => 60*24*3 },
+ },
+ },
+);
+
+=head v0.02
+
+* changing service levels of a ticket in the middle of its live
+
+=head random thoughts
+
+* Defining OutOfHours/InHours defaults sounds not that usefull for response deadlines as for resolve. For resolve I can find an example in real life: I order something in an online shop, the order comes into system when business day ended, so delivery(resolve) deadline is two business days, but in the case of in hours submission of the order they deliver during one business day. For reply deadlines I cannot imagine a situation when different InHours/OutOfHours levels are useful.
+
+
+=head v0.later
+
+* default SLA for queues
+* add support for multiple b-hours definitions, this could be very helpfull when you have 24/7 mixed with 8/5 and/or something like 8/5+4/2 for different tickets(by requestor, queue or something else). So people would be able to handle tickets in the right order using Due dates.
+
+=cut
+
+sub BusinessHours {
+ require Business::Hours;
+ return new Business::Hours;
+}
+
+sub SLA {
+ my %args = ( Type => 'Response', @_ );
+
+ my $class = $RT::SLA{'Module'} || 'Business::SLA';
+ eval "require $class" or die $@;
+ my $SLA = $class->new(
+ BusinessHours => BusinessHours(),
+ InHoursDefault => $RT::SLA{'InHoursDefault'},
+ OutOfHoursDefault => $RT::SLA{'OutOfHoursDefault'},
+ );
+
+ my $levels = $RT::SLA{'Levels'};
+ foreach my $level ( keys %$levels ) {
+ my $description = $levels->{ $level }{ $type };
+ unless ( defined $description ) {
+ $RT::Logger->warn("No $type agreement for $level");
+ next;
+ }
+
+ if ( ref $description ) {
+ $SLA->Add( $level => %$description );
+ } elsif ( $levels->{ $level } =~ /^\d+$/ ) {
+ $SLA->Add( $level => BusinessMinutes => $description );
+ } else {
+ $RT::Logger->error("Levels of SLA should be either number or hash ref");
+ }
+ }
+
+ return $SLA;
+}
+
+1;
commit 5db84775780687a5bc0a5e24e920d3f96e9aea85
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu May 10 21:54:56 2007 +0000
makefile, metafile
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..108d4f4
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,20 @@
+---
+abstract: RT Extension-SLA Extension
+author: Ruslan Zakirov <ruz at bestpractical.com>
+build_requires:
+ Test::More: 0
+distribution_type: module
+generated_by: Module::Install version 0.65
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.3.html
+ version: 1.3
+name: RT-Extension-SLA
+no_index:
+ directory:
+ - inc
+ - t
+requires:
+ Business::Hours: 0
+ Business::SLA: 0
+version: undef
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..c1e6c5b
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,13 @@
+use inc::Module::Install;
+
+RTx ('RT-Extension-SLA');
+author ('Ruslan Zakirov <ruz at bestpractical.com>');
+license('perl');
+
+build_requires('Test::More');
+
+requires('Business::SLA');
+requires('Business::Hours');
+auto_install();
+
+WriteAll();
commit e87ee996159bbb7a29b97765257c57be20e8185d
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu May 10 21:55:38 2007 +0000
M::I facility
diff --git a/inc/Module/AutoInstall.pm b/inc/Module/AutoInstall.pm
new file mode 100644
index 0000000..7efc552
--- /dev/null
+++ b/inc/Module/AutoInstall.pm
@@ -0,0 +1,768 @@
+#line 1
+package Module::AutoInstall;
+
+use strict;
+use Cwd ();
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.03';
+}
+
+# special map on pre-defined feature sets
+my %FeatureMap = (
+ '' => 'Core Features', # XXX: deprecated
+ '-core' => 'Core Features',
+);
+
+# various lexical flags
+my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $HasCPANPLUS );
+my ( $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly );
+my ( $PostambleActions, $PostambleUsed );
+
+# See if it's a testing or non-interactive session
+_accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN );
+_init();
+
+sub _accept_default {
+ $AcceptDefault = shift;
+}
+
+sub missing_modules {
+ return @Missing;
+}
+
+sub do_install {
+ __PACKAGE__->install(
+ [
+ $Config
+ ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
+ : ()
+ ],
+ @Missing,
+ );
+}
+
+# initialize various flags, and/or perform install
+sub _init {
+ foreach my $arg (
+ @ARGV,
+ split(
+ /[\s\t]+/,
+ $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || ''
+ )
+ )
+ {
+ if ( $arg =~ /^--config=(.*)$/ ) {
+ $Config = [ split( ',', $1 ) ];
+ }
+ elsif ( $arg =~ /^--installdeps=(.*)$/ ) {
+ __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
+ exit 0;
+ }
+ elsif ( $arg =~ /^--default(?:deps)?$/ ) {
+ $AcceptDefault = 1;
+ }
+ elsif ( $arg =~ /^--check(?:deps)?$/ ) {
+ $CheckOnly = 1;
+ }
+ elsif ( $arg =~ /^--skip(?:deps)?$/ ) {
+ $SkipInstall = 1;
+ }
+ elsif ( $arg =~ /^--test(?:only)?$/ ) {
+ $TestOnly = 1;
+ }
+ }
+}
+
+# overrides MakeMaker's prompt() to automatically accept the default choice
+sub _prompt {
+ goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault;
+
+ my ( $prompt, $default ) = @_;
+ my $y = ( $default =~ /^[Yy]/ );
+
+ print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] ';
+ print "$default\n";
+ return $default;
+}
+
+# the workhorse
+sub import {
+ my $class = shift;
+ my @args = @_ or return;
+ my $core_all;
+
+ print "*** $class version " . $class->VERSION . "\n";
+ print "*** Checking for Perl dependencies...\n";
+
+ my $cwd = Cwd::cwd();
+
+ $Config = [];
+
+ my $maxlen = length(
+ (
+ sort { length($b) <=> length($a) }
+ grep { /^[^\-]/ }
+ map {
+ ref($_)
+ ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} )
+ : ''
+ }
+ map { +{@args}->{$_} }
+ grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} }
+ )[0]
+ );
+
+ while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
+ my ( @required, @tests, @skiptests );
+ my $default = 1;
+ my $conflict = 0;
+
+ if ( $feature =~ m/^-(\w+)$/ ) {
+ my $option = lc($1);
+
+ # check for a newer version of myself
+ _update_to( $modules, @_ ) and return if $option eq 'version';
+
+ # sets CPAN configuration options
+ $Config = $modules if $option eq 'config';
+
+ # promote every features to core status
+ $core_all = ( $modules =~ /^all$/i ) and next
+ if $option eq 'core';
+
+ next unless $option eq 'core';
+ }
+
+ print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n";
+
+ $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' );
+
+ unshift @$modules, -default => &{ shift(@$modules) }
+ if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability
+
+ while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) {
+ if ( $mod =~ m/^-(\w+)$/ ) {
+ my $option = lc($1);
+
+ $default = $arg if ( $option eq 'default' );
+ $conflict = $arg if ( $option eq 'conflict' );
+ @tests = @{$arg} if ( $option eq 'tests' );
+ @skiptests = @{$arg} if ( $option eq 'skiptests' );
+
+ next;
+ }
+
+ printf( "- %-${maxlen}s ...", $mod );
+
+ if ( $arg and $arg =~ /^\D/ ) {
+ unshift @$modules, $arg;
+ $arg = 0;
+ }
+
+ # XXX: check for conflicts and uninstalls(!) them.
+ 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 {
+ print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
+ push @required, $mod => $arg;
+ }
+ }
+
+ next unless @required;
+
+ my $mandatory = ( $feature eq '-core' or $core_all );
+
+ if (
+ !$SkipInstall
+ and (
+ $CheckOnly
+ or _prompt(
+ qq{==> Auto-install the }
+ . ( @required / 2 )
+ . ( $mandatory ? ' mandatory' : ' optional' )
+ . qq{ module(s) from CPAN?},
+ $default ? 'y' : 'n',
+ ) =~ /^[Yy]/
+ )
+ )
+ {
+ push( @Missing, @required );
+ $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
+ }
+
+ elsif ( !$SkipInstall
+ and $default
+ and $mandatory
+ and
+ _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', )
+ =~ /^[Nn]/ )
+ {
+ push( @Missing, @required );
+ $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
+ }
+
+ else {
+ $DisabledTests{$_} = 1 for map { glob($_) } @tests;
+ }
+ }
+
+ $UnderCPAN = _check_lock(); # check for $UnderCPAN
+
+ if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
+ require Config;
+ print
+"*** Dependencies will be installed the next time you type '$Config::Config{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"
+ if eval '$>';
+ }
+ print "*** $class configuration finished.\n";
+
+ chdir $cwd;
+
+ # import to main::
+ no strict 'refs';
+ *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
+}
+
+# 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;
+
+ if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
+ print <<'END_MESSAGE';
+
+*** Since we're running under CPANPLUS, I'll just let it take care
+ of the dependency's installation later.
+END_MESSAGE
+ return 1;
+ }
+
+ _load_cpan();
+
+ # Find the CPAN lock-file
+ my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" );
+ return unless -f $lock;
+
+ # Check the lock
+ local *LOCK;
+ return unless open(LOCK, $lock);
+
+ if (
+ ( $^O eq 'MSWin32' ? _under_cpan() : <LOCK> == getppid() )
+ and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore'
+ ) {
+ print <<'END_MESSAGE';
+
+*** Since we're running under CPAN, I'll just let it take care
+ of the dependency's installation later.
+END_MESSAGE
+ return 1;
+ }
+
+ close LOCK;
+ return;
+}
+
+sub install {
+ my $class = shift;
+
+ my $i; # used below to strip leading '-' from config keys
+ my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } );
+
+ my ( @modules, @installed );
+ while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
+
+ # grep out those already installed
+ if ( defined( _version_check( _load($pkg), $ver ) ) ) {
+ push @installed, $pkg;
+ }
+ else {
+ push @modules, $pkg, $ver;
+ }
+ }
+
+ return @installed unless @modules; # nothing to do
+ return @installed if _check_lock(); # defer to the CPAN shell
+
+ print "*** Installing dependencies...\n";
+
+ return unless _connected_to('cpan.org');
+
+ my %args = @config;
+ my %failed;
+ local *FAILED;
+ if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) {
+ while (<FAILED>) { chomp; $failed{$_}++ }
+ close FAILED;
+
+ my @newmod;
+ while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) {
+ push @newmod, ( $k => $v ) unless $failed{$k};
+ }
+ @modules = @newmod;
+ }
+
+ if ( _has_cpanplus() ) {
+ _install_cpanplus( \@modules, \@config );
+ } else {
+ _install_cpan( \@modules, \@config );
+ }
+
+ print "*** $class installation finished.\n";
+
+ # see if we have successfully installed them
+ while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
+ if ( defined( _version_check( _load($pkg), $ver ) ) ) {
+ push @installed, $pkg;
+ }
+ elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
+ print FAILED "$pkg\n";
+ }
+ }
+
+ close FAILED if $args{do_once};
+
+ return @installed;
+}
+
+sub _install_cpanplus {
+ my @modules = @{ +shift };
+ my @config = _cpanplus_config( @{ +shift } );
+ my $installed = 0;
+
+ require CPANPLUS::Backend;
+ my $cp = CPANPLUS::Backend->new;
+ my $conf = $cp->configure_object;
+
+ return unless $conf->can('conf') # 0.05x+ with "sudo" support
+ or _can_write($conf->_get_build('base')); # 0.04x
+
+ # if we're root, set UNINST=1 to avoid trouble unless user asked for it.
+ my $makeflags = $conf->get_conf('makeflags') || '';
+ if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) {
+ # 0.03+ uses a hashref here
+ $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST};
+
+ } else {
+ # 0.02 and below uses a scalar
+ $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
+ if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
+
+ }
+ $conf->set_conf( makeflags => $makeflags );
+ $conf->set_conf( prereqs => 1 );
+
+
+
+ while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) {
+ $conf->set_conf( $key, $val );
+ }
+
+ my $modtree = $cp->module_tree;
+ while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
+ print "*** Installing $pkg...\n";
+
+ MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
+
+ my $success;
+ my $obj = $modtree->{$pkg};
+
+ if ( $obj and defined( _version_check( $obj->{version}, $ver ) ) ) {
+ my $pathname = $pkg;
+ $pathname =~ s/::/\\W/;
+
+ foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
+ delete $INC{$inc};
+ }
+
+ my $rv = $cp->install( modules => [ $obj->{module} ] );
+
+ if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) {
+ print "*** $pkg successfully installed.\n";
+ $success = 1;
+ } else {
+ print "*** $pkg installation cancelled.\n";
+ $success = 0;
+ }
+
+ $installed += $success;
+ } else {
+ print << ".";
+*** Could not find a version $ver or above for $pkg; skipping.
+.
+ }
+
+ MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
+ }
+
+ return $installed;
+}
+
+sub _cpanplus_config {
+ my @config = ();
+ while ( @_ ) {
+ my ($key, $value) = (shift(), shift());
+ if ( $key eq 'prerequisites_policy' ) {
+ if ( $value eq 'follow' ) {
+ $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL();
+ } elsif ( $value eq 'ask' ) {
+ $value = CPANPLUS::Internals::Constants::PREREQ_ASK();
+ } elsif ( $value eq 'ignore' ) {
+ $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE();
+ } else {
+ die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n";
+ }
+ } else {
+ die "*** Cannot convert option $key to CPANPLUS version.\n";
+ }
+ }
+ return @config;
+}
+
+sub _install_cpan {
+ my @modules = @{ +shift };
+ my @config = @{ +shift };
+ my $installed = 0;
+ my %args;
+
+ _load_cpan();
+ require Config;
+
+ if (CPAN->VERSION < 1.80) {
+ # no "sudo" support, probe for writableness
+ return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) )
+ and _can_write( $Config::Config{sitelib} );
+ }
+
+ # if we're root, set UNINST=1 to avoid trouble unless user asked for it.
+ my $makeflags = $CPAN::Config->{make_install_arg} || '';
+ $CPAN::Config->{make_install_arg} =
+ join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
+ if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
+
+ # don't show start-up info
+ $CPAN::Config->{inhibit_startup_message} = 1;
+
+ # set additional options
+ while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) {
+ ( $args{$opt} = $arg, next )
+ if $opt =~ /^force$/; # pseudo-option
+ $CPAN::Config->{$opt} = $arg;
+ }
+
+ local $CPAN::Config->{prerequisites_policy} = 'follow';
+
+ while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
+ MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
+
+ print "*** Installing $pkg...\n";
+
+ my $obj = CPAN::Shell->expand( Module => $pkg );
+ my $success = 0;
+
+ if ( $obj and defined( _version_check( $obj->cpan_version, $ver ) ) ) {
+ my $pathname = $pkg;
+ $pathname =~ s/::/\\W/;
+
+ foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
+ delete $INC{$inc};
+ }
+
+ my $rv = $args{force} ? CPAN::Shell->force( install => $pkg )
+ : CPAN::Shell->install($pkg);
+ $rv ||= eval {
+ $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )
+ ->{install}
+ if $CPAN::META;
+ };
+
+ if ( $rv eq 'YES' ) {
+ print "*** $pkg successfully installed.\n";
+ $success = 1;
+ }
+ else {
+ print "*** $pkg installation failed.\n";
+ $success = 0;
+ }
+
+ $installed += $success;
+ }
+ else {
+ print << ".";
+*** Could not find a version $ver or above for $pkg; skipping.
+.
+ }
+
+ MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
+ }
+
+ return $installed;
+}
+
+sub _has_cpanplus {
+ return (
+ $HasCPANPLUS = (
+ $INC{'CPANPLUS/Config.pm'}
+ or _load('CPANPLUS::Shell::Default')
+ )
+ );
+}
+
+# make guesses on whether we're under the CPAN installation directory
+sub _under_cpan {
+ require Cwd;
+ require File::Spec;
+
+ my $cwd = File::Spec->canonpath( Cwd::cwd() );
+ my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} );
+
+ return ( index( $cwd, $cpan ) > -1 );
+}
+
+sub _update_to {
+ my $class = __PACKAGE__;
+ my $ver = shift;
+
+ return
+ if defined( _version_check( _load($class), $ver ) ); # no need to upgrade
+
+ if (
+ _prompt( "==> A newer version of $class ($ver) is required. Install?",
+ 'y' ) =~ /^[Nn]/
+ )
+ {
+ die "*** Please install $class $ver manually.\n";
+ }
+
+ print << ".";
+*** Trying to fetch it from CPAN...
+.
+
+ # install ourselves
+ _load($class) and return $class->import(@_)
+ if $class->install( [], $class, $ver );
+
+ print << '.'; exit 1;
+
+*** Cannot bootstrap myself. :-( Installation terminated.
+.
+}
+
+# check if we're connected to some host, using inet_aton
+sub _connected_to {
+ my $site = shift;
+
+ return (
+ ( _load('Socket') and Socket::inet_aton($site) ) or _prompt(
+ qq(
+*** Your host cannot resolve the domain name '$site', which
+ probably means the Internet connections are unavailable.
+==> Should we try to install the required module(s) anyway?), 'n'
+ ) =~ /^[Yy]/
+ );
+}
+
+# check if a directory is writable; may create it on demand
+sub _can_write {
+ my $path = shift;
+ mkdir( $path, 0755 ) unless -e $path;
+
+ return 1 if -w $path;
+
+ print << ".";
+*** You are not allowed to write to the directory '$path';
+ the installation may fail due to insufficient permissions.
+.
+
+ if (
+ eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt(
+ qq(
+==> Should we try to re-execute the autoinstall process with 'sudo'?),
+ ((-t STDIN) ? 'y' : 'n')
+ ) =~ /^[Yy]/
+ )
+ {
+
+ # try to bootstrap ourselves from sudo
+ print << ".";
+*** Trying to re-execute the autoinstall process with 'sudo'...
+.
+ my $missing = join( ',', @Missing );
+ my $config = join( ',',
+ UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
+ if $Config;
+
+ return
+ unless system( 'sudo', $^X, $0, "--config=$config",
+ "--installdeps=$missing" );
+
+ print << ".";
+*** The 'sudo' command exited with error! Resuming...
+.
+ }
+
+ return _prompt(
+ qq(
+==> Should we try to install the required module(s) anyway?), 'n'
+ ) =~ /^[Yy]/;
+}
+
+# load a module and return the version it reports
+sub _load {
+ my $mod = pop; # class/instance doesn't matter
+ my $file = $mod;
+
+ $file =~ s|::|/|g;
+ $file .= '.pm';
+
+ local $@;
+ return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
+}
+
+# Load CPAN.pm and it's configuration
+sub _load_cpan {
+ return if $CPAN::VERSION;
+ require CPAN;
+ if ( $CPAN::HandleConfig::VERSION ) {
+ # Newer versions of CPAN have a HandleConfig module
+ CPAN::HandleConfig->load;
+ } else {
+ # Older versions had the load method in Config directly
+ CPAN::Config->load;
+ }
+}
+
+# compare two versions, either use Sort::Versions or plain comparison
+sub _version_check {
+ my ( $cur, $min ) = @_;
+ return unless defined $cur;
+
+ $cur =~ s/\s+$//;
+
+ # check for version numbers that are not in decimal format
+ if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) {
+ if ( ( $version::VERSION or defined( _load('version') )) and
+ version->can('new')
+ ) {
+
+ # use version.pm if it is installed.
+ 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 ) != -1 )
+ ? $cur
+ : undef );
+ }
+
+ warn "Cannot reliably compare non-decimal formatted versions.\n"
+ . "Please install version.pm or Sort::Versions.\n";
+ }
+
+ # plain comparison
+ local $^W = 0; # shuts off 'not numeric' bugs
+ return ( $cur >= $min ? $cur : undef );
+}
+
+# nothing; this usage is deprecated.
+sub main::PREREQ_PM { return {}; }
+
+sub _make_args {
+ my %args = @_;
+
+ $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing }
+ if $UnderCPAN or $TestOnly;
+
+ if ( $args{EXE_FILES} and -e 'MANIFEST' ) {
+ require ExtUtils::Manifest;
+ my $manifest = ExtUtils::Manifest::maniread('MANIFEST');
+
+ $args{EXE_FILES} =
+ [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ];
+ }
+
+ $args{test}{TESTS} ||= 't/*.t';
+ $args{test}{TESTS} = join( ' ',
+ grep { !exists( $DisabledTests{$_} ) }
+ map { glob($_) } split( /\s+/, $args{test}{TESTS} ) );
+
+ my $missing = join( ',', @Missing );
+ my $config =
+ join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
+ if $Config;
+
+ $PostambleActions = (
+ $missing
+ ? "\$(PERL) $0 --config=$config --installdeps=$missing"
+ : "\$(NOECHO) \$(NOOP)"
+ );
+
+ return %args;
+}
+
+# a wrapper to ExtUtils::MakeMaker::WriteMakefile
+sub Write {
+ require Carp;
+ Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;
+
+ if ($CheckOnly) {
+ print << ".";
+*** Makefile not written in check-only mode.
+.
+ return;
+ }
+
+ my %args = _make_args(@_);
+
+ no strict 'refs';
+
+ $PostambleUsed = 0;
+ local *MY::postamble = \&postamble unless defined &MY::postamble;
+ ExtUtils::MakeMaker::WriteMakefile(%args);
+
+ print << "." unless $PostambleUsed;
+*** WARNING: Makefile written with customized MY::postamble() without
+ including contents from Module::AutoInstall::postamble() --
+ auto installation features disabled. Please contact the author.
+.
+
+ return 1;
+}
+
+sub postamble {
+ $PostambleUsed = 1;
+
+ return << ".";
+
+config :: installdeps
+\t\$(NOECHO) \$(NOOP)
+
+checkdeps ::
+\t\$(PERL) $0 --checkdeps
+
+installdeps ::
+\t$PostambleActions
+
+.
+
+}
+
+1;
+
+__END__
+
+#line 1003
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
new file mode 100644
index 0000000..af6a59c
--- /dev/null
+++ b/inc/Module/Install.pm
@@ -0,0 +1,281 @@
+#line 1
+package Module::Install;
+
+# For any maintainers:
+# The load order for Module::Install is a bit magic.
+# It goes something like this...
+#
+# IF ( host has Module::Install installed, creating author mode ) {
+# 1. Makefile.PL calls "use inc::Module::Install"
+# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
+# 3. The installed version of inc::Module::Install loads
+# 4. inc::Module::Install calls "require Module::Install"
+# 5. The ./inc/ version of Module::Install loads
+# } ELSE {
+# 1. Makefile.PL calls "use inc::Module::Install"
+# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
+# 3. The ./inc/ version of Module::Install loads
+# }
+
+use 5.004;
+use strict 'vars';
+
+use vars qw{$VERSION};
+BEGIN {
+ # All Module::Install core packages now require synchronised versions.
+ # This will be used to ensure we don't accidentally load old or
+ # different versions of modules.
+ # 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.65';
+}
+
+# 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:
+
+ use inc::${\__PACKAGE__};
+
+not:
+
+ use ${\__PACKAGE__};
+
+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 and (stat($0))[9] > time ) {
+ die << "END_DIE";
+Your installer $0 has a modification time in the future.
+
+This is known to create infinite loops in make.
+
+Please correct this, then run $0 again.
+
+END_DIE
+}
+
+use Cwd ();
+use File::Find ();
+use File::Path ();
+use FindBin;
+
+*inc::Module::Install::VERSION = *VERSION;
+ at inc::Module::Install::ISA = __PACKAGE__;
+
+sub autoload {
+ my $self = shift;
+ my $who = $self->_caller;
+ my $cwd = Cwd::cwd();
+ my $sym = "${who}::AUTOLOAD";
+ $sym->{$cwd} = sub {
+ my $pwd = Cwd::cwd();
+ if ( my $code = $sym->{$pwd} ) {
+ # delegate back to parent dirs
+ goto &$code unless $cwd eq $pwd;
+ }
+ $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
+ unshift @_, ($self, $1);
+ goto &{$self->can('call')} unless uc($1) eq $1;
+ };
+}
+
+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"};
+}
+
+sub preload {
+ my ($self) = @_;
+
+ unless ( $self->{extensions} ) {
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ );
+ }
+
+ my @exts = @{$self->{extensions}};
+ unless ( @exts ) {
+ my $admin = $self->{admin};
+ @exts = $admin->load_all_extensions;
+ }
+
+ my %seen;
+ foreach my $obj ( @exts ) {
+ while (my ($method, $glob) = each %{ref($obj) . '::'}) {
+ next unless $obj->can($method);
+ next if $method =~ /^_/;
+ next if $method eq uc($method);
+ $seen{$method}++;
+ }
+ }
+
+ my $who = $self->_caller;
+ foreach my $name ( sort keys %seen ) {
+ *{"${who}::$name"} = sub {
+ ${"${who}::AUTOLOAD"} = "${who}::$name";
+ goto &{"${who}::AUTOLOAD"};
+ };
+ }
+}
+
+sub new {
+ my ($class, %args) = @_;
+
+ # 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';
+ $args{prefix} ||= 'inc';
+ $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
+ $args{bundle} ||= 'inc/BUNDLES';
+ $args{base} ||= $base_path;
+ $class =~ s/^\Q$args{prefix}\E:://;
+ $args{name} ||= $class;
+ $args{version} ||= $class->VERSION;
+ unless ( $args{path} ) {
+ $args{path} = $args{name};
+ $args{path} =~ s!::!/!g;
+ }
+ $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
+
+ bless( \%args, $class );
+}
+
+sub call {
+ my ($self, $method) = @_;
+ my $obj = $self->load($method) or return;
+ splice(@_, 0, 2, $obj);
+ goto &{$obj->can($method)};
+}
+
+sub load {
+ my ($self, $method) = @_;
+
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ ) unless $self->{extensions};
+
+ foreach my $obj (@{$self->{extensions}}) {
+ return $obj if $obj->can($method);
+ }
+
+ my $admin = $self->{admin} or die <<"END_DIE";
+The '$method' method does not exist in the '$self->{prefix}' path!
+Please remove the '$self->{prefix}' directory and run $0 again to load it.
+END_DIE
+
+ my $obj = $admin->load($method, 1);
+ push @{$self->{extensions}}, $obj;
+
+ $obj;
+}
+
+sub load_extensions {
+ my ($self, $path, $top) = @_;
+
+ unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
+ unshift @INC, $self->{prefix};
+ }
+
+ foreach my $rv ( $self->find_extensions($path) ) {
+ my ($file, $pkg) = @{$rv};
+ next if $self->{pathnames}{$pkg};
+
+ local $@;
+ my $new = eval { require $file; $pkg->can('new') };
+ unless ( $new ) {
+ warn $@ if $@;
+ next;
+ }
+ $self->{pathnames}{$pkg} = delete $INC{$file};
+ push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
+ }
+
+ $self->{extensions} ||= [];
+}
+
+sub find_extensions {
+ my ($self, $path) = @_;
+
+ my @found;
+ File::Find::find( sub {
+ my $file = $File::Find::name;
+ return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
+ my $subpath = $1;
+ return if lc($subpath) eq lc($self->{dispatch});
+
+ $file = "$self->{path}/$subpath.pm";
+ my $pkg = "$self->{name}::$subpath";
+ $pkg =~ s!/!::!g;
+
+ # If we have a mixed-case package name, assume case has been preserved
+ # correctly. Otherwise, root through the file to locate the case-preserved
+ # version of the package name.
+ if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
+ open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
+ my $in_pod = 0;
+ while ( <PKGFILE> ) {
+ $in_pod = 1 if /^=\w/;
+ $in_pod = 0 if /^=cut/;
+ next if ($in_pod || /^=cut/); # skip pod text
+ next if /^\s*#/; # and comments
+ if ( m/^\s*package\s+($pkg)\s*;/i ) {
+ $pkg = $1;
+ last;
+ }
+ }
+ close PKGFILE;
+ }
+
+ push @found, [ $file, $pkg ];
+ }, $path ) if -d $path;
+
+ @found;
+}
+
+sub _caller {
+ my $depth = 0;
+ my $call = caller($depth);
+ while ( $call eq __PACKAGE__ ) {
+ $depth++;
+ $call = caller($depth);
+ }
+ return $call;
+}
+
+1;
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
new file mode 100644
index 0000000..b4b55af
--- /dev/null
+++ b/inc/Module/Install/AutoInstall.pm
@@ -0,0 +1,61 @@
+#line 1
+package Module::Install::AutoInstall;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.65';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub AutoInstall { $_[0] }
+
+sub run {
+ my $self = shift;
+ $self->auto_install_now(@_);
+}
+
+sub write {
+ my $self = shift;
+ $self->auto_install(@_);
+}
+
+sub auto_install {
+ my $self = shift;
+ return if $self->{done}++;
+
+ # Flatten array of arrays into a single array
+ my @core = map @$_, map @$_, grep ref,
+ $self->build_requires, $self->requires;
+
+ my @config = @_;
+
+ # We'll need Module::AutoInstall
+ $self->include('Module::AutoInstall');
+ require Module::AutoInstall;
+
+ Module::AutoInstall->import(
+ (@config ? (-config => \@config) : ()),
+ (@core ? (-core => \@core) : ()),
+ $self->features,
+ );
+
+ $self->makemaker_args( Module::AutoInstall::_make_args() );
+
+ my $class = ref($self);
+ $self->postamble(
+ "# --- $class section:\n" .
+ Module::AutoInstall::postamble()
+ );
+}
+
+sub auto_install_now {
+ my $self = shift;
+ $self->auto_install(@_);
+ Module::AutoInstall::do_install();
+}
+
+1;
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
new file mode 100644
index 0000000..b46a8ca
--- /dev/null
+++ b/inc/Module/Install/Base.pm
@@ -0,0 +1,70 @@
+#line 1
+package Module::Install::Base;
+
+$VERSION = '0.65';
+
+# Suspend handler for "redefined" warnings
+BEGIN {
+ my $w = $SIG{__WARN__};
+ $SIG{__WARN__} = sub { $w };
+}
+
+### This is the ONLY module that shouldn't have strict on
+# use strict;
+
+#line 41
+
+sub new {
+ my ($class, %args) = @_;
+
+ foreach my $method ( qw(call load) ) {
+ *{"$class\::$method"} = sub {
+ shift()->_top->$method(@_);
+ } unless defined &{"$class\::$method"};
+ }
+
+ bless( \%args, $class );
+}
+
+#line 61
+
+sub AUTOLOAD {
+ my $self = shift;
+ local $@;
+ my $autoload = eval { $self->_top->autoload } or return;
+ goto &$autoload;
+}
+
+#line 76
+
+sub _top { $_[0]->{_top} }
+
+#line 89
+
+sub admin {
+ $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
+}
+
+sub is_admin {
+ $_[0]->admin->VERSION;
+}
+
+sub DESTROY {}
+
+package Module::Install::Base::FakeAdmin;
+
+my $Fake;
+sub new { $Fake ||= bless(\@_, $_[0]) }
+
+sub AUTOLOAD {}
+
+sub DESTROY {}
+
+# Restore warning handler
+BEGIN {
+ $SIG{__WARN__} = $SIG{__WARN__}->();
+}
+
+1;
+
+#line 138
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
new file mode 100644
index 0000000..9bcf278
--- /dev/null
+++ b/inc/Module/Install/Can.pm
@@ -0,0 +1,82 @@
+#line 1
+package Module::Install::Can;
+
+use strict;
+use Module::Install::Base;
+use Config ();
+### This adds a 5.005 Perl version dependency.
+### This is a bug and will be fixed.
+use File::Spec ();
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.65';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+# check if we can load some module
+### Upgrade this to not have to load the module if possible
+sub can_use {
+ my ($self, $mod, $ver) = @_;
+ $mod =~ s{::|\\}{/}g;
+ $mod .= '.pm' unless $mod =~ /\.pm$/i;
+
+ my $pkg = $mod;
+ $pkg =~ s{/}{::}g;
+ $pkg =~ s{\.pm$}{}i;
+
+ local $@;
+ eval { require $mod; $pkg->VERSION($ver || 0); 1 };
+}
+
+# check if we can run some command
+sub can_run {
+ my ($self, $cmd) = @_;
+
+ my $_cmd = $cmd;
+ return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
+
+ for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
+ my $abs = File::Spec->catfile($dir, $_[1]);
+ return $abs if (-x $abs or $abs = MM->maybe_command($abs));
+ }
+
+ return;
+}
+
+# can we locate a (the) C compiler
+sub can_cc {
+ my $self = shift;
+ my @chunks = split(/ /, $Config::Config{cc}) or return;
+
+ # $Config{cc} may contain args; try to find out the program part
+ while (@chunks) {
+ return $self->can_run("@chunks") || (pop(@chunks), next);
+ }
+
+ return;
+}
+
+# Fix Cygwin bug on maybe_command();
+if ( $^O eq 'cygwin' ) {
+ require ExtUtils::MM_Cygwin;
+ require ExtUtils::MM_Win32;
+ if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
+ *ExtUtils::MM_Cygwin::maybe_command = sub {
+ my ($self, $file) = @_;
+ if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
+ ExtUtils::MM_Win32->maybe_command($file);
+ } else {
+ ExtUtils::MM_Unix->maybe_command($file);
+ }
+ }
+ }
+}
+
+1;
+
+__END__
+
+#line 157
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
new file mode 100644
index 0000000..0d2c39c
--- /dev/null
+++ b/inc/Module/Install/Fetch.pm
@@ -0,0 +1,93 @@
+#line 1
+package Module::Install::Fetch;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.65';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub get_file {
+ my ($self, %args) = @_;
+ my ($scheme, $host, $path, $file) =
+ $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
+
+ if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
+ $args{url} = $args{ftp_url}
+ or (warn("LWP support unavailable!\n"), return);
+ ($scheme, $host, $path, $file) =
+ $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
+ }
+
+ $|++;
+ print "Fetching '$file' from $host... ";
+
+ unless (eval { require Socket; Socket::inet_aton($host) }) {
+ warn "'$host' resolve failed!\n";
+ return;
+ }
+
+ return unless $scheme eq 'ftp' or $scheme eq 'http';
+
+ require Cwd;
+ my $dir = Cwd::getcwd();
+ chdir $args{local_dir} or return if exists $args{local_dir};
+
+ if (eval { require LWP::Simple; 1 }) {
+ LWP::Simple::mirror($args{url}, $file);
+ }
+ elsif (eval { require Net::FTP; 1 }) { eval {
+ # use Net::FTP to get past firewall
+ my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
+ $ftp->login("anonymous", 'anonymous at example.com');
+ $ftp->cwd($path);
+ $ftp->binary;
+ $ftp->get($file) or (warn("$!\n"), return);
+ $ftp->quit;
+ } }
+ elsif (my $ftp = $self->can_run('ftp')) { eval {
+ # no Net::FTP, fallback to ftp.exe
+ require FileHandle;
+ my $fh = FileHandle->new;
+
+ local $SIG{CHLD} = 'IGNORE';
+ unless ($fh->open("|$ftp -n")) {
+ warn "Couldn't open ftp: $!\n";
+ chdir $dir; return;
+ }
+
+ my @dialog = split(/\n/, <<"END_FTP");
+open $host
+user anonymous anonymous\@example.com
+cd $path
+binary
+get $file $file
+quit
+END_FTP
+ foreach (@dialog) { $fh->print("$_\n") }
+ $fh->close;
+ } }
+ else {
+ warn "No working 'ftp' program available!\n";
+ chdir $dir; return;
+ }
+
+ unless (-f $file) {
+ warn "Fetching failed: $@\n";
+ chdir $dir; return;
+ }
+
+ return if exists $args{size} and -s $file != $args{size};
+ system($args{run}) if exists $args{run};
+ unlink($file) if $args{remove};
+
+ print(((!exists $args{check_for} or -e $args{check_for})
+ ? "done!" : "failed! ($!)"), "\n");
+ chdir $dir; return !$?;
+}
+
+1;
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
new file mode 100644
index 0000000..964b93d
--- /dev/null
+++ b/inc/Module/Install/Include.pm
@@ -0,0 +1,34 @@
+#line 1
+package Module::Install::Include;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.65';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub include {
+ shift()->admin->include(@_);
+}
+
+sub include_deps {
+ shift()->admin->include_deps(@_);
+}
+
+sub auto_include {
+ shift()->admin->auto_include(@_);
+}
+
+sub auto_include_deps {
+ shift()->admin->auto_include_deps(@_);
+}
+
+sub auto_include_dependent_dists {
+ shift()->admin->auto_include_dependent_dists(@_);
+}
+
+1;
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
new file mode 100644
index 0000000..eb67033
--- /dev/null
+++ b/inc/Module/Install/Makefile.pm
@@ -0,0 +1,212 @@
+#line 1
+package Module::Install::Makefile;
+
+use strict 'vars';
+use Module::Install::Base;
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.65';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub Makefile { $_[0] }
+
+my %seen = ();
+
+sub prompt {
+ shift;
+
+ # Infinite loop protection
+ my @c = caller();
+ if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
+ 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} ) {
+ local $ENV{PERL_MM_USE_DEFAULT} = 1;
+ goto &ExtUtils::MakeMaker::prompt;
+ } else {
+ goto &ExtUtils::MakeMaker::prompt;
+ }
+}
+
+sub makemaker_args {
+ my $self = shift;
+ my $args = ($self->{makemaker_args} ||= {});
+ %$args = ( %$args, @_ ) if @_;
+ $args;
+}
+
+# For mm args that take multiple space-seperated args,
+# append an argument to the current list.
+sub makemaker_append {
+ my $self = shift;
+ my $name = shift;
+ my $args = $self->makemaker_args;
+ $args->{name} = defined $args->{$name}
+ ? join( ' ', $args->{name}, @_ )
+ : join( ' ', @_ );
+}
+
+sub build_subdirs {
+ my $self = shift;
+ my $subdirs = $self->makemaker_args->{DIR} ||= [];
+ for my $subdir (@_) {
+ push @$subdirs, $subdir;
+ }
+}
+
+sub clean_files {
+ my $self = shift;
+ my $clean = $self->makemaker_args->{clean} ||= {};
+ %$clean = (
+ %$clean,
+ FILES => join(' ', grep length, $clean->{FILES}, @_),
+ );
+}
+
+sub realclean_files {
+ my $self = shift;
+ my $realclean = $self->makemaker_args->{realclean} ||= {};
+ %$realclean = (
+ %$realclean,
+ FILES => join(' ', grep length, $realclean->{FILES}, @_),
+ );
+}
+
+sub libs {
+ my $self = shift;
+ my $libs = ref $_[0] ? shift : [ shift ];
+ $self->makemaker_args( LIBS => $libs );
+}
+
+sub inc {
+ my $self = shift;
+ $self->makemaker_args( INC => shift );
+}
+
+sub write {
+ my $self = shift;
+ die "&Makefile->write() takes no arguments\n" if @_;
+
+ my $args = $self->makemaker_args;
+ $args->{DISTNAME} = $self->name;
+ $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
+ $args->{VERSION} = $self->version || $self->determine_VERSION($args);
+ $args->{NAME} =~ s/-/::/g;
+ if ( $self->tests ) {
+ $args->{test} = { TESTS => $self->tests };
+ }
+ if ($] >= 5.005) {
+ $args->{ABSTRACT} = $self->abstract;
+ $args->{AUTHOR} = $self->author;
+ }
+ if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
+ $args->{NO_META} = 1;
+ }
+ if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
+ $args->{SIGN} = 1;
+ }
+ unless ( $self->is_admin ) {
+ delete $args->{SIGN};
+ }
+
+ # merge both kinds of requires into prereq_pm
+ my $prereq = ($args->{PREREQ_PM} ||= {});
+ %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_,
+ ($self->build_requires, $self->requires) );
+
+ # merge both kinds of requires into prereq_pm
+ my $subdirs = ($args->{DIR} ||= []);
+ if ($self->bundles) {
+ foreach my $bundle (@{ $self->bundles }) {
+ my ($file, $dir) = @$bundle;
+ push @$subdirs, $dir if -d $dir;
+ delete $prereq->{$file};
+ }
+ }
+
+ 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";
+ }
+
+ $args->{INSTALLDIRS} = $self->installdirs;
+
+ my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
+
+ my $user_preop = delete $args{dist}->{PREOP};
+ if (my $preop = $self->admin->preop($user_preop)) {
+ $args{dist} = $preop;
+ }
+
+ my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
+ $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
+}
+
+sub fix_up_makefile {
+ my $self = shift;
+ my $makefile_name = shift;
+ my $top_class = ref($self->_top) || '';
+ my $top_version = $self->_top->VERSION || '';
+
+ my $preamble = $self->preamble
+ ? "# Preamble by $top_class $top_version\n"
+ . $self->preamble
+ : '';
+ my $postamble = "# Postamble by $top_class $top_version\n"
+ . ($self->postamble || '');
+
+ local *MAKEFILE;
+ open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ 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;
+ $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
+ $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
+ $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
+
+ # Module::Install will never be used to build the Core Perl
+ # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
+ # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
+ $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
+ #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
+
+ # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
+ $makefile =~ s/("?)-I\$\(PERL_LIB\)\1//g;
+
+ # 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: $!";
+ print MAKEFILE "$preamble$makefile$postamble" or die $!;
+ close MAKEFILE or die $!;
+
+ 1;
+}
+
+sub preamble {
+ my ($self, $text) = @_;
+ $self->{preamble} = $text . $self->{preamble} if defined $text;
+ $self->{preamble};
+}
+
+sub postamble {
+ my ($self, $text) = @_;
+ $self->{postamble} ||= $self->admin->postamble;
+ $self->{postamble} .= $text if defined $text;
+ $self->{postamble}
+}
+
+1;
+
+__END__
+
+#line 338
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
new file mode 100644
index 0000000..b5658c9
--- /dev/null
+++ b/inc/Module/Install/Metadata.pm
@@ -0,0 +1,323 @@
+#line 1
+package Module::Install::Metadata;
+
+use strict 'vars';
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.65';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+my @scalar_keys = qw{
+ name module_name abstract author version license
+ distribution_type perl_version tests installdirs
+};
+
+my @tuple_keys = qw{
+ build_requires requires recommends bundles
+};
+
+sub Meta { shift }
+sub Meta_ScalarKeys { @scalar_keys }
+sub Meta_TupleKeys { @tuple_keys }
+
+foreach my $key (@scalar_keys) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}{$key} if defined wantarray and !@_;
+ $self->{values}{$key} = shift;
+ return $self;
+ };
+}
+
+foreach my $key (@tuple_keys) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}{$key} unless @_;
+
+ my @rv;
+ while (@_) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ if ( $module eq 'perl' ) {
+ $version =~ s{^(\d+)\.(\d+)\.(\d+)}
+ {$1 + $2/1_000 + $3/1_000_000}e;
+ $self->perl_version($version);
+ next;
+ }
+ my $rv = [ $module, $version ];
+ push @rv, $rv;
+ }
+ push @{ $self->{values}{$key} }, @rv;
+ @rv;
+ };
+}
+
+sub install_as_core { $_[0]->installdirs('perl') }
+sub install_as_cpan { $_[0]->installdirs('site') }
+sub install_as_site { $_[0]->installdirs('site') }
+sub install_as_vendor { $_[0]->installdirs('vendor') }
+
+sub sign {
+ my $self = shift;
+ return $self->{'values'}{'sign'} if defined wantarray and !@_;
+ $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
+ return $self;
+}
+
+sub dynamic_config {
+ my $self = shift;
+ unless ( @_ ) {
+ warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
+ return $self;
+ }
+ $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
+ return $self;
+}
+
+sub all_from {
+ my ( $self, $file ) = @_;
+
+ unless ( defined($file) ) {
+ my $name = $self->name
+ or die "all_from called with no args without setting name() first";
+ $file = join('/', 'lib', split(/-/, $name)) . '.pm';
+ $file =~ s{.*/}{} unless -e $file;
+ die "all_from: cannot find $file from $name" unless -e $file;
+ }
+
+ $self->version_from($file) unless $self->version;
+ $self->perl_version_from($file) unless $self->perl_version;
+
+ # The remaining probes read from POD sections; if the file
+ # has an accompanying .pod, use that instead
+ my $pod = $file;
+ if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
+ $file = $pod;
+ }
+
+ $self->author_from($file) unless $self->author;
+ $self->license_from($file) unless $self->license;
+ $self->abstract_from($file) unless $self->abstract;
+}
+
+sub provides {
+ my $self = shift;
+ my $provides = ( $self->{values}{provides} ||= {} );
+ %$provides = (%$provides, @_) if @_;
+ return $provides;
+}
+
+sub auto_provides {
+ my $self = shift;
+ return $self unless $self->is_admin;
+
+ unless (-e 'MANIFEST') {
+ warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
+ return $self;
+ }
+
+ # Avoid spurious warnings as we are not checking manifest here.
+
+ local $SIG{__WARN__} = sub {1};
+ require ExtUtils::Manifest;
+ local *ExtUtils::Manifest::manicheck = sub { return };
+
+ require Module::Build;
+ my $build = Module::Build->new(
+ dist_name => $self->name,
+ dist_version => $self->version,
+ license => $self->license,
+ );
+ $self->provides(%{ $build->find_dist_packages || {} });
+}
+
+sub feature {
+ my $self = shift;
+ my $name = shift;
+ my $features = ( $self->{values}{features} ||= [] );
+
+ my $mods;
+
+ if ( @_ == 1 and ref( $_[0] ) ) {
+ # The user used ->feature like ->features by passing in the second
+ # argument as a reference. Accomodate for that.
+ $mods = $_[0];
+ } else {
+ $mods = \@_;
+ }
+
+ my $count = 0;
+ push @$features, (
+ $name => [
+ map {
+ ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
+ : @$_
+ : $_
+ } @$mods
+ ]
+ );
+
+ return @$features;
+}
+
+sub features {
+ my $self = shift;
+ while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
+ $self->feature( $name, @$mods );
+ }
+ return $self->{values}->{features}
+ ? @{ $self->{values}->{features} }
+ : ();
+}
+
+sub no_index {
+ my $self = shift;
+ my $type = shift;
+ push @{ $self->{values}{no_index}{$type} }, @_ if $type;
+ return $self->{values}{no_index};
+}
+
+sub read {
+ my $self = shift;
+ $self->include_deps( 'YAML', 0 );
+
+ require YAML;
+ my $data = YAML::LoadFile('META.yml');
+
+ # Call methods explicitly in case user has already set some values.
+ while ( my ( $key, $value ) = each %$data ) {
+ next unless $self->can($key);
+ if ( ref $value eq 'HASH' ) {
+ while ( my ( $module, $version ) = each %$value ) {
+ $self->can($key)->($self, $module => $version );
+ }
+ }
+ else {
+ $self->can($key)->($self, $value);
+ }
+ }
+ return $self;
+}
+
+sub write {
+ my $self = shift;
+ return $self unless $self->is_admin;
+ $self->admin->write_meta;
+ return $self;
+}
+
+sub version_from {
+ my ( $self, $file ) = @_;
+ require ExtUtils::MM_Unix;
+ $self->version( ExtUtils::MM_Unix->parse_version($file) );
+}
+
+sub abstract_from {
+ my ( $self, $file ) = @_;
+ require ExtUtils::MM_Unix;
+ $self->abstract(
+ bless(
+ { DISTNAME => $self->name },
+ 'ExtUtils::MM_Unix'
+ )->parse_abstract($file)
+ );
+}
+
+sub _slurp {
+ my ( $self, $file ) = @_;
+
+ local *FH;
+ open FH, "< $file" or die "Cannot open $file.pod: $!";
+ do { local $/; <FH> };
+}
+
+sub perl_version_from {
+ my ( $self, $file ) = @_;
+
+ if (
+ $self->_slurp($file) =~ m/
+ ^
+ use \s*
+ v?
+ ([\d_\.]+)
+ \s* ;
+ /ixms
+ )
+ {
+ my $v = $1;
+ $v =~ s{_}{}g;
+ $self->perl_version($1);
+ }
+ else {
+ warn "Cannot determine perl version info from $file\n";
+ return;
+ }
+}
+
+sub author_from {
+ my ( $self, $file ) = @_;
+ my $content = $self->_slurp($file);
+ if ($content =~ m/
+ =head \d \s+ (?:authors?)\b \s*
+ ([^\n]*)
+ |
+ =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
+ .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
+ ([^\n]*)
+ /ixms) {
+ my $author = $1 || $2;
+ $author =~ s{E<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ $self->author($author);
+ }
+ else {
+ warn "Cannot determine author info from $file\n";
+ }
+}
+
+sub license_from {
+ my ( $self, $file ) = @_;
+
+ if (
+ $self->_slurp($file) =~ 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',
+ 'GNU public license' => 'gpl',
+ 'GNU lesser public license' => 'gpl',
+ 'BSD license' => 'bsd',
+ 'Artistic license' => 'artistic',
+ 'GPL' => 'gpl',
+ 'LGPL' => 'lgpl',
+ 'BSD' => 'bsd',
+ 'Artistic' => 'artistic',
+ 'MIT' => 'MIT',
+ );
+ while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) {
+ $pattern =~ s{\s+}{\\s+}g;
+ if ( $license_text =~ /\b$pattern\b/i ) {
+ $self->license($license);
+ return 1;
+ }
+ }
+ }
+
+ warn "Cannot determine license info from $file\n";
+ return 'unknown';
+}
+
+1;
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
new file mode 100644
index 0000000..1513848
--- /dev/null
+++ b/inc/Module/Install/RTx.pm
@@ -0,0 +1,158 @@
+#line 1
+package Module::Install::RTx;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+$Module::Install::RTx::VERSION = '0.11';
+
+use strict;
+use FindBin;
+use File::Glob ();
+use File::Basename ();
+
+sub RTx {
+ my ($self, $name) = @_;
+ my $RTx = 'RTx';
+ $RTx = $1 if $name =~ s/^(\w+)-//;
+ my $fname = $name;
+ $fname =~ s!-!/!g;
+
+ $self->name("$RTx-$name")
+ unless $self->name;
+ $self->abstract("RT $name Extension")
+ unless $self->abstract;
+ $self->version_from (-e "$name.pm" ? "$name.pm" : "lib/$RTx/$fname.pm")
+ unless $self->version;
+
+ my @prefixes = (qw(/opt /usr/local /home /usr /sw ));
+ my $prefix = $ENV{PREFIX};
+ @ARGV = grep { /PREFIX=(.*)/ ? (($prefix = $1), 0) : 1 } @ARGV;
+
+ if ($prefix) {
+ $RT::LocalPath = $prefix;
+ $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
+ );
+ 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;
+ push @INC, $_, "$_/rt3/lib", "$_/lib/rt3", "$_/lib";
+ }
+ }
+
+ my $lib_path = File::Basename::dirname($INC{'RT.pm'});
+ print "Using RT configurations from $INC{'RT.pm'}:\n";
+
+ $RT::LocalVarPath ||= $RT::VarPath;
+ $RT::LocalPoPath ||= $RT::LocalLexiconPath;
+ $RT::LocalHtmlPath ||= $RT::MasonComponentRoot;
+
+ my %path;
+ my $with_subdirs = $ENV{WITH_SUBDIRS};
+ @ARGV = grep { /WITH_SUBDIRS=(.*)/ ? (($with_subdirs = $1), 0) : 1 } @ARGV;
+ my %subdirs = map { $_ => 1 } split(/\s*,\s*/, $with_subdirs);
+
+ foreach (qw(bin etc html po sbin var)) {
+ next unless -d "$FindBin::Bin/$_";
+ next if %subdirs and !$subdirs{$_};
+ $self->no_index( directory => $_ );
+
+ no strict 'refs';
+ my $varname = "RT::Local" . ucfirst($_) . "Path";
+ $path{$_} = ${$varname} || "$RT::LocalPath/$_";
+ }
+
+ $path{$_} .= "/$name" for grep $path{$_}, qw(etc po var);
+ my $args = join(', ', map "q($_)", %path);
+ $path{lib} = "$RT::LocalPath/lib" unless %subdirs and !$subdirs{'lib'};
+ print "./$_\t=> $path{$_}\n" for sort keys %path;
+
+ if (my @dirs = map { (-D => $_) } grep $path{$_}, qw(bin html sbin)) {
+ my @po = map { (-o => $_) } grep -f, File::Glob::bsd_glob("po/*.po");
+ $self->postamble(<< ".") if @po;
+lexicons ::
+\t\$(NOECHO) \$(PERL) -MLocale::Maketext::Extract::Run=xgettext -e \"xgettext(qw(@dirs @po))\"
+.
+ }
+
+ my $postamble = << ".";
+install ::
+\t\$(NOECHO) \$(PERL) -MExtUtils::Install -e \"install({$args})\"
+.
+
+ if ($path{var} and -d $RT::MasonDataDir) {
+ my ($uid, $gid) = (stat($RT::MasonDataDir))[4, 5];
+ $postamble .= << ".";
+\t\$(NOECHO) chown -R $uid:$gid $path{var}
+.
+ }
+
+ my %has_etc;
+ if (File::Glob::bsd_glob("$FindBin::Bin/etc/schema.*")) {
+ # got schema, load factory module
+ $has_etc{schema}++;
+ $self->load('RTxFactory');
+ $self->postamble(<< ".");
+factory ::
+\t\$(NOECHO) \$(PERL) -Ilib -I"$lib_path" -Minc::Module::Install -e"RTxFactory(qw($RTx $name))"
+
+dropdb ::
+\t\$(NOECHO) \$(PERL) -Ilib -I"$lib_path" -Minc::Module::Install -e"RTxFactory(qw($RTx $name drop))"
+
+.
+ }
+ if (File::Glob::bsd_glob("$FindBin::Bin/etc/acl.*")) {
+ $has_etc{acl}++;
+ }
+ if (-e 'etc/initialdata') {
+ $has_etc{initialdata}++;
+ }
+
+ $self->postamble("$postamble\n");
+ if (%subdirs and !$subdirs{'lib'}) {
+ $self->makemaker_args(
+ PM => { "" => "" },
+ )
+ }
+ else {
+ $self->makemaker_args( INSTALLSITELIB => "$RT::LocalPath/lib" );
+ }
+
+ if (%has_etc) {
+ $self->load('RTxInitDB');
+ print "For first-time installation, type 'make initdb'.\n";
+ my $initdb = '';
+ $initdb .= <<"." if $has_etc{schema};
+\t\$(NOECHO) \$(PERL) -Ilib -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(schema))"
+.
+ $initdb .= <<"." if $has_etc{acl};
+\t\$(NOECHO) \$(PERL) -Ilib -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(acl))"
+.
+ $initdb .= <<"." if $has_etc{initialdata};
+\t\$(NOECHO) \$(PERL) -Ilib -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(insert))"
+.
+ $self->postamble("initdb ::\n$initdb\n");
+ $self->postamble("initialize-database ::\n$initdb\n");
+ }
+}
+
+sub RTxInit {
+ unshift @INC, substr(delete($INC{'RT.pm'}), 0, -5) if $INC{'RT.pm'};
+ require RT;
+ RT::LoadConfig();
+ RT::ConnectToDatabase();
+
+ die "Cannot load RT" unless $RT::Handle and $RT::DatabaseType;
+}
+
+1;
+
+__END__
+
+#line 220
+
+#line 241
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
new file mode 100644
index 0000000..42cb653
--- /dev/null
+++ b/inc/Module/Install/Win32.pm
@@ -0,0 +1,65 @@
+#line 1
+package Module::Install::Win32;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.65';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+# determine if the user needs nmake, and download it if needed
+sub check_nmake {
+ my $self = shift;
+ $self->load('can_run');
+ $self->load('get_file');
+
+ require Config;
+ return unless (
+ $^O eq 'MSWin32' and
+ $Config::Config{make} and
+ $Config::Config{make} =~ /^nmake\b/i and
+ ! $self->can_run('nmake')
+ );
+
+ print "The required 'nmake' executable not found, fetching it...\n";
+
+ require File::Basename;
+ my $rv = $self->get_file(
+ url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
+ ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
+ local_dir => File::Basename::dirname($^X),
+ size => 51928,
+ run => 'Nmake15.exe /o > nul',
+ check_for => 'Nmake.exe',
+ remove => 1,
+ );
+
+ if (!$rv) {
+ die <<'END_MESSAGE';
+
+-------------------------------------------------------------------------------
+
+Since you are using Microsoft Windows, you will need the 'nmake' utility
+before installation. It's available at:
+
+ http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
+ or
+ ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
+
+Please download the file manually, save it to a directory in %PATH% (e.g.
+C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
+that directory, and run "Nmake15.exe" from there; that will create the
+'nmake.exe' file needed by this module.
+
+You may then resume the installation process described in README.
+
+-------------------------------------------------------------------------------
+END_MESSAGE
+ }
+}
+
+1;
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
new file mode 100644
index 0000000..d0908fb
--- /dev/null
+++ b/inc/Module/Install/WriteAll.pm
@@ -0,0 +1,43 @@
+#line 1
+package Module::Install::WriteAll;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.65';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub WriteAll {
+ my $self = shift;
+ my %args = (
+ meta => 1,
+ sign => 0,
+ inline => 0,
+ check_nmake => 1,
+ @_
+ );
+
+ $self->sign(1) if $args{sign};
+ $self->Meta->write if $args{meta};
+ $self->admin->WriteAll(%args) if $self->is_admin;
+
+ if ( $0 =~ /Build.PL$/i ) {
+ $self->Build->write;
+ } else {
+ $self->check_nmake if $args{check_nmake};
+ unless ( $self->makemaker_args->{'PL_FILES'} ) {
+ $self->makemaker_args( PL_FILES => {} );
+ }
+ if ($args{inline}) {
+ $self->Inline->write;
+ } else {
+ $self->Makefile->write;
+ }
+ }
+}
+
+1;
commit 3bb4d91b4f1e7e64894cbbb0b755305f8aca09a4
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu May 10 23:11:56 2007 +0000
add CF
diff --git a/etc/initialdata b/etc/initialdata
new file mode 100644
index 0000000..dd47ee5
--- /dev/null
+++ b/etc/initialdata
@@ -0,0 +1,13 @@
+ at CustomFeilds = (
+ {
+ Name => '_RTIR_SLA',
+ Type => 'SelectSingle',
+ Disabled => 0,
+ Description => 'SLA for Incident Reports RTIR queue',
+ Values => [
+ { Name => 'Full service', SortOrder => 1 },
+ { Name => 'Full service: out of hours', SortOrder => 2 },
+ { Name => 'Reduced service', SortOrder => 3 },
+ ],
+ },
+);
commit 83f7cdb0a5854cc3c4d894b429fbf3d6aee904a2
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri May 11 03:46:40 2007 +0000
add M::I::RTx::Factory
diff --git a/inc/Module/Install/RTx/Factory.pm b/inc/Module/Install/RTx/Factory.pm
new file mode 100644
index 0000000..4508c28
--- /dev/null
+++ b/inc/Module/Install/RTx/Factory.pm
@@ -0,0 +1,483 @@
+#line 1
+package Module::Install::RTx::Factory;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+use strict;
+use File::Basename ();
+
+sub RTxInitDB {
+ my ($self, $action) = @_;
+
+ unshift @INC, substr(delete($INC{'RT.pm'}), 0, -5) if $INC{'RT.pm'};
+
+ require RT;
+ unshift @INC, "$RT::LocalPath/lib" if $RT::LocalPath;
+
+ $RT::SbinPath ||= $RT::LocalPath;
+ $RT::SbinPath =~ s/local$/sbin/;
+
+ foreach my $file ($RT::CORE_CONFIG_FILE, $RT::SITE_CONFIG_FILE) {
+ next if !-e $file or -r $file;
+ die "No permission to read $file\n-- please re-run $0 with suitable privileges.\n";
+ }
+
+ RT::LoadConfig();
+
+ my $lib_path = File::Basename::dirname($INC{'RT.pm'});
+ my @args = ("-Ilib");
+ push @args, "-I$RT::LocalPath/lib" if $RT::LocalPath;
+ push @args, (
+ "-I$lib_path",
+ "$RT::SbinPath/rt-setup-database",
+ "--action" => $action,
+ "--datadir" => "etc",
+ "--datafile" => "etc/initialdata",
+ "--dba" => $RT::DatabaseUser,
+ "--prompt-for-dba-password" => ''
+ );
+ print "$^X @args\n";
+ (system($^X, @args) == 0) or die "...returned with error: $?\n";
+}
+
+sub RTxFactory {
+ my ($self, $RTx, $name, $drop) = @_;
+ my $namespace = "$RTx\::$name";
+
+ $self->RTxInit;
+
+ my $dbh = $RT::Handle->dbh;
+ # get all tables out of database
+ my @tables = $dbh->tables;
+ my ( %tablemap, %typemap, %modulemap );
+ my $driver = $RT::DatabaseType;
+
+ my $CollectionBaseclass = 'RT::SearchBuilder';
+ my $RecordBaseclass = 'RT::Record';
+ my $LicenseBlock = << '.';
+# BEGIN LICENSE BLOCK
+#
+# END LICENSE BLOCK
+.
+ my $Attribution = << '.';
+# Autogenerated by Module::Intall::RTx::Factory
+# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
+#
+# !! DO NOT EDIT THIS FILE !!
+#
+
+use strict;
+.
+ my $RecordInit = '';
+
+ @tables = map { do { {
+ my $table = $_;
+ $table =~ s/.*\.//g;
+ $table =~ s/\W//g;
+ $table =~ s/^\Q$name\E_//i or next;
+ $table ne 'sessions' or next;
+
+ $table = ucfirst(lc($table));
+ $table =~ s/$_/\u$_/ for qw(field group custom member value);
+ $table =~ s/(?<=Scrip)$_/\u$_/ for qw(action condition);
+ $table =~ s/$_/\U$_/ for qw(Acl);
+ $table = $name . '_' . $table;
+
+ $tablemap{$table} = $table;
+ $modulemap{$table} = $table;
+ if ( $table =~ /^(.*)s$/ ) {
+ $tablemap{$1} = $table;
+ $modulemap{$1} = $1;
+ }
+ $table;
+ } } } @tables;
+
+ $tablemap{'CreatedBy'} = 'User';
+ $tablemap{'UpdatedBy'} = 'User';
+
+ $typemap{'id'} = 'ro';
+ $typemap{'Creator'} = 'auto';
+ $typemap{'Created'} = 'auto';
+ $typemap{'Updated'} = 'auto';
+ $typemap{'UpdatedBy'} = 'auto';
+ $typemap{'LastUpdated'} = 'auto';
+ $typemap{'LastUpdatedBy'} = 'auto';
+
+ $typemap{lc($_)} = $typemap{$_} for keys %typemap;
+
+ foreach my $table (@tables) {
+ if ($drop) {
+ $dbh->do("DROP TABLE $table");
+ $dbh->do("DROP sequence ${table}_id_seq") if $driver eq 'Pg';
+ $dbh->do("DROP sequence ${table}_seq") if $driver eq 'Oracle';
+ next;
+ }
+
+ my $tablesingle = $table;
+ $tablesingle =~ s/^\Q$name\E_//i;
+ $tablesingle =~ s/s$//;
+ my $tableplural = $tablesingle . "s";
+
+ if ( $tablesingle eq 'ACL' ) {
+ $tablesingle = "ACE";
+ $tableplural = "ACL";
+ }
+
+ my %requirements;
+
+ my $CollectionClassName = $namespace . "::" . $tableplural;
+ my $RecordClassName = $namespace . "::" . $tablesingle;
+
+ my $path = $namespace;
+ $path =~ s/::/\//g;
+
+ my $RecordClassPath = $path . "/" . $tablesingle . ".pm";
+ my $CollectionClassPath = $path . "/" . $tableplural . ".pm";
+
+ #create a collection class
+ my $CreateInParams;
+ my $CreateOutParams;
+ my $ClassAccessible = "";
+ my $FieldsPod = "";
+ my $CreatePod = "";
+ my $CreateSub = "";
+ my %fields;
+ my $sth = $dbh->prepare("DESCRIBE $table");
+
+ if ( $driver eq 'Pg' ) {
+ $sth = $dbh->prepare(<<".");
+ SELECT a.attname, format_type(a.atttypid, a.atttypmod),
+ a.attnotnull, a.atthasdef, a.attnum
+ FROM pg_class c, pg_attribute a
+ WHERE c.relname ILIKE '$table'
+ AND a.attnum > 0
+ AND a.attrelid = c.oid
+ORDER BY a.attnum
+.
+ }
+ elsif ( $driver eq 'mysql' ) {
+ $sth = $dbh->prepare("DESCRIBE $table");
+ }
+ else {
+ die "$driver is currently unsupported";
+ }
+
+ $sth->execute;
+
+ while ( my $row = $sth->fetchrow_hashref() ) {
+ my ( $field, $type, $default );
+ if ( $driver eq 'Pg' ) {
+
+ $field = $row->{'attname'};
+ $type = $row->{'format_type'};
+ $default = $row->{'atthasdef'};
+
+ if ( $default != 0 ) {
+ my $tth = $dbh->prepare(<<".");
+SELECT substring(d.adsrc for 128)
+ FROM pg_attrdef d, pg_class c
+ WHERE c.relname = 'acct'
+ AND c.oid = d.adrelid
+ AND d.adnum = $row->{'attnum'}
+.
+ $tth->execute();
+ my @default = $tth->fetchrow_array;
+ $default = $default[0];
+ }
+
+ }
+ elsif ( $driver eq 'mysql' ) {
+ $field = $row->{'Field'};
+ $type = $row->{'Type'};
+ $default = $row->{'Default'};
+ }
+
+ $fields{$field} = 1;
+
+ #generate the 'accessible' datastructure
+
+ if ( $typemap{$field} eq 'auto' ) {
+ $ClassAccessible .= " $field =>
+ {read => 1, auto => 1,";
+ }
+ elsif ( $typemap{$field} eq 'ro' ) {
+ $ClassAccessible .= " $field =>
+ {read => 1,";
+ }
+ else {
+ $ClassAccessible .= " $field =>
+ {read => 1, write => 1,";
+
+ }
+
+ $ClassAccessible .= " type => '$type', default => '$default'},\n";
+
+ #generate pod for the accessible fields
+ $FieldsPod .= $self->_pod(<<".");
+^head2 $field
+
+Returns the current value of $field.
+(In the database, $field is stored as $type.)
+
+.
+
+ unless ( $typemap{$field} eq 'auto' || $typemap{$field} eq 'ro' ) {
+ $FieldsPod .= $self->_pod(<<".");
+
+^head2 Set$field VALUE
+
+
+Set $field to VALUE.
+Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
+(In the database, $field will be stored as a $type.)
+
+.
+ }
+
+ $FieldsPod .= $self->_pod(<<".");
+^cut
+
+.
+
+ if ( $modulemap{$field} ) {
+ $FieldsPod .= $self->_pod(<<".");
+^head2 ${field}Obj
+
+Returns the $modulemap{$field} Object which has the id returned by $field
+
+
+^cut
+
+sub ${field}Obj {
+ my \$self = shift;
+ my \$$field = ${namespace}::$modulemap{$field}->new(\$self->CurrentUser);
+ \$$field->Load(\$self->__Value('$field'));
+ return(\$$field);
+}
+.
+ $requirements{ $tablemap{$field} } =
+ "use ${namespace}::$modulemap{$field};";
+
+ }
+
+ unless ( $typemap{$field} eq 'auto' || $field eq 'id' ) {
+
+ #generate create statement
+ $CreateInParams .= " $field => '$default',\n";
+ $CreateOutParams .=
+ " $field => \$args{'$field'},\n";
+
+ #gerenate pod for the create statement
+ $CreatePod .= " $type '$field'";
+ $CreatePod .= " defaults to '$default'" if ($default);
+ $CreatePod .= ".\n";
+
+ }
+
+ }
+
+ $CreateSub = <<".";
+sub Create {
+ my \$self = shift;
+ my \%args = (
+$CreateInParams
+ \@_);
+ \$self->SUPER::Create(
+$CreateOutParams);
+
+}
+.
+ $CreatePod .= "\n=cut\n\n";
+
+ my $CollectionClass = $LicenseBlock . $Attribution . $self->_pod(<<".") . $self->_magic_import($CollectionClassName);
+
+^head1 NAME
+
+$CollectionClassName -- Class Description
+
+^head1 SYNOPSIS
+
+use $CollectionClassName
+
+^head1 DESCRIPTION
+
+
+^head1 METHODS
+
+^cut
+
+package $CollectionClassName;
+
+use $CollectionBaseclass;
+use $RecordClassName;
+
+use vars qw( \@ISA );
+\@ISA= qw($CollectionBaseclass);
+
+
+sub _Init {
+ my \$self = shift;
+ \$self->{'table'} = '$table';
+ \$self->{'primary_key'} = 'id';
+
+.
+
+ if ( $fields{'SortOrder'} ) {
+
+ $CollectionClass .= $self->_pod(<<".");
+
+# By default, order by name
+\$self->OrderBy( ALIAS => 'main',
+ FIELD => 'SortOrder',
+ ORDER => 'ASC');
+.
+ }
+ $CollectionClass .= $self->_pod(<<".");
+ return ( \$self->SUPER::_Init(\@_) );
+}
+
+
+^head2 NewItem
+
+Returns an empty new $RecordClassName item
+
+^cut
+
+sub NewItem {
+ my \$self = shift;
+ return($RecordClassName->new(\$self->CurrentUser));
+}
+.
+
+ my $RecordClassHeader = $Attribution . "
+
+^head1 NAME
+
+$RecordClassName
+
+
+^head1 SYNOPSIS
+
+^head1 DESCRIPTION
+
+^head1 METHODS
+
+^cut
+
+package $RecordClassName;
+use $RecordBaseclass;
+";
+
+ foreach my $key ( keys %requirements ) {
+ $RecordClassHeader .= $requirements{$key} . "\n";
+ }
+ $RecordClassHeader .= <<".";
+
+use vars qw( \@ISA );
+\@ISA= qw( $RecordBaseclass );
+
+sub _Init {
+my \$self = shift;
+
+\$self->Table('$table');
+\$self->SUPER::_Init(\@_);
+}
+
+.
+
+ my $RecordClass = $LicenseBlock . $RecordClassHeader . $self->_pod(<<".") . $self->_magic_import($RecordClassName);
+
+$RecordInit
+
+^head2 Create PARAMHASH
+
+Create takes a hash of values and creates a row in the database:
+
+$CreatePod
+
+$CreateSub
+
+$FieldsPod
+
+sub _CoreAccessible {
+ {
+
+$ClassAccessible
+}
+};
+
+.
+
+ print "About to make $RecordClassPath, $CollectionClassPath\n";
+ `mkdir -p $path`;
+
+ open( RECORD, ">$RecordClassPath" );
+ print RECORD $RecordClass;
+ close(RECORD);
+
+ open( COL, ">$CollectionClassPath" );
+ print COL $CollectionClass;
+ close(COL);
+
+ }
+}
+
+sub _magic_import {
+ my $self = shift;
+ my $class = ref($self) || $self;
+
+ #if (exists \$warnings::{unimport}) {
+ # no warnings qw(redefine);
+
+ my $path = $class;
+ $path =~ s#::#/#gi;
+
+
+ my $content = $self->_pod(<<".");
+ eval \"require ${class}_Overlay\";
+ if (\$@ && \$@ !~ qr{^Can't locate ${path}_Overlay.pm}) {
+ die \$@;
+ };
+
+ eval \"require ${class}_Vendor\";
+ if (\$@ && \$@ !~ qr{^Can't locate ${path}_Vendor.pm}) {
+ die \$@;
+ };
+
+ eval \"require ${class}_Local\";
+ if (\$@ && \$@ !~ qr{^Can't locate ${path}_Local.pm}) {
+ die \$@;
+ };
+
+
+
+
+^head1 SEE ALSO
+
+This class allows \"overlay\" methods to be placed
+into the following files _Overlay is for a System overlay by the original author,
+_Vendor is for 3rd-party vendor add-ons, while _Local is for site-local customizations.
+
+These overlay files can contain new subs or subs to replace existing subs in this module.
+
+If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+
+ no warnings qw(redefine);
+
+so that perl does not kick and scream when you redefine a subroutine or variable in your overlay.
+
+${class}_Overlay, ${class}_Vendor, ${class}_Local
+
+^cut
+
+
+1;
+.
+
+ return $content;
+}
+
+sub _pod {
+ my ($self, $text) = @_;
+ $text =~ s/^\^/=/mg;
+ return $text;
+}
commit a0b186ad3268723ae25e7b832e56f2d43e2244a3
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri May 11 03:53:41 2007 +0000
add conditions
diff --git a/lib/RT/Condition/SLA.pm b/lib/RT/Condition/SLA.pm
new file mode 100644
index 0000000..e97232e
--- /dev/null
+++ b/lib/RT/Condition/SLA.pm
@@ -0,0 +1,14 @@
+
+use strict;
+use warnings;
+
+package RT::Condition::SLA;
+use base qw(RT::Extension::SLA RT::Condition::Generic);
+
+=head1 IsSLAApplied
+
+=cut
+
+sub SLAIsApplied { return 1 }
+
+1;
diff --git a/lib/RT/Condition/SLA/RequireDefault.pm b/lib/RT/Condition/SLA/RequireDefault.pm
new file mode 100644
index 0000000..8ebb060
--- /dev/null
+++ b/lib/RT/Condition/SLA/RequireDefault.pm
@@ -0,0 +1,25 @@
+
+use strict;
+use warnings;
+
+package RT::Condition::SLA::RequireDefault;
+use base qw(RT::Condition::SLA);
+
+=head1 IsApplicable
+
+Applies the current scrip when SLA is not set. Returns true on create,
+but only if SLA CustomField is applied to the ticket and it has no
+value set.
+
+=cut
+
+sub IsApplicable {
+ my $self = shift;
+ return 0 unless $self->TransactionObj->Type eq 'Create';
+ return 0 if $self->TicketObj->FirstCustomFieldValue('SLA');
+ return 0 unless $self->SLAIsApplied;
+ return 1;
+}
+
+1;
+
commit 647b86ac2030c31670da221902a0e2702e7d8b02
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri May 11 03:55:40 2007 +0000
make a class from a module
* SLA::SLA looks wierd, use Agreements instead
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 42a37ec..4be29d0 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -55,26 +55,41 @@ so we'll have something like:
=cut
sub BusinessHours {
+ my $self = shift;
require Business::Hours;
return new Business::Hours;
}
-sub SLA {
+=head2 Aggreements [ Type => 'Response' ]
+
+Returns an instance of L<Business::SLA> class filled with
+service levels for particular Type.
+
+Now we take list of agreements and its description from the
+RT config.
+
+By default Type is 'Response'. 'Resolve' is another type
+we support.
+
+=cut
+
+sub Aggreements {
+ my $self = shift;
my %args = ( Type => 'Response', @_ );
my $class = $RT::SLA{'Module'} || 'Business::SLA';
eval "require $class" or die $@;
my $SLA = $class->new(
- BusinessHours => BusinessHours(),
+ BusinessHours => $self->BusinessHours,
InHoursDefault => $RT::SLA{'InHoursDefault'},
OutOfHoursDefault => $RT::SLA{'OutOfHoursDefault'},
);
my $levels = $RT::SLA{'Levels'};
foreach my $level ( keys %$levels ) {
- my $description = $levels->{ $level }{ $type };
+ my $description = $levels->{ $level }{ $args{'Type'} };
unless ( defined $description ) {
- $RT::Logger->warn("No $type agreement for $level");
+ $RT::Logger->warn("No $args{'Type'} agreement for $level");
next;
}
commit 9baf0a1d1d851cd54d3daa920a709a01f2bd8179
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri May 11 03:57:09 2007 +0000
our actions and conditions are subclasses of RT::Extension::SLA first of all
diff --git a/lib/RT/Action/SLA.pm b/lib/RT/Action/SLA.pm
index 447d58e..88fa9c1 100644
--- a/lib/RT/Action/SLA.pm
+++ b/lib/RT/Action/SLA.pm
@@ -4,8 +4,6 @@ use warnings;
package RT::Action::SLA;
-sub SLA {
-
-}
+use base qw(RT::Extension::SLA RT::Action::Generic);
1;
commit 205bbfe1bdc25dc12b52e722d15c63de2fcd250f
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri May 11 03:57:55 2007 +0000
update things acording to the latest changes
diff --git a/lib/RT/Action/SLA/Set.pm b/lib/RT/Action/SLA/Set.pm
index 0b47a8d..965f991 100644
--- a/lib/RT/Action/SLA/Set.pm
+++ b/lib/RT/Action/SLA/Set.pm
@@ -8,7 +8,7 @@ use base qw(RT::Action::SLA);
=head1 NAME
-RT::Action::SLA::Set - set default SLA value if it's not set
+RT::Action::SLA::Set - set default SLA value
=cut
@@ -16,8 +16,6 @@ sub Prepare { return 1 }
sub Commit {
my $self = shift;
- return 1 if $self->TicketObj->FirstCustomFieldValue('SLA');
-
my $cf = RT::CustomField->new( $self->CurrentUser );
$cf->LoadByNameAndQueue( Queue => $self->TicketObj->Queue, Name => 'SLA' );
unless ( $cf->id ) {
@@ -25,19 +23,23 @@ sub Commit {
return 1;
}
- my $SLAObj = $self->SLA;
- my $sla = $SLAObj->SLA( $self->TransactionObj->CreatedObj->Unix );
- unless ( $sla ) {
- $RT::Logger->error("No default SLA for in hours or/and out of hours time");
- return 0;
+ my $SLA = $self->Agreements;
+ my $level = $SLA->SLA( $self->TransactionObj->CreatedObj->Unix );
+ unless ( $level ) {
+ if ( $SLA->IsInHours( $self->TransactionObj->CreatedObj->Unix ) ) {
+ $RT::Logger->debug("No default service level for in hours time");
+ } else {
+ $RT::Logger->debug("No default service level for out of hours time");
+ }
+ return 1;
}
my ($status, $msg) = $self->TicketObj->AddCustomFieldValue(
Field => $cf->id,
- Value => $sla,
+ Value => $level,
);
unless ( $status ) {
- $RT::Logger->error("Couldn't set SLA: $msg");
+ $RT::Logger->error("Couldn't set service level: $msg");
return 0;
}
commit 11ec5a3f909b48518a5b8f3fc5efbeb225adb2a5
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri May 11 04:06:22 2007 +0000
update docs
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 4be29d0..f11591b 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -105,4 +105,22 @@ sub Aggreements {
return $SLA;
}
+=head1 DESIGN
+
+=head2 Classes
+
+Actions are subclasses of RT::Action::SLA class that is subclass of
+RT::Extension::SLA and RT::Action::Generic classes.
+
+Conditions are subclasses of RT::Condition::SLA class that is subclass of
+RT::Extension::SLA and RT::Condition::Generic classes.
+
+RT::Extension::SLA is a base class for all classes in the extension,
+it provides access to config, generates B::Hours and B::SLA 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' modules.
+
+=cut
+
1;
commit f49c2de41aba6f8b3725ab37dc8ab857cc710dda
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri May 11 04:10:52 2007 +0000
delete a module we've added by accident
* rename an action
* add action/condition to initialdata
diff --git a/etc/initialdata b/etc/initialdata
index dd47ee5..b194f74 100644
--- a/etc/initialdata
+++ b/etc/initialdata
@@ -11,3 +11,19 @@
],
},
);
+
+ at ScripConditions = (
+ { Name => '[SLA] Require Default', # loc
+ Description => 'Detect a situation when we should set default service level' , # loc
+ ApplicableTransTypes => 'Create',
+ ExecModule => 'SLA::RequireDefault',
+ },
+
+);
+
+ at ScripActions = (
+ { Name => '[SLA] Set service level', # loc
+ Description => 'Set the due date to the current time' , # loc
+ ExecModule => 'SLA::SetDefault',
+ },
+);
diff --git a/lib/RT/Action/SLA/Set.pm b/lib/RT/Action/SLA/SetDefault.pm
similarity index 92%
rename from lib/RT/Action/SLA/Set.pm
rename to lib/RT/Action/SLA/SetDefault.pm
index 965f991..2dde794 100644
--- a/lib/RT/Action/SLA/Set.pm
+++ b/lib/RT/Action/SLA/SetDefault.pm
@@ -2,13 +2,13 @@
use strict;
use warnings;
-package RT::Action::SLA::Set;
+package RT::Action::SLA::SetDefault;
use base qw(RT::Action::SLA);
=head1 NAME
-RT::Action::SLA::Set - set default SLA value
+RT::Action::SLA::SetDefault - set default SLA value
=cut
diff --git a/lib/RT/Action/SLA/SetSLA.pm b/lib/RT/Action/SLA/SetSLA.pm
deleted file mode 100644
index 1489952..0000000
--- a/lib/RT/Action/SLA/SetSLA.pm
+++ /dev/null
@@ -1,13 +0,0 @@
-
-use strict;
-use warnings;
-
-package RT::Action::SLA::Set;
-
-sub Prepare {
- return 1;
-}
-
-sub Commit {
- return 1;
-}
commit 1b779d867e27b1792f5259555dd4c26c8338898d
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri May 11 05:14:20 2007 +0000
move things from RT::Action::SLA::* into RT::Action::SLA_*,
RT has no support for :: in exec module :(
diff --git a/lib/RT/Action/SLA/SetDefault.pm b/lib/RT/Action/SLA_SetDefault.pm
similarity index 96%
rename from lib/RT/Action/SLA/SetDefault.pm
rename to lib/RT/Action/SLA_SetDefault.pm
index 2dde794..e67c0e3 100644
--- a/lib/RT/Action/SLA/SetDefault.pm
+++ b/lib/RT/Action/SLA_SetDefault.pm
@@ -2,7 +2,7 @@
use strict;
use warnings;
-package RT::Action::SLA::SetDefault;
+package RT::Action::SLA_SetDefault;
use base qw(RT::Action::SLA);
diff --git a/lib/RT/Action/SLA/SetDue.pm b/lib/RT/Action/SLA_SetDue.pm
similarity index 96%
rename from lib/RT/Action/SLA/SetDue.pm
rename to lib/RT/Action/SLA_SetDue.pm
index a491e20..9e1d5e1 100644
--- a/lib/RT/Action/SLA/SetDue.pm
+++ b/lib/RT/Action/SLA_SetDue.pm
@@ -2,7 +2,7 @@
use strict;
use warnings;
-package RT::Action::SLA::SetDue;
+package RT::Action::SLA_SetDue;
use base qw(RT::Action::SLA);
diff --git a/lib/RT/Action/SLA/SetStarts.pm b/lib/RT/Action/SLA_SetStarts.pm
similarity index 96%
rename from lib/RT/Action/SLA/SetStarts.pm
rename to lib/RT/Action/SLA_SetStarts.pm
index 8899fcc..0f20839 100644
--- a/lib/RT/Action/SLA/SetStarts.pm
+++ b/lib/RT/Action/SLA_SetStarts.pm
@@ -1,7 +1,7 @@
use strict;
use warnings;
-package RT::Action::SLA::SetStarts;
+package RT::Action::SLA_SetStarts;
use base qw(RT::Action::SLA);
commit 4ca8a11bb284a1cb755a4291a1bd9deac2abffc0
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri May 11 06:08:44 2007 +0000
move condition, we have no support of :: in ExecModule field
diff --git a/lib/RT/Condition/SLA/RequireDefault.pm b/lib/RT/Condition/SLA_RequireDefault.pm
similarity index 91%
rename from lib/RT/Condition/SLA/RequireDefault.pm
rename to lib/RT/Condition/SLA_RequireDefault.pm
index 8ebb060..1338c44 100644
--- a/lib/RT/Condition/SLA/RequireDefault.pm
+++ b/lib/RT/Condition/SLA_RequireDefault.pm
@@ -2,7 +2,7 @@
use strict;
use warnings;
-package RT::Condition::SLA::RequireDefault;
+package RT::Condition::SLA_RequireDefault;
use base qw(RT::Condition::SLA);
=head1 IsApplicable
commit 033d6bf3a909b5ca5097ab3c9e4eef296cae9788
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri May 11 06:12:49 2007 +0000
fixes, fixes, fixes
diff --git a/etc/initialdata b/etc/initialdata
index b194f74..47d5de4 100644
--- a/etc/initialdata
+++ b/etc/initialdata
@@ -1,9 +1,10 @@
- at CustomFeilds = (
+ at CustomFields = (
{
- Name => '_RTIR_SLA',
+ Name => 'SLA',
+ Queue => 0,
Type => 'SelectSingle',
Disabled => 0,
- Description => 'SLA for Incident Reports RTIR queue',
+ Description => 'Service Level Agreement',
Values => [
{ Name => 'Full service', SortOrder => 1 },
{ Name => 'Full service: out of hours', SortOrder => 2 },
@@ -13,17 +14,25 @@
);
@ScripConditions = (
- { Name => '[SLA] Require Default', # loc
+ { Name => '[SLA] Require default', # loc
Description => 'Detect a situation when we should set default service level' , # loc
ApplicableTransTypes => 'Create',
- ExecModule => 'SLA::RequireDefault',
+ ExecModule => 'SLA_RequireDefault',
},
);
@ScripActions = (
- { Name => '[SLA] Set service level', # loc
+ { Name => '[SLA] Set default service level', # loc
Description => 'Set the due date to the current time' , # loc
- ExecModule => 'SLA::SetDefault',
+ ExecModule => 'SLA_SetDefault',
},
);
+
+ at Scrips = (
+ { Description => "[SLA] Set default service level if needed",
+ ScripCondition => '[SLA] Require Default',
+ ScripAction => '[SLA] Set service level',
+ Template => 'Blank' },
+);
+
diff --git a/lib/RT/Action/SLA_SetDefault.pm b/lib/RT/Action/SLA_SetDefault.pm
index e67c0e3..2770acd 100644
--- a/lib/RT/Action/SLA_SetDefault.pm
+++ b/lib/RT/Action/SLA_SetDefault.pm
@@ -18,8 +18,9 @@ sub Commit {
my $cf = RT::CustomField->new( $self->CurrentUser );
$cf->LoadByNameAndQueue( Queue => $self->TicketObj->Queue, Name => 'SLA' );
+ $cf->LoadByNameAndQueue( Name => 'SLA' ) unless $cf->id;
unless ( $cf->id ) {
- $RT::Logger->warn("SLA scrip applied to a queue that has no SLA CF");
+ $RT::Logger->warning("SLA scrip applied to a queue that has no SLA CF");
return 1;
}
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index f11591b..ad48dc6 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -60,7 +60,7 @@ sub BusinessHours {
return new Business::Hours;
}
-=head2 Aggreements [ Type => 'Response' ]
+=head2 Agreements [ Type => 'Response' ]
Returns an instance of L<Business::SLA> class filled with
service levels for particular Type.
@@ -73,7 +73,7 @@ we support.
=cut
-sub Aggreements {
+sub Agreements {
my $self = shift;
my %args = ( Type => 'Response', @_ );
@@ -89,7 +89,7 @@ sub Aggreements {
foreach my $level ( keys %$levels ) {
my $description = $levels->{ $level }{ $args{'Type'} };
unless ( defined $description ) {
- $RT::Logger->warn("No $args{'Type'} agreement for $level");
+ $RT::Logger->warning("No $args{'Type'} agreement for $level");
next;
}
commit b31b9e1bc1d31aaecaa9a725b65b4c7ae9c84801
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri May 11 21:25:34 2007 +0000
new condition
diff --git a/lib/RT/Condition/SLA_RequireDueSet.pm b/lib/RT/Condition/SLA_RequireDueSet.pm
new file mode 100644
index 0000000..25748eb
--- /dev/null
+++ b/lib/RT/Condition/SLA_RequireDueSet.pm
@@ -0,0 +1,31 @@
+use strict;
+use warnings;
+
+package RT::Condition::SLA_RequireDueSet;
+
+use base qw(RT::Condition::SLA);
+
+=head1 NAME
+
+RT::Condition::SLA_RequireDueSet - checks if Due date require update
+
+=head1 DESCRIPTION
+
+Checks if Due date require update. This should be done when we create
+a ticket and it has service level value or when we set serveice level.
+
+=cut
+
+sub IsApplicable {
+ my $self = shift;
+ return 0 unless $self->SLAIsApplied;
+
+ if ( $self->TransactionObj->Type eq 'Create' ) {
+ return 1 if $self->TicketObj->FirstCustomFieldValue('SLA');
+ } elsif ( $self->TransactionObj->Type eq 'Create' ) {
+ return 1 if $self->IsCustomFieldChange('SLA');
+ }
+ return 0;
+}
+
+1;
commit f094f3bff0e85273e2d11a0b9cc069fcf8a1e1af
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri May 11 21:38:26 2007 +0000
docs update
diff --git a/lib/RT/Action/SLA_SetDefault.pm b/lib/RT/Action/SLA_SetDefault.pm
index 2770acd..2c958c0 100644
--- a/lib/RT/Action/SLA_SetDefault.pm
+++ b/lib/RT/Action/SLA_SetDefault.pm
@@ -10,6 +10,18 @@ use base qw(RT::Action::SLA);
RT::Action::SLA::SetDefault - set default SLA value
+=head1 DESCRIPTION
+
+Sets a default level of service. Transaction's created field is used
+to calculate if things happen in hours or out of. Default value then
+figured from L<InHoursDefault|XXX> and L<OutOfHoursDefault|XXX> options.
+
+This action doesn't check if the ticket has a value allready, so you
+have to use it with condition that checks this fact for you, however
+such behaviour allows you to force setting up default using custom
+condition. The default condition for this action is
+L<RT::Condition::SLA_RequireDefault>.
+
=cut
sub Prepare { return 1 }
commit 700b183fc3142ab2bdb6bf0726bd2cb0244270b3
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri May 11 21:39:47 2007 +0000
add new method into RT::ConditionSLA
diff --git a/lib/RT/Condition/SLA.pm b/lib/RT/Condition/SLA.pm
index e97232e..2359a86 100644
--- a/lib/RT/Condition/SLA.pm
+++ b/lib/RT/Condition/SLA.pm
@@ -11,4 +11,26 @@ use base qw(RT::Extension::SLA RT::Condition::Generic);
sub SLAIsApplied { return 1 }
+=head1 IsCustomFieldChange
+
+=cut
+
+sub IsCustomFieldChange {
+ my $self = shift;
+ my $cf_name = shift;
+
+ my $txn = $self->TransactionObj;
+
+ return 0 unless $txn->Type eq 'CustomField';
+
+ my $cf = $self->TicketObj->QueueObj->CustomField( $cf_name );
+ unless ( $cf->id ) {
+ $RT::Logger->error("Couldn't load the '$cf_name' field");
+ return 0;
+ }
+
+ return 0 unless $cf->id == $txn->Field;
+ return 1;
+}
+
1;
commit c81a74f7648e9f16cbfd92c810001982c677a680
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon May 14 17:23:28 2007 +0000
add GetCustomField method
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index ad48dc6..51ce4aa 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -105,6 +105,18 @@ sub Agreements {
return $SLA;
}
+sub GetCustomField {
+ my $self = shift;
+ my %args = (Ticket => undef, CustomField => 'SLA', @_);
+ unless ( $args{'Ticket'} ) {
+ $args{'Ticket'} = $self->TicketObj if $self->can('TicketObj');
+ }
+ unless ( $args{'Ticket'} ) {
+ return RT::CustomField->new( $RT::SystemUser );
+ }
+ return $args{'Ticket'}->QueueObj->CustomField( $args{'CustomField'} );
+}
+
=head1 DESIGN
=head2 Classes
commit 900ecfeab89a73921d5b42d8495af6e7a8532043
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon May 14 17:30:28 2007 +0000
use GetCustomField
diff --git a/lib/RT/Action/SLA_SetDefault.pm b/lib/RT/Action/SLA_SetDefault.pm
index 2c958c0..811f4d3 100644
--- a/lib/RT/Action/SLA_SetDefault.pm
+++ b/lib/RT/Action/SLA_SetDefault.pm
@@ -28,9 +28,7 @@ sub Prepare { return 1 }
sub Commit {
my $self = shift;
- my $cf = RT::CustomField->new( $self->CurrentUser );
- $cf->LoadByNameAndQueue( Queue => $self->TicketObj->Queue, Name => 'SLA' );
- $cf->LoadByNameAndQueue( Name => 'SLA' ) unless $cf->id;
+ my $cf = $self->GetCustomField;
unless ( $cf->id ) {
$RT::Logger->warning("SLA scrip applied to a queue that has no SLA CF");
return 1;
commit 6772e835714c9900a82aae77d9639a4b48a0e31f
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon May 14 17:35:48 2007 +0000
implement SetStarts action
diff --git a/lib/RT/Action/SLA_SetStarts.pm b/lib/RT/Action/SLA_SetStarts.pm
index 0f20839..77ed03a 100644
--- a/lib/RT/Action/SLA_SetStarts.pm
+++ b/lib/RT/Action/SLA_SetStarts.pm
@@ -5,34 +5,35 @@ package RT::Action::SLA_SetStarts;
use base qw(RT::Action::SLA);
-=head2 Prepare
+=head1 NAME
-Always run this action.
+RT::Action::SLA_SetStarts - set starts date field of a ticket according to SLA
-=cut
-
-sub Prepare { return 1 }
+=head1 DESCRIPTION
-=head2 Commit
+Look up the SLA of the ticket and set the Starts date accordingly. Nothing happens
+if the ticket has no SLA defined.
-Look up the SLA and set the Starts date accordingly unless it's allready set.
+Note that this action doesn't check if Starts field is set already, so you can
+use it set the field in a force mode or can protect field using a condition
+that checks value of Starts.
=cut
+sub Prepare { return 1 }
+
sub Commit {
my $self = shift;
my $ticket = $self->TicketObj;
+ my $level = $ticket->FirstCustomFieldValue('SLA');
+ unless ( $level ) {
+ $RT::Logger->debug('Ticket #'. $ticket->id .' has no dervice level defined, skip setting Starts');
+ return 1;
+ }
- # get out of here if have date set
- return 1 $ticket->StartsObj->Unix > 0;
-
- # XXX: we must use SLA to set starts
- my $bizhours = RT::Estension::SLA::BusinessHours();
-
- my $starts = $bizhours->first_after(
- $self->TransactionObj->CreatedObj->Unix
- );
+ my $SLA = $self->Agreements;
+ my $starts = $SLA->Starts( $self->TransactionObj->CreatedObj->Unix, $level );
my $date = RT::Date->new($RT::SystemUser);
$date->Set( Format => 'unix', Value => $starts );
commit 07e3429e1c747a6d9c87421aa254f5a104e2a749
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon May 14 17:41:31 2007 +0000
add default RequireStartsSet condition
diff --git a/lib/RT/Condition/SLA_RequireStartsSet.pm b/lib/RT/Condition/SLA_RequireStartsSet.pm
new file mode 100644
index 0000000..88a809e
--- /dev/null
+++ b/lib/RT/Condition/SLA_RequireStartsSet.pm
@@ -0,0 +1,25 @@
+use strict;
+use warnings;
+
+package RT::Condition::SLA_RequireStartsSet;
+
+use base qw(RT::Condition::SLA);
+
+=head1 NAME
+
+RT::Condition::SLA_RequireStartsSet - checks if Starts date is not set
+
+=head1 DESCRIPTION
+
+Applies if Starts date is not set for the ticket.
+
+=cut
+
+sub IsApplicable {
+ my $self = shift;
+ return 0 if $self->TicketObj->StartsObj->Unix > 0;
+ return 1;
+}
+
+1;
+
commit e73b230085fd09cb4bf363131991c9f3282b0a7a
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon May 14 17:54:02 2007 +0000
update initialdata
diff --git a/etc/initialdata b/etc/initialdata
index 47d5de4..7bc31f9 100644
--- a/etc/initialdata
+++ b/etc/initialdata
@@ -19,13 +19,21 @@
ApplicableTransTypes => 'Create',
ExecModule => 'SLA_RequireDefault',
},
-
+ { Name => '[SLA] Require Starts set', # loc
+ Description => 'Detect a situation when we should set Starts date' , # loc
+ ApplicableTransTypes => 'Create',
+ ExecModule => 'SLA_RequireStartsSet',
+ },
);
@ScripActions = (
{ Name => '[SLA] Set default service level', # loc
- Description => 'Set the due date to the current time' , # loc
- ExecModule => 'SLA_SetDefault',
+ Description => 'Set service level according to the config' , # loc
+ ExecModule => 'SLA_SetDefault',
+ },
+ { Name => '[SLA] Set starts date', # loc
+ Description => 'Set the starts date according to an agreement' , # loc
+ ExecModule => 'SLA_SetStarts',
},
);
@@ -34,5 +42,9 @@
ScripCondition => '[SLA] Require Default',
ScripAction => '[SLA] Set service level',
Template => 'Blank' },
+ { Description => "[SLA] Set starts date if needed",
+ ScripCondition => '[SLA] Require starts set',
+ ScripAction => '[SLA] Set starts date',
+ Template => 'Blank' },
);
commit dd88a3f2c7c8659b1868b854ded1a34961bb4e7f
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon May 14 20:33:28 2007 +0000
simple tests
diff --git a/t/basics.t b/t/basics.t
new file mode 100644
index 0000000..8d73e46
--- /dev/null
+++ b/t/basics.t
@@ -0,0 +1,11 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+
+use_ok 'RT::Extension::SLA';
+
+
+1;
diff --git a/t/starts.t b/t/starts.t
new file mode 100644
index 0000000..59ba3ed
--- /dev/null
+++ b/t/starts.t
@@ -0,0 +1,17 @@
+#!/usr/bin/perl -w
+
+use Test::More tests => 10;
+
+require 't/utils.pl';
+
+use_ok 'RT';
+RT::LoadConfig();
+RT::Init();
+
+use_ok 'RT::Ticket';
+
+{
+ my $ticket = RT::Ticket->new( $RT::SystemUser );
+ my ($id) = $ticket->Create( Queue => 'General', Subject => 'xxx' );
+ ok $id, "created ticket #$id";
+}
diff --git a/t/utils.pl b/t/utils.pl
new file mode 100644
index 0000000..800b719
--- /dev/null
+++ b/t/utils.pl
@@ -0,0 +1,11 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+BEGIN {
+### after: push @INC, qw(@RT_LIB_PATH@);
+ push @INC, qw(/opt/rt3/local/lib /opt/rt3/lib);
+}
+
+1;
commit f0ca670fd6c95378e9b0b2ee0af4b9d3b63886f0
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon May 14 20:34:30 2007 +0000
update M::I, META and makefile
diff --git a/META.yml b/META.yml
index 108d4f4..248dea6 100644
--- a/META.yml
+++ b/META.yml
@@ -12,6 +12,7 @@ meta-spec:
name: RT-Extension-SLA
no_index:
directory:
+ - etc
- inc
- t
requires:
diff --git a/Makefile.PL b/Makefile.PL
index c1e6c5b..9e94688 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -10,4 +10,18 @@ requires('Business::SLA');
requires('Business::Hours');
auto_install();
+my ($lp) = ($INC{'RT.pm'} =~ /^(.*)[\\\/]/);
+my $lib_path = join( ' ', "$RT::LocalPath/lib", $lp );
+my $sbin_path = $RT::SbinPath || "$RT::BasePath/sbin" || "/opt/rt3/sbin";
+my $bin_path = $RT::BinPath || "$RT::BasePath/bin" || "/opt/rt3/bin";
+
+substitute(
+ {
+ RT_LIB_PATH => $lib_path,
+ RT_BIN_PATH => $bin_path,
+ RT_SBIN_PATH => $sbin_path,
+ },
+ qw(t/utils.pl),
+);
+
WriteAll();
diff --git a/inc/Module/Install/Substitute.pm b/inc/Module/Install/Substitute.pm
new file mode 100644
index 0000000..95ff9a7
--- /dev/null
+++ b/inc/Module/Install/Substitute.pm
@@ -0,0 +1,128 @@
+#line 1
+package Module::Install::Substitute;
+
+use vars qw(@ISA);
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+use strict;
+use warnings;
+
+$Module::Install::Substitute::VERSION = '0.02';
+
+require File::Temp;
+require File::Spec;
+require Cwd;
+
+#line 64
+
+sub substitute
+{
+ my $self = shift;
+ $self->{__subst} = shift;
+ $self->{__option} = {};
+ if( UNIVERSAL::isa( $_[0], 'HASH' ) ) {
+ my $opts = shift;
+ while( my ($k,$v) = each( %$opts ) ) {
+ $self->{__option}->{ lc( $k ) } = $v || '';
+ }
+ }
+ $self->_parse_options;
+
+ my @file = @_;
+ foreach my $f (@file) {
+ $self->_rewrite_file( $f );
+ }
+
+ return;
+}
+
+sub _parse_options
+{
+ my $self = shift;
+ my $cwd = Cwd::getcwd();
+ foreach my $t ( qw(from to) ) {
+ $self->{__option}->{$t} = $cwd unless $self->{__option}->{$t};
+ my $d = $self->{__option}->{$t};
+ die "Couldn't read directory '$d'" unless -d $d && -r _;
+ }
+}
+
+sub _rewrite_file
+{
+ my ($self, $file) = @_;
+ my $source = File::Spec->catfile( $self->{__option}{from}, $file );
+ $source .= $self->{__option}{sufix} if $self->{__option}{sufix};
+ unless( -f $source && -r _ ) {
+ print STDERR "Couldn't find file '$source'\n";
+ return;
+ }
+ my $dest = File::Spec->catfile( $self->{__option}{to}, $file );
+ return $self->__rewrite_file( $source, $dest );
+}
+
+sub __rewrite_file
+{
+ my ($self, $source, $dest) = @_;
+
+ my $mode = (stat($source))[2];
+
+ open my $sfh, "<$source" or die "Couldn't open '$source' for read";
+ print "Open input '$source' file for substitution\n";
+
+ my ($tmpfh, $tmpfname) = File::Temp::tempfile('mi-subst-XXXX', UNLINK => 1);
+ $self->__process_streams( $sfh, $tmpfh, ($source eq $dest)? 1: 0 );
+ close $sfh;
+
+ seek $tmpfh, 0, 0 or die "Couldn't seek in tmp file";
+
+ open my $dfh, ">$dest" or die "Couldn't open '$dest' for write";
+ print "Open output '$dest' file for substitution\n";
+
+ while( <$tmpfh> ) {
+ print $dfh $_;
+ }
+ close $dfh;
+ chmod $mode, $dest or "Couldn't change mode on '$dest'";
+}
+
+sub __process_streams
+{
+ my ($self, $in, $out, $replace) = @_;
+
+ my @queue = ();
+ my $subst = $self->{'__subst'};
+ my $re_subst = join('|', map {"\Q$_"} keys %{ $subst } );
+
+ while( my $str = <$in> ) {
+ if( $str =~ /^###\s*(before|replace|after)\: ?(.*)$/s ) {
+ my ($action, $nstr) = ($1,$2);
+ $nstr =~ s/\@($re_subst)\@/$subst->{$1}/ge;
+
+ $action = 'before' if !$replace && $action eq 'replace';
+ if( $action eq 'before' ) {
+ die "no line before 'before' action" unless @queue;
+ # overwrite prev line;
+ pop @queue;
+ push @queue, $nstr;
+ push @queue, $str;
+ } elsif( $action eq 'replace' ) {
+ push @queue, $nstr;
+ } elsif( $action eq 'after' ) {
+ push @queue, $str;
+ push @queue, $nstr;
+ # skip one line;
+ <$in>;
+ }
+ } else {
+ push @queue, $str;
+ }
+ while( @queue > 3 ) {
+ print $out shift(@queue);
+ }
+ }
+ while( scalar @queue ) {
+ print $out shift(@queue);
+ }
+}
+
+1;
commit 633228f2ae1ed9137815b3683d4b8c8510e97815
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon May 14 20:34:55 2007 +0000
add manifest
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..7bbf363
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,30 @@
+etc/initialdata
+inc/Module/AutoInstall.pm
+inc/Module/Install.pm
+inc/Module/Install/AutoInstall.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Include.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/RTx.pm
+inc/Module/Install/RTx/Factory.pm
+inc/Module/Install/Substitute.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/RT/Action/SLA.pm
+lib/RT/Action/SLA_SetDefault.pm
+lib/RT/Action/SLA_SetDue.pm
+lib/RT/Action/SLA_SetStarts.pm
+lib/RT/Condition/SLA.pm
+lib/RT/Condition/SLA_RequireDefault.pm
+lib/RT/Condition/SLA_RequireDueSet.pm
+lib/RT/Condition/SLA_RequireStartsSet.pm
+lib/RT/Extension/SLA.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+t/basics.t
+t/starts.t
+t/utils.pl
commit 074544994bdf6ba41b720a88e1774b4d734d2120
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon May 14 20:35:13 2007 +0000
typo
diff --git a/etc/initialdata b/etc/initialdata
index 7bc31f9..b20f979 100644
--- a/etc/initialdata
+++ b/etc/initialdata
@@ -40,7 +40,7 @@
@Scrips = (
{ Description => "[SLA] Set default service level if needed",
ScripCondition => '[SLA] Require Default',
- ScripAction => '[SLA] Set service level',
+ ScripAction => '[SLA] Set default service level',
Template => 'Blank' },
{ Description => "[SLA] Set starts date if needed",
ScripCondition => '[SLA] Require starts set',
commit d0b668b76fabdaf26993eec354fcc6366d1b8744
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Oct 22 14:51:43 2007 +0000
fix docs typo
diff --git a/lib/RT/Condition/SLA_RequireDueSet.pm b/lib/RT/Condition/SLA_RequireDueSet.pm
index 25748eb..3d68e71 100644
--- a/lib/RT/Condition/SLA_RequireDueSet.pm
+++ b/lib/RT/Condition/SLA_RequireDueSet.pm
@@ -12,7 +12,7 @@ RT::Condition::SLA_RequireDueSet - checks if Due date require update
=head1 DESCRIPTION
Checks if Due date require update. This should be done when we create
-a ticket and it has service level value or when we set serveice level.
+a ticket and it has service level value or when we set service level.
=cut
commit 1d5ec01ad9537838c8cc7bc5cf176faff8eda883
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Oct 22 15:01:50 2007 +0000
use different levels for replies and responses
diff --git a/lib/RT/Action/SLA_SetDue.pm b/lib/RT/Action/SLA_SetDue.pm
index 9e1d5e1..9c819de 100644
--- a/lib/RT/Action/SLA_SetDue.pm
+++ b/lib/RT/Action/SLA_SetDue.pm
@@ -33,22 +33,33 @@ Set the Due date accordingly to SLA.
sub Commit {
my $self = shift;
- my $time = $self->TransactionObj->CreatedObj->Unix;
-
- my $due = $SLAObj->Due( $time, $SLAObj->SLA( $time ) );
-
- my $current_due = $self->TicketObj->DueObj->Unix;
-
- if ( $current_due && $current_due > 0 && $current_due < $due ) {
- $RT::Logger->debug("Ticket #". $self->TicketObj->id ." has due earlier than by SLA");
+ my $level = $ticket->FirstCustomFieldValue('SLA');
+ unless ( $level ) {
+ $RT::Logger->debug('Ticket #'. $ticket->id .' has no service level defined, skip setting Starts');
return 1;
}
+ my $due = $self->EarliestDue( $level );
+
my $date = RT::Date->new( $RT::SystemUser );
$date->Set( Format => 'unix', Value => $due );
- $self->TicketObj->SetDue( $date->ISO );
+ my ($status, $msg) = $self->TicketObj->SetDue( $date->ISO );
+ unless ( $status ) {
+ $RT::Logger->error("Couldn't set due date: $msg");
+ return 0;
+ }
return 1;
}
+sub EarliestDue {
+ my $self = shift;
+ my $level = shift;
+
+ my $time = $self->TransactionObj->CreatedObj->Unix;
+ my $response_due = $self->Agreements( Type => 'Response' )->Due( $time, $level );
+ my $resolve_due = $self->Agreements( Type => 'Resolve' )->Due( $time, $level );
+ return $resolve_due < $response_due? $resolve_due : $response_due;
+}
+
1;
commit 3aa316d51f96006af6b2ea448e55cb8d910c3230
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Oct 22 15:23:08 2007 +0000
for resolve due use ticket's created time
diff --git a/lib/RT/Action/SLA_SetDue.pm b/lib/RT/Action/SLA_SetDue.pm
index 9c819de..f668d71 100644
--- a/lib/RT/Action/SLA_SetDue.pm
+++ b/lib/RT/Action/SLA_SetDue.pm
@@ -56,9 +56,10 @@ sub EarliestDue {
my $self = shift;
my $level = shift;
- my $time = $self->TransactionObj->CreatedObj->Unix;
- my $response_due = $self->Agreements( Type => 'Response' )->Due( $time, $level );
- my $resolve_due = $self->Agreements( Type => 'Resolve' )->Due( $time, $level );
+ my $response_due = $self->Agreements( Type => 'Response' )
+ ->Due( $self->TransactionObj->CreatedObj->Unix, $level );
+ my $resolve_due = $self->Agreements( Type => 'Resolve' )
+ ->Due( $self->TicketObj->CreatedObj->Unix, $level );
return $resolve_due < $response_due? $resolve_due : $response_due;
}
commit 751a5510ad0928c798798d2208d701b419fdcc9e
Author: sunnavy <sunnavy at bestpractical.com>
Date: Mon Oct 22 17:44:47 2007 +0000
doc fix
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 51ce4aa..891dfe6 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -15,7 +15,7 @@ RT::Extension::SLA - Service Level Agreements
* several agreement levels
* options:
** InHoursDefault - default service level ticket created during business hours, but only if level hasn't been set
-** OutOfHoursDefault - default service level ticket created during business hours, but only if level hasn't been set
+** OutOfHoursDefault - default service level ticket created out of business hours, but only if level hasn't been set
** Levels - each level has definition of agreements for Response and Resolve
*** If you set a requirement for response then we set due date on create or as soon as user replies to some a in the feature, so due date means deadline for reply, as soon as somebody who is not a requestor replies we unset due
*** if you set a requirement for resolve then we set due date on create to a point in the feature, so due date defines deadline for ticket resolving
commit 6b550f98f7a1df70fdb1a088fc5f09236a7bc32d
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Oct 24 13:47:58 2007 +0000
docs update
diff --git a/lib/RT/Action/SLA_SetStarts.pm b/lib/RT/Action/SLA_SetStarts.pm
index 77ed03a..56e8537 100644
--- a/lib/RT/Action/SLA_SetStarts.pm
+++ b/lib/RT/Action/SLA_SetStarts.pm
@@ -15,7 +15,7 @@ Look up the SLA of the ticket and set the Starts date accordingly. Nothing happe
if the ticket has no SLA defined.
Note that this action doesn't check if Starts field is set already, so you can
-use it set the field in a force mode or can protect field using a condition
+use it to set the field in a force mode or can protect field using a condition
that checks value of Starts.
=cut
@@ -28,7 +28,7 @@ sub Commit {
my $ticket = $self->TicketObj;
my $level = $ticket->FirstCustomFieldValue('SLA');
unless ( $level ) {
- $RT::Logger->debug('Ticket #'. $ticket->id .' has no dervice level defined, skip setting Starts');
+ $RT::Logger->debug('Ticket #'. $ticket->id .' has no service level defined, skip setting Starts');
return 1;
}
commit f94f5202ddf1e124dcd5921ae8767493bca442a8
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Oct 24 14:36:08 2007 +0000
add GetDefaultServiceLevel method
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 891dfe6..3beccdb 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -117,6 +117,21 @@ sub GetCustomField {
return $args{'Ticket'}->QueueObj->CustomField( $args{'CustomField'} );
}
+sub GetDefaultServiceLevel {
+ my $self = shift;
+ my %args = (Ticket => undef, Queue => undef, @_);
+ unless ( $args{'Queue'} || $args{'Ticket'} ) {
+ $args{'Ticket'} = $self->TicketObj if $self->can('TicketObj');
+ }
+ if ( !$args{'Queue'} && $args{'Ticket'} ) {
+ $args{'Queue'} = $args{'Ticket'}->QueueObj;
+ }
+ if ( $args{'Queue'} ) {
+ # TODO: here we should implement per queue defaults
+ }
+ return $RT::SLA{'Default'};
+}
+
=head1 DESIGN
=head2 Classes
commit 1d710dc8acd7c00ee2677d16d1e001872a41f5be
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Oct 24 14:38:21 2007 +0000
use new method so we have now one default service level for a ticket,
based on config or per queue(TODO)
diff --git a/lib/RT/Action/SLA_SetDefault.pm b/lib/RT/Action/SLA_SetDefault.pm
index 811f4d3..b02ed74 100644
--- a/lib/RT/Action/SLA_SetDefault.pm
+++ b/lib/RT/Action/SLA_SetDefault.pm
@@ -34,14 +34,11 @@ sub Commit {
return 1;
}
- my $SLA = $self->Agreements;
- my $level = $SLA->SLA( $self->TransactionObj->CreatedObj->Unix );
+ my $level = $self->GetDefaultServiceLevel;
unless ( $level ) {
- if ( $SLA->IsInHours( $self->TransactionObj->CreatedObj->Unix ) ) {
- $RT::Logger->debug("No default service level for in hours time");
- } else {
- $RT::Logger->debug("No default service level for out of hours time");
- }
+ $RT::Logger->info(
+ "No default service level for ticket #". $self->TicketObj->id
+ ." in queue ". $self->TicketObj->QueueObj->Name;
return 1;
}
commit baccf32acb53104fab6580142b18e31ce0f2ec81
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Oct 24 15:21:43 2007 +0000
implement OutOfHours modifier
diff --git a/lib/RT/Action/SLA_SetDue.pm b/lib/RT/Action/SLA_SetDue.pm
index f668d71..f2e90c1 100644
--- a/lib/RT/Action/SLA_SetDue.pm
+++ b/lib/RT/Action/SLA_SetDue.pm
@@ -56,10 +56,16 @@ sub EarliestDue {
my $self = shift;
my $level = shift;
- my $response_due = $self->Agreements( Type => 'Response' )
- ->Due( $self->TransactionObj->CreatedObj->Unix, $level );
- my $resolve_due = $self->Agreements( Type => 'Resolve' )
- ->Due( $self->TicketObj->CreatedObj->Unix, $level );
+ my $response_time = $self->TransactionObj->CreatedObj->Unix;
+ my $response_due = $self->Agreements(
+ Type => 'Response', Time => $response_time
+ )->Due( $response_time, $level );
+
+ my $create_time = $self->TicketObj->CreatedObj->Unix;
+ my $resolve_due = $self->Agreements(
+ Type => 'Resolve', Time => $create_time
+ )->Due( $create_time, $level );
+
return $resolve_due < $response_due? $resolve_due : $response_due;
}
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 3beccdb..80fa0d6 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -25,13 +25,16 @@ RT::Extension::SLA - Service Level Agreements
so we'll have something like:
%SLA => (
- InHoursDefault => 'one real hour for reply',
- OutOfHoursDefault => 'two business hours for reply',
+ Default => 'two business hours for reply',
Levels => {
'one real hour for reply' => { Response => { RealMinutes => 60 } },
'two business hours for reply' => { Response => { BusinessMinutes => 60*2 } },
'8 business hours for resolve' => { Resolve => { BusinessMinutes => 60*8 } },
'two b-hours for reply and 3 real days for resolve' => {
+ OutOfHours => {
+ Response => { RealMinutes => +60 },
+ Resolve => { RealMinutes => +60*24 },
+ },
Response => { BusinessMinutes => 60*2 },
Resolve => { RealMinutes => 60*24*3 },
},
@@ -75,31 +78,43 @@ we support.
sub Agreements {
my $self = shift;
- my %args = ( Type => 'Response', @_ );
+ my %args = ( Type => 'Response', Time => undef, @_ );
my $class = $RT::SLA{'Module'} || 'Business::SLA';
eval "require $class" or die $@;
- my $SLA = $class->new(
- BusinessHours => $self->BusinessHours,
- InHoursDefault => $RT::SLA{'InHoursDefault'},
- OutOfHoursDefault => $RT::SLA{'OutOfHoursDefault'},
- );
+ my $SLA = $class->new( BusinessHours => $self->BusinessHours );
+
+ my $out_of_hours = 0;
+ if ( $args{'Time'} && !$SLA->IsInHours( $args{'Time'} ) ) {
+ $out_of_hours = 1;
+ }
my $levels = $RT::SLA{'Levels'};
- foreach my $level ( keys %$levels ) {
- my $description = $levels->{ $level }{ $args{'Type'} };
- unless ( defined $description ) {
- $RT::Logger->warning("No $args{'Type'} agreement for $level");
+ while ( my ($level, $meta) = each %$levels ) {
+ unless ( defined $meta->{ $args{'Type'} } ) {
+ $RT::Logger->warning("No $args{'Type'} agreement for '$level' service level");
next;
}
- if ( ref $description ) {
- $SLA->Add( $level => %$description );
- } elsif ( $levels->{ $level } =~ /^\d+$/ ) {
- $SLA->Add( $level => BusinessMinutes => $description );
+ my %props;
+ if ( ref $meta->{ $args{'Type'} } ) {
+ %props = %{ $meta->{ $args{'Type'} } };
+ } elsif ( $meta->{ $args{'Type'} } =~ /^\d+$/ ) {
+ %props = ( BusinessMinutes => $meta->{ $args{'Type'} } );
} else {
$RT::Logger->error("Levels of SLA should be either number or hash ref");
+ next;
}
+
+ if ( $out_of_hours and my $tmp = $meta->{ 'OutOfHours' }{ $args{'Type'} } ) {
+ foreach ( qw(RealMinutes BusinessMinutes) ) {
+ next unless $tmp->{ $_ };
+ $props{ $_ } ||= 0;
+ $props{ $_ } += $tmp->{ $_ };
+ }
+ }
+
+ $SLA->Add( $level => %props );
}
return $SLA;
commit f62a6ee54fd9e289faa61f10fbbfdb281322a8bb
Author: sunnavy <sunnavy at bestpractical.com>
Date: Wed Oct 24 17:23:34 2007 +0000
lack a )
diff --git a/lib/RT/Action/SLA_SetDefault.pm b/lib/RT/Action/SLA_SetDefault.pm
index b02ed74..4983ff5 100644
--- a/lib/RT/Action/SLA_SetDefault.pm
+++ b/lib/RT/Action/SLA_SetDefault.pm
@@ -38,7 +38,7 @@ sub Commit {
unless ( $level ) {
$RT::Logger->info(
"No default service level for ticket #". $self->TicketObj->id
- ." in queue ". $self->TicketObj->QueueObj->Name;
+ ." in queue ". $self->TicketObj->QueueObj->Name );
return 1;
}
commit 37f59743a0efc112d84c2357a77e7d5b905a58d2
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Oct 24 21:16:38 2007 +0000
update initial data
diff --git a/etc/initialdata b/etc/initialdata
index b20f979..58f94a9 100644
--- a/etc/initialdata
+++ b/etc/initialdata
@@ -5,11 +5,7 @@
Type => 'SelectSingle',
Disabled => 0,
Description => 'Service Level Agreement',
- Values => [
- { Name => 'Full service', SortOrder => 1 },
- { Name => 'Full service: out of hours', SortOrder => 2 },
- { Name => 'Reduced service', SortOrder => 3 },
- ],
+ Values => [ ],
},
);
@@ -21,9 +17,14 @@
},
{ Name => '[SLA] Require Starts set', # loc
Description => 'Detect a situation when we should set Starts date' , # loc
- ApplicableTransTypes => 'Create',
+ ApplicableTransTypes => 'Create,CustomField',
ExecModule => 'SLA_RequireStartsSet',
},
+ { Name => '[SLA] Require Due set', # loc
+ Description => 'Detect a situation when we should set Due date' , # loc
+ ApplicableTransTypes => 'Create,CustomField',
+ ExecModule => 'SLA_RequireDueSet',
+ },
);
@ScripActions = (
@@ -35,6 +36,10 @@
Description => 'Set the starts date according to an agreement' , # loc
ExecModule => 'SLA_SetStarts',
},
+ { Name => '[SLA] Set due date', # loc
+ Description => 'Set the due date according to an agreement' , # loc
+ ExecModule => 'SLA_SetDue',
+ },
);
@Scrips = (
@@ -46,5 +51,9 @@
ScripCondition => '[SLA] Require starts set',
ScripAction => '[SLA] Set starts date',
Template => 'Blank' },
+ { Description => "[SLA] Set due date if needed",
+ ScripCondition => '[SLA] Require due set',
+ ScripAction => '[SLA] Set due date',
+ Template => 'Blank' },
);
commit c1f75f37a40e5314a3529d53a08f5d2e40d45c32
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Oct 24 21:17:33 2007 +0000
update M::I
diff --git a/META.yml b/META.yml
index 248dea6..54a2088 100644
--- a/META.yml
+++ b/META.yml
@@ -4,7 +4,7 @@ author: Ruslan Zakirov <ruz at bestpractical.com>
build_requires:
Test::More: 0
distribution_type: module
-generated_by: Module::Install version 0.65
+generated_by: Module::Install version 0.67
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.3.html
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index af6a59c..9d13686 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.65';
+ $VERSION = '0.67';
}
# Whether or not inc::Module::Install is actually loaded, the
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
index b4b55af..c244cb5 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.65';
+ $VERSION = '0.67';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index b46a8ca..81fbcb6 100644
--- a/inc/Module/Install/Base.pm
+++ b/inc/Module/Install/Base.pm
@@ -1,7 +1,7 @@
#line 1
package Module::Install::Base;
-$VERSION = '0.65';
+$VERSION = '0.67';
# Suspend handler for "redefined" warnings
BEGIN {
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index 9bcf278..5d1eab8 100644
--- a/inc/Module/Install/Can.pm
+++ b/inc/Module/Install/Can.pm
@@ -11,7 +11,7 @@ use ExtUtils::MakeMaker ();
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.65';
+ $VERSION = '0.67';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index 0d2c39c..e884477 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.65';
+ $VERSION = '0.67';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
index 964b93d..574acc8 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.65';
+ $VERSION = '0.67';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index eb67033..fbc5cb2 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.65';
+ $VERSION = '0.67';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
@@ -17,196 +17,221 @@ sub Makefile { $_[0] }
my %seen = ();
sub prompt {
- shift;
-
- # Infinite loop protection
- my @c = caller();
- if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
- 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} ) {
- local $ENV{PERL_MM_USE_DEFAULT} = 1;
- goto &ExtUtils::MakeMaker::prompt;
- } else {
- goto &ExtUtils::MakeMaker::prompt;
- }
+ shift;
+
+ # Infinite loop protection
+ my @c = caller();
+ if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
+ 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} ) {
+ local $ENV{PERL_MM_USE_DEFAULT} = 1;
+ goto &ExtUtils::MakeMaker::prompt;
+ } else {
+ goto &ExtUtils::MakeMaker::prompt;
+ }
}
sub makemaker_args {
- my $self = shift;
- my $args = ($self->{makemaker_args} ||= {});
- %$args = ( %$args, @_ ) if @_;
- $args;
+ my $self = shift;
+ my $args = ($self->{makemaker_args} ||= {});
+ %$args = ( %$args, @_ ) if @_;
+ $args;
}
# For mm args that take multiple space-seperated args,
# append an argument to the current list.
sub makemaker_append {
- my $self = shift;
- my $name = shift;
- my $args = $self->makemaker_args;
- $args->{name} = defined $args->{$name}
- ? join( ' ', $args->{name}, @_ )
- : join( ' ', @_ );
+ my $self = sShift;
+ my $name = shift;
+ my $args = $self->makemaker_args;
+ $args->{name} = defined $args->{$name}
+ ? join( ' ', $args->{name}, @_ )
+ : join( ' ', @_ );
}
sub build_subdirs {
- my $self = shift;
- my $subdirs = $self->makemaker_args->{DIR} ||= [];
- for my $subdir (@_) {
- push @$subdirs, $subdir;
- }
+ my $self = shift;
+ my $subdirs = $self->makemaker_args->{DIR} ||= [];
+ for my $subdir (@_) {
+ push @$subdirs, $subdir;
+ }
}
sub clean_files {
- my $self = shift;
- my $clean = $self->makemaker_args->{clean} ||= {};
- %$clean = (
- %$clean,
- FILES => join(' ', grep length, $clean->{FILES}, @_),
- );
+ my $self = shift;
+ my $clean = $self->makemaker_args->{clean} ||= {};
+ %$clean = (
+ %$clean,
+ FILES => join(' ', grep length, $clean->{FILES}, @_),
+ );
}
sub realclean_files {
- my $self = shift;
- my $realclean = $self->makemaker_args->{realclean} ||= {};
- %$realclean = (
- %$realclean,
- FILES => join(' ', grep length, $realclean->{FILES}, @_),
- );
+ my $self = shift;
+ my $realclean = $self->makemaker_args->{realclean} ||= {};
+ %$realclean = (
+ %$realclean,
+ FILES => join(' ', grep length, $realclean->{FILES}, @_),
+ );
}
sub libs {
- my $self = shift;
- my $libs = ref $_[0] ? shift : [ shift ];
- $self->makemaker_args( LIBS => $libs );
+ my $self = shift;
+ my $libs = ref $_[0] ? shift : [ shift ];
+ $self->makemaker_args( LIBS => $libs );
}
sub inc {
- my $self = shift;
- $self->makemaker_args( INC => shift );
+ my $self = shift;
+ $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";
+ }
+ require File::Find;
+ %test_dir = ();
+ File::Find::find( \&_wanted_t, $dir );
+ $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
sub write {
- my $self = shift;
- die "&Makefile->write() takes no arguments\n" if @_;
-
- my $args = $self->makemaker_args;
- $args->{DISTNAME} = $self->name;
- $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
- $args->{VERSION} = $self->version || $self->determine_VERSION($args);
- $args->{NAME} =~ s/-/::/g;
- if ( $self->tests ) {
- $args->{test} = { TESTS => $self->tests };
- }
- if ($] >= 5.005) {
- $args->{ABSTRACT} = $self->abstract;
- $args->{AUTHOR} = $self->author;
- }
- if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
- $args->{NO_META} = 1;
- }
- if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
- $args->{SIGN} = 1;
- }
- unless ( $self->is_admin ) {
- delete $args->{SIGN};
- }
-
- # merge both kinds of requires into prereq_pm
- my $prereq = ($args->{PREREQ_PM} ||= {});
- %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_,
- ($self->build_requires, $self->requires) );
-
- # merge both kinds of requires into prereq_pm
- my $subdirs = ($args->{DIR} ||= []);
- if ($self->bundles) {
- foreach my $bundle (@{ $self->bundles }) {
- my ($file, $dir) = @$bundle;
- push @$subdirs, $dir if -d $dir;
- delete $prereq->{$file};
- }
- }
-
- 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";
- }
-
- $args->{INSTALLDIRS} = $self->installdirs;
-
- my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
-
- my $user_preop = delete $args{dist}->{PREOP};
- if (my $preop = $self->admin->preop($user_preop)) {
- $args{dist} = $preop;
- }
-
- my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
- $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
+ my $self = shift;
+ die "&Makefile->write() takes no arguments\n" if @_;
+
+ my $args = $self->makemaker_args;
+ $args->{DISTNAME} = $self->name;
+ $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
+ $args->{VERSION} = $self->version || $self->determine_VERSION($args);
+ $args->{NAME} =~ s/-/::/g;
+ if ( $self->tests ) {
+ $args->{test} = { TESTS => $self->tests };
+ }
+ if ($] >= 5.005) {
+ $args->{ABSTRACT} = $self->abstract;
+ $args->{AUTHOR} = $self->author;
+ }
+ if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
+ $args->{NO_META} = 1;
+ }
+ if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
+ $args->{SIGN} = 1;
+ }
+ unless ( $self->is_admin ) {
+ delete $args->{SIGN};
+ }
+
+ # merge both kinds of requires into prereq_pm
+ my $prereq = ($args->{PREREQ_PM} ||= {});
+ %$prereq = ( %$prereq,
+ map { @$_ }
+ map { @$_ }
+ grep $_,
+ ($self->build_requires, $self->requires)
+ );
+
+ # merge both kinds of requires into prereq_pm
+ my $subdirs = ($args->{DIR} ||= []);
+ if ($self->bundles) {
+ foreach my $bundle (@{ $self->bundles }) {
+ my ($file, $dir) = @$bundle;
+ push @$subdirs, $dir if -d $dir;
+ delete $prereq->{$file};
+ }
+ }
+
+ 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";
+ }
+
+ $args->{INSTALLDIRS} = $self->installdirs;
+
+ my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
+
+ my $user_preop = delete $args{dist}->{PREOP};
+ if (my $preop = $self->admin->preop($user_preop)) {
+ $args{dist} = $preop;
+ }
+
+ my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
+ $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
}
sub fix_up_makefile {
- my $self = shift;
- my $makefile_name = shift;
- my $top_class = ref($self->_top) || '';
- my $top_version = $self->_top->VERSION || '';
-
- my $preamble = $self->preamble
- ? "# Preamble by $top_class $top_version\n"
- . $self->preamble
- : '';
- my $postamble = "# Postamble by $top_class $top_version\n"
- . ($self->postamble || '');
-
- local *MAKEFILE;
- open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
- 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;
- $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
- $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
- $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
-
- # Module::Install will never be used to build the Core Perl
- # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
- # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
- $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
- #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
-
- # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
- $makefile =~ s/("?)-I\$\(PERL_LIB\)\1//g;
-
- # 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: $!";
- print MAKEFILE "$preamble$makefile$postamble" or die $!;
- close MAKEFILE or die $!;
-
- 1;
+ my $self = shift;
+ my $makefile_name = shift;
+ my $top_class = ref($self->_top) || '';
+ my $top_version = $self->_top->VERSION || '';
+
+ my $preamble = $self->preamble
+ ? "# Preamble by $top_class $top_version\n"
+ . $self->preamble
+ : '';
+ my $postamble = "# Postamble by $top_class $top_version\n"
+ . ($self->postamble || '');
+
+ local *MAKEFILE;
+ open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ 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;
+ $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
+ $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
+ $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
+
+ # Module::Install will never be used to build the Core Perl
+ # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
+ # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
+ $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
+ #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
+
+ # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
+ $makefile =~ s/("?)-I\$\(PERL_LIB\)\1//g;
+
+ # 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: $!";
+ print MAKEFILE "$preamble$makefile$postamble" or die $!;
+ close MAKEFILE or die $!;
+
+ 1;
}
sub preamble {
- my ($self, $text) = @_;
- $self->{preamble} = $text . $self->{preamble} if defined $text;
- $self->{preamble};
+ my ($self, $text) = @_;
+ $self->{preamble} = $text . $self->{preamble} if defined $text;
+ $self->{preamble};
}
sub postamble {
- my ($self, $text) = @_;
- $self->{postamble} ||= $self->admin->postamble;
- $self->{postamble} .= $text if defined $text;
- $self->{postamble}
+ my ($self, $text) = @_;
+ $self->{postamble} ||= $self->admin->postamble;
+ $self->{postamble} .= $text if defined $text;
+ $self->{postamble}
}
1;
__END__
-#line 338
+#line 363
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index b5658c9..b886046 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 $ISCORE @ISA};
BEGIN {
- $VERSION = '0.65';
+ $VERSION = '0.67';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
@@ -56,14 +56,23 @@ foreach my $key (@tuple_keys) {
};
}
-sub install_as_core { $_[0]->installdirs('perl') }
-sub install_as_cpan { $_[0]->installdirs('site') }
-sub install_as_site { $_[0]->installdirs('site') }
-sub install_as_vendor { $_[0]->installdirs('vendor') }
+# configure_requires is currently a null-op
+sub configure_requires { 1 }
+
+# Aliases for build_requires that will have alternative
+# meanings in some future version of META.yml.
+sub test_requires { shift->build_requires(@_) }
+sub install_requires { shift->build_requires(@_) }
+
+# Aliases for installdirs options
+sub install_as_core { $_[0]->installdirs('perl') }
+sub install_as_cpan { $_[0]->installdirs('site') }
+sub install_as_site { $_[0]->installdirs('site') }
+sub install_as_vendor { $_[0]->installdirs('vendor') }
sub sign {
my $self = shift;
- return $self->{'values'}{'sign'} if defined wantarray and !@_;
+ return $self->{'values'}{'sign'} if defined wantarray and ! @_;
$self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
return $self;
}
@@ -296,20 +305,24 @@ sub license_from {
{
my $license_text = $1;
my @phrases = (
- 'under the same (?:terms|license) as perl itself' => 'perl',
- 'GNU public license' => 'gpl',
- 'GNU lesser public license' => 'gpl',
- 'BSD license' => 'bsd',
- 'Artistic license' => 'artistic',
- 'GPL' => 'gpl',
- 'LGPL' => 'lgpl',
- 'BSD' => 'bsd',
- 'Artistic' => 'artistic',
- 'MIT' => 'MIT',
+ 'under the same (?:terms|license) as perl itself' => 'perl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser public license' => 'gpl', 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 ) = splice( @phrases, 0, 2 ) ) {
+ while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s{\s+}{\\s+}g;
if ( $license_text =~ /\b$pattern\b/i ) {
+ if ( $osi and $license_text =~ /All rights reserved/i ) {
+ warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
+ }
$self->license($license);
return 1;
}
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index 42cb653..612dc30 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 $ISCORE @ISA};
BEGIN {
- $VERSION = '0.65';
+ $VERSION = '0.67';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index d0908fb..e1db381 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 $ISCORE @ISA};
BEGIN {
- $VERSION = '0.65';
+ $VERSION = '0.67';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
commit ceb614674fefb91e3a8cc3d7578a931c4831c129
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Oct 24 21:18:11 2007 +0000
add $ticket that is used
diff --git a/lib/RT/Action/SLA_SetDue.pm b/lib/RT/Action/SLA_SetDue.pm
index f2e90c1..e1ecc59 100644
--- a/lib/RT/Action/SLA_SetDue.pm
+++ b/lib/RT/Action/SLA_SetDue.pm
@@ -33,6 +33,8 @@ Set the Due date accordingly to SLA.
sub Commit {
my $self = shift;
+ my $ticket = $self->TicketObj;
+
my $level = $ticket->FirstCustomFieldValue('SLA');
unless ( $level ) {
$RT::Logger->debug('Ticket #'. $ticket->id .' has no service level defined, skip setting Starts');
commit 8d09c7bc65775266184a61afed46bd40360da063
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Oct 24 21:18:35 2007 +0000
typo
diff --git a/lib/RT/Condition/SLA.pm b/lib/RT/Condition/SLA.pm
index 2359a86..b58818d 100644
--- a/lib/RT/Condition/SLA.pm
+++ b/lib/RT/Condition/SLA.pm
@@ -5,7 +5,7 @@ use warnings;
package RT::Condition::SLA;
use base qw(RT::Extension::SLA RT::Condition::Generic);
-=head1 IsSLAApplied
+=head1 SLAIsApplied
=cut
@@ -28,7 +28,6 @@ sub IsCustomFieldChange {
$RT::Logger->error("Couldn't load the '$cf_name' field");
return 0;
}
-
return 0 unless $cf->id == $txn->Field;
return 1;
}
commit 300baea60e36150f6b71c33caff46fa9f9d72dfc
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Oct 24 21:20:00 2007 +0000
add support of 'StartImmediately'
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 80fa0d6..3237c02 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -105,6 +105,9 @@ sub Agreements {
$RT::Logger->error("Levels of SLA should be either number or hash ref");
next;
}
+ if ( $meta->{'StartImmediately'} ) {
+ $props{'StartImmediately'} = $meta->{'StartImmediately'};
+ }
if ( $out_of_hours and my $tmp = $meta->{ 'OutOfHours' }{ $args{'Type'} } ) {
foreach ( qw(RealMinutes BusinessMinutes) ) {
commit 69a5519a5c95b01ac91c8a46a590fb9baf79438d
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Oct 24 21:21:18 2007 +0000
apply scrip only if SLA SF is applied to the ticket(queue)
diff --git a/lib/RT/Condition/SLA_RequireStartsSet.pm b/lib/RT/Condition/SLA_RequireStartsSet.pm
index 88a809e..446b1f7 100644
--- a/lib/RT/Condition/SLA_RequireStartsSet.pm
+++ b/lib/RT/Condition/SLA_RequireStartsSet.pm
@@ -18,8 +18,9 @@ Applies if Starts date is not set for the ticket.
sub IsApplicable {
my $self = shift;
return 0 if $self->TicketObj->StartsObj->Unix > 0;
+
+ return 0 unless $self->SLAIsApplied;
return 1;
}
1;
-
commit 255072450734156daa91c91d5d0669695cfb4399
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Oct 24 21:22:20 2007 +0000
minor
diff --git a/lib/RT/Condition/SLA_RequireDueSet.pm b/lib/RT/Condition/SLA_RequireDueSet.pm
index 3d68e71..83bfc08 100644
--- a/lib/RT/Condition/SLA_RequireDueSet.pm
+++ b/lib/RT/Condition/SLA_RequireDueSet.pm
@@ -22,9 +22,8 @@ sub IsApplicable {
if ( $self->TransactionObj->Type eq 'Create' ) {
return 1 if $self->TicketObj->FirstCustomFieldValue('SLA');
- } elsif ( $self->TransactionObj->Type eq 'Create' ) {
- return 1 if $self->IsCustomFieldChange('SLA');
}
+ return 1 if $self->IsCustomFieldChange('SLA');
return 0;
}
commit 19a12a7ba6aa1cdc52f7f5fd23b91ba221e61488
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Oct 24 21:23:06 2007 +0000
add few tests
diff --git a/t/starts.t b/t/starts.t
index 59ba3ed..ba37fa7 100644
--- a/t/starts.t
+++ b/t/starts.t
@@ -1,4 +1,7 @@
-#!/usr/bin/perl -w
+#!/usr/bin/perl
+
+use strict;
+use warnings;
use Test::More tests => 10;
@@ -11,7 +14,20 @@ RT::Init();
use_ok 'RT::Ticket';
{
+ %RT::SLA = (
+ Default => 'start immediately',
+ Levels => {
+ 'start immediately' => {
+ StartImmediately => 1,
+ Response => { RealMinutes => 2*60 },
+ },
+ },
+ );
+
my $ticket = RT::Ticket->new( $RT::SystemUser );
my ($id) = $ticket->Create( Queue => 'General', Subject => 'xxx' );
ok $id, "created ticket #$id";
+
+ ok $ticket->StartsObj->Unix > 0, 'Starts date is set';
}
+
commit 55dc4fd7677e66e0690c36367f7f8d409f360297
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Oct 24 22:00:15 2007 +0000
basic tests for Starts date are ready and things even work
diff --git a/t/starts.t b/t/starts.t
index ba37fa7..f2c7380 100644
--- a/t/starts.t
+++ b/t/starts.t
@@ -13,21 +13,57 @@ RT::Init();
use_ok 'RT::Ticket';
+use_ok 'RT::Extension::SLA';
+
+my $bhours = RT::Extension::SLA->BusinessHours;
+
+diag 'check Starts date';
+{
+ %RT::SLA = (
+ Default => 'start',
+ Levels => {
+ 'starts' => {
+ Response => 2*60,
+ Resolve => 7*60*24,
+ },
+ },
+ );
+
+ my $time = time;
+
+ my $ticket = RT::Ticket->new( $RT::SystemUser );
+ my ($id) = $ticket->Create( Queue => 'General', Subject => 'xxx' );
+ ok $id, "created ticket #$id";
+
+ my $starts = $ticket->StartsObj->Unix;
+ ok $starts > 0, 'Starts date is set';
+ if ( $bhours->first_after($time) == $time ) {
+ # in hours
+ ok $starts - $time < 5, 'Starts is quite correct';
+ } else {
+ ok $starts - $time > 5 , 'Starts is quite correct';
+ }
+}
+
+diag 'check Starts date with StartImmediately enabled';
{
%RT::SLA = (
Default => 'start immediately',
Levels => {
'start immediately' => {
StartImmediately => 1,
- Response => { RealMinutes => 2*60 },
+ Response => 2*60,
+ Resolve => 7*60*24,
},
},
);
+ my $time = time;
my $ticket = RT::Ticket->new( $RT::SystemUser );
my ($id) = $ticket->Create( Queue => 'General', Subject => 'xxx' );
ok $id, "created ticket #$id";
ok $ticket->StartsObj->Unix > 0, 'Starts date is set';
+ ok abs($starts - $time) < 5, 'Starts is quite correct';
}
commit 49a98ee89b5dfcb6a37baa9376ef37e8ed7fc3cd
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Oct 25 03:15:38 2007 +0000
add a SPEC with examples
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 3237c02..78a5736 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -9,6 +9,130 @@ RT::Extension::SLA - Service Level Agreements
=head1 DESCRIPTION
+=head1 SPECIFICATION
+
+To enable service level agreements for a queue administrtor
+should create and apply SLA custom field. To define different
+levels for different queues he CAN create several CFs with
+the same name and different set of values. All CFs MUST be
+of the same 'select one value' type.
+
+Values of the CF(s) define service levels.
+
+Each service level can be described using several options:
+StartImmediately, Resolve and Response.
+
+=head2 StartImmediately (boolean, false)
+
+By default when ticket is created Starts date is set to
+first business minute after time of creation. In other
+words if ticket is created during business hours then
+Starts will be equal to Created time, otherwise it'll
+be beginning of the next business day.
+
+However, if you provide 24/7 support then you most
+probably would be interested in Starts to be always equal
+to Created time. In this case you can set option
+StartImmediately to true value.
+
+Example:
+ '24/7' => {
+ StartImmediately => 1,
+ Response => { RealMinutes => 30 },
+ },
+ 'standard' => {
+ StartImmediately => 0, # can be ommited as it's default
+ Response => { BusinessMinutes => 2*60 },
+ },
+
+=head2 Resolve and Response (interval, no defaults)
+
+These two options define deadlines for resolve of a ticket
+and reply to customer(requestors) questions accordingly.
+
+You can define them using real time, business or both. Read more
+about the latter below.
+
+The Due date field is used to store calculated deadlines.
+
+=head3 Resolve
+
+Defines deadline when a ticket should be resolved. This option is
+quite simple and straightforward when used without L</Response>.
+
+Examples:
+ # 8 business hours
+ 'simple' => { Resolve => 60*8 },
+ ...
+ # one real week
+ 'hard' => { Resolve => { RealMinutes => 60*24*7 } },
+
+
+=head3 Response
+
+In many companies providing support service(s) resolve time
+of a ticket is less important than time of response to requestors
+from stuff members.
+
+You can use Response option to define such deadlines. When you're
+using this option Due time "flips" when requestors and non-requestors
+reply to a ticket. We set Due date when a ticket's created, unset
+when non-requestor replies... until ticket is closed when ticket's
+due date is also unset.
+
+B<NOTE> that behaviour changes when Resolve and Response options
+are combined, read below.
+
+=head3 Using both Resolve and Response in the same level
+
+Resolve and Response can be combined. In such case due date is set
+according to the earliest of two deadlines and never is dropped to
+not set. When non-requestor replies to a ticket, due date is changed to
+Response deadline, as well this happens when a ticket is closed. So
+all the time due date is defined.
+
+If a ticket met its Resolve deadline then due date stops "fliping" and
+is freezed and the ticket becomes overdue.
+
+Example:
+
+ 'standard delivery' => {
+ Response => { RealMinutes => 60*1 }, # one hour
+ Resolve => { RealMinutes => 60*24 }, # 24 real hours
+ },
+
+A client orders a good and due date of the orderis set to the next one
+hour, you have this hour to process the order and write a reply.
+As soon as goods are delivered you resolve tickets and usually meet
+Resolve deadline, but if you don't resolve or user replies then most
+probably there are problems with deliver or the good. And if after
+a week you keep replying to the client and always meeting one hour
+response deadline that doesn't mean the ticket is not over due.
+Due date was frozen 24 hours after creation of the order.
+
+=head3 Using business and real time in one option
+
+It's quite rare situation when people need it, but we've decided
+that deadline described using both types of time then business
+is applied first and then real time. For example:
+
+ 'delivery' => {
+ Resolve => { BusinessMinutes => 1, RealMinutes => 60*8 },
+ },
+ 'fast delivery' {
+ StartImmediately => 1,
+ Resolve => { RealMinutes => 60*8 },
+ },
+
+For delivery requests which come into the system during business
+hours these levels define the same deadlines, otherwise the first
+level set deadline to 8 real hours starting from the next business
+day, when tickets with the second level should be resolved in the
+next 8 hours after creation.
+
+
+=head1 OLD ideas, some havn't been integrated in the above doc
+
=head2 v0.01
* we have one Business::Hours object
commit 2014cc167aadf00c292f44a3972d74ef78d20cf7
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Oct 25 03:19:09 2007 +0000
typo
diff --git a/lib/RT/Action/SLA_SetDue.pm b/lib/RT/Action/SLA_SetDue.pm
index e1ecc59..22bfb94 100644
--- a/lib/RT/Action/SLA_SetDue.pm
+++ b/lib/RT/Action/SLA_SetDue.pm
@@ -37,7 +37,7 @@ sub Commit {
my $level = $ticket->FirstCustomFieldValue('SLA');
unless ( $level ) {
- $RT::Logger->debug('Ticket #'. $ticket->id .' has no service level defined, skip setting Starts');
+ $RT::Logger->debug('Ticket #'. $ticket->id .' has no service level defined');
return 1;
}
commit 3a7aefd4c6a54df4d04c024accaf1c742e30dc32
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Oct 25 03:20:50 2007 +0000
add Agreement method and use it in the Agreements method
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 78a5736..d4b443b 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -187,6 +187,42 @@ sub BusinessHours {
return new Business::Hours;
}
+sub Agreement {
+ my $self = shift;
+ my %args = ( Level => undef, Type => 'Response', Time => undef, @_ );
+
+ my $meta = $RT::SLA{'Levels'}{ $args{'Level'} };
+ return undef unless $meta;
+ return undef unless $meta->{ $args{'Type'} };
+
+ my %res;
+ if ( ref $meta->{ $args{'Type'} } ) {
+ %res = %{ $meta->{ $args{'Type'} } };
+ } elsif ( $meta->{ $args{'Type'} } =~ /^\d+$/ ) {
+ %res = ( BusinessMinutes => $meta->{ $args{'Type'} } );
+ } else {
+ $RT::Logger->error("Levels of SLA should be either number or hash ref");
+ return undef;
+ }
+
+ if ( defined $meta->{'StartImmediately'} ) {
+ $res{'StartImmediately'} = $meta->{'StartImmediately'};
+ }
+
+ if ( $meta->{'OutOfHours'}{ $args{'Type'} } && $args{'Time'} ) {
+ my $bhours = $self->BusinessHours;
+ if ( $bhours->first_after( $args{'Time'} ) != $args{'Time'} ) {
+ foreach ( qw(RealMinutes BusinessMinutes) ) {
+ next unless $tmp->{ $_ };
+ $res{ $_ } ||= 0;
+ $res{ $_ } += $tmp->{ $_ };
+ }
+ }
+ }
+
+ return \%res;
+}
+
=head2 Agreements [ Type => 'Response' ]
Returns an instance of L<Business::SLA> class filled with
@@ -208,40 +244,12 @@ sub Agreements {
eval "require $class" or die $@;
my $SLA = $class->new( BusinessHours => $self->BusinessHours );
- my $out_of_hours = 0;
- if ( $args{'Time'} && !$SLA->IsInHours( $args{'Time'} ) ) {
- $out_of_hours = 1;
- }
-
my $levels = $RT::SLA{'Levels'};
- while ( my ($level, $meta) = each %$levels ) {
- unless ( defined $meta->{ $args{'Type'} } ) {
- $RT::Logger->warning("No $args{'Type'} agreement for '$level' service level");
- next;
- }
-
- my %props;
- if ( ref $meta->{ $args{'Type'} } ) {
- %props = %{ $meta->{ $args{'Type'} } };
- } elsif ( $meta->{ $args{'Type'} } =~ /^\d+$/ ) {
- %props = ( BusinessMinutes => $meta->{ $args{'Type'} } );
- } else {
- $RT::Logger->error("Levels of SLA should be either number or hash ref");
- next;
- }
- if ( $meta->{'StartImmediately'} ) {
- $props{'StartImmediately'} = $meta->{'StartImmediately'};
- }
-
- if ( $out_of_hours and my $tmp = $meta->{ 'OutOfHours' }{ $args{'Type'} } ) {
- foreach ( qw(RealMinutes BusinessMinutes) ) {
- next unless $tmp->{ $_ };
- $props{ $_ } ||= 0;
- $props{ $_ } += $tmp->{ $_ };
- }
- }
+ foreach my $level ( keys %$levels ) {
+ my $props = $self->Agreement( %args, Level => $level );
+ next unless $props;
- $SLA->Add( $level => %props );
+ $SLA->Add( $level => %$props );
}
return $SLA;
commit 2dad39afaea340f185ce74c6bde4b2cd7e9a35ef
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Oct 25 05:44:41 2007 +0000
set Starts only when service level is set
diff --git a/lib/RT/Condition/SLA_RequireStartsSet.pm b/lib/RT/Condition/SLA_RequireStartsSet.pm
index 446b1f7..0f511f6 100644
--- a/lib/RT/Condition/SLA_RequireStartsSet.pm
+++ b/lib/RT/Condition/SLA_RequireStartsSet.pm
@@ -18,8 +18,7 @@ Applies if Starts date is not set for the ticket.
sub IsApplicable {
my $self = shift;
return 0 if $self->TicketObj->StartsObj->Unix > 0;
-
- return 0 unless $self->SLAIsApplied;
+ return 0 unless $self->TicketObj->FirstCustomFieldValue('SLA');
return 1;
}
commit 51159ad22a609befa8d2a6f431c43eb2a1fe12f2
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Oct 25 05:45:19 2007 +0000
typo
diff --git a/lib/RT/Action/SLA_SetDefault.pm b/lib/RT/Action/SLA_SetDefault.pm
index 4983ff5..ba680f1 100644
--- a/lib/RT/Action/SLA_SetDefault.pm
+++ b/lib/RT/Action/SLA_SetDefault.pm
@@ -16,7 +16,7 @@ Sets a default level of service. Transaction's created field is used
to calculate if things happen in hours or out of. Default value then
figured from L<InHoursDefault|XXX> and L<OutOfHoursDefault|XXX> options.
-This action doesn't check if the ticket has a value allready, so you
+This action doesn't check if the ticket has a value already, so you
have to use it with condition that checks this fact for you, however
such behaviour allows you to force setting up default using custom
condition. The default condition for this action is
commit a135b3834db5478273e949fe8b6931f414ea519f
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Oct 25 05:46:25 2007 +0000
run DueSet script on Correspond, but only service level is set
diff --git a/etc/initialdata b/etc/initialdata
index 58f94a9..50b1bde 100644
--- a/etc/initialdata
+++ b/etc/initialdata
@@ -22,7 +22,7 @@
},
{ Name => '[SLA] Require Due set', # loc
Description => 'Detect a situation when we should set Due date' , # loc
- ApplicableTransTypes => 'Create,CustomField',
+ ApplicableTransTypes => 'Create,CustomField,Correspond',
ExecModule => 'SLA_RequireDueSet',
},
);
diff --git a/lib/RT/Condition/SLA_RequireDueSet.pm b/lib/RT/Condition/SLA_RequireDueSet.pm
index 83bfc08..fc41f82 100644
--- a/lib/RT/Condition/SLA_RequireDueSet.pm
+++ b/lib/RT/Condition/SLA_RequireDueSet.pm
@@ -20,8 +20,10 @@ sub IsApplicable {
my $self = shift;
return 0 unless $self->SLAIsApplied;
- if ( $self->TransactionObj->Type eq 'Create' ) {
+ my $type = $self->TransactionObj->Type;
+ if ( $type eq 'Create' || $type eq 'Correspond' ) {
return 1 if $self->TicketObj->FirstCustomFieldValue('SLA');
+ return 0;
}
return 1 if $self->IsCustomFieldChange('SLA');
return 0;
commit 1fd56e4848e4b01fb2c93aad679282d6062b56a0
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Oct 25 05:47:54 2007 +0000
rewrite SetDue action, now it's much closer to the spec
diff --git a/lib/RT/Action/SLA_SetDue.pm b/lib/RT/Action/SLA_SetDue.pm
index 22bfb94..90b56bb 100644
--- a/lib/RT/Action/SLA_SetDue.pm
+++ b/lib/RT/Action/SLA_SetDue.pm
@@ -41,7 +41,37 @@ sub Commit {
return 1;
}
- my $due = $self->EarliestDue( $level );
+ my $txn = $self->TransactionObj;
+
+ my $last_reply = $self->LastCorrespond;
+ $RT::Logger->debug('Last reply to ticket #'. $ticket->id .' is txn #'. $last_reply->id );
+ my $is_requestors_act = $self->IsRequestorsAct( $last_reply );
+ $RT::Logger->debug('Txn #'. $last_reply->id .' is requestors\' action') if $is_requestors_act;
+
+ my $response_due = $self->Due(
+ Level => $level,
+ Type => 'Response',
+ Time => $last_reply->CreatedObj->Unix,
+ );
+
+ my $resolve_due = $self->Due(
+ Level => $level,
+ Type => 'Resolve',
+ Time => $ticket->CreatedObj->Unix,
+ );
+
+ my $type = $txn->Type;
+
+ my $due;
+ $due = $response_due if defined $response_due && $is_requestors_act;
+ $due = $resolve_due unless defined $due;
+ $due = $resolve_due if defined $due && defined $resolve_due && $resolve_due < $due;
+
+ if ( defined $due ) {
+ return 1 if $ticket->DueObj->Unix == $due;
+ } else {
+ return 1 if $ticket->DueObj->Unix <= 0;
+ }
my $date = RT::Date->new( $RT::SystemUser );
$date->Set( Format => 'unix', Value => $due );
@@ -54,21 +84,31 @@ sub Commit {
return 1;
}
-sub EarliestDue {
+sub IsRequestorsAct {
my $self = shift;
- my $level = shift;
-
- my $response_time = $self->TransactionObj->CreatedObj->Unix;
- my $response_due = $self->Agreements(
- Type => 'Response', Time => $response_time
- )->Due( $response_time, $level );
+ my $txn = shift || $self->TransactionObj;
- my $create_time = $self->TicketObj->CreatedObj->Unix;
- my $resolve_due = $self->Agreements(
- Type => 'Resolve', Time => $create_time
- )->Due( $create_time, $level );
+ return $self->TicketObj->Requestors->HasMemberRecursively(
+ $txn->CreatorObj->PrincipalObj
+ )? 1 : 0;
+}
- return $resolve_due < $response_due? $resolve_due : $response_due;
+sub LastCorrespond {
+ my $self = shift;
+
+ my $txn = $self->TransactionObj;
+ return $txn if $txn->Type eq 'Create'
+ || $txn->Type eq 'Correspond';
+
+ my $txns = $self->TicketObj->Transactions;
+ $txns->Limit( FIELD => 'Type', VALUE => 'Correspond' );
+ $txns->Limit( FIELD => 'Type', VALUE => 'Create' );
+ $txns->OrderByCols(
+ { FIELD => 'Created', ORDER => 'DESC' },
+ { FIELD => 'id', ORDER => 'DESC' },
+ );
+ $txns->RowsPerPage(1);
+ return $txns->First;
}
1;
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index d4b443b..d641bcb 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -209,7 +209,7 @@ sub Agreement {
$res{'StartImmediately'} = $meta->{'StartImmediately'};
}
- if ( $meta->{'OutOfHours'}{ $args{'Type'} } && $args{'Time'} ) {
+ if ( $args{'Time'} and my $tmp = $meta->{'OutOfHours'}{ $args{'Type'} } ) {
my $bhours = $self->BusinessHours;
if ( $bhours->first_after( $args{'Time'} ) != $args{'Time'} ) {
foreach ( qw(RealMinutes BusinessMinutes) ) {
@@ -223,6 +223,24 @@ sub Agreement {
return \%res;
}
+sub Due {
+ my $self = shift;
+ my %args = ( Level => undef, Type => undef, Time => undef, @_ );
+
+ my $agreement = $self->Agreement( %args );
+ return undef unless $agreement;
+
+ my $res = $args{'Time'};
+ if ( defined $agreement->{'BusinessMinutes'} ) {
+ my $bhours = $self->BusinessHours;
+ $res = $bhours->add_seconds( $res, 60 * $agreement->{'BusinessMinutes'} );
+ }
+ $res += $agreement->{'RealMinutes'}
+ if defined $agreement->{'RealMinutes'};
+
+ return $res;
+}
+
=head2 Agreements [ Type => 'Response' ]
Returns an instance of L<Business::SLA> class filled with
commit d641111f178957b719725f227d4d6f90d2d6bf9d
Author: sunnavy <sunnavy at bestpractical.com>
Date: Thu Oct 25 07:24:53 2007 +0000
doc typo fix
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index d641bcb..633dba0 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -88,7 +88,7 @@ are combined, read below.
Resolve and Response can be combined. In such case due date is set
according to the earliest of two deadlines and never is dropped to
not set. When non-requestor replies to a ticket, due date is changed to
-Response deadline, as well this happens when a ticket is closed. So
+Resolve deadline, as well this happens when a ticket is closed. So
all the time due date is defined.
If a ticket met its Resolve deadline then due date stops "fliping" and
@@ -101,11 +101,11 @@ Example:
Resolve => { RealMinutes => 60*24 }, # 24 real hours
},
-A client orders a good and due date of the orderis set to the next one
+A client orders goods and due date of the order is set to the next one
hour, you have this hour to process the order and write a reply.
As soon as goods are delivered you resolve tickets and usually meet
Resolve deadline, but if you don't resolve or user replies then most
-probably there are problems with deliver or the good. And if after
+probably there are problems with deliver or the goods. And if after
a week you keep replying to the client and always meeting one hour
response deadline that doesn't mean the ticket is not over due.
Due date was frozen 24 hours after creation of the order.
@@ -117,7 +117,7 @@ that deadline described using both types of time then business
is applied first and then real time. For example:
'delivery' => {
- Resolve => { BusinessMinutes => 1, RealMinutes => 60*8 },
+ Resolve => { BusinessMinutes => 60*8, RealMinutes => 60*8 },
},
'fast delivery' {
StartImmediately => 1,
commit 813739d931ca3b056700b61bfdddd725202909dd
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Oct 25 07:59:34 2007 +0000
update docs...
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 633dba0..9dd9397 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -9,8 +9,6 @@ RT::Extension::SLA - Service Level Agreements
=head1 DESCRIPTION
-=head1 SPECIFICATION
-
To enable service level agreements for a queue administrtor
should create and apply SLA custom field. To define different
levels for different queues he CAN create several CFs with
@@ -20,7 +18,7 @@ of the same 'select one value' type.
Values of the CF(s) define service levels.
Each service level can be described using several options:
-StartImmediately, Resolve and Response.
+StartImmediately, OutOfHours, Resolve and Response.
=head2 StartImmediately (boolean, false)
@@ -60,7 +58,7 @@ The Due date field is used to store calculated deadlines.
Defines deadline when a ticket should be resolved. This option is
quite simple and straightforward when used without L</Response>.
-Examples:
+Example:
# 8 business hours
'simple' => { Resolve => 60*8 },
...
@@ -117,7 +115,7 @@ that deadline described using both types of time then business
is applied first and then real time. For example:
'delivery' => {
- Resolve => { BusinessMinutes => 60*8, RealMinutes => 60*8 },
+ Resolve => { BusinessMinutes => 0, RealMinutes => 60*8 },
},
'fast delivery' {
StartImmediately => 1,
@@ -130,54 +128,32 @@ level set deadline to 8 real hours starting from the next business
day, when tickets with the second level should be resolved in the
next 8 hours after creation.
+=head2 OutOfHours (struct, no default)
-=head1 OLD ideas, some havn't been integrated in the above doc
-
-=head2 v0.01
+Out of hours modifier. Adds more real or business minutes to resolve
+and/or reply options if event happens out of business hours.
-* we have one Business::Hours object
-* several agreement levels
-* options:
-** InHoursDefault - default service level ticket created during business hours, but only if level hasn't been set
-** OutOfHoursDefault - default service level ticket created out of business hours, but only if level hasn't been set
-** Levels - each level has definition of agreements for Response and Resolve
-*** If you set a requirement for response then we set due date on create or as soon as user replies to some a in the feature, so due date means deadline for reply, as soon as somebody who is not a requestor replies we unset due
-*** if you set a requirement for resolve then we set due date on create to a point in the feature, so due date defines deadline for ticket resolving
-*** we should support situations when restrictions defined for reply and resolve, then we move due date according to reply deadlines, however when we reach resolve deadline we stop moving.
-
-*** each requirement is described by Business or Real time in terms of L<Business::SLA> module.
-
-so we'll have something like:
-%SLA => (
- Default => 'two business hours for reply',
- Levels => {
- 'one real hour for reply' => { Response => { RealMinutes => 60 } },
- 'two business hours for reply' => { Response => { BusinessMinutes => 60*2 } },
- '8 business hours for resolve' => { Resolve => { BusinessMinutes => 60*8 } },
- 'two b-hours for reply and 3 real days for resolve' => {
- OutOfHours => {
- Response => { RealMinutes => +60 },
- Resolve => { RealMinutes => +60*24 },
- },
- Response => { BusinessMinutes => 60*2 },
- Resolve => { RealMinutes => 60*24*3 },
- },
+Example:
+
+ 'level x' => {
+ OutOfHours => { Resolve => { RealMinutes => +60*24 } },
+ Resolve => { RealMinutes => 60*24 },
},
-);
-=head v0.02
+If a request comes into the system during night then supporters have two
+days, otherwise only one.
-* changing service levels of a ticket in the middle of its live
-
-=head random thoughts
-
-* Defining OutOfHours/InHours defaults sounds not that usefull for response deadlines as for resolve. For resolve I can find an example in real life: I order something in an online shop, the order comes into system when business day ended, so delivery(resolve) deadline is two business days, but in the case of in hours submission of the order they deliver during one business day. For reply deadlines I cannot imagine a situation when different InHours/OutOfHours levels are useful.
+ 'level x' => {
+ OutOfHours => { Response => { BusinessMinutes => +60*2 } },
+ Resolve => { BusinessMinutes => 60 },
+ },
+Supporters have two additional hours in the morning to deal with bunch
+of requests that came into the system during the last night.
-=head v0.later
+=head2 Default service levels
-* default SLA for queues
-* add support for multiple b-hours definitions, this could be very helpfull when you have 24/7 mixed with 8/5 and/or something like 8/5+4/2 for different tickets(by requestor, queue or something else). So people would be able to handle tickets in the right order using Due dates.
+In the config and per queue defaults(this is not implemented).
=cut
@@ -243,6 +219,8 @@ sub Due {
=head2 Agreements [ Type => 'Response' ]
+DEPRECATED
+
Returns an instance of L<Business::SLA> class filled with
service levels for particular Type.
@@ -300,6 +278,21 @@ sub GetDefaultServiceLevel {
return $RT::SLA{'Default'};
}
+=head1 TODO
+
+=head2 v0.01
+
+* we have one Business::Hours object
+* default SLA for queues
+** see below in this class
+* changing service levels of a ticket in the middle of its live
+** this should work for Due dates, for Starts makes not much sense
+
+=head2 v0.later
+
+* WebUI
+* add support for multiple b-hours definitions, this could be very helpfull when you have 24/7 mixed with 8/5 and/or something like 8/5+4/2 for different tickets(by requestor, queue or something else). So people would be able to handle tickets in the right order using Due dates.
+
=head1 DESIGN
=head2 Classes
commit fd6f0b4c8f5e52dd08169ce1dcc7dae2b71ae894
Author: sunnavy <sunnavy at bestpractical.com>
Date: Thu Oct 25 12:27:48 2007 +0000
Queue SLA Attribute support
diff --git a/lib/RT/Extension/QueueSLA.pm b/lib/RT/Extension/QueueSLA.pm
new file mode 100644
index 0000000..de365ba
--- /dev/null
+++ b/lib/RT/Extension/QueueSLA.pm
@@ -0,0 +1,46 @@
+package RT::Extension::QueueSLA;
+
+our $VERSION = '0.01';
+
+
+=head1 NAME
+
+RT::Extension::QueueSLA - default SLA for Queue
+
+=cut
+
+use RT::Queue;
+package RT::Queue;
+
+use strict;
+use warnings;
+
+
+sub SLA {
+ my $self = shift;
+ my $value = shift;
+
+# TODO: ACL check
+# return undef unless $self->CurrentUserHasRight('XXX');
+ my $attr = $self->FirstAttribute('SLA') or return undef;
+ return $attr->Content;
+}
+
+sub SetSLA {
+ my $self = shift;
+ my $value = shift;
+
+# TODO: ACL check
+# return ( 0, $self->loc('Permission Denied') )
+# unless $self->CurrentUserHasRight('XXX');
+
+ my ($status, $msg) = $self->SetAttribute(
+ Name => 'SLA',
+ Description => 'Default Queue SLA',
+ Content => $value,
+ );
+ return ($status, $msg) unless $status;
+ return ($status, $self->loc('Queue SLA changed'));
+}
+
+1;
commit 7e0778e1d764d5aff0e22c34282696e4cfc97b20
Author: sunnavy <sunnavy at bestpractical.com>
Date: Thu Oct 25 12:56:27 2007 +0000
default queue SLA should work now
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 9dd9397..263df34 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -273,7 +273,15 @@ sub GetDefaultServiceLevel {
$args{'Queue'} = $args{'Ticket'}->QueueObj;
}
if ( $args{'Queue'} ) {
- # TODO: here we should implement per queue defaults
+ local $@;
+ eval { require RT::Extension::QueueSLA };
+ if ( $@ ) {
+ $RT::Logger->crit("Couldn't load RT::Extension::QueueSLA: $@");
+ }
+ else {
+ return $self->TicketObj->QueueObj->SLA
+ if $self->TicketObj->QueueObj->SLA;
+ }
}
return $RT::SLA{'Default'};
}
commit 67e565da2fca780fa2d0a929a3db1d4285929be3
Author: sunnavy <sunnavy at bestpractical.com>
Date: Fri Oct 26 11:59:10 2007 +0000
initial unique Business::Hours object for each level
diff --git a/lib/RT/Action/SLA_SetStarts.pm b/lib/RT/Action/SLA_SetStarts.pm
index 56e8537..3ab0c0c 100644
--- a/lib/RT/Action/SLA_SetStarts.pm
+++ b/lib/RT/Action/SLA_SetStarts.pm
@@ -32,7 +32,7 @@ sub Commit {
return 1;
}
- my $SLA = $self->Agreements;
+ my $SLA = $self->SLA(Level => $level);
my $starts = $SLA->Starts( $self->TransactionObj->CreatedObj->Unix, $level );
my $date = RT::Date->new($RT::SystemUser);
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 263df34..c2464f0 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -160,7 +160,9 @@ In the config and per queue defaults(this is not implemented).
sub BusinessHours {
my $self = shift;
require Business::Hours;
- return new Business::Hours;
+ my $bhours = Business::Hours->new;
+ $bhours->business_hours(@_) if @_;
+ return $bhours;
}
sub Agreement {
@@ -186,7 +188,8 @@ sub Agreement {
}
if ( $args{'Time'} and my $tmp = $meta->{'OutOfHours'}{ $args{'Type'} } ) {
- my $bhours = $self->BusinessHours;
+ my $bhours =
+ $self->BusinessHours($RT::BusinessHours{$meta->{BusinessHours}});
if ( $bhours->first_after( $args{'Time'} ) != $args{'Time'} ) {
foreach ( qw(RealMinutes BusinessMinutes) ) {
next unless $tmp->{ $_ };
@@ -202,13 +205,15 @@ sub Agreement {
sub Due {
my $self = shift;
my %args = ( Level => undef, Type => undef, Time => undef, @_ );
+ my $meta = $RT::SLA{'Levels'}{ $args{'Level'} };
my $agreement = $self->Agreement( %args );
return undef unless $agreement;
my $res = $args{'Time'};
if ( defined $agreement->{'BusinessMinutes'} ) {
- my $bhours = $self->BusinessHours;
+ my $bhours =
+ $self->BusinessHours(%{$RT::BusinessHours{$meta->{BusinessHours}}});
$res = $bhours->add_seconds( $res, 60 * $agreement->{'BusinessMinutes'} );
}
$res += $agreement->{'RealMinutes'}
@@ -217,6 +222,7 @@ sub Due {
return $res;
}
+
=head2 Agreements [ Type => 'Response' ]
DEPRECATED
@@ -251,6 +257,34 @@ sub Agreements {
return $SLA;
}
+=head2 SLA [ Level => $level ]
+
+Returns an instance of L<Business::SLA> class filled with the level.
+
+Now we take list of agreements and its description from the
+RT config.
+
+=cut
+
+sub SLA {
+ my $self = shift;
+ my %args = @_;
+ my $level = $args{Level};
+
+ my $class = $RT::SLA{'Module'} || 'Business::SLA';
+ eval "require $class" or die $@;
+
+ my $SLA = $class->new(
+ BusinessHours => $self->BusinessHours(
+ %{ $RT::BusinessHours{ $RT::SLA{Levels}{$level}{BusinessHours} } }
+ )
+ );
+
+ $SLA->Add( $level => %{ $self->Agreement(%args) } );
+
+ return $SLA;
+}
+
sub GetCustomField {
my $self = shift;
my %args = (Ticket => undef, CustomField => 'SLA', @_);
commit 03011ff3581ce3eb17fda44d63489da6462b2367
Author: sunnavy <sunnavy at bestpractical.com>
Date: Fri Oct 26 12:07:31 2007 +0000
business_hours accept hash, not hash ref
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index c2464f0..a0e1365 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -189,7 +189,7 @@ sub Agreement {
if ( $args{'Time'} and my $tmp = $meta->{'OutOfHours'}{ $args{'Type'} } ) {
my $bhours =
- $self->BusinessHours($RT::BusinessHours{$meta->{BusinessHours}});
+ $self->BusinessHours(%{$RT::BusinessHours{$meta->{BusinessHours}}});
if ( $bhours->first_after( $args{'Time'} ) != $args{'Time'} ) {
foreach ( qw(RealMinutes BusinessMinutes) ) {
next unless $tmp->{ $_ };
commit 1c2b28fe0f919e5c5d630bf90932eb9217d2b9a1
Author: sunnavy <sunnavy at bestpractical.com>
Date: Fri Oct 26 12:51:42 2007 +0000
Default stuff support for Business::Hours, also docs
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index a0e1365..4b9dc18 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -151,6 +151,24 @@ days, otherwise only one.
Supporters have two additional hours in the morning to deal with bunch
of requests that came into the system during the last night.
+=head2 BusinessHours
+
+Each level now supports BusinessHours option to specify your own business
+hours.
+
+ 'level x' => {
+ BusinessHours => 'work just in Monday',
+ Resolve => { BusinessMinutes => 60 },
+ },
+
+then %RT::BusinessHours should have the corresponding definition:
+
+%RT::BusinessHours = ( 'work just in Monday' => {
+ 1 => { Name => 'Monday', Start => '9:00', End => '18:00' }
+ });
+
+Default Business Hours setting is in $RT::BusinessHours{'Default'}.
+
=head2 Default service levels
In the config and per queue defaults(this is not implemented).
@@ -189,7 +207,8 @@ sub Agreement {
if ( $args{'Time'} and my $tmp = $meta->{'OutOfHours'}{ $args{'Type'} } ) {
my $bhours =
- $self->BusinessHours(%{$RT::BusinessHours{$meta->{BusinessHours}}});
+ $self->BusinessHours(
+ %{ $RT::BusinessHours{ $meta->{BusinessHours} || 'Default' } } );
if ( $bhours->first_after( $args{'Time'} ) != $args{'Time'} ) {
foreach ( qw(RealMinutes BusinessMinutes) ) {
next unless $tmp->{ $_ };
@@ -213,7 +232,8 @@ sub Due {
my $res = $args{'Time'};
if ( defined $agreement->{'BusinessMinutes'} ) {
my $bhours =
- $self->BusinessHours(%{$RT::BusinessHours{$meta->{BusinessHours}}});
+ $self->BusinessHours(
+ %{ $RT::BusinessHours{ $meta->{BusinessHours} || 'Default' } } );
$res = $bhours->add_seconds( $res, 60 * $agreement->{'BusinessMinutes'} );
}
$res += $agreement->{'RealMinutes'}
@@ -276,7 +296,8 @@ sub SLA {
my $SLA = $class->new(
BusinessHours => $self->BusinessHours(
- %{ $RT::BusinessHours{ $RT::SLA{Levels}{$level}{BusinessHours} } }
+ %{ $RT::BusinessHours{ $RT::SLA{Levels}{$level}{BusinessHours}
+ || 'Default' } }
)
);
commit 433186d0b9abb9717463fed779251ee8aa386822
Author: sunnavy <sunnavy at bestpractical.com>
Date: Fri Oct 26 16:24:16 2007 +0000
bugs fix
diff --git a/lib/RT/Action/SLA_SetStarts.pm b/lib/RT/Action/SLA_SetStarts.pm
index 3ab0c0c..f3cc1eb 100644
--- a/lib/RT/Action/SLA_SetStarts.pm
+++ b/lib/RT/Action/SLA_SetStarts.pm
@@ -26,6 +26,11 @@ sub Commit {
my $self = shift;
my $ticket = $self->TicketObj;
+
+# XXX I encountered a 'Couldn't set starts date: That is already the current
+# value' warning if I didn't test it here. wierd
+ return 0 if $ticket->StartsObj->Unix > 0;
+
my $level = $ticket->FirstCustomFieldValue('SLA');
unless ( $level ) {
$RT::Logger->debug('Ticket #'. $ticket->id .' has no service level defined, skip setting Starts');
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 4b9dc18..2c54616 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -236,7 +236,7 @@ sub Due {
%{ $RT::BusinessHours{ $meta->{BusinessHours} || 'Default' } } );
$res = $bhours->add_seconds( $res, 60 * $agreement->{'BusinessMinutes'} );
}
- $res += $agreement->{'RealMinutes'}
+ $res += 60 * $agreement->{'RealMinutes'}
if defined $agreement->{'RealMinutes'};
return $res;
commit e5003972cd29b6755672e45b983dbfd558babb96
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri Oct 26 22:20:59 2007 +0000
move code that gets B::Hours' properties into BusinessHours method
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 2c54616..abc45a1 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -177,10 +177,13 @@ In the config and per queue defaults(this is not implemented).
sub BusinessHours {
my $self = shift;
+ my $name = shift || 'Default';
+
require Business::Hours;
- my $bhours = Business::Hours->new;
- $bhours->business_hours(@_) if @_;
- return $bhours;
+ my $res = new Business::Hours;
+ $res->business_hours( %{ $RT::BusinessHours{ $name } } )
+ if $RT::BusinessHours{ $name };
+ return $res;
}
sub Agreement {
@@ -206,9 +209,7 @@ sub Agreement {
}
if ( $args{'Time'} and my $tmp = $meta->{'OutOfHours'}{ $args{'Type'} } ) {
- my $bhours =
- $self->BusinessHours(
- %{ $RT::BusinessHours{ $meta->{BusinessHours} || 'Default' } } );
+ my $bhours = $self->BusinessHours( $meta->{'BusinessHours'} );
if ( $bhours->first_after( $args{'Time'} ) != $args{'Time'} ) {
foreach ( qw(RealMinutes BusinessMinutes) ) {
next unless $tmp->{ $_ };
@@ -231,9 +232,7 @@ sub Due {
my $res = $args{'Time'};
if ( defined $agreement->{'BusinessMinutes'} ) {
- my $bhours =
- $self->BusinessHours(
- %{ $RT::BusinessHours{ $meta->{BusinessHours} || 'Default' } } );
+ my $bhours = $self->BusinessHours( $meta->{'BusinessHours'} );
$res = $bhours->add_seconds( $res, 60 * $agreement->{'BusinessMinutes'} );
}
$res += 60 * $agreement->{'RealMinutes'}
@@ -296,9 +295,8 @@ sub SLA {
my $SLA = $class->new(
BusinessHours => $self->BusinessHours(
- %{ $RT::BusinessHours{ $RT::SLA{Levels}{$level}{BusinessHours}
- || 'Default' } }
- )
+ $RT::SLA{'Levels'}{ $level }{'BusinessHours'}
+ ),
);
$SLA->Add( $level => %{ $self->Agreement(%args) } );
commit 3d9924064b4c9c596790acdc9883cecb79bcbc75
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri Oct 26 22:22:37 2007 +0000
add questionable items to the top, so may be devs/users pay
attention to it and comment :) while we're hacking on tests
and implementation of other things
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index abc45a1..b4bc8c6 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -7,6 +7,18 @@ package RT::Extension::SLA;
RT::Extension::SLA - Service Level Agreements
+=head1 DESIGN QUESTIONS
+
+Here is some questionable things developers/users can comment on:
+
+=over 4
+
+=item
+
+What should happen response agreements when there is no requestors?
+
+=back
+
=head1 DESCRIPTION
To enable service level agreements for a queue administrtor
commit 36aa1b5bfc8e5e562eb4d7b684efba2b7c86a6a4
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri Oct 26 22:23:36 2007 +0000
add first simple test around due
diff --git a/t/due.t b/t/due.t
new file mode 100644
index 0000000..8795b16
--- /dev/null
+++ b/t/due.t
@@ -0,0 +1,48 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 10;
+
+require 't/utils.pl';
+
+use_ok 'RT';
+RT::LoadConfig();
+RT::Init();
+
+use_ok 'RT::Ticket';
+use_ok 'RT::Extension::SLA';
+
+diag 'check Due date';
+{
+ %RT::SLA = (
+ Default => '2',
+ Levels => {
+ '2' => { Resolve => { RealMinutes => 60*2 } },
+ '4' => { Resolve => { RealMinutes => 60*4 } },
+ },
+ );
+
+ my $time = time;
+
+ my $ticket = RT::Ticket->new( $RT::SystemUser );
+ my ($id) = $ticket->Create( Queue => 'General', Subject => 'xxx' );
+ ok $id, "created ticket #$id";
+
+ is $ticket->FirstCustomFieldValue('SLA'), '2', 'default sla';
+
+ my $orig_due = $ticket->DueObj->Unix;
+ ok $orig_due > 0, 'Due date is set';
+ ok $orig_due > $time, 'Due date is in the future';
+
+ $ticket->AddCustomFieldValue( Field => 'SLA', Value => '4' );
+ is $ticket->FirstCustomFieldValue('SLA'), '4', 'new sla';
+
+ my $new_due = $ticket->DueObj->Unix;
+ ok $new_due > 0, 'Due date is set';
+ ok $new_due > $time, 'Due date is in the future';
+
+ is $new_due, $orig_due+2*60*60, 'difference is two hours';
+}
+
commit 771162e5abca49ba0926558f6f5cfb5e28e43ccd
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sat Oct 27 00:47:20 2007 +0000
add more tests, looks like things work
diff --git a/t/due.t b/t/due.t
index 8795b16..be1c7fe 100644
--- a/t/due.t
+++ b/t/due.t
@@ -14,7 +14,7 @@ RT::Init();
use_ok 'RT::Ticket';
use_ok 'RT::Extension::SLA';
-diag 'check Due date';
+diag 'check change of Due date when SLA for a ticket is changed';
{
%RT::SLA = (
Default => '2',
@@ -46,3 +46,152 @@ diag 'check Due date';
is $new_due, $orig_due+2*60*60, 'difference is two hours';
}
+diag 'when not requestor creates a ticket, we dont set due date';
+{
+ %RT::SLA = (
+ Default => '2',
+ Levels => {
+ '2' => { Response => { RealMinutes => 60*2 } },
+ },
+ );
+
+ my $ticket = RT::Ticket->new( $RT::SystemUser );
+ my ($id) = $ticket->Create(
+ Queue => 'General',
+ Subject => 'xxx',
+ Requestor => 'user at example.com',
+ );
+ ok $id, "created ticket #$id";
+
+ is $ticket->FirstCustomFieldValue('SLA'), '2', 'default sla';
+
+ my $due = $ticket->DueObj->Unix;
+ ok $due <= 0, 'Due date is not set';
+}
+
+diag 'check that reply to requestors unset due date';
+{
+ %RT::SLA = (
+ Default => '2',
+ Levels => {
+ '2' => { Response => { RealMinutes => 60*2 } },
+ },
+ );
+
+ my $root = RT::User->new( $RT::SystemUser );
+ $root->LoadByEmail('root at localhost');
+ ok $root->id, 'loaded root user';
+
+ # 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;
+ ok $due > 0, 'Due date is set';
+ }
+
+ # 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.' );
+
+ $ticket = RT::Ticket->new( $root );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+
+ my $due = $ticket->DueObj->Unix;
+ ok $due <= 0, 'Due date is not set';
+ }
+
+ # requestor reply
+ {
+ my $ticket = RT::Ticket->new( $root );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+
+ $ticket->Correspond( Content => 'what\'s going on with my ticket?' );
+
+ $ticket = RT::Ticket->new( $root );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+
+ my $due = $ticket->DueObj->Unix;
+ ok $due > 0, 'Due date is set again';
+ }
+}
+
+diag 'check that replies dont affect resolve deadlines';
+{
+ %RT::SLA = (
+ Default => '2',
+ Levels => {
+ '2' => { Resolve => { RealMinutes => 60*2 } },
+ },
+ );
+
+ my $root = RT::User->new( $RT::SystemUser );
+ $root->LoadByEmail('root at localhost');
+ ok $root->id, 'loaded root user';
+
+ # requestor creates
+ my ($id, $orig_due);
+ {
+ 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';
+
+ $orig_due = $ticket->DueObj->Unix;
+ ok $orig_due > 0, 'Due date is set';
+ }
+
+ # 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.' );
+
+ $ticket = RT::Ticket->new( $root );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+
+ my $due = $ticket->DueObj->Unix;
+ ok $due > 0, 'Due date is set';
+ is $due, $orig_due, 'due is not changed';
+ }
+
+ # requestor reply
+ {
+ my $ticket = RT::Ticket->new( $root );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+
+ $ticket->Correspond( Content => 'what\'s going on with my ticket?' );
+
+ $ticket = RT::Ticket->new( $root );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+
+ my $due = $ticket->DueObj->Unix;
+ ok $due > 0, 'Due date is set';
+ is $due, $orig_due, 'due is not changed';
+ }
+}
+
commit 453150be66df37378679e52886174d8216bcde17
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sat Oct 27 01:23:51 2007 +0000
doc update
** made a decision on one questionable item
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index b4bc8c6..2ad4212 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -13,10 +13,6 @@ Here is some questionable things developers/users can comment on:
=over 4
-=item
-
-What should happen response agreements when there is no requestors?
-
=back
=head1 DESCRIPTION
@@ -93,16 +89,37 @@ due date is also unset.
B<NOTE> that behaviour changes when Resolve and Response options
are combined, read below.
+As response deadlines are calculated using requestors' activity
+so several rules applies to make things quite sane:
+
+=over 4
+
+=item
+
+If a ticket has no requestors then it has no response deadline.
+
+=item
+
+If a ticket is created by non-requestor then due date is left unset.
+
+=item
+
+If owner of a ticket is its requestor then his actions are treated
+as non-requestors'.
+
+=back
+
=head3 Using both Resolve and Response in the same level
Resolve and Response can be combined. In such case due date is set
according to the earliest of two deadlines and never is dropped to
-not set. When non-requestor replies to a ticket, due date is changed to
-Resolve deadline, as well this happens when a ticket is closed. So
-all the time due date is defined.
+not set.
-If a ticket met its Resolve deadline then due date stops "fliping" and
-is freezed and the ticket becomes overdue.
+If a ticket met its Resolve deadline then due date stops "fliping",
+is freezed and the ticket becomes overdue. Before that moment when
+non-requestor replies to a ticket, due date is changed to Resolve
+deadline instead of 'Not Set', as well this happens when a ticket
+is closed. So all the time due date is defined.
Example:
@@ -355,7 +372,6 @@ sub GetDefaultServiceLevel {
=head2 v0.01
-* we have one Business::Hours object
* default SLA for queues
** see below in this class
* changing service levels of a ticket in the middle of its live
commit e955db839f2e5bc3d0ab6e58bb803d71833268b6
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sat Oct 27 01:50:56 2007 +0000
add more tests
diff --git a/t/due.t b/t/due.t
index be1c7fe..4fb8b8d 100644
--- a/t/due.t
+++ b/t/due.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More tests => 46;
require 't/utils.pl';
@@ -114,7 +114,23 @@ diag 'check that reply to requestors unset due date';
ok $due <= 0, 'Due date is not set';
}
+ # non-requestor reply again
+ {
+ my $ticket = RT::Ticket->new( $RT::SystemUser );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+ $ticket->Correspond( Content => 'we are still working on this.' );
+
+ $ticket = RT::Ticket->new( $root );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+
+ my $due = $ticket->DueObj->Unix;
+ ok $due <= 0, 'Due date is not set';
+ }
+
# requestor reply
+ my $last_unreplied_due;
{
my $ticket = RT::Ticket->new( $root );
$ticket->Load( $id );
@@ -128,6 +144,26 @@ diag 'check that reply to requestors unset due date';
my $due = $ticket->DueObj->Unix;
ok $due > 0, 'Due date is set again';
+
+ $last_unreplied_due = $due;
+ }
+
+ # sleep at least one second and requestor replies again
+ sleep 1;
+ {
+ my $ticket = RT::Ticket->new( $root );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+
+ $ticket->Correspond( Content => 'HEY! Were is my answer?' );
+
+ $ticket = RT::Ticket->new( $root );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+
+ my $due = $ticket->DueObj->Unix;
+ ok $due > 0, 'Due date is still set';
+ is $due, $last_unreplied_due, 'due is unchanged';
}
}
@@ -195,3 +231,66 @@ diag 'check that replies dont affect resolve deadlines';
}
}
+diag 'check that owner is not treated as requestor';
+{
+ %RT::SLA = (
+ Default => '2',
+ Levels => {
+ '2' => { Response => { RealMinutes => 60*2 } },
+ },
+ );
+
+ my $root = RT::User->new( $RT::SystemUser );
+ $root->LoadByEmail('root at localhost');
+ ok $root->id, 'loaded root user';
+
+ # requestor creates and he is owner
+ my $id;
+ {
+ my $ticket = RT::Ticket->new( $root );
+ ($id) = $ticket->Create(
+ Queue => 'General',
+ Subject => 'xxx',
+ Requestor => $root->id,
+ Owner => $root->id,
+ );
+ ok $id, "created ticket #$id";
+
+ is $ticket->FirstCustomFieldValue('SLA'), '2', 'default sla';
+ is $ticket->Owner, $root->id, 'correct owner';
+
+ my $due = $ticket->DueObj->Unix;
+ ok $due <= 0, 'Due date is not set';
+ }
+}
+
+diag 'check that response deadline is left alone when there is no requestor';
+{
+ %RT::SLA = (
+ Default => '2',
+ Levels => {
+ '2' => { Response => { RealMinutes => 60*2 } },
+ },
+ );
+
+ my $root = RT::User->new( $RT::SystemUser );
+ $root->LoadByEmail('root at localhost');
+ ok $root->id, 'loaded root user';
+
+ # create a ticket without requestor
+ my $id;
+ {
+ my $ticket = RT::Ticket->new( $root );
+ ($id) = $ticket->Create(
+ Queue => 'General',
+ Subject => 'xxx',
+ );
+ ok $id, "created ticket #$id";
+
+ is $ticket->FirstCustomFieldValue('SLA'), '2', 'default sla';
+
+ my $due = $ticket->DueObj->Unix;
+ ok $due <= 0, 'Due date is not set';
+ }
+}
+
commit b03c65b689328e69786a663243905c6c564a35de
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sat Oct 27 02:06:16 2007 +0000
fix number of tests in the file
diff --git a/t/due.t b/t/due.t
index 4fb8b8d..0689fcd 100644
--- a/t/due.t
+++ b/t/due.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 46;
+use Test::More tests => 52;
require 't/utils.pl';
commit 1c647e1bf7c3706717698c2eee3a550cde940aa2
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sat Oct 27 02:11:11 2007 +0000
replace LastCorrespond with 'LastRequestorsEffectiveAct'
** pretty long name, but descriptive
** returns returns txn that should be used as starting point
for response deadline calculations
* don't treat Owner as requestor even if he is
diff --git a/lib/RT/Action/SLA_SetDue.pm b/lib/RT/Action/SLA_SetDue.pm
index 90b56bb..068e741 100644
--- a/lib/RT/Action/SLA_SetDue.pm
+++ b/lib/RT/Action/SLA_SetDue.pm
@@ -43,16 +43,16 @@ sub Commit {
my $txn = $self->TransactionObj;
- my $last_reply = $self->LastCorrespond;
- $RT::Logger->debug('Last reply to ticket #'. $ticket->id .' is txn #'. $last_reply->id );
- my $is_requestors_act = $self->IsRequestorsAct( $last_reply );
- $RT::Logger->debug('Txn #'. $last_reply->id .' is requestors\' action') if $is_requestors_act;
+ my $last_reply = $self->LastRequestorsEffectiveAct;
+ $RT::Logger->debug('Last effective requestors\' reply to ticket #'. $ticket->id .' is txn #'. $last_reply->id )
+ if $last_reply;
- my $response_due = $self->Due(
+ my $response_due;
+ $response_due = $self->Due(
Level => $level,
Type => 'Response',
Time => $last_reply->CreatedObj->Unix,
- );
+ ) if $last_reply;
my $resolve_due = $self->Due(
Level => $level,
@@ -60,10 +60,8 @@ sub Commit {
Time => $ticket->CreatedObj->Unix,
);
- my $type = $txn->Type;
-
my $due;
- $due = $response_due if defined $response_due && $is_requestors_act;
+ $due = $response_due if defined $response_due;
$due = $resolve_due unless defined $due;
$due = $resolve_due if defined $due && defined $resolve_due && $resolve_due < $due;
@@ -88,17 +86,16 @@ sub IsRequestorsAct {
my $self = shift;
my $txn = shift || $self->TransactionObj;
- return $self->TicketObj->Requestors->HasMemberRecursively(
- $txn->CreatorObj->PrincipalObj
- )? 1 : 0;
+ my $actor = $txn->CreatorObj->PrincipalObj;
+
+ # owner is always treated as non-requestor
+ return 0 if $actor->id == $self->TicketObj->Owner;
+
+ return $self->TicketObj->Requestors->HasMemberRecursively( $actor )? 1 : 0;
}
-sub LastCorrespond {
+sub LastRequestorsEffectiveAct {
my $self = shift;
-
- my $txn = $self->TransactionObj;
- return $txn if $txn->Type eq 'Create'
- || $txn->Type eq 'Correspond';
my $txns = $self->TicketObj->Transactions;
$txns->Limit( FIELD => 'Type', VALUE => 'Correspond' );
@@ -107,8 +104,13 @@ sub LastCorrespond {
{ FIELD => 'Created', ORDER => 'DESC' },
{ FIELD => 'id', ORDER => 'DESC' },
);
- $txns->RowsPerPage(1);
- return $txns->First;
+
+ my $res;
+ while ( my $txn = $txns->Next ) {
+ return $res unless $self->IsRequestorsAct( $txn );
+ $res = $txn;
+ }
+ return $res;
}
1;
commit b80228d8d576bfe9803cbe9f068709b93d391eca
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sat Oct 27 02:17:41 2007 +0000
update doc
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 2ad4212..91463bb 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -96,6 +96,11 @@ so several rules applies to make things quite sane:
=item
+If requestors reply multiple times and are ignored then the deadline
+is calculated using the oldest requestors' correspondence.
+
+=item
+
If a ticket has no requestors then it has no response deadline.
=item
commit 16a8a469e69f838e233f46581190bafa1864a720
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sat Oct 27 02:24:42 2007 +0000
update todo list
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 91463bb..bed4258 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -378,14 +378,16 @@ sub GetDefaultServiceLevel {
=head2 v0.01
* default SLA for queues
-** see below in this class
-* changing service levels of a ticket in the middle of its live
-** this should work for Due dates, for Starts makes not much sense
+** implemented
+** TODO: tests
+
+* add support for multiple b-hours definitions, this could be very helpfull when you have 24/7 mixed with 8/5 and/or something like 8/5+4/2 for different tickets(by requestor, queue or something else). So people would be able to handle tickets in the right order using Due dates.
+** implemented
+** TODO: tests
=head2 v0.later
* WebUI
-* add support for multiple b-hours definitions, this could be very helpfull when you have 24/7 mixed with 8/5 and/or something like 8/5+4/2 for different tickets(by requestor, queue or something else). So people would be able to handle tickets in the right order using Due dates.
=head1 DESIGN
commit 01d64b1c1c2960e449411e51c75723523900dba3
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sat Oct 27 02:38:37 2007 +0000
rename lib/RT/Extension/QueueSLA.pm -> lib/RT/Queue_SLA.pm
** so it's now in one row with lib/RT/Queue_*.pm...
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index bed4258..65c1d1e 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -361,9 +361,9 @@ sub GetDefaultServiceLevel {
}
if ( $args{'Queue'} ) {
local $@;
- eval { require RT::Extension::QueueSLA };
+ eval { require RT::Queue_SLA };
if ( $@ ) {
- $RT::Logger->crit("Couldn't load RT::Extension::QueueSLA: $@");
+ $RT::Logger->crit("Couldn't load RT::Queue_SLA: $@");
}
else {
return $self->TicketObj->QueueObj->SLA
diff --git a/lib/RT/Extension/QueueSLA.pm b/lib/RT/Queue_SLA.pm
similarity index 100%
rename from lib/RT/Extension/QueueSLA.pm
rename to lib/RT/Queue_SLA.pm
commit 6d0ae350416f571c28533e009e557358d0c487db
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sat Oct 27 02:48:57 2007 +0000
fix number of tests and a little bug in the test
diff --git a/t/starts.t b/t/starts.t
index f2c7380..069a624 100644
--- a/t/starts.t
+++ b/t/starts.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More tests => 9;
require 't/utils.pl';
@@ -63,7 +63,8 @@ diag 'check Starts date with StartImmediately enabled';
my ($id) = $ticket->Create( Queue => 'General', Subject => 'xxx' );
ok $id, "created ticket #$id";
- ok $ticket->StartsObj->Unix > 0, 'Starts date is set';
+ my $starts = $ticket->StartsObj->Unix;
+ ok $starts > 0, 'Starts date is set';
ok abs($starts - $time) < 5, 'Starts is quite correct';
}
commit 2dfff54bc1c049aafb5fd84660f24bbf489883ca
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sat Oct 27 03:27:12 2007 +0000
abstract setting up date field
diff --git a/lib/RT/Action/SLA.pm b/lib/RT/Action/SLA.pm
index 88fa9c1..f4f853e 100644
--- a/lib/RT/Action/SLA.pm
+++ b/lib/RT/Action/SLA.pm
@@ -6,4 +6,30 @@ package RT::Action::SLA;
use base qw(RT::Extension::SLA RT::Action::Generic);
+sub SetDateField {
+ my $self = shift;
+ my ($type, $value) = (@_);
+
+ my $ticket = $self->TicketObj;
+
+ my $method = $type .'Obj';
+ if ( defined $value ) {
+ return 1 if $ticket->$method->Unix == $value;
+ } else {
+ return 1 if $ticket->$method->Unix <= 0;
+ }
+
+ my $date = RT::Date->new( $RT::SystemUser );
+ $date->Set( Format => 'unix', Value => $value );
+
+ my $method = 'Set'. $type;
+ my ($status, $msg) = $ticket->$method( $date->ISO );
+ unless ( $status ) {
+ $RT::Logger->error("Couldn't set $type date: $msg");
+ return 0;
+ }
+
+ return 1;
+}
+
1;
diff --git a/lib/RT/Action/SLA_SetDue.pm b/lib/RT/Action/SLA_SetDue.pm
index 068e741..d7e89f2 100644
--- a/lib/RT/Action/SLA_SetDue.pm
+++ b/lib/RT/Action/SLA_SetDue.pm
@@ -65,21 +65,7 @@ sub Commit {
$due = $resolve_due unless defined $due;
$due = $resolve_due if defined $due && defined $resolve_due && $resolve_due < $due;
- if ( defined $due ) {
- return 1 if $ticket->DueObj->Unix == $due;
- } else {
- return 1 if $ticket->DueObj->Unix <= 0;
- }
-
- my $date = RT::Date->new( $RT::SystemUser );
- $date->Set( Format => 'unix', Value => $due );
- my ($status, $msg) = $self->TicketObj->SetDue( $date->ISO );
- unless ( $status ) {
- $RT::Logger->error("Couldn't set due date: $msg");
- return 0;
- }
-
- return 1;
+ return $self->SetDateField( Due => $due );
}
sub IsRequestorsAct {
commit 59a46b1b1d214f385ca51d34b4e8cfc2a9e61dcd
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sat Oct 27 03:28:43 2007 +0000
make test a little bit more correct
diff --git a/t/starts.t b/t/starts.t
index 069a624..f9f13a2 100644
--- a/t/starts.t
+++ b/t/starts.t
@@ -20,9 +20,9 @@ my $bhours = RT::Extension::SLA->BusinessHours;
diag 'check Starts date';
{
%RT::SLA = (
- Default => 'start',
+ Default => 'standard',
Levels => {
- 'starts' => {
+ 'standard' => {
Response => 2*60,
Resolve => 7*60*24,
},
@@ -65,6 +65,6 @@ diag 'check Starts date with StartImmediately enabled';
my $starts = $ticket->StartsObj->Unix;
ok $starts > 0, 'Starts date is set';
- ok abs($starts - $time) < 5, 'Starts is quite correct';
+ is $starts, $ticket->CreatedObj->Unix, 'Starts is correct';
}
commit 0a2efebcce7998352be88ebf0e72e28130fd620f
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sat Oct 27 03:31:31 2007 +0000
delete some old functions we don't want to use
* reimplement SetStarts action using new API
diff --git a/lib/RT/Action/SLA_SetStarts.pm b/lib/RT/Action/SLA_SetStarts.pm
index f3cc1eb..9aa2b5a 100644
--- a/lib/RT/Action/SLA_SetStarts.pm
+++ b/lib/RT/Action/SLA_SetStarts.pm
@@ -27,28 +27,18 @@ sub Commit {
my $ticket = $self->TicketObj;
-# XXX I encountered a 'Couldn't set starts date: That is already the current
-# value' warning if I didn't test it here. wierd
- return 0 if $ticket->StartsObj->Unix > 0;
-
my $level = $ticket->FirstCustomFieldValue('SLA');
unless ( $level ) {
$RT::Logger->debug('Ticket #'. $ticket->id .' has no service level defined, skip setting Starts');
return 1;
}
- my $SLA = $self->SLA(Level => $level);
- my $starts = $SLA->Starts( $self->TransactionObj->CreatedObj->Unix, $level );
-
- my $date = RT::Date->new($RT::SystemUser);
- $date->Set( Format => 'unix', Value => $starts );
- my ($status, $msg) = $ticket->SetStarts( $date->ISO );
- unless ( $status ) {
- $RT::Logger->error("Couldn't set starts date: $msg");
- return 0;
- }
+ my $starts = $self->Starts(
+ Level => $level,
+ Time => $ticket->CreatedObj->Unix,
+ );
- return 1;
+ return $self->SetDateField( Starts => $starts );
}
1;
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 65c1d1e..a7855b1 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -259,11 +259,12 @@ sub Agreement {
sub Due {
my $self = shift;
my %args = ( Level => undef, Type => undef, Time => undef, @_ );
- my $meta = $RT::SLA{'Levels'}{ $args{'Level'} };
my $agreement = $self->Agreement( %args );
return undef unless $agreement;
+ my $meta = $RT::SLA{'Levels'}{ $args{'Level'} };
+
my $res = $args{'Time'};
if ( defined $agreement->{'BusinessMinutes'} ) {
my $bhours = $self->BusinessHours( $meta->{'BusinessHours'} );
@@ -275,67 +276,17 @@ sub Due {
return $res;
}
-
-=head2 Agreements [ Type => 'Response' ]
-
-DEPRECATED
-
-Returns an instance of L<Business::SLA> class filled with
-service levels for particular Type.
-
-Now we take list of agreements and its description from the
-RT config.
-
-By default Type is 'Response'. 'Resolve' is another type
-we support.
-
-=cut
-
-sub Agreements {
+sub Starts {
my $self = shift;
- my %args = ( Type => 'Response', Time => undef, @_ );
-
- my $class = $RT::SLA{'Module'} || 'Business::SLA';
- eval "require $class" or die $@;
- my $SLA = $class->new( BusinessHours => $self->BusinessHours );
-
- my $levels = $RT::SLA{'Levels'};
- foreach my $level ( keys %$levels ) {
- my $props = $self->Agreement( %args, Level => $level );
- next unless $props;
+ my %args = ( Level => undef, Time => undef, @_ );
- $SLA->Add( $level => %$props );
- }
-
- return $SLA;
-}
-
-=head2 SLA [ Level => $level ]
-
-Returns an instance of L<Business::SLA> class filled with the level.
-
-Now we take list of agreements and its description from the
-RT config.
-
-=cut
-
-sub SLA {
- my $self = shift;
- my %args = @_;
- my $level = $args{Level};
-
- my $class = $RT::SLA{'Module'} || 'Business::SLA';
- eval "require $class" or die $@;
-
- my $SLA = $class->new(
- BusinessHours => $self->BusinessHours(
- $RT::SLA{'Levels'}{ $level }{'BusinessHours'}
- ),
- );
+ my $meta = $RT::SLA{'Levels'}{ $args{'Level'} };
+ return undef unless $meta;
- $SLA->Add( $level => %{ $self->Agreement(%args) } );
+ return $args{'Time'} if $meta->{'StartImmediately'};
- return $SLA;
+ my $bhours = $self->BusinessHours( $meta->{'BusinessHours'} );
+ return $bhours->first_after( $args{'Time'} );
}
sub GetCustomField {
commit f2e921c8fa650b4f835d0bdb1b4eba7bfc9f5226
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sat Oct 27 03:33:32 2007 +0000
we don't Business::SLA anymore
diff --git a/META.yml b/META.yml
index 54a2088..5b7ce97 100644
--- a/META.yml
+++ b/META.yml
@@ -17,5 +17,4 @@ no_index:
- t
requires:
Business::Hours: 0
- Business::SLA: 0
version: undef
diff --git a/Makefile.PL b/Makefile.PL
index 9e94688..78b2f01 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -6,7 +6,6 @@ license('perl');
build_requires('Test::More');
-requires('Business::SLA');
requires('Business::Hours');
auto_install();
commit 2a9786b03c6ed38ce7f249d404cb5cd3cead2e61
Author: sunnavy <sunnavy at bestpractical.com>
Date: Sat Oct 27 20:08:30 2007 +0000
added default queue sla test
diff --git a/t/queue.t b/t/queue.t
new file mode 100644
index 0000000..878e2f9
--- /dev/null
+++ b/t/queue.t
@@ -0,0 +1,58 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 9;
+
+require 't/utils.pl';
+
+use_ok 'RT';
+RT::LoadConfig();
+RT::Init();
+
+use_ok 'RT::Ticket';
+use_ok 'RT::Extension::SLA';
+
+my $queue = RT::Queue->new($RT::SystemUser);
+$queue->Load('General');
+
+my $queue_sla = RT::Attribute->new($RT::SystemUser);
+
+diag 'check set of Due date with Queue default SLA';
+{
+
+ # add default SLA for 'General';
+ my ($id) = $queue_sla->Create(
+ Name => 'SLA',
+ Description => 'Default Queue SLA',
+ Content => '4',
+ Object => $queue
+ );
+
+ ok( $id, 'Created SLA Attribute for General' );
+
+ %RT::SLA = (
+ Default => '2',
+ Levels => {
+ '2' => { Resolve => { RealMinutes => 60 * 2 } },
+ '4' => { Resolve => { RealMinutes => 60 * 4 } },
+ },
+ );
+
+ my $time = time;
+
+ my $ticket = RT::Ticket->new($RT::SystemUser);
+ ($id) = $ticket->Create( Queue => 'General', Subject => 'xxx' );
+ ok $id, "created ticket #$id";
+
+ is $ticket->FirstCustomFieldValue('SLA'), '4', 'default sla';
+
+ my $orig_due = $ticket->DueObj->Unix;
+ ok $orig_due > 0, 'Due date is set';
+ ok $orig_due > $time, 'Due date is in the future';
+
+ my ( $status, $message ) = $queue->DeleteAttribute('SLA');
+ ok( $status, $message );
+}
+
commit fe4ce2c572609412e97d6956389cc2ea2f31a4b3
Author: sunnavy <sunnavy at bestpractical.com>
Date: Sat Oct 27 21:02:26 2007 +0000
initial tests for business_hours, rough
diff --git a/t/business_hours.t b/t/business_hours.t
new file mode 100644
index 0000000..e3bcf91
--- /dev/null
+++ b/t/business_hours.t
@@ -0,0 +1,72 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 10;
+
+require 't/utils.pl';
+
+use_ok 'RT';
+RT::LoadConfig();
+RT::Init();
+
+use_ok 'RT::Ticket';
+use_ok 'RT::Extension::SLA';
+
+diag 'check business hours';
+{
+
+ %RT::SLA = (
+ Default => 'Sunday',
+ Levels => {
+ Sunday => {
+ Resolve => { BusinessMinutes => 60 },
+ BusinessHours => 'Sunday',
+ },
+ Monday => {
+ Resolve => { BusinessMinutes => 60 },
+ BusinessHours => 'Default',
+ },
+ },
+ );
+
+ %RT::BusinessHours = (
+ Sunday => {
+ 0 => {
+ Name => 'Sunday',
+ Start => '9:00',
+ End => '17:00'
+ }
+ },
+ Default => {
+ 1 => {
+ Name => 'Monday',
+ Start => '9:00',
+ End => '17:00'
+ },
+ },
+ );
+
+ my $time = time;
+
+ my $ticket = RT::Ticket->new($RT::SystemUser);
+ my ($id) = $ticket->Create( Queue => 'General', Subject => 'xxx' );
+ ok( $id, "created ticket #$id" );
+
+ is( $ticket->FirstCustomFieldValue('SLA'), 'Sunday', 'default sla' );
+
+ my $due = $ticket->DueObj->Unix;
+ ok( $due > 0, 'Due date is set' );
+ ok( $due > $time, 'Due date is in the future');
+
+ my ( undef,$min,$hour,$mday,$mon,$year,$wday ) = gmtime( $due );
+ is( $wday, 0, 'original due time is on Sunday' );
+
+ $ticket->AddCustomFieldValue( Field => 'SLA', Value => 'Monday' );
+ is( $ticket->FirstCustomFieldValue('SLA'), 'Monday', 'new sla' );
+ $due = $ticket->DueObj->Unix;
+ ( undef,$min,$hour,$mday,$mon,$year,$wday ) = gmtime( $due );
+ is( $wday, 1, 'new due time is on Monday' );
+}
+
commit b5acd6a97fba4c75b52fe9300758e4c04cc917b7
Author: sunnavy <sunnavy at bestpractical.com>
Date: Mon Oct 29 14:04:49 2007 +0000
use Time::MockTime to test more accurately
diff --git a/t/business_hours.t b/t/business_hours.t
index e3bcf91..911488f 100644
--- a/t/business_hours.t
+++ b/t/business_hours.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More tests => 9;
require 't/utils.pl';
@@ -14,6 +14,11 @@ RT::Init();
use_ok 'RT::Ticket';
use_ok 'RT::Extension::SLA';
+use Test::MockTime qw( :all );
+
+# XXX, TODO
+# we assume the RT's Timezone is UTC now, need a smart way to get over that.
+
diag 'check business hours';
{
@@ -26,7 +31,6 @@ diag 'check business hours';
},
Monday => {
Resolve => { BusinessMinutes => 60 },
- BusinessHours => 'Default',
},
},
);
@@ -48,7 +52,7 @@ diag 'check business hours';
},
);
- my $time = time;
+ set_absolute_time('2007-01-01T00:00:00Z');
my $ticket = RT::Ticket->new($RT::SystemUser);
my ($id) = $ticket->Create( Queue => 'General', Subject => 'xxx' );
@@ -56,17 +60,14 @@ diag 'check business hours';
is( $ticket->FirstCustomFieldValue('SLA'), 'Sunday', 'default sla' );
+ my $start = $ticket->StartsObj->Unix;
my $due = $ticket->DueObj->Unix;
- ok( $due > 0, 'Due date is set' );
- ok( $due > $time, 'Due date is in the future');
-
- my ( undef,$min,$hour,$mday,$mon,$year,$wday ) = gmtime( $due );
- is( $wday, 0, 'original due time is on Sunday' );
+ is( $start, 1168160400, 'Start date is 2007-01-07T09:00:00Z' );
+ is( $due, 1168164000, 'Due date is 2007-01-07T10:00:00Z' );
$ticket->AddCustomFieldValue( Field => 'SLA', Value => 'Monday' );
is( $ticket->FirstCustomFieldValue('SLA'), 'Monday', 'new sla' );
$due = $ticket->DueObj->Unix;
- ( undef,$min,$hour,$mday,$mon,$year,$wday ) = gmtime( $due );
- is( $wday, 1, 'new due time is on Monday' );
+ is( $due, 1167645600, 'Due date is 2007-01-01T10:00:00Z' );
}
diff --git a/t/queue.t b/t/queue.t
index 878e2f9..075e179 100644
--- a/t/queue.t
+++ b/t/queue.t
@@ -14,6 +14,9 @@ RT::Init();
use_ok 'RT::Ticket';
use_ok 'RT::Extension::SLA';
+use Test::MockTime qw( :all );
+
+
my $queue = RT::Queue->new($RT::SystemUser);
$queue->Load('General');
@@ -36,21 +39,23 @@ diag 'check set of Due date with Queue default SLA';
Default => '2',
Levels => {
'2' => { Resolve => { RealMinutes => 60 * 2 } },
- '4' => { Resolve => { RealMinutes => 60 * 4 } },
+ '4' => { StartImmediately => 1, Resolve => { RealMinutes => 60 * 4 } },
},
);
- my $time = time;
+ set_absolute_time('2007-01-01T00:00:00Z');
+ my $time = time;
my $ticket = RT::Ticket->new($RT::SystemUser);
($id) = $ticket->Create( Queue => 'General', Subject => 'xxx' );
- ok $id, "created ticket #$id";
+ ok( $id, "created ticket #$id" );
is $ticket->FirstCustomFieldValue('SLA'), '4', 'default sla';
- my $orig_due = $ticket->DueObj->Unix;
- ok $orig_due > 0, 'Due date is set';
- ok $orig_due > $time, 'Due date is in the future';
+ my $start = $ticket->StartsObj->Unix;
+ my $due = $ticket->DueObj->Unix;
+ is( $start, $time, 'Start Date is right' );
+ is( $due, $time+3600*4, 'Due date is right');
my ( $status, $message ) = $queue->DeleteAttribute('SLA');
ok( $status, $message );
commit 11caa88dc0eaec86b48a6201bd30acbc7c414e00
Author: sunnavy <sunnavy at bestpractical.com>
Date: Tue Oct 30 13:09:30 2007 +0000
more accuate tests
diff --git a/t/starts.t b/t/starts.t
index f9f13a2..00a5f91 100644
--- a/t/starts.t
+++ b/t/starts.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 9;
+use Test::More tests => 12;
require 't/utils.pl';
@@ -15,51 +15,68 @@ use_ok 'RT::Ticket';
use_ok 'RT::Extension::SLA';
+use Test::MockTime qw( :all );
+
my $bhours = RT::Extension::SLA->BusinessHours;
diag 'check Starts date';
{
%RT::SLA = (
Default => 'standard',
- Levels => {
+ Levels => {
'standard' => {
- Response => 2*60,
- Resolve => 7*60*24,
+ Response => 2 * 60,
+ Resolve => 7 * 60 * 24,
},
},
);
+ %RT::BusinessHours = (
+ Default => {
+ 1 => {
+ Name => 'Monday',
+ Start => '09:00',
+ End => '17:00'
+ },
+ 2 => {
+ Name => 'Tuesday',
+ Start => '09:00',
+ End => '17:00'
+ },
+ }
+ );
- my $time = time;
-
- my $ticket = RT::Ticket->new( $RT::SystemUser );
- my ($id) = $ticket->Create( Queue => 'General', Subject => 'xxx' );
- ok $id, "created ticket #$id";
+ my %time = (
+ '2007-01-01T13:15:00Z' => 1167657300, # 2007-01-01T13:15:00Z
+ '2007-01-01T19:15:00Z' => 1167728400, # 2007-01-02T09:00:00Z
+ '2007-01-06T13:15:00Z' => 1168246800, # 2007-01-08T09:00:00Z
+ );
- my $starts = $ticket->StartsObj->Unix;
- ok $starts > 0, 'Starts date is set';
- if ( $bhours->first_after($time) == $time ) {
- # in hours
- ok $starts - $time < 5, 'Starts is quite correct';
- } else {
- ok $starts - $time > 5 , 'Starts is quite correct';
+ for my $time ( keys %time ) {
+ set_absolute_time($time);
+ my $ticket = RT::Ticket->new($RT::SystemUser);
+ my ($id) = $ticket->Create( Queue => 'General', Subject => 'xxx' );
+ ok $id, "created ticket #$id";
+ is $ticket->StartsObj->Unix, $time{$time}, 'Starts date is right';
}
+
+ restore_time();
}
diag 'check Starts date with StartImmediately enabled';
{
%RT::SLA = (
Default => 'start immediately',
- Levels => {
+ Levels => {
'start immediately' => {
StartImmediately => 1,
- Response => 2*60,
- Resolve => 7*60*24,
+ Response => 2 * 60,
+ Resolve => 7 * 60 * 24,
},
},
);
my $time = time;
- my $ticket = RT::Ticket->new( $RT::SystemUser );
+ my $ticket = RT::Ticket->new($RT::SystemUser);
my ($id) = $ticket->Create( Queue => 'General', Subject => 'xxx' );
ok $id, "created ticket #$id";
commit 20ca6e3a07da1fa8d34484f4b3721992b615decc
Author: sunnavy <sunnavy at bestpractical.com>
Date: Wed Oct 31 08:47:41 2007 +0000
no warnings 'once' for %RT::SLA and %RT::BusinessHours
diff --git a/t/business_hours.t b/t/business_hours.t
index 911488f..336834a 100644
--- a/t/business_hours.t
+++ b/t/business_hours.t
@@ -22,6 +22,7 @@ use Test::MockTime qw( :all );
diag 'check business hours';
{
+ no warnings 'once';
%RT::SLA = (
Default => 'Sunday',
Levels => {
diff --git a/t/queue.t b/t/queue.t
index 075e179..2ee3d4a 100644
--- a/t/queue.t
+++ b/t/queue.t
@@ -35,6 +35,7 @@ diag 'check set of Due date with Queue default SLA';
ok( $id, 'Created SLA Attribute for General' );
+ no warnings 'once';
%RT::SLA = (
Default => '2',
Levels => {
commit 873d0eec4be3e042f81d5fbbf36dd5655ad379e2
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Nov 1 07:32:55 2007 +0000
allow to speccify per queue defaults in the config as we have no web UI right now
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index a7855b1..a180515 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -317,8 +317,10 @@ sub GetDefaultServiceLevel {
$RT::Logger->crit("Couldn't load RT::Queue_SLA: $@");
}
else {
- return $self->TicketObj->QueueObj->SLA
- if $self->TicketObj->QueueObj->SLA;
+ return $args{'Queue'}->SLA if $args{'Queue'}->SLA;
+ }
+ if ( $RT::SLA{'QueueDefault'} && $RT::SLA{'QueueDefault'}{ $args{'Queue'}->Name } ) {
+ return $RT::SLA{'QueueDefault'}{ $args{'Queue'}->Name };
}
}
return $RT::SLA{'Default'};
commit 781d190425793a0e30a4df22c47db3307b5f26bb
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Feb 14 04:20:33 2008 +0000
update docs
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index a180515..77ce921 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -5,19 +5,16 @@ package RT::Extension::SLA;
=head1 NAME
-RT::Extension::SLA - Service Level Agreements
+RT::Extension::SLA - Service Level Agreements for RT
-=head1 DESIGN QUESTIONS
-
-Here is some questionable things developers/users can comment on:
-
-=over 4
+=head1 DESCRIPTION
-=back
+RT's extension that allows you to automate due dates using
+service levels.
-=head1 DESCRIPTION
+=head1 CONFIGURATION
-To enable service level agreements for a queue administrtor
+To enable service level agreements for a queue administrator
should create and apply SLA custom field. To define different
levels for different queues he CAN create several CFs with
the same name and different set of values. All CFs MUST be
@@ -26,7 +23,7 @@ of the same 'select one value' type.
Values of the CF(s) define service levels.
Each service level can be described using several options:
-StartImmediately, OutOfHours, Resolve and Response.
+L</StartImmediately>, L</OutOfHours>, L</Resolve> and L</Response>.
=head2 StartImmediately (boolean, false)
@@ -137,7 +134,7 @@ A client orders goods and due date of the order is set to the next one
hour, you have this hour to process the order and write a reply.
As soon as goods are delivered you resolve tickets and usually meet
Resolve deadline, but if you don't resolve or user replies then most
-probably there are problems with deliver or the goods. And if after
+probably there are problems with delivery of the goods. And if after
a week you keep replying to the client and always meeting one hour
response deadline that doesn't mean the ticket is not over due.
Due date was frozen 24 hours after creation of the order.
@@ -145,8 +142,8 @@ Due date was frozen 24 hours after creation of the order.
=head3 Using business and real time in one option
It's quite rare situation when people need it, but we've decided
-that deadline described using both types of time then business
-is applied first and then real time. For example:
+that business is applied first and then real time when deadline
+described using both types of time. For example:
'delivery' => {
Resolve => { BusinessMinutes => 0, RealMinutes => 60*8 },
@@ -165,7 +162,8 @@ next 8 hours after creation.
=head2 OutOfHours (struct, no default)
Out of hours modifier. Adds more real or business minutes to resolve
-and/or reply options if event happens out of business hours.
+and/or reply options if event happens out of business hours, see also
+</BusinessHours> below.
Example:
@@ -175,7 +173,7 @@ Example:
},
If a request comes into the system during night then supporters have two
-days, otherwise only one.
+hours, otherwise only one.
'level x' => {
OutOfHours => { Response => { BusinessMinutes => +60*2 } },
@@ -187,7 +185,23 @@ of requests that came into the system during the last night.
=head2 BusinessHours
-Each level now supports BusinessHours option to specify your own business
+In the config you can set one or more work schedules. Use the following
+format:
+
+ %RT::BusinessHours = (
+ 'label to use' => {
+ ... description ...
+ },
+ 'another label' => {
+ ... description ...
+ },
+ );
+
+Read more about how to describe a schedule in L<Business::Hours>.
+
+=head3 Defining different business hours for service levels
+
+Each level supports BusinessHours option to specify your own business
hours.
'level x' => {
@@ -197,9 +211,9 @@ hours.
then %RT::BusinessHours should have the corresponding definition:
-%RT::BusinessHours = ( 'work just in Monday' => {
+ %RT::BusinessHours = ( 'work just in Monday' => {
1 => { Name => 'Monday', Start => '9:00', End => '18:00' }
- });
+ } );
Default Business Hours setting is in $RT::BusinessHours{'Default'}.
@@ -328,19 +342,18 @@ sub GetDefaultServiceLevel {
=head1 TODO
-=head2 v0.01
-
-* default SLA for queues
-** implemented
-** TODO: tests
-
-* add support for multiple b-hours definitions, this could be very helpfull when you have 24/7 mixed with 8/5 and/or something like 8/5+4/2 for different tickets(by requestor, queue or something else). So people would be able to handle tickets in the right order using Due dates.
-** implemented
-** TODO: tests
+ * default SLA for queues
+ ** implemented
+ ** TODO: docs, tests
-=head2 v0.later
+ * add support for multiple b-hours definitions, this could be very helpfull
+ when you have 24/7 mixed with 8/5 and/or something like 8/5+4/2 for different
+ tickets(by requestor, queue or something else). So people would be able to
+ handle tickets in the right order using Due dates.
+ ** implemented
+ ** TODO: tests
-* WebUI
+ * WebUI
=head1 DESIGN
commit 653c7b3472003a5b85cc67936b64494fcac27c09
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Feb 14 04:24:25 2008 +0000
add ACL checks on queue
diff --git a/lib/RT/Queue_SLA.pm b/lib/RT/Queue_SLA.pm
index de365ba..aadbbd0 100644
--- a/lib/RT/Queue_SLA.pm
+++ b/lib/RT/Queue_SLA.pm
@@ -19,9 +19,8 @@ use warnings;
sub SLA {
my $self = shift;
my $value = shift;
+ return undef unless $self->CurrentUserHasRight('SeeQueue');
-# TODO: ACL check
-# return undef unless $self->CurrentUserHasRight('XXX');
my $attr = $self->FirstAttribute('SLA') or return undef;
return $attr->Content;
}
@@ -30,9 +29,8 @@ sub SetSLA {
my $self = shift;
my $value = shift;
-# TODO: ACL check
-# return ( 0, $self->loc('Permission Denied') )
-# unless $self->CurrentUserHasRight('XXX');
+ return ( 0, $self->loc('Permission Denied') )
+ unless $self->CurrentUserHasRight('AdminQueue');
my ($status, $msg) = $self->SetAttribute(
Name => 'SLA',
@@ -40,7 +38,7 @@ sub SetSLA {
Content => $value,
);
return ($status, $msg) unless $status;
- return ($status, $self->loc('Queue SLA changed'));
+ return ($status, $self->loc("Queue's default service level has been changed"));
}
1;
commit 9986e30bb67866cc626e763656b10fff968b23db
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Feb 14 04:28:18 2008 +0000
replace RT::SLA option with RT::ServiceAgreements as
the former conflicts with RTIR's built-in SLAs
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 77ce921..958f299 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -238,7 +238,7 @@ sub Agreement {
my $self = shift;
my %args = ( Level => undef, Type => 'Response', Time => undef, @_ );
- my $meta = $RT::SLA{'Levels'}{ $args{'Level'} };
+ my $meta = $RT::ServiceAgreements{'Levels'}{ $args{'Level'} };
return undef unless $meta;
return undef unless $meta->{ $args{'Type'} };
@@ -277,7 +277,7 @@ sub Due {
my $agreement = $self->Agreement( %args );
return undef unless $agreement;
- my $meta = $RT::SLA{'Levels'}{ $args{'Level'} };
+ my $meta = $RT::ServiceAgreements{'Levels'}{ $args{'Level'} };
my $res = $args{'Time'};
if ( defined $agreement->{'BusinessMinutes'} ) {
@@ -294,7 +294,7 @@ sub Starts {
my $self = shift;
my %args = ( Level => undef, Time => undef, @_ );
- my $meta = $RT::SLA{'Levels'}{ $args{'Level'} };
+ my $meta = $RT::ServiceAgreements{'Levels'}{ $args{'Level'} };
return undef unless $meta;
return $args{'Time'} if $meta->{'StartImmediately'};
@@ -333,11 +333,11 @@ sub GetDefaultServiceLevel {
else {
return $args{'Queue'}->SLA if $args{'Queue'}->SLA;
}
- if ( $RT::SLA{'QueueDefault'} && $RT::SLA{'QueueDefault'}{ $args{'Queue'}->Name } ) {
- return $RT::SLA{'QueueDefault'}{ $args{'Queue'}->Name };
+ if ( $RT::ServiceAgreements{'QueueDefault'} && $RT::ServiceAgreements{'QueueDefault'}{ $args{'Queue'}->Name } ) {
+ return $RT::ServiceAgreements{'QueueDefault'}{ $args{'Queue'}->Name };
}
}
- return $RT::SLA{'Default'};
+ return $RT::ServiceAgreements{'Default'};
}
=head1 TODO
diff --git a/t/business_hours.t b/t/business_hours.t
index 336834a..431546e 100644
--- a/t/business_hours.t
+++ b/t/business_hours.t
@@ -23,7 +23,7 @@ diag 'check business hours';
{
no warnings 'once';
- %RT::SLA = (
+ %RT::ServiceAgreements = (
Default => 'Sunday',
Levels => {
Sunday => {
diff --git a/t/due.t b/t/due.t
index 0689fcd..c21c534 100644
--- a/t/due.t
+++ b/t/due.t
@@ -16,7 +16,7 @@ use_ok 'RT::Extension::SLA';
diag 'check change of Due date when SLA for a ticket is changed';
{
- %RT::SLA = (
+ %RT::ServiceAgreements = (
Default => '2',
Levels => {
'2' => { Resolve => { RealMinutes => 60*2 } },
@@ -48,7 +48,7 @@ diag 'check change of Due date when SLA for a ticket is changed';
diag 'when not requestor creates a ticket, we dont set due date';
{
- %RT::SLA = (
+ %RT::ServiceAgreements = (
Default => '2',
Levels => {
'2' => { Response => { RealMinutes => 60*2 } },
@@ -71,7 +71,7 @@ diag 'when not requestor creates a ticket, we dont set due date';
diag 'check that reply to requestors unset due date';
{
- %RT::SLA = (
+ %RT::ServiceAgreements = (
Default => '2',
Levels => {
'2' => { Response => { RealMinutes => 60*2 } },
@@ -169,7 +169,7 @@ diag 'check that reply to requestors unset due date';
diag 'check that replies dont affect resolve deadlines';
{
- %RT::SLA = (
+ %RT::ServiceAgreements = (
Default => '2',
Levels => {
'2' => { Resolve => { RealMinutes => 60*2 } },
@@ -233,7 +233,7 @@ diag 'check that replies dont affect resolve deadlines';
diag 'check that owner is not treated as requestor';
{
- %RT::SLA = (
+ %RT::ServiceAgreements = (
Default => '2',
Levels => {
'2' => { Response => { RealMinutes => 60*2 } },
@@ -266,7 +266,7 @@ diag 'check that owner is not treated as requestor';
diag 'check that response deadline is left alone when there is no requestor';
{
- %RT::SLA = (
+ %RT::ServiceAgreements = (
Default => '2',
Levels => {
'2' => { Response => { RealMinutes => 60*2 } },
diff --git a/t/queue.t b/t/queue.t
index 2ee3d4a..92fb3e1 100644
--- a/t/queue.t
+++ b/t/queue.t
@@ -36,7 +36,7 @@ diag 'check set of Due date with Queue default SLA';
ok( $id, 'Created SLA Attribute for General' );
no warnings 'once';
- %RT::SLA = (
+ %RT::ServiceAgreements = (
Default => '2',
Levels => {
'2' => { Resolve => { RealMinutes => 60 * 2 } },
diff --git a/t/starts.t b/t/starts.t
index 00a5f91..e0de415 100644
--- a/t/starts.t
+++ b/t/starts.t
@@ -21,7 +21,7 @@ my $bhours = RT::Extension::SLA->BusinessHours;
diag 'check Starts date';
{
- %RT::SLA = (
+ %RT::ServiceAgreements = (
Default => 'standard',
Levels => {
'standard' => {
@@ -64,7 +64,7 @@ diag 'check Starts date';
diag 'check Starts date with StartImmediately enabled';
{
- %RT::SLA = (
+ %RT::ServiceAgreements = (
Default => 'start immediately',
Levels => {
'start immediately' => {
commit c69b9ea0e6ac87d62db8b49aee702c2a3b56b161
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Feb 14 04:34:07 2008 +0000
rename RT::BusinessHours option into RT::ServiceBusinessHours
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 958f299..d7bd18c 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -188,7 +188,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:
- %RT::BusinessHours = (
+ %RT::ServiceBusinessHours = (
'label to use' => {
... description ...
},
@@ -209,13 +209,13 @@ hours.
Resolve => { BusinessMinutes => 60 },
},
-then %RT::BusinessHours should have the corresponding definition:
+then %RT::ServiceBusinessHours should have the corresponding definition:
- %RT::BusinessHours = ( 'work just in Monday' => {
+ %RT::ServiceBusinessHours = ( 'work just in Monday' => {
1 => { Name => 'Monday', Start => '9:00', End => '18:00' }
} );
-Default Business Hours setting is in $RT::BusinessHours{'Default'}.
+Default Business Hours setting is in $RT::ServiceBusinessHours{'Default'}.
=head2 Default service levels
@@ -229,8 +229,8 @@ sub BusinessHours {
require Business::Hours;
my $res = new Business::Hours;
- $res->business_hours( %{ $RT::BusinessHours{ $name } } )
- if $RT::BusinessHours{ $name };
+ $res->business_hours( %{ $RT::ServiceBusinessHours{ $name } } )
+ if $RT::ServiceBusinessHours{ $name };
return $res;
}
diff --git a/t/business_hours.t b/t/business_hours.t
index 431546e..66469fc 100644
--- a/t/business_hours.t
+++ b/t/business_hours.t
@@ -36,7 +36,7 @@ diag 'check business hours';
},
);
- %RT::BusinessHours = (
+ %RT::ServiceBusinessHours = (
Sunday => {
0 => {
Name => 'Sunday',
diff --git a/t/starts.t b/t/starts.t
index e0de415..4ee3ef7 100644
--- a/t/starts.t
+++ b/t/starts.t
@@ -30,7 +30,7 @@ diag 'check Starts date';
},
},
);
- %RT::BusinessHours = (
+ %RT::ServiceBusinessHours = (
Default => {
1 => {
Name => 'Monday',
commit 6dde42c17e9aa4c21487423d6f681d563e8ef0cc
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Feb 14 06:48:20 2008 +0000
load global field if local is not applied
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index d7bd18c..96a1baf 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -312,7 +312,9 @@ sub GetCustomField {
unless ( $args{'Ticket'} ) {
return RT::CustomField->new( $RT::SystemUser );
}
- return $args{'Ticket'}->QueueObj->CustomField( $args{'CustomField'} );
+ my $cfs = $args{'Ticket'}->QueueObj->TicketCustomFields;
+ $cfs->Limit( FIELD => 'Name', VALUE => $args{'CustomField'} );
+ return $cfs->First || RT::CustomField->new( $RT::SystemUser );
}
sub GetDefaultServiceLevel {
commit 74711b1ab4cf0428673ca2d310ab501a9a3b63fa
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Feb 14 06:48:49 2008 +0000
use method we have instead of duplicating
diff --git a/lib/RT/Condition/SLA.pm b/lib/RT/Condition/SLA.pm
index b58818d..b7bc116 100644
--- a/lib/RT/Condition/SLA.pm
+++ b/lib/RT/Condition/SLA.pm
@@ -23,9 +23,9 @@ sub IsCustomFieldChange {
return 0 unless $txn->Type eq 'CustomField';
- my $cf = $self->TicketObj->QueueObj->CustomField( $cf_name );
+ my $cf = $self->GetCustomField( $cf_name );
unless ( $cf->id ) {
- $RT::Logger->error("Couldn't load the '$cf_name' field");
+ $RT::Logger->error("Custom field '$cf_name' is not applied to ticket #". $self->TicketObj->id);
return 0;
}
return 0 unless $cf->id == $txn->Field;
commit 1735b26076007843c2c317c9b6751b489d0e5b71
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Feb 14 06:50:05 2008 +0000
we check that level is set in Prepare code and return error otherwise,
so we don't need to check it in commit code
diff --git a/lib/RT/Action/SLA_SetDue.pm b/lib/RT/Action/SLA_SetDue.pm
index d7e89f2..72fc445 100644
--- a/lib/RT/Action/SLA_SetDue.pm
+++ b/lib/RT/Action/SLA_SetDue.pm
@@ -34,14 +34,8 @@ sub Commit {
my $self = shift;
my $ticket = $self->TicketObj;
-
- my $level = $ticket->FirstCustomFieldValue('SLA');
- unless ( $level ) {
- $RT::Logger->debug('Ticket #'. $ticket->id .' has no service level defined');
- return 1;
- }
-
my $txn = $self->TransactionObj;
+ my $level = $ticket->FirstCustomFieldValue('SLA');
my $last_reply = $self->LastRequestorsEffectiveAct;
$RT::Logger->debug('Last effective requestors\' reply to ticket #'. $ticket->id .' is txn #'. $last_reply->id )
commit a6115b2bf364333f419337bbaf43160e5984ae59
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Feb 14 06:51:14 2008 +0000
$method is already declared with 'my' earlier
diff --git a/lib/RT/Action/SLA.pm b/lib/RT/Action/SLA.pm
index f4f853e..0560400 100644
--- a/lib/RT/Action/SLA.pm
+++ b/lib/RT/Action/SLA.pm
@@ -22,7 +22,7 @@ sub SetDateField {
my $date = RT::Date->new( $RT::SystemUser );
$date->Set( Format => 'unix', Value => $value );
- my $method = 'Set'. $type;
+ $method = 'Set'. $type;
my ($status, $msg) = $ticket->$method( $date->ISO );
unless ( $status ) {
$RT::Logger->error("Couldn't set $type date: $msg");
commit 43ed8a51ecca21664d0d7b34d93bb842c0e82b43
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Feb 14 07:07:36 2008 +0000
fix call to GetCustomField
diff --git a/lib/RT/Condition/SLA.pm b/lib/RT/Condition/SLA.pm
index b7bc116..cb9f261 100644
--- a/lib/RT/Condition/SLA.pm
+++ b/lib/RT/Condition/SLA.pm
@@ -23,7 +23,7 @@ sub IsCustomFieldChange {
return 0 unless $txn->Type eq 'CustomField';
- my $cf = $self->GetCustomField( $cf_name );
+ my $cf = $self->GetCustomField( CustomField => $cf_name );
unless ( $cf->id ) {
$RT::Logger->error("Custom field '$cf_name' is not applied to ticket #". $self->TicketObj->id);
return 0;
commit 3770b9d473a75bbfa03f3c5849370311237b7e2e
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Feb 14 07:08:29 2008 +0000
make tests less noisy
* force TZ to GMT as tests expect it
diff --git a/t/business_hours.t b/t/business_hours.t
index 66469fc..ae7b29c 100644
--- a/t/business_hours.t
+++ b/t/business_hours.t
@@ -3,12 +3,19 @@
use strict;
use warnings;
+
use Test::More tests => 9;
require 't/utils.pl';
use_ok 'RT';
RT::LoadConfig();
+$RT::LogToScreen = $ENV{'TEST_VERBOSE'} ? 'debug': 'warning';
+
+# XXX, TODO
+# we assume the RT's Timezone is UTC now, need a smart way to get over that.
+$ENV{'TZ'} = $RT::Timezone = 'GMT';
+
RT::Init();
use_ok 'RT::Ticket';
@@ -16,9 +23,6 @@ use_ok 'RT::Extension::SLA';
use Test::MockTime qw( :all );
-# XXX, TODO
-# we assume the RT's Timezone is UTC now, need a smart way to get over that.
-
diag 'check business hours';
{
diff --git a/t/due.t b/t/due.t
index c21c534..7e1c211 100644
--- a/t/due.t
+++ b/t/due.t
@@ -9,6 +9,7 @@ require 't/utils.pl';
use_ok 'RT';
RT::LoadConfig();
+$RT::LogToScreen = $ENV{'TEST_VERBOSE'} ? 'debug': 'warning';
RT::Init();
use_ok 'RT::Ticket';
diff --git a/t/queue.t b/t/queue.t
index 92fb3e1..980bae3 100644
--- a/t/queue.t
+++ b/t/queue.t
@@ -9,6 +9,7 @@ require 't/utils.pl';
use_ok 'RT';
RT::LoadConfig();
+$RT::LogToScreen = $ENV{'TEST_VERBOSE'} ? 'debug': 'warning';
RT::Init();
use_ok 'RT::Ticket';
diff --git a/t/starts.t b/t/starts.t
index 4ee3ef7..11c38e2 100644
--- a/t/starts.t
+++ b/t/starts.t
@@ -9,6 +9,12 @@ require 't/utils.pl';
use_ok 'RT';
RT::LoadConfig();
+$RT::LogToScreen = $ENV{'TEST_VERBOSE'} ? 'debug': 'warning';
+
+# XXX, TODO
+# we assume the RT's Timezone is UTC now, need a smart way to get over that.
+$ENV{'TZ'} = $RT::Timezone = 'GMT';
+
RT::Init();
use_ok 'RT::Ticket';
commit d6f413fc7622196722a10069e8397fd24bb8f08c
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Feb 14 07:09:15 2008 +0000
update META and M::I
diff --git a/META.yml b/META.yml
index 5b7ce97..c15585c 100644
--- a/META.yml
+++ b/META.yml
@@ -1,10 +1,11 @@
---
abstract: RT Extension-SLA Extension
-author: Ruslan Zakirov <ruz at bestpractical.com>
+author:
+ - Ruslan Zakirov <ruz at bestpractical.com>
build_requires:
Test::More: 0
distribution_type: module
-generated_by: Module::Install version 0.67
+generated_by: Module::Install version 0.68
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.3.html
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index 9d13686..89a8653 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.67';
+ $VERSION = '0.68';
}
# Whether or not inc::Module::Install is actually loaded, the
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
index c244cb5..3a490fb 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.67';
+ $VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index 81fbcb6..49dfde6 100644
--- a/inc/Module/Install/Base.pm
+++ b/inc/Module/Install/Base.pm
@@ -1,7 +1,7 @@
#line 1
package Module::Install::Base;
-$VERSION = '0.67';
+$VERSION = '0.68';
# Suspend handler for "redefined" warnings
BEGIN {
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index 5d1eab8..ec66fdb 100644
--- a/inc/Module/Install/Can.pm
+++ b/inc/Module/Install/Can.pm
@@ -11,7 +11,7 @@ use ExtUtils::MakeMaker ();
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.67';
+ $VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index e884477..e0dd6db 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.67';
+ $VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
index 574acc8..001d0c6 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.67';
+ $VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index fbc5cb2..17bd8a7 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.67';
+ $VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index b886046..f77d68a 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 $ISCORE @ISA};
BEGIN {
- $VERSION = '0.67';
+ $VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index 612dc30..4f808c7 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 $ISCORE @ISA};
BEGIN {
- $VERSION = '0.67';
+ $VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index e1db381..078797c 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 $ISCORE @ISA};
BEGIN {
- $VERSION = '0.67';
+ $VERSION = '0.68';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
commit a68e84174aab3b3b9bfed11247c023ac79b54b75
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Feb 14 08:12:46 2008 +0000
doc every feature we have in this module
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 96a1baf..8fac05f 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -1,3 +1,4 @@
+use 5.8.0;
use strict;
use warnings;
@@ -14,16 +15,38 @@ service levels.
=head1 CONFIGURATION
-To enable service level agreements for a queue administrator
-should create and apply SLA custom field. To define different
-levels for different queues he CAN create several CFs with
-the same name and different set of values. All CFs MUST be
-of the same 'select one value' type.
-
-Values of the CF(s) define service levels.
+Service level agreements of tickets is controlled by SLA custom
+field. It's created during `make initdb` step and applied globally.
+This CF MUST be of 'select one value' type. Values of the CF
+define service levels.
+
+It's possible to define different set of levels for different
+queues. You can create several CFs with the same name and
+different set of values. But if you move tickets between
+queues a lot then it's gonna be a problem and it's preferred
+to use ONE SLA custom field.
+
+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:
+
+ %RT::ServiceAgreements = (
+ Default => '4h',
+ QueueDefault => {
+ 'Incident' => '2h',
+ },
+ Levels => {
+ '2h' => { Resolve => { RealMinutes => 60*2 } },
+ '4h' => { Resolve => { RealMinutes => 60*4 } },
+ },
+ );
Each service level can be described using several options:
-L</StartImmediately>, L</OutOfHours>, L</Resolve> and L</Response>.
+L<StartImmediately|/"StartImmediately (boolean, false)">,
+L<Resolve|/"Resolve and Response (interval, no defaults)">,
+L<Response|/"Resolve and Response (interval, no defaults)">,
+L<OutOfHours|/"OutOfHours (struct, no default)">
+and L</BusinessHours>.
=head2 StartImmediately (boolean, false)
@@ -54,7 +77,7 @@ These two options define deadlines for resolve of a ticket
and reply to customer(requestors) questions accordingly.
You can define them using real time, business or both. Read more
-about the latter below.
+about the latter L<below|/"Using both Resolve and Response in the same level">.
The Due date field is used to store calculated deadlines.
@@ -79,26 +102,26 @@ from stuff members.
You can use Response option to define such deadlines. When you're
using this option Due time "flips" when requestors and non-requestors
-reply to a ticket. We set Due date when a ticket's created, unset
+reply to a ticket. We set Due date when a ticket is created, unset
when non-requestor replies... until ticket is closed when ticket's
-due date is also unset.
+Due date is also unset.
B<NOTE> that behaviour changes when Resolve and Response options
-are combined, read below.
+are combined, read L<below|/"Using both Resolve and Response in the same level">.
As response deadlines are calculated using requestors' activity
-so several rules applies to make things quite sane:
+so several rules applies to make things sane:
=over 4
=item
-If requestors reply multiple times and are ignored then the deadline
+If requestor(s) reply multiple times and are ignored then the deadline
is calculated using the oldest requestors' correspondence.
=item
-If a ticket has no requestors then it has no response deadline.
+If a ticket has no requestor(s) then it has no response deadline.
=item
@@ -115,7 +138,7 @@ as non-requestors'.
Resolve and Response can be combined. In such case due date is set
according to the earliest of two deadlines and never is dropped to
-not set.
+'not set'.
If a ticket met its Resolve deadline then due date stops "fliping",
is freezed and the ticket becomes overdue. Before that moment when
@@ -162,8 +185,8 @@ next 8 hours after creation.
=head2 OutOfHours (struct, no default)
Out of hours modifier. Adds more real or business minutes to resolve
-and/or reply options if event happens out of business hours, see also
-</BusinessHours> below.
+and/or reply options if event happens out of business hours, read also
+</"Configuring business hours"> below.
Example:
@@ -183,16 +206,19 @@ hours, otherwise only one.
Supporters have two additional hours in the morning to deal with bunch
of requests that came into the system during the last night.
-=head2 BusinessHours
+=head2 Configuring business hours
In the config you can set one or more work schedules. Use the following
format:
%RT::ServiceBusinessHours = (
- 'label to use' => {
+ 'Default' => {
+ ... description ...
+ },
+ 'Support' => {
... description ...
},
- 'another label' => {
+ 'Sales' => {
... description ...
},
);
@@ -211,15 +237,36 @@ hours.
then %RT::ServiceBusinessHours should have the corresponding definition:
- %RT::ServiceBusinessHours = ( 'work just in Monday' => {
- 1 => { Name => 'Monday', Start => '9:00', End => '18:00' }
- } );
+ %RT::ServiceBusinessHours = (
+ 'work just in Monday' => {
+ 1 => { Name => 'Monday', Start => '9:00', End => '18:00' },
+ },
+ );
Default Business Hours setting is in $RT::ServiceBusinessHours{'Default'}.
-=head2 Default service levels
+=head2 Defining service levels per queue
-In the config and per queue defaults(this is not implemented).
+In the config you can set per queue defaults, using
+ %RT::ServiceAgreements = (
+ Default => 'global default level of service',
+ QueueDefault => {
+ 'queue name' => 'default value for this queue',
+ ...
+ },
+ ...
+ };
+
+=head2 Access control
+
+You can totally hide SLA custom field from users and use per queue
+defaults, just revoke SeeCustomField and ModifyCustomField.
+
+If you want people to see the current service level ticket is assigned
+to then grant SeeCustomField right.
+
+You may want to allow customers or managers to escalate thier tickets.
+Just grant them ModifyCustomField right.
=cut
@@ -346,7 +393,7 @@ sub GetDefaultServiceLevel {
* default SLA for queues
** implemented
- ** TODO: docs, tests
+ ** TODO: tests for options in the config
* add support for multiple b-hours definitions, this could be very helpfull
when you have 24/7 mixed with 8/5 and/or something like 8/5+4/2 for different
@@ -356,22 +403,33 @@ sub GetDefaultServiceLevel {
** TODO: tests
* WebUI
+ ** not implemented
=head1 DESIGN
=head2 Classes
-Actions are subclasses of RT::Action::SLA class that is subclass of
-RT::Extension::SLA and RT::Action::Generic classes.
+Actions are subclasses of L<RT::Action::SLA> class that is subclass of
+L<RT::Extension::SLA> and L<RT::Action::Generic> classes.
-Conditions are subclasses of RT::Condition::SLA class that is subclass of
-RT::Extension::SLA and RT::Condition::Generic classes.
+Conditions are subclasses of L<RT::Condition::SLA> class that is subclass of
+L<RT::Extension::SLA> and L<RT::Condition::Generic> classes.
-RT::Extension::SLA is a base class for all classes in the extension,
-it provides access to config, generates B::Hours and B::SLA objects, and
+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' modules.
+all actions and conditions then we MUST avoid adding methods which overload
+methods in 'RT::{Condition,Action}::Generic' RT's modules.
+
+=head1 AUTHOR
+
+Ruslan Zakirov E<lt>ruz at bestpractical.comE<gt>
+
+=head1 COPYRIGHT
+
+This extension is Copyright (C) 2007-2008 Best Practical Solutions, LLC.
+
+It is freely redistributable under the terms of version 2 of the GNU GPL.
=cut
commit 818f7bd5c512e9f1cfb21864fcdba08f33646436
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Feb 14 08:13:47 2008 +0000
update meta and makefile, we distribute under GPL2
diff --git a/META.yml b/META.yml
index c15585c..e98dedb 100644
--- a/META.yml
+++ b/META.yml
@@ -6,7 +6,7 @@ build_requires:
Test::More: 0
distribution_type: module
generated_by: Module::Install version 0.68
-license: perl
+license: gpl2
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.3.html
version: 1.3
@@ -18,4 +18,5 @@ no_index:
- t
requires:
Business::Hours: 0
+ perl: 5.8.0
version: undef
diff --git a/Makefile.PL b/Makefile.PL
index 78b2f01..2448393 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -1,8 +1,8 @@
use inc::Module::Install;
RTx ('RT-Extension-SLA');
-author ('Ruslan Zakirov <ruz at bestpractical.com>');
-license('perl');
+all_from('lib/RT/Extension/SLA.pm');
+license('gpl2');
build_requires('Test::More');
commit 9e99637927a62660ebcfa263711331cc1adfadfc
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Feb 14 08:23:03 2008 +0000
it's version 0.01
diff --git a/MANIFEST b/MANIFEST
index 7bbf363..22c271a 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,3 +1,4 @@
+Changes
etc/initialdata
inc/Module/AutoInstall.pm
inc/Module/Install.pm
@@ -22,9 +23,13 @@ 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/Queue_SLA.pm
Makefile.PL
MANIFEST This list of files
META.yml
t/basics.t
+t/business_hours.t
+t/due.t
+t/queue.t
t/starts.t
t/utils.pl
diff --git a/META.yml b/META.yml
index e98dedb..f46c97d 100644
--- a/META.yml
+++ b/META.yml
@@ -1,5 +1,5 @@
---
-abstract: RT Extension-SLA Extension
+abstract: Service Level Agreements for RT
author:
- Ruslan Zakirov <ruz at bestpractical.com>
build_requires:
@@ -19,4 +19,4 @@ no_index:
requires:
Business::Hours: 0
perl: 5.8.0
-version: undef
+version: 0.01
diff --git a/Makefile.PL b/Makefile.PL
index 2448393..07119da 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -1,5 +1,6 @@
use inc::Module::Install;
+abstract('Service Level Agreements for RT');
RTx ('RT-Extension-SLA');
all_from('lib/RT/Extension/SLA.pm');
license('gpl2');
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 8fac05f..88c91b5 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -4,6 +4,8 @@ use warnings;
package RT::Extension::SLA;
+our $VERSION = '0.01';
+
=head1 NAME
RT::Extension::SLA - Service Level Agreements for RT
commit 7cd4b90765b91aa56cd85fd1dd2c9c4b3e49c02d
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue May 6 00:04:11 2008 +0000
POD fixes
diff --git a/lib/RT/Action/SLA.pm b/lib/RT/Action/SLA.pm
index 0560400..4991da0 100644
--- a/lib/RT/Action/SLA.pm
+++ b/lib/RT/Action/SLA.pm
@@ -6,6 +6,24 @@ package RT::Action::SLA;
use base qw(RT::Extension::SLA RT::Action::Generic);
+=head1 NAME
+
+RT::Action::SLA - base class for all actions in the extension
+
+=head1 DESCRIPTION
+
+It's not a real action, but container for subclassing which provide
+help methods for other actions.
+
+=head1 METHODS
+
+=head2 SetDateField NAME VALUE
+
+Sets specified ticket's date field to the value, doesn't update
+if field is set already. VALUE is unix time.
+
+=cut
+
sub SetDateField {
my $self = shift;
my ($type, $value) = (@_);
diff --git a/lib/RT/Action/SLA_SetDefault.pm b/lib/RT/Action/SLA_SetDefault.pm
index ba680f1..e9834b6 100644
--- a/lib/RT/Action/SLA_SetDefault.pm
+++ b/lib/RT/Action/SLA_SetDefault.pm
@@ -8,7 +8,7 @@ use base qw(RT::Action::SLA);
=head1 NAME
-RT::Action::SLA::SetDefault - set default SLA value
+RT::Action::SLA_SetDefault - set default SLA value
=head1 DESCRIPTION
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 88c91b5..fb002a2 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -48,7 +48,7 @@ L<StartImmediately|/"StartImmediately (boolean, false)">,
L<Resolve|/"Resolve and Response (interval, no defaults)">,
L<Response|/"Resolve and Response (interval, no defaults)">,
L<OutOfHours|/"OutOfHours (struct, no default)">
-and L</BusinessHours>.
+and L<ServiceBusinessHours|/"Configuring business hours">.
=head2 StartImmediately (boolean, false)
@@ -64,6 +64,7 @@ to Created time. In this case you can set option
StartImmediately to true value.
Example:
+
'24/7' => {
StartImmediately => 1,
Response => { RealMinutes => 30 },
@@ -89,13 +90,13 @@ Defines deadline when a ticket should be resolved. This option is
quite simple and straightforward when used without L</Response>.
Example:
+
# 8 business hours
'simple' => { Resolve => 60*8 },
...
# one real week
'hard' => { Resolve => { RealMinutes => 60*24*7 } },
-
=head3 Response
In many companies providing support service(s) resolve time
@@ -249,7 +250,8 @@ Default Business Hours setting is in $RT::ServiceBusinessHours{'Default'}.
=head2 Defining service levels per queue
-In the config you can set per queue defaults, using
+In the config you can set per queue defaults, using:
+
%RT::ServiceAgreements = (
Default => 'global default level of service',
QueueDefault => {
commit 76d1d95d1f6f4de8fa8f46c8dc9f54856c1ef12d
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue May 6 00:07:12 2008 +0000
add changes to the repo
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..35feb1f
--- /dev/null
+++ b/Changes
@@ -0,0 +1,5 @@
+
+0.01 Thu Feb 14 11:17:00 +0400 2008
+
+ * initial release
+
commit e49cdc3672cf76e4f87b6148e6bbea8790f9712b
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue May 6 00:10:02 2008 +0000
update M::I
diff --git a/META.yml b/META.yml
index f46c97d..160f6b5 100644
--- a/META.yml
+++ b/META.yml
@@ -1,22 +1,22 @@
----
-abstract: Service Level Agreements for RT
-author:
- - Ruslan Zakirov <ruz at bestpractical.com>
-build_requires:
+---
+abstract: 'Service Level Agreements for RT'
+author:
+ - 'Ruslan Zakirov <ruz at bestpractical.com>'
+build_requires:
Test::More: 0
distribution_type: module
-generated_by: Module::Install version 0.68
+generated_by: 'Module::Install version 0.72'
license: gpl2
-meta-spec:
+meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.3.html
version: 1.3
name: RT-Extension-SLA
-no_index:
- directory:
+no_index:
+ directory:
- etc
- inc
- t
-requires:
+requires:
Business::Hours: 0
perl: 5.8.0
version: 0.01
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index 89a8653..052cf1e 100644
--- a/inc/Module/Install.pm
+++ b/inc/Module/Install.pm
@@ -17,20 +17,30 @@ package Module::Install;
# 3. The ./inc/ version of Module::Install loads
# }
-use 5.004;
+BEGIN {
+ require 5.004;
+}
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- # All Module::Install core packages now require synchronised versions.
- # This will be used to ensure we don't accidentally load old or
- # different versions of modules.
- # 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.68';
+ # All Module::Install core packages now require synchronised versions.
+ # This will be used to ensure we don't accidentally load old or
+ # different versions of modules.
+ # 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.72';
+
+ *inc::Module::Install::VERSION = *VERSION;
+ @inc::Module::Install::ISA = __PACKAGE__;
+
}
+
+
+
+
# 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.
@@ -38,26 +48,29 @@ BEGIN {
# 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";
+unless ( $INC{$file} ) { die <<"END_DIE" }
+
Please invoke ${\__PACKAGE__} with:
- use inc::${\__PACKAGE__};
+ use inc::${\__PACKAGE__};
not:
- use ${\__PACKAGE__};
+ use ${\__PACKAGE__};
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 and (stat($0))[9] > time ) {
- die << "END_DIE";
+if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
+
Your installer $0 has a modification time in the future.
This is known to create infinite loops in make.
@@ -65,115 +78,142 @@ 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 or -f 'Build.PL' ) { die <<"END_DIE" }
+
+Module::Install no longer supports Build.PL.
+
+It was impossible to maintain duel backends, and has been deprecated.
+
+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));
+
+
+
+
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
-*inc::Module::Install::VERSION = *VERSION;
- at inc::Module::Install::ISA = __PACKAGE__;
-
sub autoload {
- my $self = shift;
- my $who = $self->_caller;
- my $cwd = Cwd::cwd();
- my $sym = "${who}::AUTOLOAD";
- $sym->{$cwd} = sub {
- my $pwd = Cwd::cwd();
- if ( my $code = $sym->{$pwd} ) {
- # delegate back to parent dirs
- goto &$code unless $cwd eq $pwd;
- }
- $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
- unshift @_, ($self, $1);
- goto &{$self->can('call')} unless uc($1) eq $1;
- };
+ my $self = shift;
+ my $who = $self->_caller;
+ my $cwd = Cwd::cwd();
+ my $sym = "${who}::AUTOLOAD";
+ $sym->{$cwd} = sub {
+ my $pwd = Cwd::cwd();
+ if ( my $code = $sym->{$pwd} ) {
+ # delegate back to parent dirs
+ goto &$code unless $cwd eq $pwd;
+ }
+ $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
+ unshift @_, ( $self, $1 );
+ goto &{$self->can('call')} unless uc($1) eq $1;
+ };
}
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"};
+ 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"};
+
+ return 1;
}
sub preload {
- my ($self) = @_;
-
- unless ( $self->{extensions} ) {
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- );
- }
-
- my @exts = @{$self->{extensions}};
- unless ( @exts ) {
- my $admin = $self->{admin};
- @exts = $admin->load_all_extensions;
- }
-
- my %seen;
- foreach my $obj ( @exts ) {
- while (my ($method, $glob) = each %{ref($obj) . '::'}) {
- next unless $obj->can($method);
- next if $method =~ /^_/;
- next if $method eq uc($method);
- $seen{$method}++;
- }
- }
-
- my $who = $self->_caller;
- foreach my $name ( sort keys %seen ) {
- *{"${who}::$name"} = sub {
- ${"${who}::AUTOLOAD"} = "${who}::$name";
- goto &{"${who}::AUTOLOAD"};
- };
- }
+ my $self = shift;
+ unless ( $self->{extensions} ) {
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ );
+ }
+
+ my @exts = @{$self->{extensions}};
+ unless ( @exts ) {
+ my $admin = $self->{admin};
+ @exts = $admin->load_all_extensions;
+ }
+
+ my %seen;
+ foreach my $obj ( @exts ) {
+ while (my ($method, $glob) = each %{ref($obj) . '::'}) {
+ next unless $obj->can($method);
+ next if $method =~ /^_/;
+ next if $method eq uc($method);
+ $seen{$method}++;
+ }
+ }
+
+ my $who = $self->_caller;
+ foreach my $name ( sort keys %seen ) {
+ *{"${who}::$name"} = sub {
+ ${"${who}::AUTOLOAD"} = "${who}::$name";
+ goto &{"${who}::AUTOLOAD"};
+ };
+ }
}
sub new {
- my ($class, %args) = @_;
-
- # 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';
- $args{prefix} ||= 'inc';
- $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
- $args{bundle} ||= 'inc/BUNDLES';
- $args{base} ||= $base_path;
- $class =~ s/^\Q$args{prefix}\E:://;
- $args{name} ||= $class;
- $args{version} ||= $class->VERSION;
- unless ( $args{path} ) {
- $args{path} = $args{name};
- $args{path} =~ s!::!/!g;
- }
- $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
-
- bless( \%args, $class );
+ my ($class, %args) = @_;
+
+ # 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';
+ $args{prefix} ||= 'inc';
+ $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
+ $args{bundle} ||= 'inc/BUNDLES';
+ $args{base} ||= $base_path;
+ $class =~ s/^\Q$args{prefix}\E:://;
+ $args{name} ||= $class;
+ $args{version} ||= $class->VERSION;
+ unless ( $args{path} ) {
+ $args{path} = $args{name};
+ $args{path} =~ s!::!/!g;
+ }
+ $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
+ $args{wrote} = 0;
+
+ bless( \%args, $class );
}
sub call {
@@ -184,98 +224,130 @@ sub call {
}
sub load {
- my ($self, $method) = @_;
+ my ($self, $method) = @_;
- $self->load_extensions(
- "$self->{prefix}/$self->{path}", $self
- ) unless $self->{extensions};
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ ) unless $self->{extensions};
- foreach my $obj (@{$self->{extensions}}) {
- return $obj if $obj->can($method);
- }
+ foreach my $obj (@{$self->{extensions}}) {
+ return $obj if $obj->can($method);
+ }
- my $admin = $self->{admin} or die <<"END_DIE";
+ my $admin = $self->{admin} or die <<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE
- my $obj = $admin->load($method, 1);
- push @{$self->{extensions}}, $obj;
+ my $obj = $admin->load($method, 1);
+ push @{$self->{extensions}}, $obj;
- $obj;
+ $obj;
}
sub load_extensions {
- my ($self, $path, $top) = @_;
-
- unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
- unshift @INC, $self->{prefix};
- }
-
- foreach my $rv ( $self->find_extensions($path) ) {
- my ($file, $pkg) = @{$rv};
- next if $self->{pathnames}{$pkg};
-
- local $@;
- my $new = eval { require $file; $pkg->can('new') };
- unless ( $new ) {
- warn $@ if $@;
- next;
- }
- $self->{pathnames}{$pkg} = delete $INC{$file};
- push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
- }
-
- $self->{extensions} ||= [];
+ my ($self, $path, $top) = @_;
+
+ unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
+ unshift @INC, $self->{prefix};
+ }
+
+ foreach my $rv ( $self->find_extensions($path) ) {
+ my ($file, $pkg) = @{$rv};
+ next if $self->{pathnames}{$pkg};
+
+ local $@;
+ my $new = eval { require $file; $pkg->can('new') };
+ unless ( $new ) {
+ warn $@ if $@;
+ next;
+ }
+ $self->{pathnames}{$pkg} = delete $INC{$file};
+ push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
+ }
+
+ $self->{extensions} ||= [];
}
sub find_extensions {
- my ($self, $path) = @_;
-
- my @found;
- File::Find::find( sub {
- my $file = $File::Find::name;
- return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
- my $subpath = $1;
- return if lc($subpath) eq lc($self->{dispatch});
-
- $file = "$self->{path}/$subpath.pm";
- my $pkg = "$self->{name}::$subpath";
- $pkg =~ s!/!::!g;
-
- # If we have a mixed-case package name, assume case has been preserved
- # correctly. Otherwise, root through the file to locate the case-preserved
- # version of the package name.
- if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
- open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
- my $in_pod = 0;
- while ( <PKGFILE> ) {
- $in_pod = 1 if /^=\w/;
- $in_pod = 0 if /^=cut/;
- next if ($in_pod || /^=cut/); # skip pod text
- next if /^\s*#/; # and comments
- if ( m/^\s*package\s+($pkg)\s*;/i ) {
- $pkg = $1;
- last;
- }
- }
- close PKGFILE;
- }
-
- push @found, [ $file, $pkg ];
- }, $path ) if -d $path;
-
- @found;
+ my ($self, $path) = @_;
+
+ my @found;
+ File::Find::find( sub {
+ my $file = $File::Find::name;
+ return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
+ my $subpath = $1;
+ return if lc($subpath) eq lc($self->{dispatch});
+
+ $file = "$self->{path}/$subpath.pm";
+ my $pkg = "$self->{name}::$subpath";
+ $pkg =~ s!/!::!g;
+
+ # If we have a mixed-case package name, assume case has been preserved
+ # correctly. Otherwise, root through the file to locate the case-preserved
+ # version of the package name.
+ if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
+ my $content = Module::Install::_read($subpath . '.pm');
+ my $in_pod = 0;
+ foreach ( split //, $content ) {
+ $in_pod = 1 if /^=\w/;
+ $in_pod = 0 if /^=cut/;
+ next if ($in_pod || /^=cut/); # skip pod text
+ next if /^\s*#/; # and comments
+ if ( m/^\s*package\s+($pkg)\s*;/i ) {
+ $pkg = $1;
+ last;
+ }
+ }
+ }
+
+ push @found, [ $file, $pkg ];
+ }, $path ) if -d $path;
+
+ @found;
}
+
+
+
+
+#####################################################################
+# Utility Functions
+
sub _caller {
- my $depth = 0;
- my $call = caller($depth);
- while ( $call eq __PACKAGE__ ) {
- $depth++;
- $call = caller($depth);
- }
- return $call;
+ my $depth = 0;
+ my $call = caller($depth);
+ while ( $call eq __PACKAGE__ ) {
+ $depth++;
+ $call = caller($depth);
+ }
+ return $call;
+}
+
+sub _read {
+ local *FH;
+ open FH, "< $_[0]" or die "open($_[0]): $!";
+ my $str = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $str;
+}
+
+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]): $!";
+}
+
+sub _version {
+ my $s = shift || 0;
+ $s =~ s/^(\d+)\.?//;
+ my $l = $1 || 0;
+ my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
+ $l = $l . '.' . join '', @v if @v;
+ return $l + 0;
}
1;
+
+# Copyright 2008 Adam Kennedy.
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
index 3a490fb..ce24f7e 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.68';
+ $VERSION = '0.72';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index 49dfde6..7fd0189 100644
--- a/inc/Module/Install/Base.pm
+++ b/inc/Module/Install/Base.pm
@@ -1,7 +1,7 @@
#line 1
package Module::Install::Base;
-$VERSION = '0.68';
+$VERSION = '0.72';
# Suspend handler for "redefined" warnings
BEGIN {
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index ec66fdb..ea669c2 100644
--- a/inc/Module/Install/Can.pm
+++ b/inc/Module/Install/Can.pm
@@ -11,7 +11,7 @@ use ExtUtils::MakeMaker ();
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.72';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index e0dd6db..e283757 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.68';
+ $VERSION = '0.72';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
index 001d0c6..d27a92a 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.68';
+ $VERSION = '0.72';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index 17bd8a7..f40a97c 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.68';
+ $VERSION = '0.72';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
@@ -37,7 +37,7 @@ sub prompt {
sub makemaker_args {
my $self = shift;
my $args = ($self->{makemaker_args} ||= {});
- %$args = ( %$args, @_ ) if @_;
+ %$args = ( %$args, @_ ) if @_;
$args;
}
@@ -63,18 +63,18 @@ sub build_subdirs {
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
- %$clean = (
+ %$clean = (
%$clean,
- FILES => join(' ', grep length, $clean->{FILES}, @_),
+ FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
);
}
sub realclean_files {
- my $self = shift;
+ my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
- %$realclean = (
+ %$realclean = (
%$realclean,
- FILES => join(' ', grep length, $realclean->{FILES}, @_),
+ FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
);
}
@@ -104,8 +104,8 @@ sub tests_recursive {
unless ( -d $dir ) {
die "tests_recursive dir '$dir' does not exist";
}
- require File::Find;
%test_dir = ();
+ require File::Find;
File::Find::find( \&_wanted_t, $dir );
$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}
@@ -114,10 +114,15 @@ sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
+ # Make sure we have a new enough
+ require ExtUtils::MakeMaker;
+ $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION );
+
+ # Generate the
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
- $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
- $args->{VERSION} = $self->version || $self->determine_VERSION($args);
+ $args->{NAME} = $self->module_name || $self->name;
+ $args->{VERSION} = $self->version;
$args->{NAME} =~ s/-/::/g;
if ( $self->tests ) {
$args->{test} = { TESTS => $self->tests };
@@ -142,9 +147,12 @@ sub write {
map { @$_ }
map { @$_ }
grep $_,
- ($self->build_requires, $self->requires)
+ ($self->configure_requires, $self->build_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} ||= []);
if ($self->bundles) {
@@ -205,7 +213,7 @@ sub fix_up_makefile {
#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
- $makefile =~ s/("?)-I\$\(PERL_LIB\)\1//g;
+ $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
# XXX - This is currently unused; not sure if it breaks other MM-users
# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
@@ -234,4 +242,4 @@ sub postamble {
__END__
-#line 363
+#line 371
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index f77d68a..a10c773 100644
--- a/inc/Module/Install/Metadata.pm
+++ b/inc/Module/Install/Metadata.pm
@@ -6,18 +6,30 @@ use Module::Install::Base;
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.68';
+ $VERSION = '0.72';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
my @scalar_keys = qw{
- name module_name abstract author version license
- distribution_type perl_version tests installdirs
+ name
+ module_name
+ abstract
+ author
+ version
+ license
+ distribution_type
+ perl_version
+ tests
+ installdirs
};
my @tuple_keys = qw{
- build_requires requires recommends bundles
+ configure_requires
+ build_requires
+ requires
+ recommends
+ bundles
};
sub Meta { shift }
@@ -25,44 +37,68 @@ sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys { @tuple_keys }
foreach my $key (@scalar_keys) {
- *$key = sub {
- my $self = shift;
- return $self->{values}{$key} if defined wantarray and !@_;
- $self->{values}{$key} = shift;
- return $self;
- };
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}{$key} if defined wantarray and !@_;
+ $self->{values}{$key} = shift;
+ return $self;
+ };
+}
+
+sub requires {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}->{requires} }, [ $module, $version ];
+ }
+ $self->{values}{requires};
+}
+
+sub build_requires {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}->{build_requires} }, [ $module, $version ];
+ }
+ $self->{values}{build_requires};
+}
+
+sub configure_requires {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}->{configure_requires} }, [ $module, $version ];
+ }
+ $self->{values}{configure_requires};
}
-foreach my $key (@tuple_keys) {
- *$key = sub {
- my $self = shift;
- return $self->{values}{$key} unless @_;
-
- my @rv;
- while (@_) {
- my $module = shift or last;
- my $version = shift || 0;
- if ( $module eq 'perl' ) {
- $version =~ s{^(\d+)\.(\d+)\.(\d+)}
- {$1 + $2/1_000 + $3/1_000_000}e;
- $self->perl_version($version);
- next;
- }
- my $rv = [ $module, $version ];
- push @rv, $rv;
- }
- push @{ $self->{values}{$key} }, @rv;
- @rv;
- };
+sub recommends {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}->{recommends} }, [ $module, $version ];
+ }
+ $self->{values}{recommends};
}
-# configure_requires is currently a null-op
-sub configure_requires { 1 }
+sub bundles {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}->{bundles} }, [ $module, $version ];
+ }
+ $self->{values}{bundles};
+}
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
-sub test_requires { shift->build_requires(@_) }
-sub install_requires { shift->build_requires(@_) }
+sub test_requires { shift->build_requires(@_) }
+sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
sub install_as_core { $_[0]->installdirs('perl') }
@@ -71,10 +107,10 @@ sub install_as_site { $_[0]->installdirs('site') }
sub install_as_vendor { $_[0]->installdirs('vendor') }
sub sign {
- my $self = shift;
- return $self->{'values'}{'sign'} if defined wantarray and ! @_;
- $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
- return $self;
+ my $self = shift;
+ return $self->{'values'}{'sign'} if defined wantarray and ! @_;
+ $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
+ return $self;
}
sub dynamic_config {
@@ -83,254 +119,268 @@ sub dynamic_config {
warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
return $self;
}
- $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
+ $self->{values}{dynamic_config} = $_[0] ? 1 : 0;
return $self;
}
sub all_from {
- my ( $self, $file ) = @_;
-
- unless ( defined($file) ) {
- my $name = $self->name
- or die "all_from called with no args without setting name() first";
- $file = join('/', 'lib', split(/-/, $name)) . '.pm';
- $file =~ s{.*/}{} unless -e $file;
- die "all_from: cannot find $file from $name" unless -e $file;
- }
-
- $self->version_from($file) unless $self->version;
- $self->perl_version_from($file) unless $self->perl_version;
-
- # The remaining probes read from POD sections; if the file
- # has an accompanying .pod, use that instead
- my $pod = $file;
- if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
- $file = $pod;
- }
-
- $self->author_from($file) unless $self->author;
- $self->license_from($file) unless $self->license;
- $self->abstract_from($file) unless $self->abstract;
+ my ( $self, $file ) = @_;
+
+ unless ( defined($file) ) {
+ my $name = $self->name
+ or die "all_from called with no args without setting name() first";
+ $file = join('/', 'lib', split(/-/, $name)) . '.pm';
+ $file =~ s{.*/}{} unless -e $file;
+ die "all_from: cannot find $file from $name" unless -e $file;
+ }
+
+ # Some methods pull from POD instead of code.
+ # If there is a matching .pod, use that instead
+ my $pod = $file;
+ $pod =~ s/\.pm$/.pod/i;
+ $pod = $file unless -e $pod;
+
+ # Pull the different values
+ $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->license_from($pod) unless $self->license;
+ $self->abstract_from($pod) unless $self->abstract;
+
+ return 1;
}
sub provides {
- my $self = shift;
- my $provides = ( $self->{values}{provides} ||= {} );
- %$provides = (%$provides, @_) if @_;
- return $provides;
+ my $self = shift;
+ my $provides = ( $self->{values}{provides} ||= {} );
+ %$provides = (%$provides, @_) if @_;
+ return $provides;
}
sub auto_provides {
- my $self = shift;
- return $self unless $self->is_admin;
-
- unless (-e 'MANIFEST') {
- warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
- return $self;
- }
-
- # Avoid spurious warnings as we are not checking manifest here.
-
- local $SIG{__WARN__} = sub {1};
- require ExtUtils::Manifest;
- local *ExtUtils::Manifest::manicheck = sub { return };
-
- require Module::Build;
- my $build = Module::Build->new(
- dist_name => $self->name,
- dist_version => $self->version,
- license => $self->license,
- );
- $self->provides(%{ $build->find_dist_packages || {} });
+ my $self = shift;
+ return $self unless $self->is_admin;
+ unless (-e 'MANIFEST') {
+ warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
+ return $self;
+ }
+ # Avoid spurious warnings as we are not checking manifest here.
+ local $SIG{__WARN__} = sub {1};
+ require ExtUtils::Manifest;
+ local *ExtUtils::Manifest::manicheck = sub { return };
+
+ require Module::Build;
+ my $build = Module::Build->new(
+ dist_name => $self->name,
+ dist_version => $self->version,
+ license => $self->license,
+ );
+ $self->provides( %{ $build->find_dist_packages || {} } );
}
sub feature {
- my $self = shift;
- my $name = shift;
- my $features = ( $self->{values}{features} ||= [] );
-
- my $mods;
-
- if ( @_ == 1 and ref( $_[0] ) ) {
- # The user used ->feature like ->features by passing in the second
- # argument as a reference. Accomodate for that.
- $mods = $_[0];
- } else {
- $mods = \@_;
- }
-
- my $count = 0;
- push @$features, (
- $name => [
- map {
- ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
- : @$_
- : $_
- } @$mods
- ]
- );
-
- return @$features;
+ my $self = shift;
+ my $name = shift;
+ my $features = ( $self->{values}{features} ||= [] );
+ my $mods;
+
+ if ( @_ == 1 and ref( $_[0] ) ) {
+ # The user used ->feature like ->features by passing in the second
+ # argument as a reference. Accomodate for that.
+ $mods = $_[0];
+ } else {
+ $mods = \@_;
+ }
+
+ my $count = 0;
+ push @$features, (
+ $name => [
+ map {
+ ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
+ } @$mods
+ ]
+ );
+
+ return @$features;
}
sub features {
- my $self = shift;
- while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
- $self->feature( $name, @$mods );
- }
- return $self->{values}->{features}
- ? @{ $self->{values}->{features} }
- : ();
+ my $self = shift;
+ while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
+ $self->feature( $name, @$mods );
+ }
+ return $self->{values}->{features}
+ ? @{ $self->{values}->{features} }
+ : ();
}
sub no_index {
- my $self = shift;
- my $type = shift;
- push @{ $self->{values}{no_index}{$type} }, @_ if $type;
- return $self->{values}{no_index};
+ my $self = shift;
+ my $type = shift;
+ push @{ $self->{values}{no_index}{$type} }, @_ if $type;
+ return $self->{values}{no_index};
}
sub read {
- my $self = shift;
- $self->include_deps( 'YAML', 0 );
-
- require YAML;
- my $data = YAML::LoadFile('META.yml');
-
- # Call methods explicitly in case user has already set some values.
- while ( my ( $key, $value ) = each %$data ) {
- next unless $self->can($key);
- if ( ref $value eq 'HASH' ) {
- while ( my ( $module, $version ) = each %$value ) {
- $self->can($key)->($self, $module => $version );
- }
- }
- else {
- $self->can($key)->($self, $value);
- }
- }
- return $self;
+ my $self = shift;
+ $self->include_deps( 'YAML::Tiny', 0 );
+
+ require YAML::Tiny;
+ my $data = YAML::Tiny::LoadFile('META.yml');
+
+ # Call methods explicitly in case user has already set some values.
+ while ( my ( $key, $value ) = each %$data ) {
+ next unless $self->can($key);
+ if ( ref $value eq 'HASH' ) {
+ while ( my ( $module, $version ) = each %$value ) {
+ $self->can($key)->($self, $module => $version );
+ }
+ } else {
+ $self->can($key)->($self, $value);
+ }
+ }
+ return $self;
}
sub write {
- my $self = shift;
- return $self unless $self->is_admin;
- $self->admin->write_meta;
- return $self;
+ my $self = shift;
+ return $self unless $self->is_admin;
+ $self->admin->write_meta;
+ return $self;
}
sub version_from {
- my ( $self, $file ) = @_;
- require ExtUtils::MM_Unix;
- $self->version( ExtUtils::MM_Unix->parse_version($file) );
+ require ExtUtils::MM_Unix;
+ my ( $self, $file ) = @_;
+ $self->version( ExtUtils::MM_Unix->parse_version($file) );
}
sub abstract_from {
- my ( $self, $file ) = @_;
- require ExtUtils::MM_Unix;
- $self->abstract(
- bless(
- { DISTNAME => $self->name },
- 'ExtUtils::MM_Unix'
- )->parse_abstract($file)
- );
+ require ExtUtils::MM_Unix;
+ my ( $self, $file ) = @_;
+ $self->abstract(
+ bless(
+ { DISTNAME => $self->name },
+ 'ExtUtils::MM_Unix'
+ )->parse_abstract($file)
+ );
}
-sub _slurp {
- my ( $self, $file ) = @_;
-
- local *FH;
- open FH, "< $file" or die "Cannot open $file.pod: $!";
- do { local $/; <FH> };
+sub name_from {
+ my $self = shift;
+ if (
+ Module::Install::_read($_[0]) =~ m/
+ ^ \s*
+ package \s*
+ ([\w:]+)
+ \s* ;
+ /ixms
+ ) {
+ my $name = $1;
+ $name =~ s{::}{-}g;
+ $self->name($name);
+ } else {
+ die "Cannot determine name from $_[0]\n";
+ return;
+ }
}
sub perl_version_from {
- my ( $self, $file ) = @_;
-
- if (
- $self->_slurp($file) =~ m/
- ^
- use \s*
- v?
- ([\d_\.]+)
- \s* ;
- /ixms
- )
- {
- my $v = $1;
- $v =~ s{_}{}g;
- $self->perl_version($1);
- }
- else {
- warn "Cannot determine perl version info from $file\n";
- return;
- }
+ my $self = shift;
+ if (
+ Module::Install::_read($_[0]) =~ m/
+ ^
+ use \s*
+ v?
+ ([\d_\.]+)
+ \s* ;
+ /ixms
+ ) {
+ my $perl_version = $1;
+ $perl_version =~ s{_}{}g;
+ $self->perl_version($perl_version);
+ } else {
+ warn "Cannot determine perl version info from $_[0]\n";
+ return;
+ }
}
sub author_from {
- my ( $self, $file ) = @_;
- my $content = $self->_slurp($file);
- if ($content =~ m/
- =head \d \s+ (?:authors?)\b \s*
- ([^\n]*)
- |
- =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
- .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
- ([^\n]*)
- /ixms) {
- my $author = $1 || $2;
- $author =~ s{E<lt>}{<}g;
- $author =~ s{E<gt>}{>}g;
- $self->author($author);
- }
- else {
- warn "Cannot determine author info from $file\n";
- }
+ my $self = shift;
+ my $content = Module::Install::_read($_[0]);
+ if ($content =~ m/
+ =head \d \s+ (?:authors?)\b \s*
+ ([^\n]*)
+ |
+ =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
+ .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
+ ([^\n]*)
+ /ixms) {
+ my $author = $1 || $2;
+ $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 {
- my ( $self, $file ) = @_;
-
- if (
- $self->_slurp($file) =~ 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 public license' => 'gpl', 1,
- 'GNU lesser public license' => 'gpl', 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 ) {
- if ( $osi and $license_text =~ /All rights reserved/i ) {
- warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
+ 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 public license' => 'gpl', 1,
+ 'GNU lesser 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 ) {
+ if ( $osi and $license_text =~ /All rights reserved/i ) {
+ warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
+ }
+ $self->license($license);
+ return 1;
+ }
+ }
+ }
+
+ warn "Cannot determine license info from $_[0]\n";
+ return 'unknown';
+}
+
+sub install_script {
+ my $self = shift;
+ my $args = $self->makemaker_args;
+ my $exe = $args->{EXE_FILES} ||= [];
+ foreach ( @_ ) {
+ if ( -f $_ ) {
+ push @$exe, $_;
+ } elsif ( -d 'script' and -f "script/$_" ) {
+ push @$exe, "script/$_";
+ } else {
+ die "Cannot find script '$_'";
}
- $self->license($license);
- return 1;
- }
- }
- }
-
- warn "Cannot determine license info from $file\n";
- return 'unknown';
+ }
}
1;
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
index 1513848..c087b12 100644
--- a/inc/Module/Install/RTx.pm
+++ b/inc/Module/Install/RTx.pm
@@ -1,16 +1,23 @@
#line 1
package Module::Install::RTx;
-use Module::Install::Base; @ISA = qw(Module::Install::Base);
-
-$Module::Install::RTx::VERSION = '0.11';
+use 5.008;
use strict;
+use warnings;
+no warnings 'once';
+
+use Module::Install::Base;
+use base 'Module::Install::Base';
+our $VERSION = '0.22';
+
use FindBin;
-use File::Glob ();
+use File::Glob ();
use File::Basename ();
sub RTx {
- my ($self, $name) = @_;
+ my ( $self, $name ) = @_;
+
+ my $original_name = $name;
my $RTx = 'RTx';
$RTx = $1 if $name =~ s/^(\w+)-//;
my $fname = $name;
@@ -18,47 +25,54 @@ sub RTx {
$self->name("$RTx-$name")
unless $self->name;
+ $self->all_from( -e "$name.pm" ? "$name.pm" : "lib/$RTx/$fname.pm" )
+ unless $self->version;
$self->abstract("RT $name Extension")
unless $self->abstract;
- $self->version_from (-e "$name.pm" ? "$name.pm" : "lib/$RTx/$fname.pm")
- unless $self->version;
my @prefixes = (qw(/opt /usr/local /home /usr /sw ));
- my $prefix = $ENV{PREFIX};
- @ARGV = grep { /PREFIX=(.*)/ ? (($prefix = $1), 0) : 1 } @ARGV;
+ my $prefix = $ENV{PREFIX};
+ @ARGV = grep { /PREFIX=(.*)/ ? ( ( $prefix = $1 ), 0 ) : 1 } @ARGV;
if ($prefix) {
$RT::LocalPath = $prefix;
$INC{'RT.pm'} = "$RT::LocalPath/lib/RT.pm";
- }
- else {
+ } else {
local @INC = (
@INC,
- $ENV{RTHOME} ? ($ENV{RTHOME}, "$ENV{RTHOME}/lib") : (),
- map {( "$_/rt3/lib", "$_/lib/rt3", "$_/lib" )} grep $_, @prefixes
+ $ENV{RTHOME} ? ( $ENV{RTHOME}, "$ENV{RTHOME}/lib" ) : (),
+ map { ( "$_/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";
+ warn
+ "Cannot find the location of RT.pm that defines \$RT::LocalPath in: @INC\n";
$_ = $self->prompt("Path to your RT.pm:") or exit;
push @INC, $_, "$_/rt3/lib", "$_/lib/rt3", "$_/lib";
}
}
- my $lib_path = File::Basename::dirname($INC{'RT.pm'});
- print "Using RT configurations from $INC{'RT.pm'}:\n";
+ my $lib_path = File::Basename::dirname( $INC{'RT.pm'} );
+ my $local_lib_path = "$RT::LocalPath/lib";
+ print "Using RT configuration from $INC{'RT.pm'}:\n";
+ unshift @INC, "$RT::LocalPath/lib" if $RT::LocalPath;
- $RT::LocalVarPath ||= $RT::VarPath;
- $RT::LocalPoPath ||= $RT::LocalLexiconPath;
- $RT::LocalHtmlPath ||= $RT::MasonComponentRoot;
+ $RT::LocalVarPath ||= $RT::VarPath;
+ $RT::LocalPoPath ||= $RT::LocalLexiconPath;
+ $RT::LocalHtmlPath ||= $RT::MasonComponentRoot;
my %path;
my $with_subdirs = $ENV{WITH_SUBDIRS};
- @ARGV = grep { /WITH_SUBDIRS=(.*)/ ? (($with_subdirs = $1), 0) : 1 } @ARGV;
- my %subdirs = map { $_ => 1 } split(/\s*,\s*/, $with_subdirs);
+ @ARGV = grep { /WITH_SUBDIRS=(.*)/ ? ( ( $with_subdirs = $1 ), 0 ) : 1 }
+ @ARGV;
+
+ my %subdirs;
+ %subdirs = map { $_ => 1 } split( /\s*,\s*/, $with_subdirs )
+ if defined $with_subdirs;
foreach (qw(bin etc html po sbin var)) {
next unless -d "$FindBin::Bin/$_";
- next if %subdirs and !$subdirs{$_};
+ next if keys %subdirs and !$subdirs{$_};
$self->no_index( directory => $_ );
no strict 'refs';
@@ -67,12 +81,25 @@ sub RTx {
}
$path{$_} .= "/$name" for grep $path{$_}, qw(etc po var);
- my $args = join(', ', map "q($_)", %path);
- $path{lib} = "$RT::LocalPath/lib" unless %subdirs and !$subdirs{'lib'};
+ $path{lib} = "$RT::LocalPath/lib" unless keys %subdirs and !$subdirs{'lib'};
+
+ # If we're running on RT 3.8 with plugin support, we really wany
+ # to install libs, mason templates and po files into plugin specific
+ # directories
+ if ($RT::LocalPluginPath) {
+ foreach my $path (qw(lib po html etc bin sbin)) {
+ next unless -d "$FindBin::Bin/$path";
+ next if %subdirs and !$subdirs{$path};
+ $path{$path} = $RT::LocalPluginPath . "/$original_name/$path";
+ }
+ }
+
+ my $args = join( ', ', map "q($_)", %path );
print "./$_\t=> $path{$_}\n" for sort keys %path;
- if (my @dirs = map { (-D => $_) } grep $path{$_}, qw(bin html sbin)) {
- my @po = map { (-o => $_) } grep -f, File::Glob::bsd_glob("po/*.po");
+ if ( my @dirs = map { ( -D => $_ ) } grep $path{$_}, qw(bin html sbin) ) {
+ my @po = map { ( -o => $_ ) } grep -f,
+ File::Glob::bsd_glob("po/*.po");
$self->postamble(<< ".") if @po;
lexicons ::
\t\$(NOECHO) \$(PERL) -MLocale::Maketext::Extract::Run=xgettext -e \"xgettext(qw(@dirs @po))\"
@@ -84,56 +111,56 @@ install ::
\t\$(NOECHO) \$(PERL) -MExtUtils::Install -e \"install({$args})\"
.
- if ($path{var} and -d $RT::MasonDataDir) {
- my ($uid, $gid) = (stat($RT::MasonDataDir))[4, 5];
+ if ( $path{var} and -d $RT::MasonDataDir ) {
+ my ( $uid, $gid ) = ( stat($RT::MasonDataDir) )[ 4, 5 ];
$postamble .= << ".";
\t\$(NOECHO) chown -R $uid:$gid $path{var}
.
}
my %has_etc;
- if (File::Glob::bsd_glob("$FindBin::Bin/etc/schema.*")) {
+ if ( File::Glob::bsd_glob("$FindBin::Bin/etc/schema.*") ) {
+
# got schema, load factory module
$has_etc{schema}++;
$self->load('RTxFactory');
$self->postamble(<< ".");
factory ::
-\t\$(NOECHO) \$(PERL) -Ilib -I"$lib_path" -Minc::Module::Install -e"RTxFactory(qw($RTx $name))"
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxFactory(qw($RTx $name))"
dropdb ::
-\t\$(NOECHO) \$(PERL) -Ilib -I"$lib_path" -Minc::Module::Install -e"RTxFactory(qw($RTx $name drop))"
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxFactory(qw($RTx $name drop))"
.
}
- if (File::Glob::bsd_glob("$FindBin::Bin/etc/acl.*")) {
+ if ( File::Glob::bsd_glob("$FindBin::Bin/etc/acl.*") ) {
$has_etc{acl}++;
}
- if (-e 'etc/initialdata') {
- $has_etc{initialdata}++;
- }
+ if ( -e 'etc/initialdata' ) { $has_etc{initialdata}++; }
$self->postamble("$postamble\n");
- if (%subdirs and !$subdirs{'lib'}) {
- $self->makemaker_args(
- PM => { "" => "" },
- )
- }
- else {
+ if ( %subdirs and !$subdirs{'lib'} ) {
+ $self->makemaker_args( PM => { "" => "" }, );
+ } else {
$self->makemaker_args( INSTALLSITELIB => "$RT::LocalPath/lib" );
}
+ $self->makemaker_args( INSTALLSITEMAN1DIR => "$RT::LocalPath/man/man1" );
+ $self->makemaker_args( INSTALLSITEMAN3DIR => "$RT::LocalPath/man/man3" );
+ $self->makemaker_args( INSTALLSITEARCH => "$RT::LocalPath/man" );
+ $self->makemaker_args( INSTALLARCHLIB => "$RT::LocalPath/lib" );
if (%has_etc) {
$self->load('RTxInitDB');
print "For first-time installation, type 'make initdb'.\n";
my $initdb = '';
$initdb .= <<"." if $has_etc{schema};
-\t\$(NOECHO) \$(PERL) -Ilib -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(schema))"
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(schema))"
.
$initdb .= <<"." if $has_etc{acl};
-\t\$(NOECHO) \$(PERL) -Ilib -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(acl))"
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(acl))"
.
$initdb .= <<"." if $has_etc{initialdata};
-\t\$(NOECHO) \$(PERL) -Ilib -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(insert))"
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(insert))"
.
$self->postamble("initdb ::\n$initdb\n");
$self->postamble("initialize-database ::\n$initdb\n");
@@ -141,7 +168,7 @@ dropdb ::
}
sub RTxInit {
- unshift @INC, substr(delete($INC{'RT.pm'}), 0, -5) if $INC{'RT.pm'};
+ unshift @INC, substr( delete( $INC{'RT.pm'} ), 0, -5 ) if $INC{'RT.pm'};
require RT;
RT::LoadConfig();
RT::ConnectToDatabase();
@@ -153,6 +180,4 @@ sub RTxInit {
__END__
-#line 220
-
-#line 241
+#line 281
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index 4f808c7..f8744e7 100644
--- a/inc/Module/Install/Win32.pm
+++ b/inc/Module/Install/Win32.pm
@@ -4,11 +4,11 @@ package Module::Install::Win32;
use strict;
use Module::Install::Base;
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.68';
- $ISCORE = 1;
+ $VERSION = '0.72';
@ISA = qw{Module::Install::Base};
+ $ISCORE = 1;
}
# determine if the user needs nmake, and download it if needed
@@ -16,7 +16,7 @@ sub check_nmake {
my $self = shift;
$self->load('can_run');
$self->load('get_file');
-
+
require Config;
return unless (
$^O eq 'MSWin32' and
@@ -38,8 +38,7 @@ sub check_nmake {
remove => 1,
);
- if (!$rv) {
- die <<'END_MESSAGE';
+ die <<'END_MESSAGE' unless $rv;
-------------------------------------------------------------------------------
@@ -59,7 +58,7 @@ You may then resume the installation process described in README.
-------------------------------------------------------------------------------
END_MESSAGE
- }
+
}
1;
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index 078797c..d1d8a06 100644
--- a/inc/Module/Install/WriteAll.pm
+++ b/inc/Module/Install/WriteAll.pm
@@ -4,40 +4,37 @@ package Module::Install::WriteAll;
use strict;
use Module::Install::Base;
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.68';
- $ISCORE = 1;
+ $VERSION = '0.72';
@ISA = qw{Module::Install::Base};
+ $ISCORE = 1;
}
sub WriteAll {
- my $self = shift;
- my %args = (
- meta => 1,
- sign => 0,
- inline => 0,
- check_nmake => 1,
- @_
- );
+ my $self = shift;
+ my %args = (
+ meta => 1,
+ sign => 0,
+ inline => 0,
+ check_nmake => 1,
+ @_,
+ );
+
+ $self->sign(1) if $args{sign};
+ $self->Meta->write if $args{meta};
+ $self->admin->WriteAll(%args) if $self->is_admin;
- $self->sign(1) if $args{sign};
- $self->Meta->write if $args{meta};
- $self->admin->WriteAll(%args) if $self->is_admin;
+ $self->check_nmake if $args{check_nmake};
+ unless ( $self->makemaker_args->{PL_FILES} ) {
+ $self->makemaker_args( PL_FILES => {} );
+ }
- if ( $0 =~ /Build.PL$/i ) {
- $self->Build->write;
- } else {
- $self->check_nmake if $args{check_nmake};
- unless ( $self->makemaker_args->{'PL_FILES'} ) {
- $self->makemaker_args( PL_FILES => {} );
- }
- if ($args{inline}) {
- $self->Inline->write;
- } else {
- $self->Makefile->write;
- }
- }
+ if ( $args{inline} ) {
+ $self->Inline->write;
+ } else {
+ $self->Makefile->write;
+ }
}
1;
commit 071e9bd419fa25d438d1e86a20c0d87dfc26bdb8
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue May 6 00:13:56 2008 +0000
bump version
diff --git a/Changes b/Changes
index 35feb1f..384685f 100644
--- a/Changes
+++ b/Changes
@@ -1,4 +1,8 @@
+0.02 Thu May 06 04:07:00 +0400 2008
+
+ * POD cleanup
+
0.01 Thu Feb 14 11:17:00 +0400 2008
* initial release
diff --git a/META.yml b/META.yml
index 160f6b5..2152a53 100644
--- a/META.yml
+++ b/META.yml
@@ -19,4 +19,4 @@ no_index:
requires:
Business::Hours: 0
perl: 5.8.0
-version: 0.01
+version: 0.02
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index fb002a2..07a6bff 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.01';
+our $VERSION = '0.02';
=head1 NAME
commit 7a55d8511cf640df0df1060185a6baca263f5b2a
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Oct 27 14:30:12 2008 +0000
update M::I
diff --git a/META.yml b/META.yml
index 2152a53..6c20557 100644
--- a/META.yml
+++ b/META.yml
@@ -5,15 +5,18 @@ author:
build_requires:
Test::More: 0
distribution_type: module
-generated_by: 'Module::Install version 0.72'
+generated_by: 'Module::Install version 0.77'
license: gpl2
meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.3.html
- version: 1.3
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
name: RT-Extension-SLA
no_index:
directory:
- etc
+ - html
+ - po
+ - var
- inc
- t
requires:
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index 052cf1e..eb449ca 100644
--- a/inc/Module/Install.pm
+++ b/inc/Module/Install.pm
@@ -30,7 +30,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.72';
+ $VERSION = '0.77';
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
@@ -85,7 +85,7 @@ 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 or -f 'Build.PL' ) { die <<"END_DIE" }
+if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
Module::Install no longer supports Build.PL.
@@ -125,8 +125,10 @@ sub autoload {
goto &$code unless $cwd eq $pwd;
}
$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
- unshift @_, ( $self, $1 );
- goto &{$self->can('call')} unless uc($1) eq $1;
+ unless ( uc($1) eq $1 ) {
+ unshift @_, ( $self, $1 );
+ goto &{$self->can('call')};
+ }
};
}
@@ -339,7 +341,10 @@ sub _write {
close FH or die "close($_[0]): $!";
}
-sub _version {
+# _version is for processing module versions (eg, 1.03_05) not
+# Perl versions (eg, 5.8.1).
+
+sub _version ($) {
my $s = shift || 0;
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
@@ -348,6 +353,17 @@ sub _version {
return $l + 0;
}
+# Cloned from Params::Util::_CLASS
+sub _CLASS ($) {
+ (
+ defined $_[0]
+ and
+ ! ref $_[0]
+ and
+ $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
+ ) ? $_[0] : undef;
+}
+
1;
# Copyright 2008 Adam Kennedy.
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
index ce24f7e..8b3bcaa 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.72';
+ $VERSION = '0.77';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index 7fd0189..433ebed 100644
--- a/inc/Module/Install/Base.pm
+++ b/inc/Module/Install/Base.pm
@@ -1,7 +1,7 @@
#line 1
package Module::Install::Base;
-$VERSION = '0.72';
+$VERSION = '0.77';
# Suspend handler for "redefined" warnings
BEGIN {
@@ -45,6 +45,8 @@ sub admin {
$_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
}
+#line 101
+
sub is_admin {
$_[0]->admin->VERSION;
}
@@ -67,4 +69,4 @@ BEGIN {
1;
-#line 138
+#line 146
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index ea669c2..9025607 100644
--- a/inc/Module/Install/Can.pm
+++ b/inc/Module/Install/Can.pm
@@ -11,7 +11,7 @@ use ExtUtils::MakeMaker ();
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.72';
+ $VERSION = '0.77';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
@@ -39,6 +39,7 @@ sub can_run {
return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
+ next if $dir eq '';
my $abs = File::Spec->catfile($dir, $_[1]);
return $abs if (-x $abs or $abs = MM->maybe_command($abs));
}
@@ -79,4 +80,4 @@ if ( $^O eq 'cygwin' ) {
__END__
-#line 157
+#line 158
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index e283757..d66aba5 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.72';
+ $VERSION = '0.77';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
index d27a92a..0c7dc5a 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.72';
+ $VERSION = '0.77';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index f40a97c..92cd1ef 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.72';
+ $VERSION = '0.77';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
@@ -36,9 +36,9 @@ sub prompt {
sub makemaker_args {
my $self = shift;
- my $args = ($self->{makemaker_args} ||= {});
- %$args = ( %$args, @_ ) if @_;
- $args;
+ my $args = ( $self->{makemaker_args} ||= {} );
+ %$args = ( %$args, @_ );
+ return $args;
}
# For mm args that take multiple space-seperated args,
@@ -116,7 +116,13 @@ sub write {
# Make sure we have a new enough
require ExtUtils::MakeMaker;
- $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION );
+
+ # 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->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
# Generate the
my $args = $self->makemaker_args;
@@ -175,7 +181,9 @@ sub write {
my $user_preop = delete $args{dist}->{PREOP};
if (my $preop = $self->admin->preop($user_preop)) {
- $args{dist} = $preop;
+ foreach my $key ( keys %$preop ) {
+ $args{dist}->{$key} = $preop->{$key};
+ }
}
my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
@@ -242,4 +250,4 @@ sub postamble {
__END__
-#line 371
+#line 379
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index a10c773..397fb97 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 $ISCORE @ISA};
BEGIN {
- $VERSION = '0.72';
+ $VERSION = '0.77';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
@@ -17,9 +17,7 @@ my @scalar_keys = qw{
abstract
author
version
- license
distribution_type
- perl_version
tests
installdirs
};
@@ -30,13 +28,21 @@ my @tuple_keys = qw{
requires
recommends
bundles
+ resources
+};
+
+my @resource_keys = qw{
+ homepage
+ bugtracker
+ repository
};
-sub Meta { shift }
-sub Meta_ScalarKeys { @scalar_keys }
-sub Meta_TupleKeys { @tuple_keys }
+sub Meta { shift }
+sub Meta_ScalarKeys { @scalar_keys }
+sub Meta_TupleKeys { @tuple_keys }
+sub Meta_ResourceKeys { @resource_keys }
-foreach my $key (@scalar_keys) {
+foreach my $key ( @scalar_keys ) {
*$key = sub {
my $self = shift;
return $self->{values}{$key} if defined wantarray and !@_;
@@ -45,12 +51,30 @@ foreach my $key (@scalar_keys) {
};
}
+foreach my $key ( @resource_keys ) {
+ *$key = sub {
+ my $self = shift;
+ unless ( @_ ) {
+ return () unless $self->{values}{resources};
+ return map { $_->[1] }
+ grep { $_->[0] eq $key }
+ @{ $self->{values}{resources} };
+ }
+ return $self->{values}{resources}{$key} unless @_;
+ my $uri = shift or die(
+ "Did not provide a value to $key()"
+ );
+ $self->resources( $key => $uri );
+ return 1;
+ };
+}
+
sub requires {
my $self = shift;
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
- push @{ $self->{values}->{requires} }, [ $module, $version ];
+ push @{ $self->{values}{requires} }, [ $module, $version ];
}
$self->{values}{requires};
}
@@ -60,7 +84,7 @@ sub build_requires {
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
- push @{ $self->{values}->{build_requires} }, [ $module, $version ];
+ push @{ $self->{values}{build_requires} }, [ $module, $version ];
}
$self->{values}{build_requires};
}
@@ -70,7 +94,7 @@ sub configure_requires {
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
- push @{ $self->{values}->{configure_requires} }, [ $module, $version ];
+ push @{ $self->{values}{configure_requires} }, [ $module, $version ];
}
$self->{values}{configure_requires};
}
@@ -80,7 +104,7 @@ sub recommends {
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
- push @{ $self->{values}->{recommends} }, [ $module, $version ];
+ push @{ $self->{values}{recommends} }, [ $module, $version ];
}
$self->{values}{recommends};
}
@@ -90,11 +114,33 @@ sub bundles {
while ( @_ ) {
my $module = shift or last;
my $version = shift || 0;
- push @{ $self->{values}->{bundles} }, [ $module, $version ];
+ push @{ $self->{values}{bundles} }, [ $module, $version ];
}
$self->{values}{bundles};
}
+# Resource handling
+my %lc_resource = map { $_ => 1 } qw{
+ homepage
+ license
+ bugtracker
+ repository
+};
+
+sub resources {
+ my $self = shift;
+ while ( @_ ) {
+ my $name = shift or last;
+ my $value = shift or next;
+ if ( $name eq lc $name and ! $lc_resource{$name} ) {
+ die("Unsupported reserved lowercase resource '$name'");
+ }
+ $self->{values}{resources} ||= [];
+ push @{ $self->{values}{resources} }, [ $name, $value ];
+ }
+ $self->{values}{resources};
+}
+
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
sub test_requires { shift->build_requires(@_) }
@@ -108,30 +154,73 @@ sub install_as_vendor { $_[0]->installdirs('vendor') }
sub sign {
my $self = shift;
- return $self->{'values'}{'sign'} if defined wantarray and ! @_;
- $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
+ return $self->{values}{sign} if defined wantarray and ! @_;
+ $self->{values}{sign} = ( @_ ? $_[0] : 1 );
return $self;
}
sub dynamic_config {
my $self = shift;
unless ( @_ ) {
- warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
+ warn "You MUST provide an explicit true/false value to dynamic_config\n";
return $self;
}
$self->{values}{dynamic_config} = $_[0] ? 1 : 0;
- return $self;
+ return 1;
+}
+
+sub perl_version {
+ my $self = shift;
+ return $self->{values}{perl_version} unless @_;
+ my $version = shift or die(
+ "Did not provide a value to perl_version()"
+ );
+
+ # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
+ # numbers (eg, 5.006001 or 5.008009).
+
+ $version =~ s/^(\d+)\.(\d+)\.(\d+)$/sprintf("%d.%03d%03d",$1,$2,$3)/e;
+
+ $version =~ s/_.+$//;
+ $version = $version + 0; # Numify
+ unless ( $version >= 5.005 ) {
+ die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
+ }
+ $self->{values}{perl_version} = $version;
+ return 1;
+}
+
+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 eq 'perl' ) {
+ $self->resources( license => 'http://dev.perl.org/licenses/' );
+ }
+
+ return 1;
}
sub all_from {
my ( $self, $file ) = @_;
unless ( defined($file) ) {
- my $name = $self->name
- or die "all_from called with no args without setting name() first";
+ my $name = $self->name or die(
+ "all_from called with no args without setting name() first"
+ );
$file = join('/', 'lib', split(/-/, $name)) . '.pm';
$file =~ s{.*/}{} unless -e $file;
- die "all_from: cannot find $file from $name" unless -e $file;
+ unless ( -e $file ) {
+ die("all_from cannot find $file from $name");
+ }
+ }
+ unless ( -f $file ) {
+ die("The path '$file' does not exist, or is not a file");
}
# Some methods pull from POD instead of code.
@@ -210,8 +299,8 @@ sub features {
while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
$self->feature( $name, @$mods );
}
- return $self->{values}->{features}
- ? @{ $self->{values}->{features} }
+ return $self->{values}{features}
+ ? @{ $self->{values}{features} }
: ();
}
@@ -267,22 +356,25 @@ sub abstract_from {
);
}
+# Add both distribution and module name
sub name_from {
- my $self = shift;
+ my ($self, $file) = @_;
if (
- Module::Install::_read($_[0]) =~ m/
+ Module::Install::_read($file) =~ m/
^ \s*
package \s*
([\w:]+)
\s* ;
/ixms
) {
- my $name = $1;
+ my ($name, $module_name) = ($1, $1);
$name =~ s{::}{-}g;
$self->name($name);
+ unless ( $self->module_name ) {
+ $self->module_name($module_name);
+ }
} else {
- die "Cannot determine name from $_[0]\n";
- return;
+ die("Cannot determine name from $file\n");
}
}
@@ -291,7 +383,7 @@ sub perl_version_from {
if (
Module::Install::_read($_[0]) =~ m/
^
- use \s*
+ (?:use|require) \s*
v?
([\d_\.]+)
\s* ;
@@ -341,8 +433,12 @@ sub license_from {
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,
@@ -356,7 +452,7 @@ sub license_from {
$pattern =~ s{\s+}{\\s+}g;
if ( $license_text =~ /\b$pattern\b/i ) {
if ( $osi and $license_text =~ /All rights reserved/i ) {
- warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
+ print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
}
$self->license($license);
return 1;
@@ -368,6 +464,24 @@ sub license_from {
return 'unknown';
}
+sub bugtracker_from {
+ my $self = shift;
+ my $content = Module::Install::_read($_[0]);
+ my @links = $content =~ m/L\<(http\:\/\/rt\.cpan\.org\/[^>]+)\>/g;
+ unless ( @links ) {
+ warn "Cannot determine bugtracker info from $_[0]\n";
+ return 0;
+ }
+ if ( @links > 1 ) {
+ warn "Found more than on rt.cpan.org link in $_[0]\n";
+ return 0;
+ }
+
+ # Set the bugtracker
+ bugtracker( $links[0] );
+ return 1;
+}
+
sub install_script {
my $self = shift;
my $args = $self->makemaker_args;
@@ -378,7 +492,7 @@ sub install_script {
} elsif ( -d 'script' and -f "script/$_" ) {
push @$exe, "script/$_";
} else {
- die "Cannot find script '$_'";
+ die("Cannot find script '$_'");
}
}
}
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
index c087b12..2028f5e 100644
--- a/inc/Module/Install/RTx.pm
+++ b/inc/Module/Install/RTx.pm
@@ -8,12 +8,15 @@ no warnings 'once';
use Module::Install::Base;
use base 'Module::Install::Base';
-our $VERSION = '0.22';
+our $VERSION = '0.23';
use FindBin;
use File::Glob ();
use File::Basename ();
+my @DIRS = qw(etc lib html bin sbin po var);
+my @INDEX_DIRS = qw(lib bin sbin);
+
sub RTx {
my ( $self, $name ) = @_;
@@ -60,8 +63,8 @@ sub RTx {
$RT::LocalVarPath ||= $RT::VarPath;
$RT::LocalPoPath ||= $RT::LocalLexiconPath;
$RT::LocalHtmlPath ||= $RT::MasonComponentRoot;
+ $RT::LocalLibPath ||= "$RT::LocalPath/lib";
- my %path;
my $with_subdirs = $ENV{WITH_SUBDIRS};
@ARGV = grep { /WITH_SUBDIRS=(.*)/ ? ( ( $with_subdirs = $1 ), 0 ) : 1 }
@ARGV;
@@ -69,36 +72,40 @@ sub RTx {
my %subdirs;
%subdirs = map { $_ => 1 } split( /\s*,\s*/, $with_subdirs )
if defined $with_subdirs;
-
- foreach (qw(bin etc html po sbin var)) {
- next unless -d "$FindBin::Bin/$_";
- next if keys %subdirs and !$subdirs{$_};
- $self->no_index( directory => $_ );
-
- no strict 'refs';
- my $varname = "RT::Local" . ucfirst($_) . "Path";
- $path{$_} = ${$varname} || "$RT::LocalPath/$_";
+ unless ( keys %subdirs ) {
+ $subdirs{$_} = 1 foreach grep -d "$FindBin::Bin/$_", @DIRS;
}
- $path{$_} .= "/$name" for grep $path{$_}, qw(etc po var);
- $path{lib} = "$RT::LocalPath/lib" unless keys %subdirs and !$subdirs{'lib'};
-
# If we're running on RT 3.8 with plugin support, we really wany
# to install libs, mason templates and po files into plugin specific
# directories
- if ($RT::LocalPluginPath) {
- foreach my $path (qw(lib po html etc bin sbin)) {
- next unless -d "$FindBin::Bin/$path";
- next if %subdirs and !$subdirs{$path};
- $path{$path} = $RT::LocalPluginPath . "/$original_name/$path";
+ my %path;
+ if ( $RT::LocalPluginPath ) {
+ die "Because of bugs in RT 3.8.0 this extension can not be installed.\n"
+ ."Upgrade to RT 3.8.1 or newer.\n" if $RT::VERSION =~ /^3\.8\.0/;
+ $path{$_} = $RT::LocalPluginPath . "/$original_name/$_"
+ foreach @DIRS;
+ } else {
+ foreach ( @DIRS ) {
+ no strict 'refs';
+ my $varname = "RT::Local" . ucfirst($_) . "Path";
+ $path{$_} = ${$varname} || "$RT::LocalPath/$_";
}
+
+ $path{$_} .= "/$name" for grep $path{$_}, qw(etc po var);
}
- my $args = join( ', ', map "q($_)", %path );
- print "./$_\t=> $path{$_}\n" for sort keys %path;
+ my %index = map { $_ => 1 } @INDEX_DIRS;
+ $self->no_index( directory => $_ ) foreach grep !$index{$_}, @DIRS;
+
+ my $args = join ', ', map "q($_)", map { ($_, $path{$_}) }
+ grep $subdirs{$_}, keys %path;
- if ( my @dirs = map { ( -D => $_ ) } grep $path{$_}, qw(bin html sbin) ) {
- my @po = map { ( -o => $_ ) } grep -f,
+ print "./$_\t=> $path{$_}\n" for sort keys %subdirs;
+
+ if ( my @dirs = map { ( -D => $_ ) } grep $subdirs{$_}, qw(bin html sbin) ) {
+ my @po = map { ( -o => $_ ) }
+ grep -f,
File::Glob::bsd_glob("po/*.po");
$self->postamble(<< ".") if @po;
lexicons ::
@@ -111,7 +118,7 @@ install ::
\t\$(NOECHO) \$(PERL) -MExtUtils::Install -e \"install({$args})\"
.
- if ( $path{var} and -d $RT::MasonDataDir ) {
+ if ( $subdirs{var} and -d $RT::MasonDataDir ) {
my ( $uid, $gid ) = ( stat($RT::MasonDataDir) )[ 4, 5 ];
$postamble .= << ".";
\t\$(NOECHO) chown -R $uid:$gid $path{var}
@@ -139,16 +146,17 @@ dropdb ::
if ( -e 'etc/initialdata' ) { $has_etc{initialdata}++; }
$self->postamble("$postamble\n");
- if ( %subdirs and !$subdirs{'lib'} ) {
+ unless ( $subdirs{'lib'} ) {
$self->makemaker_args( PM => { "" => "" }, );
} else {
- $self->makemaker_args( INSTALLSITELIB => "$RT::LocalPath/lib" );
+ $self->makemaker_args( INSTALLSITELIB => $path{'lib'} );
+ $self->makemaker_args( INSTALLARCHLIB => $path{'lib'} );
}
- $self->makemaker_args( INSTALLSITEMAN1DIR => "$RT::LocalPath/man/man1" );
- $self->makemaker_args( INSTALLSITEMAN3DIR => "$RT::LocalPath/man/man3" );
- $self->makemaker_args( INSTALLSITEARCH => "$RT::LocalPath/man" );
- $self->makemaker_args( INSTALLARCHLIB => "$RT::LocalPath/lib" );
+ $self->makemaker_args( INSTALLSITEMAN1DIR => "$RT::LocalPath/man/man1" );
+ $self->makemaker_args( INSTALLSITEMAN3DIR => "$RT::LocalPath/man/man3" );
+ $self->makemaker_args( INSTALLSITEARCH => "$RT::LocalPath/man" );
+
if (%has_etc) {
$self->load('RTxInitDB');
print "For first-time installation, type 'make initdb'.\n";
@@ -180,4 +188,4 @@ sub RTxInit {
__END__
-#line 281
+#line 302
diff --git a/inc/Module/Install/RTx/Factory.pm b/inc/Module/Install/RTx/Factory.pm
index 4508c28..23ce911 100644
--- a/inc/Module/Install/RTx/Factory.pm
+++ b/inc/Module/Install/RTx/Factory.pm
@@ -31,7 +31,7 @@ sub RTxInitDB {
"$RT::SbinPath/rt-setup-database",
"--action" => $action,
"--datadir" => "etc",
- "--datafile" => "etc/initialdata",
+ (($action eq 'insert') ? ("--datafile" => "etc/initialdata") : ()),
"--dba" => $RT::DatabaseUser,
"--prompt-for-dba-password" => ''
);
diff --git a/inc/Module/Install/Substitute.pm b/inc/Module/Install/Substitute.pm
index 95ff9a7..56af7fe 100644
--- a/inc/Module/Install/Substitute.pm
+++ b/inc/Module/Install/Substitute.pm
@@ -1,19 +1,20 @@
#line 1
package Module::Install::Substitute;
-use vars qw(@ISA);
-use Module::Install::Base; @ISA = qw(Module::Install::Base);
-
use strict;
use warnings;
+use 5.008; # I don't care much about earlier versions
+
+use Module::Install::Base;
+our @ISA = qw(Module::Install::Base);
-$Module::Install::Substitute::VERSION = '0.02';
+our $VERSION = '0.03';
require File::Temp;
require File::Spec;
require Cwd;
-#line 64
+#line 89
sub substitute
{
@@ -94,11 +95,12 @@ sub __process_streams
my $re_subst = join('|', map {"\Q$_"} keys %{ $subst } );
while( my $str = <$in> ) {
- if( $str =~ /^###\s*(before|replace|after)\: ?(.*)$/s ) {
+ if( $str =~ /^###\s*(before|replace|after)\:\s?(.*)$/s ) {
my ($action, $nstr) = ($1,$2);
$nstr =~ s/\@($re_subst)\@/$subst->{$1}/ge;
- $action = 'before' if !$replace && $action eq 'replace';
+ die "Replace action is bad idea for situations when dest is equal to source"
+ if $replace && $action eq 'replace';
if( $action eq 'before' ) {
die "no line before 'before' action" unless @queue;
# overwrite prev line;
@@ -126,3 +128,4 @@ sub __process_streams
}
1;
+
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index f8744e7..cff76a2 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.72';
+ $VERSION = '0.77';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index d1d8a06..f35620f 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.72';
+ $VERSION = '0.77';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
commit b02d19b370da7a51f9fbf2e69cf04b32feec016b
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Mar 4 14:02:56 2009 +0000
docs updates, thanks to Richard Foley
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 07a6bff..f26f11c 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -12,21 +12,34 @@ RT::Extension::SLA - Service Level Agreements for RT
=head1 DESCRIPTION
-RT's extension that allows you to automate due dates using
-service levels.
+RT extension to implement automated due dates using service levels.
+
+=head1 INSTALL
+
+=over 4
+
+=item perl Makefile.PL
+
+=item make
+
+=item make install
+
+=item make initdb (for the first time only)
+
+=back
=head1 CONFIGURATION
-Service level agreements of tickets is controlled by SLA custom
-field. It's created during `make initdb` step and applied globally.
-This CF MUST be of 'select one value' type. Values of the CF
-define service levels.
+Service level agreements of tickets is controlled by an SLA custom field (CF).
+This field is created during C<make initdb> step (above) and applied globally.
+This CF MUST be of C<select one value> type. Values of the CF define the
+service levels.
It's possible to define different set of levels for different
queues. You can create several CFs with the same name and
different set of values. But if you move tickets between
-queues a lot then it's gonna be a problem and it's preferred
-to use ONE SLA custom field.
+queues a lot then it's going to be a problem and it's preferred
+to use B<ONE> SLA custom field.
There is no WebUI in the current version. Almost everything is
controlled in the RT's config using option C<%RT::ServiceAgreements>
@@ -43,6 +56,9 @@ and C<%RT::ServiceBusinessHours>. For example:
},
);
+In this example I<Incident> is the name of the queue, and I<2h> is the name of
+the SLA which will be applied to this queue by default.
+
Each service level can be described using several options:
L<StartImmediately|/"StartImmediately (boolean, false)">,
L<Resolve|/"Resolve and Response (interval, no defaults)">,
@@ -52,16 +68,16 @@ and L<ServiceBusinessHours|/"Configuring business hours">.
=head2 StartImmediately (boolean, false)
-By default when ticket is created Starts date is set to
+By default when a ticket is created Starts date is set to
first business minute after time of creation. In other
-words if ticket is created during business hours then
-Starts will be equal to Created time, otherwise it'll
+words if a ticket is created during business hours then
+Starts will be equal to Created time, otherwise Starts will
be beginning of the next business day.
However, if you provide 24/7 support then you most
probably would be interested in Starts to be always equal
to Created time. In this case you can set option
-StartImmediately to true value.
+StartImmediately to a true value.
Example:
@@ -143,7 +159,7 @@ Resolve and Response can be combined. In such case due date is set
according to the earliest of two deadlines and never is dropped to
'not set'.
-If a ticket met its Resolve deadline then due date stops "fliping",
+If a ticket met its Resolve deadline then due date stops "flipping",
is freezed and the ticket becomes overdue. Before that moment when
non-requestor replies to a ticket, due date is changed to Resolve
deadline instead of 'Not Set', as well this happens when a ticket
@@ -425,13 +441,19 @@ 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.
+=head1 NOTES
+
+If you run C<make initdb> more than once you will create multiple SLA CFs. You
+can remove these via RT's C<Configuration-E<gt>Global> menu, (both Custom Fields
+and Scrips).
+
=head1 AUTHOR
Ruslan Zakirov E<lt>ruz at bestpractical.comE<gt>
=head1 COPYRIGHT
-This extension is Copyright (C) 2007-2008 Best Practical Solutions, LLC.
+This extension is Copyright (C) 2007-2009 Best Practical Solutions, LLC.
It is freely redistributable under the terms of version 2 of the GNU GPL.
commit 5e75cfb38f97a8d96944611116b40d9c9c00e3e8
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Apr 20 17:53:34 2009 +0000
describe a new feature in the doc
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index f26f11c..f0df88a 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -63,6 +63,7 @@ Each service level can be described using several options:
L<StartImmediately|/"StartImmediately (boolean, false)">,
L<Resolve|/"Resolve and Response (interval, no defaults)">,
L<Response|/"Resolve and Response (interval, no defaults)">,
+L<KeepInLoop|/"Keep in loop (interval, no defaults)">,
L<OutOfHours|/"OutOfHours (struct, no default)">
and L<ServiceBusinessHours|/"Configuring business hours">.
@@ -201,6 +202,23 @@ level set deadline to 8 real hours starting from the next business
day, when tickets with the second level should be resolved in the
next 8 hours after creation.
+=head2 Keep in loop (interval, no defaults)
+
+If response deadline is used then Due date is changed to repsonse
+deadline or to "Not Set" when staff replies to a ticket. In some
+cases you want to keep requestors in loop and keed them up to date
+every few hours. KeepInLoop option can be used to achieve this.
+
+ 'incident' => {
+ Response => { RealMinutes => 60*1 }, # one hour
+ KeepInLoop => { RealMinutes => 60*2 }, # two hours
+ Resolve => { RealMinutes => 60*24 }, # 24 real hours
+ },
+
+In the above example Due is set to one hour after creation, reply
+of a non-requestor moves Due date two hours forward, requestors'
+replies move Due date to one hour and resolve deadine is 24 hours.
+
=head2 OutOfHours (struct, no default)
Out of hours modifier. Adds more real or business minutes to resolve
@@ -411,19 +429,15 @@ sub GetDefaultServiceLevel {
=head1 TODO
- * default SLA for queues
- ** implemented
- ** TODO: tests for options in the config
+ * [implemented, TODO: tests for options in the config] default SLA for queues
- * add support for multiple b-hours definitions, this could be very helpfull
- when you have 24/7 mixed with 8/5 and/or something like 8/5+4/2 for different
- tickets(by requestor, queue or something else). So people would be able to
- handle tickets in the right order using Due dates.
- ** implemented
- ** TODO: tests
+ * [implemented, TODO: tests] add support for multiple b-hours definitions,
+ this could be very helpfull when you have 24/7 mixed with 8/5 and/or
+ something like 8/5+4/2 for different tickets(by requestor, queue or
+ something else). So people would be able to handle tickets in the right
+ order using Due dates.
- * WebUI
- ** not implemented
+ * [not implemented] WebUI
=head1 DESIGN
commit 03063f9ff6444a136943f56646da742a2e58a0b3
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Apr 20 17:56:12 2009 +0000
implement KeepInLoop feature
diff --git a/lib/RT/Action/SLA_SetDue.pm b/lib/RT/Action/SLA_SetDue.pm
index 72fc445..208c2c3 100644
--- a/lib/RT/Action/SLA_SetDue.pm
+++ b/lib/RT/Action/SLA_SetDue.pm
@@ -37,16 +37,17 @@ sub Commit {
my $txn = $self->TransactionObj;
my $level = $ticket->FirstCustomFieldValue('SLA');
- my $last_reply = $self->LastRequestorsEffectiveAct;
- $RT::Logger->debug('Last effective requestors\' reply to ticket #'. $ticket->id .' is txn #'. $last_reply->id )
- if $last_reply;
+ my ($last_reply, $is_requestor) = $self->LastEffectiveAct;
+ $RT::Logger->debug(
+ 'Last effective '. ($is_requestor? '':'non-') .'requestors\' reply'
+ .' to ticket #'. $ticket->id .' is txn #'. $last_reply->id
+ );
- my $response_due;
- $response_due = $self->Due(
+ my $response_due = $self->Due(
Level => $level,
- Type => 'Response',
+ Type => $is_requestor? 'Response': 'KeepInLoop',
Time => $last_reply->CreatedObj->Unix,
- ) if $last_reply;
+ );
my $resolve_due = $self->Due(
Level => $level,
@@ -74,7 +75,7 @@ sub IsRequestorsAct {
return $self->TicketObj->Requestors->HasMemberRecursively( $actor )? 1 : 0;
}
-sub LastRequestorsEffectiveAct {
+sub LastEffectiveAct {
my $self = shift;
my $txns = $self->TicketObj->Transactions;
@@ -87,10 +88,13 @@ sub LastRequestorsEffectiveAct {
my $res;
while ( my $txn = $txns->Next ) {
- return $res unless $self->IsRequestorsAct( $txn );
+ unless ( $self->IsRequestorsAct( $txn ) ) {
+ last if $res;
+ return ($txn);
+ }
$res = $txn;
}
- return $res;
+ return ($res, 'requestor');
}
1;
commit 47540b51e675197c0e07cc20f15be0b9e5074853
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Apr 20 17:56:46 2009 +0000
add tests for KeepInLoop thing
diff --git a/t/due.t b/t/due.t
index 7e1c211..c021189 100644
--- a/t/due.t
+++ b/t/due.t
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 52;
+use Test::More tests => 72;
require 't/utils.pl';
@@ -168,6 +168,116 @@ diag 'check that reply to requestors unset due date';
}
}
+diag 'check that reply to requestors dont unset due date with KeepInLoop';
+{
+ %RT::ServiceAgreements = (
+ Default => '2',
+ Levels => {
+ '2' => {
+ Response => { RealMinutes => 60*2 },
+ KeepInLoop => { RealMinutes => 60*4 },
+ },
+ },
+ );
+
+ my $root = RT::User->new( $RT::SystemUser );
+ $root->LoadByEmail('root at localhost');
+ ok $root->id, 'loaded root user';
+
+ # requestor creates
+ my $id;
+ my $due;
+ {
+ 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';
+
+ $due = $ticket->DueObj->Unix;
+ ok $due > 0, 'Due date is set';
+ }
+
+ # 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.' );
+
+ $ticket = RT::Ticket->new( $root );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+
+ my $tmp = $ticket->DueObj->Unix;
+ ok $tmp > 0, 'Due date is set';
+ ok $tmp > $due, "keep in loop is 4hours when response is 2hours";
+ $due = $tmp;
+ }
+
+ # non-requestor reply again
+ {
+ sleep 1;
+ my $ticket = RT::Ticket->new( $RT::SystemUser );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+ $ticket->Correspond( Content => 'we are still working on this.' );
+
+ $ticket = RT::Ticket->new( $root );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+
+ my $tmp = $ticket->DueObj->Unix;
+ ok $tmp > 0, 'Due date is set';
+ ok $tmp > $due, "keep in loop sligtly moved";
+ $due = $tmp;
+ }
+
+ # requestor reply
+ my $last_unreplied_due;
+ {
+ my $ticket = RT::Ticket->new( $root );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+
+ $ticket->Correspond( Content => 'what\'s going on with my ticket?' );
+
+ $ticket = RT::Ticket->new( $root );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+
+ my $tmp = $ticket->DueObj->Unix;
+ ok $tmp > 0, 'Due date is set';
+ ok $tmp < $due, "response deadline is 2 hours earlier";
+ $due = $tmp;
+
+ $last_unreplied_due = $due;
+ }
+
+ # sleep at least one second and requestor replies again
+ sleep 1;
+ {
+ my $ticket = RT::Ticket->new( $root );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+
+ $ticket->Correspond( Content => 'HEY! Were is my answer?' );
+
+ $ticket = RT::Ticket->new( $root );
+ $ticket->Load( $id );
+ ok $ticket->id, "loaded ticket #$id";
+
+ my $tmp = $ticket->DueObj->Unix;
+ ok $tmp > 0, 'Due date is set';
+ is $tmp, $last_unreplied_due, 'due is unchanged';
+ $due = $tmp;
+ }
+}
+
diag 'check that replies dont affect resolve deadlines';
{
%RT::ServiceAgreements = (
commit 3f8e70a3aec6fe1d04febfbf47baec09a433ec5d
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Apr 20 18:18:53 2009 +0000
update inc/
diff --git a/inc/Module/AutoInstall.pm b/inc/Module/AutoInstall.pm
index 7efc552..739bc85 100644
--- a/inc/Module/AutoInstall.pm
+++ b/inc/Module/AutoInstall.pm
@@ -115,6 +115,8 @@ sub import {
)[0]
);
+ $UnderCPAN = _check_lock(1); # check for $UnderCPAN
+
while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
my ( @required, @tests, @skiptests );
my $default = 1;
@@ -184,6 +186,7 @@ sub import {
!$SkipInstall
and (
$CheckOnly
+ or ($mandatory and $UnderCPAN)
or _prompt(
qq{==> Auto-install the }
. ( @required / 2 )
@@ -214,8 +217,6 @@ sub import {
}
}
- $UnderCPAN = _check_lock(); # check for $UnderCPAN
-
if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
require Config;
print
@@ -237,7 +238,7 @@ sub import {
# 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;
+ return unless @Missing or @_;
if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
print <<'END_MESSAGE';
@@ -313,7 +314,7 @@ sub install {
@modules = @newmod;
}
- if ( _has_cpanplus() ) {
+ if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) {
_install_cpanplus( \@modules, \@config );
} else {
_install_cpan( \@modules, \@config );
@@ -706,7 +707,7 @@ sub _make_args {
if $Config;
$PostambleActions = (
- $missing
+ ($missing and not $UnderCPAN)
? "\$(PERL) $0 --config=$config --installdeps=$missing"
: "\$(NOECHO) \$(NOOP)"
);
@@ -746,7 +747,7 @@ sub Write {
sub postamble {
$PostambleUsed = 1;
- return << ".";
+ return <<"END_MAKE";
config :: installdeps
\t\$(NOECHO) \$(NOOP)
@@ -757,7 +758,7 @@ checkdeps ::
installdeps ::
\t$PostambleActions
-.
+END_MAKE
}
@@ -765,4 +766,4 @@ installdeps ::
__END__
-#line 1003
+#line 1004
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index eb449ca..5b9ddbf 100644
--- a/inc/Module/Install.pm
+++ b/inc/Module/Install.pm
@@ -17,12 +17,10 @@ package Module::Install;
# 3. The ./inc/ version of Module::Install loads
# }
-BEGIN {
- require 5.004;
-}
+use 5.005;
use strict 'vars';
-use vars qw{$VERSION};
+use vars qw{$VERSION $MAIN};
BEGIN {
# All Module::Install core packages now require synchronised versions.
# This will be used to ensure we don't accidentally load old or
@@ -30,7 +28,10 @@ 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.77';
+ $VERSION = '0.85';
+
+ # Storage for the pseudo-singleton
+ $MAIN = undef;
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
@@ -69,15 +70,26 @@ END_DIE
# 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 and (stat($0))[9] > time ) { die <<"END_DIE" }
+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.
+Your installer $0 has a modification time in the future ($s > $t).
This is known to create infinite loops in make.
Please correct this, then run $0 again.
END_DIE
+}
@@ -121,14 +133,22 @@ sub autoload {
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
- # delegate back to parent dirs
+ # Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
- unless ( uc($1) eq $1 ) {
- unshift @_, ( $self, $1 );
- goto &{$self->can('call')};
+ my $method = $1;
+ if ( uc($method) eq $method ) {
+ # Do nothing
+ return;
+ } elsif ( $method =~ /^_/ and $self->can($method) ) {
+ # Dispatch to the root M:I class
+ return $self->$method(@_);
}
+
+ # Dispatch to the appropriate plugin
+ unshift @_, ( $self, $1 );
+ goto &{$self->can('call')};
};
}
@@ -153,6 +173,9 @@ sub import {
delete $INC{"$self->{file}"};
delete $INC{"$self->{path}.pm"};
+ # Save to the singleton
+ $MAIN = $self;
+
return 1;
}
@@ -166,8 +189,7 @@ sub preload {
my @exts = @{$self->{extensions}};
unless ( @exts ) {
- my $admin = $self->{admin};
- @exts = $admin->load_all_extensions;
+ @exts = $self->{admin}->load_all_extensions;
}
my %seen;
@@ -250,7 +272,7 @@ END_DIE
sub load_extensions {
my ($self, $path, $top) = @_;
- unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
+ unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
}
@@ -314,7 +336,7 @@ sub find_extensions {
#####################################################################
-# Utility Functions
+# Common Utility Functions
sub _caller {
my $depth = 0;
@@ -328,31 +350,70 @@ sub _caller {
sub _read {
local *FH;
- open FH, "< $_[0]" or die "open($_[0]): $!";
- my $str = do { local $/; <FH> };
+ if ( $] >= 5.006 ) {
+ open( FH, '<', $_[0] ) or die "open($_[0]): $!";
+ } else {
+ open( FH, "< $_[0]" ) or die "open($_[0]): $!";
+ }
+ my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
- return $str;
+ return $string;
+}
+
+sub _readperl {
+ my $string = Module::Install::_read($_[0]);
+ $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
+ $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
+ $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
+ return $string;
+}
+
+sub _readpod {
+ my $string = Module::Install::_read($_[0]);
+ $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
+ return $string if $_[0] =~ /\.pod\z/;
+ $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
+ $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
+ $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
+ $string =~ s/^\n+//s;
+ return $string;
}
sub _write {
local *FH;
- open FH, "> $_[0]" or die "open($_[0]): $!";
- foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
+ if ( $] >= 5.006 ) {
+ open( FH, '>', $_[0] ) or die "open($_[0]): $!";
+ } else {
+ open( FH, "> $_[0]" ) or die "open($_[0]): $!";
+ }
+ foreach ( 1 .. $#_ ) {
+ print FH $_[$_] or die "print($_[0]): $!";
+ }
close FH or die "close($_[0]): $!";
}
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
-
sub _version ($) {
my $s = shift || 0;
- $s =~ s/^(\d+)\.?//;
+ my $d =()= $s =~ /(\.)/g;
+ if ( $d >= 2 ) {
+ # Normalise multipart versions
+ $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
+ }
+ $s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
- my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
- $l = $l . '.' . join '', @v if @v;
+ my @v = map {
+ $_ . '0' x (3 - length $_)
+ } $s =~ /(\d{1,3})\D?/g;
+ $l = $l . '.' . join '', @v if @v;
return $l + 0;
}
+sub _cmp ($$) {
+ _version($_[0]) <=> _version($_[1]);
+}
+
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
@@ -360,10 +421,10 @@ sub _CLASS ($) {
and
! ref $_[0]
and
- $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
+ $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
) ? $_[0] : undef;
}
1;
-# Copyright 2008 Adam Kennedy.
+# Copyright 2008 - 2009 Adam Kennedy.
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
index 8b3bcaa..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.77';
+ $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 433ebed..ac416c9 100644
--- a/inc/Module/Install/Base.pm
+++ b/inc/Module/Install/Base.pm
@@ -1,7 +1,11 @@
#line 1
package Module::Install::Base;
-$VERSION = '0.77';
+use strict 'vars';
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '0.85';
+}
# Suspend handler for "redefined" warnings
BEGIN {
@@ -12,51 +16,61 @@ BEGIN {
### This is the ONLY module that shouldn't have strict on
# use strict;
-#line 41
+#line 45
sub new {
- my ($class, %args) = @_;
+ my ($class, %args) = @_;
- foreach my $method ( qw(call load) ) {
- *{"$class\::$method"} = sub {
- shift()->_top->$method(@_);
- } unless defined &{"$class\::$method"};
- }
+ foreach my $method ( qw(call load) ) {
+ next if defined &{"$class\::$method"};
+ *{"$class\::$method"} = sub {
+ shift()->_top->$method(@_);
+ };
+ }
- bless( \%args, $class );
+ bless( \%args, $class );
}
-#line 61
+#line 66
sub AUTOLOAD {
- my $self = shift;
- local $@;
- my $autoload = eval { $self->_top->autoload } or return;
- goto &$autoload;
+ my $self = shift;
+ local $@;
+ my $autoload = eval {
+ $self->_top->autoload
+ } or return;
+ goto &$autoload;
}
-#line 76
+#line 83
-sub _top { $_[0]->{_top} }
+sub _top {
+ $_[0]->{_top};
+}
-#line 89
+#line 98
sub admin {
- $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
+ $_[0]->_top->{admin}
+ or
+ Module::Install::Base::FakeAdmin->new;
}
-#line 101
+#line 114
sub is_admin {
- $_[0]->admin->VERSION;
+ $_[0]->admin->VERSION;
}
sub DESTROY {}
package Module::Install::Base::FakeAdmin;
-my $Fake;
-sub new { $Fake ||= bless(\@_, $_[0]) }
+my $fake;
+
+sub new {
+ $fake ||= bless(\@_, $_[0]);
+}
sub AUTOLOAD {}
@@ -69,4 +83,4 @@ BEGIN {
1;
-#line 146
+#line 162
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index 9025607..3e2d523 100644
--- a/inc/Module/Install/Can.pm
+++ b/inc/Module/Install/Can.pm
@@ -3,15 +3,13 @@ package Module::Install::Can;
use strict;
use Module::Install::Base;
-use Config ();
-### This adds a 5.005 Perl version dependency.
-### This is a bug and will be fixed.
-use File::Spec ();
+use Config ();
+use File::Spec ();
use ExtUtils::MakeMaker ();
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.77';
+ $VERSION = '0.85';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
@@ -80,4 +78,4 @@ if ( $^O eq 'cygwin' ) {
__END__
-#line 158
+#line 156
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index d66aba5..0a62208 100644
--- a/inc/Module/Install/Fetch.pm
+++ b/inc/Module/Install/Fetch.pm
@@ -6,20 +6,20 @@ use Module::Install::Base;
use vars qw{$VERSION $ISCORE @ISA};
BEGIN {
- $VERSION = '0.77';
+ $VERSION = '0.85';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
sub get_file {
my ($self, %args) = @_;
- my ($scheme, $host, $path, $file) =
+ my ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
$args{url} = $args{ftp_url}
or (warn("LWP support unavailable!\n"), return);
- ($scheme, $host, $path, $file) =
+ ($scheme, $host, $path, $file) =
$args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
}
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
index 0c7dc5a..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.77';
+ $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 92cd1ef..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.77';
+ $VERSION = '0.85';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
@@ -64,7 +64,7 @@ sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
%$clean = (
- %$clean,
+ %$clean,
FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
);
}
@@ -73,7 +73,7 @@ sub realclean_files {
my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
%$realclean = (
- %$realclean,
+ %$realclean,
FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
);
}
@@ -114,17 +114,32 @@ sub write {
my $self = shift;
die "&Makefile->write() takes no arguments\n" if @_;
- # Make sure we have a new enough
- require ExtUtils::MakeMaker;
+ # Check the current Perl version
+ my $perl_version = $self->perl_version;
+ if ( $perl_version ) {
+ eval "use $perl_version; 1"
+ or die "ERROR: perl: Version $] is installed, "
+ . "but we need version >= $perl_version";
+ }
- # 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.
+ # Make sure we have a new enough MakeMaker
+ require ExtUtils::MakeMaker;
- $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
+ 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+)/ );
+ } 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 );
+ }
- # Generate the
+ # Generate the MakeMaker params
my $args = $self->makemaker_args;
$args->{DISTNAME} = $self->name;
$args->{NAME} = $self->module_name || $self->name;
@@ -133,7 +148,7 @@ sub write {
if ( $self->tests ) {
$args->{test} = { TESTS => $self->tests };
}
- if ($] >= 5.005) {
+ if ( $] >= 5.005 ) {
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = $self->author;
}
@@ -147,7 +162,7 @@ sub write {
delete $args->{SIGN};
}
- # merge both kinds of requires into prereq_pm
+ # Merge both kinds of requires into prereq_pm
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
map { @$_ }
@@ -196,7 +211,7 @@ sub fix_up_makefile {
my $top_class = ref($self->_top) || '';
my $top_version = $self->_top->VERSION || '';
- my $preamble = $self->preamble
+ my $preamble = $self->preamble
? "# Preamble by $top_class $top_version\n"
. $self->preamble
: '';
@@ -250,4 +265,4 @@ sub postamble {
__END__
-#line 379
+#line 394
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index 397fb97..ca16db7 100644
--- a/inc/Module/Install/Metadata.pm
+++ b/inc/Module/Install/Metadata.pm
@@ -4,13 +4,18 @@ package Module::Install::Metadata;
use strict 'vars';
use Module::Install::Base;
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.77';
- $ISCORE = 1;
+ $VERSION = '0.85';
@ISA = qw{Module::Install::Base};
+ $ISCORE = 1;
}
+my @boolean_keys = qw{
+ sign
+ mymeta
+};
+
my @scalar_keys = qw{
name
module_name
@@ -37,16 +42,43 @@ my @resource_keys = qw{
repository
};
+my @array_keys = qw{
+ keywords
+};
+
sub Meta { shift }
+sub Meta_BooleanKeys { @boolean_keys }
sub Meta_ScalarKeys { @scalar_keys }
sub Meta_TupleKeys { @tuple_keys }
sub Meta_ResourceKeys { @resource_keys }
+sub Meta_ArrayKeys { @array_keys }
+
+foreach my $key ( @boolean_keys ) {
+ *$key = sub {
+ my $self = shift;
+ if ( defined wantarray and not @_ ) {
+ return $self->{values}->{$key};
+ }
+ $self->{values}->{$key} = ( @_ ? $_[0] : 1 );
+ return $self;
+ };
+}
foreach my $key ( @scalar_keys ) {
*$key = sub {
my $self = shift;
- return $self->{values}{$key} if defined wantarray and !@_;
- $self->{values}{$key} = shift;
+ return $self->{values}->{$key} if defined wantarray and !@_;
+ $self->{values}->{$key} = shift;
+ return $self;
+ };
+}
+
+foreach my $key ( @array_keys ) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}->{$key} if defined wantarray and !@_;
+ $self->{values}->{$key} ||= [];
+ push @{$self->{values}->{$key}}, @_;
return $self;
};
}
@@ -55,12 +87,12 @@ foreach my $key ( @resource_keys ) {
*$key = sub {
my $self = shift;
unless ( @_ ) {
- return () unless $self->{values}{resources};
+ return () unless $self->{values}->{resources};
return map { $_->[1] }
grep { $_->[0] eq $key }
- @{ $self->{values}{resources} };
+ @{ $self->{values}->{resources} };
}
- return $self->{values}{resources}{$key} unless @_;
+ return $self->{values}->{resources}->{$key} unless @_;
my $uri = shift or die(
"Did not provide a value to $key()"
);
@@ -69,54 +101,19 @@ foreach my $key ( @resource_keys ) {
};
}
-sub requires {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}{requires} }, [ $module, $version ];
- }
- $self->{values}{requires};
-}
-
-sub build_requires {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}{build_requires} }, [ $module, $version ];
- }
- $self->{values}{build_requires};
-}
-
-sub configure_requires {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}{configure_requires} }, [ $module, $version ];
- }
- $self->{values}{configure_requires};
-}
-
-sub recommends {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}{recommends} }, [ $module, $version ];
- }
- $self->{values}{recommends};
-}
-
-sub bundles {
- my $self = shift;
- while ( @_ ) {
- my $module = shift or last;
- my $version = shift || 0;
- push @{ $self->{values}{bundles} }, [ $module, $version ];
- }
- $self->{values}{bundles};
+foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}->{$key} unless @_;
+ my @added;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @added, [ $module, $version ];
+ }
+ push @{ $self->{values}->{$key} }, @added;
+ return map {@$_} @added;
+ };
}
# Resource handling
@@ -135,29 +132,22 @@ sub resources {
if ( $name eq lc $name and ! $lc_resource{$name} ) {
die("Unsupported reserved lowercase resource '$name'");
}
- $self->{values}{resources} ||= [];
- push @{ $self->{values}{resources} }, [ $name, $value ];
+ $self->{values}->{resources} ||= [];
+ push @{ $self->{values}->{resources} }, [ $name, $value ];
}
- $self->{values}{resources};
+ $self->{values}->{resources};
}
# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
-sub test_requires { shift->build_requires(@_) }
-sub install_requires { shift->build_requires(@_) }
+sub test_requires { shift->build_requires(@_) }
+sub install_requires { shift->build_requires(@_) }
# Aliases for installdirs options
-sub install_as_core { $_[0]->installdirs('perl') }
-sub install_as_cpan { $_[0]->installdirs('site') }
-sub install_as_site { $_[0]->installdirs('site') }
-sub install_as_vendor { $_[0]->installdirs('vendor') }
-
-sub sign {
- my $self = shift;
- return $self->{values}{sign} if defined wantarray and ! @_;
- $self->{values}{sign} = ( @_ ? $_[0] : 1 );
- return $self;
-}
+sub install_as_core { $_[0]->installdirs('perl') }
+sub install_as_cpan { $_[0]->installdirs('site') }
+sub install_as_site { $_[0]->installdirs('site') }
+sub install_as_vendor { $_[0]->installdirs('vendor') }
sub dynamic_config {
my $self = shift;
@@ -165,42 +155,60 @@ sub dynamic_config {
warn "You MUST provide an explicit true/false value to dynamic_config\n";
return $self;
}
- $self->{values}{dynamic_config} = $_[0] ? 1 : 0;
+ $self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
return 1;
}
sub perl_version {
my $self = shift;
- return $self->{values}{perl_version} unless @_;
+ return $self->{values}->{perl_version} unless @_;
my $version = shift or die(
"Did not provide a value to perl_version()"
);
- # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
- # numbers (eg, 5.006001 or 5.008009).
-
- $version =~ s/^(\d+)\.(\d+)\.(\d+)$/sprintf("%d.%03d%03d",$1,$2,$3)/e;
+ # Normalize the version
+ $version = $self->_perl_version($version);
- $version =~ s/_.+$//;
- $version = $version + 0; # Numify
+ # We don't support the reall old versions
unless ( $version >= 5.005 ) {
die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
}
- $self->{values}{perl_version} = $version;
- return 1;
+
+ $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 @_;
+ return $self->{values}->{license} unless @_;
my $license = shift or die(
'Did not provide a value to license()'
);
- $self->{values}{license} = $license;
+ $self->{values}->{license} = $license;
# Automatically fill in license URLs
- if ( $license eq 'perl' ) {
- $self->resources( license => 'http://dev.perl.org/licenses/' );
+ if ( $license_urls{$license} ) {
+ $self->resources( license => $license_urls{$license} );
}
return 1;
@@ -242,7 +250,7 @@ sub all_from {
sub provides {
my $self = shift;
- my $provides = ( $self->{values}{provides} ||= {} );
+ my $provides = ( $self->{values}->{provides} ||= {} );
%$provides = (%$provides, @_) if @_;
return $provides;
}
@@ -271,7 +279,7 @@ sub auto_provides {
sub feature {
my $self = shift;
my $name = shift;
- my $features = ( $self->{values}{features} ||= [] );
+ my $features = ( $self->{values}->{features} ||= [] );
my $mods;
if ( @_ == 1 and ref( $_[0] ) ) {
@@ -299,16 +307,16 @@ sub features {
while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
$self->feature( $name, @$mods );
}
- return $self->{values}{features}
- ? @{ $self->{values}{features} }
+ return $self->{values}->{features}
+ ? @{ $self->{values}->{features} }
: ();
}
sub no_index {
my $self = shift;
my $type = shift;
- push @{ $self->{values}{no_index}{$type} }, @_ if $type;
- return $self->{values}{no_index};
+ push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
+ return $self->{values}->{no_index};
}
sub read {
@@ -451,9 +459,6 @@ sub license_from {
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s{\s+}{\\s+}g;
if ( $license_text =~ /\b$pattern\b/i ) {
- if ( $osi and $license_text =~ /All rights reserved/i ) {
- print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
- }
$self->license($license);
return 1;
}
@@ -464,10 +469,18 @@ sub license_from {
return 'unknown';
}
+sub _extract_bugtracker {
+ my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g;
+ my %links;
+ @links{@links}=();
+ @links=keys %links;
+ return @links;
+}
+
sub bugtracker_from {
my $self = shift;
my $content = Module::Install::_read($_[0]);
- my @links = $content =~ m/L\<(http\:\/\/rt\.cpan\.org\/[^>]+)\>/g;
+ my @links = _extract_bugtracker($content);
unless ( @links ) {
warn "Cannot determine bugtracker info from $_[0]\n";
return 0;
@@ -482,19 +495,86 @@ sub bugtracker_from {
return 1;
}
-sub install_script {
+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;
+ while ( @requires ) {
+ my $module = shift @requires;
+ my $version = shift @requires;
+ $self->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?)\.(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
+ }
+ return $v;
+}
+
+
+
+
+
+######################################################################
+# MYMETA.yml Support
+
+sub WriteMyMeta {
+ die "WriteMyMeta has been deprecated";
+}
+
+sub write_mymeta {
my $self = shift;
- my $args = $self->makemaker_args;
- my $exe = $args->{EXE_FILES} ||= [];
- foreach ( @_ ) {
- if ( -f $_ ) {
- push @$exe, $_;
- } elsif ( -d 'script' and -f "script/$_" ) {
- push @$exe, "script/$_";
- } else {
- die("Cannot find script '$_'");
+
+ # 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;
+ }
+
+ # Merge the perl version into the dependencies
+ my $val = $self->Meta->{values};
+ my $perl = delete $val->{perl_version};
+ if ( $perl ) {
+ $val->{requires} ||= [];
+ my $requires = $val->{requires};
+
+ # Canonize to three-dot version after Perl 5.6
+ if ( $perl >= 5.006 ) {
+ $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
}
+ unshift @$requires, [ perl => $perl ];
}
+
+ # Load the advisory META.yml file
+ my @yaml = YAML::Tiny::LoadFile('META.yml');
+ my $meta = $yaml[0];
+
+ # Overwrite the non-configure dependency hashs
+ delete $meta->{requires};
+ delete $meta->{build_requires};
+ delete $meta->{recommends};
+ if ( exists $val->{requires} ) {
+ $meta->{requires} = { map { @$_ } @{ $val->{requires} } };
+ }
+ if ( exists $val->{build_requires} ) {
+ $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
+ }
+
+ # Save as the MYMETA.yml file
+ print "Writing MYMETA.yml\n";
+ YAML::Tiny::DumpFile('MYMETA.yml', $meta);
}
1;
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
index 2028f5e..20a354b 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.23';
+our $VERSION = '0.24';
use FindBin;
use File::Glob ();
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index cff76a2..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.77';
+ $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 f35620f..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.77';
+ $VERSION = '0.85';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -22,7 +22,6 @@ sub WriteAll {
);
$self->sign(1) if $args{sign};
- $self->Meta->write if $args{meta};
$self->admin->WriteAll(%args) if $self->is_admin;
$self->check_nmake if $args{check_nmake};
@@ -30,11 +29,22 @@ sub WriteAll {
$self->makemaker_args( PL_FILES => {} );
}
+ # Until ExtUtils::MakeMaker support MYMETA.yml, make sure
+ # we clean it up properly ourself.
+ $self->realclean_files('MYMETA.yml');
+
if ( $args{inline} ) {
$self->Inline->write;
} else {
$self->Makefile->write;
}
+
+ # 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;
+
+ return 1;
}
1;
commit f1963baeb2645e695326abedb88b2b6ffabff2b1
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Apr 20 19:26:21 2009 +0000
bump version, update Changes and meta file
diff --git a/Changes b/Changes
index 384685f..b111776 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,6 @@
+0.03 Mon Apr 20 23:25:03 +0400 2009
+
+ * Add KeepInLoop option
0.02 Thu May 06 04:07:00 +0400 2008
diff --git a/META.yml b/META.yml
index 6c20557..c96930b 100644
--- a/META.yml
+++ b/META.yml
@@ -3,9 +3,12 @@ abstract: 'Service Level Agreements for RT'
author:
- 'Ruslan Zakirov <ruz at bestpractical.com>'
build_requires:
+ ExtUtils::MakeMaker: 6.42
Test::More: 0
+configure_requires:
+ ExtUtils::MakeMaker: 6.42
distribution_type: module
-generated_by: 'Module::Install version 0.77'
+generated_by: 'Module::Install version 0.85'
license: gpl2
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -14,12 +17,11 @@ name: RT-Extension-SLA
no_index:
directory:
- etc
- - html
- - po
- - var
- inc
- t
requires:
Business::Hours: 0
perl: 5.8.0
-version: 0.02
+resources:
+ license: http://opensource.org/licenses/gpl-2.0.php
+version: 0.03
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index f0df88a..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.02';
+our $VERSION = '0.03';
=head1 NAME
commit 6cdb6f0bf1fbed51f38621adf6834a67931baa05
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon Apr 27 19:04:02 2009 +0000
fist pass on a reporting
diff --git a/lib/RT/Extension/SLA/Report.pm b/lib/RT/Extension/SLA/Report.pm
new file mode 100644
index 0000000..afbae9e
--- /dev/null
+++ b/lib/RT/Extension/SLA/Report.pm
@@ -0,0 +1,98 @@
+use 5.8.0;
+use strict;
+use warnings;
+
+package RT::Extension::SLA::Report;
+
+sub new {}
+
+sub init {}
+
+sub State {
+ my $self = shift;
+ return $self->{State} ||= {};
+}
+
+{ my $cache;
+sub Handlers {
+ my $self = shift;
+
+ return $cache if $cache;
+
+ $cache = {
+ Create => 'OnCreate',
+ Set => {
+ Owner => 'OnOwnerChange',
+ },
+ Correpond => 'OnResponse',
+ CustomField => { map $_ => 'OnServiceLevelChange', $self->ServiceLevelCustomFields },
+ };
+
+ return $cache;
+}
+
+sub Drive {
+ my $self = shift;
+ my $txns = shift;
+
+ 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;
+
+ $self->$h( Transaction => $txn, State => $state );
+ }
+}
+
+sub InitialServiceLevel {
+ my $self = shift;
+ my $ticket = shift;
+
+ my $txns = $ticket->Transactions;
+ foreach my $cf ( $self->ServiceLevelCustomFields ) {
+ $txns->_OpenParen('ServiceLevelCustomFields');
+ $txns->Limit(
+ SUBCLAUSE => 'ServiceLevelCustomFields',
+ ENTRYAGGREGATOR => 'OR',
+ FIELD => 'Type',
+ VALUE => 'CustomField',
+ );
+ $txns->Limit(
+ SUBCLAUSE => 'ServiceLevelCustomFields',
+ ENTRYAGGREGATOR => 'AND',
+ FIELD => 'Field',
+ VALUE => $cf->id,
+ );
+ $txns->_CloseParen('ServiceLevelCustomFields');
+ }
+
+ return $self;
+}
+
+{ 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
+
+ push @cache, $_ while $_ = $cfs->Next;
+
+ return @cache;
+} }
+
+1;
commit ad5e80bcc46a6a539b9e71a518501ce90eef5909
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed Apr 29 20:54:43 2009 +0000
another pass on reporting
diff --git a/lib/RT/Extension/SLA/Report.pm b/lib/RT/Extension/SLA/Report.pm
index afbae9e..52a254e 100644
--- a/lib/RT/Extension/SLA/Report.pm
+++ b/lib/RT/Extension/SLA/Report.pm
@@ -24,12 +24,14 @@ sub Handlers {
Set => {
Owner => 'OnOwnerChange',
},
- Correpond => 'OnResponse',
+ Correspond => 'OnResponse',
CustomField => { map $_ => 'OnServiceLevelChange', $self->ServiceLevelCustomFields },
+ AddWatcher => { Requestor => 'OnRequestorChange' },
+ DelWatcher => { Requestor => 'OnRequestorChange' },
};
return $cache;
-}
+} }
sub Drive {
my $self = shift;
@@ -55,29 +57,157 @@ sub Drive {
}
}
+sub OnCreate {
+ my $self = shift;
+ my %args = ( Ticket => undef, Transaction => undef, State => undef, @_);
+
+ my $level = $self->InitialServiceLevel( $args{'Ticket'} );
+
+ my $state = $args{'State'};
+ %$state = ();
+ $state->{'level'} = $level;
+ $state->{'transaction'} = $args{'Transaction'};
+ $state->{'requestors'} = [ $self->InitialRequestors( $args{'Ticket'} ) ];
+ $state->{'owner'} = $self->InitialOwner( $args{'Ticket'} );
+ return;
+}
+
+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 OnResponse {
+ my $self = shift;
+ my $self
+}
+
+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 1;
+}
+
sub InitialServiceLevel {
my $self = shift;
my $ticket = shift;
+ return $self->InitialValue(
+ Ticket => $ticket,
+ Current => $ticket->FirstCustomFieldValue('SLA'),
+ Criteria => { CustomField => [ map $_->id, $self->ServiceLevelCustomFields ] },
+ );
+}
+
+sub InitialRequestors {
+ my $self = shift;
+ my $ticket = shift;
+
+ my @current = map $_->Member, @{ $ticket->Requestors->MembersObj->ItemsArrayRef };
+
+ my $txns = $self->Transactions(
+ Ticket => $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 $ticket = shift;
+
+ return $self->InitialValue(
+ %args,
+ Current => $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 = $ticket->Transactions;
- foreach my $cf ( $self->ServiceLevelCustomFields ) {
- $txns->_OpenParen('ServiceLevelCustomFields');
+
+ my $clause = 'ByTypeAndField';
+ while ( my ($type, $field) = each %{ $args{'Criteria'} } ) {
+ $txns->_OpenParen( $clause );
$txns->Limit(
- SUBCLAUSE => 'ServiceLevelCustomFields',
ENTRYAGGREGATOR => 'OR',
+ SUBCLAUSE => $clause,
FIELD => 'Type',
- VALUE => 'CustomField',
- );
- $txns->Limit(
- SUBCLAUSE => 'ServiceLevelCustomFields',
- ENTRYAGGREGATOR => 'AND',
- FIELD => 'Field',
- VALUE => $cf->id,
+ VALUE => $type,
);
- $txns->_CloseParen('ServiceLevelCustomFields');
+ 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 $self;
+ return $txns;
}
{ my @cache = ();
commit c0d57bce9d3781619c5bb6b2cddb6b34a74c1df3
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Sat May 2 22:49:34 2009 +0000
another round, close to something testable
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 919365e..43c17a4 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -14,6 +14,14 @@ 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
@@ -45,7 +53,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:
- %RT::ServiceAgreements = (
+ Set( %ServiceAgreements,
Default => '4h',
QueueDefault => {
'Incident' => '2h',
@@ -248,7 +256,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:
- %RT::ServiceBusinessHours = (
+ Set( %ServiceBusinessHours,
'Default' => {
... description ...
},
@@ -274,7 +282,7 @@ hours.
then %RT::ServiceBusinessHours should have the corresponding definition:
- %RT::ServiceBusinessHours = (
+ Set( %ServiceBusinessHours,
'work just in Monday' => {
1 => { Name => 'Monday', Start => '9:00', End => '18:00' },
},
@@ -286,14 +294,14 @@ Default Business Hours setting is in $RT::ServiceBusinessHours{'Default'}.
In the config you can set per queue defaults, using:
- %RT::ServiceAgreements = (
+ Set( %ServiceAgreements,
Default => 'global default level of service',
QueueDefault => {
'queue name' => 'default value for this queue',
...
},
...
- };
+ );
=head2 Access control
@@ -427,6 +435,12 @@ sub GetDefaultServiceLevel {
return $RT::ServiceAgreements{'Default'};
}
+sub ReportOnTicket {
+ my $self = shift;
+ my $id = shift;
+
+}
+
=head1 TODO
* [implemented, TODO: tests for options in the config] default SLA for queues
diff --git a/lib/RT/Extension/SLA/Report.pm b/lib/RT/Extension/SLA/Report.pm
index 52a254e..65ee23d 100644
--- a/lib/RT/Extension/SLA/Report.pm
+++ b/lib/RT/Extension/SLA/Report.pm
@@ -4,13 +4,29 @@ use warnings;
package RT::Extension::SLA::Report;
-sub new {}
+sub new {
+ my $proto = shift;
+ my $self = bless {}, ref($proto)||$proto;
+ return $self->init( @_ );
+}
-sub init {}
+sub init {
+ my $self = shift;
+ my %args = (Ticket => undef, @_);
+ $self->{'Ticket'} = $args{'Ticket'} || die "boo";
+ $self->{'State'} = {};
+ $self->{'Stats'} = [];
+ return $self;
+}
sub State {
my $self = shift;
- return $self->{State} ||= {};
+ return $self->{State};
+}
+
+sub Stats {
+ my $self = shift;
+ return $self->{Stats};
}
{ my $cache;
@@ -33,9 +49,9 @@ sub Handlers {
return $cache;
} }
-sub Drive {
+sub Run {
my $self = shift;
- my $txns = shift;
+ my $txns = shift || $self->{'Ticket'}->Transactions;
my $state = $self->State;
my $handler = $self->Handlers;
@@ -53,20 +69,18 @@ sub Drive {
}
next unless $h;
- $self->$h( Transaction => $txn, State => $state );
+ $self->$h( Ticket => $self->{'Ticket'}, Transaction => $txn, State => $state );
}
+ return $self;
}
sub OnCreate {
my $self = shift;
my %args = ( Ticket => undef, Transaction => undef, State => undef, @_);
- my $level = $self->InitialServiceLevel( $args{'Ticket'} );
-
my $state = $args{'State'};
%$state = ();
- $state->{'level'} = $level;
- $state->{'transaction'} = $args{'Transaction'};
+ $state->{'level'} = $self->InitialServiceLevel( $args{'Ticket'} );
$state->{'requestors'} = [ $self->InitialRequestors( $args{'Ticket'} ) ];
$state->{'owner'} = $self->InitialOwner( $args{'Ticket'} );
return;
@@ -88,7 +102,76 @@ sub OnRequestorChange {
sub OnResponse {
my $self = shift;
- my $self
+ 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 ) {
+ die "not yet implemented";
+ }
+ 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,
+ 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'}->{'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 => 'KeepInLoop',
+ owner => $args{'State'}->{'owner'},
+ failed => $failed,
+ owner_act => $owner,
+ shift => $txn->CreatedObj->Unix - $deadline,
+ };
+ push @{ $self->Stats }, $stat;
+ }
+ }
}
sub IsRequestorsAct {
@@ -107,7 +190,7 @@ sub IsRequestorsAct {
$cgm->LoadByCols( GroupId => $id, MemberId => $actor, Disabled => 0 );
return 1 if $cgm->id;
}
- return 1;
+ return 0;
}
sub InitialServiceLevel {
@@ -147,11 +230,10 @@ sub InitialRequestors {
sub InitialOwner {
my $self = shift;
- my $ticket = shift;
-
+ my %args = (Ticket => undef, @_);
return $self->InitialValue(
%args,
- Current => $ticket->Owner,
+ Current => $args{'Ticket'}->Owner,
Criteria => { 'Set', 'Owner' },
);
}
@@ -174,7 +256,7 @@ sub Transactions {
my $self = shift;
my %args = (Ticket => undef, Criteria => undef, Order => 'ASC', @_);
- my $txns = $ticket->Transactions;
+ my $txns = $args{'Ticket'}->Transactions;
my $clause = 'ByTypeAndField';
while ( my ($type, $field) = each %{ $args{'Criteria'} } ) {
diff --git a/t/basics.t b/t/basics.t
index 8d73e46..998b596 100644
--- a/t/basics.t
+++ b/t/basics.t
@@ -3,9 +3,10 @@
use strict;
use warnings;
-use Test::More tests => 1;
+use Test::More tests => 2;
use_ok 'RT::Extension::SLA';
+use_ok 'RT::Extension::SLA::Report';
1;
commit d874bd1556eac95704f92947c29c265ca3967789
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon May 4 19:13:52 2009 +0000
update TODO with some ideas
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 43c17a4..000c562 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -441,7 +441,20 @@ sub ReportOnTicket {
}
-=head1 TODO
+=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
* [implemented, TODO: tests for options in the config] default SLA for queues
@@ -451,8 +464,6 @@ sub ReportOnTicket {
something else). So people would be able to handle tickets in the right
order using Due dates.
- * [not implemented] WebUI
-
=head1 DESIGN
=head2 Classes
commit 7f35d89ce6853160eaf0ed44c83b8a6b3ca53eb6
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Mon May 4 22:32:51 2009 +0000
more changes here and there regarding reporting
* new Summary.pm to help combine multiple reports
together
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 000c562..49667d8 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -435,10 +435,12 @@ sub GetDefaultServiceLevel {
return $RT::ServiceAgreements{'Default'};
}
-sub ReportOnTicket {
+sub Report {
my $self = shift;
- my $id = shift;
+ my $ticket = shift;
+ require RT::Extension::SLA::Report;
+ return RT::Extension::SLA::Report->new( Ticket => $ticket )->Run;
}
=head1 TODO and CAVEATS
diff --git a/lib/RT/Extension/SLA/Report.pm b/lib/RT/Extension/SLA/Report.pm
index 65ee23d..dbb10ff 100644
--- a/lib/RT/Extension/SLA/Report.pm
+++ b/lib/RT/Extension/SLA/Report.pm
@@ -19,6 +19,31 @@ sub init {
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;
+
+ $self->$h( Ticket => $self->{'Ticket'}, Transaction => $txn, State => $state );
+ }
+ return $self;
+}
+
sub State {
my $self = shift;
return $self->{State};
@@ -41,49 +66,27 @@ sub Handlers {
Owner => 'OnOwnerChange',
},
Correspond => 'OnResponse',
- CustomField => { map $_ => 'OnServiceLevelChange', $self->ServiceLevelCustomFields },
+ CustomField => { map { $_->id => 'OnServiceLevelChange' } $self->ServiceLevelCustomFields },
AddWatcher => { Requestor => 'OnRequestorChange' },
DelWatcher => { Requestor => 'OnRequestorChange' },
};
+ use Data::Dumper;
+ Test::More::diag( Dumper $cache );
+
return $cache;
} }
-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;
-
- $self->$h( Ticket => $self->{'Ticket'}, Transaction => $txn, State => $state );
- }
- return $self;
-}
-
sub OnCreate {
my $self = shift;
my %args = ( Ticket => undef, Transaction => undef, State => undef, @_);
my $state = $args{'State'};
%$state = ();
- $state->{'level'} = $self->InitialServiceLevel( $args{'Ticket'} );
- $state->{'requestors'} = [ $self->InitialRequestors( $args{'Ticket'} ) ];
- $state->{'owner'} = $self->InitialOwner( $args{'Ticket'} );
- return;
+ $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 {
@@ -100,15 +103,21 @@ sub OnRequestorChange {
}
}
+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;
- }
+# unless ( $args{'State'}->{'level'} ) {
+# $RT::Logger->debug('No service level -> ignore txn #'. $txn->id );
+# return;
+# }
my $act = $args{'State'}->{'act'};
if ( $self->IsRequestorsAct( $txn ) ) {
@@ -143,6 +152,7 @@ sub OnResponse {
owner => $args{'State'}->{'owner'},
failed => $failed,
owner_act => $owner,
+ actor => $txn->Creator,
shift => $txn->CreatedObj->Unix - $deadline,
};
push @{ $self->Stats }, $stat;
@@ -152,22 +162,25 @@ sub OnResponse {
my $deadline = RT::Extension::SLA->Due(
Type => 'Response',
Level => $args{'State'}->{'level'},
- Time => $args{'State'}->{'acted'},
+ Time => $args{'State'}->{'act'}->{'acted'},
);
unless ( defined $deadline ) {
$RT::Logger->debug( "Non-requestors' reply after requestors', without response deadline");
return;
}
+ Test::More::diag( 'deadline '. $deadline .' '. Dumper( $args{'State'} ) );
+
# repsonse
my $failed = $txn->CreatedObj->Unix > $deadline? 1 : 0;
my $owner = $args{'State'}->{'owner'} == $txn->Creator? 1 : 0;
my $stat = {
- type => 'KeepInLoop',
+ type => 'Response',
owner => $args{'State'}->{'owner'},
failed => $failed,
owner_act => $owner,
- shift => $txn->CreatedObj->Unix - $deadline,
+ actor => $txn->Creator,
+ shift => ($txn->CreatedObj->Unix - $deadline),
};
push @{ $self->Stats }, $stat;
}
@@ -195,23 +208,23 @@ sub IsRequestorsAct {
sub InitialServiceLevel {
my $self = shift;
- my $ticket = shift;
+ my %args = @_;
return $self->InitialValue(
- Ticket => $ticket,
- Current => $ticket->FirstCustomFieldValue('SLA'),
+ Ticket => $args{'Ticket'},
+ Current => $args{'Ticket'}->FirstCustomFieldValue('SLA'),
Criteria => { CustomField => [ map $_->id, $self->ServiceLevelCustomFields ] },
);
}
sub InitialRequestors {
my $self = shift;
- my $ticket = shift;
+ my %args = @_;
- my @current = map $_->Member, @{ $ticket->Requestors->MembersObj->ItemsArrayRef };
+ my @current = map $_->MemberId, @{ $args{'Ticket'}->Requestors->MembersObj->ItemsArrayRef };
my $txns = $self->Transactions(
- Ticket => $ticket,
+ Ticket => $args{'Ticket'},
Order => 'DESC',
Criteria => { 'AddWatcher' => 'Requestor', DelWatcher => 'Requestor' },
);
@@ -302,9 +315,7 @@ sub ServiceLevelCustomFields {
$cfs->Limit( FIELD => 'LookupType', VALUE => RT::Ticket->CustomFieldLookupType );
# XXX: limit to applied custom fields only
- push @cache, $_ while $_ = $cfs->Next;
-
- return @cache;
+ return @cache = @{ $cfs->ItemsArrayRef };
} }
1;
diff --git a/lib/RT/Extension/SLA/Summary.pm b/lib/RT/Extension/SLA/Summary.pm
new file mode 100644
index 0000000..b59ba9d
--- /dev/null
+++ b/lib/RT/Extension/SLA/Summary.pm
@@ -0,0 +1,68 @@
+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'} ||= { };
+}
+
+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;
commit d86f44b77c2c8c9e416dd4e4653d6f98beb10daa
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue May 5 01:11:11 2009 +0000
add first html, more simple tests and changes Summary
diff --git a/META.yml b/META.yml
index c96930b..89aa5fb 100644
--- a/META.yml
+++ b/META.yml
@@ -17,6 +17,7 @@ name: RT-Extension-SLA
no_index:
directory:
- etc
+ - html
- inc
- t
requires:
diff --git a/html/Callbacks/RT-Extension-SLA/Tools/Reports/Elements/Tabs/Default b/html/Callbacks/RT-Extension-SLA/Tools/Reports/Elements/Tabs/Default
new file mode 100644
index 0000000..73c310b
--- /dev/null
+++ b/html/Callbacks/RT-Extension-SLA/Tools/Reports/Elements/Tabs/Default
@@ -0,0 +1,9 @@
+<%ARGS>
+$tabs => {}
+</%ARGS>
+<%INIT>
+$tabs->{'s'} = {
+ title => loc('Service Level Aggreements'),
+ path => 'Tools/Reports/SLA.html',
+};
+</%INIT>
diff --git a/html/Tools/Reports/SLA.html b/html/Tools/Reports/SLA.html
new file mode 100644
index 0000000..1cdeb03
--- /dev/null
+++ b/html/Tools/Reports/SLA.html
@@ -0,0 +1,43 @@
+<& /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 ) {
+ <tr><td><% $owner %><td>
+% my $i = 1;
+% foreach ( map $stats->{ $_ }, grep $i++%2, @columns ) {
+<td><% $_ || 0 %></td>
+% }
+ </tr>
+% }
+</table>
+
+<%ARGS>
+$Query => undef
+</%ARGS>
+<%INIT>
+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 => $ticket );
+ $summary->AddReport( $report );
+}
+
+my $result = $summary->Result;
+
+</%INIT>
diff --git a/lib/RT/Extension/SLA/Summary.pm b/lib/RT/Extension/SLA/Summary.pm
index b59ba9d..a0dc52f 100644
--- a/lib/RT/Extension/SLA/Summary.pm
+++ b/lib/RT/Extension/SLA/Summary.pm
@@ -20,6 +20,18 @@ 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;
diff --git a/t/basics.t b/t/basics.t
index 998b596..08d6b46 100644
--- a/t/basics.t
+++ b/t/basics.t
@@ -3,10 +3,11 @@
use strict;
use warnings;
-use Test::More tests => 2;
+use Test::More tests => 3;
use_ok 'RT::Extension::SLA';
use_ok 'RT::Extension::SLA::Report';
+use_ok 'RT::Extension::SLA::Summary';
1;
commit 3b1e96bc8f52616b304068415846650952ab01c1
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue May 5 01:50:43 2009 +0000
cleanup debug code
* fix some bugs
diff --git a/html/Tools/Reports/SLA.html b/html/Tools/Reports/SLA.html
index 1cdeb03..df07885 100644
--- a/html/Tools/Reports/SLA.html
+++ b/html/Tools/Reports/SLA.html
@@ -12,12 +12,13 @@
</tr>
% while ( my ($owner, $stats) = each %$result ) {
- <tr><td><% $owner %><td>
+<tr>
+<td><% $owner %></td>
% my $i = 1;
% foreach ( map $stats->{ $_ }, grep $i++%2, @columns ) {
<td><% $_ || 0 %></td>
% }
- </tr>
+</tr>
% }
</table>
@@ -34,10 +35,9 @@ 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 => $ticket );
+ my $report = RT::Extension::SLA->Report( $ticket );
$summary->AddReport( $report );
}
my $result = $summary->Result;
-
</%INIT>
diff --git a/lib/RT/Extension/SLA/Report.pm b/lib/RT/Extension/SLA/Report.pm
index dbb10ff..9d0d8c2 100644
--- a/lib/RT/Extension/SLA/Report.pm
+++ b/lib/RT/Extension/SLA/Report.pm
@@ -39,6 +39,8 @@ sub Run {
}
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;
@@ -71,9 +73,6 @@ sub Handlers {
DelWatcher => { Requestor => 'OnRequestorChange' },
};
- use Data::Dumper;
- Test::More::diag( Dumper $cache );
-
return $cache;
} }
@@ -131,7 +130,10 @@ sub OnResponse {
$act->{'acted'} = $txn->CreatedObj->Unix;
} else {
unless ( $act ) {
- die "not yet implemented";
+ $act = $args{'State'}->{'act'} = {};
+ $act->{'requestor'} = 0;
+ $act->{'acted'} = $txn->CreatedObj->Unix;
+ return;
}
unless ( $act->{'requestor'} ) {
# check keep in loop
@@ -169,8 +171,6 @@ sub OnResponse {
return;
}
- Test::More::diag( 'deadline '. $deadline .' '. Dumper( $args{'State'} ) );
-
# repsonse
my $failed = $txn->CreatedObj->Unix > $deadline? 1 : 0;
my $owner = $args{'State'}->{'owner'} == $txn->Creator? 1 : 0;
commit 2d90ba67ebca90387200299ea2f1f65d78c5bad7
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue May 5 14:46:40 2009 +0000
show user using a component
* show some simple form
diff --git a/html/Tools/Reports/SLA.html b/html/Tools/Reports/SLA.html
index df07885..d50bbc8 100644
--- a/html/Tools/Reports/SLA.html
+++ b/html/Tools/Reports/SLA.html
@@ -12,8 +12,10 @@
</tr>
% while ( my ($owner, $stats) = each %$result ) {
+% my $user = RT::User->new( $session{'CurrentUser'} );
+% $user->Load( $owner );
<tr>
-<td><% $owner %></td>
+<td><& /Elements/ShowUser, User => $user &></td>
% my $i = 1;
% foreach ( map $stats->{ $_ }, grep $i++%2, @columns ) {
<td><% $_ || 0 %></td>
@@ -22,6 +24,11 @@
% }
</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>
commit 1c7053699a4d8cc9f8098e4b2e7cb34a3aaeea66
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue May 5 15:36:23 2009 +0000
new test file, basics of reporting
diff --git a/t/reporting/basic.t b/t/reporting/basic.t
new file mode 100644
index 0000000..55befef
--- /dev/null
+++ b/t/reporting/basic.t
@@ -0,0 +1,114 @@
+#!/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 b5df3d71e1f28eb4ec7cf251706483a7cf69d280
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Tue May 5 15:37:19 2009 +0000
bump dev. version, update manifest and meta
diff --git a/MANIFEST b/MANIFEST
index 22c271a..c76a77e 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,5 +1,7 @@
Changes
etc/initialdata
+html/Callbacks/RT-Extension-SLA/Tools/Reports/Elements/Tabs/Default
+html/Tools/Reports/SLA.html
inc/Module/AutoInstall.pm
inc/Module/Install.pm
inc/Module/Install/AutoInstall.pm
@@ -23,6 +25,8 @@ 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
@@ -31,5 +35,6 @@ 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 89aa5fb..4c8edd2 100644
--- a/META.yml
+++ b/META.yml
@@ -25,4 +25,4 @@ requires:
perl: 5.8.0
resources:
license: http://opensource.org/licenses/gpl-2.0.php
-version: 0.03
+version: 0.03_01
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 49667d8..ba8b899 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.03_01';
=head1 NAME
commit c837fc5598e49a97b4bb3950a86df546e342ddb0
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed May 13 21:56:44 2009 +0000
update M::I
diff --git a/inc/Module/AutoInstall.pm b/inc/Module/AutoInstall.pm
index 739bc85..38c98f5 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 );
@@ -187,6 +197,7 @@ sub import {
and (
$CheckOnly
or ($mandatory and $UnderCPAN)
+ or $AllDeps
or _prompt(
qq{==> Auto-install the }
. ( @required / 2 )
@@ -235,21 +246,35 @@ sub import {
*{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
}
+sub _running_under {
+ my $thing = shift;
+ print <<"END_MESSAGE";
+*** Since we're running under ${thing}, I'll just let it take care
+ of the dependency's installation later.
+END_MESSAGE
+ return 1;
+}
+
# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
# if we are, then we simply let it taking care of our dependencies
sub _check_lock {
return unless @Missing or @_;
+ my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING};
+
if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
- print <<'END_MESSAGE';
+ return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS');
+ }
-*** Since we're running under CPANPLUS, I'll just let it take care
- of the dependency's installation later.
-END_MESSAGE
- return 1;
+ require CPAN;
+
+ if ($CPAN::VERSION > '1.89' && $cpan_env) {
+ return _running_under('CPAN');
}
- _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" );
@@ -633,7 +658,7 @@ sub _load {
# Load CPAN.pm and it's configuration
sub _load_cpan {
- return if $CPAN::VERSION;
+ return if $CPAN::VERSION and not @_;
require CPAN;
if ( $CPAN::HandleConfig::VERSION ) {
# Newer versions of CPAN have a HandleConfig module
@@ -766,4 +791,4 @@ END_MAKE
__END__
-#line 1004
+#line 1045
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index 5b9ddbf..fadb682 100644
--- a/inc/Module/Install.pm
+++ b/inc/Module/Install.pm
@@ -28,7 +28,7 @@ BEGIN {
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '0.85';
+ $VERSION = '0.87';
# Storage for the pseudo-singleton
$MAIN = undef;
diff --git a/inc/Module/Install/AutoInstall.pm b/inc/Module/Install/AutoInstall.pm
index b7e92a5..562bd0a 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.85';
+ $VERSION = '0.87';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index ac416c9..211585a 100644
--- a/inc/Module/Install/Base.pm
+++ b/inc/Module/Install/Base.pm
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.85';
+ $VERSION = '0.87';
}
# Suspend handler for "redefined" warnings
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index 3e2d523..ef98ee4 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.85';
+ $VERSION = '0.87';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index 0a62208..763732d 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.85';
+ $VERSION = '0.87';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
index 92aad58..406da54 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.85';
+ $VERSION = '0.87';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index 2b80f0f..b1854f6 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.85';
+ $VERSION = '0.87';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index ca16db7..6852f9a 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.85';
+ $VERSION = '0.87';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
index c00da94..5d11a43 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.85';
+ $VERSION = '0.87';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index df3900a..a73f351 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.85';
+ $VERSION = '0.87';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
commit d2ff490e43f5e8e22b046c44ebb358f4f3aa3b52
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed May 13 21:58:49 2009 +0000
add protection by a right
diff --git a/META.yml b/META.yml
index 4c8edd2..a510d6f 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 0.87'
license: gpl2
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
diff --git a/html/Callbacks/RT-Extension-SLA/Tools/Reports/Elements/Tabs/Default b/html/Callbacks/RT-Extension-SLA/Tools/Reports/Elements/Tabs/Default
index 73c310b..d1f352c 100644
--- a/html/Callbacks/RT-Extension-SLA/Tools/Reports/Elements/Tabs/Default
+++ b/html/Callbacks/RT-Extension-SLA/Tools/Reports/Elements/Tabs/Default
@@ -2,6 +2,9 @@
$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',
diff --git a/html/Tools/Reports/SLA.html b/html/Tools/Reports/SLA.html
index d50bbc8..ee2f6ae 100644
--- a/html/Tools/Reports/SLA.html
+++ b/html/Tools/Reports/SLA.html
@@ -33,6 +33,14 @@
$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;
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index ba8b899..0937f50 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -316,6 +316,14 @@ 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';
commit 9d6dfd0c4592ce33d37dd6709190160f26bca682
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Wed May 13 22:00:18 2009 +0000
add tabs to tickets so you can jump to a report right after search
diff --git a/html/Callbacks/RT-Extension-SLA/Ticket/Elements/Tabs/Default b/html/Callbacks/RT-Extension-SLA/Ticket/Elements/Tabs/Default
new file mode 100644
index 0000000..d8bbb01
--- /dev/null
+++ b/html/Callbacks/RT-Extension-SLA/Ticket/Elements/Tabs/Default
@@ -0,0 +1,15 @@
+<%ARGS>
+$Query => undef
+$tabs => {}
+</%ARGS>
+<%INIT>
+
+$Query ||= $session{'CurrentSearchHash'}->{'Query'};
+
+return unless $Query;
+
+$tabs->{"m"} = {
+ path => "Tools/Reports/SLA.html?". $m->comp( '/Elements/QueryString', Query => $Query ),
+ title => loc('Report SLA'),
+};
+</%INIT>
commit b8ba4c57d7f7fc129dd587a6212240b9d1bff55c
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu May 14 14:27:44 2009 +0000
add report per ticket for debugging and analysis
diff --git a/html/Callbacks/RT-Extension-SLA/Ticket/Elements/Tabs/Default b/html/Callbacks/RT-Extension-SLA/Ticket/Elements/Tabs/Default
index d8bbb01..76253a0 100644
--- a/html/Callbacks/RT-Extension-SLA/Ticket/Elements/Tabs/Default
+++ b/html/Callbacks/RT-Extension-SLA/Ticket/Elements/Tabs/Default
@@ -1,15 +1,24 @@
<%ARGS>
$Query => undef
$tabs => {}
+$Ticket => undef
</%ARGS>
<%INIT>
-$Query ||= $session{'CurrentSearchHash'}->{'Query'};
+return unless $session{'CurrentUser'}->PrincipalObj->HasRight(
+ Object => $RT::System, Right => 'SeeSLAReports',
+);
-return unless $Query;
-
-$tabs->{"m"} = {
- path => "Tools/Reports/SLA.html?". $m->comp( '/Elements/QueryString', Query => $Query ),
- title => loc('Report SLA'),
-};
+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/Ticket/SLA.html b/html/Ticket/SLA.html
new file mode 100644
index 0000000..0cde6da
--- /dev/null
+++ b/html/Ticket/SLA.html
@@ -0,0 +1,46 @@
+<& /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>
commit 6b9c3dcbbb257be37af5d13c6efd086c417b26c9
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu May 14 14:29:08 2009 +0000
store txn in the stats
diff --git a/lib/RT/Extension/SLA/Report.pm b/lib/RT/Extension/SLA/Report.pm
index 9d0d8c2..94290cd 100644
--- a/lib/RT/Extension/SLA/Report.pm
+++ b/lib/RT/Extension/SLA/Report.pm
@@ -150,12 +150,13 @@ sub OnResponse {
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,
- actor => $txn->Creator,
- shift => $txn->CreatedObj->Unix - $deadline,
+ 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;
}
@@ -175,12 +176,13 @@ sub OnResponse {
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,
- actor => $txn->Creator,
- shift => ($txn->CreatedObj->Unix - $deadline),
+ 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;
}
commit f923d0958349d01555fd7261aef2bc72151335df
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu May 14 15:07:41 2009 +0000
update manifest
diff --git a/MANIFEST b/MANIFEST
index c76a77e..ad65521 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,6 +1,8 @@
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
commit beeb2300776b29ce2927edbb58c5e92a6455315d
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu May 14 15:08:02 2009 +0000
update M::I
diff --git a/META.yml b/META.yml
index a510d6f..0317c5a 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.87'
+generated_by: 'Module::Install version 0.88'
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 38c98f5..807fa7b 100644
--- a/inc/Module/AutoInstall.pm
+++ b/inc/Module/AutoInstall.pm
@@ -175,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;
}
}
@@ -268,8 +277,11 @@ sub _check_lock {
require CPAN;
- if ($CPAN::VERSION > '1.89' && $cpan_env) {
- return _running_under('CPAN');
+ if ($CPAN::VERSION > '1.89') {
+ if ($cpan_env) {
+ return _running_under('CPAN');
+ }
+ return; # CPAN.pm new enough, don't need to check further
}
# last ditch attempt, this -will- configure CPAN, very sorry
@@ -310,7 +322,7 @@ sub install {
while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
# grep out those already installed
- if ( defined( _version_check( _load($pkg), $ver ) ) ) {
+ if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
else {
@@ -349,7 +361,7 @@ sub install {
# see if we have successfully installed them
while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
- if ( defined( _version_check( _load($pkg), $ver ) ) ) {
+ if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
push @installed, $pkg;
}
elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
@@ -404,7 +416,7 @@ sub _install_cpanplus {
my $success;
my $obj = $modtree->{$pkg};
- if ( $obj and defined( _version_check( $obj->{version}, $ver ) ) ) {
+ if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) {
my $pathname = $pkg;
$pathname =~ s/::/\\W/;
@@ -497,7 +509,7 @@ sub _install_cpan {
my $obj = CPAN::Shell->expand( Module => $pkg );
my $success = 0;
- if ( $obj and defined( _version_check( $obj->cpan_version, $ver ) ) ) {
+ if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) {
my $pathname = $pkg;
$pathname =~ s/::/\\W/;
@@ -561,7 +573,7 @@ sub _update_to {
my $ver = shift;
return
- if defined( _version_check( _load($class), $ver ) ); # no need to upgrade
+ if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade
if (
_prompt( "==> A newer version of $class ($ver) is required. Install?",
@@ -670,9 +682,11 @@ sub _load_cpan {
}
# compare two versions, either use Sort::Versions or plain comparison
-sub _version_check {
+# return values same as <=>
+sub _version_cmp {
my ( $cur, $min ) = @_;
- return unless defined $cur;
+ return -1 unless defined $cur; # if 0 keep comparing
+ return 1 unless $min;
$cur =~ s/\s+$//;
@@ -683,16 +697,13 @@ sub _version_check {
) {
# use version.pm if it is installed.
- return (
- ( version->new($cur) >= version->new($min) ) ? $cur : undef );
+ return version->new($cur) <=> version->new($min);
}
elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) )
{
# use Sort::Versions as the sorting algorithm for a.b.c versions
- return ( ( Sort::Versions::versioncmp( $cur, $min ) != -1 )
- ? $cur
- : undef );
+ return Sort::Versions::versioncmp( $cur, $min );
}
warn "Cannot reliably compare non-decimal formatted versions.\n"
@@ -701,7 +712,7 @@ sub _version_check {
# plain comparison
local $^W = 0; # shuts off 'not numeric' bugs
- return ( $cur >= $min ? $cur : undef );
+ return $cur <=> $min;
}
# nothing; this usage is deprecated.
@@ -791,4 +802,4 @@ END_MAKE
__END__
-#line 1045
+#line 1056
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
index fadb682..d39e460 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.87';
+ $VERSION = '0.88';
# 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 562bd0a..32f1423 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.87';
+ $VERSION = '0.88';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
index 211585a..c08b3f0 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.87';
+ $VERSION = '0.88';
}
# Suspend handler for "redefined" warnings
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
index ef98ee4..fd64344 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.87';
+ $VERSION = '0.88';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
index 763732d..e0acf6b 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.87';
+ $VERSION = '0.88';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Include.pm b/inc/Module/Install/Include.pm
index 406da54..6324bd5 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.87';
+ $VERSION = '0.88';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
index b1854f6..3d10124 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.87';
+ $VERSION = '0.88';
$ISCORE = 1;
@ISA = qw{Module::Install::Base};
}
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
index 6852f9a..6fd221f 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.87';
+ $VERSION = '0.88';
@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 5d11a43..d91b287 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.87';
+ $VERSION = '0.88';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
index a73f351..e82f5d3 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.87';
+ $VERSION = '0.88';
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
commit 7dae2f6b4ab5a7286aa617b91b1596b6c74d03c4
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu May 14 15:09:25 2009 +0000
bump version
diff --git a/META.yml b/META.yml
index 0317c5a..a894f6d 100644
--- a/META.yml
+++ b/META.yml
@@ -25,4 +25,4 @@ requires:
perl: 5.8.0
resources:
license: http://opensource.org/licenses/gpl-2.0.php
-version: 0.03_01
+version: 0.03_02
diff --git a/lib/RT/Extension/SLA.pm b/lib/RT/Extension/SLA.pm
index 0937f50..a6bcbab 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_01';
+our $VERSION = '0.03_02';
=head1 NAME
commit e2bd1d9ed9d626d8c7f2c9635ca7aa0a504a06e4
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 a6bcbab..e909e27 100644
--- a/lib/RT/Extension/SLA.pm
+++ b/lib/RT/Extension/SLA.pm
@@ -479,16 +479,16 @@ sub Report {
=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
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list