[Bps-public-commit] rt-extension-assets-applegsx branch, master, created. d689191391e57883966fb189e08ffc2fc47c0c53
Alex Vandiver
alexmv at bestpractical.com
Mon Sep 30 14:47:52 EDT 2013
The branch, master has been created
at d689191391e57883966fb189e08ffc2fc47c0c53 (commit)
- Log -----------------------------------------------------------------
commit 03c4c58208773b6e26ce2ad965bdf0b71a195fc1
Author: sunnavy <sunnavy at bestpractical.com>
Date: Tue Oct 9 08:39:33 2012 +0800
initial import
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..2597782
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,13 @@
+blib*
+Makefile
+Makefile.old
+pm_to_blib*
+*.tar.gz
+.lwpcookies
+cover_db
+pod2htm*.tmp
+/RT-Extension-Assets-AppleGSX*
+README
+*.bak
+*.swp
+/MYMETA.*
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..30d8610
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,22 @@
+---
+abstract: 'RT Extension-Assets-AppleGSX Extension'
+author:
+ - 'sunnavy <sunnavy at bestpractical.com>'
+build_requires:
+ ExtUtils::MakeMaker: 6.36
+configure_requires:
+ ExtUtils::MakeMaker: 6.36
+distribution_type: module
+dynamic_config: 1
+generated_by: 'Module::Install version 1.06'
+license: gplv2
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: RT-Extension-Assets-AppleGSX
+no_index:
+ directory:
+ - inc
+resources:
+ license: http://opensource.org/licenses/gpl-license.php
+version: 0.01
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..8d8bf52
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,10 @@
+use inc::Module::Install;
+
+
+RTx 'RT-Extension-Assets-AppleGSX';
+all_from 'lib/RT/Extension/Assets/AppleGSX.pm';
+readme_from 'lib/RT/Extension/Assets/AppleGSX.pm';
+license 'gplv2';
+
+sign;
+WriteAll;
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
new file mode 100644
index 0000000..4ecf46b
--- /dev/null
+++ b/inc/Module/Install.pm
@@ -0,0 +1,470 @@
+#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.005;
+use strict 'vars';
+use Cwd ();
+use File::Find ();
+use File::Path ();
+
+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
+ # 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 = '1.06';
+
+ # Storage for the pseudo-singleton
+ $MAIN = undef;
+
+ *inc::Module::Install::VERSION = *VERSION;
+ @inc::Module::Install::ISA = __PACKAGE__;
+
+}
+
+sub import {
+ my $class = shift;
+ my $self = $class->new(@_);
+ my $who = $self->_caller;
+
+ #-------------------------------------------------------------
+ # all of the following checks should be included in import(),
+ # to allow "eval 'require Module::Install; 1' to test
+ # installation of Module::Install. (RT #51267)
+ #-------------------------------------------------------------
+
+ # Whether or not inc::Module::Install is actually loaded, the
+ # $INC{inc/Module/Install.pm} is what will still get set as long as
+ # the caller loaded module this in the documented manner.
+ # If not set, the caller may NOT have loaded the bundled version, and thus
+ # they may not have a MI version that works with the Makefile.PL. This would
+ # result in false errors or unexpected behaviour. And we don't want that.
+ my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
+ unless ( $INC{$file} ) { die <<"END_DIE" }
+
+Please invoke ${\__PACKAGE__} with:
+
+ use inc::${\__PACKAGE__};
+
+not:
+
+ use ${\__PACKAGE__};
+
+END_DIE
+
+ # This reportedly fixes a rare Win32 UTC file time issue, but
+ # as this is a non-cross-platform XS module not in the core,
+ # we shouldn't really depend on it. See RT #24194 for detail.
+ # (Also, this module only supports Perl 5.6 and above).
+ eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
+
+ # If the script that is loading Module::Install is from the future,
+ # then make will detect this and cause it to re-run over and over
+ # again. This is bad. Rather than taking action to touch it (which
+ # is unreliable on some platforms and requires write permissions)
+ # for now we should catch this and refuse to run.
+ if ( -f $0 ) {
+ my $s = (stat($0))[9];
+
+ # If the modification time is only slightly in the future,
+ # sleep briefly to remove the problem.
+ my $a = $s - time;
+ if ( $a > 0 and $a < 5 ) { sleep 5 }
+
+ # Too far in the future, throw an error.
+ my $t = time;
+ if ( $s > $t ) { die <<"END_DIE" }
+
+Your installer $0 has a modification time in the future ($s > $t).
+
+This is known to create infinite loops in make.
+
+Please correct this, then run $0 again.
+
+END_DIE
+ }
+
+
+ # Build.PL was formerly supported, but no longer is due to excessive
+ # difficulty in implementing every single feature twice.
+ if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
+
+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));
+
+ #-------------------------------------------------------------
+
+ unless ( -f $self->{file} ) {
+ foreach my $key (keys %INC) {
+ delete $INC{$key} if $key =~ /Module\/Install/;
+ }
+
+ local $^W;
+ require "$self->{path}/$self->{dispatch}.pm";
+ File::Path::mkpath("$self->{prefix}/$self->{author}");
+ $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
+ $self->{admin}->init;
+ @_ = ($class, _self => $self);
+ goto &{"$self->{name}::import"};
+ }
+
+ local $^W;
+ *{"${who}::AUTOLOAD"} = $self->autoload;
+ $self->preload;
+
+ # Unregister loader and worker packages so subdirs can use them again
+ delete $INC{'inc/Module/Install.pm'};
+ delete $INC{'Module/Install.pm'};
+
+ # Save to the singleton
+ $MAIN = $self;
+
+ return 1;
+}
+
+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;
+ }
+ unless ($$sym =~ s/([^:]+)$//) {
+ # XXX: it looks like we can't retrieve the missing function
+ # via $$sym (usually $main::AUTOLOAD) in this case.
+ # I'm still wondering if we should slurp Makefile.PL to
+ # get some context or not ...
+ my ($package, $file, $line) = caller;
+ die <<"EOT";
+Unknown function is found at $file line $line.
+Execution of $file aborted due to runtime errors.
+
+If you're a contributor to a project, you may need to install
+some Module::Install extensions from CPAN (or other repository).
+If you're a user of a module, please contact the author.
+EOT
+ }
+ my $method = $1;
+ if ( uc($method) eq $method ) {
+ # Do nothing
+ 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')};
+ };
+}
+
+sub preload {
+ my $self = shift;
+ unless ( $self->{extensions} ) {
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ );
+ }
+
+ my @exts = @{$self->{extensions}};
+ unless ( @exts ) {
+ @exts = $self->{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 ) {
+ local $^W;
+ *{"${who}::$name"} = sub {
+ ${"${who}::AUTOLOAD"} = "${who}::$name";
+ goto &{"${who}::AUTOLOAD"};
+ };
+ }
+}
+
+sub new {
+ my ($class, %args) = @_;
+
+ delete $INC{'FindBin.pm'};
+ {
+ # to suppress the redefine warning
+ local $SIG{__WARN__} = sub {};
+ require FindBin;
+ }
+
+ # ignore the prefix on extension modules built from top level.
+ my $base_path = Cwd::abs_path($FindBin::Bin);
+ unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
+ delete $args{prefix};
+ }
+ return $args{_self} if $args{_self};
+
+ $args{dispatch} ||= 'Admin';
+ $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 {
+ 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) = @_;
+
+ my $should_reload = 0;
+ unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
+ unshift @INC, $self->{prefix};
+ $should_reload = 1;
+ }
+
+ foreach my $rv ( $self->find_extensions($path) ) {
+ my ($file, $pkg) = @{$rv};
+ next if $self->{pathnames}{$pkg};
+
+ local $@;
+ my $new = eval { local $^W; require $file; $pkg->can('new') };
+ unless ( $new ) {
+ warn $@ if $@;
+ next;
+ }
+ $self->{pathnames}{$pkg} =
+ $should_reload ? delete $INC{$file} : $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) ) {
+ 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;
+}
+
+
+
+
+
+#####################################################################
+# Common Utility Functions
+
+sub _caller {
+ my $depth = 0;
+ my $call = caller($depth);
+ while ( $call eq __PACKAGE__ ) {
+ $depth++;
+ $call = caller($depth);
+ }
+ return $call;
+}
+
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
+sub _read {
+ local *FH;
+ open( FH, '<', $_[0] ) or die "open($_[0]): $!";
+ my $string = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $string;
+}
+END_NEW
+sub _read {
+ local *FH;
+ open( FH, "< $_[0]" ) or die "open($_[0]): $!";
+ my $string = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $string;
+}
+END_OLD
+
+sub _readperl {
+ my $string = Module::Install::_read($_[0]);
+ $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;
+}
+
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
+sub _write {
+ local *FH;
+ open( FH, '>', $_[0] ) or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) {
+ print FH $_[$_] or die "print($_[0]): $!";
+ }
+ close FH or die "close($_[0]): $!";
+}
+END_NEW
+sub _write {
+ local *FH;
+ open( FH, "> $_[0]" ) or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) {
+ print FH $_[$_] or die "print($_[0]): $!";
+ }
+ close FH or die "close($_[0]): $!";
+}
+END_OLD
+
+# _version is for processing module versions (eg, 1.03_05) not
+# Perl versions (eg, 5.8.1).
+sub _version ($) {
+ my $s = shift || 0;
+ 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;
+ return $l + 0;
+}
+
+sub _cmp ($$) {
+ _version($_[1]) <=> _version($_[2]);
+}
+
+# Cloned from Params::Util::_CLASS
+sub _CLASS ($) {
+ (
+ defined $_[0]
+ and
+ ! ref $_[0]
+ and
+ $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
+ ) ? $_[0] : undef;
+}
+
+1;
+
+# Copyright 2008 - 2012 Adam Kennedy.
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
new file mode 100644
index 0000000..802844a
--- /dev/null
+++ b/inc/Module/Install/Base.pm
@@ -0,0 +1,83 @@
+#line 1
+package Module::Install::Base;
+
+use strict 'vars';
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.06';
+}
+
+# Suspend handler for "redefined" warnings
+BEGIN {
+ my $w = $SIG{__WARN__};
+ $SIG{__WARN__} = sub { $w };
+}
+
+#line 42
+
+sub new {
+ my $class = shift;
+ unless ( defined &{"${class}::call"} ) {
+ *{"${class}::call"} = sub { shift->_top->call(@_) };
+ }
+ unless ( defined &{"${class}::load"} ) {
+ *{"${class}::load"} = sub { shift->_top->load(@_) };
+ }
+ bless { @_ }, $class;
+}
+
+#line 61
+
+sub AUTOLOAD {
+ local $@;
+ my $func = eval { shift->_top->autoload } or return;
+ goto &$func;
+}
+
+#line 75
+
+sub _top {
+ $_[0]->{_top};
+}
+
+#line 90
+
+sub admin {
+ $_[0]->_top->{admin}
+ or
+ Module::Install::Base::FakeAdmin->new;
+}
+
+#line 106
+
+sub is_admin {
+ ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin');
+}
+
+sub DESTROY {}
+
+package Module::Install::Base::FakeAdmin;
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = $Module::Install::Base::VERSION;
+}
+
+my $fake;
+
+sub new {
+ $fake ||= bless(\@_, $_[0]);
+}
+
+sub AUTOLOAD {}
+
+sub DESTROY {}
+
+# Restore warning handler
+BEGIN {
+ $SIG{__WARN__} = $SIG{__WARN__}->();
+}
+
+1;
+
+#line 159
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
new file mode 100644
index 0000000..22167b8
--- /dev/null
+++ b/inc/Module/Install/Can.pm
@@ -0,0 +1,154 @@
+#line 1
+package Module::Install::Can;
+
+use strict;
+use Config ();
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.06';
+ @ISA = 'Module::Install::Base';
+ $ISCORE = 1;
+}
+
+# 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}), '.') {
+ next if $dir eq '';
+ require File::Spec;
+ my $abs = File::Spec->catfile($dir, $cmd);
+ return $abs if (-x $abs or $abs = MM->maybe_command($abs));
+ }
+
+ return;
+}
+
+# Can our C compiler environment build XS files
+sub can_xs {
+ my $self = shift;
+
+ # Ensure we have the CBuilder module
+ $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 );
+
+ # Do we have the configure_requires checker?
+ local $@;
+ eval "require ExtUtils::CBuilder;";
+ if ( $@ ) {
+ # They don't obey configure_requires, so it is
+ # someone old and delicate. Try to avoid hurting
+ # them by falling back to an older simpler test.
+ return $self->can_cc();
+ }
+
+ # Do we have a working C compiler
+ my $builder = ExtUtils::CBuilder->new(
+ quiet => 1,
+ );
+ unless ( $builder->have_compiler ) {
+ # No working C compiler
+ return 0;
+ }
+
+ # Write a C file representative of what XS becomes
+ require File::Temp;
+ my ( $FH, $tmpfile ) = File::Temp::tempfile(
+ "compilexs-XXXXX",
+ SUFFIX => '.c',
+ );
+ binmode $FH;
+ print $FH <<'END_C';
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+int main(int argc, char **argv) {
+ return 0;
+}
+
+int boot_sanexs() {
+ return 1;
+}
+
+END_C
+ close $FH;
+
+ # Can the C compiler access the same headers XS does
+ my @libs = ();
+ my $object = undef;
+ eval {
+ local $^W = 0;
+ $object = $builder->compile(
+ source => $tmpfile,
+ );
+ @libs = $builder->link(
+ objects => $object,
+ module_name => 'sanexs',
+ );
+ };
+ my $result = $@ ? 0 : 1;
+
+ # Clean up all the build files
+ foreach ( $tmpfile, $object, @libs ) {
+ next unless defined $_;
+ 1 while unlink;
+ }
+
+ return $result;
+}
+
+# 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 236
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
new file mode 100644
index 0000000..bee0c4f
--- /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 @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.06';
+ @ISA = 'Module::Install::Base';
+ $ISCORE = 1;
+}
+
+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/Makefile.pm b/inc/Module/Install/Makefile.pm
new file mode 100644
index 0000000..7052f36
--- /dev/null
+++ b/inc/Module/Install/Makefile.pm
@@ -0,0 +1,418 @@
+#line 1
+package Module::Install::Makefile;
+
+use strict 'vars';
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
+use Fcntl qw/:flock :seek/;
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.06';
+ @ISA = 'Module::Install::Base';
+ $ISCORE = 1;
+}
+
+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 or non-interactive session, always use defaults
+ if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
+ local $ENV{PERL_MM_USE_DEFAULT} = 1;
+ goto &ExtUtils::MakeMaker::prompt;
+ } else {
+ goto &ExtUtils::MakeMaker::prompt;
+ }
+}
+
+# Store a cleaned up version of the MakeMaker version,
+# since we need to behave differently in a variety of
+# ways based on the MM version.
+my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
+
+# If we are passed a param, do a "newer than" comparison.
+# Otherwise, just return the MakeMaker version.
+sub makemaker {
+ ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
+}
+
+# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
+# as we only need to know here whether the attribute is an array
+# or a hash or something else (which may or may not be appendable).
+my %makemaker_argtype = (
+ C => 'ARRAY',
+ CONFIG => 'ARRAY',
+# CONFIGURE => 'CODE', # ignore
+ DIR => 'ARRAY',
+ DL_FUNCS => 'HASH',
+ DL_VARS => 'ARRAY',
+ EXCLUDE_EXT => 'ARRAY',
+ EXE_FILES => 'ARRAY',
+ FUNCLIST => 'ARRAY',
+ H => 'ARRAY',
+ IMPORTS => 'HASH',
+ INCLUDE_EXT => 'ARRAY',
+ LIBS => 'ARRAY', # ignore ''
+ MAN1PODS => 'HASH',
+ MAN3PODS => 'HASH',
+ META_ADD => 'HASH',
+ META_MERGE => 'HASH',
+ PL_FILES => 'HASH',
+ PM => 'HASH',
+ PMLIBDIRS => 'ARRAY',
+ PMLIBPARENTDIRS => 'ARRAY',
+ PREREQ_PM => 'HASH',
+ CONFIGURE_REQUIRES => 'HASH',
+ SKIP => 'ARRAY',
+ TYPEMAPS => 'ARRAY',
+ XS => 'HASH',
+# VERSION => ['version',''], # ignore
+# _KEEP_AFTER_FLUSH => '',
+
+ clean => 'HASH',
+ depend => 'HASH',
+ dist => 'HASH',
+ dynamic_lib=> 'HASH',
+ linkext => 'HASH',
+ macro => 'HASH',
+ postamble => 'HASH',
+ realclean => 'HASH',
+ test => 'HASH',
+ tool_autosplit => 'HASH',
+
+ # special cases where you can use makemaker_append
+ CCFLAGS => 'APPENDABLE',
+ DEFINE => 'APPENDABLE',
+ INC => 'APPENDABLE',
+ LDDLFLAGS => 'APPENDABLE',
+ LDFROM => 'APPENDABLE',
+);
+
+sub makemaker_args {
+ my ($self, %new_args) = @_;
+ my $args = ( $self->{makemaker_args} ||= {} );
+ foreach my $key (keys %new_args) {
+ if ($makemaker_argtype{$key}) {
+ if ($makemaker_argtype{$key} eq 'ARRAY') {
+ $args->{$key} = [] unless defined $args->{$key};
+ unless (ref $args->{$key} eq 'ARRAY') {
+ $args->{$key} = [$args->{$key}]
+ }
+ push @{$args->{$key}},
+ ref $new_args{$key} eq 'ARRAY'
+ ? @{$new_args{$key}}
+ : $new_args{$key};
+ }
+ elsif ($makemaker_argtype{$key} eq 'HASH') {
+ $args->{$key} = {} unless defined $args->{$key};
+ foreach my $skey (keys %{ $new_args{$key} }) {
+ $args->{$key}{$skey} = $new_args{$key}{$skey};
+ }
+ }
+ elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
+ $self->makemaker_append($key => $new_args{$key});
+ }
+ }
+ else {
+ if (defined $args->{$key}) {
+ warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n};
+ }
+ $args->{$key} = $new_args{$key};
+ }
+ }
+ return $args;
+}
+
+# For mm args that take multiple space-seperated args,
+# append an argument to the current list.
+sub makemaker_append {
+ my $self = 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 _wanted_t {
+}
+
+sub tests_recursive {
+ my $self = shift;
+ my $dir = shift || 't';
+ unless ( -d $dir ) {
+ die "tests_recursive dir '$dir' does not exist";
+ }
+ my %tests = map { $_ => 1 } split / /, ($self->tests || '');
+ require File::Find;
+ File::Find::find(
+ sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 },
+ $dir
+ );
+ $self->tests( join ' ', sort keys %tests );
+}
+
+sub write {
+ my $self = shift;
+ die "&Makefile->write() takes no arguments\n" if @_;
+
+ # 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";
+ }
+
+ # Make sure we have a new enough MakeMaker
+ require ExtUtils::MakeMaker;
+
+ if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
+ # This previous attempted to inherit the version of
+ # ExtUtils::MakeMaker in use by the module author, but this
+ # was found to be untenable as some authors build releases
+ # using future dev versions of EU:MM that nobody else has.
+ # Instead, #toolchain suggests we use 6.59 which is the most
+ # stable version on CPAN at time of writing and is, to quote
+ # ribasushi, "not terminally fucked, > and tested enough".
+ # TODO: We will now need to maintain this over time to push
+ # the version up as new versions are released.
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 );
+ } else {
+ # Allow legacy-compatibility with 5.005 by depending on the
+ # most recent EU:MM that supported 5.005.
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 );
+ }
+
+ # Generate the MakeMaker params
+ my $args = $self->makemaker_args;
+ $args->{DISTNAME} = $self->name;
+ $args->{NAME} = $self->module_name || $self->name;
+ $args->{NAME} =~ s/-/::/g;
+ $args->{VERSION} = $self->version or die <<'EOT';
+ERROR: Can't determine distribution version. Please specify it
+explicitly via 'version' in Makefile.PL, or set a valid $VERSION
+in a module, and provide its file path via 'version_from' (or
+'all_from' if you prefer) in Makefile.PL.
+EOT
+
+ if ( $self->tests ) {
+ my @tests = split ' ', $self->tests;
+ my %seen;
+ $args->{test} = {
+ TESTS => (join ' ', grep {!$seen{$_}++} @tests),
+ };
+ } elsif ( $Module::Install::ExtraTests::use_extratests ) {
+ # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness.
+ # So, just ignore our xt tests here.
+ } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
+ $args->{test} = {
+ TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
+ };
+ }
+ if ( $] >= 5.005 ) {
+ $args->{ABSTRACT} = $self->abstract;
+ $args->{AUTHOR} = join ', ', @{$self->author || []};
+ }
+ if ( $self->makemaker(6.10) ) {
+ $args->{NO_META} = 1;
+ #$args->{NO_MYMETA} = 1;
+ }
+ if ( $self->makemaker(6.17) and $self->sign ) {
+ $args->{SIGN} = 1;
+ }
+ unless ( $self->is_admin ) {
+ delete $args->{SIGN};
+ }
+ if ( $self->makemaker(6.31) and $self->license ) {
+ $args->{LICENSE} = $self->license;
+ }
+
+ my $prereq = ($args->{PREREQ_PM} ||= {});
+ %$prereq = ( %$prereq,
+ map { @$_ } # flatten [module => version]
+ map { @$_ }
+ grep $_,
+ ($self->requires)
+ );
+
+ # Remove any reference to perl, PREREQ_PM doesn't support it
+ delete $args->{PREREQ_PM}->{perl};
+
+ # Merge both kinds of requires into BUILD_REQUIRES
+ my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
+ %$build_prereq = ( %$build_prereq,
+ map { @$_ } # flatten [module => version]
+ map { @$_ }
+ grep $_,
+ ($self->configure_requires, $self->build_requires)
+ );
+
+ # Remove any reference to perl, BUILD_REQUIRES doesn't support it
+ delete $args->{BUILD_REQUIRES}->{perl};
+
+ # Delete bundled dists from prereq_pm, add it to Makefile DIR
+ my $subdirs = ($args->{DIR} || []);
+ if ($self->bundles) {
+ my %processed;
+ foreach my $bundle (@{ $self->bundles }) {
+ my ($mod_name, $dist_dir) = @$bundle;
+ delete $prereq->{$mod_name};
+ $dist_dir = File::Basename::basename($dist_dir); # dir for building this module
+ if (not exists $processed{$dist_dir}) {
+ if (-d $dist_dir) {
+ # List as sub-directory to be processed by make
+ push @$subdirs, $dist_dir;
+ }
+ # Else do nothing: the module is already present on the system
+ $processed{$dist_dir} = undef;
+ }
+ }
+ }
+
+ unless ( $self->makemaker('6.55_03') ) {
+ %$prereq = (%$prereq,%$build_prereq);
+ delete $args->{BUILD_REQUIRES};
+ }
+
+ if ( my $perl_version = $self->perl_version ) {
+ eval "use $perl_version; 1"
+ or die "ERROR: perl: Version $] is installed, "
+ . "but we need version >= $perl_version";
+
+ if ( $self->makemaker(6.48) ) {
+ $args->{MIN_PERL_VERSION} = $perl_version;
+ }
+ }
+
+ if ($self->installdirs) {
+ warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS};
+ $args->{INSTALLDIRS} = $self->installdirs;
+ }
+
+ my %args = map {
+ ( $_ => $args->{$_} ) } grep {defined($args->{$_} )
+ } keys %$args;
+
+ my $user_preop = delete $args{dist}->{PREOP};
+ if ( my $preop = $self->admin->preop($user_preop) ) {
+ foreach my $key ( keys %$preop ) {
+ $args{dist}->{$key} = $preop->{$key};
+ }
+ }
+
+ 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: $!";
+ eval { flock MAKEFILE, LOCK_EX };
+ my $makefile = do { local $/; <MAKEFILE> };
+
+ $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;
+
+ seek MAKEFILE, 0, SEEK_SET;
+ truncate MAKEFILE, 0;
+ 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 544
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
new file mode 100644
index 0000000..58430f3
--- /dev/null
+++ b/inc/Module/Install/Metadata.pm
@@ -0,0 +1,722 @@
+#line 1
+package Module::Install::Metadata;
+
+use strict 'vars';
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.06';
+ @ISA = 'Module::Install::Base';
+ $ISCORE = 1;
+}
+
+my @boolean_keys = qw{
+ sign
+};
+
+my @scalar_keys = qw{
+ name
+ module_name
+ abstract
+ version
+ distribution_type
+ tests
+ installdirs
+};
+
+my @tuple_keys = qw{
+ configure_requires
+ build_requires
+ requires
+ recommends
+ bundles
+ resources
+};
+
+my @resource_keys = qw{
+ homepage
+ bugtracker
+ repository
+};
+
+my @array_keys = qw{
+ keywords
+ author
+};
+
+*authors = \&author;
+
+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;
+ };
+}
+
+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;
+ };
+}
+
+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;
+ };
+}
+
+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
+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(@_) }
+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 dynamic_config {
+ my $self = shift;
+ my $value = @_ ? shift : 1;
+ if ( $self->{values}->{dynamic_config} ) {
+ # Once dynamic we never change to static, for safety
+ return 0;
+ }
+ $self->{values}->{dynamic_config} = $value ? 1 : 0;
+ return 1;
+}
+
+# Convenience command
+sub static_config {
+ shift->dynamic_config(0);
+}
+
+sub perl_version {
+ my $self = shift;
+ return $self->{values}->{perl_version} unless @_;
+ my $version = shift or die(
+ "Did not provide a value to perl_version()"
+ );
+
+ # Normalize the version
+ $version = $self->_perl_version($version);
+
+ # We don't support the really old versions
+ unless ( $version >= 5.005 ) {
+ die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
+ }
+
+ $self->{values}->{perl_version} = $version;
+}
+
+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;
+ 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");
+ }
+
+ $self->{values}{all_from} = $file;
+
+ # Some methods pull from POD instead of code.
+ # If there is a matching .pod, use that instead
+ my $pod = $file;
+ $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;
+}
+
+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::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;
+}
+
+sub version_from {
+ require ExtUtils::MM_Unix;
+ my ( $self, $file ) = @_;
+ $self->version( ExtUtils::MM_Unix->parse_version($file) );
+
+ # for version integrity check
+ $self->makemaker_args( VERSION_FROM => $file );
+}
+
+sub abstract_from {
+ require ExtUtils::MM_Unix;
+ my ( $self, $file ) = @_;
+ $self->abstract(
+ bless(
+ { DISTNAME => $self->name },
+ 'ExtUtils::MM_Unix'
+ )->parse_abstract($file)
+ );
+}
+
+# Add both distribution and module name
+sub name_from {
+ my ($self, $file) = @_;
+ if (
+ Module::Install::_read($file) =~ m/
+ ^ \s*
+ package \s*
+ ([\w:]+)
+ \s* ;
+ /ixms
+ ) {
+ 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 $file\n");
+ }
+}
+
+sub _extract_perl_version {
+ if (
+ $_[0] =~ m/
+ ^\s*
+ (?:use|require) \s*
+ v?
+ ([\d_\.]+)
+ \s* ;
+ /ixms
+ ) {
+ my $perl_version = $1;
+ $perl_version =~ s{_}{}g;
+ return $perl_version;
+ } else {
+ return;
+ }
+}
+
+sub perl_version_from {
+ my $self = shift;
+ my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
+ if ($perl_version) {
+ $self->perl_version($perl_version);
+ } else {
+ warn "Cannot determine perl version info from $_[0]\n";
+ return;
+ }
+}
+
+sub author_from {
+ 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;
+
+ # XXX: ugly but should work anyway...
+ if (eval "require Pod::Escapes; 1") {
+ # Pod::Escapes has a mapping table.
+ # It's in core of perl >= 5.9.3, and should be installed
+ # as one of the Pod::Simple's prereqs, which is a prereq
+ # of Pod::Text 3.x (see also below).
+ $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
+ {
+ defined $2
+ ? chr($2)
+ : defined $Pod::Escapes::Name2character_number{$1}
+ ? chr($Pod::Escapes::Name2character_number{$1})
+ : do {
+ warn "Unknown escape: E<$1>";
+ "E<$1>";
+ };
+ }gex;
+ }
+ elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
+ # Pod::Text < 3.0 has yet another mapping table,
+ # though the table name of 2.x and 1.x are different.
+ # (1.x is in core of Perl < 5.6, 2.x is in core of
+ # Perl < 5.9.3)
+ my $mapping = ($Pod::Text::VERSION < 2)
+ ? \%Pod::Text::HTML_Escapes
+ : \%Pod::Text::ESCAPES;
+ $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
+ {
+ defined $2
+ ? chr($2)
+ : defined $mapping->{$1}
+ ? $mapping->{$1}
+ : do {
+ warn "Unknown escape: E<$1>";
+ "E<$1>";
+ };
+ }gex;
+ }
+ else {
+ $author =~ s{E<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ }
+ $self->author($author);
+ } else {
+ warn "Cannot determine author info from $_[0]\n";
+ }
+}
+
+#Stolen from M::B
+my %license_urls = (
+ perl => 'http://dev.perl.org/licenses/',
+ apache => 'http://apache.org/licenses/LICENSE-2.0',
+ apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
+ artistic => 'http://opensource.org/licenses/artistic-license.php',
+ artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
+ lgpl => 'http://opensource.org/licenses/lgpl-license.php',
+ lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
+ lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
+ bsd => 'http://opensource.org/licenses/bsd-license.php',
+ gpl => 'http://opensource.org/licenses/gpl-license.php',
+ gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
+ gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
+ mit => 'http://opensource.org/licenses/mit-license.php',
+ mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
+ open_source => undef,
+ unrestricted => undef,
+ restrictive => undef,
+ unknown => undef,
+);
+
+sub license {
+ my $self = shift;
+ return $self->{values}->{license} unless @_;
+ my $license = shift or die(
+ 'Did not provide a value to license()'
+ );
+ $license = __extract_license($license) || lc $license;
+ $self->{values}->{license} = $license;
+
+ # Automatically fill in license URLs
+ if ( $license_urls{$license} ) {
+ $self->resources( license => $license_urls{$license} );
+ }
+
+ return 1;
+}
+
+sub _extract_license {
+ my $pod = shift;
+ my $matched;
+ return __extract_license(
+ ($matched) = $pod =~ m/
+ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?)
+ (=head \d.*|=cut.*|)\z
+ /xms
+ ) || __extract_license(
+ ($matched) = $pod =~ m/
+ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?)
+ (=head \d.*|=cut.*|)\z
+ /xms
+ );
+}
+
+sub __extract_license {
+ my $license_text = shift or return;
+ my @phrases = (
+ '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1,
+ '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
+ 'Artistic and GPL' => 'perl', 1,
+ 'GNU general public license' => 'gpl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser general public license' => 'lgpl', 1,
+ 'GNU lesser public license' => 'lgpl', 1,
+ 'GNU library general public license' => 'lgpl', 1,
+ 'GNU library public license' => 'lgpl', 1,
+ 'GNU Free Documentation license' => 'unrestricted', 1,
+ 'GNU Affero General Public License' => 'open_source', 1,
+ '(?:Free)?BSD license' => 'bsd', 1,
+ 'Artistic license 2\.0' => 'artistic_2', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'Apache (?:Software )?license' => 'apache', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 1,
+ 'Mozilla Public License' => 'mozilla', 1,
+ 'Q Public License' => 'open_source', 1,
+ 'OpenSSL License' => 'unrestricted', 1,
+ 'SSLeay License' => 'unrestricted', 1,
+ 'zlib License' => 'open_source', 1,
+ 'proprietary' => 'proprietary', 0,
+ );
+ while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
+ $pattern =~ s#\s+#\\s+#gs;
+ if ( $license_text =~ /\b$pattern\b/i ) {
+ return $license;
+ }
+ }
+ return '';
+}
+
+sub license_from {
+ my $self = shift;
+ if (my $license=_extract_license(Module::Install::_read($_[0]))) {
+ $self->license($license);
+ } else {
+ warn "Cannot determine license info from $_[0]\n";
+ return 'unknown';
+ }
+}
+
+sub _extract_bugtracker {
+ my @links = $_[0] =~ m#L<(
+ https?\Q://rt.cpan.org/\E[^>]+|
+ https?\Q://github.com/\E[\w_]+/[\w_]+/issues|
+ https?\Q://code.google.com/p/\E[\w_\-]+/issues/list
+ )>#gx;
+ my %links;
+ @links{@links}=();
+ @links=keys %links;
+ return @links;
+}
+
+sub bugtracker_from {
+ my $self = shift;
+ my $content = Module::Install::_read($_[0]);
+ my @links = _extract_bugtracker($content);
+ unless ( @links ) {
+ warn "Cannot determine bugtracker info from $_[0]\n";
+ return 0;
+ }
+ if ( @links > 1 ) {
+ warn "Found more than one bugtracker link in $_[0]\n";
+ return 0;
+ }
+
+ # Set the bugtracker
+ bugtracker( $links[0] );
+ return 1;
+}
+
+sub requires_from {
+ my $self = shift;
+ my $content = Module::Install::_readperl($_[0]);
+ my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg;
+ while ( @requires ) {
+ my $module = shift @requires;
+ my $version = shift @requires;
+ $self->requires( $module => $version );
+ }
+}
+
+sub test_requires_from {
+ my $self = shift;
+ my $content = Module::Install::_readperl($_[0]);
+ my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
+ while ( @requires ) {
+ my $module = shift @requires;
+ my $version = shift @requires;
+ $self->test_requires( $module => $version );
+ }
+}
+
+# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
+# numbers (eg, 5.006001 or 5.008009).
+# Also, convert double-part versions (eg, 5.8)
+sub _perl_version {
+ my $v = $_[-1];
+ $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
+ $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(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) ) {
+ # Numify
+ $v = $v + 0;
+ }
+ return $v;
+}
+
+sub add_metadata {
+ my $self = shift;
+ my %hash = @_;
+ for my $key (keys %hash) {
+ warn "add_metadata: $key is not prefixed with 'x_'.\n" .
+ "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
+ $self->{values}->{$key} = $hash{$key};
+ }
+}
+
+
+######################################################################
+# MYMETA Support
+
+sub WriteMyMeta {
+ die "WriteMyMeta has been deprecated";
+}
+
+sub write_mymeta_yaml {
+ my $self = shift;
+
+ # We need YAML::Tiny to write the MYMETA.yml file
+ unless ( eval { require YAML::Tiny; 1; } ) {
+ return 1;
+ }
+
+ # Generate the data
+ my $meta = $self->_write_mymeta_data or return 1;
+
+ # Save as the MYMETA.yml file
+ print "Writing MYMETA.yml\n";
+ YAML::Tiny::DumpFile('MYMETA.yml', $meta);
+}
+
+sub write_mymeta_json {
+ my $self = shift;
+
+ # We need JSON to write the MYMETA.json file
+ unless ( eval { require JSON; 1; } ) {
+ return 1;
+ }
+
+ # Generate the data
+ my $meta = $self->_write_mymeta_data or return 1;
+
+ # Save as the MYMETA.yml file
+ print "Writing MYMETA.json\n";
+ Module::Install::_write(
+ 'MYMETA.json',
+ JSON->new->pretty(1)->canonical->encode($meta),
+ );
+}
+
+sub _write_mymeta_data {
+ my $self = shift;
+
+ # If there's no existing META.yml there is nothing we can do
+ return undef unless -f 'META.yml';
+
+ # We need Parse::CPAN::Meta to load the file
+ unless ( eval { require Parse::CPAN::Meta; 1; } ) {
+ return undef;
+ }
+
+ # Merge the perl version into the dependencies
+ my $val = $self->Meta->{values};
+ my $perl = delete $val->{perl_version};
+ 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 = Parse::CPAN::Meta::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} } };
+ }
+
+ return $meta;
+}
+
+1;
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
new file mode 100644
index 0000000..73b9cda
--- /dev/null
+++ b/inc/Module/Install/RTx.pm
@@ -0,0 +1,231 @@
+#line 1
+package Module::Install::RTx;
+
+use 5.008;
+use strict;
+use warnings;
+no warnings 'once';
+
+use Module::Install::Base;
+use base 'Module::Install::Base';
+our $VERSION = '0.29';
+
+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 ) = @_;
+
+ my $original_name = $name;
+ my $RTx = 'RTx';
+ $RTx = $1 if $name =~ s/^(\w+)-//;
+ my $fname = $name;
+ $fname =~ s!-!/!g;
+
+ $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;
+
+ 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 = (
+ $ENV{RTHOME} ? ( $ENV{RTHOME}, "$ENV{RTHOME}/lib" ) : (),
+ @INC,
+ map { ( "$_/rt4/lib", "$_/lib/rt4", "$_/rt3/lib", "$_/lib/rt3", "$_/lib" )
+ } grep $_, @prefixes
+ );
+ until ( eval { require RT; $RT::LocalPath } ) {
+ warn
+ "Cannot find the location of RT.pm that defines \$RT::LocalPath in: @INC\n";
+ $_ = $self->prompt("Path to directory containing your RT.pm:") or exit;
+ $_ =~ s/\/RT\.pm$//;
+ push @INC, $_, "$_/rt3/lib", "$_/lib/rt3", "$_/lib";
+ }
+ }
+
+ 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;
+ unshift @INC, $lib_path;
+
+ $RT::LocalVarPath ||= $RT::VarPath;
+ $RT::LocalPoPath ||= $RT::LocalLexiconPath;
+ $RT::LocalHtmlPath ||= $RT::MasonComponentRoot;
+ $RT::LocalLibPath ||= "$RT::LocalPath/lib";
+
+ my $with_subdirs = $ENV{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;
+ unless ( keys %subdirs ) {
+ $subdirs{$_} = 1 foreach grep -d "$FindBin::Bin/$_", @DIRS;
+ }
+
+ # 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
+ 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 %index = map { $_ => 1 } @INDEX_DIRS;
+ $self->no_index( directory => $_ ) foreach grep !$index{$_}, @DIRS;
+
+ my $args = join ', ', map "q($_)", map { ($_, $path{$_}) }
+ grep $subdirs{$_}, keys %path;
+
+ 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 ::
+\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 ( $subdirs{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"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxFactory(qw($RTx $name))"
+
+dropdb ::
+\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.*") ) {
+ $has_etc{acl}++;
+ }
+ if ( -e 'etc/initialdata' ) { $has_etc{initialdata}++; }
+
+ $self->postamble("$postamble\n");
+ unless ( $subdirs{'lib'} ) {
+ $self->makemaker_args( PM => { "" => "" }, );
+ } else {
+ $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" );
+
+ 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"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(schema))"
+.
+ $initdb .= <<"." if $has_etc{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"$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");
+ }
+}
+
+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;
+}
+
+# stolen from RT::Handle so we work on 3.6 (cmp_versions came in with 3.8)
+{ my %word = (
+ a => -4,
+ alpha => -4,
+ b => -3,
+ beta => -3,
+ pre => -2,
+ rc => -1,
+ head => 9999,
+);
+sub cmp_version($$) {
+ my ($a, $b) = (@_);
+ my @a = grep defined, map { /^[0-9]+$/? $_ : /^[a-zA-Z]+$/? $word{$_}|| -10 : undef }
+ split /([^0-9]+)/, $a;
+ my @b = grep defined, map { /^[0-9]+$/? $_ : /^[a-zA-Z]+$/? $word{$_}|| -10 : undef }
+ split /([^0-9]+)/, $b;
+ @a > @b
+ ? push @b, (0) x (@a- at b)
+ : push @a, (0) x (@b- at a);
+ for ( my $i = 0; $i < @a; $i++ ) {
+ return $a[$i] <=> $b[$i] if $a[$i] <=> $b[$i];
+ }
+ return 0;
+}}
+sub requires_rt {
+ my ($self,$version) = @_;
+
+ # if we're exactly the same version as what we want, silently return
+ return if ($version eq $RT::VERSION);
+
+ my @sorted = sort cmp_version $version,$RT::VERSION;
+
+ if ($sorted[-1] eq $version) {
+ # should we die?
+ warn "\nWarning: prerequisite RT $version not found. Your installed version of RT ($RT::VERSION) is too old.\n\n";
+ }
+}
+
+1;
+
+__END__
+
+#line 348
diff --git a/inc/Module/Install/ReadmeFromPod.pm b/inc/Module/Install/ReadmeFromPod.pm
new file mode 100644
index 0000000..fb7075f
--- /dev/null
+++ b/inc/Module/Install/ReadmeFromPod.pm
@@ -0,0 +1,138 @@
+#line 1
+package Module::Install::ReadmeFromPod;
+
+use 5.006;
+use strict;
+use warnings;
+use base qw(Module::Install::Base);
+use vars qw($VERSION);
+
+$VERSION = '0.18';
+
+sub readme_from {
+ my $self = shift;
+ return unless $self->is_admin;
+
+ # Input file
+ my $in_file = shift || $self->_all_from
+ or die "Can't determine file to make readme_from";
+
+ # Get optional arguments
+ my ($clean, $format, $out_file, $options);
+ my $args = shift;
+ if ( ref $args ) {
+ # Arguments are in a hashref
+ if ( ref($args) ne 'HASH' ) {
+ die "Expected a hashref but got a ".ref($args)."\n";
+ } else {
+ $clean = $args->{'clean'};
+ $format = $args->{'format'};
+ $out_file = $args->{'output_file'};
+ $options = $args->{'options'};
+ }
+ } else {
+ # Arguments are in a list
+ $clean = $args;
+ $format = shift;
+ $out_file = shift;
+ $options = \@_;
+ }
+
+ # Default values;
+ $clean ||= 0;
+ $format ||= 'txt';
+
+ # Generate README
+ print "readme_from $in_file to $format\n";
+ if ($format =~ m/te?xt/) {
+ $out_file = $self->_readme_txt($in_file, $out_file, $options);
+ } elsif ($format =~ m/html?/) {
+ $out_file = $self->_readme_htm($in_file, $out_file, $options);
+ } elsif ($format eq 'man') {
+ $out_file = $self->_readme_man($in_file, $out_file, $options);
+ } elsif ($format eq 'pdf') {
+ $out_file = $self->_readme_pdf($in_file, $out_file, $options);
+ }
+
+ if ($clean) {
+ $self->clean_files($out_file);
+ }
+
+ return 1;
+}
+
+
+sub _readme_txt {
+ my ($self, $in_file, $out_file, $options) = @_;
+ $out_file ||= 'README';
+ require Pod::Text;
+ my $parser = Pod::Text->new( @$options );
+ open my $out_fh, '>', $out_file or die "Could not write file $out_file:\n$!\n";
+ $parser->output_fh( *$out_fh );
+ $parser->parse_file( $in_file );
+ close $out_fh;
+ return $out_file;
+}
+
+
+sub _readme_htm {
+ my ($self, $in_file, $out_file, $options) = @_;
+ $out_file ||= 'README.htm';
+ require Pod::Html;
+ Pod::Html::pod2html(
+ "--infile=$in_file",
+ "--outfile=$out_file",
+ @$options,
+ );
+ # Remove temporary files if needed
+ for my $file ('pod2htmd.tmp', 'pod2htmi.tmp') {
+ if (-e $file) {
+ unlink $file or warn "Warning: Could not remove file '$file'.\n$!\n";
+ }
+ }
+ return $out_file;
+}
+
+
+sub _readme_man {
+ my ($self, $in_file, $out_file, $options) = @_;
+ $out_file ||= 'README.1';
+ require Pod::Man;
+ my $parser = Pod::Man->new( @$options );
+ $parser->parse_from_file($in_file, $out_file);
+ return $out_file;
+}
+
+
+sub _readme_pdf {
+ my ($self, $in_file, $out_file, $options) = @_;
+ $out_file ||= 'README.pdf';
+ eval { require App::pod2pdf; }
+ or die "Could not generate $out_file because pod2pdf could not be found\n";
+ my $parser = App::pod2pdf->new( @$options );
+ $parser->parse_from_file($in_file);
+ open my $out_fh, '>', $out_file or die "Could not write file $out_file:\n$!\n";
+ select $out_fh;
+ $parser->output;
+ select STDOUT;
+ close $out_fh;
+ return $out_file;
+}
+
+
+sub _all_from {
+ my $self = shift;
+ return unless $self->admin->{extensions};
+ my ($metadata) = grep {
+ ref($_) eq 'Module::Install::Metadata';
+ } @{$self->admin->{extensions}};
+ return unless $metadata;
+ return $metadata->{values}{all_from} || '';
+}
+
+'Readme!';
+
+__END__
+
+#line 254
+
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
new file mode 100644
index 0000000..eeaa3fe
--- /dev/null
+++ b/inc/Module/Install/Win32.pm
@@ -0,0 +1,64 @@
+#line 1
+package Module::Install::Win32;
+
+use strict;
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.06';
+ @ISA = 'Module::Install::Base';
+ $ISCORE = 1;
+}
+
+# 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,
+ );
+
+ die <<'END_MESSAGE' unless $rv;
+
+-------------------------------------------------------------------------------
+
+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..85d8018
--- /dev/null
+++ b/inc/Module/Install/WriteAll.pm
@@ -0,0 +1,63 @@
+#line 1
+package Module::Install::WriteAll;
+
+use strict;
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.06';
+ @ISA = qw{Module::Install::Base};
+ $ISCORE = 1;
+}
+
+sub WriteAll {
+ my $self = shift;
+ my %args = (
+ meta => 1,
+ sign => 0,
+ inline => 0,
+ check_nmake => 1,
+ @_,
+ );
+
+ $self->sign(1) if $args{sign};
+ $self->admin->WriteAll(%args) if $self->is_admin;
+
+ $self->check_nmake if $args{check_nmake};
+ unless ( $self->makemaker_args->{PL_FILES} ) {
+ # XXX: This still may be a bit over-defensive...
+ unless ($self->makemaker(6.25)) {
+ $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
+ }
+ }
+
+ # Until ExtUtils::MakeMaker support MYMETA.yml, make sure
+ # 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.
+ if ( $args{meta} ) {
+ $self->Meta->write;
+ }
+
+ # Experimental support for MYMETA
+ if ( $ENV{X_MYMETA} ) {
+ if ( $ENV{X_MYMETA} eq 'JSON' ) {
+ $self->Meta->write_mymeta_json;
+ } else {
+ $self->Meta->write_mymeta_yaml;
+ }
+ }
+
+ return 1;
+}
+
+1;
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
new file mode 100644
index 0000000..cc0406a
--- /dev/null
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -0,0 +1,70 @@
+use strict;
+use warnings;
+package RT::Extension::Assets::AppleGSX;
+
+our $VERSION = '0.01';
+
+=head1 NAME
+
+RT-Extension-Assets-AppleGSX - Apple GSX for RT Assets
+
+=head1 INSTALLATION
+
+=over
+
+=item perl Makefile.PL
+
+=item make
+
+=item make install
+
+May need root permissions
+
+=item make initdb
+
+Only run this the first time you install this module.
+
+If you run this twice, you may end up with duplicate data
+in your database.
+
+If you are upgrading this module, check for upgrading instructions
+in case changes need to be made to your database.
+
+=item Edit your /opt/rt4/etc/RT_SiteConfig.pm
+
+Add this line:
+
+ Set(@Plugins, qw(RT::Extension::Assets::AppleGSX));
+
+or add C<RT::Extension::Assets::AppleGSX> to your existing C<@Plugins> line.
+
+=item Clear your mason cache
+
+ rm -rf /opt/rt4/var/mason_data/obj
+
+=item Restart your webserver
+
+=back
+
+=head1 AUTHOR
+
+sunnavy <sunnavy at bestpractical.com>
+
+=head1 BUGS
+
+All bugs should be reported via
+L<http://rt.cpan.org/Public/Dist/Display.html?Name=RT-Extension-Assets-AppleGSX>
+or L<bug-RT-Extension-Assets-AppleGSX at rt.cpan.org>.
+
+
+=head1 LICENSE AND COPYRIGHT
+
+This software is Copyright (c) 2012 by Best Practical Solutions
+
+This is free software, licensed under:
+
+ The GNU General Public License, Version 2, June 1991
+
+=cut
+
+1;
commit eff62271fcc6ab9ba56ce913cab7379acdc0a5e1
Author: sunnavy <sunnavy at bestpractical.com>
Date: Wed Oct 10 22:11:58 2012 +0800
first working version
diff --git a/META.yml b/META.yml
index 30d8610..baa5faf 100644
--- a/META.yml
+++ b/META.yml
@@ -16,6 +16,7 @@ meta-spec:
name: RT-Extension-Assets-AppleGSX
no_index:
directory:
+ - etc
- inc
resources:
license: http://opensource.org/licenses/gpl-license.php
diff --git a/bin/rt-apple-gsx-set-warranty b/bin/rt-apple-gsx-set-warranty
new file mode 100644
index 0000000..aa64581
--- /dev/null
+++ b/bin/rt-apple-gsx-set-warranty
@@ -0,0 +1,133 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+
+use lib '/opt/rt4/local/lib', '/opt/rt4/lib';
+
+use Getopt::Long;
+my %opt;
+GetOptions( \%opt, 'help|h', );
+if ( $opt{help} ) {
+ require Pod::Usage;
+ Pod::Usage::pod2usage({ verbose => 2 });
+ exit;
+}
+
+require RT;
+RT::LoadConfig();
+RT::Init();
+
+my $serial_cf = RT::CustomField->new(RT->SystemUser);
+$serial_cf->Load('Serial Number');
+unless ( $serial_cf->id ) {
+ die "Custom Field 'Serial Number' not found";
+}
+
+require RT::Attribute;
+my $attr = RT::Attribute->new( RT->SystemUser );
+$attr->LoadByNameAndObject( Name => 'AppleGSXTransactionId', Object => RT->System );
+unless ( $attr->id ) {
+ $attr->Create( Name => 'AppleGSXTransactionId', Object => RT->System );
+}
+
+my $last_txn_id = $attr->Content;
+
+my $txns = RT::Transactions->new(RT->SystemUser);
+$txns->Limit(
+ FIELD => 'ObjectType',
+ VALUE => 'RT::Asset',
+);
+
+$txns->Limit(
+ FIELD => 'id',
+ VALUE => $last_txn_id,
+ OPERATOR => '>',
+) if $last_txn_id;
+
+$txns->Limit(
+ FIELD => 'Type',
+ VALUE => 'Create',
+ SUBCLAUSE => 'Set',
+);
+
+$txns->Limit(
+ FIELD => 'Type',
+ VALUE => 'CustomField',
+ SUBCLAUSE => 'Set',
+ ENTRYAGGREGATOR => 'OR',
+);
+
+$txns->Limit(
+ FIELD => 'Field',
+ VALUE => $serial_cf->id,
+ SUBCLAUSE => 'Set',
+ ENTRYAGGREGATOR => 'AND',
+);
+
+my %assets;
+while ( my $txn = $txns->Next ) {
+ $assets{$txn->ObjectId} ||= $txn->Object;
+}
+
+my %FIELDS_MAP = (
+ 'Warranty Status' => 'warrantyStatus',
+ 'Coverage Start Date' => 'coverageStartDate',
+ 'Coverage End Date' => 'coverageEndDate',
+);
+
+for my $asset ( values %assets ) {
+ my $trademark = $asset->FirstCustomFieldValue('Trademark');
+ next unless $trademark && $trademark eq 'Apple';
+ if ( my $serial = $asset->FirstCustomFieldValue('Serial Number') ) {
+ my $gsx = RT::Extension::Assets::AppleGSX->Client;
+ my $info = $gsx->WarrantyStatus($serial);
+ if ( $info && $info->{warrantyDetailInfo} ) {
+ for my $field ( keys %FIELDS_MAP ) {
+ if ( defined $info->{warrantyDetailInfo}{ $FIELDS_MAP{$field} } ) {
+ $asset->AddCustomFieldValue(
+ Field => $field,
+ Value =>
+ $info->{warrantyDetailInfo}{ $FIELDS_MAP{$field} },
+ );
+ }
+ else {
+ my $old = $asset->FirstCustomFieldValue($field);
+ if ( defined $old ) {
+ $asset->DeleteCustomFieldValue(
+ Field => $field,
+ Value => $old,
+ );
+ }
+ }
+ }
+ }
+ }
+ else {
+ for my $field ( keys %FIELDS_MAP ) {
+ my $old = $asset->FirstCustomFieldValue($field);
+ if ( defined $old ) {
+ $asset->DeleteCustomFieldValue(
+ Field => $field,
+ Value => $old,
+ );
+ }
+ }
+ }
+}
+
+$attr->SetContent($txns->Last->id) if $txns->Last;
+
+__END__
+
+=head1 NAME
+
+rt-apple-gsx-set-warranty - set warranty info for apple assets
+
+=head1 SYNOPSIS
+
+ rt-apple-gsx-set-warranty
+
+=head1 DESCRIPTION
+
+This script will incrementally set warranty info for apple assets.
+cron job is recommended.
diff --git a/etc/initialdata b/etc/initialdata
new file mode 100644
index 0000000..5522ec0
--- /dev/null
+++ b/etc/initialdata
@@ -0,0 +1,33 @@
+ at CustomFields = (
+ {
+ Name => 'Trademark',
+ LookupType => 'RT::Asset',
+ Type => 'Freeform',
+ MaxValues => 1,
+ },
+ {
+ Name => 'Serial Number',
+ LookupType => 'RT::Asset',
+ Type => 'Freeform',
+ MaxValues => 1,
+ },
+ {
+ Name => 'Warranty Status',
+ LookupType => 'RT::Asset',
+ Type => 'Freeform',
+ MaxValues => 1,
+ },
+ {
+ Name => 'Coverage Start Date',
+ LookupType => 'RT::Asset',
+ Type => 'Date',
+ MaxValues => 1,
+ },
+ {
+ Name => 'Coverage End Date',
+ LookupType => 'RT::Asset',
+ Type => 'Date',
+ MaxValues => 1,
+ },
+);
+
diff --git a/inc/Module/Install/RTx/Factory.pm b/inc/Module/Install/RTx/Factory.pm
new file mode 100644
index 0000000..23ce911
--- /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",
+ (($action eq 'insert') ? ("--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;
+}
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index cc0406a..ee3cf78 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -4,6 +4,22 @@ package RT::Extension::Assets::AppleGSX;
our $VERSION = '0.01';
+my $client;
+
+sub InitClient {
+ my $class = shift;
+ require RT::Extension::Assets::AppleGSX::Client;
+ $client =
+ RT::Extension::Assets::AppleGSX::Client->new(
+ RT->Config->Get('AppleGSXOptions'),
+ );
+}
+
+sub Client {
+ InitClient() unless $client;
+ return $client;
+}
+
=head1 NAME
RT-Extension-Assets-AppleGSX - Apple GSX for RT Assets
diff --git a/lib/RT/Extension/Assets/AppleGSX/Client.pm b/lib/RT/Extension/Assets/AppleGSX/Client.pm
new file mode 100644
index 0000000..a09cf02
--- /dev/null
+++ b/lib/RT/Extension/Assets/AppleGSX/Client.pm
@@ -0,0 +1,125 @@
+use strict;
+use warnings;
+
+package RT::Extension::Assets::AppleGSX::Client;
+
+use LWP::UserAgent;
+
+use XML::Simple;
+my $xs = XML::Simple->new;
+
+use base 'Class::Accessor::Fast';
+__PACKAGE__->mk_accessors(
+ qw/UserAgent UserSessionId UserSessionTimeout UserId Password
+ ServiceAccountNo Lang UserTimeZone/
+);
+
+sub new {
+ my $class = shift;
+ my $args = ref $_[0] eq 'HASH' ? shift @_ : {@_};
+ my $self = $class->SUPER::new($args);
+ $self->UserAgent( LWP::UserAgent->new() ) unless $self->UserAgent;
+ return $self;
+}
+
+sub Authenticate {
+ my $self = shift;
+
+ my $xml = $self->PrepareXML(
+ 'Authenticate',
+ {
+ userId => $self->UserId,
+ password => $self->Password,
+ serviceAccountNo => $self->ServiceAccountNo,
+ languageCode => 'en',
+ userTimeZone => 'CEST',
+ }
+ );
+
+ my $res = $self->SendRequest($xml);
+ if ( $res->is_success ) {
+ my $ret =
+ $self->ParseResponseXML( 'Authenticate', $res->decoded_content );
+ $self->UserSessionId( $ret->{'userSessionId'} );
+
+ # official timeout is 30 minutes, minus 5 is to avoid potential
+ # out of sync time issue
+ $self->UserSessionTimeout( time() + 25 * 60 );
+ return $self->UserSessionId;
+ }
+ else {
+ warn "failed to auth gsx: " . $res->status_line;
+ return;
+ }
+}
+
+sub WarrantyStatus {
+ my $self = shift;
+ my $serial = shift or return;
+
+ $self->Authenticate
+ unless $self->UserSessionId && time() < $self->UserSessionTimeout;
+
+ my $xml = $self->PrepareXML(
+ 'WarrantyStatus',
+ {
+ 'userSession' => { userSessionId => $self->UserSessionId, },
+ 'unitDetail' => { serialNumber => $serial, }
+ }
+ );
+
+ my $res = $self->SendRequest($xml);
+ if ( $res->is_success ) {
+ return $self->ParseResponseXML( 'WarrantyStatus',
+ $res->decoded_content );
+ }
+ else {
+ warn "failed to get warranty status of serial $serial";
+ return;
+ }
+}
+
+sub PrepareXML {
+ my $self = shift;
+ my $method = shift;
+ my $args = shift || {};
+
+ my $xml = $xs->XMLout(
+ {
+ 'SOAP-ENV:Body' =>
+ { "ns1:$method" => { "${method}Request" => $args, }, },
+ },
+ NoAttr => 1,
+ KeyAttr => [],
+ RootName => '',
+ );
+ return <<"EOF",
+<?xml version="1.0" encoding="UTF-8"?>
+<SOAP-ENV:Envelope xmlns:SOAP-ENV="http://schemas.xmlsoap.org/soap/envelope/"
+xmlns:ns1="http://gsxws.apple.com/elements/global">
+$xml
+</SOAP-ENV:Envelope>
+EOF
+
+}
+
+sub ParseResponseXML {
+ my $self = shift;
+ my $method = shift;
+ my $xml = shift;
+ my $ret = $xs->XMLin( $xml, NoAttr => 1, SuppressEmpty => undef );
+ return $ret->{'S:Body'}{"ns3:${method}Response"}{"${method}Response"};
+}
+
+sub SendRequest {
+ my $self = shift;
+ my $xml = shift;
+ my $res = $self->UserAgent->post(
+ 'https://gsxws2.apple.com/gsx-ws/services/am/asp',
+ 'Content-Type' => 'text/xml; charset=utf-8',
+ Content => $xml,
+ );
+ return $res;
+}
+
+1;
commit 74099e04d39e34e56919a306261d278f38ecaf7d
Author: sunnavy <sunnavy at bestpractical.com>
Date: Wed Oct 10 22:16:13 2012 +0800
example of AppleGSXOptions config
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index ee3cf78..5bdb4c1 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -54,6 +54,15 @@ Add this line:
or add C<RT::Extension::Assets::AppleGSX> to your existing C<@Plugins> line.
+Config Apple GSX:
+
+ Set(
+ %AppleGSXOptions,
+ UserId => 'foo at example.com',
+ Password => 'secret',
+ ServiceAccountNo => 12345,
+ );
+
=item Clear your mason cache
rm -rf /opt/rt4/var/mason_data/obj
commit fecce4f81218ed949ef1d148086caa4603611b49
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Fri Jan 18 05:35:08 2013 -0500
Update inc/
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
index 73b9cda..ce01018 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.29';
+our $VERSION = '0.30';
use FindBin;
use File::Glob ();
@@ -129,18 +129,7 @@ install ::
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"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxFactory(qw($RTx $name))"
-
-dropdb ::
-\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.*") ) {
$has_etc{acl}++;
@@ -164,28 +153,19 @@ dropdb ::
print "For first-time installation, type 'make initdb'.\n";
my $initdb = '';
$initdb .= <<"." if $has_etc{schema};
-\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -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 \$(NAME) \$(VERSION)))"
.
$initdb .= <<"." if $has_etc{acl};
-\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -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 \$(NAME) \$(VERSION)))"
.
$initdb .= <<"." if $has_etc{initialdata};
-\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -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 \$(NAME) \$(VERSION)))"
.
$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;
-}
-
# stolen from RT::Handle so we work on 3.6 (cmp_versions came in with 3.8)
{ my %word = (
a => -4,
@@ -228,4 +208,4 @@ sub requires_rt {
__END__
-#line 348
+#line 328
diff --git a/inc/Module/Install/RTx/Factory.pm b/inc/Module/Install/RTx/Factory.pm
index 23ce911..a8702e4 100644
--- a/inc/Module/Install/RTx/Factory.pm
+++ b/inc/Module/Install/RTx/Factory.pm
@@ -6,7 +6,7 @@ use strict;
use File::Basename ();
sub RTxInitDB {
- my ($self, $action) = @_;
+ my ($self, $action, $name, $version) = @_;
unshift @INC, substr(delete($INC{'RT.pm'}), 0, -5) if $INC{'RT.pm'};
@@ -23,6 +23,8 @@ sub RTxInitDB {
RT::LoadConfig();
+ require RT::System;
+
my $lib_path = File::Basename::dirname($INC{'RT.pm'});
my @args = ("-Ilib");
push @args, "-I$RT::LocalPath/lib" if $RT::LocalPath;
@@ -33,451 +35,12 @@ sub RTxInitDB {
"--datadir" => "etc",
(($action eq 'insert') ? ("--datafile" => "etc/initialdata") : ()),
"--dba" => $RT::DatabaseUser,
- "--prompt-for-dba-password" => ''
+ "--prompt-for-dba-password" => '',
+ (RT::System->can('AddUpgradeHistory') ? ("--package" => $name, "--ext-version" => $version) : ()),
);
+
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;
-}
diff --git a/inc/Module/Install/ReadmeFromPod.pm b/inc/Module/Install/ReadmeFromPod.pm
index fb7075f..6a80818 100644
--- a/inc/Module/Install/ReadmeFromPod.pm
+++ b/inc/Module/Install/ReadmeFromPod.pm
@@ -7,7 +7,7 @@ use warnings;
use base qw(Module::Install::Base);
use vars qw($VERSION);
-$VERSION = '0.18';
+$VERSION = '0.20';
sub readme_from {
my $self = shift;
diff --git a/inc/Module/Install/Substitute.pm b/inc/Module/Install/Substitute.pm
new file mode 100644
index 0000000..56af7fe
--- /dev/null
+++ b/inc/Module/Install/Substitute.pm
@@ -0,0 +1,131 @@
+#line 1
+package Module::Install::Substitute;
+
+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);
+
+our $VERSION = '0.03';
+
+require File::Temp;
+require File::Spec;
+require Cwd;
+
+#line 89
+
+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?(.*)$/s ) {
+ my ($action, $nstr) = ($1,$2);
+ $nstr =~ s/\@($re_subst)\@/$subst->{$1}/ge;
+
+ 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;
+ 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 64540c4ab0372b65e8b72807eb701f340bcb5fee
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Fri Jan 18 05:34:42 2013 -0500
Substitute RT lib path and perl
diff --git a/.gitignore b/.gitignore
index 2597782..c3c70ea 100644
--- a/.gitignore
+++ b/.gitignore
@@ -11,3 +11,4 @@ README
*.bak
*.swp
/MYMETA.*
+/bin/rt-apple-gsx-set-warranty
diff --git a/Makefile.PL b/Makefile.PL
index 8d8bf52..61a2e72 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -6,5 +6,18 @@ all_from 'lib/RT/Extension/Assets/AppleGSX.pm';
readme_from 'lib/RT/Extension/Assets/AppleGSX.pm';
license 'gplv2';
+use Config;
+my $perl_path = $Config{perlpath};
+$perl_path .= $Config{_exe}
+ if $^O ne 'VMS' and $perl_path !~ m/$Config{_exe}$/i;
+
+substitute( {
+ RT_LIB_PATH => "$RT::LocalPath/lib " . File::Basename::dirname( $INC{'RT.pm'} ),
+ PERL => $perl_path,
+ },
+ { sufix => ".in" },
+ 'bin/rt-apple-gsx-set-warranty',
+);
+
sign;
WriteAll;
diff --git a/bin/rt-apple-gsx-set-warranty b/bin/rt-apple-gsx-set-warranty.in
similarity index 96%
rename from bin/rt-apple-gsx-set-warranty
rename to bin/rt-apple-gsx-set-warranty.in
index aa64581..d46dba3 100644
--- a/bin/rt-apple-gsx-set-warranty
+++ b/bin/rt-apple-gsx-set-warranty.in
@@ -1,8 +1,16 @@
#!/usr/bin/env perl
+### before: #!@PERL@
+
use strict;
use warnings;
-use lib '/opt/rt4/local/lib', '/opt/rt4/lib';
+BEGIN {
+### after: use lib qw(@RT_LIB_PATH@);
+use lib qw(/opt/rt4-assets/local/lib /opt/rt4-assets/lib);
+use RT;
+RT::LoadConfig();
+RT::Init();
+}
use Getopt::Long;
my %opt;
@@ -13,9 +21,6 @@ if ( $opt{help} ) {
exit;
}
-require RT;
-RT::LoadConfig();
-RT::Init();
my $serial_cf = RT::CustomField->new(RT->SystemUser);
$serial_cf->Load('Serial Number');
@@ -23,7 +28,7 @@ unless ( $serial_cf->id ) {
die "Custom Field 'Serial Number' not found";
}
-require RT::Attribute;
+
my $attr = RT::Attribute->new( RT->SystemUser );
$attr->LoadByNameAndObject( Name => 'AppleGSXTransactionId', Object => RT->System );
unless ( $attr->id ) {
commit 011969c01de48ca976458b9831d826c5f016d7e0
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Fri Jan 18 05:35:44 2013 -0500
chmod +x bin/rt-apple-gsx-set-warranty
diff --git a/bin/rt-apple-gsx-set-warranty.in b/bin/rt-apple-gsx-set-warranty.in
old mode 100644
new mode 100755
commit 1d442d653dd2dbb946a902ebfcf48a413258282e
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Fri Jan 18 05:36:24 2013 -0500
Require that AppleGSXOptions be set to run
diff --git a/bin/rt-apple-gsx-set-warranty.in b/bin/rt-apple-gsx-set-warranty.in
index d46dba3..8a4048a 100755
--- a/bin/rt-apple-gsx-set-warranty.in
+++ b/bin/rt-apple-gsx-set-warranty.in
@@ -21,6 +21,10 @@ if ( $opt{help} ) {
exit;
}
+# Sanity check that the extension is configured
+die "AppleGSXOptions not set; please read the documentation for " .
+ "RT::Extension::Assets::AppleGSX for more on configuring this extension."
+ unless RT->Config->Get('AppleGSXOptions');
my $serial_cf = RT::CustomField->new(RT->SystemUser);
$serial_cf->Load('Serial Number');
commit 6180dbf3bd8374b3bc2980c3a1e726fa4ce4ecef
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Fri Jan 18 05:37:48 2013 -0500
Allow greater flexibility of the CFs used
diff --git a/bin/rt-apple-gsx-set-warranty.in b/bin/rt-apple-gsx-set-warranty.in
index 8a4048a..0f520a1 100755
--- a/bin/rt-apple-gsx-set-warranty.in
+++ b/bin/rt-apple-gsx-set-warranty.in
@@ -26,10 +26,24 @@ die "AppleGSXOptions not set; please read the documentation for " .
"RT::Extension::Assets::AppleGSX for more on configuring this extension."
unless RT->Config->Get('AppleGSXOptions');
-my $serial_cf = RT::CustomField->new(RT->SystemUser);
-$serial_cf->Load('Serial Number');
-unless ( $serial_cf->id ) {
- die "Custom Field 'Serial Number' not found";
+
+my $serial_name = RT->Config->Get('AppleGSXSerialCF') || "Serial Number";
+
+my $FIELDS_MAP = RT->Config->Get('AppleGSXMap') || {
+ 'Warranty Status' => 'warrantyStatus',
+ 'Warranty Start Date' => 'coverageStartDate',
+ 'Warranty End Date' => 'coverageEndDate',
+};
+
+my $CHECKS = RT->Config->Get('AppleGSXChecks') || {
+ 'Trademark' => qr/\bApple(Care)?\b/i,
+};
+
+# Check that all of the CFs we reference exist
+for my $cfname ($serial_name, keys(%$FIELDS_MAP), keys(%$CHECKS)) {
+ my $cf = RT::CustomField->new(RT->SystemUser);
+ $cf->Load($cfname);
+ die "Custom Field '$cfname' not found" unless $cf->id;
}
@@ -39,8 +53,11 @@ unless ( $attr->id ) {
$attr->Create( Name => 'AppleGSXTransactionId', Object => RT->System );
}
-my $last_txn_id = $attr->Content;
+my $serial_cf = RT::CustomField->new(RT->SystemUser);
+$serial_cf->Load($serial_name);
+
+my $last_txn_id = $attr->Content;
my $txns = RT::Transactions->new(RT->SystemUser);
$txns->Limit(
FIELD => 'ObjectType',
@@ -78,25 +95,22 @@ while ( my $txn = $txns->Next ) {
$assets{$txn->ObjectId} ||= $txn->Object;
}
-my %FIELDS_MAP = (
- 'Warranty Status' => 'warrantyStatus',
- 'Coverage Start Date' => 'coverageStartDate',
- 'Coverage End Date' => 'coverageEndDate',
-);
-
for my $asset ( values %assets ) {
- my $trademark = $asset->FirstCustomFieldValue('Trademark');
- next unless $trademark && $trademark eq 'Apple';
- if ( my $serial = $asset->FirstCustomFieldValue('Serial Number') ) {
+ my @match = grep {$_->[1] and $_->[1] =~ /$CHECKS->{$_->[0]}/}
+ map {[$_, $asset->FirstCustomFieldValue($_)]}
+ keys %$CHECKS;
+ next unless @match;
+
+ if ( my $serial = $asset->FirstCustomFieldValue($serial_name) ) {
my $gsx = RT::Extension::Assets::AppleGSX->Client;
my $info = $gsx->WarrantyStatus($serial);
if ( $info && $info->{warrantyDetailInfo} ) {
- for my $field ( keys %FIELDS_MAP ) {
- if ( defined $info->{warrantyDetailInfo}{ $FIELDS_MAP{$field} } ) {
+ for my $field ( keys %$FIELDS_MAP ) {
+ if ( defined $info->{warrantyDetailInfo}{ $FIELDS_MAP->{$field} } ) {
$asset->AddCustomFieldValue(
Field => $field,
Value =>
- $info->{warrantyDetailInfo}{ $FIELDS_MAP{$field} },
+ $info->{warrantyDetailInfo}{ $FIELDS_MAP->{$field} },
);
}
else {
@@ -112,7 +126,7 @@ for my $asset ( values %assets ) {
}
}
else {
- for my $field ( keys %FIELDS_MAP ) {
+ for my $field ( keys %$FIELDS_MAP ) {
my $old = $asset->FirstCustomFieldValue($field);
if ( defined $old ) {
$asset->DeleteCustomFieldValue(
@@ -138,5 +152,8 @@ rt-apple-gsx-set-warranty - set warranty info for apple assets
=head1 DESCRIPTION
-This script will incrementally set warranty info for apple assets.
-cron job is recommended.
+This script will incrementally set warranty info for apple assets;
+running it as a cron job is recommended.
+
+See L<RT::Extension::Assets::AppleGSX> for the necessary RT
+configuration.
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index 5bdb4c1..fbd6faa 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -38,13 +38,11 @@ May need root permissions
=item make initdb
-Only run this the first time you install this module.
+Only run this the first time you install this module; this will create
+several custom fields for assets. If you already have custom fields for
+serial numbers and warantee information, this step is unnecessary.
-If you run this twice, you may end up with duplicate data
-in your database.
-
-If you are upgrading this module, check for upgrading instructions
-in case changes need to be made to your database.
+Running C<make initdb> twice will cause duplicate custom fields.
=item Edit your /opt/rt4/etc/RT_SiteConfig.pm
@@ -54,22 +52,39 @@ Add this line:
or add C<RT::Extension::Assets::AppleGSX> to your existing C<@Plugins> line.
-Config Apple GSX:
+=item Add additional configuration options
+
+You must configure the authentication information used to connect to GSX:
- Set(
- %AppleGSXOptions,
+ Set( %AppleGSXOptions,
UserId => 'foo at example.com',
Password => 'secret',
ServiceAccountNo => 12345,
);
-=item Clear your mason cache
+Additionally, if you are not using the supplied custom fields, you may
+wish to Set one or more of the following (their defaults are shown):
+
+ # Name of custom field containing serial number
+ Set( $AppleGSXSerialCF => "Serial Number" )
+
+ # CFs to import from GSX, and their names there
+ Set( %AppleGSXMap,
+ 'Warranty Status' => 'warrantyStatus',
+ 'Warranty Start Date' => 'coverageStartDate',
+ 'Warranty End Date' => 'coverageEndDate',
+ );
+
+ # Only attempt to import data from GSX for assets matching the
+ # following CF values:
+ Set( %AppleGSXChecks,
+ 'Trademark' => qr/\bApple(Care)?\b/i,
+ );
- rm -rf /opt/rt4/var/mason_data/obj
-=item Restart your webserver
+=item Run F</opt/rt4-assets/local/plugins/RT-Extension-Assets-AppleGSX/bin/rt-apple-gsx-set-warranty>
-=back
+You will likely wish to configure this script to run regularly, via a cron job.
=head1 AUTHOR
@@ -84,7 +99,7 @@ or L<bug-RT-Extension-Assets-AppleGSX at rt.cpan.org>.
=head1 LICENSE AND COPYRIGHT
-This software is Copyright (c) 2012 by Best Practical Solutions
+This software is Copyright (c) 2013 by Best Practical Solutions
This is free software, licensed under:
commit 27b21051d714c382bfdd4f3b0c65e47040046169
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Fri Jan 18 05:41:26 2013 -0500
Update CFs for new LookupType (and default naming)
diff --git a/etc/initialdata b/etc/initialdata
index 5522ec0..a2eb09a 100644
--- a/etc/initialdata
+++ b/etc/initialdata
@@ -1,31 +1,31 @@
@CustomFields = (
{
Name => 'Trademark',
- LookupType => 'RT::Asset',
+ LookupType => 'RT::Catalog-RT::Asset',
Type => 'Freeform',
MaxValues => 1,
},
{
Name => 'Serial Number',
- LookupType => 'RT::Asset',
+ LookupType => 'RT::Catalog-RT::Asset',
Type => 'Freeform',
MaxValues => 1,
},
{
Name => 'Warranty Status',
- LookupType => 'RT::Asset',
+ LookupType => 'RT::Catalog-RT::Asset',
Type => 'Freeform',
MaxValues => 1,
},
{
- Name => 'Coverage Start Date',
- LookupType => 'RT::Asset',
+ Name => 'Warranty Start Date',
+ LookupType => 'RT::Catalog-RT::Asset',
Type => 'Date',
MaxValues => 1,
},
{
- Name => 'Coverage End Date',
- LookupType => 'RT::Asset',
+ Name => 'Warranty End Date',
+ LookupType => 'RT::Catalog-RT::Asset',
Type => 'Date',
MaxValues => 1,
},
commit e6756eaf24123308ae12363e2c873c48d9955968
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Jan 23 14:34:24 2013 -0500
Move to a web-based credentials entry
diff --git a/html/Admin/Assets/GSX/index.html b/html/Admin/Assets/GSX/index.html
new file mode 100644
index 0000000..3a84268
--- /dev/null
+++ b/html/Admin/Assets/GSX/index.html
@@ -0,0 +1,55 @@
+<& /Admin/Elements/Header, Title => loc("Apple GSX") &>
+<& /Elements/Tabs &>
+
+% unless ($ok) {
+<&| /Widgets/TitleBox, title => loc('Authentication failure'), class => "error" &>
+Credentials below are incorrect!
+</&>
+% }
+
+<form method="post" action="<% RT->Config->Get('WebPath') %>/Admin/Assets/GSX/">
+<table>
+<tr><td class="label"><label for="UserId"><&|/l&>User ID</&></label></td>
+ <td><input name="UserId" id="UserId" value="<% $UserId %>" size="20" /></td>
+</tr>
+
+<tr><td class="label"><label for="Password"><&|/l&>Password</&></label></td>
+ <td><input name="Password" id="Password" type="password" size="20" /></td>
+</tr>
+
+<tr><td class="label"><label for="ServiceAccountNo"><&|/l&>Service Account #</&></label></td>
+ <td><input name="ServiceAccountNo" id="ServiceAccountNo" value="<% $ServiceAccountNo %>" size="20" /></td>
+</tr>
+</table>
+
+<& /Elements/Submit, Name => "Update", Label => loc('Update') &>
+</form>
+<%init>
+$m->clear_and_abort(403) unless $session{'CurrentUser'}->HasRight(
+ Object => RT->System,
+ Right => 'SuperUser',
+);
+
+my $config = RT->System->FirstAttribute('AppleGSXOptions');
+$config = $config ? $config->Content : {};
+if ($ARGS{Update}) {
+ $config->{UserId} = $UserId;
+ $config->{Password} = $Password if $Password;
+ $config->{ServiceAccountNo} = $ServiceAccountNo;
+ RT->System->SetAttribute( Name => 'AppleGSXOptions', Content => $config );
+}
+
+my $gsx = RT::Extension::Assets::AppleGSX->Client;
+my $ok = $config->{UserId}
+ && $config->{Password}
+ && $config->{ServiceAccountNo}
+ && $gsx->Authenticate;
+
+$UserId = $config->{UserId};
+$ServiceAccountNo = $config->{ServiceAccountNo};
+</%init>
+<%args>
+$UserId => ""
+$Password => ""
+$ServiceAccountNo => ""
+</%args>
diff --git a/html/Callbacks/RT-Extension-Assets-AppleGSX/Elements/Tabs/Privileged b/html/Callbacks/RT-Extension-Assets-AppleGSX/Elements/Tabs/Privileged
new file mode 100644
index 0000000..3fdbde5
--- /dev/null
+++ b/html/Callbacks/RT-Extension-Assets-AppleGSX/Elements/Tabs/Privileged
@@ -0,0 +1,10 @@
+<%init>
+return unless $session{CurrentUser}->HasRight(
+ Object => RT->System,
+ Right => 'SuperUser',
+);
+
+my $assets = Menu();
+$assets = $assets->child($_) for qw/tools config assets/;
+$assets->child(gsx => title => "Apple GSX", path => "/Admin/Assets/GSX/");
+</%init>
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index fbd6faa..6f46d05 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -1,23 +1,16 @@
use strict;
use warnings;
package RT::Extension::Assets::AppleGSX;
+use RT::Extension::Assets::AppleGSX::Client;
our $VERSION = '0.01';
-my $client;
-
-sub InitClient {
- my $class = shift;
- require RT::Extension::Assets::AppleGSX::Client;
- $client =
- RT::Extension::Assets::AppleGSX::Client->new(
- RT->Config->Get('AppleGSXOptions'),
- );
-}
-
sub Client {
- InitClient() unless $client;
- return $client;
+ my $config = RT->System->FirstAttribute('AppleGSXOptions');
+ return
+ RT::Extension::Assets::AppleGSX::Client->new(
+ $config ? $config->Content : {},
+ );
}
=head1 NAME
@@ -54,16 +47,13 @@ or add C<RT::Extension::Assets::AppleGSX> to your existing C<@Plugins> line.
=item Add additional configuration options
-You must configure the authentication information used to connect to GSX:
-
- Set( %AppleGSXOptions,
- UserId => 'foo at example.com',
- Password => 'secret',
- ServiceAccountNo => 12345,
- );
+You must configure the authentication information used to connect to GSX
+via the web UI, at Tools -> Configuration -> Assets -> Apple GSX. This
+menu option is only available to SuperUsers.
Additionally, if you are not using the supplied custom fields, you may
-wish to Set one or more of the following (their defaults are shown):
+wish to Set one or more of the following in your F<RT_SiteConfig.pm>
+(their defaults are shown):
# Name of custom field containing serial number
Set( $AppleGSXSerialCF => "Serial Number" )
commit 20b08361ec8e519c3bbf97a734afd867eda23d92
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Jan 23 14:34:45 2013 -0500
Bump version
diff --git a/META.yml b/META.yml
index baa5faf..3987404 100644
--- a/META.yml
+++ b/META.yml
@@ -17,7 +17,8 @@ name: RT-Extension-Assets-AppleGSX
no_index:
directory:
- etc
+ - html
- inc
resources:
license: http://opensource.org/licenses/gpl-license.php
-version: 0.01
+version: 0.02
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index 6f46d05..3f0d4f2 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -3,7 +3,7 @@ use warnings;
package RT::Extension::Assets::AppleGSX;
use RT::Extension::Assets::AppleGSX::Client;
-our $VERSION = '0.01';
+our $VERSION = '0.02';
sub Client {
my $config = RT->System->FirstAttribute('AppleGSXOptions');
commit e11e3776474bfed7d6671eb8e35c26386508e960
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Tue Feb 5 17:31:12 2013 -0500
Add dependencies
diff --git a/META.yml b/META.yml
index 3987404..e80ada9 100644
--- a/META.yml
+++ b/META.yml
@@ -19,6 +19,10 @@ no_index:
- etc
- html
- inc
+requires:
+ Class::Accessor::Fast: 0
+ LWP::UserAgent: 0
+ XML::Simple: 0
resources:
license: http://opensource.org/licenses/gpl-license.php
version: 0.02
diff --git a/Makefile.PL b/Makefile.PL
index 61a2e72..f55e0f0 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -6,6 +6,10 @@ all_from 'lib/RT/Extension/Assets/AppleGSX.pm';
readme_from 'lib/RT/Extension/Assets/AppleGSX.pm';
license 'gplv2';
+requires 'Class::Accessor::Fast';
+requires 'LWP::UserAgent';
+requires 'XML::Simple';
+
use Config;
my $perl_path = $Config{perlpath};
$perl_path .= $Config{_exe}
commit c1cc292de213c04fc0ff440149c19b98c94273e4
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Thu Feb 7 05:07:48 2013 -0500
Update "is it configured" for config in attributes, not RT_SiteConfig.pm
diff --git a/bin/rt-apple-gsx-set-warranty.in b/bin/rt-apple-gsx-set-warranty.in
index 0f520a1..5b8c0c2 100755
--- a/bin/rt-apple-gsx-set-warranty.in
+++ b/bin/rt-apple-gsx-set-warranty.in
@@ -22,9 +22,9 @@ if ( $opt{help} ) {
}
# Sanity check that the extension is configured
-die "AppleGSXOptions not set; please read the documentation for " .
+die "Apple GSX authentication not configured; please read the documentation for " .
"RT::Extension::Assets::AppleGSX for more on configuring this extension."
- unless RT->Config->Get('AppleGSXOptions');
+ unless RT->System->FirstAttribute('AppleGSXOptions');
my $serial_name = RT->Config->Get('AppleGSXSerialCF') || "Serial Number";
commit 9856517fa44960284f122bb85e88aa49cabcbca3
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Sat Feb 9 00:02:33 2013 -0500
Only update CF value if it differs
diff --git a/bin/rt-apple-gsx-set-warranty.in b/bin/rt-apple-gsx-set-warranty.in
index 5b8c0c2..216cd88 100755
--- a/bin/rt-apple-gsx-set-warranty.in
+++ b/bin/rt-apple-gsx-set-warranty.in
@@ -106,22 +106,19 @@ for my $asset ( values %assets ) {
my $info = $gsx->WarrantyStatus($serial);
if ( $info && $info->{warrantyDetailInfo} ) {
for my $field ( keys %$FIELDS_MAP ) {
- if ( defined $info->{warrantyDetailInfo}{ $FIELDS_MAP->{$field} } ) {
+ my $old = $asset->FirstCustomFieldValue($field);
+ my $new = $info->{warrantyDetailInfo}{ $FIELDS_MAP->{$field} };
+ if ( defined $new ) {
$asset->AddCustomFieldValue(
Field => $field,
- Value =>
- $info->{warrantyDetailInfo}{ $FIELDS_MAP->{$field} },
+ Value => $new,
+ ) if ($old || '') ne $new;
+ } elsif (defined $old) {
+ $asset->DeleteCustomFieldValue(
+ Field => $field,
+ Value => $old,
);
}
- else {
- my $old = $asset->FirstCustomFieldValue($field);
- if ( defined $old ) {
- $asset->DeleteCustomFieldValue(
- Field => $field,
- Value => $old,
- );
- }
- }
}
}
}
commit 17f3e293c94f5b372f977f77a68931eb984ab84d
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Mon Feb 11 12:48:53 2013 -0500
Fail harder and faster on improper credentials
diff --git a/bin/rt-apple-gsx-set-warranty.in b/bin/rt-apple-gsx-set-warranty.in
index 216cd88..e6981ab 100755
--- a/bin/rt-apple-gsx-set-warranty.in
+++ b/bin/rt-apple-gsx-set-warranty.in
@@ -26,6 +26,10 @@ die "Apple GSX authentication not configured; please read the documentation for
"RT::Extension::Assets::AppleGSX for more on configuring this extension."
unless RT->System->FirstAttribute('AppleGSXOptions');
+my $gsx = RT::Extension::Assets::AppleGSX->Client;
+die "Apple GSX credentials are incorrect or out-of-date; update them in " .
+ "Tools -> Configuration -> Assets -> Apple GSX"
+ unless $gsx->Authenticate;
my $serial_name = RT->Config->Get('AppleGSXSerialCF') || "Serial Number";
@@ -102,7 +106,6 @@ for my $asset ( values %assets ) {
next unless @match;
if ( my $serial = $asset->FirstCustomFieldValue($serial_name) ) {
- my $gsx = RT::Extension::Assets::AppleGSX->Client;
my $info = $gsx->WarrantyStatus($serial);
if ( $info && $info->{warrantyDetailInfo} ) {
for my $field ( keys %$FIELDS_MAP ) {
commit 69d191caca3a166d74bc58517874c59807cbdea7
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Tue Feb 12 17:00:23 2013 -0500
Provide better error messages on API failure
diff --git a/lib/RT/Extension/Assets/AppleGSX/Client.pm b/lib/RT/Extension/Assets/AppleGSX/Client.pm
index a09cf02..3eb5858 100644
--- a/lib/RT/Extension/Assets/AppleGSX/Client.pm
+++ b/lib/RT/Extension/Assets/AppleGSX/Client.pm
@@ -74,7 +74,13 @@ sub WarrantyStatus {
$res->decoded_content );
}
else {
- warn "failed to get warranty status of serial $serial";
+ my $data = eval { $xs->parse_string( $res->decoded_content, NoAttr => 1, SuppressEmpty => undef ) };
+ if ($data) {
+ warn "Failed to get Apple GSX warranty status of serial $serial: "
+ . $data->{"S:Body"}{"S:Fault"}{"faultstring"};
+ } else {
+ warn "Failed to get Apple GSX warranty status of serial $serial: ".$res->status_line;
+ }
return;
}
}
commit 9c706ed62e278407d5fba004771655925bc497c1
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Tue Feb 12 17:00:48 2013 -0500
Attempt API call repeatedly, in case incomplete data is returned
Apparently the GSX API will sometimes return results with only partial
data, omitting somewhat useful information such as the actual warranty
information requested. These failed responses can be recognized by
their lack of serialNumber, among other properties.
Make WarrantyStatus calls repeatedly until a complete response is
obtained, trying up to 5 times.
-----
An incomplete response is of the form:
<S:Envelope xmlns:S="http://schemas.xmlsoap.org/soap/envelope/">
<S:Body>
<ns3:WarrantyStatusResponse xmlns:ns3="http://gsxws.apple.com/elements/global">
<WarrantyStatusResponse>
<operationId>[redacted]</operationId>
<warrantyDetailInfo>
<serialNumber/>
<warrantyStatus/>
<coverageEndDate/>
<coverageStartDate/>
<daysRemaining>0</daysRemaining>
<estimatedPurchaseDate/>
<globalWarranty/>
<purchaseCountry/>
<registrationDate/>
<imageURL>http://service.info.apple.com/parts/service_parts/products/imac_21_mid2011.jpg</imageURL>
<explodedViewURL>http://service.info.apple.com/parts/service_parts/ev/imac_21_mid2011.ev.pdf</explodedViewURL>
<manualURL>http://download.info.apple.com/Apple_Support_Area/Misc/Service/servicemanuals/imac_21_mid11.pdf</manualURL>
<productDescription>iMac (21.5-inch, Mid 2011)</productDescription>
<configDescription>IMAC 21.5"/2.5QC/500GB/6750M CTO</configDescription>
<slaGroupDescription/>
<ecorathFlag/>
<powerTrainFlag/>
<triCareFlag/>
<contractCoverageEndDate/>
<contractCoverageStartDate/>
<contractType/>
<laborCovered/>
<limitedWarranty/>
<partCovered/>
<warrantyReferenceNo/>
<isPersonalized/>
<acPlusFlag/>
</warrantyDetailInfo>
<communicationMessage/>
</WarrantyStatusResponse>
</ns3:WarrantyStatusResponse>
</S:Body>
</S:Envelope>
diff --git a/lib/RT/Extension/Assets/AppleGSX/Client.pm b/lib/RT/Extension/Assets/AppleGSX/Client.pm
index 3eb5858..6778e0f 100644
--- a/lib/RT/Extension/Assets/AppleGSX/Client.pm
+++ b/lib/RT/Extension/Assets/AppleGSX/Client.pm
@@ -68,21 +68,24 @@ sub WarrantyStatus {
}
);
- my $res = $self->SendRequest($xml);
- if ( $res->is_success ) {
- return $self->ParseResponseXML( 'WarrantyStatus',
- $res->decoded_content );
- }
- else {
- my $data = eval { $xs->parse_string( $res->decoded_content, NoAttr => 1, SuppressEmpty => undef ) };
- if ($data) {
- warn "Failed to get Apple GSX warranty status of serial $serial: "
- . $data->{"S:Body"}{"S:Fault"}{"faultstring"};
- } else {
- warn "Failed to get Apple GSX warranty status of serial $serial: ".$res->status_line;
+ for my $try (1..5) {
+ my $res = $self->SendRequest($xml);
+ unless ($res->is_success) {
+ my $data = eval {$xs->parse_string( $res->decoded_content, NoAttr => 1, SuppressEmpty => undef ) };
+ if ($data) {
+ warn "Failed to get Apple GSX warranty status of serial $serial: "
+ . $data->{"S:Body"}{"S:Fault"}{"faultstring"};
+ } else {
+ warn "Failed to get Apple GSX warranty status of serial $serial: ".$res->status_line;
+ }
+ return;
}
- return;
+
+ my $ret = $self->ParseResponseXML( 'WarrantyStatus', $res->decoded_content );
+ return $ret if $ret->{warrantyDetailInfo} and $ret->{warrantyDetailInfo}{serialNumber};
}
+ warn "Repeatedly failed to get complete response from Apple GSX for serial $serial";
+ return;
}
sub PrepareXML {
commit 767876665e8906119cd174b4892933753fb0a431
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Tue Feb 12 17:08:59 2013 -0500
Short-circuit, now that ->WarrantyStatus is either valid or undef
diff --git a/bin/rt-apple-gsx-set-warranty.in b/bin/rt-apple-gsx-set-warranty.in
index e6981ab..82cdee2 100755
--- a/bin/rt-apple-gsx-set-warranty.in
+++ b/bin/rt-apple-gsx-set-warranty.in
@@ -107,21 +107,20 @@ for my $asset ( values %assets ) {
if ( my $serial = $asset->FirstCustomFieldValue($serial_name) ) {
my $info = $gsx->WarrantyStatus($serial);
- if ( $info && $info->{warrantyDetailInfo} ) {
- for my $field ( keys %$FIELDS_MAP ) {
- my $old = $asset->FirstCustomFieldValue($field);
- my $new = $info->{warrantyDetailInfo}{ $FIELDS_MAP->{$field} };
- if ( defined $new ) {
- $asset->AddCustomFieldValue(
- Field => $field,
- Value => $new,
- ) if ($old || '') ne $new;
- } elsif (defined $old) {
- $asset->DeleteCustomFieldValue(
- Field => $field,
- Value => $old,
- );
- }
+ next unless $info;
+ for my $field ( keys %$FIELDS_MAP ) {
+ my $old = $asset->FirstCustomFieldValue($field);
+ my $new = $info->{warrantyDetailInfo}{ $FIELDS_MAP->{$field} };
+ if ( defined $new ) {
+ $asset->AddCustomFieldValue(
+ Field => $field,
+ Value => $new,
+ ) if ($old || '') ne $new;
+ } elsif (defined $old) {
+ $asset->DeleteCustomFieldValue(
+ Field => $field,
+ Value => $old,
+ );
}
}
}
commit ba4a8bbfcc957e91c57eb1c91400c4e08b537d2e
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Tue Feb 12 17:23:15 2013 -0500
GSX returns data in mm/dd/yy format -- force Time::ParseDate accordingly
diff --git a/bin/rt-apple-gsx-set-warranty.in b/bin/rt-apple-gsx-set-warranty.in
index 82cdee2..87e8162 100755
--- a/bin/rt-apple-gsx-set-warranty.in
+++ b/bin/rt-apple-gsx-set-warranty.in
@@ -99,6 +99,9 @@ while ( my $txn = $txns->Next ) {
$assets{$txn->ObjectId} ||= $txn->Object;
}
+# GSX returns everything in mm/dd/yy format
+RT->Config->Set( 'DateDayBeforeMonth' => 0 );
+
for my $asset ( values %assets ) {
my @match = grep {$_->[1] and $_->[1] =~ /$CHECKS->{$_->[0]}/}
map {[$_, $asset->FirstCustomFieldValue($_)]}
commit 11645a5edd1eb0361dd7fb766a6013a8121c0585
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Tue Feb 12 17:24:03 2013 -0500
To prevent no-op date changes in history, canonicalize dates before checking $old eq $new
diff --git a/bin/rt-apple-gsx-set-warranty.in b/bin/rt-apple-gsx-set-warranty.in
index 87e8162..106b7c2 100755
--- a/bin/rt-apple-gsx-set-warranty.in
+++ b/bin/rt-apple-gsx-set-warranty.in
@@ -115,6 +115,14 @@ for my $asset ( values %assets ) {
my $old = $asset->FirstCustomFieldValue($field);
my $new = $info->{warrantyDetailInfo}{ $FIELDS_MAP->{$field} };
if ( defined $new ) {
+ # Canonicalize date and datetime CFs
+ if ($asset->LoadCustomFieldByIdentifier($field)->Type =~ /^date(time)?/i) {
+ my $datetime = $1;
+ my $date = RT::Date->new( RT->SystemUser );
+ $date->Set( Format => 'unknown', Value => $new );
+ $new = $datetime ? $date->DateTime : $date->Date;
+ }
+
$asset->AddCustomFieldValue(
Field => $field,
Value => $new,
commit cbb4a3fc961ea4e88c8000495106eba9719a1ce3
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Mon Feb 25 17:41:28 2013 -0500
Update to a more modern RTx::Factory
diff --git a/inc/Module/Install/RTx/Factory.pm b/inc/Module/Install/RTx/Factory.pm
index a8702e4..76ab761 100644
--- a/inc/Module/Install/RTx/Factory.pm
+++ b/inc/Module/Install/RTx/Factory.pm
@@ -34,7 +34,7 @@ sub RTxInitDB {
"--action" => $action,
"--datadir" => "etc",
(($action eq 'insert') ? ("--datafile" => "etc/initialdata") : ()),
- "--dba" => $RT::DatabaseUser,
+ "--dba" => $RT::DatabaseAdmin || $RT::DatabaseUser,
"--prompt-for-dba-password" => '',
(RT::System->can('AddUpgradeHistory') ? ("--package" => $name, "--ext-version" => $version) : ()),
);
commit 8f6f2103a378c71a8ccf38435870b84eb8a9f212
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Tue Feb 26 15:35:06 2013 -0500
Update Module::Install::RTx
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
index ce01018..abf6aea 100644
--- a/inc/Module/Install/RTx.pm
+++ b/inc/Module/Install/RTx.pm
@@ -14,7 +14,7 @@ use FindBin;
use File::Glob ();
use File::Basename ();
-my @DIRS = qw(etc lib html bin sbin po var);
+my @DIRS = qw(etc lib html static bin sbin po var);
my @INDEX_DIRS = qw(lib bin sbin);
sub RTx {
@@ -62,10 +62,11 @@ sub RTx {
unshift @INC, "$RT::LocalPath/lib" if $RT::LocalPath;
unshift @INC, $lib_path;
- $RT::LocalVarPath ||= $RT::VarPath;
- $RT::LocalPoPath ||= $RT::LocalLexiconPath;
- $RT::LocalHtmlPath ||= $RT::MasonComponentRoot;
- $RT::LocalLibPath ||= "$RT::LocalPath/lib";
+ $RT::LocalVarPath ||= $RT::VarPath;
+ $RT::LocalPoPath ||= $RT::LocalLexiconPath;
+ $RT::LocalHtmlPath ||= $RT::MasonComponentRoot;
+ $RT::LocalStaticPath ||= $RT::StaticPath;
+ $RT::LocalLibPath ||= "$RT::LocalPath/lib";
my $with_subdirs = $ENV{WITH_SUBDIRS};
@ARGV = grep { /WITH_SUBDIRS=(.*)/ ? ( ( $with_subdirs = $1 ), 0 ) : 1 }
@@ -208,4 +209,4 @@ sub requires_rt {
__END__
-#line 328
+#line 329
commit 2a3983358f969c336abf435eec083b6055332ba5
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Feb 27 19:49:11 2013 -0500
Cache Client objects
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index 3f0d4f2..b096d28 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -5,12 +5,20 @@ use RT::Extension::Assets::AppleGSX::Client;
our $VERSION = '0.02';
+my $CLIENT;
+my $CLIENT_CACHE;
sub Client {
my $config = RT->System->FirstAttribute('AppleGSXOptions');
- return
- RT::Extension::Assets::AppleGSX::Client->new(
+ undef $CLIENT
+ if $CLIENT_CACHE and $config and $config->LastUpdatedObj->Unix > $CLIENT_CACHE;
+
+ unless ($CLIENT) {
+ $CLIENT = RT::Extension::Assets::AppleGSX::Client->new(
$config ? $config->Content : {},
);
+ $CLIENT_CACHE = $config ? $config->LastUpdatedObj->Unix : -1;
+ }
+ return $CLIENT;
}
=head1 NAME
commit b0925c76f941ff5ac47927384a85a8b6178b93a2
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Feb 27 19:53:31 2013 -0500
Refactor defaults
These are not simply provided in an etc/ file, because doing so makes it
impossible to override the values in a later plugin.
diff --git a/bin/rt-apple-gsx-set-warranty.in b/bin/rt-apple-gsx-set-warranty.in
index 106b7c2..fac6291 100755
--- a/bin/rt-apple-gsx-set-warranty.in
+++ b/bin/rt-apple-gsx-set-warranty.in
@@ -31,17 +31,9 @@ die "Apple GSX credentials are incorrect or out-of-date; update them in " .
"Tools -> Configuration -> Assets -> Apple GSX"
unless $gsx->Authenticate;
-my $serial_name = RT->Config->Get('AppleGSXSerialCF') || "Serial Number";
-
-my $FIELDS_MAP = RT->Config->Get('AppleGSXMap') || {
- 'Warranty Status' => 'warrantyStatus',
- 'Warranty Start Date' => 'coverageStartDate',
- 'Warranty End Date' => 'coverageEndDate',
-};
-
-my $CHECKS = RT->Config->Get('AppleGSXChecks') || {
- 'Trademark' => qr/\bApple(Care)?\b/i,
-};
+my $serial_name = RT::Extension::Assets::AppleGSX->SerialCF;
+my $FIELDS_MAP = RT::Extension::Assets::AppleGSX->Fields;
+my $CHECKS = RT::Extension::Assets::AppleGSX->Checks;
# Check that all of the CFs we reference exist
for my $cfname ($serial_name, keys(%$FIELDS_MAP), keys(%$CHECKS)) {
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index b096d28..452ee02 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -21,6 +21,24 @@ sub Client {
return $CLIENT;
}
+sub SerialCF {
+ return RT->Config->Get('AppleGSXSerialCF') || "Serial Number";
+}
+
+sub Fields {
+ return RT->Config->Get('AppleGSXMap') || {
+ 'Warranty Status' => 'warrantyStatus',
+ 'Warranty Start Date' => 'coverageStartDate',
+ 'Warranty End Date' => 'coverageEndDate',
+ };
+}
+
+sub Checks {
+ return RT->Config->Get('AppleGSXChecks') || {
+ 'Trademark' => qr/\bApple(Care)?\b/i,
+ }
+}
+
=head1 NAME
RT-Extension-Assets-AppleGSX - Apple GSX for RT Assets
commit 8135b96666f176865725e9e1d9766fcc2760dd77
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Feb 27 19:54:40 2013 -0500
Refactor GSX updating into a method on Assets
diff --git a/bin/rt-apple-gsx-set-warranty.in b/bin/rt-apple-gsx-set-warranty.in
index fac6291..cb083cf 100755
--- a/bin/rt-apple-gsx-set-warranty.in
+++ b/bin/rt-apple-gsx-set-warranty.in
@@ -91,54 +91,7 @@ while ( my $txn = $txns->Next ) {
$assets{$txn->ObjectId} ||= $txn->Object;
}
-# GSX returns everything in mm/dd/yy format
-RT->Config->Set( 'DateDayBeforeMonth' => 0 );
-
-for my $asset ( values %assets ) {
- my @match = grep {$_->[1] and $_->[1] =~ /$CHECKS->{$_->[0]}/}
- map {[$_, $asset->FirstCustomFieldValue($_)]}
- keys %$CHECKS;
- next unless @match;
-
- if ( my $serial = $asset->FirstCustomFieldValue($serial_name) ) {
- my $info = $gsx->WarrantyStatus($serial);
- next unless $info;
- for my $field ( keys %$FIELDS_MAP ) {
- my $old = $asset->FirstCustomFieldValue($field);
- my $new = $info->{warrantyDetailInfo}{ $FIELDS_MAP->{$field} };
- if ( defined $new ) {
- # Canonicalize date and datetime CFs
- if ($asset->LoadCustomFieldByIdentifier($field)->Type =~ /^date(time)?/i) {
- my $datetime = $1;
- my $date = RT::Date->new( RT->SystemUser );
- $date->Set( Format => 'unknown', Value => $new );
- $new = $datetime ? $date->DateTime : $date->Date;
- }
-
- $asset->AddCustomFieldValue(
- Field => $field,
- Value => $new,
- ) if ($old || '') ne $new;
- } elsif (defined $old) {
- $asset->DeleteCustomFieldValue(
- Field => $field,
- Value => $old,
- );
- }
- }
- }
- else {
- for my $field ( keys %$FIELDS_MAP ) {
- my $old = $asset->FirstCustomFieldValue($field);
- if ( defined $old ) {
- $asset->DeleteCustomFieldValue(
- Field => $field,
- Value => $old,
- );
- }
- }
- }
-}
+$_->UpdateGSX for values %assets;
$attr->SetContent($txns->Last->id) if $txns->Last;
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index 452ee02..4f0907e 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -39,6 +39,62 @@ sub Checks {
}
}
+package RT::Asset;
+
+sub UpdateGSX {
+ my $self = shift;
+
+ # GSX returns everything in mm/dd/yy format
+ local $RT::DateDayBeforeMonth = 0;
+
+ my $serial_name = RT::Extension::Assets::AppleGSX->SerialCF;
+ my $FIELDS_MAP = RT::Extension::Assets::AppleGSX->Fields;
+ my $CHECKS = RT::Extension::Assets::AppleGSX->Checks;
+
+ my @match = grep {$_->[1] and $_->[1] =~ /$CHECKS->{$_->[0]}/}
+ map {[$_, $self->FirstCustomFieldValue($_)]}
+ keys %$CHECKS;
+ return unless @match;
+
+ if ( my $serial = $self->FirstCustomFieldValue($serial_name) ) {
+ my $info = $CLIENT->WarrantyStatus($serial);
+ return unless $info;
+ for my $field ( keys %$FIELDS_MAP ) {
+ my $old = $self->FirstCustomFieldValue($field);
+ my $new = $info->{warrantyDetailInfo}{ $FIELDS_MAP->{$field} };
+ if ( defined $new ) {
+ # Canonicalize date and datetime CFs
+ if ($self->LoadCustomFieldByIdentifier($field)->Type =~ /^date(time)?/i) {
+ my $datetime = $1;
+ my $date = RT::Date->new( RT->SystemUser );
+ $date->Set( Format => 'unknown', Value => $new );
+ $new = $datetime ? $date->DateTime : $date->Date;
+ }
+ $self->AddCustomFieldValue(
+ Field => $field,
+ Value => $new,
+ ) if ($old||'') ne $new;
+ } elsif (defined $old) {
+ $self->DeleteCustomFieldValue(
+ Field => $field,
+ Value => $old,
+ );
+ }
+ }
+ }
+ else {
+ for my $field ( keys %$FIELDS_MAP ) {
+ my $old = $self->FirstCustomFieldValue($field);
+ if ( defined $old ) {
+ $self->DeleteCustomFieldValue(
+ Field => $field,
+ Value => $old,
+ );
+ }
+ }
+ }
+}
+
=head1 NAME
RT-Extension-Assets-AppleGSX - Apple GSX for RT Assets
commit 35a3eb8e18aa98be7ccb90436f908753d3e34a96
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Feb 27 19:54:58 2013 -0500
Ensure that we do not spuriously update 0-valued CFs
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index 4f0907e..0b98991 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -61,6 +61,7 @@ sub UpdateGSX {
return unless $info;
for my $field ( keys %$FIELDS_MAP ) {
my $old = $self->FirstCustomFieldValue($field);
+ $old = '' unless defined $old;
my $new = $info->{warrantyDetailInfo}{ $FIELDS_MAP->{$field} };
if ( defined $new ) {
# Canonicalize date and datetime CFs
@@ -73,7 +74,7 @@ sub UpdateGSX {
$self->AddCustomFieldValue(
Field => $field,
Value => $new,
- ) if ($old||'') ne $new;
+ ) if $old ne $new;
} elsif (defined $old) {
$self->DeleteCustomFieldValue(
Field => $field,
commit 36a14e990a5899203aec30bb3fc611a7902fd99f
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Feb 27 19:56:56 2013 -0500
Import GSX data on asset creation
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index 0b98991..a7827c4 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -39,6 +39,24 @@ sub Checks {
}
}
+{
+ my $old_create = \&RT::Asset::Create;
+ no warnings 'redefine';
+ *RT::Asset::Create = sub {
+ my $self = shift;
+ my @ret = $old_create->($self, @_);
+ return @ret unless $ret[0];
+
+ RT::Extension::Assets::AppleGSX->Client;
+ unless ($CLIENT->Authenticate) {
+ push @ret, "GSX credentials out of date; cannot import data";
+ return @ret;
+ }
+ $self->UpdateGSX;
+ return @ret;
+ };
+}
+
package RT::Asset;
sub UpdateGSX {
commit c9456bc7ce61932c33219183d0d9c26575680586
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Wed Feb 27 19:59:14 2013 -0500
We need to update all assets, in case GSX information changed but we didn't
diff --git a/bin/rt-apple-gsx-set-warranty.in b/bin/rt-apple-gsx-set-warranty.in
index cb083cf..f7bbd71 100755
--- a/bin/rt-apple-gsx-set-warranty.in
+++ b/bin/rt-apple-gsx-set-warranty.in
@@ -42,59 +42,12 @@ for my $cfname ($serial_name, keys(%$FIELDS_MAP), keys(%$CHECKS)) {
die "Custom Field '$cfname' not found" unless $cf->id;
}
-
-my $attr = RT::Attribute->new( RT->SystemUser );
-$attr->LoadByNameAndObject( Name => 'AppleGSXTransactionId', Object => RT->System );
-unless ( $attr->id ) {
- $attr->Create( Name => 'AppleGSXTransactionId', Object => RT->System );
-}
-
-
-my $serial_cf = RT::CustomField->new(RT->SystemUser);
-$serial_cf->Load($serial_name);
-
-my $last_txn_id = $attr->Content;
-my $txns = RT::Transactions->new(RT->SystemUser);
-$txns->Limit(
- FIELD => 'ObjectType',
- VALUE => 'RT::Asset',
-);
-
-$txns->Limit(
- FIELD => 'id',
- VALUE => $last_txn_id,
- OPERATOR => '>',
-) if $last_txn_id;
-
-$txns->Limit(
- FIELD => 'Type',
- VALUE => 'Create',
- SUBCLAUSE => 'Set',
-);
-
-$txns->Limit(
- FIELD => 'Type',
- VALUE => 'CustomField',
- SUBCLAUSE => 'Set',
- ENTRYAGGREGATOR => 'OR',
-);
-
-$txns->Limit(
- FIELD => 'Field',
- VALUE => $serial_cf->id,
- SUBCLAUSE => 'Set',
- ENTRYAGGREGATOR => 'AND',
-);
-
-my %assets;
-while ( my $txn = $txns->Next ) {
- $assets{$txn->ObjectId} ||= $txn->Object;
+my $assets = RT::Assets->new( RT->SystemUser );
+$assets->UnLimit;
+while (my $asset = $assets->Next) {
+ $asset->UpdateGSX;
}
-$_->UpdateGSX for values %assets;
-
-$attr->SetContent($txns->Last->id) if $txns->Last;
-
__END__
=head1 NAME
commit 28228145e268c126fa896a6d6ba1fbefab5921d3
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Thu Mar 7 16:03:34 2013 -0500
Make UpdateGSX return useful result values
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index a7827c4..4059ecd 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -72,11 +72,15 @@ sub UpdateGSX {
my @match = grep {$_->[1] and $_->[1] =~ /$CHECKS->{$_->[0]}/}
map {[$_, $self->FirstCustomFieldValue($_)]}
keys %$CHECKS;
- return unless @match;
+ return (0, "GSX does not apply (check ".join(", ",sort keys %$CHECKS)."?)")
+ unless @match;
if ( my $serial = $self->FirstCustomFieldValue($serial_name) ) {
my $info = $CLIENT->WarrantyStatus($serial);
- return unless $info;
+ return (0, "GSX contains no information (check $serial_name?)")
+ unless $info;
+
+ my @results;
for my $field ( keys %$FIELDS_MAP ) {
my $old = $self->FirstCustomFieldValue($field);
$old = '' unless defined $old;
@@ -89,28 +93,36 @@ sub UpdateGSX {
$date->Set( Format => 'unknown', Value => $new );
$new = $datetime ? $date->DateTime : $date->Date;
}
- $self->AddCustomFieldValue(
- Field => $field,
- Value => $new,
- ) if $old ne $new;
+ if ($old ne $new) {
+ my ($ok, $msg) = $self->AddCustomFieldValue(
+ Field => $field,
+ Value => $new,
+ );
+ push @results, $msg;
+ }
} elsif (defined $old) {
- $self->DeleteCustomFieldValue(
+ my ($ok, $msg) = $self->DeleteCustomFieldValue(
Field => $field,
Value => $old,
);
+ push @results, $msg;
}
}
+ return (1, @results);
}
else {
+ my @results;
for my $field ( keys %$FIELDS_MAP ) {
my $old = $self->FirstCustomFieldValue($field);
if ( defined $old ) {
- $self->DeleteCustomFieldValue(
+ my ($ok, $msg) = $self->DeleteCustomFieldValue(
Field => $field,
Value => $old,
);
+ push @results, $msg;
}
}
+ return (1, @results);
}
}
commit 0eeae399b74d718722194f450e9bedcbdb61317e
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Thu Mar 7 16:04:09 2013 -0500
Add an "Update from Apple GSX" button
diff --git a/html/Callbacks/RT-Extension-Assets-AppleGSX/Asset/Display.html/BeforeDisplay b/html/Callbacks/RT-Extension-Assets-AppleGSX/Asset/Display.html/BeforeDisplay
new file mode 100644
index 0000000..13dce81
--- /dev/null
+++ b/html/Callbacks/RT-Extension-Assets-AppleGSX/Asset/Display.html/BeforeDisplay
@@ -0,0 +1,14 @@
+<%init>
+if ( $ARGSRef->{AppleGSXUpdate} ) {
+ my ($ok, @results) = $Asset->UpdateGSX;
+ MaybeRedirectForResults(
+ Actions => \@results,
+ Arguments => { id => $Asset->id }
+ );
+}
+</%init>
+
+<%args>
+$ARGSRef
+$Asset
+</%args>
diff --git a/html/Callbacks/RT-Extension-Assets-AppleGSX/Elements/Tabs/Privileged b/html/Callbacks/RT-Extension-Assets-AppleGSX/Elements/Tabs/Privileged
index 3fdbde5..486c16a 100644
--- a/html/Callbacks/RT-Extension-Assets-AppleGSX/Elements/Tabs/Privileged
+++ b/html/Callbacks/RT-Extension-Assets-AppleGSX/Elements/Tabs/Privileged
@@ -1,10 +1,25 @@
<%init>
-return unless $session{CurrentUser}->HasRight(
- Object => RT->System,
- Right => 'SuperUser',
+if ($session{CurrentUser}->HasRight(Object => RT->System, Right => 'SuperUser')) {
+ my $assets = Menu();
+ $assets = $assets->child($_) for qw/tools config assets/;
+ $assets->child(gsx => title => "Apple GSX", path => "/Admin/Assets/GSX/");
+}
+
+
+my $request = $r->path_info;
+ $request =~ s{/+}{/}g;
+
+return unless $request =~ m{^/Asset/};
+my $id = $DECODED_ARGS->{id};
+return unless $id and $id =~ /^\d+$/;
+
+my $asset = RT::Asset->new( $session{CurrentUser} );
+my ($ok, $msg) = $asset->Load($id);
+return unless $asset->id;
+
+PageMenu()->child("actions")->child( "applegsx",
+ title => loc("Update from Apple GSX"),
+ path => "/Asset/Display.html?id=$id&AppleGSXUpdate=1"
);
-my $assets = Menu();
-$assets = $assets->child($_) for qw/tools config assets/;
-$assets->child(gsx => title => "Apple GSX", path => "/Admin/Assets/GSX/");
</%init>
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index 4059ecd..0d9cde7 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -75,6 +75,8 @@ sub UpdateGSX {
return (0, "GSX does not apply (check ".join(", ",sort keys %$CHECKS)."?)")
unless @match;
+ RT::Extension::Assets::AppleGSX->Client;
+
if ( my $serial = $self->FirstCustomFieldValue($serial_name) ) {
my $info = $CLIENT->WarrantyStatus($serial);
return (0, "GSX contains no information (check $serial_name?)")
commit fc76591ba7e48ef78e1bb4a694875c35f9d3dcca
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Thu Mar 7 16:25:07 2013 -0500
Add a return value and message for if credentials are missing or wrong
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index 0d9cde7..26ce6a3 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -77,6 +77,9 @@ sub UpdateGSX {
RT::Extension::Assets::AppleGSX->Client;
+ return (0, "GSX credentials out of date; cannot import data")
+ unless $CLIENT->Authenticate;
+
if ( my $serial = $self->FirstCustomFieldValue($serial_name) ) {
my $info = $CLIENT->WarrantyStatus($serial);
return (0, "GSX contains no information (check $serial_name?)")
commit 0e3d05fa31b572774ece474411d200a59e8f5011
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Thu Mar 7 16:26:10 2013 -0500
defined($old) was always true, due to the placement of the $old ||= ''
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index 26ce6a3..54d984c 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -88,7 +88,6 @@ sub UpdateGSX {
my @results;
for my $field ( keys %$FIELDS_MAP ) {
my $old = $self->FirstCustomFieldValue($field);
- $old = '' unless defined $old;
my $new = $info->{warrantyDetailInfo}{ $FIELDS_MAP->{$field} };
if ( defined $new ) {
# Canonicalize date and datetime CFs
@@ -98,6 +97,7 @@ sub UpdateGSX {
$date->Set( Format => 'unknown', Value => $new );
$new = $datetime ? $date->DateTime : $date->Date;
}
+ $old = '' unless defined $old;
if ($old ne $new) {
my ($ok, $msg) = $self->AddCustomFieldValue(
Field => $field,
commit 4784890b15279330b7c05c8343b46de609ba4f6c
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Thu Mar 7 16:26:40 2013 -0500
local($RT::DateDayBeforeMonth) does not work during server runtime (?)
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index 54d984c..32619b2 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -62,9 +62,6 @@ package RT::Asset;
sub UpdateGSX {
my $self = shift;
- # GSX returns everything in mm/dd/yy format
- local $RT::DateDayBeforeMonth = 0;
-
my $serial_name = RT::Extension::Assets::AppleGSX->SerialCF;
my $FIELDS_MAP = RT::Extension::Assets::AppleGSX->Fields;
my $CHECKS = RT::Extension::Assets::AppleGSX->Checks;
@@ -85,6 +82,13 @@ sub UpdateGSX {
return (0, "GSX contains no information (check $serial_name?)")
unless $info;
+ # GSX returns everything in mm/dd/yy format. Sadly, local'ing
+ # $RT::DateDayBeforeMonth is insufficient (?!). We set it back,
+ # below; ensure that this function does not return between these
+ # two statements!
+ my $date_order = RT->Config->Get("DateDayBeforeMonth");
+ RT->Config->Set("DateDayBeforeMonth" => 0);
+
my @results;
for my $field ( keys %$FIELDS_MAP ) {
my $old = $self->FirstCustomFieldValue($field);
@@ -113,6 +117,9 @@ sub UpdateGSX {
push @results, $msg;
}
}
+
+ RT->Config->Set("DateDayBeforeMonth" => $date_order);
+
return (1, @results);
}
else {
commit 182f499c4aca697a987da5b2d7ef7ae69b34d34e
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Fri Mar 22 10:52:30 2013 -0700
Only attempt GSX auth during Create if relevant
This removes a number of unnecessary warning messages during creation of
non-Apple assets if GSX has not been configured yet.
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index 32619b2..aa88864 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -45,20 +45,26 @@ sub Checks {
*RT::Asset::Create = sub {
my $self = shift;
my @ret = $old_create->($self, @_);
- return @ret unless $ret[0];
+ return @ret unless $ret[0] and $self->GSXApplies;
- RT::Extension::Assets::AppleGSX->Client;
- unless ($CLIENT->Authenticate) {
- push @ret, "GSX credentials out of date; cannot import data";
- return @ret;
- }
- $self->UpdateGSX;
+ my ($ok, @extra) = $self->UpdateGSX;
+ push @ret, @extra unless $ok;
return @ret;
};
}
package RT::Asset;
+sub GSXApplies {
+ my $self = shift;
+ my $CHECKS = RT::Extension::Assets::AppleGSX->Checks;
+
+ my @match = grep {$_->[1] and $_->[1] =~ /$CHECKS->{$_->[0]}/}
+ map {[$_, $self->FirstCustomFieldValue($_)]}
+ keys %$CHECKS;
+ return scalar @match;
+}
+
sub UpdateGSX {
my $self = shift;
@@ -66,11 +72,8 @@ sub UpdateGSX {
my $FIELDS_MAP = RT::Extension::Assets::AppleGSX->Fields;
my $CHECKS = RT::Extension::Assets::AppleGSX->Checks;
- my @match = grep {$_->[1] and $_->[1] =~ /$CHECKS->{$_->[0]}/}
- map {[$_, $self->FirstCustomFieldValue($_)]}
- keys %$CHECKS;
return (0, "GSX does not apply (check ".join(", ",sort keys %$CHECKS)."?)")
- unless @match;
+ unless $self->GSXApplies;
RT::Extension::Assets::AppleGSX->Client;
commit 347d79cc133b55cbbc2b59c0d427de31efa19b13
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Fri May 17 20:14:57 2013 -0400
Updates for new 4.2 menu organization
diff --git a/html/Callbacks/RT-Extension-Assets-AppleGSX/Elements/Tabs/Privileged b/html/Callbacks/RT-Extension-Assets-AppleGSX/Elements/Tabs/Privileged
index 486c16a..17b3d1f 100644
--- a/html/Callbacks/RT-Extension-Assets-AppleGSX/Elements/Tabs/Privileged
+++ b/html/Callbacks/RT-Extension-Assets-AppleGSX/Elements/Tabs/Privileged
@@ -1,7 +1,7 @@
<%init>
if ($session{CurrentUser}->HasRight(Object => RT->System, Right => 'SuperUser')) {
my $assets = Menu();
- $assets = $assets->child($_) for qw/tools config assets/;
+ $assets = $assets->child($_) for qw/admin assets/;
$assets->child(gsx => title => "Apple GSX", path => "/Admin/Assets/GSX/");
}
commit 4a0305f92de0f923ec39d1bdf498769fca18e716
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Tue May 28 20:37:18 2013 -0400
Avoid errors if the CF does not apply
diff --git a/lib/RT/Extension/Assets/AppleGSX.pm b/lib/RT/Extension/Assets/AppleGSX.pm
index aa88864..185d542 100644
--- a/lib/RT/Extension/Assets/AppleGSX.pm
+++ b/lib/RT/Extension/Assets/AppleGSX.pm
@@ -59,10 +59,12 @@ sub GSXApplies {
my $self = shift;
my $CHECKS = RT::Extension::Assets::AppleGSX->Checks;
- my @match = grep {$_->[1] and $_->[1] =~ /$CHECKS->{$_->[0]}/}
- map {[$_, $self->FirstCustomFieldValue($_)]}
- keys %$CHECKS;
- return scalar @match;
+ for my $check (keys %$CHECKS) {
+ next unless $self->LoadCustomFieldByIdentifier( $check )->id;
+ my $value = $self->FirstCustomFieldValue($check);
+ return 1 if defined $value and $value =~ /$CHECKS->{$check}/;
+ }
+ return 0;
}
sub UpdateGSX {
commit f710eed05564a9cced4479aeaf15aae4454b6a20
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Mon Aug 5 20:48:06 2013 -0400
Bump Module::Install::RTx
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
index abf6aea..c9fe996 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.30';
+our $VERSION = '0.31';
use FindBin;
use File::Glob ();
commit ffe6dec9ace2064cfd3019bb3f13ec1c76b515d9
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Mon Aug 5 20:48:43 2013 -0400
Silence two common forms of error that don't need to be warnings in the logs
diff --git a/lib/RT/Extension/Assets/AppleGSX/Client.pm b/lib/RT/Extension/Assets/AppleGSX/Client.pm
index 6778e0f..69bf117 100644
--- a/lib/RT/Extension/Assets/AppleGSX/Client.pm
+++ b/lib/RT/Extension/Assets/AppleGSX/Client.pm
@@ -72,11 +72,13 @@ sub WarrantyStatus {
my $res = $self->SendRequest($xml);
unless ($res->is_success) {
my $data = eval {$xs->parse_string( $res->decoded_content, NoAttr => 1, SuppressEmpty => undef ) };
- if ($data) {
- warn "Failed to get Apple GSX warranty status of serial $serial: "
- . $data->{"S:Body"}{"S:Fault"}{"faultstring"};
+ my $fault = $data ? $data->{"S:Body"}{"S:Fault"}{"faultstring"} : $res->status_line;
+ if ($fault =~ /^The serial number entered has been marked as obsolete/) {
+ # no-op
+ } elsif ($fault =~ /^The serial you entered is not valid/) {
+ # no-op
} else {
- warn "Failed to get Apple GSX warranty status of serial $serial: ".$res->status_line;
+ warn "Failed to get Apple GSX warranty status of serial $serial: $fault";
}
return;
}
commit 26c474e0e0f49793c4b9a66be85241de11f4d4a1
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Tue Sep 24 14:20:22 2013 -0400
Update inc/
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
index c9fe996..ac04c79 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.31';
+our $VERSION = '0.32';
use FindBin;
use File::Glob ();
@@ -136,6 +136,7 @@ install ::
$has_etc{acl}++;
}
if ( -e 'etc/initialdata' ) { $has_etc{initialdata}++; }
+ if ( -d 'etc/upgrade/' ) { $has_etc{upgrade}++; }
$self->postamble("$postamble\n");
unless ( $subdirs{'lib'} ) {
@@ -164,6 +165,12 @@ install ::
.
$self->postamble("initdb ::\n$initdb\n");
$self->postamble("initialize-database ::\n$initdb\n");
+ if ($has_etc{upgrade}) {
+ print "To upgrade from a previous version of this extension, use 'make upgrade-database'\n";
+ my $upgradedb = qq|\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(upgrade \$(NAME) \$(VERSION)))"\n|;
+ $self->postamble("upgrade-database ::\n$upgradedb\n");
+ $self->postamble("upgradedb ::\n$upgradedb\n");
+ }
}
}
@@ -209,4 +216,4 @@ sub requires_rt {
__END__
-#line 329
+#line 336
diff --git a/inc/Module/Install/RTx/Factory.pm b/inc/Module/Install/RTx/Factory.pm
index 76ab761..6776688 100644
--- a/inc/Module/Install/RTx/Factory.pm
+++ b/inc/Module/Install/RTx/Factory.pm
@@ -32,12 +32,19 @@ sub RTxInitDB {
"-I$lib_path",
"$RT::SbinPath/rt-setup-database",
"--action" => $action,
- "--datadir" => "etc",
+ ($action eq 'upgrade' ? () : ("--datadir" => "etc")),
(($action eq 'insert') ? ("--datafile" => "etc/initialdata") : ()),
"--dba" => $RT::DatabaseAdmin || $RT::DatabaseUser,
"--prompt-for-dba-password" => '',
(RT::System->can('AddUpgradeHistory') ? ("--package" => $name, "--ext-version" => $version) : ()),
);
+ # If we're upgrading against an RT which isn't at least 4.2 (has
+ # AddUpgradeHistory) then pass --package. Upgrades against later RT
+ # releases will pick up --package from AddUpgradeHistory.
+ if ($action eq 'upgrade' and
+ not RT::System->can('AddUpgradeHistory')) {
+ push @args, "--package" => $name;
+ }
print "$^X @args\n";
(system($^X, @args) == 0) or die "...returned with error: $?\n";
diff --git a/inc/Module/Install/ReadmeFromPod.pm b/inc/Module/Install/ReadmeFromPod.pm
index 6a80818..b5e03c3 100644
--- a/inc/Module/Install/ReadmeFromPod.pm
+++ b/inc/Module/Install/ReadmeFromPod.pm
@@ -7,7 +7,7 @@ use warnings;
use base qw(Module::Install::Base);
use vars qw($VERSION);
-$VERSION = '0.20';
+$VERSION = '0.22';
sub readme_from {
my $self = shift;
commit d689191391e57883966fb189e08ffc2fc47c0c53
Author: Alex Vandiver <alexmv at bestpractical.com>
Date: Tue Sep 24 15:01:13 2013 -0400
Expand namespace to cope with ns3 -> ns4 rename by Apple
Namespace expansion requires SAX support, so ensure that the module
adds XML::SAX as a dependency.
diff --git a/META.yml b/META.yml
index e80ada9..a7bc482 100644
--- a/META.yml
+++ b/META.yml
@@ -22,6 +22,7 @@ no_index:
requires:
Class::Accessor::Fast: 0
LWP::UserAgent: 0
+ XML::SAX: 0
XML::Simple: 0
resources:
license: http://opensource.org/licenses/gpl-license.php
diff --git a/Makefile.PL b/Makefile.PL
index f55e0f0..f00a423 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -8,6 +8,7 @@ license 'gplv2';
requires 'Class::Accessor::Fast';
requires 'LWP::UserAgent';
+requires 'XML::SAX';
requires 'XML::Simple';
use Config;
diff --git a/lib/RT/Extension/Assets/AppleGSX/Client.pm b/lib/RT/Extension/Assets/AppleGSX/Client.pm
index 69bf117..6a1dd28 100644
--- a/lib/RT/Extension/Assets/AppleGSX/Client.pm
+++ b/lib/RT/Extension/Assets/AppleGSX/Client.pm
@@ -118,8 +118,10 @@ sub ParseResponseXML {
my $self = shift;
my $method = shift;
my $xml = shift;
- my $ret = $xs->XMLin( $xml, NoAttr => 1, SuppressEmpty => undef );
- return $ret->{'S:Body'}{"ns3:${method}Response"}{"${method}Response"};
+ my $ret = $xs->XMLin( $xml, NoAttr => 1, SuppressEmpty => undef, NSExpand => 1 );
+ return $ret->{'{http://schemas.xmlsoap.org/soap/envelope/}Body'}
+ ->{"{http://gsxws.apple.com/elements/global}${method}Response"}
+ ->{"${method}Response"};
}
sub SendRequest {
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list