[Bps-public-commit] rtx-rest branch, master, created. c0984997cae1585554da8d937d40e2762abd2591
Alex Vandiver
alexmv at bestpractical.com
Wed Mar 12 15:22:37 EDT 2014
The branch, master has been created
at c0984997cae1585554da8d937d40e2762abd2591 (commit)
- Log -----------------------------------------------------------------
commit 6af5564fd61be2a50199eb2d935e411d06169e46
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Jul 23 19:03:58 2013 -0700
Skeleton
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..30a15b4
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,14 @@
+blib*
+Makefile
+Makefile.old
+pm_to_blib*
+*.tar.gz
+.lwpcookies
+cover_db
+pod2htm*.tmp
+/RTx-REST*
+*.bak
+*.swp
+/MYMETA.*
+/t/tmp
+/xt/tmp
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..8d0f82d
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,9 @@
+use inc::Module::Install;
+
+RTx 'RTx-REST';
+all_from 'lib/RTx/REST.pm';
+readme_from 'lib/RTx/REST.pm';
+license 'gplv2';
+
+sign;
+WriteAll;
diff --git a/lib/RTx/REST.pm b/lib/RTx/REST.pm
new file mode 100644
index 0000000..7d581c4
--- /dev/null
+++ b/lib/RTx/REST.pm
@@ -0,0 +1,61 @@
+use strict;
+use warnings;
+package RTx::REST;
+
+our $VERSION = '0.01';
+
+=head1 NAME
+
+RTx-REST - Adds a modern REST API to RT under /REST/2.0/
+
+=head1 INSTALLATION
+
+=over
+
+=item C<perl Makefile.PL>
+
+=item C<make>
+
+=item C<make install>
+
+May need root permissions
+
+=item Edit your F</opt/rt4/etc/RT_SiteConfig.pm>
+
+Add this line:
+
+ Set(@Plugins, qw(RTx::REST));
+
+or add C<RTx::REST> 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
+
+Thomas Sibley <trs at bestpractical.com>
+
+=head1 BUGS
+
+All bugs should be reported via email to
+L<bug-RTx-REST at rt.cpan.org|mailto:bug-RTx-REST at rt.cpan.org>
+or via the web at
+L<rt.cpan.org|http://rt.cpan.org/Public/Dist/Display.html?Name=RTx-REST>.
+
+
+=head1 LICENSE AND COPYRIGHT
+
+This software is Copyright (c) 2013 by Best Practical Solutions
+
+This is free software, licensed under:
+
+ The GNU General Public License, Version 2, June 1991
+
+=cut
+
+1;
commit 15d382c2fbc9459a6c443f75f30eeb5bdd7cfe51
Author: Thomas Sibley <trs at bestpractical.com>
Date: Thu Jul 25 11:32:38 2013 -0700
Build and install toolchain and metadata
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..a020d1d
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,26 @@
+---
+abstract: 'RT REST Extension'
+author:
+ - 'Thomas Sibley <trs 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: RTx-REST
+no_index:
+ directory:
+ - inc
+requires:
+ Plack::Builder: 0
+ UNIVERSAL::require: 0
+ Web::Machine: 0
+resources:
+ license: http://opensource.org/licenses/gpl-license.php
+version: 0.01
diff --git a/README b/README
new file mode 100644
index 0000000..e3ba8d3
--- /dev/null
+++ b/README
@@ -0,0 +1,36 @@
+NAME
+ RTx-REST - Adds a modern REST API to RT under /REST/2.0/
+
+INSTALLATION
+ "perl Makefile.PL"
+ "make"
+ "make install"
+ May need root permissions
+
+ Edit your /opt/rt4/etc/RT_SiteConfig.pm
+ Add this line:
+
+ Set(@Plugins, qw(RTx::REST));
+
+ or add "RTx::REST" to your existing @Plugins line.
+
+ Clear your mason cache
+ rm -rf /opt/rt4/var/mason_data/obj
+
+ Restart your webserver
+
+AUTHOR
+ Thomas Sibley <trs at bestpractical.com>
+
+BUGS
+ All bugs should be reported via email to bug-RTx-REST at rt.cpan.org
+ <mailto:bug-RTx-REST at rt.cpan.org> or via the web at rt.cpan.org
+ <http://rt.cpan.org/Public/Dist/Display.html?Name=RTx-REST>.
+
+LICENSE AND COPYRIGHT
+ This software is Copyright (c) 2013 by Best Practical Solutions
+
+ This is free software, licensed under:
+
+ The GNU General Public License, Version 2, June 1991
+
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..c9fe996
--- /dev/null
+++ b/inc/Module/Install/RTx.pm
@@ -0,0 +1,212 @@
+#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.31';
+
+use FindBin;
+use File::Glob ();
+use File::Basename ();
+
+my @DIRS = qw(etc lib html static 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::LocalStaticPath ||= $RT::StaticPath;
+ $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.*") ) {
+ $has_etc{schema}++;
+ }
+ 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 \$(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 \$(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 \$(NAME) \$(VERSION)))"
+.
+ $self->postamble("initdb ::\n$initdb\n");
+ $self->postamble("initialize-database ::\n$initdb\n");
+ }
+}
+
+# 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 329
diff --git a/inc/Module/Install/ReadmeFromPod.pm b/inc/Module/Install/ReadmeFromPod.pm
new file mode 100644
index 0000000..6a80818
--- /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.20';
+
+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;
commit 943d8f69ef8e1a0e6d6615fc4f92df0d3fde3cf2
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Jul 30 14:47:15 2013 -0700
Basic structure and a reading for a few resource types
A rough sketch so far.
diff --git a/Makefile.PL b/Makefile.PL
index 8d0f82d..6498017 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -5,5 +5,21 @@ all_from 'lib/RTx/REST.pm';
readme_from 'lib/RTx/REST.pm';
license 'gplv2';
+requires_rt('4.1.17');
+
+# 4.1.17 isn't quite enough; needs trs/4.2/rest-v2 for now.
+
+requires 'Encode';
+requires 'JSON';
+requires 'Moose';
+requires 'namespace::autoclean';
+requires 'Plack::Builder';
+requires 'Scalar::Util';
+requires 'UNIVERSAL::require';
+requires 'Web::Machine';
+
+# A critical bug fix for Web::Machine is needed for most clients to behave properly:
+# cpanm git://github.com/tsibley/Web-Machine.git@content-length-after-filters
+
sign;
WriteAll;
diff --git a/lib/RTx/REST.pm b/lib/RTx/REST.pm
index 7d581c4..44713be 100644
--- a/lib/RTx/REST.pm
+++ b/lib/RTx/REST.pm
@@ -4,10 +4,65 @@ package RTx::REST;
our $VERSION = '0.01';
+use UNIVERSAL::require;
+use Plack::Builder;
+use Web::Machine;
+
=head1 NAME
RTx-REST - Adds a modern REST API to RT under /REST/2.0/
+=cut
+
+# XXX TODO: API doc
+
+sub resource {
+ my $class = "RTx::REST::Resource::$_[0]";
+ $class->require or die $@;
+ Web::Machine->new(
+ resource => $class,
+ )->to_app;
+}
+
+sub app {
+ sub {
+ # XXX TODO: logging of SQL queries in RT's framework for doing so
+ # XXX TODO: Need a dispatcher? Or do it inside resources? Web::Simple?
+ RT::ConnectToDatabase();
+ my $dispatch = builder {
+ # XXX TODO: better auth integration
+ enable "Auth::Basic",
+ realm => RT->Config->Get("rtname") . " API",
+ authenticator => sub {
+ my ($user, $pass, $env) = @_;
+ my $cu = RT::CurrentUser->new;
+ $cu->Load($user);
+
+ if ($cu->id and $cu->IsPassword($pass)) {
+ $env->{"rt.current_user"} = $cu;
+ return 1;
+ } else {
+ RT->Logger->error("FAILED LOGIN for $user from $env->{REMOTE_ADDR}");
+ return 0;
+ }
+ };
+ mount "/\L$_" => resource($_)
+ for qw(Ticket Queue User);
+ mount "/" => sub { [ 404, ['Content-type' => 'text/plain'], ['Unknown resource'] ] };
+ };
+ $dispatch->(@_);
+ }
+}
+
+# Called by RT::Interface::Web::Handler->PSGIApp
+sub PSGIWrap {
+ my ($class, $app) = @_;
+ builder {
+ mount "/REST/2.0" => $class->app;
+ mount "/" => $app;
+ };
+}
+
=head1 INSTALLATION
=over
@@ -47,7 +102,6 @@ L<bug-RTx-REST at rt.cpan.org|mailto:bug-RTx-REST at rt.cpan.org>
or via the web at
L<rt.cpan.org|http://rt.cpan.org/Public/Dist/Display.html?Name=RTx-REST>.
-
=head1 LICENSE AND COPYRIGHT
This software is Copyright (c) 2013 by Best Practical Solutions
diff --git a/lib/RTx/REST/Resource.pm b/lib/RTx/REST/Resource.pm
new file mode 100644
index 0000000..2f1e441
--- /dev/null
+++ b/lib/RTx/REST/Resource.pm
@@ -0,0 +1,17 @@
+package RTx::REST::Resource;
+use strict;
+use warnings;
+
+use Moose;
+use namespace::autoclean;
+
+extends 'Web::Machine::Resource';
+
+sub finish_request {
+ my ($self, $meta) = @_;
+ if ($meta->{exception}) {
+ RT->Logger->crit("Error processing resource request: $meta->{exception}");
+ }
+}
+
+1;
diff --git a/lib/RTx/REST/Resource/Queue.pm b/lib/RTx/REST/Resource/Queue.pm
new file mode 100644
index 0000000..82f383d
--- /dev/null
+++ b/lib/RTx/REST/Resource/Queue.pm
@@ -0,0 +1,13 @@
+package RTx::REST::Resource::Queue;
+use strict;
+use warnings;
+
+use Moose;
+use namespace::autoclean;
+
+extends 'RTx::REST::Resource';
+with 'RTx::REST::Resource::Role::Record';
+
+__PACKAGE__->meta->make_immutable;
+
+1;
diff --git a/lib/RTx/REST/Resource/Role/Record.pm b/lib/RTx/REST/Resource/Role/Record.pm
new file mode 100644
index 0000000..cde25ed
--- /dev/null
+++ b/lib/RTx/REST/Resource/Role/Record.pm
@@ -0,0 +1,123 @@
+package RTx::REST::Resource::Role::Record;
+use strict;
+use warnings;
+
+use Moose::Role;
+use namespace::autoclean;
+
+use Scalar::Util qw( blessed );
+use Web::Machine::Util qw( bind_path create_date );
+use Encode qw( decode_utf8 );
+use JSON ();
+
+has 'record_class' => (
+ is => 'ro',
+ isa => 'ClassName',
+ required => 1,
+ lazy => 1,
+ default => \&_record_class,
+);
+
+has 'record' => (
+ is => 'ro',
+ isa => 'RT::Record',
+ required => 1,
+ lazy_build => 1,
+);
+
+has 'current_user' => (
+ is => 'ro',
+ isa => 'RT::CurrentUser',
+ required => 1,
+ lazy_build => 1,
+);
+
+sub _record_class {
+ my $self = shift;
+ my ($type) = blessed($self) =~ /::(\w+)$/;
+ my $class = "RT::$type";
+ $class->require;
+ return $class;
+}
+
+sub _build_record {
+ my $self = shift;
+ my $record = $self->record_class->new( $self->current_user );
+ $record->Load( bind_path('/:id', $self->request->path_info) );
+ return $record;
+}
+
+# XXX TODO: real sessions
+sub _build_current_user {
+ $_[0]->request->env->{"rt.current_user"} || RT::CurrentUser->new;
+}
+
+sub serialize_record {
+ my $self = shift;
+ my %data = $self->record->Serialize(@_);
+
+ for my $column (grep !ref($data{$_}), keys %data) {
+ if ($self->record->_Accessible($column => "read")) {
+ # XXX TODO: dates are in GMT, and should be marked as such
+ $data{$column} = $self->record->$column;
+ } else {
+ delete $data{$column};
+ }
+ }
+
+ # Replace UIDs with object placeholders
+ for my $uid (grep ref eq 'SCALAR', values %data) {
+ if (not defined $$uid) {
+ $uid = undef;
+ next;
+ }
+
+ my ($class, $rtname, $id) = $$uid =~ /^([^-]+?)(?:-(.+?))?-(.+)$/;
+ next unless $class and $id;
+
+ $class =~ s/^RT:://;
+ $class = lc $class;
+
+ $uid = {
+ type => $class,
+ id => $id,
+ url => "/$class/$id",
+ };
+ }
+ return \%data;
+}
+
+sub resource_exists {
+ $_[0]->record->id
+}
+
+sub forbidden {
+ my $self = shift;
+ return 0 unless $self->record->id;
+
+ my $can_see = $self->record->can("CurrentUserCanSee");
+ return 1 if $can_see and not $self->record->$can_see();
+ return 0;
+}
+
+sub last_modified {
+ my $self = shift;
+ return unless $self->record->_Accessible("LastUpdated" => "read");
+ my $updated = $self->record->LastUpdatedObj->RFC2616
+ or return;
+ return create_date($updated);
+}
+
+sub charsets_provided { [ 'utf-8' ] }
+sub default_charset { 'utf-8' }
+
+sub content_types_provided { [
+ { 'application/json' => 'to_json' },
+] }
+
+sub to_json {
+ my $self = shift;
+ return JSON::to_json($self->serialize_record, { pretty => 1 });
+}
+
+1;
diff --git a/lib/RTx/REST/Resource/Ticket.pm b/lib/RTx/REST/Resource/Ticket.pm
new file mode 100644
index 0000000..41101b7
--- /dev/null
+++ b/lib/RTx/REST/Resource/Ticket.pm
@@ -0,0 +1,20 @@
+package RTx::REST::Resource::Ticket;
+use strict;
+use warnings;
+
+use Moose;
+use namespace::autoclean;
+
+extends 'RTx::REST::Resource';
+with 'RTx::REST::Resource::Role::Record';
+
+sub forbidden {
+ my $self = shift;
+ return 0 if not $self->record->id;
+ return 0 if $self->record->CurrentUserHasRight("ShowTicket");
+ return 1;
+}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
diff --git a/lib/RTx/REST/Resource/User.pm b/lib/RTx/REST/Resource/User.pm
new file mode 100644
index 0000000..964ed6e
--- /dev/null
+++ b/lib/RTx/REST/Resource/User.pm
@@ -0,0 +1,21 @@
+package RTx::REST::Resource::User;
+use strict;
+use warnings;
+
+use Moose;
+use namespace::autoclean;
+
+extends 'RTx::REST::Resource';
+with 'RTx::REST::Resource::Role::Record';
+
+sub forbidden {
+ my $self = shift;
+ return 0 if not $self->record->id;
+ return 0 if $self->record->id == $self->current_user->id;
+ return 0 if $self->record->CurrentUserHasRight("AdminUsers");
+ return 1;
+}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
commit e59722f1eafacd3abaa0375bf52e48e3676dfab7
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Jul 30 16:04:19 2013 -0700
Use MooseX::NonMoose for immutable, inline constructors
diff --git a/Makefile.PL b/Makefile.PL
index 6498017..c6009d2 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -12,6 +12,7 @@ requires_rt('4.1.17');
requires 'Encode';
requires 'JSON';
requires 'Moose';
+requires 'MooseX::NonMoose';
requires 'namespace::autoclean';
requires 'Plack::Builder';
requires 'Scalar::Util';
diff --git a/lib/RTx/REST/Resource.pm b/lib/RTx/REST/Resource.pm
index 2f1e441..c7caaad 100644
--- a/lib/RTx/REST/Resource.pm
+++ b/lib/RTx/REST/Resource.pm
@@ -3,6 +3,7 @@ use strict;
use warnings;
use Moose;
+use MooseX::NonMoose;
use namespace::autoclean;
extends 'Web::Machine::Resource';
@@ -14,4 +15,7 @@ sub finish_request {
}
}
+no Moose;
+__PACKAGE__->meta->make_immutable;
+
1;
diff --git a/lib/RTx/REST/Resource/Queue.pm b/lib/RTx/REST/Resource/Queue.pm
index 82f383d..cb18339 100644
--- a/lib/RTx/REST/Resource/Queue.pm
+++ b/lib/RTx/REST/Resource/Queue.pm
@@ -8,6 +8,7 @@ use namespace::autoclean;
extends 'RTx::REST::Resource';
with 'RTx::REST::Resource::Role::Record';
+no Moose;
__PACKAGE__->meta->make_immutable;
1;
diff --git a/lib/RTx/REST/Resource/Ticket.pm b/lib/RTx/REST/Resource/Ticket.pm
index 41101b7..7a350cf 100644
--- a/lib/RTx/REST/Resource/Ticket.pm
+++ b/lib/RTx/REST/Resource/Ticket.pm
@@ -15,6 +15,7 @@ sub forbidden {
return 1;
}
+no Moose;
__PACKAGE__->meta->make_immutable;
1;
diff --git a/lib/RTx/REST/Resource/User.pm b/lib/RTx/REST/Resource/User.pm
index 964ed6e..8a8d48c 100644
--- a/lib/RTx/REST/Resource/User.pm
+++ b/lib/RTx/REST/Resource/User.pm
@@ -16,6 +16,7 @@ sub forbidden {
return 1;
}
+no Moose;
__PACKAGE__->meta->make_immutable;
1;
commit ab4249f9e83abd7b09ff98ddab612cf4bf7ab8eb
Author: Thomas Sibley <trs at bestpractical.com>
Date: Thu Aug 1 15:14:13 2013 -0700
Move current_user into RTx::REST::Resource
diff --git a/lib/RTx/REST/Resource.pm b/lib/RTx/REST/Resource.pm
index c7caaad..0772a07 100644
--- a/lib/RTx/REST/Resource.pm
+++ b/lib/RTx/REST/Resource.pm
@@ -8,6 +8,18 @@ use namespace::autoclean;
extends 'Web::Machine::Resource';
+has 'current_user' => (
+ is => 'ro',
+ isa => 'RT::CurrentUser',
+ required => 1,
+ lazy_build => 1,
+);
+
+# XXX TODO: real sessions
+sub _build_current_user {
+ $_[0]->request->env->{"rt.current_user"} || RT::CurrentUser->new;
+}
+
sub finish_request {
my ($self, $meta) = @_;
if ($meta->{exception}) {
diff --git a/lib/RTx/REST/Resource/Role/Record.pm b/lib/RTx/REST/Resource/Role/Record.pm
index cde25ed..d1fd63b 100644
--- a/lib/RTx/REST/Resource/Role/Record.pm
+++ b/lib/RTx/REST/Resource/Role/Record.pm
@@ -10,6 +10,8 @@ use Web::Machine::Util qw( bind_path create_date );
use Encode qw( decode_utf8 );
use JSON ();
+requires 'current_user';
+
has 'record_class' => (
is => 'ro',
isa => 'ClassName',
@@ -25,13 +27,6 @@ has 'record' => (
lazy_build => 1,
);
-has 'current_user' => (
- is => 'ro',
- isa => 'RT::CurrentUser',
- required => 1,
- lazy_build => 1,
-);
-
sub _record_class {
my $self = shift;
my ($type) = blessed($self) =~ /::(\w+)$/;
@@ -47,11 +42,6 @@ sub _build_record {
return $record;
}
-# XXX TODO: real sessions
-sub _build_current_user {
- $_[0]->request->env->{"rt.current_user"} || RT::CurrentUser->new;
-}
-
sub serialize_record {
my $self = shift;
my %data = $self->record->Serialize(@_);
commit b638546059260c357b1cff0bd12068bbb176aaae
Author: Thomas Sibley <trs at bestpractical.com>
Date: Thu Aug 1 15:29:29 2013 -0700
Update META
diff --git a/META.yml b/META.yml
index a020d1d..fb97a26 100644
--- a/META.yml
+++ b/META.yml
@@ -18,9 +18,15 @@ no_index:
directory:
- inc
requires:
+ Encode: 0
+ JSON: 0
+ Moose: 0
+ MooseX::NonMoose: 0
Plack::Builder: 0
+ Scalar::Util: 0
UNIVERSAL::require: 0
Web::Machine: 0
+ namespace::autoclean: 0
resources:
license: http://opensource.org/licenses/gpl-license.php
version: 0.01
commit 284a15449ad2573606b382de94b467965ee01141
Author: Thomas Sibley <trs at bestpractical.com>
Date: Thu Aug 1 15:29:33 2013 -0700
Promote raw SQL dates to a standard format
Critically, one that includes a timezone.
diff --git a/lib/RTx/REST/Resource/Role/Record.pm b/lib/RTx/REST/Resource/Role/Record.pm
index d1fd63b..4f4b083 100644
--- a/lib/RTx/REST/Resource/Role/Record.pm
+++ b/lib/RTx/REST/Resource/Role/Record.pm
@@ -43,13 +43,20 @@ sub _build_record {
}
sub serialize_record {
- my $self = shift;
- my %data = $self->record->Serialize(@_);
+ my $self = shift;
+ my $record = $self->record;
+ my %data = $record->Serialize(@_);
for my $column (grep !ref($data{$_}), keys %data) {
- if ($self->record->_Accessible($column => "read")) {
- # XXX TODO: dates are in GMT, and should be marked as such
- $data{$column} = $self->record->$column;
+ if ($record->_Accessible($column => "read")) {
+ $data{$column} = $record->$column;
+
+ # Promote raw SQL dates to a standard format
+ if ($record->_Accessible($column => "type") =~ /(datetime|timestamp)/i) {
+ my $date = RT::Date->new( $self->current_user );
+ $date->Set( Format => 'sql', Value => $data{$column} );
+ $data{$column} = $date->W3CDTF( Timezone => 'UTC' );
+ }
} else {
delete $data{$column};
}
commit 57d313f630c93f955c8480d682df12316151dd90
Author: Thomas Sibley <trs at bestpractical.com>
Date: Thu Aug 1 15:57:13 2013 -0700
Use Module::Pluggable to setup all resources
diff --git a/META.yml b/META.yml
index fb97a26..89b5048 100644
--- a/META.yml
+++ b/META.yml
@@ -3,9 +3,9 @@ abstract: 'RT REST Extension'
author:
- 'Thomas Sibley <trs at bestpractical.com>'
build_requires:
- ExtUtils::MakeMaker: 6.36
+ ExtUtils::MakeMaker: 6.59
configure_requires:
- ExtUtils::MakeMaker: 6.36
+ ExtUtils::MakeMaker: 6.59
distribution_type: module
dynamic_config: 1
generated_by: 'Module::Install version 1.06'
@@ -20,6 +20,7 @@ no_index:
requires:
Encode: 0
JSON: 0
+ Module::Pluggable: 0
Moose: 0
MooseX::NonMoose: 0
Plack::Builder: 0
@@ -27,6 +28,7 @@ requires:
UNIVERSAL::require: 0
Web::Machine: 0
namespace::autoclean: 0
+ perl: 5.10.0
resources:
license: http://opensource.org/licenses/gpl-license.php
version: 0.01
diff --git a/Makefile.PL b/Makefile.PL
index c6009d2..e49e4dc 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -11,6 +11,7 @@ requires_rt('4.1.17');
requires 'Encode';
requires 'JSON';
+requires 'Module::Pluggable';
requires 'Moose';
requires 'MooseX::NonMoose';
requires 'namespace::autoclean';
diff --git a/lib/RTx/REST.pm b/lib/RTx/REST.pm
index 44713be..d3bc4b2 100644
--- a/lib/RTx/REST.pm
+++ b/lib/RTx/REST.pm
@@ -1,5 +1,7 @@
use strict;
use warnings;
+use 5.010;
+
package RTx::REST;
our $VERSION = '0.01';
@@ -7,6 +9,11 @@ our $VERSION = '0.01';
use UNIVERSAL::require;
use Plack::Builder;
use Web::Machine;
+use Module::Pluggable
+ sub_name => "_resources",
+ search_path => ["RTx::REST::Resource"],
+ max_depth => 4,
+ require => 1;
=head1 NAME
@@ -16,16 +23,22 @@ RTx-REST - Adds a modern REST API to RT under /REST/2.0/
# XXX TODO: API doc
+sub resources {
+ state @resources;
+ @resources = grep { s/^RTx::REST::Resource:://; $_ } $_[0]->_resources
+ unless @resources;
+ return @resources;
+}
+
sub resource {
- my $class = "RTx::REST::Resource::$_[0]";
- $class->require or die $@;
Web::Machine->new(
- resource => $class,
+ resource => "RTx::REST::Resource::$_[0]",
)->to_app;
}
sub app {
- sub {
+ my $class = shift;
+ return sub {
# XXX TODO: logging of SQL queries in RT's framework for doing so
# XXX TODO: Need a dispatcher? Or do it inside resources? Web::Simple?
RT::ConnectToDatabase();
@@ -47,7 +60,7 @@ sub app {
}
};
mount "/\L$_" => resource($_)
- for qw(Ticket Queue User);
+ for $class->resources;
mount "/" => sub { [ 404, ['Content-type' => 'text/plain'], ['Unknown resource'] ] };
};
$dispatch->(@_);
commit ea9a7f18b3e786b922205b4d27036d7337330f99
Author: Thomas Sibley <trs at bestpractical.com>
Date: Thu Aug 1 16:33:10 2013 -0700
Require a new-enough version of Module::Pluggable
4.8 is tested, and only newer versions support max_depth.
diff --git a/Makefile.PL b/Makefile.PL
index e49e4dc..b3bcdef 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -11,7 +11,7 @@ requires_rt('4.1.17');
requires 'Encode';
requires 'JSON';
-requires 'Module::Pluggable';
+requires 'Module::Pluggable' => '4.8';
requires 'Moose';
requires 'MooseX::NonMoose';
requires 'namespace::autoclean';
commit c3d22a7bfd86e8a1b7e2c9131a80d1f33acc3030
Author: Thomas Sibley <trs at bestpractical.com>
Date: Thu Aug 1 16:41:55 2013 -0700
I just released Web::Machine 0.12 which fixes this bug
diff --git a/Makefile.PL b/Makefile.PL
index b3bcdef..4f95a29 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -18,10 +18,7 @@ requires 'namespace::autoclean';
requires 'Plack::Builder';
requires 'Scalar::Util';
requires 'UNIVERSAL::require';
-requires 'Web::Machine';
-
-# A critical bug fix for Web::Machine is needed for most clients to behave properly:
-# cpanm git://github.com/tsibley/Web-Machine.git@content-length-after-filters
+requires 'Web::Machine' => '0.12';
sign;
WriteAll;
commit 61afe6fcecd6f175f6b2d376ae64d2816ac95624
Author: Thomas Sibley <trs at bestpractical.com>
Date: Thu Aug 1 17:50:02 2013 -0700
Deletable resources, either via ->Delete or ->SetDisabled(1)
diff --git a/lib/RTx/REST/Resource/Role/Record/Deletable.pm b/lib/RTx/REST/Resource/Role/Record/Deletable.pm
new file mode 100644
index 0000000..d5b5471
--- /dev/null
+++ b/lib/RTx/REST/Resource/Role/Record/Deletable.pm
@@ -0,0 +1,27 @@
+package RTx::REST::Resource::Role::Record::Deletable;
+use strict;
+use warnings;
+
+use Moose::Role;
+use namespace::autoclean;
+
+with 'RTx::REST::Resource::Role::Record';
+
+around 'allowed_methods' => sub {
+ my $orig = shift;
+ my $self = shift;
+ my $ok = $self->$orig(@_);
+ push @$ok, "DELETE"
+ unless grep $_ eq "DELETE", @$ok;
+ return $ok;
+};
+
+sub delete_resource {
+ my $self = shift;
+ my ($ok, $msg) = $self->record->Delete;
+ RT->Logger->debug("Failed to delete ", $self->record_class, " #", $self->record->id, ": $msg")
+ unless $ok;
+ return $ok;
+}
+
+1;
diff --git a/lib/RTx/REST/Resource/Role/Record/DisableOnDelete.pm b/lib/RTx/REST/Resource/Role/Record/DisableOnDelete.pm
new file mode 100644
index 0000000..e4f4f00
--- /dev/null
+++ b/lib/RTx/REST/Resource/Role/Record/DisableOnDelete.pm
@@ -0,0 +1,18 @@
+package RTx::REST::Resource::Role::Record::DisableOnDelete;
+use strict;
+use warnings;
+
+use Moose::Role;
+use namespace::autoclean;
+
+with 'RTx::REST::Resource::Role::Record::Deletable';
+
+sub delete_resource {
+ my $self = shift;
+ my ($ok, $msg) = $self->record->SetDisabled(1);
+ RT->Logger->debug("Failed to disable ", $self->record_class, " #", $self->record->id, ": $msg")
+ unless $ok;
+ return $ok;
+}
+
+1;
diff --git a/lib/RTx/REST/Resource/Ticket.pm b/lib/RTx/REST/Resource/Ticket.pm
index 7a350cf..71c094a 100644
--- a/lib/RTx/REST/Resource/Ticket.pm
+++ b/lib/RTx/REST/Resource/Ticket.pm
@@ -7,6 +7,7 @@ use namespace::autoclean;
extends 'RTx::REST::Resource';
with 'RTx::REST::Resource::Role::Record';
+with 'RTx::REST::Resource::Role::Record::Deletable';
sub forbidden {
my $self = shift;
diff --git a/lib/RTx/REST/Resource/User.pm b/lib/RTx/REST/Resource/User.pm
index 8a8d48c..f22f2f5 100644
--- a/lib/RTx/REST/Resource/User.pm
+++ b/lib/RTx/REST/Resource/User.pm
@@ -7,6 +7,7 @@ use namespace::autoclean;
extends 'RTx::REST::Resource';
with 'RTx::REST::Resource::Role::Record';
+with 'RTx::REST::Resource::Role::Record::DisableOnDelete';
sub forbidden {
my $self = shift;
commit d20ddd0dbe95201c93335f30beb56a426f91fd63
Author: Thomas Sibley <trs at bestpractical.com>
Date: Thu Aug 1 17:51:25 2013 -0700
Provide user Privileged status as a boolean flag
diff --git a/lib/RTx/REST/Resource/User.pm b/lib/RTx/REST/Resource/User.pm
index f22f2f5..dc8ef93 100644
--- a/lib/RTx/REST/Resource/User.pm
+++ b/lib/RTx/REST/Resource/User.pm
@@ -9,6 +9,14 @@ extends 'RTx::REST::Resource';
with 'RTx::REST::Resource::Role::Record';
with 'RTx::REST::Resource::Role::Record::DisableOnDelete';
+around 'serialize_record' => sub {
+ my $orig = shift;
+ my $self = shift;
+ my $data = $self->$orig(@_);
+ $data->{Privileged} = $self->record->Privileged ? 1 : 0;
+ return $data;
+};
+
sub forbidden {
my $self = shift;
return 0 if not $self->record->id;
commit f696ec82d1c786b38769ff0000a448c46f672eec
Author: Thomas Sibley <trs at bestpractical.com>
Date: Thu Aug 1 17:51:50 2013 -0700
Provide user Disabled status from the Principal
diff --git a/lib/RTx/REST/Resource/Role/Record/DisabledFromPrincipal.pm b/lib/RTx/REST/Resource/Role/Record/DisabledFromPrincipal.pm
new file mode 100644
index 0000000..cfde083
--- /dev/null
+++ b/lib/RTx/REST/Resource/Role/Record/DisabledFromPrincipal.pm
@@ -0,0 +1,21 @@
+package RTx::REST::Resource::Role::Record::DisabledFromPrincipal;
+use strict;
+use warnings;
+
+use Moose::Role;
+use namespace::autoclean;
+
+with 'RTx::REST::Resource::Role::Record';
+
+around 'serialize_record' => sub {
+ my $orig = shift;
+ my $self = shift;
+ my $data = $self->$orig(@_);
+
+ $data->{Disabled} = $self->record->PrincipalObj->Disabled
+ unless exists $data->{Disabled};
+
+ return $data;
+};
+
+1;
diff --git a/lib/RTx/REST/Resource/User.pm b/lib/RTx/REST/Resource/User.pm
index dc8ef93..0d66337 100644
--- a/lib/RTx/REST/Resource/User.pm
+++ b/lib/RTx/REST/Resource/User.pm
@@ -8,6 +8,7 @@ use namespace::autoclean;
extends 'RTx::REST::Resource';
with 'RTx::REST::Resource::Role::Record';
with 'RTx::REST::Resource::Role::Record::DisableOnDelete';
+with 'RTx::REST::Resource::Role::Record::DisabledFromPrincipal';
around 'serialize_record' => sub {
my $orig = shift;
commit c20459ddff015eda2024989788e58c5e4740bcab
Author: Thomas Sibley <trs at bestpractical.com>
Date: Mon Aug 5 06:57:57 2013 -0700
"no Moose" is redundant with namespace::autoclean
diff --git a/lib/RTx/REST/Resource.pm b/lib/RTx/REST/Resource.pm
index 0772a07..95bfb4a 100644
--- a/lib/RTx/REST/Resource.pm
+++ b/lib/RTx/REST/Resource.pm
@@ -27,7 +27,6 @@ sub finish_request {
}
}
-no Moose;
__PACKAGE__->meta->make_immutable;
1;
diff --git a/lib/RTx/REST/Resource/Queue.pm b/lib/RTx/REST/Resource/Queue.pm
index cb18339..82f383d 100644
--- a/lib/RTx/REST/Resource/Queue.pm
+++ b/lib/RTx/REST/Resource/Queue.pm
@@ -8,7 +8,6 @@ use namespace::autoclean;
extends 'RTx::REST::Resource';
with 'RTx::REST::Resource::Role::Record';
-no Moose;
__PACKAGE__->meta->make_immutable;
1;
diff --git a/lib/RTx/REST/Resource/Ticket.pm b/lib/RTx/REST/Resource/Ticket.pm
index 71c094a..0554aa5 100644
--- a/lib/RTx/REST/Resource/Ticket.pm
+++ b/lib/RTx/REST/Resource/Ticket.pm
@@ -16,7 +16,6 @@ sub forbidden {
return 1;
}
-no Moose;
__PACKAGE__->meta->make_immutable;
1;
diff --git a/lib/RTx/REST/Resource/User.pm b/lib/RTx/REST/Resource/User.pm
index 0d66337..fb3aa68 100644
--- a/lib/RTx/REST/Resource/User.pm
+++ b/lib/RTx/REST/Resource/User.pm
@@ -26,7 +26,6 @@ sub forbidden {
return 1;
}
-no Moose;
__PACKAGE__->meta->make_immutable;
1;
commit c9751d427ce06c1b63f4ad1ad0e0f6f12c4cd217
Author: Thomas Sibley <trs at bestpractical.com>
Date: Mon Aug 5 07:30:16 2013 -0700
Restructure Resource::Role::Record into a subclass and rejigger roles
I think having the core functionality provided by a subclass rather than
role will be more extensible and flexible in the future.
diff --git a/lib/RTx/REST/Resource/Queue.pm b/lib/RTx/REST/Resource/Queue.pm
index 82f383d..7f853e3 100644
--- a/lib/RTx/REST/Resource/Queue.pm
+++ b/lib/RTx/REST/Resource/Queue.pm
@@ -5,8 +5,7 @@ use warnings;
use Moose;
use namespace::autoclean;
-extends 'RTx::REST::Resource';
-with 'RTx::REST::Resource::Role::Record';
+extends 'RTx::REST::Resource::Record';
__PACKAGE__->meta->make_immutable;
diff --git a/lib/RTx/REST/Resource/Role/Record.pm b/lib/RTx/REST/Resource/Record.pm
similarity index 96%
rename from lib/RTx/REST/Resource/Role/Record.pm
rename to lib/RTx/REST/Resource/Record.pm
index 4f4b083..945d491 100644
--- a/lib/RTx/REST/Resource/Role/Record.pm
+++ b/lib/RTx/REST/Resource/Record.pm
@@ -1,17 +1,17 @@
-package RTx::REST::Resource::Role::Record;
+package RTx::REST::Resource::Record;
use strict;
use warnings;
-use Moose::Role;
+use Moose;
use namespace::autoclean;
+extends 'RTx::REST::Resource';
+
use Scalar::Util qw( blessed );
use Web::Machine::Util qw( bind_path create_date );
use Encode qw( decode_utf8 );
use JSON ();
-requires 'current_user';
-
has 'record_class' => (
is => 'ro',
isa => 'ClassName',
@@ -117,4 +117,6 @@ sub to_json {
return JSON::to_json($self->serialize_record, { pretty => 1 });
}
+__PACKAGE__->meta->make_immutable;
+
1;
diff --git a/lib/RTx/REST/Resource/Role/Record/Deletable.pm b/lib/RTx/REST/Resource/Record/Deletable.pm
similarity index 83%
rename from lib/RTx/REST/Resource/Role/Record/Deletable.pm
rename to lib/RTx/REST/Resource/Record/Deletable.pm
index d5b5471..d19072f 100644
--- a/lib/RTx/REST/Resource/Role/Record/Deletable.pm
+++ b/lib/RTx/REST/Resource/Record/Deletable.pm
@@ -1,11 +1,12 @@
-package RTx::REST::Resource::Role::Record::Deletable;
+package RTx::REST::Resource::Record::Deletable;
use strict;
use warnings;
use Moose::Role;
use namespace::autoclean;
-with 'RTx::REST::Resource::Role::Record';
+requires 'record';
+requires 'record_class';
around 'allowed_methods' => sub {
my $orig = shift;
diff --git a/lib/RTx/REST/Resource/Role/Record/DisableOnDelete.pm b/lib/RTx/REST/Resource/Record/DisableOnDelete.pm
similarity index 73%
rename from lib/RTx/REST/Resource/Role/Record/DisableOnDelete.pm
rename to lib/RTx/REST/Resource/Record/DisableOnDelete.pm
index e4f4f00..6a2d274 100644
--- a/lib/RTx/REST/Resource/Role/Record/DisableOnDelete.pm
+++ b/lib/RTx/REST/Resource/Record/DisableOnDelete.pm
@@ -1,11 +1,11 @@
-package RTx::REST::Resource::Role::Record::DisableOnDelete;
+package RTx::REST::Resource::Record::DisableOnDelete;
use strict;
use warnings;
use Moose::Role;
use namespace::autoclean;
-with 'RTx::REST::Resource::Role::Record::Deletable';
+with 'RTx::REST::Resource::Record::Deletable';
sub delete_resource {
my $self = shift;
diff --git a/lib/RTx/REST/Resource/Role/Record/DisabledFromPrincipal.pm b/lib/RTx/REST/Resource/Record/DisabledFromPrincipal.pm
similarity index 74%
rename from lib/RTx/REST/Resource/Role/Record/DisabledFromPrincipal.pm
rename to lib/RTx/REST/Resource/Record/DisabledFromPrincipal.pm
index cfde083..582fb7f 100644
--- a/lib/RTx/REST/Resource/Role/Record/DisabledFromPrincipal.pm
+++ b/lib/RTx/REST/Resource/Record/DisabledFromPrincipal.pm
@@ -1,11 +1,12 @@
-package RTx::REST::Resource::Role::Record::DisabledFromPrincipal;
+package RTx::REST::Resource::Record::DisabledFromPrincipal;
use strict;
use warnings;
use Moose::Role;
use namespace::autoclean;
-with 'RTx::REST::Resource::Role::Record';
+requires 'record';
+requires 'record_class';
around 'serialize_record' => sub {
my $orig = shift;
diff --git a/lib/RTx/REST/Resource/Ticket.pm b/lib/RTx/REST/Resource/Ticket.pm
index 0554aa5..f4ae10a 100644
--- a/lib/RTx/REST/Resource/Ticket.pm
+++ b/lib/RTx/REST/Resource/Ticket.pm
@@ -5,9 +5,8 @@ use warnings;
use Moose;
use namespace::autoclean;
-extends 'RTx::REST::Resource';
-with 'RTx::REST::Resource::Role::Record';
-with 'RTx::REST::Resource::Role::Record::Deletable';
+extends 'RTx::REST::Resource::Record';
+with 'RTx::REST::Resource::Record::Deletable';
sub forbidden {
my $self = shift;
diff --git a/lib/RTx/REST/Resource/User.pm b/lib/RTx/REST/Resource/User.pm
index fb3aa68..5fdbeee 100644
--- a/lib/RTx/REST/Resource/User.pm
+++ b/lib/RTx/REST/Resource/User.pm
@@ -5,10 +5,9 @@ use warnings;
use Moose;
use namespace::autoclean;
-extends 'RTx::REST::Resource';
-with 'RTx::REST::Resource::Role::Record';
-with 'RTx::REST::Resource::Role::Record::DisableOnDelete';
-with 'RTx::REST::Resource::Role::Record::DisabledFromPrincipal';
+extends 'RTx::REST::Resource::Record';
+with 'RTx::REST::Resource::Record::DisableOnDelete';
+with 'RTx::REST::Resource::Record::DisabledFromPrincipal';
around 'serialize_record' => sub {
my $orig = shift;
commit e58e3fad5ac9aa79d5e953583dd741f3820c9fef
Author: Thomas Sibley <trs at bestpractical.com>
Date: Mon Aug 5 07:32:25 2013 -0700
Use roles to determine allowed_methods
diff --git a/lib/RTx/REST/Resource/Record.pm b/lib/RTx/REST/Resource/Record.pm
index 945d491..a9b1fa9 100644
--- a/lib/RTx/REST/Resource/Record.pm
+++ b/lib/RTx/REST/Resource/Record.pm
@@ -105,6 +105,14 @@ sub last_modified {
return create_date($updated);
}
+sub allowed_methods {
+ my $self = shift;
+ my @ok = ('GET', 'HEAD');
+ push @ok, 'DELETE' if $self->DOES("RTx::REST::Resource::Record::Deletable");
+ push @ok, 'PUT' if $self->DOES("RTx::REST::Resource::Record::Updatable");
+ return \@ok;
+}
+
sub charsets_provided { [ 'utf-8' ] }
sub default_charset { 'utf-8' }
diff --git a/lib/RTx/REST/Resource/Record/Deletable.pm b/lib/RTx/REST/Resource/Record/Deletable.pm
index d19072f..04f5dfe 100644
--- a/lib/RTx/REST/Resource/Record/Deletable.pm
+++ b/lib/RTx/REST/Resource/Record/Deletable.pm
@@ -8,15 +8,6 @@ use namespace::autoclean;
requires 'record';
requires 'record_class';
-around 'allowed_methods' => sub {
- my $orig = shift;
- my $self = shift;
- my $ok = $self->$orig(@_);
- push @$ok, "DELETE"
- unless grep $_ eq "DELETE", @$ok;
- return $ok;
-};
-
sub delete_resource {
my $self = shift;
my ($ok, $msg) = $self->record->Delete;
diff --git a/lib/RTx/REST/Resource/Record/DisableOnDelete.pm b/lib/RTx/REST/Resource/Record/DeletableByDisabling.pm
similarity index 85%
rename from lib/RTx/REST/Resource/Record/DisableOnDelete.pm
rename to lib/RTx/REST/Resource/Record/DeletableByDisabling.pm
index 6a2d274..a5ecb7e 100644
--- a/lib/RTx/REST/Resource/Record/DisableOnDelete.pm
+++ b/lib/RTx/REST/Resource/Record/DeletableByDisabling.pm
@@ -1,4 +1,4 @@
-package RTx::REST::Resource::Record::DisableOnDelete;
+package RTx::REST::Resource::Record::DeletableByDisabling;
use strict;
use warnings;
diff --git a/lib/RTx/REST/Resource/User.pm b/lib/RTx/REST/Resource/User.pm
index 5fdbeee..d09e005 100644
--- a/lib/RTx/REST/Resource/User.pm
+++ b/lib/RTx/REST/Resource/User.pm
@@ -6,7 +6,7 @@ use Moose;
use namespace::autoclean;
extends 'RTx::REST::Resource::Record';
-with 'RTx::REST::Resource::Record::DisableOnDelete';
+with 'RTx::REST::Resource::Record::DeletableByDisabling';
with 'RTx::REST::Resource::Record::DisabledFromPrincipal';
around 'serialize_record' => sub {
commit b001d1158e40daae58c06bc63a78c7226b67f801
Author: Thomas Sibley <trs at bestpractical.com>
Date: Mon Aug 5 07:33:30 2013 -0700
Queues are deletable via disabling
diff --git a/lib/RTx/REST/Resource/Queue.pm b/lib/RTx/REST/Resource/Queue.pm
index 7f853e3..4b7614c 100644
--- a/lib/RTx/REST/Resource/Queue.pm
+++ b/lib/RTx/REST/Resource/Queue.pm
@@ -6,6 +6,7 @@ use Moose;
use namespace::autoclean;
extends 'RTx::REST::Resource::Record';
+with 'RTx::REST::Resource::Record::DeletableByDisabling';
__PACKAGE__->meta->make_immutable;
commit cbf8b7bfe269f1869d6787ef2c8d24238706d848
Author: Thomas Sibley <trs at bestpractical.com>
Date: Mon Aug 5 07:37:20 2013 -0700
Remove a silly role
It's a simple enough change to make directly, and doesn't meet general
purpose reusability requirements; it would only ever be reused by
Groups.
(Too much kool-aid.)
diff --git a/lib/RTx/REST/Resource/Record/DisabledFromPrincipal.pm b/lib/RTx/REST/Resource/Record/DisabledFromPrincipal.pm
deleted file mode 100644
index 582fb7f..0000000
--- a/lib/RTx/REST/Resource/Record/DisabledFromPrincipal.pm
+++ /dev/null
@@ -1,22 +0,0 @@
-package RTx::REST::Resource::Record::DisabledFromPrincipal;
-use strict;
-use warnings;
-
-use Moose::Role;
-use namespace::autoclean;
-
-requires 'record';
-requires 'record_class';
-
-around 'serialize_record' => sub {
- my $orig = shift;
- my $self = shift;
- my $data = $self->$orig(@_);
-
- $data->{Disabled} = $self->record->PrincipalObj->Disabled
- unless exists $data->{Disabled};
-
- return $data;
-};
-
-1;
diff --git a/lib/RTx/REST/Resource/User.pm b/lib/RTx/REST/Resource/User.pm
index d09e005..fa0711f 100644
--- a/lib/RTx/REST/Resource/User.pm
+++ b/lib/RTx/REST/Resource/User.pm
@@ -7,13 +7,13 @@ use namespace::autoclean;
extends 'RTx::REST::Resource::Record';
with 'RTx::REST::Resource::Record::DeletableByDisabling';
-with 'RTx::REST::Resource::Record::DisabledFromPrincipal';
around 'serialize_record' => sub {
my $orig = shift;
my $self = shift;
my $data = $self->$orig(@_);
$data->{Privileged} = $self->record->Privileged ? 1 : 0;
+ $data->{Disabled} = $self->record->PrincipalObj->Disabled;
return $data;
};
commit d34eeebb167134d2ad38b0bc825d58d109f72b1a
Author: Thomas Sibley <trs at bestpractical.com>
Date: Mon Aug 5 08:57:17 2013 -0700
Updatable records via PUT + JSON
diff --git a/lib/RTx/REST/Resource/Queue.pm b/lib/RTx/REST/Resource/Queue.pm
index 4b7614c..2991ff3 100644
--- a/lib/RTx/REST/Resource/Queue.pm
+++ b/lib/RTx/REST/Resource/Queue.pm
@@ -7,6 +7,7 @@ use namespace::autoclean;
extends 'RTx::REST::Resource::Record';
with 'RTx::REST::Resource::Record::DeletableByDisabling';
+with 'RTx::REST::Resource::Record::Updatable';
__PACKAGE__->meta->make_immutable;
diff --git a/lib/RTx/REST/Resource/Record/Updatable.pm b/lib/RTx/REST/Resource/Record/Updatable.pm
new file mode 100644
index 0000000..ad5e33c
--- /dev/null
+++ b/lib/RTx/REST/Resource/Record/Updatable.pm
@@ -0,0 +1,35 @@
+package RTx::REST::Resource::Record::Updatable;
+use strict;
+use warnings;
+
+use Moose::Role;
+use namespace::autoclean;
+use JSON ();
+
+requires 'record';
+requires 'record_class';
+
+sub content_types_accepted { [ {'application/json' => 'from_json'} ] }
+
+sub from_json {
+ my $self = shift;
+ $self->update_resource(
+ JSON::from_json(
+ $self->request->content,
+ )
+ );
+}
+
+sub update_resource {
+ my $self = shift;
+ my $data = shift;
+ my @results = $self->record->Update(
+ ARGSRef => $data,
+ AttributesRef => [ $self->record->WritableAttributes ],
+ );
+ # XXX TODO: Figure out how to return success/failure? Core RT::Record's
+ # ->Update will need to be replaced or improved.
+ return;
+}
+
+1;
diff --git a/lib/RTx/REST/Resource/Ticket.pm b/lib/RTx/REST/Resource/Ticket.pm
index f4ae10a..5a2be49 100644
--- a/lib/RTx/REST/Resource/Ticket.pm
+++ b/lib/RTx/REST/Resource/Ticket.pm
@@ -7,6 +7,7 @@ use namespace::autoclean;
extends 'RTx::REST::Resource::Record';
with 'RTx::REST::Resource::Record::Deletable';
+with 'RTx::REST::Resource::Record::Updatable';
sub forbidden {
my $self = shift;
diff --git a/lib/RTx/REST/Resource/User.pm b/lib/RTx/REST/Resource/User.pm
index fa0711f..1508014 100644
--- a/lib/RTx/REST/Resource/User.pm
+++ b/lib/RTx/REST/Resource/User.pm
@@ -7,6 +7,7 @@ use namespace::autoclean;
extends 'RTx::REST::Resource::Record';
with 'RTx::REST::Resource::Record::DeletableByDisabling';
+with 'RTx::REST::Resource::Record::Updatable';
around 'serialize_record' => sub {
my $orig = shift;
commit 4aa544b43e09ff180585fdebcfb9e41b6029e6f9
Author: Thomas Sibley <trs at bestpractical.com>
Date: Mon Aug 5 08:59:14 2013 -0700
Destroy the record object before the request finishes
This lets any cleanup happen that the records themselves need to do.
diff --git a/lib/RTx/REST/Resource/Record.pm b/lib/RTx/REST/Resource/Record.pm
index a9b1fa9..f073fd4 100644
--- a/lib/RTx/REST/Resource/Record.pm
+++ b/lib/RTx/REST/Resource/Record.pm
@@ -125,6 +125,14 @@ sub to_json {
return JSON::to_json($self->serialize_record, { pretty => 1 });
}
+sub finish_request {
+ my $self = shift;
+ # Ensure the record object is destroyed before the request finishes, for
+ # any cleanup that may need to happen (i.e. TransactionBatch).
+ $self->clear_record;
+ return $self->SUPER::finish_request(@_);
+}
+
__PACKAGE__->meta->make_immutable;
1;
commit f3b75aab6259a028b7ada5f50f6a783c2fe266d0
Author: Thomas Sibley <trs at bestpractical.com>
Date: Mon Aug 5 09:00:21 2013 -0700
Use an explicit base_uri rather than falling back to the default via undef
base_uri is now usable directly from other methods.
diff --git a/lib/RTx/REST/Resource/Record.pm b/lib/RTx/REST/Resource/Record.pm
index f073fd4..ab1eab5 100644
--- a/lib/RTx/REST/Resource/Record.pm
+++ b/lib/RTx/REST/Resource/Record.pm
@@ -84,6 +84,10 @@ sub serialize_record {
return \%data;
}
+sub base_uri {
+ $_[0]->request->base
+}
+
sub resource_exists {
$_[0]->record->id
}
commit 94d0b3cae9ac8c4060bf25f54bdb95b781e79e3a
Author: Thomas Sibley <trs at bestpractical.com>
Date: Mon Aug 5 12:04:15 2013 -0700
Basic docs on current functionality
diff --git a/lib/RTx/REST.pm b/lib/RTx/REST.pm
index d3bc4b2..0871940 100644
--- a/lib/RTx/REST.pm
+++ b/lib/RTx/REST.pm
@@ -15,10 +15,54 @@ use Module::Pluggable
max_depth => 4,
require => 1;
+=encoding utf-8
+
=head1 NAME
RTx-REST - Adds a modern REST API to RT under /REST/2.0/
+=head1 USAGE
+
+Currently provided endpoints under C</REST/2.0/> are:
+
+ GET /ticket/:id
+ PUT /ticket/:id <JSON body>
+ DELETE /ticket/:id
+ Sets ticket status to "deleted".
+
+ GET /queue/:id
+ PUT /queue/:id <JSON body>
+ DELETE /queue/:id
+ Disables the queue.
+
+ GET /user/:id
+ PUT /user/:id <JSON body>
+ DELETE /user/:id
+ Disables the user.
+
+For queues and users, C<:id> may be the numeric id or the unique name.
+
+When a GET request is made, each endpoint returns a JSON representation of the
+specified record, or a 404 if not found.
+
+When a PUT request is made, the request body should be a modified copy (or
+partial copy) of the JSON representation of the specified record, and the
+record will be updated.
+
+A DELETE request to a resource will delete or disable the underlying record.
+
+=head2 Authentication
+
+Currently authentication is limited to internal RT usernames and passwords,
+provided via HTTP Basic auth. Most HTTP libraries already have a way of
+providing basic auth credentials when making requests. Using curl, for
+example:
+
+ curl -u username:password …
+
+This sort of authentication should B<always> be done over HTTPS/SSL for
+security. You should only serve up the C</REST/2.0/> endpoint over SSL.
+
=cut
# XXX TODO: API doc
commit c4349ab17438e088908a1ce8b16fbda489422caf
Author: Thomas Sibley <trs at bestpractical.com>
Date: Mon Aug 5 12:05:46 2013 -0700
Allow UID hashrefs to be resubmitted on update
This lets clients round-trip JSON documents after modification.
diff --git a/lib/RTx/REST/Resource/Record/Updatable.pm b/lib/RTx/REST/Resource/Record/Updatable.pm
index ad5e33c..ca37387 100644
--- a/lib/RTx/REST/Resource/Record/Updatable.pm
+++ b/lib/RTx/REST/Resource/Record/Updatable.pm
@@ -5,6 +5,7 @@ use warnings;
use Moose::Role;
use namespace::autoclean;
use JSON ();
+use RTx::REST::Util qw( looks_like_uid );
requires 'record';
requires 'record_class';
@@ -23,6 +24,22 @@ sub from_json {
sub update_resource {
my $self = shift;
my $data = shift;
+
+ # Sanitize input
+ for my $field (sort keys %$data) {
+ my $value = $data->{$field};
+ next unless ref $value;
+ if (looks_like_uid($value)) {
+ # Deconstruct UIDs back into simple foreign key IDs, assuming it
+ # points to the same record type (class).
+ $data->{$field} = $value->{id} || 0;
+ }
+ else {
+ RT->Logger->debug("Received unknown value via JSON for field $field: ".ref($value));
+ delete $data->{$field};
+ }
+ }
+
my @results = $self->record->Update(
ARGSRef => $data,
AttributesRef => [ $self->record->WritableAttributes ],
diff --git a/lib/RTx/REST/Util.pm b/lib/RTx/REST/Util.pm
new file mode 100644
index 0000000..c7c054d
--- /dev/null
+++ b/lib/RTx/REST/Util.pm
@@ -0,0 +1,18 @@
+package RTx::REST::Util;
+use strict;
+use warnings;
+
+use Sub::Exporter -setup => {
+ exports => [qw[
+ looks_like_uid
+ ]]
+};
+
+sub looks_like_uid {
+ my $value = shift;
+ return 0 unless ref $value eq 'HASH';
+ return 0 unless $value->{type} and $value->{id} and $value->{url};
+ return 1;
+}
+
+1;
commit 1b541a521f00de41b83f99e06c82278c118bf517
Author: Thomas Sibley <trs at bestpractical.com>
Date: Mon Aug 5 13:19:44 2013 -0700
Add the resource url for each record
diff --git a/lib/RTx/REST/Resource/Record.pm b/lib/RTx/REST/Resource/Record.pm
index ab1eab5..4c12aba 100644
--- a/lib/RTx/REST/Resource/Record.pm
+++ b/lib/RTx/REST/Resource/Record.pm
@@ -81,6 +81,10 @@ sub serialize_record {
url => "/$class/$id",
};
}
+
+ # Add the resource url for this record
+ $data{_url} = join "/", $self->base_uri, $self->record->id;
+
return \%data;
}
commit 4f38db01a8bf4a5c38d551a5552dd2cd5e2eaf43
Author: Thomas Sibley <trs at bestpractical.com>
Date: Mon Aug 5 15:16:29 2013 -0700
Use Module::Runtime instead of UNIVERSAL::require
The former is already an indirect dep via Web::Machine.
diff --git a/Makefile.PL b/Makefile.PL
index 4f95a29..69d0dd6 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -12,12 +12,12 @@ requires_rt('4.1.17');
requires 'Encode';
requires 'JSON';
requires 'Module::Pluggable' => '4.8';
+requires 'Module::Runtime';
requires 'Moose';
requires 'MooseX::NonMoose';
requires 'namespace::autoclean';
requires 'Plack::Builder';
requires 'Scalar::Util';
-requires 'UNIVERSAL::require';
requires 'Web::Machine' => '0.12';
sign;
diff --git a/lib/RTx/REST/Resource/Record.pm b/lib/RTx/REST/Resource/Record.pm
index 4c12aba..e7d1264 100644
--- a/lib/RTx/REST/Resource/Record.pm
+++ b/lib/RTx/REST/Resource/Record.pm
@@ -10,6 +10,7 @@ extends 'RTx::REST::Resource';
use Scalar::Util qw( blessed );
use Web::Machine::Util qw( bind_path create_date );
use Encode qw( decode_utf8 );
+use Module::Runtime qw( require_module );
use JSON ();
has 'record_class' => (
@@ -31,7 +32,7 @@ sub _record_class {
my $self = shift;
my ($type) = blessed($self) =~ /::(\w+)$/;
my $class = "RT::$type";
- $class->require;
+ require_module($class);
return $class;
}
commit 550b017c7c8e42e84ebf945225af5dcb1bfeeef7
Author: Thomas Sibley <trs at bestpractical.com>
Date: Mon Aug 5 15:17:06 2013 -0700
Sub::Exporter is required for RTx::REST::Utils
diff --git a/Makefile.PL b/Makefile.PL
index 69d0dd6..cc7c058 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -18,6 +18,7 @@ requires 'MooseX::NonMoose';
requires 'namespace::autoclean';
requires 'Plack::Builder';
requires 'Scalar::Util';
+requires 'Sub::Exporter';
requires 'Web::Machine' => '0.12';
sign;
commit 41d4b6779dab611755c9c8399954537de3fcecd3
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Aug 6 08:56:43 2013 -0700
Refactor the record serialization logic into Util.pm
diff --git a/lib/RTx/REST/Resource/Record.pm b/lib/RTx/REST/Resource/Record.pm
index e7d1264..915f46d 100644
--- a/lib/RTx/REST/Resource/Record.pm
+++ b/lib/RTx/REST/Resource/Record.pm
@@ -12,6 +12,7 @@ use Web::Machine::Util qw( bind_path create_date );
use Encode qw( decode_utf8 );
use Module::Runtime qw( require_module );
use JSON ();
+use RTx::REST::Util qw( serialize_record );
has 'record_class' => (
is => 'ro',
@@ -43,50 +44,14 @@ sub _build_record {
return $record;
}
-sub serialize_record {
- my $self = shift;
- my $record = $self->record;
- my %data = $record->Serialize(@_);
-
- for my $column (grep !ref($data{$_}), keys %data) {
- if ($record->_Accessible($column => "read")) {
- $data{$column} = $record->$column;
-
- # Promote raw SQL dates to a standard format
- if ($record->_Accessible($column => "type") =~ /(datetime|timestamp)/i) {
- my $date = RT::Date->new( $self->current_user );
- $date->Set( Format => 'sql', Value => $data{$column} );
- $data{$column} = $date->W3CDTF( Timezone => 'UTC' );
- }
- } else {
- delete $data{$column};
- }
- }
-
- # Replace UIDs with object placeholders
- for my $uid (grep ref eq 'SCALAR', values %data) {
- if (not defined $$uid) {
- $uid = undef;
- next;
- }
-
- my ($class, $rtname, $id) = $$uid =~ /^([^-]+?)(?:-(.+?))?-(.+)$/;
- next unless $class and $id;
-
- $class =~ s/^RT:://;
- $class = lc $class;
-
- $uid = {
- type => $class,
- id => $id,
- url => "/$class/$id",
- };
- }
+sub serialize {
+ my $self = shift;
+ my $data = serialize_record( $self->record );
# Add the resource url for this record
- $data{_url} = join "/", $self->base_uri, $self->record->id;
+ $data->{_url} = join "/", $self->base_uri, $self->record->id;
- return \%data;
+ return $data;
}
sub base_uri {
@@ -131,7 +96,7 @@ sub content_types_provided { [
sub to_json {
my $self = shift;
- return JSON::to_json($self->serialize_record, { pretty => 1 });
+ return JSON::to_json($self->serialize, { pretty => 1 });
}
sub finish_request {
diff --git a/lib/RTx/REST/Resource/User.pm b/lib/RTx/REST/Resource/User.pm
index 1508014..a76ae85 100644
--- a/lib/RTx/REST/Resource/User.pm
+++ b/lib/RTx/REST/Resource/User.pm
@@ -9,7 +9,7 @@ extends 'RTx::REST::Resource::Record';
with 'RTx::REST::Resource::Record::DeletableByDisabling';
with 'RTx::REST::Resource::Record::Updatable';
-around 'serialize_record' => sub {
+around 'serialize' => sub {
my $orig = shift;
my $self = shift;
my $data = $self->$orig(@_);
diff --git a/lib/RTx/REST/Util.pm b/lib/RTx/REST/Util.pm
index c7c054d..eb462a8 100644
--- a/lib/RTx/REST/Util.pm
+++ b/lib/RTx/REST/Util.pm
@@ -5,6 +5,7 @@ use warnings;
use Sub::Exporter -setup => {
exports => [qw[
looks_like_uid
+ serialize_record
]]
};
@@ -15,4 +16,45 @@ sub looks_like_uid {
return 1;
}
+sub serialize_record {
+ my $record = shift;
+ my %data = $record->Serialize(@_);
+
+ for my $column (grep !ref($data{$_}), keys %data) {
+ if ($record->_Accessible($column => "read")) {
+ $data{$column} = $record->$column;
+
+ # Promote raw SQL dates to a standard format
+ if ($record->_Accessible($column => "type") =~ /(datetime|timestamp)/i) {
+ my $date = RT::Date->new( $record->CurrentUser );
+ $date->Set( Format => 'sql', Value => $data{$column} );
+ $data{$column} = $date->W3CDTF( Timezone => 'UTC' );
+ }
+ } else {
+ delete $data{$column};
+ }
+ }
+
+ # Replace UIDs with object placeholders
+ for my $uid (grep ref eq 'SCALAR', values %data) {
+ if (not defined $$uid) {
+ $uid = undef;
+ next;
+ }
+
+ my ($class, $rtname, $id) = $$uid =~ /^([^-]+?)(?:-(.+?))?-(.+)$/;
+ next unless $class and $id;
+
+ $class =~ s/^RT:://;
+ $class = lc $class;
+
+ $uid = {
+ type => $class,
+ id => $id,
+ url => "/$class/$id",
+ };
+ }
+ return \%data;
+}
+
1;
commit 1cf688913bb88eb6e562386d8bb984b169ce0e6a
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Aug 6 09:45:55 2013 -0700
Collections as resources, starting with Tickets
diff --git a/lib/RTx/REST.pm b/lib/RTx/REST.pm
index 0871940..95e9e2b 100644
--- a/lib/RTx/REST.pm
+++ b/lib/RTx/REST.pm
@@ -30,6 +30,8 @@ Currently provided endpoints under C</REST/2.0/> are:
DELETE /ticket/:id
Sets ticket status to "deleted".
+ GET /tickets?query=<TicketSQL>
+
GET /queue/:id
PUT /queue/:id <JSON body>
DELETE /queue/:id
diff --git a/lib/RTx/REST/Resource/Collection.pm b/lib/RTx/REST/Resource/Collection.pm
new file mode 100644
index 0000000..a589a35
--- /dev/null
+++ b/lib/RTx/REST/Resource/Collection.pm
@@ -0,0 +1,90 @@
+package RTx::REST::Resource::Collection;
+use strict;
+use warnings;
+
+use Moose;
+use namespace::autoclean;
+
+extends 'RTx::REST::Resource';
+
+use Scalar::Util qw( blessed );
+use Web::Machine::Util qw( bind_path create_date );
+use Encode qw( decode_utf8 );
+use Module::Runtime qw( require_module );
+use JSON ();
+use RTx::REST::Util qw( serialize_record );
+
+has 'collection_class' => (
+ is => 'ro',
+ isa => 'ClassName',
+ required => 1,
+ lazy => 1,
+ default => \&_collection_class,
+);
+
+has 'collection' => (
+ is => 'ro',
+ isa => 'RT::SearchBuilder',
+ required => 1,
+ lazy_build => 1,
+);
+
+sub _collection_class {
+ my $self = shift;
+ my ($type) = blessed($self) =~ /::(\w+)$/;
+ my $class = "RT::$type";
+ require_module($class);
+ return $class;
+}
+
+sub _build_collection {
+ my $self = shift;
+ my $collection = $self->collection_class->new( $self->current_user );
+ $self->limit_collection($collection);
+ return $collection;
+}
+
+sub limit_collection { }
+
+sub serialize {
+ my $self = shift;
+ my $collection = $self->collection;
+ my @results;
+
+ # XXX TODO: paging
+
+ while (my $item = $collection->Next) {
+ push @results, serialize_record($item);
+ }
+ return {
+ count => scalar(@results) || 0,
+ total => $collection->CountAll || 0,
+ items => \@results,
+ };
+}
+
+# XXX TODO: Bulk update via DELETE/PUT on a collection resource?
+
+sub charsets_provided { [ 'utf-8' ] }
+sub default_charset { 'utf-8' }
+
+sub content_types_provided { [
+ { 'application/json' => 'to_json' },
+] }
+
+sub to_json {
+ my $self = shift;
+ return JSON::to_json($self->serialize, { pretty => 1 });
+}
+
+sub finish_request {
+ my $self = shift;
+ # Ensure the collection object is destroyed before the request finishes, for
+ # any cleanup that may need to happen (i.e. TransactionBatch).
+ $self->clear_collection;
+ return $self->SUPER::finish_request(@_);
+}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
diff --git a/lib/RTx/REST/Resource/Tickets.pm b/lib/RTx/REST/Resource/Tickets.pm
new file mode 100644
index 0000000..f1e0579
--- /dev/null
+++ b/lib/RTx/REST/Resource/Tickets.pm
@@ -0,0 +1,20 @@
+package RTx::REST::Resource::Tickets;
+use strict;
+use warnings;
+
+use Moose;
+use namespace::autoclean;
+
+extends 'RTx::REST::Resource::Collection';
+
+sub limit_collection {
+ my ($self, $tickets) = @_;
+ my ($ok, $msg) = $tickets->FromSQL(
+ $self->request->param('query') || ""
+ );
+ # XXX TODO: thread errors back to client; abort request with 4xx code?
+}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
commit c90f70530086e30845a19e44456e82557d89377d
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Aug 6 09:56:03 2013 -0700
Paging for collection resources
diff --git a/lib/RTx/REST.pm b/lib/RTx/REST.pm
index 95e9e2b..e05efe5 100644
--- a/lib/RTx/REST.pm
+++ b/lib/RTx/REST.pm
@@ -23,6 +23,8 @@ RTx-REST - Adds a modern REST API to RT under /REST/2.0/
=head1 USAGE
+=head2 Summary
+
Currently provided endpoints under C</REST/2.0/> are:
GET /ticket/:id
@@ -45,14 +47,41 @@ Currently provided endpoints under C</REST/2.0/> are:
For queues and users, C<:id> may be the numeric id or the unique name.
When a GET request is made, each endpoint returns a JSON representation of the
-specified record, or a 404 if not found.
+specified resource, or a 404 if not found.
When a PUT request is made, the request body should be a modified copy (or
-partial copy) of the JSON representation of the specified record, and the
+partial copy) of the JSON representation of the specified resource, and the
record will be updated.
A DELETE request to a resource will delete or disable the underlying record.
+=head2 Paging
+
+All plural resources (such as C</tickets>) require pagination, controlled by
+the query parameters C<page> and C<per_page>. The default page size is 20
+items, but it may be increased up to 100 (or decreased if desired). Page
+numbers start at 1.
+
+=head2 Example of plural resources (collections)
+
+Resources which represent a collection of other resources use the following
+standard JSON format:
+
+ {
+ "count" : 20,
+ "page" : 1,
+ "per_page" : 20,
+ "total" : 3810,
+ "items" : [
+ { … },
+ { … },
+ …
+ ]
+ }
+
+Each item is nearly the same representation used when an individual resource
+is requested.
+
=head2 Authentication
Currently authentication is limited to internal RT usernames and passwords,
diff --git a/lib/RTx/REST/Resource/Collection.pm b/lib/RTx/REST/Resource/Collection.pm
index a589a35..b169aac 100644
--- a/lib/RTx/REST/Resource/Collection.pm
+++ b/lib/RTx/REST/Resource/Collection.pm
@@ -41,9 +41,22 @@ sub _build_collection {
my $self = shift;
my $collection = $self->collection_class->new( $self->current_user );
$self->limit_collection($collection);
+ $self->paging($collection);
return $collection;
}
+sub paging {
+ my ($self, $collection) = @_;
+ my $per_page = $self->request->param('per_page') || 20;
+ $per_page = 20 if $per_page <= 0;
+ $per_page = 100 if $per_page > 100;
+ $collection->RowsPerPage($per_page);
+
+ my $page = $self->request->param('page') || 1;
+ $page = 1 if $page < 0;
+ $collection->GotoPage($page - 1);
+}
+
sub limit_collection { }
sub serialize {
@@ -57,9 +70,11 @@ sub serialize {
push @results, serialize_record($item);
}
return {
- count => scalar(@results) || 0,
- total => $collection->CountAll || 0,
- items => \@results,
+ count => scalar(@results) + 0,
+ total => $collection->CountAll + 0,
+ per_page => $collection->RowsPerPage + 0,
+ page => ($collection->FirstRow / $collection->RowsPerPage) + 1,
+ items => \@results,
};
}
commit 649cf25f2db7ee2ae419d483847a2f14d1698bf2
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Aug 6 10:14:46 2013 -0700
Document the use of Last-Modified/If-Modified-Since and status codes
diff --git a/lib/RTx/REST.pm b/lib/RTx/REST.pm
index e05efe5..5481522 100644
--- a/lib/RTx/REST.pm
+++ b/lib/RTx/REST.pm
@@ -94,6 +94,20 @@ example:
This sort of authentication should B<always> be done over HTTPS/SSL for
security. You should only serve up the C</REST/2.0/> endpoint over SSL.
+=head2 Conditional requests (If-Modified-Since)
+
+You can take advantage of the C<Last-Modified> headers returned by most single
+resource endpoints. Add a C<If-Modified-Since> header to your requests for
+the same resource, using the most recent C<Last-Modified> value seen, and the
+API may respond with a 304 Not Modified. You can also use HEAD requests to
+check for updates without receiving the actual content when there is a newer
+version.
+
+=head2 Status codes
+
+The REST API uses the full range of HTTP status codes, and your client should
+handle them appropriately.
+
=cut
# XXX TODO: API doc
commit dc85f6d5e31936c0a82fb1ab4d1cede1bb3a92ab
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Aug 6 10:41:03 2013 -0700
Refactor UID expansion into a separate function for use elsewhere
diff --git a/lib/RTx/REST/Util.pm b/lib/RTx/REST/Util.pm
index eb462a8..1e8aa68 100644
--- a/lib/RTx/REST/Util.pm
+++ b/lib/RTx/REST/Util.pm
@@ -5,6 +5,7 @@ use warnings;
use Sub::Exporter -setup => {
exports => [qw[
looks_like_uid
+ expand_uid
serialize_record
]]
};
@@ -16,6 +17,25 @@ sub looks_like_uid {
return 1;
}
+sub expand_uid {
+ my $uid = shift;
+ $uid = $$uid if ref $uid eq 'SCALAR';
+
+ return if not defined $uid;
+
+ my ($class, $rtname, $id) = $uid =~ /^([^-]+?)(?:-(.+?))?-(.+)$/;
+ return unless $class and $id;
+
+ $class =~ s/^RT:://;
+ $class = lc $class;
+
+ return {
+ type => $class,
+ id => $id,
+ url => "/$class/$id",
+ };
+}
+
sub serialize_record {
my $record = shift;
my %data = $record->Serialize(@_);
@@ -37,22 +57,7 @@ sub serialize_record {
# Replace UIDs with object placeholders
for my $uid (grep ref eq 'SCALAR', values %data) {
- if (not defined $$uid) {
- $uid = undef;
- next;
- }
-
- my ($class, $rtname, $id) = $$uid =~ /^([^-]+?)(?:-(.+?))?-(.+)$/;
- next unless $class and $id;
-
- $class =~ s/^RT:://;
- $class = lc $class;
-
- $uid = {
- type => $class,
- id => $id,
- url => "/$class/$id",
- };
+ $uid = expand_uid($uid);
}
return \%data;
}
commit a4bd84e9e982590f42bfcaf6103a89eb5b2535fa
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Aug 6 10:41:44 2013 -0700
Serialize role group membership for records which have roles
diff --git a/lib/RTx/REST/Util.pm b/lib/RTx/REST/Util.pm
index 1e8aa68..0f7357e 100644
--- a/lib/RTx/REST/Util.pm
+++ b/lib/RTx/REST/Util.pm
@@ -59,6 +59,22 @@ sub serialize_record {
for my $uid (grep ref eq 'SCALAR', values %data) {
$uid = expand_uid($uid);
}
+
+ # Include role members, if applicable
+ if ($record->DOES("RT::Record::Role::Roles")) {
+ for my $role ($record->Roles) {
+ my $members = $data{$role} = [];
+ my $group = $record->RoleGroup($role);
+ my $gm = $group->MembersObj;
+ while ($_ = $gm->Next) {
+ push @$members, expand_uid($_->MemberObj->Object->UID);
+ }
+
+ # Avoid the extra array ref for single member roles
+ $data{$role} = shift @$members
+ if $group->SingleMemberRoleGroup;
+ }
+ }
return \%data;
}
commit c99f787a8550ff54732beb8e1e2f9ecc9eec5a61
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Aug 6 10:42:10 2013 -0700
Note why we use the Perl API after calling ->Serialize
diff --git a/lib/RTx/REST/Util.pm b/lib/RTx/REST/Util.pm
index 0f7357e..5b2b99b 100644
--- a/lib/RTx/REST/Util.pm
+++ b/lib/RTx/REST/Util.pm
@@ -42,6 +42,8 @@ sub serialize_record {
for my $column (grep !ref($data{$_}), keys %data) {
if ($record->_Accessible($column => "read")) {
+ # Replace values via the Perl API for consistency, access control,
+ # and utf-8 handling.
$data{$column} = $record->$column;
# Promote raw SQL dates to a standard format
commit d6e6e54390004f379ddcdf946b8b0643aa130cc3
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Aug 6 10:45:18 2013 -0700
Remove a TODO that's done
diff --git a/lib/RTx/REST/Resource/Collection.pm b/lib/RTx/REST/Resource/Collection.pm
index b169aac..c69516d 100644
--- a/lib/RTx/REST/Resource/Collection.pm
+++ b/lib/RTx/REST/Resource/Collection.pm
@@ -64,8 +64,6 @@ sub serialize {
my $collection = $self->collection;
my @results;
- # XXX TODO: paging
-
while (my $item = $collection->Next) {
push @results, serialize_record($item);
}
commit 8c74265d3f369ca8f25d97351ab6734580ed862d
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Aug 6 10:55:37 2013 -0700
Support for simple search syntax
diff --git a/lib/RTx/REST.pm b/lib/RTx/REST.pm
index 5481522..6e503bc 100644
--- a/lib/RTx/REST.pm
+++ b/lib/RTx/REST.pm
@@ -33,6 +33,7 @@ Currently provided endpoints under C</REST/2.0/> are:
Sets ticket status to "deleted".
GET /tickets?query=<TicketSQL>
+ GET /tickets?simple=1;query=<simple search query>
GET /queue/:id
PUT /queue/:id <JSON body>
diff --git a/lib/RTx/REST/Resource/Tickets.pm b/lib/RTx/REST/Resource/Tickets.pm
index f1e0579..966da1d 100644
--- a/lib/RTx/REST/Resource/Tickets.pm
+++ b/lib/RTx/REST/Resource/Tickets.pm
@@ -7,11 +7,23 @@ use namespace::autoclean;
extends 'RTx::REST::Resource::Collection';
+use RT::Search::Simple;
+
sub limit_collection {
my ($self, $tickets) = @_;
- my ($ok, $msg) = $tickets->FromSQL(
- $self->request->param('query') || ""
- );
+ my $query = $self->request->param('query') || "";
+
+ if ($self->request->param('simple') and $query) {
+ # XXX TODO: Note that "normal" ModifyQuery callback isn't invoked
+ # XXX TODO: Special-casing of "#NNN" isn't used
+ my $search = RT::Search::Simple->new(
+ Argument => $query,
+ TicketsObj => $tickets,
+ );
+ $query = $search->QueryToSQL;
+ }
+
+ my ($ok, $msg) = $tickets->FromSQL($query);
# XXX TODO: thread errors back to client; abort request with 4xx code?
}
commit 26003ff3b59d27fba7eb4736aa92f5fb44056b4f
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Aug 6 11:21:27 2013 -0700
Return 400 Bad Request on malformed search queries
This uses an explicit return \400 from the content function rather than
using a malformed_request function to avoid the need to build a new
collection object and call FromSQL twice.
The collection object on resources is now unlimited and unpaged until
->search is called so that query can be a separate attribute.
diff --git a/lib/RTx/REST/Resource/Collection.pm b/lib/RTx/REST/Resource/Collection.pm
index c69516d..44c6088 100644
--- a/lib/RTx/REST/Resource/Collection.pm
+++ b/lib/RTx/REST/Resource/Collection.pm
@@ -40,24 +40,28 @@ sub _collection_class {
sub _build_collection {
my $self = shift;
my $collection = $self->collection_class->new( $self->current_user );
- $self->limit_collection($collection);
- $self->paging($collection);
return $collection;
}
-sub paging {
- my ($self, $collection) = @_;
+sub setup_paging {
+ my $self = shift;
my $per_page = $self->request->param('per_page') || 20;
$per_page = 20 if $per_page <= 0;
$per_page = 100 if $per_page > 100;
- $collection->RowsPerPage($per_page);
+ $self->collection->RowsPerPage($per_page);
my $page = $self->request->param('page') || 1;
$page = 1 if $page < 0;
- $collection->GotoPage($page - 1);
+ $self->collection->GotoPage($page - 1);
}
-sub limit_collection { }
+sub limit_collection { 1 }
+
+sub search {
+ my $self = shift;
+ $self->setup_paging;
+ return $self->limit_collection;
+}
sub serialize {
my $self = shift;
@@ -87,6 +91,8 @@ sub content_types_provided { [
sub to_json {
my $self = shift;
+ $self->search
+ or return \400;
return JSON::to_json($self->serialize, { pretty => 1 });
}
diff --git a/lib/RTx/REST/Resource/Tickets.pm b/lib/RTx/REST/Resource/Tickets.pm
index 966da1d..d33b7cb 100644
--- a/lib/RTx/REST/Resource/Tickets.pm
+++ b/lib/RTx/REST/Resource/Tickets.pm
@@ -9,8 +9,15 @@ extends 'RTx::REST::Resource::Collection';
use RT::Search::Simple;
-sub limit_collection {
- my ($self, $tickets) = @_;
+has 'query' => (
+ is => 'ro',
+ isa => 'Str',
+ required => 1,
+ lazy_build => 1,
+);
+
+sub _build_query {
+ my $self = shift;
my $query = $self->request->param('query') || "";
if ($self->request->param('simple') and $query) {
@@ -18,13 +25,18 @@ sub limit_collection {
# XXX TODO: Special-casing of "#NNN" isn't used
my $search = RT::Search::Simple->new(
Argument => $query,
- TicketsObj => $tickets,
+ TicketsObj => $self->collection,
);
$query = $search->QueryToSQL;
}
+ return $query;
+}
- my ($ok, $msg) = $tickets->FromSQL($query);
- # XXX TODO: thread errors back to client; abort request with 4xx code?
+sub limit_collection {
+ my $self = shift;
+ my ($ok, $msg) = $self->collection->FromSQL( $self->query );
+ $self->response->body($msg) if not $ok;
+ return $ok;
}
__PACKAGE__->meta->make_immutable;
commit 2d257ea8c27c28089454693dd730344eedccbe09
Author: Thomas Sibley <trs at bestpractical.com>
Date: Wed Aug 7 10:50:29 2013 -0700
Collection resources queryable by JSON structures
Very basic support at the moment. Perhaps we'll do away with this for a
different approach, or extend it to be similar to ElasticSearch's
boolean structure for arbitrary complexity.
diff --git a/lib/RTx/REST/Resource/Collection/QueryByJSON.pm b/lib/RTx/REST/Resource/Collection/QueryByJSON.pm
new file mode 100644
index 0000000..ef86e13
--- /dev/null
+++ b/lib/RTx/REST/Resource/Collection/QueryByJSON.pm
@@ -0,0 +1,61 @@
+package RTx::REST::Resource::Collection::QueryByJSON;
+use strict;
+use warnings;
+
+use Moose::Role;
+use namespace::autoclean;
+
+use JSON ();
+
+requires 'collection';
+
+has 'query' => (
+ is => 'ro',
+ isa => 'ArrayRef[HashRef]',
+ required => 1,
+ lazy_build => 1,
+);
+
+sub _build_query {
+ my $self = shift;
+ return JSON::from_json( $self->request->content || '[]' );
+}
+
+sub allowed_methods {
+ [ 'POST' ]
+}
+
+sub searchable_fields {
+ $_[0]->collection->RecordClass->ReadableAttributes
+}
+
+sub limit_collection {
+ my $self = shift;
+ my $collection = $self->collection;
+ my $query = $self->query;
+ my @fields = $self->searchable_fields;
+ my %searchable = map {; $_ => 1 } @fields;
+
+ for my $limit (@$query) {
+ next unless $limit->{field}
+ and $searchable{$limit->{field}}
+ and defined $limit->{value};
+
+ $collection->Limit(
+ FIELD => $limit->{field},
+ VALUE => $limit->{value},
+ ( $limit->{operator}
+ ? (OPERATOR => $limit->{operator})
+ : () ),
+ );
+ }
+ return 1;
+}
+
+sub process_post {
+ my $self = shift;
+ $self->response->body( $self->to_json );
+ return 1;
+}
+
+1;
diff --git a/lib/RTx/REST/Resource/Queues.pm b/lib/RTx/REST/Resource/Queues.pm
new file mode 100644
index 0000000..d19355f
--- /dev/null
+++ b/lib/RTx/REST/Resource/Queues.pm
@@ -0,0 +1,13 @@
+package RTx::REST::Resource::Queues;
+use strict;
+use warnings;
+
+use Moose;
+use namespace::autoclean;
+
+extends 'RTx::REST::Resource::Collection';
+with 'RTx::REST::Resource::Collection::QueryByJSON';
+
+__PACKAGE__->meta->make_immutable;
+
+1;
diff --git a/lib/RTx/REST/Resource/Users.pm b/lib/RTx/REST/Resource/Users.pm
new file mode 100644
index 0000000..f079759
--- /dev/null
+++ b/lib/RTx/REST/Resource/Users.pm
@@ -0,0 +1,29 @@
+package RTx::REST::Resource::Users;
+use strict;
+use warnings;
+
+use Moose;
+use namespace::autoclean;
+
+extends 'RTx::REST::Resource::Collection';
+with 'RTx::REST::Resource::Collection::QueryByJSON';
+
+sub searchable_fields {
+ my $class = $_[0]->collection->RecordClass;
+ grep {
+ $class->_Accessible($_ => "public")
+ } $class->ReadableAttributes
+}
+
+sub forbidden {
+ my $self = shift;
+ return 0 if $self->current_user->HasRight(
+ Right => "AdminUsers",
+ Object => RT->System,
+ );
+ return 1;
+}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
commit cfafffe6a235d1916b9a91f0528636e7c16df23a
Author: Thomas Sibley <trs at bestpractical.com>
Date: Wed Aug 7 11:10:18 2013 -0700
Refactor the process_post which uses the GET handler to_json
Other resources will start using it, and it provides a central place for
fixes.
The refactor also considers the case that to_json may return a status
code which should not be used as the body but instead returned itself.
diff --git a/lib/RTx/REST/Resource/Collection/ProcessPOSTasGET.pm b/lib/RTx/REST/Resource/Collection/ProcessPOSTasGET.pm
new file mode 100644
index 0000000..a479e0b
--- /dev/null
+++ b/lib/RTx/REST/Resource/Collection/ProcessPOSTasGET.pm
@@ -0,0 +1,23 @@
+package RTx::REST::Resource::Collection::ProcessPOSTasGET;
+use strict;
+use warnings;
+
+use Moose::Role;
+use namespace::autoclean;
+
+use Web::Machine::FSM::States qw( is_status_code );
+
+requires 'to_json';
+
+sub process_post {
+ my $self = shift;
+ my $json = $self->to_json;
+ unless (is_status_code($json)) {
+ $self->response->body( $json );
+ return 1;
+ } else {
+ return $json;
+ }
+}
+
+1;
diff --git a/lib/RTx/REST/Resource/Collection/QueryByJSON.pm b/lib/RTx/REST/Resource/Collection/QueryByJSON.pm
index ef86e13..4b7af83 100644
--- a/lib/RTx/REST/Resource/Collection/QueryByJSON.pm
+++ b/lib/RTx/REST/Resource/Collection/QueryByJSON.pm
@@ -7,6 +7,8 @@ use namespace::autoclean;
use JSON ();
+with 'RTx::REST::Resource::Collection::ProcessPOSTasGET';
+
requires 'collection';
has 'query' => (
@@ -52,10 +54,4 @@ sub limit_collection {
return 1;
}
-sub process_post {
- my $self = shift;
- $self->response->body( $self->to_json );
- return 1;
-}
-
1;
commit 39d8aa2d271a46c43b3dfd6eb85114f34be022a1
Author: Thomas Sibley <trs at bestpractical.com>
Date: Wed Aug 7 11:14:23 2013 -0700
Allow POSTing to /tickets for searching as well
diff --git a/lib/RTx/REST/Resource/Tickets.pm b/lib/RTx/REST/Resource/Tickets.pm
index d33b7cb..7d29d44 100644
--- a/lib/RTx/REST/Resource/Tickets.pm
+++ b/lib/RTx/REST/Resource/Tickets.pm
@@ -6,6 +6,7 @@ use Moose;
use namespace::autoclean;
extends 'RTx::REST::Resource::Collection';
+with 'RTx::REST::Resource::Collection::ProcessPOSTasGET';
use RT::Search::Simple;
@@ -32,6 +33,10 @@ sub _build_query {
return $query;
}
+sub allowed_methods {
+ [ 'GET', 'HEAD', 'POST' ]
+}
+
sub limit_collection {
my $self = shift;
my ($ok, $msg) = $self->collection->FromSQL( $self->query );
commit 1e06db7a91424f6a8fe3ef74af16e3e2e05549d7
Author: Thomas Sibley <trs at bestpractical.com>
Date: Wed Aug 7 11:26:19 2013 -0700
Document collection resources a little more
diff --git a/lib/RTx/REST.pm b/lib/RTx/REST.pm
index 6e503bc..11fb13b 100644
--- a/lib/RTx/REST.pm
+++ b/lib/RTx/REST.pm
@@ -32,9 +32,6 @@ Currently provided endpoints under C</REST/2.0/> are:
DELETE /ticket/:id
Sets ticket status to "deleted".
- GET /tickets?query=<TicketSQL>
- GET /tickets?simple=1;query=<simple search query>
-
GET /queue/:id
PUT /queue/:id <JSON body>
DELETE /queue/:id
@@ -56,12 +53,46 @@ record will be updated.
A DELETE request to a resource will delete or disable the underlying record.
-=head2 Paging
+=head2 Searching
-All plural resources (such as C</tickets>) require pagination, controlled by
-the query parameters C<page> and C<per_page>. The default page size is 20
-items, but it may be increased up to 100 (or decreased if desired). Page
-numbers start at 1.
+=head3 Tickets
+
+ GET /tickets?query=<TicketSQL>
+ GET /tickets?simple=1;query=<simple search query>
+ POST /tickets
+ With the 'query' and optional 'simple' parameters
+
+The C<query> parameter expects TicketSQL by default unless a true value is sent
+for the C<simple> parameter.
+
+Results are returned in
+L<the format described below|/"Example of plural resources (collections)">.
+
+=head3 Queues and users
+
+ POST /queues
+ POST /users
+
+These resources accept a basic JSON structure as the search conditions which
+specifies one or more fields to limit on (using specified operators and
+values). An example:
+
+ curl -si -u user:pass http://rt.example.com/REST/2.0/queues -XPOST --data-binary '
+ [
+ { "field": "Name",
+ "operator": "LIKE",
+ "value": "Engineering" },
+
+ { "field": "Lifecycle",
+ "value": "helpdesk" }
+ ]
+ '
+
+The JSON payload must be an array of hashes with the keys C<field> and C<value>
+and optionally C<operator>.
+
+Results are returned in
+L<the format described below|/"Example of plural resources (collections)">.
=head2 Example of plural resources (collections)
@@ -83,6 +114,13 @@ standard JSON format:
Each item is nearly the same representation used when an individual resource
is requested.
+=head2 Paging
+
+All plural resources (such as C</tickets>) require pagination, controlled by
+the query parameters C<page> and C<per_page>. The default page size is 20
+items, but it may be increased up to 100 (or decreased if desired). Page
+numbers start at 1.
+
=head2 Authentication
Currently authentication is limited to internal RT usernames and passwords,
commit 566d71222dfe31ececc666dc8eab9179ef4a6a75
Author: Thomas Sibley <trs at bestpractical.com>
Date: Wed Aug 7 14:37:31 2013 -0700
Updatable is now Writable and includes create via POST
PUT is limited to update operations only for our sanity. Web-Machine's
routing of PUT vs. POST varies significantly depending on if the
resource exists, so we'll strictly enforce POST for create and PUT for
update, even though they could be used interchangeably with some more
effort.
diff --git a/lib/RTx/REST.pm b/lib/RTx/REST.pm
index 11fb13b..17bb827 100644
--- a/lib/RTx/REST.pm
+++ b/lib/RTx/REST.pm
@@ -53,6 +53,20 @@ record will be updated.
A DELETE request to a resource will delete or disable the underlying record.
+=head2 Creating
+
+ POST /ticket
+ POST /queue
+ POST /user
+
+A POST request to a resource endpoint, without a specific id/name, will create
+a new resource of that type. The request should have a JSON payload similar to
+the ones returned for existing resources.
+
+On success, the return status is 201 Created and a Location header points to
+the new resource uri. On failure, the status code indicates the nature of the
+issue, and a descriptive message is in the response body.
+
=head2 Searching
=head3 Tickets
diff --git a/lib/RTx/REST/Resource/Queue.pm b/lib/RTx/REST/Resource/Queue.pm
index 2991ff3..df3f65f 100644
--- a/lib/RTx/REST/Resource/Queue.pm
+++ b/lib/RTx/REST/Resource/Queue.pm
@@ -7,7 +7,7 @@ use namespace::autoclean;
extends 'RTx::REST::Resource::Record';
with 'RTx::REST::Resource::Record::DeletableByDisabling';
-with 'RTx::REST::Resource::Record::Updatable';
+with 'RTx::REST::Resource::Record::Writable';
__PACKAGE__->meta->make_immutable;
diff --git a/lib/RTx/REST/Resource/Record.pm b/lib/RTx/REST/Resource/Record.pm
index 915f46d..90e1d73 100644
--- a/lib/RTx/REST/Resource/Record.pm
+++ b/lib/RTx/REST/Resource/Record.pm
@@ -82,8 +82,8 @@ sub last_modified {
sub allowed_methods {
my $self = shift;
my @ok = ('GET', 'HEAD');
- push @ok, 'DELETE' if $self->DOES("RTx::REST::Resource::Record::Deletable");
- push @ok, 'PUT' if $self->DOES("RTx::REST::Resource::Record::Updatable");
+ push @ok, 'DELETE' if $self->DOES("RTx::REST::Resource::Record::Deletable");
+ push @ok, 'PUT', 'POST' if $self->DOES("RTx::REST::Resource::Record::Writable");
return \@ok;
}
diff --git a/lib/RTx/REST/Resource/Record/Updatable.pm b/lib/RTx/REST/Resource/Record/Updatable.pm
deleted file mode 100644
index ca37387..0000000
--- a/lib/RTx/REST/Resource/Record/Updatable.pm
+++ /dev/null
@@ -1,52 +0,0 @@
-package RTx::REST::Resource::Record::Updatable;
-use strict;
-use warnings;
-
-use Moose::Role;
-use namespace::autoclean;
-use JSON ();
-use RTx::REST::Util qw( looks_like_uid );
-
-requires 'record';
-requires 'record_class';
-
-sub content_types_accepted { [ {'application/json' => 'from_json'} ] }
-
-sub from_json {
- my $self = shift;
- $self->update_resource(
- JSON::from_json(
- $self->request->content,
- )
- );
-}
-
-sub update_resource {
- my $self = shift;
- my $data = shift;
-
- # Sanitize input
- for my $field (sort keys %$data) {
- my $value = $data->{$field};
- next unless ref $value;
- if (looks_like_uid($value)) {
- # Deconstruct UIDs back into simple foreign key IDs, assuming it
- # points to the same record type (class).
- $data->{$field} = $value->{id} || 0;
- }
- else {
- RT->Logger->debug("Received unknown value via JSON for field $field: ".ref($value));
- delete $data->{$field};
- }
- }
-
- my @results = $self->record->Update(
- ARGSRef => $data,
- AttributesRef => [ $self->record->WritableAttributes ],
- );
- # XXX TODO: Figure out how to return success/failure? Core RT::Record's
- # ->Update will need to be replaced or improved.
- return;
-}
-
-1;
diff --git a/lib/RTx/REST/Resource/Record/Writable.pm b/lib/RTx/REST/Resource/Record/Writable.pm
new file mode 100644
index 0000000..0ae936d
--- /dev/null
+++ b/lib/RTx/REST/Resource/Record/Writable.pm
@@ -0,0 +1,91 @@
+package RTx::REST::Resource::Record::Writable;
+use strict;
+use warnings;
+
+use Moose::Role;
+use namespace::autoclean;
+use JSON ();
+use RTx::REST::Util qw( looks_like_uid );
+
+requires 'record';
+requires 'record_class';
+
+sub post_is_create { 1 }
+sub allow_missing_post { 1 }
+sub create_path_after_handler { 1 }
+sub create_path {
+ $_[0]->record->id || undef
+}
+
+sub content_types_accepted { [ {'application/json' => 'from_json'} ] }
+
+sub from_json {
+ my $self = shift;
+ my $data = JSON::from_json( $self->request->content );
+
+ $self->filter_input($data);
+
+ my $method = $self->request->method;
+ return $method eq 'PUT' ? $self->update_resource($data) :
+ $method eq 'POST' ? $self->create_resource($data) :
+ \501 ;
+}
+
+sub filter_input {
+ my $self = shift;
+ my $data = shift;
+
+ # Sanitize input
+ for my $field (sort keys %$data) {
+ my $value = $data->{$field};
+ next unless ref $value;
+ if (looks_like_uid($value)) {
+ # Deconstruct UIDs back into simple foreign key IDs, assuming it
+ # points to the same record type (class).
+ $data->{$field} = $value->{id} || 0;
+ }
+ else {
+ RT->Logger->debug("Received unknown value via JSON for field $field: ".ref($value));
+ delete $data->{$field};
+ }
+ }
+}
+
+sub update_resource {
+ my $self = shift;
+ my $data = shift;
+
+ if (not $self->resource_exists) {
+ $self->response->body("Resource does not exist; use POST to create");
+ return \404;
+ }
+
+ my @results = $self->record->Update(
+ ARGSRef => $data,
+ AttributesRef => [ $self->record->WritableAttributes ],
+ );
+ # XXX TODO: Figure out how to return success/failure? Core RT::Record's
+ # ->Update will need to be replaced or improved.
+ $self->response->body( JSON::to_json(\@results) );
+ return;
+}
+
+sub create_resource {
+ my $self = shift;
+ my $data = shift;
+
+ if ($self->resource_exists) {
+ $self->response->body("Resource already exists; use PUT to update");
+ return \409;
+ }
+
+ my ($ok, $msg) = $self->record->Create( %$data );
+ if ($ok) {
+ return;
+ } else {
+ $self->response->body($msg || "Create failed for unknown reason");
+ return \409;
+ }
+}
+
+1;
diff --git a/lib/RTx/REST/Resource/Ticket.pm b/lib/RTx/REST/Resource/Ticket.pm
index 5a2be49..db9afa1 100644
--- a/lib/RTx/REST/Resource/Ticket.pm
+++ b/lib/RTx/REST/Resource/Ticket.pm
@@ -7,7 +7,7 @@ use namespace::autoclean;
extends 'RTx::REST::Resource::Record';
with 'RTx::REST::Resource::Record::Deletable';
-with 'RTx::REST::Resource::Record::Updatable';
+with 'RTx::REST::Resource::Record::Writable';
sub forbidden {
my $self = shift;
diff --git a/lib/RTx/REST/Resource/User.pm b/lib/RTx/REST/Resource/User.pm
index a76ae85..d49ea8c 100644
--- a/lib/RTx/REST/Resource/User.pm
+++ b/lib/RTx/REST/Resource/User.pm
@@ -7,7 +7,7 @@ use namespace::autoclean;
extends 'RTx::REST::Resource::Record';
with 'RTx::REST::Resource::Record::DeletableByDisabling';
-with 'RTx::REST::Resource::Record::Updatable';
+with 'RTx::REST::Resource::Record::Writable';
around 'serialize' => sub {
my $orig = shift;
commit 62280f2881296dfbe9e5fc4e65d552bf29773fe9
Author: Thomas Sibley <trs at bestpractical.com>
Date: Wed Aug 7 14:42:30 2013 -0700
Refactor filter_input into deserialize_record in Util.pm
Our serialization and deserialization routines need to be aware of each
other and will benefit from colocation in the same file.
diff --git a/lib/RTx/REST/Resource/Record/Writable.pm b/lib/RTx/REST/Resource/Record/Writable.pm
index 0ae936d..56e75c7 100644
--- a/lib/RTx/REST/Resource/Record/Writable.pm
+++ b/lib/RTx/REST/Resource/Record/Writable.pm
@@ -5,7 +5,7 @@ use warnings;
use Moose::Role;
use namespace::autoclean;
use JSON ();
-use RTx::REST::Util qw( looks_like_uid );
+use RTx::REST::Util qw( deserialize_record );
requires 'record';
requires 'record_class';
@@ -21,9 +21,10 @@ sub content_types_accepted { [ {'application/json' => 'from_json'} ] }
sub from_json {
my $self = shift;
- my $data = JSON::from_json( $self->request->content );
-
- $self->filter_input($data);
+ my $data = deserialize_record(
+ $self->record,
+ JSON::from_json( $self->request->content ),
+ );
my $method = $self->request->method;
return $method eq 'PUT' ? $self->update_resource($data) :
@@ -31,26 +32,6 @@ sub from_json {
\501 ;
}
-sub filter_input {
- my $self = shift;
- my $data = shift;
-
- # Sanitize input
- for my $field (sort keys %$data) {
- my $value = $data->{$field};
- next unless ref $value;
- if (looks_like_uid($value)) {
- # Deconstruct UIDs back into simple foreign key IDs, assuming it
- # points to the same record type (class).
- $data->{$field} = $value->{id} || 0;
- }
- else {
- RT->Logger->debug("Received unknown value via JSON for field $field: ".ref($value));
- delete $data->{$field};
- }
- }
-}
-
sub update_resource {
my $self = shift;
my $data = shift;
diff --git a/lib/RTx/REST/Util.pm b/lib/RTx/REST/Util.pm
index 5b2b99b..60dadb3 100644
--- a/lib/RTx/REST/Util.pm
+++ b/lib/RTx/REST/Util.pm
@@ -7,6 +7,7 @@ use Sub::Exporter -setup => {
looks_like_uid
expand_uid
serialize_record
+ deserialize_record
]]
};
@@ -80,4 +81,25 @@ sub serialize_record {
return \%data;
}
+sub deserialize_record {
+ my $record = shift;
+ my $data = shift;
+
+ # Sanitize input for the Perl API
+ for my $field (sort keys %$data) {
+ my $value = $data->{$field};
+ next unless ref $value;
+ if (looks_like_uid($value)) {
+ # Deconstruct UIDs back into simple foreign key IDs, assuming it
+ # points to the same record type (class).
+ $data->{$field} = $value->{id} || 0;
+ }
+ else {
+ RT->Logger->debug("Received unknown value via JSON for field $field: ".ref($value));
+ delete $data->{$field};
+ }
+ }
+ return $data;
+}
+
1;
commit 8723b9bfa90ad06d8082fb2a8e0b5ca5716f4543
Author: Thomas Sibley <trs at bestpractical.com>
Date: Wed Aug 7 14:43:28 2013 -0700
Only call load if we found a bound id
diff --git a/lib/RTx/REST/Resource/Record.pm b/lib/RTx/REST/Resource/Record.pm
index 90e1d73..af7b003 100644
--- a/lib/RTx/REST/Resource/Record.pm
+++ b/lib/RTx/REST/Resource/Record.pm
@@ -40,7 +40,8 @@ sub _record_class {
sub _build_record {
my $self = shift;
my $record = $self->record_class->new( $self->current_user );
- $record->Load( bind_path('/:id', $self->request->path_info) );
+ my $id = bind_path('/:id', $self->request->path_info);
+ $record->Load($id) if $id;
return $record;
}
commit e506268efbcd2cc46c7c46b2d824d688ec02fb36
Author: Thomas Sibley <trs at bestpractical.com>
Date: Wed Aug 7 16:02:50 2013 -0700
Deserialize roles when creating new records
Update is still broken for roles
diff --git a/lib/RTx/REST/Util.pm b/lib/RTx/REST/Util.pm
index 60dadb3..7f91371 100644
--- a/lib/RTx/REST/Util.pm
+++ b/lib/RTx/REST/Util.pm
@@ -85,6 +85,8 @@ sub deserialize_record {
my $record = shift;
my $data = shift;
+ my $does_roles = $record->DOES("RT::Record::Role::Roles");
+
# Sanitize input for the Perl API
for my $field (sort keys %$data) {
my $value = $data->{$field};
@@ -94,6 +96,16 @@ sub deserialize_record {
# points to the same record type (class).
$data->{$field} = $value->{id} || 0;
}
+ elsif ($does_roles and $record->HasRole($field)) {
+ my @members = ref $value eq 'ARRAY'
+ ? @$value : $value;
+
+ for my $member (@members) {
+ $member = $member->{id} || 0
+ if looks_like_uid($member);
+ }
+ $data->{$field} = \@members;
+ }
else {
RT->Logger->debug("Received unknown value via JSON for field $field: ".ref($value));
delete $data->{$field};
commit 822d40bb968c69dbdc469bfcafc5c07110db2248
Author: Thomas Sibley <trs at bestpractical.com>
Date: Wed Aug 7 16:06:24 2013 -0700
Note some pain points
diff --git a/lib/RTx/REST/Resource/Record/Deletable.pm b/lib/RTx/REST/Resource/Record/Deletable.pm
index 04f5dfe..d684866 100644
--- a/lib/RTx/REST/Resource/Record/Deletable.pm
+++ b/lib/RTx/REST/Resource/Record/Deletable.pm
@@ -13,6 +13,7 @@ sub delete_resource {
my ($ok, $msg) = $self->record->Delete;
RT->Logger->debug("Failed to delete ", $self->record_class, " #", $self->record->id, ": $msg")
unless $ok;
+ # XXX TODO: why can't I return a status code here? only true/false is available.
return $ok;
}
diff --git a/lib/RTx/REST/Resource/Record/Writable.pm b/lib/RTx/REST/Resource/Record/Writable.pm
index 56e75c7..a233679 100644
--- a/lib/RTx/REST/Resource/Record/Writable.pm
+++ b/lib/RTx/REST/Resource/Record/Writable.pm
@@ -41,6 +41,7 @@ sub update_resource {
return \404;
}
+ # XXX TODO: ->Update doesn't handle roles
my @results = $self->record->Update(
ARGSRef => $data,
AttributesRef => [ $self->record->WritableAttributes ],
commit 224804ab9b462ff169bc0c5f8ef10ad3ee66bb63
Author: Thomas Sibley <trs at bestpractical.com>
Date: Wed Aug 7 16:20:44 2013 -0700
Standardize error responses
Provide errors in the same content-type we're advertising for the
response (JSON).
diff --git a/lib/RTx/REST/Resource/Record/Writable.pm b/lib/RTx/REST/Resource/Record/Writable.pm
index a233679..bccbca5 100644
--- a/lib/RTx/REST/Resource/Record/Writable.pm
+++ b/lib/RTx/REST/Resource/Record/Writable.pm
@@ -5,7 +5,7 @@ use warnings;
use Moose::Role;
use namespace::autoclean;
use JSON ();
-use RTx::REST::Util qw( deserialize_record );
+use RTx::REST::Util qw( deserialize_record error_as_json );
requires 'record';
requires 'record_class';
@@ -37,8 +37,9 @@ sub update_resource {
my $data = shift;
if (not $self->resource_exists) {
- $self->response->body("Resource does not exist; use POST to create");
- return \404;
+ return error_as_json(
+ $self->response,
+ \404, "Resource does not exist; use POST to create");
}
# XXX TODO: ->Update doesn't handle roles
@@ -57,16 +58,18 @@ sub create_resource {
my $data = shift;
if ($self->resource_exists) {
- $self->response->body("Resource already exists; use PUT to update");
- return \409;
+ return error_as_json(
+ $self->response,
+ \409, "Resource already exists; use PUT to update");
}
my ($ok, $msg) = $self->record->Create( %$data );
if ($ok) {
return;
} else {
- $self->response->body($msg || "Create failed for unknown reason");
- return \409;
+ return error_as_json(
+ $self->response,
+ \409, $msg || "Create failed for unknown reason");
}
}
diff --git a/lib/RTx/REST/Resource/Tickets.pm b/lib/RTx/REST/Resource/Tickets.pm
index 7d29d44..ce4d9d6 100644
--- a/lib/RTx/REST/Resource/Tickets.pm
+++ b/lib/RTx/REST/Resource/Tickets.pm
@@ -8,6 +8,7 @@ use namespace::autoclean;
extends 'RTx::REST::Resource::Collection';
with 'RTx::REST::Resource::Collection::ProcessPOSTasGET';
+use RTx::REST::Util qw( error_as_json );
use RT::Search::Simple;
has 'query' => (
@@ -40,8 +41,7 @@ sub allowed_methods {
sub limit_collection {
my $self = shift;
my ($ok, $msg) = $self->collection->FromSQL( $self->query );
- $self->response->body($msg) if not $ok;
- return $ok;
+ return error_as_json( $self->response, ($ok ? 1 : 0), $msg );
}
__PACKAGE__->meta->make_immutable;
diff --git a/lib/RTx/REST/Util.pm b/lib/RTx/REST/Util.pm
index 7f91371..ad71332 100644
--- a/lib/RTx/REST/Util.pm
+++ b/lib/RTx/REST/Util.pm
@@ -8,6 +8,7 @@ use Sub::Exporter -setup => {
expand_uid
serialize_record
deserialize_record
+ error_as_json
]]
};
@@ -114,4 +115,16 @@ sub deserialize_record {
return $data;
}
+sub error_as_json {
+ my $response = shift;
+ my $return = shift;
+ $response->header( "Content-type" => "application/json; charset=utf-8" );
+ $response->body(
+ JSON::to_json(
+ { message => join "", @_ }
+ )
+ );
+ return $return;
+}
+
1;
commit c0f4157fb0ce1a95ad9dd2e89e16c813564b6354
Author: Thomas Sibley <trs at bestpractical.com>
Date: Wed Aug 7 16:21:11 2013 -0700
Allow search and limit_collection to return status codes directly
It may be useful to return something other than \400 and follows the
Web-Machine pattern.
diff --git a/lib/RTx/REST/Resource/Collection.pm b/lib/RTx/REST/Resource/Collection.pm
index 44c6088..49a108d 100644
--- a/lib/RTx/REST/Resource/Collection.pm
+++ b/lib/RTx/REST/Resource/Collection.pm
@@ -9,6 +9,7 @@ extends 'RTx::REST::Resource';
use Scalar::Util qw( blessed );
use Web::Machine::Util qw( bind_path create_date );
+use Web::Machine::FSM::States qw( is_status_code );
use Encode qw( decode_utf8 );
use Module::Runtime qw( require_module );
use JSON ();
@@ -91,8 +92,9 @@ sub content_types_provided { [
sub to_json {
my $self = shift;
- $self->search
- or return \400;
+ my $status = $self->search;
+ return $status if is_status_code($status);
+ return \400 unless $status;
return JSON::to_json($self->serialize, { pretty => 1 });
}
commit 3a7b86c9580ddfac5ca436c0a0ea08ae2fff1097
Author: Thomas Sibley <trs at bestpractical.com>
Date: Wed Aug 7 17:07:21 2013 -0700
Malformed JSON request sanity checks
diff --git a/Makefile.PL b/Makefile.PL
index cc7c058..9e34fb2 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -15,6 +15,7 @@ requires 'Module::Pluggable' => '4.8';
requires 'Module::Runtime';
requires 'Moose';
requires 'MooseX::NonMoose';
+requires 'MooseX::Role::Parameterized';
requires 'namespace::autoclean';
requires 'Plack::Builder';
requires 'Scalar::Util';
diff --git a/lib/RTx/REST/Resource/Collection/QueryByJSON.pm b/lib/RTx/REST/Resource/Collection/QueryByJSON.pm
index 4b7af83..a9920dd 100644
--- a/lib/RTx/REST/Resource/Collection/QueryByJSON.pm
+++ b/lib/RTx/REST/Resource/Collection/QueryByJSON.pm
@@ -8,6 +8,8 @@ use namespace::autoclean;
use JSON ();
with 'RTx::REST::Resource::Collection::ProcessPOSTasGET';
+with 'RTx::REST::Resource::Role::RequestBodyIsJSON'
+ => { type => 'ARRAY' };
requires 'collection';
@@ -20,7 +22,7 @@ has 'query' => (
sub _build_query {
my $self = shift;
- return JSON::from_json( $self->request->content || '[]' );
+ return JSON::from_json( $self->request->content );
}
sub allowed_methods {
diff --git a/lib/RTx/REST/Resource/Record/Writable.pm b/lib/RTx/REST/Resource/Record/Writable.pm
index bccbca5..03c48f1 100644
--- a/lib/RTx/REST/Resource/Record/Writable.pm
+++ b/lib/RTx/REST/Resource/Record/Writable.pm
@@ -7,6 +7,9 @@ use namespace::autoclean;
use JSON ();
use RTx::REST::Util qw( deserialize_record error_as_json );
+with 'RTx::REST::Resource::Role::RequestBodyIsJSON'
+ => { type => 'HASH' };
+
requires 'record';
requires 'record_class';
diff --git a/lib/RTx/REST/Resource/Role/RequestBodyIsJSON.pm b/lib/RTx/REST/Resource/Role/RequestBodyIsJSON.pm
new file mode 100644
index 0000000..5c410fb
--- /dev/null
+++ b/lib/RTx/REST/Resource/Role/RequestBodyIsJSON.pm
@@ -0,0 +1,47 @@
+package RTx::REST::Resource::Role::RequestBodyIsJSON;
+use strict;
+use warnings;
+
+use MooseX::Role::Parameterized;
+use namespace::autoclean;
+
+use JSON ();
+use RTx::REST::Util qw( error_as_json );
+use Moose::Util::TypeConstraints qw( enum );
+
+parameter 'type' => (
+ isa => enum([qw(ARRAY HASH)]),
+ default => 'HASH',
+);
+
+role {
+ my $P = shift;
+
+ around 'malformed_request' => sub {
+ my $orig = shift;
+ my $self = shift;
+ my $malformed = $self->$orig(@_);
+ return $malformed if $malformed;
+
+ my $request = $self->request;
+ return 0 unless $request->method =~ /^(PUT|POST)$/;
+
+ my $json = eval {
+ JSON::from_json($request->content)
+ };
+ if ($@ or not $json) {
+ my $error = $@;
+ $error =~ s/ at \S+? line \d+\.?$//;
+ error_as_json($self->response, undef, "JSON parse error: $error");
+ return 1;
+ }
+ elsif (ref $json ne $P->type) {
+ error_as_json($self->response, undef, "JSON object must be a ", $P->type);
+ return 1;
+ } else {
+ return 0;
+ }
+ };
+};
+
+1;
commit 6a209c22339c4765115bbf3b52217447ed84fa61
Author: Thomas Sibley <trs at bestpractical.com>
Date: Wed Aug 7 17:13:08 2013 -0700
Abstract out record creation from create_resource
… so we can account for classes with a non-standard return value from
Create (such as tickets).
diff --git a/lib/RTx/REST/Resource/Record/Writable.pm b/lib/RTx/REST/Resource/Record/Writable.pm
index 03c48f1..5bb17dd 100644
--- a/lib/RTx/REST/Resource/Record/Writable.pm
+++ b/lib/RTx/REST/Resource/Record/Writable.pm
@@ -56,6 +56,12 @@ sub update_resource {
return;
}
+sub create_record {
+ my $self = shift;
+ my $data = shift;
+ return $self->record->Create( %$data );
+}
+
sub create_resource {
my $self = shift;
my $data = shift;
@@ -66,7 +72,7 @@ sub create_resource {
\409, "Resource already exists; use PUT to update");
}
- my ($ok, $msg) = $self->record->Create( %$data );
+ my ($ok, $msg) = $self->create_record($data);
if ($ok) {
return;
} else {
diff --git a/lib/RTx/REST/Resource/Ticket.pm b/lib/RTx/REST/Resource/Ticket.pm
index db9afa1..e6e49a6 100644
--- a/lib/RTx/REST/Resource/Ticket.pm
+++ b/lib/RTx/REST/Resource/Ticket.pm
@@ -16,6 +16,13 @@ sub forbidden {
return 1;
}
+sub create_record {
+ my $self = shift;
+ my $data = shift;
+ my ($ok, $txn, $msg) = $self->record->Create(%$data);
+ return ($ok, $msg);
+}
+
__PACKAGE__->meta->make_immutable;
1;
commit ef3cdcdc07a024e040a7c21cf8b25bf55a49c09f
Author: Thomas Sibley <trs at bestpractical.com>
Date: Thu Aug 8 13:57:36 2013 -0700
Add a logger in the PSGI environment which uses RT's logging framework
Web::Machine, and other PSGI components, will use this to log messages
and we don't need to log ourselves in the finish_request function.
diff --git a/lib/RTx/REST.pm b/lib/RTx/REST.pm
index 17bb827..827417e 100644
--- a/lib/RTx/REST.pm
+++ b/lib/RTx/REST.pm
@@ -181,6 +181,11 @@ sub resource {
sub app {
my $class = shift;
return sub {
+ my ($env) = @_;
+ $env->{'psgix.logger'} = sub {
+ my $what = shift;
+ RT->Logger->log(%$what);
+ };
# XXX TODO: logging of SQL queries in RT's framework for doing so
# XXX TODO: Need a dispatcher? Or do it inside resources? Web::Simple?
RT::ConnectToDatabase();
diff --git a/lib/RTx/REST/Resource.pm b/lib/RTx/REST/Resource.pm
index 95bfb4a..b128e18 100644
--- a/lib/RTx/REST/Resource.pm
+++ b/lib/RTx/REST/Resource.pm
@@ -20,13 +20,6 @@ sub _build_current_user {
$_[0]->request->env->{"rt.current_user"} || RT::CurrentUser->new;
}
-sub finish_request {
- my ($self, $meta) = @_;
- if ($meta->{exception}) {
- RT->Logger->crit("Error processing resource request: $meta->{exception}");
- }
-}
-
__PACKAGE__->meta->make_immutable;
1;
commit 3ac4f1fa1ae6e4809ff89bd2d8b4ceaf774d4f25
Author: Thomas Sibley <trs at bestpractical.com>
Date: Thu Aug 8 15:04:08 2013 -0700
Handle decoding of UTF-8 data in request (params and body)
Web::Machine doesn't currently handle this automatically like outgoing
resources. Due to some asymmetry in processing, we also need to encode
to UTF-8 whenever we set the response body before returning an error
status code.
diff --git a/lib/RTx/REST/Resource/Collection.pm b/lib/RTx/REST/Resource/Collection.pm
index 49a108d..200c8fe 100644
--- a/lib/RTx/REST/Resource/Collection.pm
+++ b/lib/RTx/REST/Resource/Collection.pm
@@ -10,9 +10,7 @@ extends 'RTx::REST::Resource';
use Scalar::Util qw( blessed );
use Web::Machine::Util qw( bind_path create_date );
use Web::Machine::FSM::States qw( is_status_code );
-use Encode qw( decode_utf8 );
use Module::Runtime qw( require_module );
-use JSON ();
use RTx::REST::Util qw( serialize_record );
has 'collection_class' => (
diff --git a/lib/RTx/REST/Resource/Collection/QueryByJSON.pm b/lib/RTx/REST/Resource/Collection/QueryByJSON.pm
index a9920dd..e0362fe 100644
--- a/lib/RTx/REST/Resource/Collection/QueryByJSON.pm
+++ b/lib/RTx/REST/Resource/Collection/QueryByJSON.pm
@@ -22,7 +22,7 @@ has 'query' => (
sub _build_query {
my $self = shift;
- return JSON::from_json( $self->request->content );
+ return JSON::decode_json( $self->request->content );
}
sub allowed_methods {
diff --git a/lib/RTx/REST/Resource/Record.pm b/lib/RTx/REST/Resource/Record.pm
index af7b003..b59488c 100644
--- a/lib/RTx/REST/Resource/Record.pm
+++ b/lib/RTx/REST/Resource/Record.pm
@@ -9,7 +9,6 @@ extends 'RTx::REST::Resource';
use Scalar::Util qw( blessed );
use Web::Machine::Util qw( bind_path create_date );
-use Encode qw( decode_utf8 );
use Module::Runtime qw( require_module );
use JSON ();
use RTx::REST::Util qw( serialize_record );
diff --git a/lib/RTx/REST/Resource/Record/Writable.pm b/lib/RTx/REST/Resource/Record/Writable.pm
index 5bb17dd..5d2bda7 100644
--- a/lib/RTx/REST/Resource/Record/Writable.pm
+++ b/lib/RTx/REST/Resource/Record/Writable.pm
@@ -26,7 +26,7 @@ sub from_json {
my $self = shift;
my $data = deserialize_record(
$self->record,
- JSON::from_json( $self->request->content ),
+ JSON::decode_json( $self->request->content ),
);
my $method = $self->request->method;
@@ -52,7 +52,7 @@ sub update_resource {
);
# XXX TODO: Figure out how to return success/failure? Core RT::Record's
# ->Update will need to be replaced or improved.
- $self->response->body( JSON::to_json(\@results) );
+ $self->response->body( JSON::encode_json(\@results) );
return;
}
diff --git a/lib/RTx/REST/Resource/Tickets.pm b/lib/RTx/REST/Resource/Tickets.pm
index ce4d9d6..9ca56f8 100644
--- a/lib/RTx/REST/Resource/Tickets.pm
+++ b/lib/RTx/REST/Resource/Tickets.pm
@@ -8,6 +8,7 @@ use namespace::autoclean;
extends 'RTx::REST::Resource::Collection';
with 'RTx::REST::Resource::Collection::ProcessPOSTasGET';
+use Encode qw( decode_utf8 );
use RTx::REST::Util qw( error_as_json );
use RT::Search::Simple;
@@ -20,7 +21,7 @@ has 'query' => (
sub _build_query {
my $self = shift;
- my $query = $self->request->param('query') || "";
+ my $query = decode_utf8($self->request->param('query') || "");
if ($self->request->param('simple') and $query) {
# XXX TODO: Note that "normal" ModifyQuery callback isn't invoked
diff --git a/lib/RTx/REST/Util.pm b/lib/RTx/REST/Util.pm
index ad71332..082eabc 100644
--- a/lib/RTx/REST/Util.pm
+++ b/lib/RTx/REST/Util.pm
@@ -2,6 +2,8 @@ package RTx::REST::Util;
use strict;
use warnings;
+use JSON ();
+
use Sub::Exporter -setup => {
exports => [qw[
looks_like_uid
@@ -119,11 +121,7 @@ sub error_as_json {
my $response = shift;
my $return = shift;
$response->header( "Content-type" => "application/json; charset=utf-8" );
- $response->body(
- JSON::to_json(
- { message => join "", @_ }
- )
- );
+ $response->body( JSON::encode_json({ message => join "", @_ }) );
return $return;
}
commit 946131ac7ddadbe012ee378b34870ac37b5f724d
Author: Thomas Sibley <trs at bestpractical.com>
Date: Fri Aug 9 14:29:29 2013 -0700
Basic CF support
Returned as "CF.Name" keys, always as arrays. Needs to handle
image/file CFs, long text (via LargeContent), and roundtripping.
diff --git a/lib/RTx/REST/Util.pm b/lib/RTx/REST/Util.pm
index 082eabc..6dbce61 100644
--- a/lib/RTx/REST/Util.pm
+++ b/lib/RTx/REST/Util.pm
@@ -81,6 +81,23 @@ sub serialize_record {
if $group->SingleMemberRoleGroup;
}
}
+
+ # Custom fields; no role yet, but we have registered lookup types
+ my %registered_type = map {; $_ => 1 } RT::CustomField->LookupTypes;
+ if ($registered_type{$record->CustomFieldLookupType}) {
+ my $cfs = $record->CustomFields;
+ while (my $cf = $cfs->Next) {
+ # Multiple CFs with the same name will use the same key
+ my $key = "CF." . $cf->Name;
+ my $values = $data{$key} ||= [];
+ my $ocfvs = $cf->ValuesForObject( $record );
+ while (my $ocfv = $ocfvs->Next) {
+ # XXX TODO: handle image/file uploads specially
+ # XXX TODO: we sometimes need to use LargeContent instead
+ push @$values, $ocfv->Content;
+ }
+ }
+ }
return \%data;
}
commit 81a5a18f2342fa93e318bc7fbd6f7b8b628e5895
Author: Thomas Sibley <trs at bestpractical.com>
Date: Fri Aug 9 15:36:06 2013 -0700
Automatic detection of resources isn't as simple anymore
Listing resources manually is simpler than filtering out base classes,
dealing with multiple directories, etc.
diff --git a/Makefile.PL b/Makefile.PL
index 9e34fb2..c7038fd 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -11,7 +11,6 @@ requires_rt('4.1.17');
requires 'Encode';
requires 'JSON';
-requires 'Module::Pluggable' => '4.8';
requires 'Module::Runtime';
requires 'Moose';
requires 'MooseX::NonMoose';
diff --git a/lib/RTx/REST.pm b/lib/RTx/REST.pm
index 827417e..b532815 100644
--- a/lib/RTx/REST.pm
+++ b/lib/RTx/REST.pm
@@ -9,11 +9,6 @@ our $VERSION = '0.01';
use UNIVERSAL::require;
use Plack::Builder;
use Web::Machine;
-use Module::Pluggable
- sub_name => "_resources",
- search_path => ["RTx::REST::Resource"],
- max_depth => 4,
- require => 1;
=encoding utf-8
@@ -166,10 +161,14 @@ handle them appropriately.
# XXX TODO: API doc
sub resources {
- state @resources;
- @resources = grep { s/^RTx::REST::Resource:://; $_ } $_[0]->_resources
- unless @resources;
- return @resources;
+ return qw(
+ Queue
+ Queues
+ Ticket
+ Tickets
+ User
+ Users
+ );
}
sub resource {
@@ -206,8 +205,10 @@ sub app {
return 0;
}
};
- mount "/\L$_" => resource($_)
- for $class->resources;
+ for ($class->resources) {
+ (my $path = lc $_) =~ s{::}{/}g;
+ mount "/$path" => resource($_);
+ }
mount "/" => sub { [ 404, ['Content-type' => 'text/plain'], ['Unknown resource'] ] };
};
$dispatch->(@_);
commit 7bf466797dfda8daac6f454e752a4b46d7c5066f
Author: Thomas Sibley <trs at bestpractical.com>
Date: Fri Aug 30 15:09:44 2013 -0700
Provide a standard format_datetime() utility function
diff --git a/lib/RTx/REST/Util.pm b/lib/RTx/REST/Util.pm
index 6dbce61..437dbfb 100644
--- a/lib/RTx/REST/Util.pm
+++ b/lib/RTx/REST/Util.pm
@@ -40,6 +40,13 @@ sub expand_uid {
};
}
+sub format_datetime {
+ my $sql = shift;
+ my $date = RT::Date->new( RT->SystemUser );
+ $date->Set( Format => 'sql', Value => $sql );
+ return $date->W3CDTF( Timezone => 'UTC' );
+}
+
sub serialize_record {
my $record = shift;
my %data = $record->Serialize(@_);
@@ -52,9 +59,7 @@ sub serialize_record {
# Promote raw SQL dates to a standard format
if ($record->_Accessible($column => "type") =~ /(datetime|timestamp)/i) {
- my $date = RT::Date->new( $record->CurrentUser );
- $date->Set( Format => 'sql', Value => $data{$column} );
- $data{$column} = $date->W3CDTF( Timezone => 'UTC' );
+ $data{$column} = format_datetime( $data{$column} );
}
} else {
delete $data{$column};
commit b63ca8a7d6dbeca25e529e0b085b1f96a10f35a2
Author: Thomas Sibley <trs at bestpractical.com>
Date: Fri Aug 30 15:11:05 2013 -0700
RTx::REST->base_path to provide the path prefix for resources
diff --git a/lib/RTx/REST.pm b/lib/RTx/REST.pm
index b532815..193438b 100644
--- a/lib/RTx/REST.pm
+++ b/lib/RTx/REST.pm
@@ -224,6 +224,10 @@ sub PSGIWrap {
};
}
+sub base_path {
+ RT->Config->Get("WebPath") . "/REST/2.0"
+}
+
=head1 INSTALLATION
=over
commit fe9cdf048f0d298179e50465b908c9fde18b1a46
Author: Thomas Sibley <trs at bestpractical.com>
Date: Fri Aug 30 15:21:40 2013 -0700
Standardize on full URIs under a _url key to reference resources
Previously both url and _url were used and some values were full URIs
while others were not.
diff --git a/lib/RTx/REST.pm b/lib/RTx/REST.pm
index 193438b..91453f8 100644
--- a/lib/RTx/REST.pm
+++ b/lib/RTx/REST.pm
@@ -228,6 +228,10 @@ sub base_path {
RT->Config->Get("WebPath") . "/REST/2.0"
}
+sub base_uri {
+ RT->Config->Get("WebBaseURL") . base_path()
+}
+
=head1 INSTALLATION
=over
diff --git a/lib/RTx/REST/Util.pm b/lib/RTx/REST/Util.pm
index 437dbfb..06036a3 100644
--- a/lib/RTx/REST/Util.pm
+++ b/lib/RTx/REST/Util.pm
@@ -17,7 +17,7 @@ use Sub::Exporter -setup => {
sub looks_like_uid {
my $value = shift;
return 0 unless ref $value eq 'HASH';
- return 0 unless $value->{type} and $value->{id} and $value->{url};
+ return 0 unless $value->{type} and $value->{id} and $value->{_url};
return 1;
}
@@ -36,7 +36,7 @@ sub expand_uid {
return {
type => $class,
id => $id,
- url => "/$class/$id",
+ _url => RTx::REST->base_uri . "/$class/$id",
};
}
commit f87203a33d3102e2787e0a4dba78b3c082b55a3f
Author: Thomas Sibley <trs at bestpractical.com>
Date: Fri Aug 30 15:33:38 2013 -0700
Use a builder instead of a default subref so subclassing works
A default coderef is static, and unsubclassable. The whole point of
builders is to allow subclassing.
diff --git a/lib/RTx/REST/Resource/Collection.pm b/lib/RTx/REST/Resource/Collection.pm
index 200c8fe..0706762 100644
--- a/lib/RTx/REST/Resource/Collection.pm
+++ b/lib/RTx/REST/Resource/Collection.pm
@@ -17,8 +17,7 @@ has 'collection_class' => (
is => 'ro',
isa => 'ClassName',
required => 1,
- lazy => 1,
- default => \&_collection_class,
+ lazy_build => 1,
);
has 'collection' => (
@@ -28,7 +27,7 @@ has 'collection' => (
lazy_build => 1,
);
-sub _collection_class {
+sub _build_collection_class {
my $self = shift;
my ($type) = blessed($self) =~ /::(\w+)$/;
my $class = "RT::$type";
diff --git a/lib/RTx/REST/Resource/Record.pm b/lib/RTx/REST/Resource/Record.pm
index b59488c..a961ac3 100644
--- a/lib/RTx/REST/Resource/Record.pm
+++ b/lib/RTx/REST/Resource/Record.pm
@@ -17,8 +17,7 @@ has 'record_class' => (
is => 'ro',
isa => 'ClassName',
required => 1,
- lazy => 1,
- default => \&_record_class,
+ lazy_build => 1,
);
has 'record' => (
@@ -28,7 +27,7 @@ has 'record' => (
lazy_build => 1,
);
-sub _record_class {
+sub _build_record_class {
my $self = shift;
my ($type) = blessed($self) =~ /::(\w+)$/;
my $class = "RT::$type";
commit 2e71fce46acd02dcfbac4ac946ef70c6c097d9ad
Author: Thomas Sibley <trs at bestpractical.com>
Date: Fri Aug 30 15:38:20 2013 -0700
Format DateTime CFs the same way as all other datetimes
diff --git a/lib/RTx/REST/Util.pm b/lib/RTx/REST/Util.pm
index 06036a3..cc8ee3a 100644
--- a/lib/RTx/REST/Util.pm
+++ b/lib/RTx/REST/Util.pm
@@ -96,10 +96,15 @@ sub serialize_record {
my $key = "CF." . $cf->Name;
my $values = $data{$key} ||= [];
my $ocfvs = $cf->ValuesForObject( $record );
+ my $type = $cf->Type;
while (my $ocfv = $ocfvs->Next) {
# XXX TODO: handle image/file uploads specially
# XXX TODO: we sometimes need to use LargeContent instead
- push @$values, $ocfv->Content;
+ my $content = $ocfv->Content;
+ if ($type eq 'DateTime') {
+ $content = format_datetime($content);
+ }
+ push @$values, $content;
}
}
}
commit e59ebbe61bb9d5e54056ba4e73875ad9ecca33c5
Author: Thomas Sibley <trs at bestpractical.com>
Date: Fri Aug 30 15:39:02 2013 -0700
Expand image/upload CFs into a hash with filename, content-type, and a url
The download url does not yet exist, but will soon.
diff --git a/lib/RTx/REST/Util.pm b/lib/RTx/REST/Util.pm
index cc8ee3a..9b3b26b 100644
--- a/lib/RTx/REST/Util.pm
+++ b/lib/RTx/REST/Util.pm
@@ -98,12 +98,17 @@ sub serialize_record {
my $ocfvs = $cf->ValuesForObject( $record );
my $type = $cf->Type;
while (my $ocfv = $ocfvs->Next) {
- # XXX TODO: handle image/file uploads specially
- # XXX TODO: we sometimes need to use LargeContent instead
my $content = $ocfv->Content;
if ($type eq 'DateTime') {
$content = format_datetime($content);
}
+ elsif ($type eq 'Image' or $type eq 'Binary') {
+ $content = {
+ content_type => $ocfv->ContentType,
+ filename => $content,
+ _url => RTx::REST->base_uri . "/download/cf/" . $ocfv->id,
+ };
+ }
push @$values, $content;
}
}
commit a10ccbcddcd92f39b0ccb5d3fae56ed019485d41
Author: Thomas Sibley <trs at bestpractical.com>
Date: Fri Aug 30 17:12:52 2013 -0700
Refactor record serialization logic into a Record::Readable role
The Record resource is now more generally usable, such as for resources
backed by records but which don't want to use a serialized
representation.
The name "Readable" may not be quite right, but it matches the existing
naming of similar roles (i.e. Writable). For now, it's fine. In the
future, it may want to become more specific.
diff --git a/lib/RTx/REST/Resource/Queue.pm b/lib/RTx/REST/Resource/Queue.pm
index df3f65f..d647738 100644
--- a/lib/RTx/REST/Resource/Queue.pm
+++ b/lib/RTx/REST/Resource/Queue.pm
@@ -6,6 +6,7 @@ use Moose;
use namespace::autoclean;
extends 'RTx::REST::Resource::Record';
+with 'RTx::REST::Resource::Record::Readable';
with 'RTx::REST::Resource::Record::DeletableByDisabling';
with 'RTx::REST::Resource::Record::Writable';
diff --git a/lib/RTx/REST/Resource/Record.pm b/lib/RTx/REST/Resource/Record.pm
index a961ac3..217a58d 100644
--- a/lib/RTx/REST/Resource/Record.pm
+++ b/lib/RTx/REST/Resource/Record.pm
@@ -10,8 +10,6 @@ extends 'RTx::REST::Resource';
use Scalar::Util qw( blessed );
use Web::Machine::Util qw( bind_path create_date );
use Module::Runtime qw( require_module );
-use JSON ();
-use RTx::REST::Util qw( serialize_record );
has 'record_class' => (
is => 'ro',
@@ -43,16 +41,6 @@ sub _build_record {
return $record;
}
-sub serialize {
- my $self = shift;
- my $data = serialize_record( $self->record );
-
- # Add the resource url for this record
- $data->{_url} = join "/", $self->base_uri, $self->record->id;
-
- return $data;
-}
-
sub base_uri {
$_[0]->request->base
}
@@ -80,24 +68,13 @@ sub last_modified {
sub allowed_methods {
my $self = shift;
- my @ok = ('GET', 'HEAD');
+ my @ok;
+ push @ok, 'GET', 'HEAD' if $self->DOES("RTx::REST::Resource::Record::Readable");
push @ok, 'DELETE' if $self->DOES("RTx::REST::Resource::Record::Deletable");
push @ok, 'PUT', 'POST' if $self->DOES("RTx::REST::Resource::Record::Writable");
return \@ok;
}
-sub charsets_provided { [ 'utf-8' ] }
-sub default_charset { 'utf-8' }
-
-sub content_types_provided { [
- { 'application/json' => 'to_json' },
-] }
-
-sub to_json {
- my $self = shift;
- return JSON::to_json($self->serialize, { pretty => 1 });
-}
-
sub finish_request {
my $self = shift;
# Ensure the record object is destroyed before the request finishes, for
diff --git a/lib/RTx/REST/Resource/Record/Readable.pm b/lib/RTx/REST/Resource/Record/Readable.pm
new file mode 100644
index 0000000..2ba09d4
--- /dev/null
+++ b/lib/RTx/REST/Resource/Record/Readable.pm
@@ -0,0 +1,38 @@
+package RTx::REST::Resource::Record::Readable;
+use strict;
+use warnings;
+
+use Moose::Role;
+use namespace::autoclean;
+
+requires 'record';
+requires 'record_class';
+requires 'current_user';
+requires 'base_uri';
+
+use JSON ();
+use RTx::REST::Util qw( serialize_record );
+
+sub serialize {
+ my $self = shift;
+ my $data = serialize_record( $self->record );
+
+ # Add the resource url for this record
+ $data->{_url} = join "/", $self->base_uri, $self->record->id;
+
+ return $data;
+}
+
+sub charsets_provided { [ 'utf-8' ] }
+sub default_charset { 'utf-8' }
+
+sub content_types_provided { [
+ { 'application/json' => 'to_json' },
+] }
+
+sub to_json {
+ my $self = shift;
+ return JSON::to_json($self->serialize, { pretty => 1 });
+}
+
+1;
diff --git a/lib/RTx/REST/Resource/Ticket.pm b/lib/RTx/REST/Resource/Ticket.pm
index e6e49a6..b09ba9e 100644
--- a/lib/RTx/REST/Resource/Ticket.pm
+++ b/lib/RTx/REST/Resource/Ticket.pm
@@ -6,6 +6,7 @@ use Moose;
use namespace::autoclean;
extends 'RTx::REST::Resource::Record';
+with 'RTx::REST::Resource::Record::Readable';
with 'RTx::REST::Resource::Record::Deletable';
with 'RTx::REST::Resource::Record::Writable';
diff --git a/lib/RTx/REST/Resource/User.pm b/lib/RTx/REST/Resource/User.pm
index d49ea8c..6459383 100644
--- a/lib/RTx/REST/Resource/User.pm
+++ b/lib/RTx/REST/Resource/User.pm
@@ -6,6 +6,7 @@ use Moose;
use namespace::autoclean;
extends 'RTx::REST::Resource::Record';
+with 'RTx::REST::Resource::Record::Readable';
with 'RTx::REST::Resource::Record::DeletableByDisabling';
with 'RTx::REST::Resource::Record::Writable';
commit 283f8912aac7a606281fff594f8c8f3f1ce6e43d
Author: Thomas Sibley <trs at bestpractical.com>
Date: Fri Aug 30 17:16:01 2013 -0700
Downloading of object CF values via the previously generated urls
diff --git a/lib/RTx/REST.pm b/lib/RTx/REST.pm
index 91453f8..e3c2fc4 100644
--- a/lib/RTx/REST.pm
+++ b/lib/RTx/REST.pm
@@ -168,6 +168,7 @@ sub resources {
Tickets
User
Users
+ Download::CF
);
}
diff --git a/lib/RTx/REST/Resource/Download/CF.pm b/lib/RTx/REST/Resource/Download/CF.pm
new file mode 100644
index 0000000..06b5987
--- /dev/null
+++ b/lib/RTx/REST/Resource/Download/CF.pm
@@ -0,0 +1,51 @@
+package RTx::REST::Resource::Download::CF;
+use strict;
+use warnings;
+
+use Moose;
+use namespace::autoclean;
+
+extends 'RTx::REST::Resource::Record';
+
+has 'content_type' => (
+ is => 'ro',
+ isa => 'Str',
+ required => 1,
+ lazy_build => 1,
+);
+
+sub _build_record_class { "RT::ObjectCustomFieldValue" }
+sub _build_content_type {
+ my $self = shift;
+ return $self->record->ContentType || 'text/plain';
+}
+
+sub allowed_methods { [ 'GET', 'HEAD' ] }
+
+sub content_types_provided { [
+ { $_[0]->content_type => 'to_content' },
+] }
+
+sub charsets_provided {
+ my $self = shift;
+ # We need to serve both binary data (sans charset) and textual data (using
+ # utf-8). The RT::I18N helper is used in _DecodeLOB (via LargeContent),
+ # and determines if the data returned by LargeContent has been decoded from
+ # UTF-8 bytes to characters. If not, the data remains bytes and we serve
+ # no charset.
+ if ( RT::I18N::IsTextualContentType( $self->content_type ) ) {
+ return [ 'utf-8' ];
+ } else {
+ return [];
+ }
+}
+sub default_charset { $_[0]->charsets_provided->[0] }
+
+sub to_content {
+ my $self = shift;
+ return $self->record->LargeContent;
+}
+
+__PACKAGE__->meta->make_immutable;
+
+1;
commit c0984997cae1585554da8d937d40e2762abd2591
Author: Thomas Sibley <trs at bestpractical.com>
Date: Fri Aug 30 17:18:35 2013 -0700
Add my (incomplete) TODO list
There are a lot of places to jump in and add features.
diff --git a/TODO b/TODO
new file mode 100644
index 0000000..0ecd31a
--- /dev/null
+++ b/TODO
@@ -0,0 +1,8 @@
+Find TODOs in the code via `ag TODO`.
+
+XXX TODO: Include Links in record serializations
+XXX TODO: Serialized resources for CFs, Links, Groups
+XXX TODO: History + attachments
+XXX TODO: Articles, Classes, Topics
+XXX TODO: Updating of roles and CFs (and links, etc)
+XXX TODO: Adding comments/replies
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list