[Bps-public-commit] rt-extension-announce branch, master, created. 20a61f04c2faca3499c2d551b82dfea01b86cebb
? sunnavy
sunnavy at bestpractical.com
Fri Feb 1 15:10:15 EST 2013
The branch, master has been created
at 20a61f04c2faca3499c2d551b82dfea01b86cebb (commit)
- Log -----------------------------------------------------------------
commit 02d612a635fa488e7cf0698acd2f1844121ef650
Author: Jim Brandt <jbrandt at bestpractical.com>
Date: Wed Jun 20 10:13:22 2012 -0400
Initial commit.
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..2cbfeea
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,12 @@
+blib*
+Makefile
+Makefile.old
+pm_to_blib*
+*.tar.gz
+.lwpcookies
+cover_db
+pod2htm*.tmp
+/RT-Extension-Announce*
+*.bak
+*.swp
+/MYMETA.*
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..f102477
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,23 @@
+---
+abstract: 'RT Extension-Announce Extension'
+author:
+ - 'Jim Brandt <jbrandt at bestpractical.com>'
+build_requires:
+ ExtUtils::MakeMaker: 6.36
+configure_requires:
+ ExtUtils::MakeMaker: 6.36
+distribution_type: module
+dynamic_config: 1
+generated_by: 'Module::Install version 1.06'
+license: gplv2
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: RT-Extension-Announce
+no_index:
+ directory:
+ - html
+ - inc
+resources:
+ license: http://opensource.org/licenses/gpl-license.php
+version: 0.01
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..8b22e05
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,10 @@
+use inc::Module::Install;
+
+
+RTx 'RT-Extension-Announce';
+all_from 'lib/RT/Extension/Announce.pm';
+readme_from 'lib/RT/Extension/Announce.pm';
+license 'gplv2';
+
+sign;
+WriteAll;
diff --git a/README b/README
new file mode 100644
index 0000000..471aa4c
--- /dev/null
+++ b/README
@@ -0,0 +1,63 @@
+NAME
+ RT-Extension-Announce - Display announcements as a banner on RT pages.
+
+INSTALLATION
+ perl Makefile.PL
+ make
+ make install
+ May need root permissions
+
+ Edit your /opt/rt4/etc/RT_SiteConfig.pm
+ Add these lines:
+
+ Set($RTAnnounceQueue, 'AnnounceQueueName');
+ Set(@Plugins, qw(RT::Extension::Announce));
+
+ or add "RT::Extension::Announce" to your existing @Plugins line.
+
+ Clear your mason cache
+ rm -rf /opt/rt4/var/mason_data/obj
+
+ Restart your webserver
+
+DESCRIPTION
+ The Announce extension gives you an easy way to insert announcements on
+ RT pages so all users can see the message. You may want to display a
+ banner during maintenance or an unscheduled outage to make sure the
+ people fielding customer tickets know that something is going on.
+
+ To post an announcement, create a ticket in the queue you identified in
+ the RTAnnounceQueue configuration. The extension displays the two most
+ recent updates on new or open tickets in that queue. The subject and
+ most recent textual message are displayed. As the incident or
+ maintenance progresses, just post the updates to the ticket and the
+ announcement will be updated with the latest information.
+
+ You should set up a designated queue for announcement messages so you
+ can post tickets only when you want an announcement displayed. You can
+ set permissions on the queue to control who can create new announcements
+ and who should see them.
+
+ Setting up a designated queue also allows you to customize it in other
+ ways. For example, you may not want to send the typical 'ticket create'
+ email messages, so you could change or customize the scrips that run or
+ create new templates. If you send announcement messages to an email
+ list, you could create a list user in RT and add it as a CC to the
+ announcement queue. Then messages posted for announcement in RT will
+ also be sent to the notification list.
+
+AUTHOR
+ Jim Brandt <jbrandt at bestpractical.com>
+
+BUGS
+ All bugs should be reported via
+ <http://rt.cpan.org/Public/Dist/Display.html?Name=RT-Extension-Announce>
+ or bug-RT-Extension-Announce at rt.cpan.org.
+
+LICENSE AND COPYRIGHT
+ This software is Copyright (c) 2012 by Best Practical Solutions, LLC
+
+ This is free software, licensed under:
+
+ The GNU General Public License, Version 2, June 1991
+
diff --git a/html/Callbacks/RT-Extension-Announce/Elements/Header/Head b/html/Callbacks/RT-Extension-Announce/Elements/Header/Head
new file mode 100644
index 0000000..fed441d
--- /dev/null
+++ b/html/Callbacks/RT-Extension-Announce/Elements/Header/Head
@@ -0,0 +1,49 @@
+%# BEGIN BPS TAGGED BLOCK {{{
+%#
+%# COPYRIGHT:
+%#
+%# This software is Copyright (c) 2012 Best Practical Solutions, LLC
+%# <sales at bestpractical.com>
+%#
+%# (Except where explicitly superseded by other copyright notices)
+%#
+%#
+%# LICENSE:
+%#
+%# This work is made available to you under the terms of Version 2 of
+%# the GNU General Public License. A copy of that license should have
+%# been provided with this software, but in any event can be snarfed
+%# from www.gnu.org.
+%#
+%# This work is distributed in the hope that it will be useful, but
+%# WITHOUT ANY WARRANTY; without even the implied warranty of
+%# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+%# General Public License for more details.
+%#
+%# You should have received a copy of the GNU General Public License
+%# along with this program; if not, write to the Free Software
+%# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+%# 02110-1301 or visit their web page on the internet at
+%# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+%#
+%#
+%# CONTRIBUTION SUBMISSION POLICY:
+%#
+%# (The following paragraph is not intended to limit the rights granted
+%# to you to modify and distribute this software under the terms of
+%# the GNU General Public License and is only of importance to you if
+%# you choose to contribute your changes and enhancements to the
+%# community by submitting them to Best Practical Solutions, LLC.)
+%#
+%# By intentionally submitting any modifications, corrections or
+%# derivatives to this work, or any other work intended for use with
+%# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+%# you are the copyright holder for those contributions and you grant
+%# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+%# royalty-free, perpetual, license to use, copy, create derivative
+%# works based on those contributions, and sublicense and distribute
+%# those contributions and any derivatives thereof.
+%#
+%# END BPS TAGGED BLOCK }}}
+<link rel="stylesheet" type="text/css" href="<%RT->Config->Get('WebPath')%>/NoAuth/css/announce.css">
+<script type="text/javascript" src="<%RT->Config->Get('WebPath')%>/NoAuth/js/announce.js"></script>
diff --git a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
new file mode 100644
index 0000000..0fc86a0
--- /dev/null
+++ b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
@@ -0,0 +1,118 @@
+%# BEGIN BPS TAGGED BLOCK {{{
+%#
+%# COPYRIGHT:
+%#
+%# This software is Copyright (c) 2012 Best Practical Solutions, LLC
+%# <sales at bestpractical.com>
+%#
+%# (Except where explicitly superseded by other copyright notices)
+%#
+%#
+%# LICENSE:
+%#
+%# This work is made available to you under the terms of Version 2 of
+%# the GNU General Public License. A copy of that license should have
+%# been provided with this software, but in any event can be snarfed
+%# from www.gnu.org.
+%#
+%# This work is distributed in the hope that it will be useful, but
+%# WITHOUT ANY WARRANTY; without even the implied warranty of
+%# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+%# General Public License for more details.
+%#
+%# You should have received a copy of the GNU General Public License
+%# along with this program; if not, write to the Free Software
+%# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+%# 02110-1301 or visit their web page on the internet at
+%# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+%#
+%#
+%# CONTRIBUTION SUBMISSION POLICY:
+%#
+%# (The following paragraph is not intended to limit the rights granted
+%# to you to modify and distribute this software under the terms of
+%# the GNU General Public License and is only of importance to you if
+%# you choose to contribute your changes and enhancements to the
+%# community by submitting them to Best Practical Solutions, LLC.)
+%#
+%# By intentionally submitting any modifications, corrections or
+%# derivatives to this work, or any other work intended for use with
+%# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+%# you are the copyright holder for those contributions and you grant
+%# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+%# royalty-free, perpetual, license to use, copy, create derivative
+%# works based on those contributions, and sublicense and distribute
+%# those contributions and any derivatives thereof.
+%#
+%# END BPS TAGGED BLOCK }}}
+
+<div id="announce">
+<table class="announce">
+%my $rows = 1;
+%while( my $ticket = $tickets->Next ){
+ <tr><td class="announce_subject">
+ <a class="announce_subject"
+ href="<% RT->Config->Get('WebPath') %>/Ticket/Display.html?id=<% $ticket->Id %>">
+ <% $ticket->Subject %></a></td>
+ <td>
+<%perl>
+ my $txns = $ticket->Transactions;
+ for my $type ( qw(Create Comment Correspond) ){
+ $txns->Limit( FIELD => 'Type', VALUE => $type );
+ }
+ $txns->OrderBy( FIELD => 'Created', ORDER => 'DESC' );
+ $txns->RowsPerPage(1);
+ my $content_obj = $txns->First->ContentObj;
+ my $content = $content_obj->Content;
+ if( length $content > $MaxMessageLength ){
+ $content = substr($content, 0, $MaxMessageLength);
+ # Try to break at a word boundary.
+ $content =~ s/^(.*)\b\w+$/$1/g;
+ $content =~ s/\s+$//g; # Remove trailing space
+ $content .= chr(8230); # Ellipsis character
+ }
+</%perl>
+<% $content %> <a href="<% RT->Config->Get('WebPath') %>/Ticket/Display.html?id=<% $ticket->Id %>">See Details</a>
+</td></tr>
+% if( $rows == $ShowTickets && $tickets->Count > $ShowTickets ){
+% # Tack on the more link
+<tr><td colspan=2 class="toggle_announcements">
+<a href='#' class="toggle_announcements" id="toggle_announcements">More Announcements</a>
+</td></tr>
+<tbody id="more_announcements">
+% }
+
+%$rows++;
+%}
+%if( $rows >= $ShowTickets ){
+</tbody>
+%}
+</table></div>
+<%INIT>
+if ( not defined RT->Config->Get('RTAnnounceQueue') ){
+ $RT::Logger->error('No queue defined for Announce extension. Set $RTAnnounceQueue in RT_SiteConfig.pm');
+ return;
+}
+# Only display on Homepage
+warn $m->request_comp->path;
+return unless ( $m->request_comp->path =~ /^\/index.html$/ );
+
+my $queue = RT->Config->Get('RTAnnounceQueue');
+$queue =~ s/(['\\])/\\$1/g;
+my $Queue = RT::Queue->new( $session{'CurrentUser'} );
+$Queue->Load($queue);
+unless( $Queue->Id ){
+ $RT::Logger->error('Invalid queue ' . $queue . ' set for Announce extension.');
+ return;
+}
+
+my $tickets = RT::Tickets->new( $session{'CurrentUser'} );
+$tickets->OrderBy( FIELD => 'LastUpdated', ORDER => 'DESC' );
+$tickets->FromSQL("Queue = '$queue' AND ( Status = 'new' OR Status = 'open' )");
+return if $tickets->Count == 0;
+
+</%INIT>
+<%ARGS>
+$ShowTickets => 2
+$MaxMessageLength => 300;
+</%ARGS>
diff --git a/html/NoAuth/css/announce.css b/html/NoAuth/css/announce.css
new file mode 100644
index 0000000..4d4a350
--- /dev/null
+++ b/html/NoAuth/css/announce.css
@@ -0,0 +1,47 @@
+#announce {
+ padding-top: 10px; # Keep from running into the menu on the right
+}
+
+table.announce {
+ background-color:#fcc;
+ width: 100%;
+ border-top-left-radius: 0.3em;
+ border-top-right-radius: 0.3em;
+ border-bottom-right-radius: 0.3em;
+ border-bottom-left-radius: 0.3em;
+ valign: top;
+}
+
+td.toggle_announcements {
+ text-align: center;
+}
+
+a.toggle_announcements:link {
+ font-weight: bold;
+ color: #000000;
+}
+
+a.toggle_announcements:visited {
+ font-weight: bold;
+ color: #000000;
+}
+
+a.toggle_announcements:hover {
+ font-weight: bold;
+ color: #808080;
+ text-decoration: none;
+}
+
+td.announce_subject {
+ width: 25%;
+}
+
+a.announce_subject:link {
+ color: red;
+ font-weight: bold;
+}
+
+a.announce_subject:visited {
+ color: red;
+ font-weight: bold;
+}
\ No newline at end of file
diff --git a/html/NoAuth/js/announce.js b/html/NoAuth/js/announce.js
new file mode 100644
index 0000000..588f503
--- /dev/null
+++ b/html/NoAuth/js/announce.js
@@ -0,0 +1,17 @@
+
+jQuery(document).ready(function() {
+ jQuery('#more_announcements').hide();
+ var hide = true;
+ jQuery('#toggle_announcements').click( function() {
+ if ( hide == true ) {
+ jQuery('#more_announcements').show();
+ jQuery('#toggle_announcements').html('Less Announcements');
+ hide = false;
+ }
+ else if ( hide == false ) {
+ jQuery('#more_announcements').hide();
+ jQuery('#toggle_announcements').html('More Announcements');
+ hide = true;
+ }
+ });
+});
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
new file mode 100644
index 0000000..4ecf46b
--- /dev/null
+++ b/inc/Module/Install.pm
@@ -0,0 +1,470 @@
+#line 1
+package Module::Install;
+
+# For any maintainers:
+# The load order for Module::Install is a bit magic.
+# It goes something like this...
+#
+# IF ( host has Module::Install installed, creating author mode ) {
+# 1. Makefile.PL calls "use inc::Module::Install"
+# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
+# 3. The installed version of inc::Module::Install loads
+# 4. inc::Module::Install calls "require Module::Install"
+# 5. The ./inc/ version of Module::Install loads
+# } ELSE {
+# 1. Makefile.PL calls "use inc::Module::Install"
+# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
+# 3. The ./inc/ version of Module::Install loads
+# }
+
+use 5.005;
+use strict 'vars';
+use Cwd ();
+use File::Find ();
+use File::Path ();
+
+use vars qw{$VERSION $MAIN};
+BEGIN {
+ # All Module::Install core packages now require synchronised versions.
+ # This will be used to ensure we don't accidentally load old or
+ # different versions of modules.
+ # This is not enforced yet, but will be some time in the next few
+ # releases once we can make sure it won't clash with custom
+ # Module::Install extensions.
+ $VERSION = '1.06';
+
+ # Storage for the pseudo-singleton
+ $MAIN = undef;
+
+ *inc::Module::Install::VERSION = *VERSION;
+ @inc::Module::Install::ISA = __PACKAGE__;
+
+}
+
+sub import {
+ my $class = shift;
+ my $self = $class->new(@_);
+ my $who = $self->_caller;
+
+ #-------------------------------------------------------------
+ # all of the following checks should be included in import(),
+ # to allow "eval 'require Module::Install; 1' to test
+ # installation of Module::Install. (RT #51267)
+ #-------------------------------------------------------------
+
+ # Whether or not inc::Module::Install is actually loaded, the
+ # $INC{inc/Module/Install.pm} is what will still get set as long as
+ # the caller loaded module this in the documented manner.
+ # If not set, the caller may NOT have loaded the bundled version, and thus
+ # they may not have a MI version that works with the Makefile.PL. This would
+ # result in false errors or unexpected behaviour. And we don't want that.
+ my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
+ unless ( $INC{$file} ) { die <<"END_DIE" }
+
+Please invoke ${\__PACKAGE__} with:
+
+ use inc::${\__PACKAGE__};
+
+not:
+
+ use ${\__PACKAGE__};
+
+END_DIE
+
+ # This reportedly fixes a rare Win32 UTC file time issue, but
+ # as this is a non-cross-platform XS module not in the core,
+ # we shouldn't really depend on it. See RT #24194 for detail.
+ # (Also, this module only supports Perl 5.6 and above).
+ eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
+
+ # If the script that is loading Module::Install is from the future,
+ # then make will detect this and cause it to re-run over and over
+ # again. This is bad. Rather than taking action to touch it (which
+ # is unreliable on some platforms and requires write permissions)
+ # for now we should catch this and refuse to run.
+ if ( -f $0 ) {
+ my $s = (stat($0))[9];
+
+ # If the modification time is only slightly in the future,
+ # sleep briefly to remove the problem.
+ my $a = $s - time;
+ if ( $a > 0 and $a < 5 ) { sleep 5 }
+
+ # Too far in the future, throw an error.
+ my $t = time;
+ if ( $s > $t ) { die <<"END_DIE" }
+
+Your installer $0 has a modification time in the future ($s > $t).
+
+This is known to create infinite loops in make.
+
+Please correct this, then run $0 again.
+
+END_DIE
+ }
+
+
+ # Build.PL was formerly supported, but no longer is due to excessive
+ # difficulty in implementing every single feature twice.
+ if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
+
+Module::Install no longer supports Build.PL.
+
+It was impossible to maintain duel backends, and has been deprecated.
+
+Please remove all Build.PL files and only use the Makefile.PL installer.
+
+END_DIE
+
+ #-------------------------------------------------------------
+
+ # To save some more typing in Module::Install installers, every...
+ # use inc::Module::Install
+ # ...also acts as an implicit use strict.
+ $^H |= strict::bits(qw(refs subs vars));
+
+ #-------------------------------------------------------------
+
+ unless ( -f $self->{file} ) {
+ foreach my $key (keys %INC) {
+ delete $INC{$key} if $key =~ /Module\/Install/;
+ }
+
+ local $^W;
+ require "$self->{path}/$self->{dispatch}.pm";
+ File::Path::mkpath("$self->{prefix}/$self->{author}");
+ $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
+ $self->{admin}->init;
+ @_ = ($class, _self => $self);
+ goto &{"$self->{name}::import"};
+ }
+
+ local $^W;
+ *{"${who}::AUTOLOAD"} = $self->autoload;
+ $self->preload;
+
+ # Unregister loader and worker packages so subdirs can use them again
+ delete $INC{'inc/Module/Install.pm'};
+ delete $INC{'Module/Install.pm'};
+
+ # Save to the singleton
+ $MAIN = $self;
+
+ return 1;
+}
+
+sub autoload {
+ my $self = shift;
+ my $who = $self->_caller;
+ my $cwd = Cwd::cwd();
+ my $sym = "${who}::AUTOLOAD";
+ $sym->{$cwd} = sub {
+ my $pwd = Cwd::cwd();
+ if ( my $code = $sym->{$pwd} ) {
+ # Delegate back to parent dirs
+ goto &$code unless $cwd eq $pwd;
+ }
+ unless ($$sym =~ s/([^:]+)$//) {
+ # XXX: it looks like we can't retrieve the missing function
+ # via $$sym (usually $main::AUTOLOAD) in this case.
+ # I'm still wondering if we should slurp Makefile.PL to
+ # get some context or not ...
+ my ($package, $file, $line) = caller;
+ die <<"EOT";
+Unknown function is found at $file line $line.
+Execution of $file aborted due to runtime errors.
+
+If you're a contributor to a project, you may need to install
+some Module::Install extensions from CPAN (or other repository).
+If you're a user of a module, please contact the author.
+EOT
+ }
+ my $method = $1;
+ if ( uc($method) eq $method ) {
+ # Do nothing
+ return;
+ } elsif ( $method =~ /^_/ and $self->can($method) ) {
+ # Dispatch to the root M:I class
+ return $self->$method(@_);
+ }
+
+ # Dispatch to the appropriate plugin
+ unshift @_, ( $self, $1 );
+ goto &{$self->can('call')};
+ };
+}
+
+sub preload {
+ my $self = shift;
+ unless ( $self->{extensions} ) {
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ );
+ }
+
+ my @exts = @{$self->{extensions}};
+ unless ( @exts ) {
+ @exts = $self->{admin}->load_all_extensions;
+ }
+
+ my %seen;
+ foreach my $obj ( @exts ) {
+ while (my ($method, $glob) = each %{ref($obj) . '::'}) {
+ next unless $obj->can($method);
+ next if $method =~ /^_/;
+ next if $method eq uc($method);
+ $seen{$method}++;
+ }
+ }
+
+ my $who = $self->_caller;
+ foreach my $name ( sort keys %seen ) {
+ local $^W;
+ *{"${who}::$name"} = sub {
+ ${"${who}::AUTOLOAD"} = "${who}::$name";
+ goto &{"${who}::AUTOLOAD"};
+ };
+ }
+}
+
+sub new {
+ my ($class, %args) = @_;
+
+ delete $INC{'FindBin.pm'};
+ {
+ # to suppress the redefine warning
+ local $SIG{__WARN__} = sub {};
+ require FindBin;
+ }
+
+ # ignore the prefix on extension modules built from top level.
+ my $base_path = Cwd::abs_path($FindBin::Bin);
+ unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
+ delete $args{prefix};
+ }
+ return $args{_self} if $args{_self};
+
+ $args{dispatch} ||= 'Admin';
+ $args{prefix} ||= 'inc';
+ $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
+ $args{bundle} ||= 'inc/BUNDLES';
+ $args{base} ||= $base_path;
+ $class =~ s/^\Q$args{prefix}\E:://;
+ $args{name} ||= $class;
+ $args{version} ||= $class->VERSION;
+ unless ( $args{path} ) {
+ $args{path} = $args{name};
+ $args{path} =~ s!::!/!g;
+ }
+ $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
+ $args{wrote} = 0;
+
+ bless( \%args, $class );
+}
+
+sub call {
+ my ($self, $method) = @_;
+ my $obj = $self->load($method) or return;
+ splice(@_, 0, 2, $obj);
+ goto &{$obj->can($method)};
+}
+
+sub load {
+ my ($self, $method) = @_;
+
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ ) unless $self->{extensions};
+
+ foreach my $obj (@{$self->{extensions}}) {
+ return $obj if $obj->can($method);
+ }
+
+ my $admin = $self->{admin} or die <<"END_DIE";
+The '$method' method does not exist in the '$self->{prefix}' path!
+Please remove the '$self->{prefix}' directory and run $0 again to load it.
+END_DIE
+
+ my $obj = $admin->load($method, 1);
+ push @{$self->{extensions}}, $obj;
+
+ $obj;
+}
+
+sub load_extensions {
+ my ($self, $path, $top) = @_;
+
+ my $should_reload = 0;
+ unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
+ unshift @INC, $self->{prefix};
+ $should_reload = 1;
+ }
+
+ foreach my $rv ( $self->find_extensions($path) ) {
+ my ($file, $pkg) = @{$rv};
+ next if $self->{pathnames}{$pkg};
+
+ local $@;
+ my $new = eval { local $^W; require $file; $pkg->can('new') };
+ unless ( $new ) {
+ warn $@ if $@;
+ next;
+ }
+ $self->{pathnames}{$pkg} =
+ $should_reload ? delete $INC{$file} : $INC{$file};
+ push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
+ }
+
+ $self->{extensions} ||= [];
+}
+
+sub find_extensions {
+ my ($self, $path) = @_;
+
+ my @found;
+ File::Find::find( sub {
+ my $file = $File::Find::name;
+ return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
+ my $subpath = $1;
+ return if lc($subpath) eq lc($self->{dispatch});
+
+ $file = "$self->{path}/$subpath.pm";
+ my $pkg = "$self->{name}::$subpath";
+ $pkg =~ s!/!::!g;
+
+ # If we have a mixed-case package name, assume case has been preserved
+ # correctly. Otherwise, root through the file to locate the case-preserved
+ # version of the package name.
+ if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
+ my $content = Module::Install::_read($subpath . '.pm');
+ my $in_pod = 0;
+ foreach ( split //, $content ) {
+ $in_pod = 1 if /^=\w/;
+ $in_pod = 0 if /^=cut/;
+ next if ($in_pod || /^=cut/); # skip pod text
+ next if /^\s*#/; # and comments
+ if ( m/^\s*package\s+($pkg)\s*;/i ) {
+ $pkg = $1;
+ last;
+ }
+ }
+ }
+
+ push @found, [ $file, $pkg ];
+ }, $path ) if -d $path;
+
+ @found;
+}
+
+
+
+
+
+#####################################################################
+# Common Utility Functions
+
+sub _caller {
+ my $depth = 0;
+ my $call = caller($depth);
+ while ( $call eq __PACKAGE__ ) {
+ $depth++;
+ $call = caller($depth);
+ }
+ return $call;
+}
+
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
+sub _read {
+ local *FH;
+ open( FH, '<', $_[0] ) or die "open($_[0]): $!";
+ my $string = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $string;
+}
+END_NEW
+sub _read {
+ local *FH;
+ open( FH, "< $_[0]" ) or die "open($_[0]): $!";
+ my $string = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $string;
+}
+END_OLD
+
+sub _readperl {
+ my $string = Module::Install::_read($_[0]);
+ $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
+ $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
+ $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
+ return $string;
+}
+
+sub _readpod {
+ my $string = Module::Install::_read($_[0]);
+ $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
+ return $string if $_[0] =~ /\.pod\z/;
+ $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
+ $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
+ $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
+ $string =~ s/^\n+//s;
+ return $string;
+}
+
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
+sub _write {
+ local *FH;
+ open( FH, '>', $_[0] ) or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) {
+ print FH $_[$_] or die "print($_[0]): $!";
+ }
+ close FH or die "close($_[0]): $!";
+}
+END_NEW
+sub _write {
+ local *FH;
+ open( FH, "> $_[0]" ) or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) {
+ print FH $_[$_] or die "print($_[0]): $!";
+ }
+ close FH or die "close($_[0]): $!";
+}
+END_OLD
+
+# _version is for processing module versions (eg, 1.03_05) not
+# Perl versions (eg, 5.8.1).
+sub _version ($) {
+ my $s = shift || 0;
+ my $d =()= $s =~ /(\.)/g;
+ if ( $d >= 2 ) {
+ # Normalise multipart versions
+ $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
+ }
+ $s =~ s/^(\d+)\.?//;
+ my $l = $1 || 0;
+ my @v = map {
+ $_ . '0' x (3 - length $_)
+ } $s =~ /(\d{1,3})\D?/g;
+ $l = $l . '.' . join '', @v if @v;
+ return $l + 0;
+}
+
+sub _cmp ($$) {
+ _version($_[1]) <=> _version($_[2]);
+}
+
+# Cloned from Params::Util::_CLASS
+sub _CLASS ($) {
+ (
+ defined $_[0]
+ and
+ ! ref $_[0]
+ and
+ $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
+ ) ? $_[0] : undef;
+}
+
+1;
+
+# Copyright 2008 - 2012 Adam Kennedy.
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
new file mode 100644
index 0000000..802844a
--- /dev/null
+++ b/inc/Module/Install/Base.pm
@@ -0,0 +1,83 @@
+#line 1
+package Module::Install::Base;
+
+use strict 'vars';
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = '1.06';
+}
+
+# Suspend handler for "redefined" warnings
+BEGIN {
+ my $w = $SIG{__WARN__};
+ $SIG{__WARN__} = sub { $w };
+}
+
+#line 42
+
+sub new {
+ my $class = shift;
+ unless ( defined &{"${class}::call"} ) {
+ *{"${class}::call"} = sub { shift->_top->call(@_) };
+ }
+ unless ( defined &{"${class}::load"} ) {
+ *{"${class}::load"} = sub { shift->_top->load(@_) };
+ }
+ bless { @_ }, $class;
+}
+
+#line 61
+
+sub AUTOLOAD {
+ local $@;
+ my $func = eval { shift->_top->autoload } or return;
+ goto &$func;
+}
+
+#line 75
+
+sub _top {
+ $_[0]->{_top};
+}
+
+#line 90
+
+sub admin {
+ $_[0]->_top->{admin}
+ or
+ Module::Install::Base::FakeAdmin->new;
+}
+
+#line 106
+
+sub is_admin {
+ ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin');
+}
+
+sub DESTROY {}
+
+package Module::Install::Base::FakeAdmin;
+
+use vars qw{$VERSION};
+BEGIN {
+ $VERSION = $Module::Install::Base::VERSION;
+}
+
+my $fake;
+
+sub new {
+ $fake ||= bless(\@_, $_[0]);
+}
+
+sub AUTOLOAD {}
+
+sub DESTROY {}
+
+# Restore warning handler
+BEGIN {
+ $SIG{__WARN__} = $SIG{__WARN__}->();
+}
+
+1;
+
+#line 159
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
new file mode 100644
index 0000000..22167b8
--- /dev/null
+++ b/inc/Module/Install/Can.pm
@@ -0,0 +1,154 @@
+#line 1
+package Module::Install::Can;
+
+use strict;
+use Config ();
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.06';
+ @ISA = 'Module::Install::Base';
+ $ISCORE = 1;
+}
+
+# check if we can load some module
+### Upgrade this to not have to load the module if possible
+sub can_use {
+ my ($self, $mod, $ver) = @_;
+ $mod =~ s{::|\\}{/}g;
+ $mod .= '.pm' unless $mod =~ /\.pm$/i;
+
+ my $pkg = $mod;
+ $pkg =~ s{/}{::}g;
+ $pkg =~ s{\.pm$}{}i;
+
+ local $@;
+ eval { require $mod; $pkg->VERSION($ver || 0); 1 };
+}
+
+# Check if we can run some command
+sub can_run {
+ my ($self, $cmd) = @_;
+
+ my $_cmd = $cmd;
+ return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
+
+ for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
+ next if $dir eq '';
+ require File::Spec;
+ my $abs = File::Spec->catfile($dir, $cmd);
+ return $abs if (-x $abs or $abs = MM->maybe_command($abs));
+ }
+
+ return;
+}
+
+# Can our C compiler environment build XS files
+sub can_xs {
+ my $self = shift;
+
+ # Ensure we have the CBuilder module
+ $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 );
+
+ # Do we have the configure_requires checker?
+ local $@;
+ eval "require ExtUtils::CBuilder;";
+ if ( $@ ) {
+ # They don't obey configure_requires, so it is
+ # someone old and delicate. Try to avoid hurting
+ # them by falling back to an older simpler test.
+ return $self->can_cc();
+ }
+
+ # Do we have a working C compiler
+ my $builder = ExtUtils::CBuilder->new(
+ quiet => 1,
+ );
+ unless ( $builder->have_compiler ) {
+ # No working C compiler
+ return 0;
+ }
+
+ # Write a C file representative of what XS becomes
+ require File::Temp;
+ my ( $FH, $tmpfile ) = File::Temp::tempfile(
+ "compilexs-XXXXX",
+ SUFFIX => '.c',
+ );
+ binmode $FH;
+ print $FH <<'END_C';
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+int main(int argc, char **argv) {
+ return 0;
+}
+
+int boot_sanexs() {
+ return 1;
+}
+
+END_C
+ close $FH;
+
+ # Can the C compiler access the same headers XS does
+ my @libs = ();
+ my $object = undef;
+ eval {
+ local $^W = 0;
+ $object = $builder->compile(
+ source => $tmpfile,
+ );
+ @libs = $builder->link(
+ objects => $object,
+ module_name => 'sanexs',
+ );
+ };
+ my $result = $@ ? 0 : 1;
+
+ # Clean up all the build files
+ foreach ( $tmpfile, $object, @libs ) {
+ next unless defined $_;
+ 1 while unlink;
+ }
+
+ return $result;
+}
+
+# Can we locate a (the) C compiler
+sub can_cc {
+ my $self = shift;
+ my @chunks = split(/ /, $Config::Config{cc}) or return;
+
+ # $Config{cc} may contain args; try to find out the program part
+ while (@chunks) {
+ return $self->can_run("@chunks") || (pop(@chunks), next);
+ }
+
+ return;
+}
+
+# Fix Cygwin bug on maybe_command();
+if ( $^O eq 'cygwin' ) {
+ require ExtUtils::MM_Cygwin;
+ require ExtUtils::MM_Win32;
+ if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
+ *ExtUtils::MM_Cygwin::maybe_command = sub {
+ my ($self, $file) = @_;
+ if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
+ ExtUtils::MM_Win32->maybe_command($file);
+ } else {
+ ExtUtils::MM_Unix->maybe_command($file);
+ }
+ }
+ }
+}
+
+1;
+
+__END__
+
+#line 236
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
new file mode 100644
index 0000000..bee0c4f
--- /dev/null
+++ b/inc/Module/Install/Fetch.pm
@@ -0,0 +1,93 @@
+#line 1
+package Module::Install::Fetch;
+
+use strict;
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.06';
+ @ISA = 'Module::Install::Base';
+ $ISCORE = 1;
+}
+
+sub get_file {
+ my ($self, %args) = @_;
+ my ($scheme, $host, $path, $file) =
+ $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
+
+ if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
+ $args{url} = $args{ftp_url}
+ or (warn("LWP support unavailable!\n"), return);
+ ($scheme, $host, $path, $file) =
+ $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
+ }
+
+ $|++;
+ print "Fetching '$file' from $host... ";
+
+ unless (eval { require Socket; Socket::inet_aton($host) }) {
+ warn "'$host' resolve failed!\n";
+ return;
+ }
+
+ return unless $scheme eq 'ftp' or $scheme eq 'http';
+
+ require Cwd;
+ my $dir = Cwd::getcwd();
+ chdir $args{local_dir} or return if exists $args{local_dir};
+
+ if (eval { require LWP::Simple; 1 }) {
+ LWP::Simple::mirror($args{url}, $file);
+ }
+ elsif (eval { require Net::FTP; 1 }) { eval {
+ # use Net::FTP to get past firewall
+ my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
+ $ftp->login("anonymous", 'anonymous at example.com');
+ $ftp->cwd($path);
+ $ftp->binary;
+ $ftp->get($file) or (warn("$!\n"), return);
+ $ftp->quit;
+ } }
+ elsif (my $ftp = $self->can_run('ftp')) { eval {
+ # no Net::FTP, fallback to ftp.exe
+ require FileHandle;
+ my $fh = FileHandle->new;
+
+ local $SIG{CHLD} = 'IGNORE';
+ unless ($fh->open("|$ftp -n")) {
+ warn "Couldn't open ftp: $!\n";
+ chdir $dir; return;
+ }
+
+ my @dialog = split(/\n/, <<"END_FTP");
+open $host
+user anonymous anonymous\@example.com
+cd $path
+binary
+get $file $file
+quit
+END_FTP
+ foreach (@dialog) { $fh->print("$_\n") }
+ $fh->close;
+ } }
+ else {
+ warn "No working 'ftp' program available!\n";
+ chdir $dir; return;
+ }
+
+ unless (-f $file) {
+ warn "Fetching failed: $@\n";
+ chdir $dir; return;
+ }
+
+ return if exists $args{size} and -s $file != $args{size};
+ system($args{run}) if exists $args{run};
+ unlink($file) if $args{remove};
+
+ print(((!exists $args{check_for} or -e $args{check_for})
+ ? "done!" : "failed! ($!)"), "\n");
+ chdir $dir; return !$?;
+}
+
+1;
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
new file mode 100644
index 0000000..7052f36
--- /dev/null
+++ b/inc/Module/Install/Makefile.pm
@@ -0,0 +1,418 @@
+#line 1
+package Module::Install::Makefile;
+
+use strict 'vars';
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
+use Fcntl qw/:flock :seek/;
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.06';
+ @ISA = 'Module::Install::Base';
+ $ISCORE = 1;
+}
+
+sub Makefile { $_[0] }
+
+my %seen = ();
+
+sub prompt {
+ shift;
+
+ # Infinite loop protection
+ my @c = caller();
+ if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
+ die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
+ }
+
+ # In automated testing or non-interactive session, always use defaults
+ if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
+ local $ENV{PERL_MM_USE_DEFAULT} = 1;
+ goto &ExtUtils::MakeMaker::prompt;
+ } else {
+ goto &ExtUtils::MakeMaker::prompt;
+ }
+}
+
+# Store a cleaned up version of the MakeMaker version,
+# since we need to behave differently in a variety of
+# ways based on the MM version.
+my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
+
+# If we are passed a param, do a "newer than" comparison.
+# Otherwise, just return the MakeMaker version.
+sub makemaker {
+ ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
+}
+
+# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
+# as we only need to know here whether the attribute is an array
+# or a hash or something else (which may or may not be appendable).
+my %makemaker_argtype = (
+ C => 'ARRAY',
+ CONFIG => 'ARRAY',
+# CONFIGURE => 'CODE', # ignore
+ DIR => 'ARRAY',
+ DL_FUNCS => 'HASH',
+ DL_VARS => 'ARRAY',
+ EXCLUDE_EXT => 'ARRAY',
+ EXE_FILES => 'ARRAY',
+ FUNCLIST => 'ARRAY',
+ H => 'ARRAY',
+ IMPORTS => 'HASH',
+ INCLUDE_EXT => 'ARRAY',
+ LIBS => 'ARRAY', # ignore ''
+ MAN1PODS => 'HASH',
+ MAN3PODS => 'HASH',
+ META_ADD => 'HASH',
+ META_MERGE => 'HASH',
+ PL_FILES => 'HASH',
+ PM => 'HASH',
+ PMLIBDIRS => 'ARRAY',
+ PMLIBPARENTDIRS => 'ARRAY',
+ PREREQ_PM => 'HASH',
+ CONFIGURE_REQUIRES => 'HASH',
+ SKIP => 'ARRAY',
+ TYPEMAPS => 'ARRAY',
+ XS => 'HASH',
+# VERSION => ['version',''], # ignore
+# _KEEP_AFTER_FLUSH => '',
+
+ clean => 'HASH',
+ depend => 'HASH',
+ dist => 'HASH',
+ dynamic_lib=> 'HASH',
+ linkext => 'HASH',
+ macro => 'HASH',
+ postamble => 'HASH',
+ realclean => 'HASH',
+ test => 'HASH',
+ tool_autosplit => 'HASH',
+
+ # special cases where you can use makemaker_append
+ CCFLAGS => 'APPENDABLE',
+ DEFINE => 'APPENDABLE',
+ INC => 'APPENDABLE',
+ LDDLFLAGS => 'APPENDABLE',
+ LDFROM => 'APPENDABLE',
+);
+
+sub makemaker_args {
+ my ($self, %new_args) = @_;
+ my $args = ( $self->{makemaker_args} ||= {} );
+ foreach my $key (keys %new_args) {
+ if ($makemaker_argtype{$key}) {
+ if ($makemaker_argtype{$key} eq 'ARRAY') {
+ $args->{$key} = [] unless defined $args->{$key};
+ unless (ref $args->{$key} eq 'ARRAY') {
+ $args->{$key} = [$args->{$key}]
+ }
+ push @{$args->{$key}},
+ ref $new_args{$key} eq 'ARRAY'
+ ? @{$new_args{$key}}
+ : $new_args{$key};
+ }
+ elsif ($makemaker_argtype{$key} eq 'HASH') {
+ $args->{$key} = {} unless defined $args->{$key};
+ foreach my $skey (keys %{ $new_args{$key} }) {
+ $args->{$key}{$skey} = $new_args{$key}{$skey};
+ }
+ }
+ elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
+ $self->makemaker_append($key => $new_args{$key});
+ }
+ }
+ else {
+ if (defined $args->{$key}) {
+ warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n};
+ }
+ $args->{$key} = $new_args{$key};
+ }
+ }
+ return $args;
+}
+
+# For mm args that take multiple space-seperated args,
+# append an argument to the current list.
+sub makemaker_append {
+ my $self = shift;
+ my $name = shift;
+ my $args = $self->makemaker_args;
+ $args->{$name} = defined $args->{$name}
+ ? join( ' ', $args->{$name}, @_ )
+ : join( ' ', @_ );
+}
+
+sub build_subdirs {
+ my $self = shift;
+ my $subdirs = $self->makemaker_args->{DIR} ||= [];
+ for my $subdir (@_) {
+ push @$subdirs, $subdir;
+ }
+}
+
+sub clean_files {
+ my $self = shift;
+ my $clean = $self->makemaker_args->{clean} ||= {};
+ %$clean = (
+ %$clean,
+ FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
+ );
+}
+
+sub realclean_files {
+ my $self = shift;
+ my $realclean = $self->makemaker_args->{realclean} ||= {};
+ %$realclean = (
+ %$realclean,
+ FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
+ );
+}
+
+sub libs {
+ my $self = shift;
+ my $libs = ref $_[0] ? shift : [ shift ];
+ $self->makemaker_args( LIBS => $libs );
+}
+
+sub inc {
+ my $self = shift;
+ $self->makemaker_args( INC => shift );
+}
+
+sub _wanted_t {
+}
+
+sub tests_recursive {
+ my $self = shift;
+ my $dir = shift || 't';
+ unless ( -d $dir ) {
+ die "tests_recursive dir '$dir' does not exist";
+ }
+ my %tests = map { $_ => 1 } split / /, ($self->tests || '');
+ require File::Find;
+ File::Find::find(
+ sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 },
+ $dir
+ );
+ $self->tests( join ' ', sort keys %tests );
+}
+
+sub write {
+ my $self = shift;
+ die "&Makefile->write() takes no arguments\n" if @_;
+
+ # Check the current Perl version
+ my $perl_version = $self->perl_version;
+ if ( $perl_version ) {
+ eval "use $perl_version; 1"
+ or die "ERROR: perl: Version $] is installed, "
+ . "but we need version >= $perl_version";
+ }
+
+ # Make sure we have a new enough MakeMaker
+ require ExtUtils::MakeMaker;
+
+ if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
+ # This previous attempted to inherit the version of
+ # ExtUtils::MakeMaker in use by the module author, but this
+ # was found to be untenable as some authors build releases
+ # using future dev versions of EU:MM that nobody else has.
+ # Instead, #toolchain suggests we use 6.59 which is the most
+ # stable version on CPAN at time of writing and is, to quote
+ # ribasushi, "not terminally fucked, > and tested enough".
+ # TODO: We will now need to maintain this over time to push
+ # the version up as new versions are released.
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 );
+ } else {
+ # Allow legacy-compatibility with 5.005 by depending on the
+ # most recent EU:MM that supported 5.005.
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 );
+ }
+
+ # Generate the MakeMaker params
+ my $args = $self->makemaker_args;
+ $args->{DISTNAME} = $self->name;
+ $args->{NAME} = $self->module_name || $self->name;
+ $args->{NAME} =~ s/-/::/g;
+ $args->{VERSION} = $self->version or die <<'EOT';
+ERROR: Can't determine distribution version. Please specify it
+explicitly via 'version' in Makefile.PL, or set a valid $VERSION
+in a module, and provide its file path via 'version_from' (or
+'all_from' if you prefer) in Makefile.PL.
+EOT
+
+ if ( $self->tests ) {
+ my @tests = split ' ', $self->tests;
+ my %seen;
+ $args->{test} = {
+ TESTS => (join ' ', grep {!$seen{$_}++} @tests),
+ };
+ } elsif ( $Module::Install::ExtraTests::use_extratests ) {
+ # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness.
+ # So, just ignore our xt tests here.
+ } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
+ $args->{test} = {
+ TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
+ };
+ }
+ if ( $] >= 5.005 ) {
+ $args->{ABSTRACT} = $self->abstract;
+ $args->{AUTHOR} = join ', ', @{$self->author || []};
+ }
+ if ( $self->makemaker(6.10) ) {
+ $args->{NO_META} = 1;
+ #$args->{NO_MYMETA} = 1;
+ }
+ if ( $self->makemaker(6.17) and $self->sign ) {
+ $args->{SIGN} = 1;
+ }
+ unless ( $self->is_admin ) {
+ delete $args->{SIGN};
+ }
+ if ( $self->makemaker(6.31) and $self->license ) {
+ $args->{LICENSE} = $self->license;
+ }
+
+ my $prereq = ($args->{PREREQ_PM} ||= {});
+ %$prereq = ( %$prereq,
+ map { @$_ } # flatten [module => version]
+ map { @$_ }
+ grep $_,
+ ($self->requires)
+ );
+
+ # Remove any reference to perl, PREREQ_PM doesn't support it
+ delete $args->{PREREQ_PM}->{perl};
+
+ # Merge both kinds of requires into BUILD_REQUIRES
+ my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
+ %$build_prereq = ( %$build_prereq,
+ map { @$_ } # flatten [module => version]
+ map { @$_ }
+ grep $_,
+ ($self->configure_requires, $self->build_requires)
+ );
+
+ # Remove any reference to perl, BUILD_REQUIRES doesn't support it
+ delete $args->{BUILD_REQUIRES}->{perl};
+
+ # Delete bundled dists from prereq_pm, add it to Makefile DIR
+ my $subdirs = ($args->{DIR} || []);
+ if ($self->bundles) {
+ my %processed;
+ foreach my $bundle (@{ $self->bundles }) {
+ my ($mod_name, $dist_dir) = @$bundle;
+ delete $prereq->{$mod_name};
+ $dist_dir = File::Basename::basename($dist_dir); # dir for building this module
+ if (not exists $processed{$dist_dir}) {
+ if (-d $dist_dir) {
+ # List as sub-directory to be processed by make
+ push @$subdirs, $dist_dir;
+ }
+ # Else do nothing: the module is already present on the system
+ $processed{$dist_dir} = undef;
+ }
+ }
+ }
+
+ unless ( $self->makemaker('6.55_03') ) {
+ %$prereq = (%$prereq,%$build_prereq);
+ delete $args->{BUILD_REQUIRES};
+ }
+
+ if ( my $perl_version = $self->perl_version ) {
+ eval "use $perl_version; 1"
+ or die "ERROR: perl: Version $] is installed, "
+ . "but we need version >= $perl_version";
+
+ if ( $self->makemaker(6.48) ) {
+ $args->{MIN_PERL_VERSION} = $perl_version;
+ }
+ }
+
+ if ($self->installdirs) {
+ warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS};
+ $args->{INSTALLDIRS} = $self->installdirs;
+ }
+
+ my %args = map {
+ ( $_ => $args->{$_} ) } grep {defined($args->{$_} )
+ } keys %$args;
+
+ my $user_preop = delete $args{dist}->{PREOP};
+ if ( my $preop = $self->admin->preop($user_preop) ) {
+ foreach my $key ( keys %$preop ) {
+ $args{dist}->{$key} = $preop->{$key};
+ }
+ }
+
+ my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
+ $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
+}
+
+sub fix_up_makefile {
+ my $self = shift;
+ my $makefile_name = shift;
+ my $top_class = ref($self->_top) || '';
+ my $top_version = $self->_top->VERSION || '';
+
+ my $preamble = $self->preamble
+ ? "# Preamble by $top_class $top_version\n"
+ . $self->preamble
+ : '';
+ my $postamble = "# Postamble by $top_class $top_version\n"
+ . ($self->postamble || '');
+
+ local *MAKEFILE;
+ open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ eval { flock MAKEFILE, LOCK_EX };
+ my $makefile = do { local $/; <MAKEFILE> };
+
+ $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
+ $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
+ $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
+ $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
+ $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
+
+ # Module::Install will never be used to build the Core Perl
+ # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
+ # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
+ $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
+ #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
+
+ # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
+ $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
+
+ # XXX - This is currently unused; not sure if it breaks other MM-users
+ # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
+
+ seek MAKEFILE, 0, SEEK_SET;
+ truncate MAKEFILE, 0;
+ print MAKEFILE "$preamble$makefile$postamble" or die $!;
+ close MAKEFILE or die $!;
+
+ 1;
+}
+
+sub preamble {
+ my ($self, $text) = @_;
+ $self->{preamble} = $text . $self->{preamble} if defined $text;
+ $self->{preamble};
+}
+
+sub postamble {
+ my ($self, $text) = @_;
+ $self->{postamble} ||= $self->admin->postamble;
+ $self->{postamble} .= $text if defined $text;
+ $self->{postamble}
+}
+
+1;
+
+__END__
+
+#line 544
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
new file mode 100644
index 0000000..58430f3
--- /dev/null
+++ b/inc/Module/Install/Metadata.pm
@@ -0,0 +1,722 @@
+#line 1
+package Module::Install::Metadata;
+
+use strict 'vars';
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.06';
+ @ISA = 'Module::Install::Base';
+ $ISCORE = 1;
+}
+
+my @boolean_keys = qw{
+ sign
+};
+
+my @scalar_keys = qw{
+ name
+ module_name
+ abstract
+ version
+ distribution_type
+ tests
+ installdirs
+};
+
+my @tuple_keys = qw{
+ configure_requires
+ build_requires
+ requires
+ recommends
+ bundles
+ resources
+};
+
+my @resource_keys = qw{
+ homepage
+ bugtracker
+ repository
+};
+
+my @array_keys = qw{
+ keywords
+ author
+};
+
+*authors = \&author;
+
+sub Meta { shift }
+sub Meta_BooleanKeys { @boolean_keys }
+sub Meta_ScalarKeys { @scalar_keys }
+sub Meta_TupleKeys { @tuple_keys }
+sub Meta_ResourceKeys { @resource_keys }
+sub Meta_ArrayKeys { @array_keys }
+
+foreach my $key ( @boolean_keys ) {
+ *$key = sub {
+ my $self = shift;
+ if ( defined wantarray and not @_ ) {
+ return $self->{values}->{$key};
+ }
+ $self->{values}->{$key} = ( @_ ? $_[0] : 1 );
+ return $self;
+ };
+}
+
+foreach my $key ( @scalar_keys ) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}->{$key} if defined wantarray and !@_;
+ $self->{values}->{$key} = shift;
+ return $self;
+ };
+}
+
+foreach my $key ( @array_keys ) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}->{$key} if defined wantarray and !@_;
+ $self->{values}->{$key} ||= [];
+ push @{$self->{values}->{$key}}, @_;
+ return $self;
+ };
+}
+
+foreach my $key ( @resource_keys ) {
+ *$key = sub {
+ my $self = shift;
+ unless ( @_ ) {
+ return () unless $self->{values}->{resources};
+ return map { $_->[1] }
+ grep { $_->[0] eq $key }
+ @{ $self->{values}->{resources} };
+ }
+ return $self->{values}->{resources}->{$key} unless @_;
+ my $uri = shift or die(
+ "Did not provide a value to $key()"
+ );
+ $self->resources( $key => $uri );
+ return 1;
+ };
+}
+
+foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}->{$key} unless @_;
+ my @added;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @added, [ $module, $version ];
+ }
+ push @{ $self->{values}->{$key} }, @added;
+ return map {@$_} @added;
+ };
+}
+
+# Resource handling
+my %lc_resource = map { $_ => 1 } qw{
+ homepage
+ license
+ bugtracker
+ repository
+};
+
+sub resources {
+ my $self = shift;
+ while ( @_ ) {
+ my $name = shift or last;
+ my $value = shift or next;
+ if ( $name eq lc $name and ! $lc_resource{$name} ) {
+ die("Unsupported reserved lowercase resource '$name'");
+ }
+ $self->{values}->{resources} ||= [];
+ push @{ $self->{values}->{resources} }, [ $name, $value ];
+ }
+ $self->{values}->{resources};
+}
+
+# Aliases for build_requires that will have alternative
+# meanings in some future version of META.yml.
+sub test_requires { shift->build_requires(@_) }
+sub install_requires { shift->build_requires(@_) }
+
+# Aliases for installdirs options
+sub install_as_core { $_[0]->installdirs('perl') }
+sub install_as_cpan { $_[0]->installdirs('site') }
+sub install_as_site { $_[0]->installdirs('site') }
+sub install_as_vendor { $_[0]->installdirs('vendor') }
+
+sub dynamic_config {
+ my $self = shift;
+ my $value = @_ ? shift : 1;
+ if ( $self->{values}->{dynamic_config} ) {
+ # Once dynamic we never change to static, for safety
+ return 0;
+ }
+ $self->{values}->{dynamic_config} = $value ? 1 : 0;
+ return 1;
+}
+
+# Convenience command
+sub static_config {
+ shift->dynamic_config(0);
+}
+
+sub perl_version {
+ my $self = shift;
+ return $self->{values}->{perl_version} unless @_;
+ my $version = shift or die(
+ "Did not provide a value to perl_version()"
+ );
+
+ # Normalize the version
+ $version = $self->_perl_version($version);
+
+ # We don't support the really old versions
+ unless ( $version >= 5.005 ) {
+ die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
+ }
+
+ $self->{values}->{perl_version} = $version;
+}
+
+sub all_from {
+ my ( $self, $file ) = @_;
+
+ unless ( defined($file) ) {
+ my $name = $self->name or die(
+ "all_from called with no args without setting name() first"
+ );
+ $file = join('/', 'lib', split(/-/, $name)) . '.pm';
+ $file =~ s{.*/}{} unless -e $file;
+ unless ( -e $file ) {
+ die("all_from cannot find $file from $name");
+ }
+ }
+ unless ( -f $file ) {
+ die("The path '$file' does not exist, or is not a file");
+ }
+
+ $self->{values}{all_from} = $file;
+
+ # Some methods pull from POD instead of code.
+ # If there is a matching .pod, use that instead
+ my $pod = $file;
+ $pod =~ s/\.pm$/.pod/i;
+ $pod = $file unless -e $pod;
+
+ # Pull the different values
+ $self->name_from($file) unless $self->name;
+ $self->version_from($file) unless $self->version;
+ $self->perl_version_from($file) unless $self->perl_version;
+ $self->author_from($pod) unless @{$self->author || []};
+ $self->license_from($pod) unless $self->license;
+ $self->abstract_from($pod) unless $self->abstract;
+
+ return 1;
+}
+
+sub provides {
+ my $self = shift;
+ my $provides = ( $self->{values}->{provides} ||= {} );
+ %$provides = (%$provides, @_) if @_;
+ return $provides;
+}
+
+sub auto_provides {
+ my $self = shift;
+ return $self unless $self->is_admin;
+ unless (-e 'MANIFEST') {
+ warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
+ return $self;
+ }
+ # Avoid spurious warnings as we are not checking manifest here.
+ local $SIG{__WARN__} = sub {1};
+ require ExtUtils::Manifest;
+ local *ExtUtils::Manifest::manicheck = sub { return };
+
+ require Module::Build;
+ my $build = Module::Build->new(
+ dist_name => $self->name,
+ dist_version => $self->version,
+ license => $self->license,
+ );
+ $self->provides( %{ $build->find_dist_packages || {} } );
+}
+
+sub feature {
+ my $self = shift;
+ my $name = shift;
+ my $features = ( $self->{values}->{features} ||= [] );
+ my $mods;
+
+ if ( @_ == 1 and ref( $_[0] ) ) {
+ # The user used ->feature like ->features by passing in the second
+ # argument as a reference. Accomodate for that.
+ $mods = $_[0];
+ } else {
+ $mods = \@_;
+ }
+
+ my $count = 0;
+ push @$features, (
+ $name => [
+ map {
+ ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
+ } @$mods
+ ]
+ );
+
+ return @$features;
+}
+
+sub features {
+ my $self = shift;
+ while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
+ $self->feature( $name, @$mods );
+ }
+ return $self->{values}->{features}
+ ? @{ $self->{values}->{features} }
+ : ();
+}
+
+sub no_index {
+ my $self = shift;
+ my $type = shift;
+ push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
+ return $self->{values}->{no_index};
+}
+
+sub read {
+ my $self = shift;
+ $self->include_deps( 'YAML::Tiny', 0 );
+
+ require YAML::Tiny;
+ my $data = YAML::Tiny::LoadFile('META.yml');
+
+ # Call methods explicitly in case user has already set some values.
+ while ( my ( $key, $value ) = each %$data ) {
+ next unless $self->can($key);
+ if ( ref $value eq 'HASH' ) {
+ while ( my ( $module, $version ) = each %$value ) {
+ $self->can($key)->($self, $module => $version );
+ }
+ } else {
+ $self->can($key)->($self, $value);
+ }
+ }
+ return $self;
+}
+
+sub write {
+ my $self = shift;
+ return $self unless $self->is_admin;
+ $self->admin->write_meta;
+ return $self;
+}
+
+sub version_from {
+ require ExtUtils::MM_Unix;
+ my ( $self, $file ) = @_;
+ $self->version( ExtUtils::MM_Unix->parse_version($file) );
+
+ # for version integrity check
+ $self->makemaker_args( VERSION_FROM => $file );
+}
+
+sub abstract_from {
+ require ExtUtils::MM_Unix;
+ my ( $self, $file ) = @_;
+ $self->abstract(
+ bless(
+ { DISTNAME => $self->name },
+ 'ExtUtils::MM_Unix'
+ )->parse_abstract($file)
+ );
+}
+
+# Add both distribution and module name
+sub name_from {
+ my ($self, $file) = @_;
+ if (
+ Module::Install::_read($file) =~ m/
+ ^ \s*
+ package \s*
+ ([\w:]+)
+ \s* ;
+ /ixms
+ ) {
+ my ($name, $module_name) = ($1, $1);
+ $name =~ s{::}{-}g;
+ $self->name($name);
+ unless ( $self->module_name ) {
+ $self->module_name($module_name);
+ }
+ } else {
+ die("Cannot determine name from $file\n");
+ }
+}
+
+sub _extract_perl_version {
+ if (
+ $_[0] =~ m/
+ ^\s*
+ (?:use|require) \s*
+ v?
+ ([\d_\.]+)
+ \s* ;
+ /ixms
+ ) {
+ my $perl_version = $1;
+ $perl_version =~ s{_}{}g;
+ return $perl_version;
+ } else {
+ return;
+ }
+}
+
+sub perl_version_from {
+ my $self = shift;
+ my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
+ if ($perl_version) {
+ $self->perl_version($perl_version);
+ } else {
+ warn "Cannot determine perl version info from $_[0]\n";
+ return;
+ }
+}
+
+sub author_from {
+ my $self = shift;
+ my $content = Module::Install::_read($_[0]);
+ if ($content =~ m/
+ =head \d \s+ (?:authors?)\b \s*
+ ([^\n]*)
+ |
+ =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
+ .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
+ ([^\n]*)
+ /ixms) {
+ my $author = $1 || $2;
+
+ # XXX: ugly but should work anyway...
+ if (eval "require Pod::Escapes; 1") {
+ # Pod::Escapes has a mapping table.
+ # It's in core of perl >= 5.9.3, and should be installed
+ # as one of the Pod::Simple's prereqs, which is a prereq
+ # of Pod::Text 3.x (see also below).
+ $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
+ {
+ defined $2
+ ? chr($2)
+ : defined $Pod::Escapes::Name2character_number{$1}
+ ? chr($Pod::Escapes::Name2character_number{$1})
+ : do {
+ warn "Unknown escape: E<$1>";
+ "E<$1>";
+ };
+ }gex;
+ }
+ elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
+ # Pod::Text < 3.0 has yet another mapping table,
+ # though the table name of 2.x and 1.x are different.
+ # (1.x is in core of Perl < 5.6, 2.x is in core of
+ # Perl < 5.9.3)
+ my $mapping = ($Pod::Text::VERSION < 2)
+ ? \%Pod::Text::HTML_Escapes
+ : \%Pod::Text::ESCAPES;
+ $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
+ {
+ defined $2
+ ? chr($2)
+ : defined $mapping->{$1}
+ ? $mapping->{$1}
+ : do {
+ warn "Unknown escape: E<$1>";
+ "E<$1>";
+ };
+ }gex;
+ }
+ else {
+ $author =~ s{E<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ }
+ $self->author($author);
+ } else {
+ warn "Cannot determine author info from $_[0]\n";
+ }
+}
+
+#Stolen from M::B
+my %license_urls = (
+ perl => 'http://dev.perl.org/licenses/',
+ apache => 'http://apache.org/licenses/LICENSE-2.0',
+ apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
+ artistic => 'http://opensource.org/licenses/artistic-license.php',
+ artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
+ lgpl => 'http://opensource.org/licenses/lgpl-license.php',
+ lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
+ lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
+ bsd => 'http://opensource.org/licenses/bsd-license.php',
+ gpl => 'http://opensource.org/licenses/gpl-license.php',
+ gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
+ gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
+ mit => 'http://opensource.org/licenses/mit-license.php',
+ mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
+ open_source => undef,
+ unrestricted => undef,
+ restrictive => undef,
+ unknown => undef,
+);
+
+sub license {
+ my $self = shift;
+ return $self->{values}->{license} unless @_;
+ my $license = shift or die(
+ 'Did not provide a value to license()'
+ );
+ $license = __extract_license($license) || lc $license;
+ $self->{values}->{license} = $license;
+
+ # Automatically fill in license URLs
+ if ( $license_urls{$license} ) {
+ $self->resources( license => $license_urls{$license} );
+ }
+
+ return 1;
+}
+
+sub _extract_license {
+ my $pod = shift;
+ my $matched;
+ return __extract_license(
+ ($matched) = $pod =~ m/
+ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?)
+ (=head \d.*|=cut.*|)\z
+ /xms
+ ) || __extract_license(
+ ($matched) = $pod =~ m/
+ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?)
+ (=head \d.*|=cut.*|)\z
+ /xms
+ );
+}
+
+sub __extract_license {
+ my $license_text = shift or return;
+ my @phrases = (
+ '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1,
+ '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
+ 'Artistic and GPL' => 'perl', 1,
+ 'GNU general public license' => 'gpl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser general public license' => 'lgpl', 1,
+ 'GNU lesser public license' => 'lgpl', 1,
+ 'GNU library general public license' => 'lgpl', 1,
+ 'GNU library public license' => 'lgpl', 1,
+ 'GNU Free Documentation license' => 'unrestricted', 1,
+ 'GNU Affero General Public License' => 'open_source', 1,
+ '(?:Free)?BSD license' => 'bsd', 1,
+ 'Artistic license 2\.0' => 'artistic_2', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'Apache (?:Software )?license' => 'apache', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 1,
+ 'Mozilla Public License' => 'mozilla', 1,
+ 'Q Public License' => 'open_source', 1,
+ 'OpenSSL License' => 'unrestricted', 1,
+ 'SSLeay License' => 'unrestricted', 1,
+ 'zlib License' => 'open_source', 1,
+ 'proprietary' => 'proprietary', 0,
+ );
+ while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
+ $pattern =~ s#\s+#\\s+#gs;
+ if ( $license_text =~ /\b$pattern\b/i ) {
+ return $license;
+ }
+ }
+ return '';
+}
+
+sub license_from {
+ my $self = shift;
+ if (my $license=_extract_license(Module::Install::_read($_[0]))) {
+ $self->license($license);
+ } else {
+ warn "Cannot determine license info from $_[0]\n";
+ return 'unknown';
+ }
+}
+
+sub _extract_bugtracker {
+ my @links = $_[0] =~ m#L<(
+ https?\Q://rt.cpan.org/\E[^>]+|
+ https?\Q://github.com/\E[\w_]+/[\w_]+/issues|
+ https?\Q://code.google.com/p/\E[\w_\-]+/issues/list
+ )>#gx;
+ my %links;
+ @links{@links}=();
+ @links=keys %links;
+ return @links;
+}
+
+sub bugtracker_from {
+ my $self = shift;
+ my $content = Module::Install::_read($_[0]);
+ my @links = _extract_bugtracker($content);
+ unless ( @links ) {
+ warn "Cannot determine bugtracker info from $_[0]\n";
+ return 0;
+ }
+ if ( @links > 1 ) {
+ warn "Found more than one bugtracker link in $_[0]\n";
+ return 0;
+ }
+
+ # Set the bugtracker
+ bugtracker( $links[0] );
+ return 1;
+}
+
+sub requires_from {
+ my $self = shift;
+ my $content = Module::Install::_readperl($_[0]);
+ my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg;
+ while ( @requires ) {
+ my $module = shift @requires;
+ my $version = shift @requires;
+ $self->requires( $module => $version );
+ }
+}
+
+sub test_requires_from {
+ my $self = shift;
+ my $content = Module::Install::_readperl($_[0]);
+ my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
+ while ( @requires ) {
+ my $module = shift @requires;
+ my $version = shift @requires;
+ $self->test_requires( $module => $version );
+ }
+}
+
+# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
+# numbers (eg, 5.006001 or 5.008009).
+# Also, convert double-part versions (eg, 5.8)
+sub _perl_version {
+ my $v = $_[-1];
+ $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
+ $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
+ $v =~ s/(\.\d\d\d)000$/$1/;
+ $v =~ s/_.+$//;
+ if ( ref($v) ) {
+ # Numify
+ $v = $v + 0;
+ }
+ return $v;
+}
+
+sub add_metadata {
+ my $self = shift;
+ my %hash = @_;
+ for my $key (keys %hash) {
+ warn "add_metadata: $key is not prefixed with 'x_'.\n" .
+ "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
+ $self->{values}->{$key} = $hash{$key};
+ }
+}
+
+
+######################################################################
+# MYMETA Support
+
+sub WriteMyMeta {
+ die "WriteMyMeta has been deprecated";
+}
+
+sub write_mymeta_yaml {
+ my $self = shift;
+
+ # We need YAML::Tiny to write the MYMETA.yml file
+ unless ( eval { require YAML::Tiny; 1; } ) {
+ return 1;
+ }
+
+ # Generate the data
+ my $meta = $self->_write_mymeta_data or return 1;
+
+ # Save as the MYMETA.yml file
+ print "Writing MYMETA.yml\n";
+ YAML::Tiny::DumpFile('MYMETA.yml', $meta);
+}
+
+sub write_mymeta_json {
+ my $self = shift;
+
+ # We need JSON to write the MYMETA.json file
+ unless ( eval { require JSON; 1; } ) {
+ return 1;
+ }
+
+ # Generate the data
+ my $meta = $self->_write_mymeta_data or return 1;
+
+ # Save as the MYMETA.yml file
+ print "Writing MYMETA.json\n";
+ Module::Install::_write(
+ 'MYMETA.json',
+ JSON->new->pretty(1)->canonical->encode($meta),
+ );
+}
+
+sub _write_mymeta_data {
+ my $self = shift;
+
+ # If there's no existing META.yml there is nothing we can do
+ return undef unless -f 'META.yml';
+
+ # We need Parse::CPAN::Meta to load the file
+ unless ( eval { require Parse::CPAN::Meta; 1; } ) {
+ return undef;
+ }
+
+ # Merge the perl version into the dependencies
+ my $val = $self->Meta->{values};
+ my $perl = delete $val->{perl_version};
+ if ( $perl ) {
+ $val->{requires} ||= [];
+ my $requires = $val->{requires};
+
+ # Canonize to three-dot version after Perl 5.6
+ if ( $perl >= 5.006 ) {
+ $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
+ }
+ unshift @$requires, [ perl => $perl ];
+ }
+
+ # Load the advisory META.yml file
+ my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
+ my $meta = $yaml[0];
+
+ # Overwrite the non-configure dependency hashs
+ delete $meta->{requires};
+ delete $meta->{build_requires};
+ delete $meta->{recommends};
+ if ( exists $val->{requires} ) {
+ $meta->{requires} = { map { @$_ } @{ $val->{requires} } };
+ }
+ if ( exists $val->{build_requires} ) {
+ $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
+ }
+
+ return $meta;
+}
+
+1;
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
new file mode 100644
index 0000000..73b9cda
--- /dev/null
+++ b/inc/Module/Install/RTx.pm
@@ -0,0 +1,231 @@
+#line 1
+package Module::Install::RTx;
+
+use 5.008;
+use strict;
+use warnings;
+no warnings 'once';
+
+use Module::Install::Base;
+use base 'Module::Install::Base';
+our $VERSION = '0.29';
+
+use FindBin;
+use File::Glob ();
+use File::Basename ();
+
+my @DIRS = qw(etc lib html bin sbin po var);
+my @INDEX_DIRS = qw(lib bin sbin);
+
+sub RTx {
+ my ( $self, $name ) = @_;
+
+ my $original_name = $name;
+ my $RTx = 'RTx';
+ $RTx = $1 if $name =~ s/^(\w+)-//;
+ my $fname = $name;
+ $fname =~ s!-!/!g;
+
+ $self->name("$RTx-$name")
+ unless $self->name;
+ $self->all_from( -e "$name.pm" ? "$name.pm" : "lib/$RTx/$fname.pm" )
+ unless $self->version;
+ $self->abstract("RT $name Extension")
+ unless $self->abstract;
+
+ my @prefixes = (qw(/opt /usr/local /home /usr /sw ));
+ my $prefix = $ENV{PREFIX};
+ @ARGV = grep { /PREFIX=(.*)/ ? ( ( $prefix = $1 ), 0 ) : 1 } @ARGV;
+
+ if ($prefix) {
+ $RT::LocalPath = $prefix;
+ $INC{'RT.pm'} = "$RT::LocalPath/lib/RT.pm";
+ } else {
+ local @INC = (
+ $ENV{RTHOME} ? ( $ENV{RTHOME}, "$ENV{RTHOME}/lib" ) : (),
+ @INC,
+ map { ( "$_/rt4/lib", "$_/lib/rt4", "$_/rt3/lib", "$_/lib/rt3", "$_/lib" )
+ } grep $_, @prefixes
+ );
+ until ( eval { require RT; $RT::LocalPath } ) {
+ warn
+ "Cannot find the location of RT.pm that defines \$RT::LocalPath in: @INC\n";
+ $_ = $self->prompt("Path to directory containing your RT.pm:") or exit;
+ $_ =~ s/\/RT\.pm$//;
+ push @INC, $_, "$_/rt3/lib", "$_/lib/rt3", "$_/lib";
+ }
+ }
+
+ my $lib_path = File::Basename::dirname( $INC{'RT.pm'} );
+ my $local_lib_path = "$RT::LocalPath/lib";
+ print "Using RT configuration from $INC{'RT.pm'}:\n";
+ unshift @INC, "$RT::LocalPath/lib" if $RT::LocalPath;
+ unshift @INC, $lib_path;
+
+ $RT::LocalVarPath ||= $RT::VarPath;
+ $RT::LocalPoPath ||= $RT::LocalLexiconPath;
+ $RT::LocalHtmlPath ||= $RT::MasonComponentRoot;
+ $RT::LocalLibPath ||= "$RT::LocalPath/lib";
+
+ my $with_subdirs = $ENV{WITH_SUBDIRS};
+ @ARGV = grep { /WITH_SUBDIRS=(.*)/ ? ( ( $with_subdirs = $1 ), 0 ) : 1 }
+ @ARGV;
+
+ my %subdirs;
+ %subdirs = map { $_ => 1 } split( /\s*,\s*/, $with_subdirs )
+ if defined $with_subdirs;
+ unless ( keys %subdirs ) {
+ $subdirs{$_} = 1 foreach grep -d "$FindBin::Bin/$_", @DIRS;
+ }
+
+ # If we're running on RT 3.8 with plugin support, we really wany
+ # to install libs, mason templates and po files into plugin specific
+ # directories
+ my %path;
+ if ( $RT::LocalPluginPath ) {
+ die "Because of bugs in RT 3.8.0 this extension can not be installed.\n"
+ ."Upgrade to RT 3.8.1 or newer.\n" if $RT::VERSION =~ /^3\.8\.0/;
+ $path{$_} = $RT::LocalPluginPath . "/$original_name/$_"
+ foreach @DIRS;
+ } else {
+ foreach ( @DIRS ) {
+ no strict 'refs';
+ my $varname = "RT::Local" . ucfirst($_) . "Path";
+ $path{$_} = ${$varname} || "$RT::LocalPath/$_";
+ }
+
+ $path{$_} .= "/$name" for grep $path{$_}, qw(etc po var);
+ }
+
+ my %index = map { $_ => 1 } @INDEX_DIRS;
+ $self->no_index( directory => $_ ) foreach grep !$index{$_}, @DIRS;
+
+ my $args = join ', ', map "q($_)", map { ($_, $path{$_}) }
+ grep $subdirs{$_}, keys %path;
+
+ print "./$_\t=> $path{$_}\n" for sort keys %subdirs;
+
+ if ( my @dirs = map { ( -D => $_ ) } grep $subdirs{$_}, qw(bin html sbin) ) {
+ my @po = map { ( -o => $_ ) }
+ grep -f,
+ File::Glob::bsd_glob("po/*.po");
+ $self->postamble(<< ".") if @po;
+lexicons ::
+\t\$(NOECHO) \$(PERL) -MLocale::Maketext::Extract::Run=xgettext -e \"xgettext(qw(@dirs @po))\"
+.
+ }
+
+ my $postamble = << ".";
+install ::
+\t\$(NOECHO) \$(PERL) -MExtUtils::Install -e \"install({$args})\"
+.
+
+ if ( $subdirs{var} and -d $RT::MasonDataDir ) {
+ my ( $uid, $gid ) = ( stat($RT::MasonDataDir) )[ 4, 5 ];
+ $postamble .= << ".";
+\t\$(NOECHO) chown -R $uid:$gid $path{var}
+.
+ }
+
+ my %has_etc;
+ if ( File::Glob::bsd_glob("$FindBin::Bin/etc/schema.*") ) {
+
+ # got schema, load factory module
+ $has_etc{schema}++;
+ $self->load('RTxFactory');
+ $self->postamble(<< ".");
+factory ::
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxFactory(qw($RTx $name))"
+
+dropdb ::
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxFactory(qw($RTx $name drop))"
+
+.
+ }
+ if ( File::Glob::bsd_glob("$FindBin::Bin/etc/acl.*") ) {
+ $has_etc{acl}++;
+ }
+ if ( -e 'etc/initialdata' ) { $has_etc{initialdata}++; }
+
+ $self->postamble("$postamble\n");
+ unless ( $subdirs{'lib'} ) {
+ $self->makemaker_args( PM => { "" => "" }, );
+ } else {
+ $self->makemaker_args( INSTALLSITELIB => $path{'lib'} );
+ $self->makemaker_args( INSTALLARCHLIB => $path{'lib'} );
+ }
+
+ $self->makemaker_args( INSTALLSITEMAN1DIR => "$RT::LocalPath/man/man1" );
+ $self->makemaker_args( INSTALLSITEMAN3DIR => "$RT::LocalPath/man/man3" );
+ $self->makemaker_args( INSTALLSITEARCH => "$RT::LocalPath/man" );
+
+ if (%has_etc) {
+ $self->load('RTxInitDB');
+ print "For first-time installation, type 'make initdb'.\n";
+ my $initdb = '';
+ $initdb .= <<"." if $has_etc{schema};
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(schema))"
+.
+ $initdb .= <<"." if $has_etc{acl};
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(acl))"
+.
+ $initdb .= <<"." if $has_etc{initialdata};
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(insert))"
+.
+ $self->postamble("initdb ::\n$initdb\n");
+ $self->postamble("initialize-database ::\n$initdb\n");
+ }
+}
+
+sub RTxInit {
+ unshift @INC, substr( delete( $INC{'RT.pm'} ), 0, -5 ) if $INC{'RT.pm'};
+ require RT;
+ RT::LoadConfig();
+ RT::ConnectToDatabase();
+
+ die "Cannot load RT" unless $RT::Handle and $RT::DatabaseType;
+}
+
+# stolen from RT::Handle so we work on 3.6 (cmp_versions came in with 3.8)
+{ my %word = (
+ a => -4,
+ alpha => -4,
+ b => -3,
+ beta => -3,
+ pre => -2,
+ rc => -1,
+ head => 9999,
+);
+sub cmp_version($$) {
+ my ($a, $b) = (@_);
+ my @a = grep defined, map { /^[0-9]+$/? $_ : /^[a-zA-Z]+$/? $word{$_}|| -10 : undef }
+ split /([^0-9]+)/, $a;
+ my @b = grep defined, map { /^[0-9]+$/? $_ : /^[a-zA-Z]+$/? $word{$_}|| -10 : undef }
+ split /([^0-9]+)/, $b;
+ @a > @b
+ ? push @b, (0) x (@a- at b)
+ : push @a, (0) x (@b- at a);
+ for ( my $i = 0; $i < @a; $i++ ) {
+ return $a[$i] <=> $b[$i] if $a[$i] <=> $b[$i];
+ }
+ return 0;
+}}
+sub requires_rt {
+ my ($self,$version) = @_;
+
+ # if we're exactly the same version as what we want, silently return
+ return if ($version eq $RT::VERSION);
+
+ my @sorted = sort cmp_version $version,$RT::VERSION;
+
+ if ($sorted[-1] eq $version) {
+ # should we die?
+ warn "\nWarning: prerequisite RT $version not found. Your installed version of RT ($RT::VERSION) is too old.\n\n";
+ }
+}
+
+1;
+
+__END__
+
+#line 348
diff --git a/inc/Module/Install/ReadmeFromPod.pm b/inc/Module/Install/ReadmeFromPod.pm
new file mode 100644
index 0000000..fb7075f
--- /dev/null
+++ b/inc/Module/Install/ReadmeFromPod.pm
@@ -0,0 +1,138 @@
+#line 1
+package Module::Install::ReadmeFromPod;
+
+use 5.006;
+use strict;
+use warnings;
+use base qw(Module::Install::Base);
+use vars qw($VERSION);
+
+$VERSION = '0.18';
+
+sub readme_from {
+ my $self = shift;
+ return unless $self->is_admin;
+
+ # Input file
+ my $in_file = shift || $self->_all_from
+ or die "Can't determine file to make readme_from";
+
+ # Get optional arguments
+ my ($clean, $format, $out_file, $options);
+ my $args = shift;
+ if ( ref $args ) {
+ # Arguments are in a hashref
+ if ( ref($args) ne 'HASH' ) {
+ die "Expected a hashref but got a ".ref($args)."\n";
+ } else {
+ $clean = $args->{'clean'};
+ $format = $args->{'format'};
+ $out_file = $args->{'output_file'};
+ $options = $args->{'options'};
+ }
+ } else {
+ # Arguments are in a list
+ $clean = $args;
+ $format = shift;
+ $out_file = shift;
+ $options = \@_;
+ }
+
+ # Default values;
+ $clean ||= 0;
+ $format ||= 'txt';
+
+ # Generate README
+ print "readme_from $in_file to $format\n";
+ if ($format =~ m/te?xt/) {
+ $out_file = $self->_readme_txt($in_file, $out_file, $options);
+ } elsif ($format =~ m/html?/) {
+ $out_file = $self->_readme_htm($in_file, $out_file, $options);
+ } elsif ($format eq 'man') {
+ $out_file = $self->_readme_man($in_file, $out_file, $options);
+ } elsif ($format eq 'pdf') {
+ $out_file = $self->_readme_pdf($in_file, $out_file, $options);
+ }
+
+ if ($clean) {
+ $self->clean_files($out_file);
+ }
+
+ return 1;
+}
+
+
+sub _readme_txt {
+ my ($self, $in_file, $out_file, $options) = @_;
+ $out_file ||= 'README';
+ require Pod::Text;
+ my $parser = Pod::Text->new( @$options );
+ open my $out_fh, '>', $out_file or die "Could not write file $out_file:\n$!\n";
+ $parser->output_fh( *$out_fh );
+ $parser->parse_file( $in_file );
+ close $out_fh;
+ return $out_file;
+}
+
+
+sub _readme_htm {
+ my ($self, $in_file, $out_file, $options) = @_;
+ $out_file ||= 'README.htm';
+ require Pod::Html;
+ Pod::Html::pod2html(
+ "--infile=$in_file",
+ "--outfile=$out_file",
+ @$options,
+ );
+ # Remove temporary files if needed
+ for my $file ('pod2htmd.tmp', 'pod2htmi.tmp') {
+ if (-e $file) {
+ unlink $file or warn "Warning: Could not remove file '$file'.\n$!\n";
+ }
+ }
+ return $out_file;
+}
+
+
+sub _readme_man {
+ my ($self, $in_file, $out_file, $options) = @_;
+ $out_file ||= 'README.1';
+ require Pod::Man;
+ my $parser = Pod::Man->new( @$options );
+ $parser->parse_from_file($in_file, $out_file);
+ return $out_file;
+}
+
+
+sub _readme_pdf {
+ my ($self, $in_file, $out_file, $options) = @_;
+ $out_file ||= 'README.pdf';
+ eval { require App::pod2pdf; }
+ or die "Could not generate $out_file because pod2pdf could not be found\n";
+ my $parser = App::pod2pdf->new( @$options );
+ $parser->parse_from_file($in_file);
+ open my $out_fh, '>', $out_file or die "Could not write file $out_file:\n$!\n";
+ select $out_fh;
+ $parser->output;
+ select STDOUT;
+ close $out_fh;
+ return $out_file;
+}
+
+
+sub _all_from {
+ my $self = shift;
+ return unless $self->admin->{extensions};
+ my ($metadata) = grep {
+ ref($_) eq 'Module::Install::Metadata';
+ } @{$self->admin->{extensions}};
+ return unless $metadata;
+ return $metadata->{values}{all_from} || '';
+}
+
+'Readme!';
+
+__END__
+
+#line 254
+
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
new file mode 100644
index 0000000..eeaa3fe
--- /dev/null
+++ b/inc/Module/Install/Win32.pm
@@ -0,0 +1,64 @@
+#line 1
+package Module::Install::Win32;
+
+use strict;
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.06';
+ @ISA = 'Module::Install::Base';
+ $ISCORE = 1;
+}
+
+# determine if the user needs nmake, and download it if needed
+sub check_nmake {
+ my $self = shift;
+ $self->load('can_run');
+ $self->load('get_file');
+
+ require Config;
+ return unless (
+ $^O eq 'MSWin32' and
+ $Config::Config{make} and
+ $Config::Config{make} =~ /^nmake\b/i and
+ ! $self->can_run('nmake')
+ );
+
+ print "The required 'nmake' executable not found, fetching it...\n";
+
+ require File::Basename;
+ my $rv = $self->get_file(
+ url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
+ ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
+ local_dir => File::Basename::dirname($^X),
+ size => 51928,
+ run => 'Nmake15.exe /o > nul',
+ check_for => 'Nmake.exe',
+ remove => 1,
+ );
+
+ die <<'END_MESSAGE' unless $rv;
+
+-------------------------------------------------------------------------------
+
+Since you are using Microsoft Windows, you will need the 'nmake' utility
+before installation. It's available at:
+
+ http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
+ or
+ ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
+
+Please download the file manually, save it to a directory in %PATH% (e.g.
+C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
+that directory, and run "Nmake15.exe" from there; that will create the
+'nmake.exe' file needed by this module.
+
+You may then resume the installation process described in README.
+
+-------------------------------------------------------------------------------
+END_MESSAGE
+
+}
+
+1;
diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm
new file mode 100644
index 0000000..85d8018
--- /dev/null
+++ b/inc/Module/Install/WriteAll.pm
@@ -0,0 +1,63 @@
+#line 1
+package Module::Install::WriteAll;
+
+use strict;
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '1.06';
+ @ISA = qw{Module::Install::Base};
+ $ISCORE = 1;
+}
+
+sub WriteAll {
+ my $self = shift;
+ my %args = (
+ meta => 1,
+ sign => 0,
+ inline => 0,
+ check_nmake => 1,
+ @_,
+ );
+
+ $self->sign(1) if $args{sign};
+ $self->admin->WriteAll(%args) if $self->is_admin;
+
+ $self->check_nmake if $args{check_nmake};
+ unless ( $self->makemaker_args->{PL_FILES} ) {
+ # XXX: This still may be a bit over-defensive...
+ unless ($self->makemaker(6.25)) {
+ $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
+ }
+ }
+
+ # Until ExtUtils::MakeMaker support MYMETA.yml, make sure
+ # we clean it up properly ourself.
+ $self->realclean_files('MYMETA.yml');
+
+ if ( $args{inline} ) {
+ $self->Inline->write;
+ } else {
+ $self->Makefile->write;
+ }
+
+ # The Makefile write process adds a couple of dependencies,
+ # so write the META.yml files after the Makefile.
+ if ( $args{meta} ) {
+ $self->Meta->write;
+ }
+
+ # Experimental support for MYMETA
+ if ( $ENV{X_MYMETA} ) {
+ if ( $ENV{X_MYMETA} eq 'JSON' ) {
+ $self->Meta->write_mymeta_json;
+ } else {
+ $self->Meta->write_mymeta_yaml;
+ }
+ }
+
+ return 1;
+}
+
+1;
diff --git a/lib/RT/Extension/Announce.pm b/lib/RT/Extension/Announce.pm
new file mode 100644
index 0000000..20bed43
--- /dev/null
+++ b/lib/RT/Extension/Announce.pm
@@ -0,0 +1,89 @@
+use strict;
+use warnings;
+package RT::Extension::Announce;
+
+our $VERSION = '0.01';
+
+=head1 NAME
+
+RT-Extension-Announce - Display announcements as a banner on RT pages.
+
+=head1 INSTALLATION
+
+=over
+
+=item perl Makefile.PL
+
+=item make
+
+=item make install
+
+May need root permissions
+
+=item Edit your /opt/rt4/etc/RT_SiteConfig.pm
+
+Add these lines:
+
+ Set($RTAnnounceQueue, 'AnnounceQueueName');
+ Set(@Plugins, qw(RT::Extension::Announce));
+
+or add C<RT::Extension::Announce> 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 DESCRIPTION
+
+The Announce extension gives you an easy way to insert announcements on RT pages
+so all users can see the message. You may want to display a banner during maintenance or
+an unscheduled outage to make sure the people fielding customer tickets know that
+something is going on.
+
+To post an announcement, create a ticket in the queue you identified in the
+RTAnnounceQueue configuration. The extension displays the two most recent updates
+on new or open tickets in that queue. The subject and most recent textual
+message are displayed. As the incident or maintenance progresses, just post
+the updates to the ticket and the announcement will be updated with the latest
+information.
+
+You should set up a designated queue for announcement messages so you can post
+tickets only when you want an announcement displayed. You can set
+permissions on the queue to control who can create new announcements
+and who should see them.
+
+Setting up a designated
+queue also allows you to customize it in other ways. For example, you may not
+want to send the typical 'ticket create' email messages, so you could change
+or customize the scrips that run or create new templates. If you send
+announcement messages to an email list,
+you could create a list user in RT and add it as a CC to the announcement
+queue. Then messages posted for announcement in RT will also be sent to the
+notification list.
+
+=head1 AUTHOR
+
+Jim Brandt <jbrandt at bestpractical.com>
+
+=head1 BUGS
+
+All bugs should be reported via
+L<http://rt.cpan.org/Public/Dist/Display.html?Name=RT-Extension-Announce>
+or L<bug-RT-Extension-Announce at rt.cpan.org>.
+
+
+=head1 LICENSE AND COPYRIGHT
+
+This software is Copyright (c) 2012 by Best Practical Solutions, LLC
+
+This is free software, licensed under:
+
+ The GNU General Public License, Version 2, June 1991
+
+=cut
+
+1;
commit 4235f83709dd364e9feb5748d010c6f44a5e367b
Author: Jim Brandt <jbrandt at bestpractical.com>
Date: Wed Jun 20 16:39:28 2012 -0400
Add group filtering
Also: fixed wrong sort order, updated docs, removed configurable
queue since it is now installed, added initialdata.
diff --git a/META.yml b/META.yml
index f102477..803f2a6 100644
--- a/META.yml
+++ b/META.yml
@@ -16,6 +16,7 @@ meta-spec:
name: RT-Extension-Announce
no_index:
directory:
+ - etc
- html
- inc
resources:
diff --git a/README b/README
index 471aa4c..e2e0397 100644
--- a/README
+++ b/README
@@ -10,11 +10,15 @@ INSTALLATION
Edit your /opt/rt4/etc/RT_SiteConfig.pm
Add these lines:
- Set($RTAnnounceQueue, 'AnnounceQueueName');
Set(@Plugins, qw(RT::Extension::Announce));
+ Set(@CustomFieldValuesSources, (qw(RT::CustomFieldValues::AnnounceGroups)));
or add "RT::Extension::Announce" to your existing @Plugins line.
+ make initdb
+ Run this in the install directory where you ran the previous make
+ commands.
+
Clear your mason cache
rm -rf /opt/rt4/var/mason_data/obj
@@ -22,29 +26,38 @@ INSTALLATION
DESCRIPTION
The Announce extension gives you an easy way to insert announcements on
- RT pages so all users can see the message. You may want to display a
- banner during maintenance or an unscheduled outage to make sure the
- people fielding customer tickets know that something is going on.
-
- To post an announcement, create a ticket in the queue you identified in
- the RTAnnounceQueue configuration. The extension displays the two most
- recent updates on new or open tickets in that queue. The subject and
- most recent textual message are displayed. As the incident or
- maintenance progresses, just post the updates to the ticket and the
- announcement will be updated with the latest information.
-
- You should set up a designated queue for announcement messages so you
- can post tickets only when you want an announcement displayed. You can
- set permissions on the queue to control who can create new announcements
- and who should see them.
-
- Setting up a designated queue also allows you to customize it in other
- ways. For example, you may not want to send the typical 'ticket create'
- email messages, so you could change or customize the scrips that run or
- create new templates. If you send announcement messages to an email
- list, you could create a list user in RT and add it as a CC to the
- announcement queue. Then messages posted for announcement in RT will
- also be sent to the notification list.
+ the RT homepage so all users can see the message. You may want to
+ display a banner during maintenance or an unscheduled outage to make
+ sure the people fielding customer tickets know that something is going
+ on.
+
+ When you install the extension, a new queue is created called
+ RTAnnounce. To post an announcement, create a ticket in that queue. The
+ extension displays the subject and most recent update on active tickets
+ in the RTAnnounce queue. As the incident or maintenance progresses, just
+ post the updates to the ticket and the announcement will be updated with
+ the latest information. When the incident is over, resolve the ticket
+ and the announcement will be removed.
+
+ The RTAnnounce queue has a group custom field which you can use to limit
+ who will see an announcement. If you set no RT group, all users will see
+ the announcement. If you set one or more groups, memebers of those
+ groups will see it.
+
+ By default, the announements are static text. If you give users the
+ ShowTicket right on the RTAnnounce queue, the announcements will have
+ links to the source tickets. This will allow users to see the history of
+ an announcement or see longer messages that might be truncated on the
+ homepage.
+
+ The RTAnnounce queue is a regular queue, so you can control access to
+ creating announcements the same way you manage permissions on other
+ queues. In addition to setting permissions, you may not want to send the
+ typical 'ticket create' email messages, so you could change or customize
+ the scrips that run or create new templates. If you send announcement
+ messages to an email list, you could create a list user in RT and add it
+ as a CC to the announcement queue. Then messages posted for announcement
+ in RT will also be sent to the notification list.
AUTHOR
Jim Brandt <jbrandt at bestpractical.com>
diff --git a/etc/initialdata b/etc/initialdata
new file mode 100644
index 0000000..9fbb521
--- /dev/null
+++ b/etc/initialdata
@@ -0,0 +1,16 @@
+ at Queues = ({ Name => 'RTAnnounce',
+ Description => 'Queue for announcements',
+ CorrespondAddress => "",
+ CommentAddress => "", });
+
+ at CustomFields = (
+ {
+ Name => 'Announcement Groups',
+ Queue => RTAnnounce,
+ Type => 'Select',
+ Disabled => 0,
+ Description => 'Groups who can view individual announcements',
+ Values => [ ],
+ ValuesClass => 'RT::CustomFieldValues::AnnounceGroups',
+ },
+);
diff --git a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
index 0fc86a0..5b28f6e 100644
--- a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
+++ b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
@@ -49,11 +49,17 @@
<div id="announce">
<table class="announce">
%my $rows = 1;
-%while( my $ticket = $tickets->Next ){
+%#while( my $ticket = $tickets->Next ){
+%foreach my $ticket ( @tickets ){
<tr><td class="announce_subject">
+% if( $show_ticket_links ){
<a class="announce_subject"
href="<% RT->Config->Get('WebPath') %>/Ticket/Display.html?id=<% $ticket->Id %>">
- <% $ticket->Subject %></a></td>
+ <% $ticket->Subject %></a>
+% }else{
+ <% $ticket->Subject %>
+% }
+ </td>
<td>
<%perl>
my $txns = $ticket->Transactions;
@@ -72,16 +78,18 @@
$content .= chr(8230); # Ellipsis character
}
</%perl>
-<% $content %> <a href="<% RT->Config->Get('WebPath') %>/Ticket/Display.html?id=<% $ticket->Id %>">See Details</a>
+<% $content %>
+%if( $show_ticket_links){
+ (<a class="announcements_detail" href="<% RT->Config->Get('WebPath') %>/Ticket/Display.html?id=<% $ticket->Id %>">more</a>)
+%}
</td></tr>
-% if( $rows == $ShowTickets && $tickets->Count > $ShowTickets ){
-% # Tack on the more link
+% if( $rows == $ShowTickets && (scalar @tickets) > $ShowTickets ){
+% # More announcements, initially hidden.
<tr><td colspan=2 class="toggle_announcements">
<a href='#' class="toggle_announcements" id="toggle_announcements">More Announcements</a>
</td></tr>
<tbody id="more_announcements">
% }
-
%$rows++;
%}
%if( $rows >= $ShowTickets ){
@@ -89,30 +97,73 @@
%}
</table></div>
<%INIT>
-if ( not defined RT->Config->Get('RTAnnounceQueue') ){
- $RT::Logger->error('No queue defined for Announce extension. Set $RTAnnounceQueue in RT_SiteConfig.pm');
- return;
-}
# Only display on Homepage
-warn $m->request_comp->path;
return unless ( $m->request_comp->path =~ /^\/index.html$/ );
-my $queue = RT->Config->Get('RTAnnounceQueue');
-$queue =~ s/(['\\])/\\$1/g;
my $Queue = RT::Queue->new( $session{'CurrentUser'} );
-$Queue->Load($queue);
+$Queue->Load('RTAnnounce');
unless( $Queue->Id ){
- $RT::Logger->error('Invalid queue ' . $queue . ' set for Announce extension.');
+ $RT::Logger->error('RTAnnounce queue not found for Announce extension. Did you run make initdb?');
return;
}
-my $tickets = RT::Tickets->new( $session{'CurrentUser'} );
-$tickets->OrderBy( FIELD => 'LastUpdated', ORDER => 'DESC' );
-$tickets->FromSQL("Queue = '$queue' AND ( Status = 'new' OR Status = 'open' )");
+my @tickets;
+
+# Get announce tickets.
+my $tickets = RT::Tickets->new( RT->SystemUser );
+$tickets->OrderBy( FIELD => 'LastUpdated', ORDER => 'ASC' );
+$tickets->FromSQL("Queue = 'RTAnnounce' AND ( Status = 'new' OR Status = 'open' )");
return if $tickets->Count == 0;
+# Get groups for each ticket
+while( my $ticket = $tickets->Next ){
+
+ my $groups = $ticket->CustomFieldValues('Announcement Groups');
+
+ if( $groups->Count == 0 ){
+ # No groups defined, everyone sees announcement
+ push @tickets, $ticket;
+ }
+
+ my @groups;
+ while ( my $group = $groups->Next ){
+ push @groups, $group->Content;
+ }
+
+ foreach my $group_name ( @groups ){
+ my $group_obj = RT::Group->new(RT->SystemUser);
+ $group_obj->LoadUserDefinedGroup($group_name);
+
+ unless( $group_obj->Id && $group_obj->Name eq $group_name ){
+ $RT::Logger->error("$group_name is not a valid group. Not showing this announcement.");
+ next;
+ }
+
+ if ( $group_obj->HasMemberRecursively($session{'CurrentUser'}->PrincipalObj) ) {
+ # User can see this announcement.
+ push @tickets, $ticket;
+ }
+ else{
+ $RT::Logger->debug('Not showing announcement ticket ' . $ticket->Id
+ . ' to user ' . $session{'CurrentUser'}->Name . ' because they are not '
+ . 'in group ' . $group_name );
+ }
+ }
+}
+
+# Don't show links if users can't view the announce tickets.
+my $show_ticket_links = $tickets[0]->HasRight(
+ Right => 'ShowTicket',
+ Principal => $session{'CurrentUser'} );
+
+unless( $show_ticket_links ){
+ $RT::Logger->debug('User ' . $session{'CurrentUser'}->Name . ' does not have '
+ . 'the ShowTicket right on the RTAnnounce queue and will not see links to '
+ . 'announcement tickets.');
+}
+
</%INIT>
<%ARGS>
$ShowTickets => 2
-$MaxMessageLength => 300;
+$MaxMessageLength => 300
</%ARGS>
diff --git a/html/NoAuth/css/announce.css b/html/NoAuth/css/announce.css
index 4d4a350..0d06348 100644
--- a/html/NoAuth/css/announce.css
+++ b/html/NoAuth/css/announce.css
@@ -32,8 +32,22 @@ a.toggle_announcements:hover {
text-decoration: none;
}
+a.announcements_detail:link {
+ text-decoration: underline;
+}
+
+a.announcements_detail:visited {
+ text-decoration: underline;
+}
+
+a.announcements_detail:hover {
+ text-decoration: underline;
+}
+
td.announce_subject {
width: 25%;
+ color: red;
+ font-weight: bold;
}
a.announce_subject:link {
diff --git a/inc/Module/Install/RTx/Factory.pm b/inc/Module/Install/RTx/Factory.pm
new file mode 100644
index 0000000..23ce911
--- /dev/null
+++ b/inc/Module/Install/RTx/Factory.pm
@@ -0,0 +1,483 @@
+#line 1
+package Module::Install::RTx::Factory;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+use strict;
+use File::Basename ();
+
+sub RTxInitDB {
+ my ($self, $action) = @_;
+
+ unshift @INC, substr(delete($INC{'RT.pm'}), 0, -5) if $INC{'RT.pm'};
+
+ require RT;
+ unshift @INC, "$RT::LocalPath/lib" if $RT::LocalPath;
+
+ $RT::SbinPath ||= $RT::LocalPath;
+ $RT::SbinPath =~ s/local$/sbin/;
+
+ foreach my $file ($RT::CORE_CONFIG_FILE, $RT::SITE_CONFIG_FILE) {
+ next if !-e $file or -r $file;
+ die "No permission to read $file\n-- please re-run $0 with suitable privileges.\n";
+ }
+
+ RT::LoadConfig();
+
+ my $lib_path = File::Basename::dirname($INC{'RT.pm'});
+ my @args = ("-Ilib");
+ push @args, "-I$RT::LocalPath/lib" if $RT::LocalPath;
+ push @args, (
+ "-I$lib_path",
+ "$RT::SbinPath/rt-setup-database",
+ "--action" => $action,
+ "--datadir" => "etc",
+ (($action eq 'insert') ? ("--datafile" => "etc/initialdata") : ()),
+ "--dba" => $RT::DatabaseUser,
+ "--prompt-for-dba-password" => ''
+ );
+ print "$^X @args\n";
+ (system($^X, @args) == 0) or die "...returned with error: $?\n";
+}
+
+sub RTxFactory {
+ my ($self, $RTx, $name, $drop) = @_;
+ my $namespace = "$RTx\::$name";
+
+ $self->RTxInit;
+
+ my $dbh = $RT::Handle->dbh;
+ # get all tables out of database
+ my @tables = $dbh->tables;
+ my ( %tablemap, %typemap, %modulemap );
+ my $driver = $RT::DatabaseType;
+
+ my $CollectionBaseclass = 'RT::SearchBuilder';
+ my $RecordBaseclass = 'RT::Record';
+ my $LicenseBlock = << '.';
+# BEGIN LICENSE BLOCK
+#
+# END LICENSE BLOCK
+.
+ my $Attribution = << '.';
+# Autogenerated by Module::Intall::RTx::Factory
+# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
+#
+# !! DO NOT EDIT THIS FILE !!
+#
+
+use strict;
+.
+ my $RecordInit = '';
+
+ @tables = map { do { {
+ my $table = $_;
+ $table =~ s/.*\.//g;
+ $table =~ s/\W//g;
+ $table =~ s/^\Q$name\E_//i or next;
+ $table ne 'sessions' or next;
+
+ $table = ucfirst(lc($table));
+ $table =~ s/$_/\u$_/ for qw(field group custom member value);
+ $table =~ s/(?<=Scrip)$_/\u$_/ for qw(action condition);
+ $table =~ s/$_/\U$_/ for qw(Acl);
+ $table = $name . '_' . $table;
+
+ $tablemap{$table} = $table;
+ $modulemap{$table} = $table;
+ if ( $table =~ /^(.*)s$/ ) {
+ $tablemap{$1} = $table;
+ $modulemap{$1} = $1;
+ }
+ $table;
+ } } } @tables;
+
+ $tablemap{'CreatedBy'} = 'User';
+ $tablemap{'UpdatedBy'} = 'User';
+
+ $typemap{'id'} = 'ro';
+ $typemap{'Creator'} = 'auto';
+ $typemap{'Created'} = 'auto';
+ $typemap{'Updated'} = 'auto';
+ $typemap{'UpdatedBy'} = 'auto';
+ $typemap{'LastUpdated'} = 'auto';
+ $typemap{'LastUpdatedBy'} = 'auto';
+
+ $typemap{lc($_)} = $typemap{$_} for keys %typemap;
+
+ foreach my $table (@tables) {
+ if ($drop) {
+ $dbh->do("DROP TABLE $table");
+ $dbh->do("DROP sequence ${table}_id_seq") if $driver eq 'Pg';
+ $dbh->do("DROP sequence ${table}_seq") if $driver eq 'Oracle';
+ next;
+ }
+
+ my $tablesingle = $table;
+ $tablesingle =~ s/^\Q$name\E_//i;
+ $tablesingle =~ s/s$//;
+ my $tableplural = $tablesingle . "s";
+
+ if ( $tablesingle eq 'ACL' ) {
+ $tablesingle = "ACE";
+ $tableplural = "ACL";
+ }
+
+ my %requirements;
+
+ my $CollectionClassName = $namespace . "::" . $tableplural;
+ my $RecordClassName = $namespace . "::" . $tablesingle;
+
+ my $path = $namespace;
+ $path =~ s/::/\//g;
+
+ my $RecordClassPath = $path . "/" . $tablesingle . ".pm";
+ my $CollectionClassPath = $path . "/" . $tableplural . ".pm";
+
+ #create a collection class
+ my $CreateInParams;
+ my $CreateOutParams;
+ my $ClassAccessible = "";
+ my $FieldsPod = "";
+ my $CreatePod = "";
+ my $CreateSub = "";
+ my %fields;
+ my $sth = $dbh->prepare("DESCRIBE $table");
+
+ if ( $driver eq 'Pg' ) {
+ $sth = $dbh->prepare(<<".");
+ SELECT a.attname, format_type(a.atttypid, a.atttypmod),
+ a.attnotnull, a.atthasdef, a.attnum
+ FROM pg_class c, pg_attribute a
+ WHERE c.relname ILIKE '$table'
+ AND a.attnum > 0
+ AND a.attrelid = c.oid
+ORDER BY a.attnum
+.
+ }
+ elsif ( $driver eq 'mysql' ) {
+ $sth = $dbh->prepare("DESCRIBE $table");
+ }
+ else {
+ die "$driver is currently unsupported";
+ }
+
+ $sth->execute;
+
+ while ( my $row = $sth->fetchrow_hashref() ) {
+ my ( $field, $type, $default );
+ if ( $driver eq 'Pg' ) {
+
+ $field = $row->{'attname'};
+ $type = $row->{'format_type'};
+ $default = $row->{'atthasdef'};
+
+ if ( $default != 0 ) {
+ my $tth = $dbh->prepare(<<".");
+SELECT substring(d.adsrc for 128)
+ FROM pg_attrdef d, pg_class c
+ WHERE c.relname = 'acct'
+ AND c.oid = d.adrelid
+ AND d.adnum = $row->{'attnum'}
+.
+ $tth->execute();
+ my @default = $tth->fetchrow_array;
+ $default = $default[0];
+ }
+
+ }
+ elsif ( $driver eq 'mysql' ) {
+ $field = $row->{'Field'};
+ $type = $row->{'Type'};
+ $default = $row->{'Default'};
+ }
+
+ $fields{$field} = 1;
+
+ #generate the 'accessible' datastructure
+
+ if ( $typemap{$field} eq 'auto' ) {
+ $ClassAccessible .= " $field =>
+ {read => 1, auto => 1,";
+ }
+ elsif ( $typemap{$field} eq 'ro' ) {
+ $ClassAccessible .= " $field =>
+ {read => 1,";
+ }
+ else {
+ $ClassAccessible .= " $field =>
+ {read => 1, write => 1,";
+
+ }
+
+ $ClassAccessible .= " type => '$type', default => '$default'},\n";
+
+ #generate pod for the accessible fields
+ $FieldsPod .= $self->_pod(<<".");
+^head2 $field
+
+Returns the current value of $field.
+(In the database, $field is stored as $type.)
+
+.
+
+ unless ( $typemap{$field} eq 'auto' || $typemap{$field} eq 'ro' ) {
+ $FieldsPod .= $self->_pod(<<".");
+
+^head2 Set$field VALUE
+
+
+Set $field to VALUE.
+Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
+(In the database, $field will be stored as a $type.)
+
+.
+ }
+
+ $FieldsPod .= $self->_pod(<<".");
+^cut
+
+.
+
+ if ( $modulemap{$field} ) {
+ $FieldsPod .= $self->_pod(<<".");
+^head2 ${field}Obj
+
+Returns the $modulemap{$field} Object which has the id returned by $field
+
+
+^cut
+
+sub ${field}Obj {
+ my \$self = shift;
+ my \$$field = ${namespace}::$modulemap{$field}->new(\$self->CurrentUser);
+ \$$field->Load(\$self->__Value('$field'));
+ return(\$$field);
+}
+.
+ $requirements{ $tablemap{$field} } =
+ "use ${namespace}::$modulemap{$field};";
+
+ }
+
+ unless ( $typemap{$field} eq 'auto' || $field eq 'id' ) {
+
+ #generate create statement
+ $CreateInParams .= " $field => '$default',\n";
+ $CreateOutParams .=
+ " $field => \$args{'$field'},\n";
+
+ #gerenate pod for the create statement
+ $CreatePod .= " $type '$field'";
+ $CreatePod .= " defaults to '$default'" if ($default);
+ $CreatePod .= ".\n";
+
+ }
+
+ }
+
+ $CreateSub = <<".";
+sub Create {
+ my \$self = shift;
+ my \%args = (
+$CreateInParams
+ \@_);
+ \$self->SUPER::Create(
+$CreateOutParams);
+
+}
+.
+ $CreatePod .= "\n=cut\n\n";
+
+ my $CollectionClass = $LicenseBlock . $Attribution . $self->_pod(<<".") . $self->_magic_import($CollectionClassName);
+
+^head1 NAME
+
+$CollectionClassName -- Class Description
+
+^head1 SYNOPSIS
+
+use $CollectionClassName
+
+^head1 DESCRIPTION
+
+
+^head1 METHODS
+
+^cut
+
+package $CollectionClassName;
+
+use $CollectionBaseclass;
+use $RecordClassName;
+
+use vars qw( \@ISA );
+\@ISA= qw($CollectionBaseclass);
+
+
+sub _Init {
+ my \$self = shift;
+ \$self->{'table'} = '$table';
+ \$self->{'primary_key'} = 'id';
+
+.
+
+ if ( $fields{'SortOrder'} ) {
+
+ $CollectionClass .= $self->_pod(<<".");
+
+# By default, order by name
+\$self->OrderBy( ALIAS => 'main',
+ FIELD => 'SortOrder',
+ ORDER => 'ASC');
+.
+ }
+ $CollectionClass .= $self->_pod(<<".");
+ return ( \$self->SUPER::_Init(\@_) );
+}
+
+
+^head2 NewItem
+
+Returns an empty new $RecordClassName item
+
+^cut
+
+sub NewItem {
+ my \$self = shift;
+ return($RecordClassName->new(\$self->CurrentUser));
+}
+.
+
+ my $RecordClassHeader = $Attribution . "
+
+^head1 NAME
+
+$RecordClassName
+
+
+^head1 SYNOPSIS
+
+^head1 DESCRIPTION
+
+^head1 METHODS
+
+^cut
+
+package $RecordClassName;
+use $RecordBaseclass;
+";
+
+ foreach my $key ( keys %requirements ) {
+ $RecordClassHeader .= $requirements{$key} . "\n";
+ }
+ $RecordClassHeader .= <<".";
+
+use vars qw( \@ISA );
+\@ISA= qw( $RecordBaseclass );
+
+sub _Init {
+my \$self = shift;
+
+\$self->Table('$table');
+\$self->SUPER::_Init(\@_);
+}
+
+.
+
+ my $RecordClass = $LicenseBlock . $RecordClassHeader . $self->_pod(<<".") . $self->_magic_import($RecordClassName);
+
+$RecordInit
+
+^head2 Create PARAMHASH
+
+Create takes a hash of values and creates a row in the database:
+
+$CreatePod
+
+$CreateSub
+
+$FieldsPod
+
+sub _CoreAccessible {
+ {
+
+$ClassAccessible
+}
+};
+
+.
+
+ print "About to make $RecordClassPath, $CollectionClassPath\n";
+ `mkdir -p $path`;
+
+ open( RECORD, ">$RecordClassPath" );
+ print RECORD $RecordClass;
+ close(RECORD);
+
+ open( COL, ">$CollectionClassPath" );
+ print COL $CollectionClass;
+ close(COL);
+
+ }
+}
+
+sub _magic_import {
+ my $self = shift;
+ my $class = ref($self) || $self;
+
+ #if (exists \$warnings::{unimport}) {
+ # no warnings qw(redefine);
+
+ my $path = $class;
+ $path =~ s#::#/#gi;
+
+
+ my $content = $self->_pod(<<".");
+ eval \"require ${class}_Overlay\";
+ if (\$@ && \$@ !~ qr{^Can't locate ${path}_Overlay.pm}) {
+ die \$@;
+ };
+
+ eval \"require ${class}_Vendor\";
+ if (\$@ && \$@ !~ qr{^Can't locate ${path}_Vendor.pm}) {
+ die \$@;
+ };
+
+ eval \"require ${class}_Local\";
+ if (\$@ && \$@ !~ qr{^Can't locate ${path}_Local.pm}) {
+ die \$@;
+ };
+
+
+
+
+^head1 SEE ALSO
+
+This class allows \"overlay\" methods to be placed
+into the following files _Overlay is for a System overlay by the original author,
+_Vendor is for 3rd-party vendor add-ons, while _Local is for site-local customizations.
+
+These overlay files can contain new subs or subs to replace existing subs in this module.
+
+If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+
+ no warnings qw(redefine);
+
+so that perl does not kick and scream when you redefine a subroutine or variable in your overlay.
+
+${class}_Overlay, ${class}_Vendor, ${class}_Local
+
+^cut
+
+
+1;
+.
+
+ return $content;
+}
+
+sub _pod {
+ my ($self, $text) = @_;
+ $text =~ s/^\^/=/mg;
+ return $text;
+}
diff --git a/lib/RT/CustomFieldValues/AnnounceGroups.pm b/lib/RT/CustomFieldValues/AnnounceGroups.pm
new file mode 100644
index 0000000..6b4e5ad
--- /dev/null
+++ b/lib/RT/CustomFieldValues/AnnounceGroups.pm
@@ -0,0 +1,81 @@
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC
+# <sales at bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+# 02110-1301 or visit their web page on the internet at
+# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# END BPS TAGGED BLOCK }}}
+
+package RT::CustomFieldValues::AnnounceGroups;
+
+use strict;
+use warnings;
+
+use base qw(RT::CustomFieldValues::External);
+use RT::Groups;
+
+sub SourceDescription {
+ return 'RT user defined groups for the RT Announce plugin';
+}
+
+sub ExternalValues {
+ my $self = shift;
+
+ my @res;
+ my $i = 0;
+ my $groups = RT::Groups->new( $self->CurrentUser );
+ $groups->LimitToUserDefinedGroups;
+ $groups->OrderByCols( { FIELD => 'Name' } );
+ while( my $group = $groups->Next ) {
+ push @res, {
+ name => $group->Name,
+ description => $group->Description,
+ sortorder => $i++,
+ };
+ }
+ return \@res;
+}
+
+RT::Base->_ImportOverlays();
+
+1;
diff --git a/lib/RT/Extension/Announce.pm b/lib/RT/Extension/Announce.pm
index 20bed43..419647d 100644
--- a/lib/RT/Extension/Announce.pm
+++ b/lib/RT/Extension/Announce.pm
@@ -24,11 +24,15 @@ May need root permissions
Add these lines:
- Set($RTAnnounceQueue, 'AnnounceQueueName');
Set(@Plugins, qw(RT::Extension::Announce));
+ Set(@CustomFieldValuesSources, (qw(RT::CustomFieldValues::AnnounceGroups)));
or add C<RT::Extension::Announce> to your existing C<@Plugins> line.
+=item make initdb
+
+Run this in the install directory where you ran the previous make commands.
+
=item Clear your mason cache
rm -rf /opt/rt4/var/mason_data/obj
@@ -39,25 +43,33 @@ or add C<RT::Extension::Announce> to your existing C<@Plugins> line.
=head1 DESCRIPTION
-The Announce extension gives you an easy way to insert announcements on RT pages
+The Announce extension gives you an easy way to insert announcements on the RT homepage
so all users can see the message. You may want to display a banner during maintenance or
an unscheduled outage to make sure the people fielding customer tickets know that
something is going on.
-To post an announcement, create a ticket in the queue you identified in the
-RTAnnounceQueue configuration. The extension displays the two most recent updates
-on new or open tickets in that queue. The subject and most recent textual
-message are displayed. As the incident or maintenance progresses, just post
+When you install the extension, a new queue is created called RTAnnounce.
+To post an announcement, create a ticket in that queue.
+The extension displays the subject and most recent update on active tickets in the
+RTAnnounce queue. As the incident or maintenance progresses, just post
the updates to the ticket and the announcement will be updated with the latest
-information.
-
-You should set up a designated queue for announcement messages so you can post
-tickets only when you want an announcement displayed. You can set
-permissions on the queue to control who can create new announcements
-and who should see them.
-
-Setting up a designated
-queue also allows you to customize it in other ways. For example, you may not
+information. When the incident is over, resolve the ticket and the
+announcement will be removed.
+
+The RTAnnounce queue has a group custom field which you can use to limit
+who will see an announcement. If you set no RT group, all users will see
+the announcement. If you set one or more groups, memebers of those groups
+will see it.
+
+By default, the announements are static text. If you give
+users the ShowTicket right on the RTAnnounce queue, the announcements
+will have links to the source tickets. This will allow users to see the
+history of an announcement or see longer messages that might be
+truncated on the homepage.
+
+The RTAnnounce queue is a regular queue, so you can control access to creating
+announcements the same way you manage permissions on other queues.
+In addition to setting permissions, you may not
want to send the typical 'ticket create' email messages, so you could change
or customize the scrips that run or create new templates. If you send
announcement messages to an email list,
commit 719219276cbc8614af8d587b6e3051bc36dde898
Author: Jim Brandt <jbrandt at bestpractical.com>
Date: Thu Jun 21 08:30:50 2012 -0400
Added border style to reflect RT aileron border sytle
diff --git a/html/NoAuth/css/announce.css b/html/NoAuth/css/announce.css
index 0d06348..856d793 100644
--- a/html/NoAuth/css/announce.css
+++ b/html/NoAuth/css/announce.css
@@ -10,6 +10,12 @@ table.announce {
border-bottom-right-radius: 0.3em;
border-bottom-left-radius: 0.3em;
valign: top;
+ border-left: 1px solid #ccc;
+ border-top: 1px solid #ccc;
+ border-bottom: 2px solid #aaa;
+ border-right: 2px solid #aaa;
+ border-radius: 0.5em;
+ padding: 1.5em 1em 1em 1em;
}
td.toggle_announcements {
commit 21805721bc1118b5abd3eeb3517d4a6ae4abdde1
Author: Jim Brandt <jbrandt at bestpractical.com>
Date: Thu Jun 21 09:36:17 2012 -0400
Fix reversed sort order on tickets.
Most recent updates on announcement tickets should appear first,
but the ASC order was doing the reverse. Changed to DESC.
Also tweaked the top padding and added a TESTING document.
diff --git a/TESTING.pod b/TESTING.pod
new file mode 100644
index 0000000..b90778a
--- /dev/null
+++ b/TESTING.pod
@@ -0,0 +1,105 @@
+=head1 Testing RT::Extension::Announce
+
+This document contains the test plan for the RT::Extension::Announce
+extension.
+
+=head1 Installation
+
+The extension should install with no errors. If you experience any errors
+during installtion, resolve them before testing as errors indicate the extension
+likely was not installed correctly.
+
+After installing, you should see one new RT queue and one new custom field.
+
+To confirm, log in as root or a user with admin privileges and do the
+following:
+
+=over
+
+=item 1.
+
+Go to Tools > Configuration > Queues. Confirm you see a queue
+called RTAnnounce.
+
+=item 2.
+
+Click on RTAnnounce, then click Ticket Custom Fields on the queue
+configuration page. Confirm the Selected Custom Fields section has an
+Announcement Groups custom field.
+
+=back
+
+If either of the above are missing, the 'make initdb' step was not
+run during the installation or it didn't run successfully. Resolve
+those issues before continuing.
+
+=head1 Creating Announcements
+
+As with any other queue, you'll need to create a group with permissions
+to create tickets in the RTAnnounce queue. For the remaining tests
+you'll need a user with permissions for that queue or an admin user
+like root. You'll also need access to a regular user to confirm
+what your users will see.
+
+The following confirm the extension is working. Multiple browsers
+can be helpful when testing as multiple users.
+
+=over
+
+=item 1.
+
+Create a new ticket in the RTAnnounce queue with no Announcement
+Group selected. Go to the RT homepage and confirm you see the
+announcement.
+
+=item 2.
+
+As the admin user, the announcement subjects should be links and you
+should see a 'more' link after the message content. Click the links to
+confirm you go to the announcement ticket.
+
+=item 3.
+
+Start to create another ticket in the RTAnnounce queue. Confirm
+you see groups from your RT instance in the Announcement Groups
+custom field on the create page.
+
+=item 4.
+
+Create the new ticket and select one or more groups when creating
+the ticket. Confirm a user in the selected group can see the announcement
+on the homepage.
+
+=item 5.
+
+Log in as a user not in one of the selected groups and confirm that
+user sees the first announcement with no group, but does not see the
+second announcement with groups selected. This user should not see
+the 'more' link and the announcement subject should not be a link.
+
+=item 6.
+
+Add one more announcement. The admin user should see a 'More Announcements'
+link at the bottom of the announcement box. Click the link to expand the
+announcement box.
+
+=item 7.
+
+Update the first announcement (comment or reply to the ticket). The
+announcements display should now show the first announcement at the top.
+
+=item 8.
+
+As the admin user, give the regular test user the ShowTicket right on
+the RTAnnounce queue (there are multiple ways to do this). That
+user should now see links in the announcements.
+
+=item 9.
+
+Resolve the first announcement ticket and confirm it is removed from the
+announcements list. With two active announcements, the admin user
+should no longer see the More Announcements link.
+
+=back
+
+=cut
diff --git a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
index 5b28f6e..2360658 100644
--- a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
+++ b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
@@ -111,7 +111,7 @@ my @tickets;
# Get announce tickets.
my $tickets = RT::Tickets->new( RT->SystemUser );
-$tickets->OrderBy( FIELD => 'LastUpdated', ORDER => 'ASC' );
+$tickets->OrderBy( FIELD => 'LastUpdated', ORDER => 'DESC' );
$tickets->FromSQL("Queue = 'RTAnnounce' AND ( Status = 'new' OR Status = 'open' )");
return if $tickets->Count == 0;
diff --git a/html/NoAuth/css/announce.css b/html/NoAuth/css/announce.css
index 856d793..776a100 100644
--- a/html/NoAuth/css/announce.css
+++ b/html/NoAuth/css/announce.css
@@ -15,7 +15,7 @@ table.announce {
border-bottom: 2px solid #aaa;
border-right: 2px solid #aaa;
border-radius: 0.5em;
- padding: 1.5em 1em 1em 1em;
+ padding: 1em 1em 1em 1em;
}
td.toggle_announcements {
commit dfe0b8375bfeb83ffcfbeec80988f63e200068c5
Author: Jim Brandt <jbrandt at bestpractical.com>
Date: Fri Jun 22 10:35:36 2012 -0400
Don't display comments, use ActiveStatusArray
Don't display comments on announcement tickets on the homepage.
Update docs to describe the above.
Use ActiveStatusArray to get active tickets rather than hardcoded
new and open.
Properly quote queue in initialdata.
diff --git a/README b/README
index e2e0397..75913ca 100644
--- a/README
+++ b/README
@@ -31,19 +31,34 @@ DESCRIPTION
sure the people fielding customer tickets know that something is going
on.
+DETAILS
When you install the extension, a new queue is created called
RTAnnounce. To post an announcement, create a ticket in that queue. The
- extension displays the subject and most recent update on active tickets
- in the RTAnnounce queue. As the incident or maintenance progresses, just
- post the updates to the ticket and the announcement will be updated with
- the latest information. When the incident is over, resolve the ticket
- and the announcement will be removed.
-
- The RTAnnounce queue has a group custom field which you can use to limit
- who will see an announcement. If you set no RT group, all users will see
- the announcement. If you set one or more groups, memebers of those
- groups will see it.
-
+ extension displays on the RT homepage the subject and most recent
+ correspondence on active tickets in the RTAnnounce queue. As the
+ incident or maintenance progresses, just reply to the ticket and the
+ announcement will be updated with the latest information.
+
+ When multiple announcements are active, they are ordered by the last
+ update time with the announcement with the most recent update coming
+ first.
+
+ When the incident is over, resolve the ticket and the announcement will
+ be removed.
+
+ Comments on announce tickets are not shown in the announcement. However,
+ comments are visible on the ticket for users who have permission to view
+ the full ticket. If you have multiple announcements, a new comment
+ updates the last updated time and will move the announcement to the top
+ of the list.
+
+ANNOUNCEMENT GROUPS
+ The RTAnnounce queue has a custom field called 'Announcement Groups'
+ which you can use to manage who will see an announcement. If you set no
+ value, all users will see the announcement. If you set one or more RT
+ groups, only memebers of those groups will see it.
+
+PERMISSIONS
By default, the announements are static text. If you give users the
ShowTicket right on the RTAnnounce queue, the announcements will have
links to the source tickets. This will allow users to see the history of
@@ -52,9 +67,11 @@ DESCRIPTION
The RTAnnounce queue is a regular queue, so you can control access to
creating announcements the same way you manage permissions on other
- queues. In addition to setting permissions, you may not want to send the
- typical 'ticket create' email messages, so you could change or customize
- the scrips that run or create new templates. If you send announcement
+ queues.
+
+ In addition to setting permissions, you may not want to send the typical
+ 'ticket create' email messages, so you could change or customize the
+ scrips that run or create new templates. If you send announcement
messages to an email list, you could create a list user in RT and add it
as a CC to the announcement queue. Then messages posted for announcement
in RT will also be sent to the notification list.
diff --git a/TESTING.pod b/TESTING.pod
index b90778a..80dd4e5 100644
--- a/TESTING.pod
+++ b/TESTING.pod
@@ -85,16 +85,21 @@ announcement box.
=item 7.
-Update the first announcement (comment or reply to the ticket). The
+Reply to the first announcement with an update. The
announcements display should now show the first announcement at the top.
=item 8.
+Comment on the first announcement. Confirm the comment does not
+appear on the homepage.
+
+=item 9.
+
As the admin user, give the regular test user the ShowTicket right on
the RTAnnounce queue (there are multiple ways to do this). That
user should now see links in the announcements.
-=item 9.
+=item 10.
Resolve the first announcement ticket and confirm it is removed from the
announcements list. With two active announcements, the admin user
diff --git a/etc/initialdata b/etc/initialdata
index 9fbb521..e7211b5 100644
--- a/etc/initialdata
+++ b/etc/initialdata
@@ -6,7 +6,7 @@
@CustomFields = (
{
Name => 'Announcement Groups',
- Queue => RTAnnounce,
+ Queue => 'RTAnnounce',
Type => 'Select',
Disabled => 0,
Description => 'Groups who can view individual announcements',
diff --git a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
index 2360658..aa4a657 100644
--- a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
+++ b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
@@ -49,7 +49,6 @@
<div id="announce">
<table class="announce">
%my $rows = 1;
-%#while( my $ticket = $tickets->Next ){
%foreach my $ticket ( @tickets ){
<tr><td class="announce_subject">
% if( $show_ticket_links ){
@@ -63,7 +62,7 @@
<td>
<%perl>
my $txns = $ticket->Transactions;
- for my $type ( qw(Create Comment Correspond) ){
+ for my $type ( qw(Create Correspond) ){
$txns->Limit( FIELD => 'Type', VALUE => $type );
}
$txns->OrderBy( FIELD => 'Created', ORDER => 'DESC' );
@@ -100,7 +99,7 @@
# Only display on Homepage
return unless ( $m->request_comp->path =~ /^\/index.html$/ );
-my $Queue = RT::Queue->new( $session{'CurrentUser'} );
+my $Queue = RT::Queue->new( RT->SystemUser );
$Queue->Load('RTAnnounce');
unless( $Queue->Id ){
$RT::Logger->error('RTAnnounce queue not found for Announce extension. Did you run make initdb?');
@@ -112,7 +111,10 @@ my @tickets;
# Get announce tickets.
my $tickets = RT::Tickets->new( RT->SystemUser );
$tickets->OrderBy( FIELD => 'LastUpdated', ORDER => 'DESC' );
-$tickets->FromSQL("Queue = 'RTAnnounce' AND ( Status = 'new' OR Status = 'open' )");
+my @statuses = $Queue->ActiveStatusArray();
+ at statuses = map {s/(['\\])/\\$1/g; "Status = '$_'"} @statuses;
+my $status_query = join(' OR ', @statuses );
+$tickets->FromSQL("Queue = 'RTAnnounce' AND ( $status_query )");
return if $tickets->Count == 0;
# Get groups for each ticket
diff --git a/lib/RT/Extension/Announce.pm b/lib/RT/Extension/Announce.pm
index 419647d..37fee6d 100644
--- a/lib/RT/Extension/Announce.pm
+++ b/lib/RT/Extension/Announce.pm
@@ -48,18 +48,35 @@ so all users can see the message. You may want to display a banner during mainte
an unscheduled outage to make sure the people fielding customer tickets know that
something is going on.
+=head1 DETAILS
+
When you install the extension, a new queue is created called RTAnnounce.
To post an announcement, create a ticket in that queue.
-The extension displays the subject and most recent update on active tickets in the
-RTAnnounce queue. As the incident or maintenance progresses, just post
-the updates to the ticket and the announcement will be updated with the latest
-information. When the incident is over, resolve the ticket and the
+The extension displays on the RT homepage the subject and most recent correspondence
+on active tickets in the RTAnnounce queue. As the incident or maintenance progresses,
+just reply to the ticket and the announcement will be updated with the latest
+information.
+
+When multiple announcements are active, they are ordered by
+the last update time with the announcement with the most recent
+update coming first.
+
+When the incident is over, resolve the ticket and the
announcement will be removed.
-The RTAnnounce queue has a group custom field which you can use to limit
-who will see an announcement. If you set no RT group, all users will see
-the announcement. If you set one or more groups, memebers of those groups
-will see it.
+Comments on announce tickets are not shown in the announcement. However,
+comments are visible on the ticket for users who have permission to view
+the full ticket. If you have multiple announcements, a new comment updates
+the last updated time and will move the announcement to the top of the list.
+
+=head1 ANNOUNCEMENT GROUPS
+
+The RTAnnounce queue has a custom field called 'Announcement Groups' which
+you can use to manage who will see an announcement. If you set no value, all
+users will see the announcement. If you set one or more RT groups, only memebers
+of those groups will see it.
+
+=head1 PERMISSIONS
By default, the announements are static text. If you give
users the ShowTicket right on the RTAnnounce queue, the announcements
@@ -69,6 +86,7 @@ truncated on the homepage.
The RTAnnounce queue is a regular queue, so you can control access to creating
announcements the same way you manage permissions on other queues.
+
In addition to setting permissions, you may not
want to send the typical 'ticket create' email messages, so you could change
or customize the scrips that run or create new templates. If you send
commit 193a0c78bf5e9f8fb3f393225424d43f97b986e6
Author: Jim Brandt <jbrandt at bestpractical.com>
Date: Wed Jun 27 16:08:08 2012 -0400
Updated MANIFEST
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..206ff85
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,23 @@
+etc/initialdata
+html/Callbacks/RT-Extension-Announce/Elements/Header/Head
+html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
+html/NoAuth/css/announce.css
+html/NoAuth/js/announce.js
+inc/Module/Install.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/ReadmeFromPod.pm
+inc/Module/Install/RTx.pm
+inc/Module/Install/RTx/Factory.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/RT/CustomFieldValues/AnnounceGroups.pm
+lib/RT/Extension/Announce.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+README
+TESTING.pod
commit 97275b9e743327d67576a5b2ef52befd864c506e
Author: Jim Brandt <jbrandt at bestpractical.com>
Date: Fri Aug 3 14:10:21 2012 -0400
Return if all announce tickets are filtered out by group
diff --git a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
index aa4a657..7707f50 100644
--- a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
+++ b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
@@ -153,6 +153,9 @@ while( my $ticket = $tickets->Next ){
}
}
+# Current user isn't in any groups that can see tickets.
+return if @tickets == 0;
+
# Don't show links if users can't view the announce tickets.
my $show_ticket_links = $tickets[0]->HasRight(
Right => 'ShowTicket',
commit c039325010f72720db510ff7433b524a4ab8c004
Author: Jim Brandt <jbrandt at bestpractical.com>
Date: Mon Sep 17 10:39:36 2012 -0400
Add some basic tests
diff --git a/MANIFEST b/MANIFEST
index 206ff85..a4f30fa 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -12,12 +12,14 @@ inc/Module/Install/Metadata.pm
inc/Module/Install/ReadmeFromPod.pm
inc/Module/Install/RTx.pm
inc/Module/Install/RTx/Factory.pm
+inc/Module/Install/Substitute.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
lib/RT/CustomFieldValues/AnnounceGroups.pm
lib/RT/Extension/Announce.pm
+lib/RT/Extension/Announce/Test.pm.in
Makefile.PL
MANIFEST This list of files
META.yml
README
-TESTING.pod
+t/basic.t
diff --git a/Makefile.PL b/Makefile.PL
index 8b22e05..025fbbf 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -1,10 +1,31 @@
use inc::Module::Install;
-
RTx 'RT-Extension-Announce';
all_from 'lib/RT/Extension/Announce.pm';
readme_from 'lib/RT/Extension/Announce.pm';
license 'gplv2';
+my ($lp) = ($INC{'RT.pm'} =~ /^(.*)[\\\/]/);
+my $lib_path = join( ' ', "$RT::LocalPath/lib", $lp );
+
+# Straight from perldoc perlvar
+use Config;
+my $secure_perl_path = $Config{perlpath};
+if ($^O ne 'VMS') {
+ $secure_perl_path .= $Config{_exe}
+ unless $secure_perl_path =~ m/$Config{_exe}$/i;
+}
+
+substitute(
+ {
+ RT_LIB_PATH => $lib_path,
+ PERL => $ENV{PERL} || $secure_perl_path,
+ },
+ {
+ sufix => '.in'
+ },
+ qw(lib/RT/Extension/Announce/Test.pm),
+);
+
sign;
WriteAll;
diff --git a/inc/Module/Install/Substitute.pm b/inc/Module/Install/Substitute.pm
new file mode 100644
index 0000000..56af7fe
--- /dev/null
+++ b/inc/Module/Install/Substitute.pm
@@ -0,0 +1,131 @@
+#line 1
+package Module::Install::Substitute;
+
+use strict;
+use warnings;
+use 5.008; # I don't care much about earlier versions
+
+use Module::Install::Base;
+our @ISA = qw(Module::Install::Base);
+
+our $VERSION = '0.03';
+
+require File::Temp;
+require File::Spec;
+require Cwd;
+
+#line 89
+
+sub substitute
+{
+ my $self = shift;
+ $self->{__subst} = shift;
+ $self->{__option} = {};
+ if( UNIVERSAL::isa( $_[0], 'HASH' ) ) {
+ my $opts = shift;
+ while( my ($k,$v) = each( %$opts ) ) {
+ $self->{__option}->{ lc( $k ) } = $v || '';
+ }
+ }
+ $self->_parse_options;
+
+ my @file = @_;
+ foreach my $f (@file) {
+ $self->_rewrite_file( $f );
+ }
+
+ return;
+}
+
+sub _parse_options
+{
+ my $self = shift;
+ my $cwd = Cwd::getcwd();
+ foreach my $t ( qw(from to) ) {
+ $self->{__option}->{$t} = $cwd unless $self->{__option}->{$t};
+ my $d = $self->{__option}->{$t};
+ die "Couldn't read directory '$d'" unless -d $d && -r _;
+ }
+}
+
+sub _rewrite_file
+{
+ my ($self, $file) = @_;
+ my $source = File::Spec->catfile( $self->{__option}{from}, $file );
+ $source .= $self->{__option}{sufix} if $self->{__option}{sufix};
+ unless( -f $source && -r _ ) {
+ print STDERR "Couldn't find file '$source'\n";
+ return;
+ }
+ my $dest = File::Spec->catfile( $self->{__option}{to}, $file );
+ return $self->__rewrite_file( $source, $dest );
+}
+
+sub __rewrite_file
+{
+ my ($self, $source, $dest) = @_;
+
+ my $mode = (stat($source))[2];
+
+ open my $sfh, "<$source" or die "Couldn't open '$source' for read";
+ print "Open input '$source' file for substitution\n";
+
+ my ($tmpfh, $tmpfname) = File::Temp::tempfile('mi-subst-XXXX', UNLINK => 1);
+ $self->__process_streams( $sfh, $tmpfh, ($source eq $dest)? 1: 0 );
+ close $sfh;
+
+ seek $tmpfh, 0, 0 or die "Couldn't seek in tmp file";
+
+ open my $dfh, ">$dest" or die "Couldn't open '$dest' for write";
+ print "Open output '$dest' file for substitution\n";
+
+ while( <$tmpfh> ) {
+ print $dfh $_;
+ }
+ close $dfh;
+ chmod $mode, $dest or "Couldn't change mode on '$dest'";
+}
+
+sub __process_streams
+{
+ my ($self, $in, $out, $replace) = @_;
+
+ my @queue = ();
+ my $subst = $self->{'__subst'};
+ my $re_subst = join('|', map {"\Q$_"} keys %{ $subst } );
+
+ while( my $str = <$in> ) {
+ if( $str =~ /^###\s*(before|replace|after)\:\s?(.*)$/s ) {
+ my ($action, $nstr) = ($1,$2);
+ $nstr =~ s/\@($re_subst)\@/$subst->{$1}/ge;
+
+ die "Replace action is bad idea for situations when dest is equal to source"
+ if $replace && $action eq 'replace';
+ if( $action eq 'before' ) {
+ die "no line before 'before' action" unless @queue;
+ # overwrite prev line;
+ pop @queue;
+ push @queue, $nstr;
+ push @queue, $str;
+ } elsif( $action eq 'replace' ) {
+ push @queue, $nstr;
+ } elsif( $action eq 'after' ) {
+ push @queue, $str;
+ push @queue, $nstr;
+ # skip one line;
+ <$in>;
+ }
+ } else {
+ push @queue, $str;
+ }
+ while( @queue > 3 ) {
+ print $out shift(@queue);
+ }
+ }
+ while( scalar @queue ) {
+ print $out shift(@queue);
+ }
+}
+
+1;
+
diff --git a/lib/RT/Extension/Announce/Test.pm.in b/lib/RT/Extension/Announce/Test.pm.in
new file mode 100644
index 0000000..c0b8d14
--- /dev/null
+++ b/lib/RT/Extension/Announce/Test.pm.in
@@ -0,0 +1,43 @@
+use strict;
+use warnings;
+
+### after: use lib qw(@RT_LIB_PATH@);
+use lib qw(/opt/rt4/local/lib /opt/rt4/lib);
+
+package RT::Extension::Announce::Test;
+
+our @ISA;
+BEGIN {
+ local $@;
+ eval { require RT::Test; 1 } or do {
+ require Test::More;
+ Test::More::BAIL_OUT(
+ "requires 3.8 to run tests. Error:\n$@\n"
+ ."You may need to set PERL5LIB=/path/to/rt/lib"
+ );
+ };
+ push @ISA, 'RT::Test';
+}
+
+sub import {
+ my $class = shift;
+ my %args = @_;
+
+ $args{'requires'} ||= [];
+ if ( $args{'testing'} ) {
+ unshift @{ $args{'requires'} }, 'RT::Extension::Announce';
+ } else {
+ $args{'testing'} = 'RT::Extension::Announce';
+ }
+
+ $args{'config'} =<<CONFIG;
+Set(\@CustomFieldValuesSources, (qw(RT::CustomFieldValues::AnnounceGroups)));
+CONFIG
+
+ $class->SUPER::import( %args );
+ $class->export_to_level(1);
+
+ require RT::Extension::Announce;
+}
+
+1;
diff --git a/t/basic.t b/t/basic.t
new file mode 100644
index 0000000..2f063fa
--- /dev/null
+++ b/t/basic.t
@@ -0,0 +1,28 @@
+use strict;
+use warnings;
+
+use RT::Extension::Announce::Test tests => 15;
+
+use_ok('RT::Extension::Announce');
+
+RT->Config->Set( Plugins => 'RT::Extension::Announce' );
+RT->Config->Set( CustomFieldValuesSources => 'RT::CustomFieldValues::AnnounceGroups' );
+
+my ( $baseurl, $m ) = RT::Test->started_ok();
+
+ok( $m->login( 'root', 'password' ), 'logged in' );
+
+diag "Create an announcement";
+{
+ my $t = RT::Test->create_ticket(
+ Queue => 'RTAnnounce',
+ Subject => 'Test Announcement',
+ Content => 'This is a test announcement xcontentx',
+ );
+
+ ok( $t->id, 'Create announcement ticket: ' . $t->id);
+
+ $m->get_ok($m->rt_base_url);
+ $m->content_like(qr/Test Announcement/, 'Found the test announcement subject');
+ $m->content_like(qr/xcontentx/, 'Found the test announcement content');
+}
commit a7c205eaff123fa24c0af581250ccd3f96c57183
Author: Jim Brandt <jbrandt at bestpractical.com>
Date: Mon Sep 17 10:41:40 2012 -0400
Make announce queue name configurable
diff --git a/META.yml b/META.yml
index 803f2a6..12c5e46 100644
--- a/META.yml
+++ b/META.yml
@@ -19,6 +19,7 @@ no_index:
- etc
- html
- inc
+ - t
resources:
license: http://opensource.org/licenses/gpl-license.php
-version: 0.01
+version: 0.03
diff --git a/README b/README
index 75913ca..4ec5897 100644
--- a/README
+++ b/README
@@ -76,6 +76,15 @@ PERMISSIONS
as a CC to the announcement queue. Then messages posted for announcement
in RT will also be sent to the notification list.
+CONFIGURATION
+ You can change the name of the queue used for announcements. First edit
+ the RTAnnounce queue in RT and change its name to your new name. Add a
+ line to your RT_SiteConfig.pm to set that new value:
+
+ Set($RTAnnounceQueue, 'Custom Announce Name');
+
+ Then clear your mason cache and restart your server.
+
AUTHOR
Jim Brandt <jbrandt at bestpractical.com>
diff --git a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
index 7707f50..44b3b0c 100644
--- a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
+++ b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
@@ -100,7 +100,7 @@
return unless ( $m->request_comp->path =~ /^\/index.html$/ );
my $Queue = RT::Queue->new( RT->SystemUser );
-$Queue->Load('RTAnnounce');
+$Queue->Load($AnnounceQueue);
unless( $Queue->Id ){
$RT::Logger->error('RTAnnounce queue not found for Announce extension. Did you run make initdb?');
return;
@@ -114,7 +114,7 @@ $tickets->OrderBy( FIELD => 'LastUpdated', ORDER => 'DESC' );
my @statuses = $Queue->ActiveStatusArray();
@statuses = map {s/(['\\])/\\$1/g; "Status = '$_'"} @statuses;
my $status_query = join(' OR ', @statuses );
-$tickets->FromSQL("Queue = 'RTAnnounce' AND ( $status_query )");
+$tickets->FromSQL("Queue = '$AnnounceQueue' AND ( $status_query )");
return if $tickets->Count == 0;
# Get groups for each ticket
@@ -163,7 +163,7 @@ my $show_ticket_links = $tickets[0]->HasRight(
unless( $show_ticket_links ){
$RT::Logger->debug('User ' . $session{'CurrentUser'}->Name . ' does not have '
- . 'the ShowTicket right on the RTAnnounce queue and will not see links to '
+ . "the ShowTicket right on the $AnnounceQueue queue and will not see links to "
. 'announcement tickets.');
}
@@ -171,4 +171,5 @@ unless( $show_ticket_links ){
<%ARGS>
$ShowTickets => 2
$MaxMessageLength => 300
+$AnnounceQueue => RT->Config->Get('RTAnnounceQueue') || 'RTAnnounce'
</%ARGS>
diff --git a/lib/RT/Extension/Announce.pm b/lib/RT/Extension/Announce.pm
index 37fee6d..257ed98 100644
--- a/lib/RT/Extension/Announce.pm
+++ b/lib/RT/Extension/Announce.pm
@@ -2,7 +2,7 @@ use strict;
use warnings;
package RT::Extension::Announce;
-our $VERSION = '0.01';
+our $VERSION = '0.03';
=head1 NAME
@@ -95,6 +95,16 @@ you could create a list user in RT and add it as a CC to the announcement
queue. Then messages posted for announcement in RT will also be sent to the
notification list.
+=head1 CONFIGURATION
+
+You can change the name of the queue used for announcements. First edit the
+RTAnnounce queue in RT and change its name to your new name. Add a line
+to your RT_SiteConfig.pm to set that new value:
+
+ Set($RTAnnounceQueue, 'Custom Announce Name');
+
+Then clear your mason cache and restart your server.
+
=head1 AUTHOR
Jim Brandt <jbrandt at bestpractical.com>
commit 2dcb95d0075d66737c31794723c4b008e5657802
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Oct 2 16:39:02 2012 -0700
Use a CSS, not Perl, comment :)
diff --git a/html/NoAuth/css/announce.css b/html/NoAuth/css/announce.css
index 776a100..9081d6f 100644
--- a/html/NoAuth/css/announce.css
+++ b/html/NoAuth/css/announce.css
@@ -1,5 +1,5 @@
#announce {
- padding-top: 10px; # Keep from running into the menu on the right
+ padding-top: 10px; /* Keep from running into the menu on the right */
}
table.announce {
@@ -64,4 +64,4 @@ a.announce_subject:link {
a.announce_subject:visited {
color: red;
font-weight: bold;
-}
\ No newline at end of file
+}
commit d3fa54ea5aae9c6d994bc1a82d3be1069b544d5e
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Oct 2 16:43:21 2012 -0700
Add JS and CSS via standard framework methods
This gets the JS and CSS into the squished bundles.
diff --git a/MANIFEST b/MANIFEST
index a4f30fa..07df030 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,5 +1,4 @@
etc/initialdata
-html/Callbacks/RT-Extension-Announce/Elements/Header/Head
html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
html/NoAuth/css/announce.css
html/NoAuth/js/announce.js
diff --git a/html/Callbacks/RT-Extension-Announce/Elements/Header/Head b/html/Callbacks/RT-Extension-Announce/Elements/Header/Head
deleted file mode 100644
index fed441d..0000000
--- a/html/Callbacks/RT-Extension-Announce/Elements/Header/Head
+++ /dev/null
@@ -1,49 +0,0 @@
-%# BEGIN BPS TAGGED BLOCK {{{
-%#
-%# COPYRIGHT:
-%#
-%# This software is Copyright (c) 2012 Best Practical Solutions, LLC
-%# <sales at bestpractical.com>
-%#
-%# (Except where explicitly superseded by other copyright notices)
-%#
-%#
-%# LICENSE:
-%#
-%# This work is made available to you under the terms of Version 2 of
-%# the GNU General Public License. A copy of that license should have
-%# been provided with this software, but in any event can be snarfed
-%# from www.gnu.org.
-%#
-%# This work is distributed in the hope that it will be useful, but
-%# WITHOUT ANY WARRANTY; without even the implied warranty of
-%# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-%# General Public License for more details.
-%#
-%# You should have received a copy of the GNU General Public License
-%# along with this program; if not, write to the Free Software
-%# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-%# 02110-1301 or visit their web page on the internet at
-%# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
-%#
-%#
-%# CONTRIBUTION SUBMISSION POLICY:
-%#
-%# (The following paragraph is not intended to limit the rights granted
-%# to you to modify and distribute this software under the terms of
-%# the GNU General Public License and is only of importance to you if
-%# you choose to contribute your changes and enhancements to the
-%# community by submitting them to Best Practical Solutions, LLC.)
-%#
-%# By intentionally submitting any modifications, corrections or
-%# derivatives to this work, or any other work intended for use with
-%# Request Tracker, to Best Practical Solutions, LLC, you confirm that
-%# you are the copyright holder for those contributions and you grant
-%# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
-%# royalty-free, perpetual, license to use, copy, create derivative
-%# works based on those contributions, and sublicense and distribute
-%# those contributions and any derivatives thereof.
-%#
-%# END BPS TAGGED BLOCK }}}
-<link rel="stylesheet" type="text/css" href="<%RT->Config->Get('WebPath')%>/NoAuth/css/announce.css">
-<script type="text/javascript" src="<%RT->Config->Get('WebPath')%>/NoAuth/js/announce.js"></script>
diff --git a/lib/RT/Extension/Announce.pm b/lib/RT/Extension/Announce.pm
index 257ed98..5320f14 100644
--- a/lib/RT/Extension/Announce.pm
+++ b/lib/RT/Extension/Announce.pm
@@ -4,6 +4,9 @@ package RT::Extension::Announce;
our $VERSION = '0.03';
+RT->AddJavaScript('announce.js');
+RT->AddStyleSheets('announce.css');
+
=head1 NAME
RT-Extension-Announce - Display announcements as a banner on RT pages.
commit df2375a76f120b7faae1a64d114429a64145a6ff
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Oct 2 16:44:00 2012 -0700
Ignore the generated Test.pm
diff --git a/.gitignore b/.gitignore
index 2cbfeea..745d1a3 100644
--- a/.gitignore
+++ b/.gitignore
@@ -10,3 +10,4 @@ pod2htm*.tmp
*.bak
*.swp
/MYMETA.*
+/lib/RT/Extension/Announce/Test.pm
commit 61acf266af074daae2db574078e57e0b5af54bcc
Author: Thomas Sibley <trs at bestpractical.com>
Date: Tue Oct 2 16:44:46 2012 -0700
Ignore test tmp dir
diff --git a/.gitignore b/.gitignore
index 745d1a3..6fb9039 100644
--- a/.gitignore
+++ b/.gitignore
@@ -11,3 +11,4 @@ pod2htm*.tmp
*.swp
/MYMETA.*
/lib/RT/Extension/Announce/Test.pm
+/t/tmp
commit e53b70df7c4575e01ada8c459c3b210b6720961d
Author: Thomas Sibley <trs at bestpractical.com>
Date: Thu Oct 4 12:43:03 2012 -0700
Reduce group check to a single query
Rather than count and then loop, just loop and check what we got, if
anything.
diff --git a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
index 44b3b0c..f37053f 100644
--- a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
+++ b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
@@ -122,16 +122,17 @@ while( my $ticket = $tickets->Next ){
my $groups = $ticket->CustomFieldValues('Announcement Groups');
- if( $groups->Count == 0 ){
- # No groups defined, everyone sees announcement
- push @tickets, $ticket;
- }
-
my @groups;
while ( my $group = $groups->Next ){
push @groups, $group->Content;
}
+ unless (@groups) {
+ # No groups defined, everyone sees announcement
+ push @tickets, $ticket;
+ next;
+ }
+
foreach my $group_name ( @groups ){
my $group_obj = RT::Group->new(RT->SystemUser);
$group_obj->LoadUserDefinedGroup($group_name);
commit ab71540ae553661fffcfa9a03ba0f4569da0ce73
Author: Thomas Sibley <trs at bestpractical.com>
Date: Thu Oct 4 13:01:49 2012 -0700
Improve debug logging
diff --git a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
index f37053f..96921ee 100644
--- a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
+++ b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
@@ -117,9 +117,11 @@ my $status_query = join(' OR ', @statuses );
$tickets->FromSQL("Queue = '$AnnounceQueue' AND ( $status_query )");
return if $tickets->Count == 0;
+my $who = $session{CurrentUser}->Name;
+
# Get groups for each ticket
while( my $ticket = $tickets->Next ){
-
+ my $tid = $ticket->id;
my $groups = $ticket->CustomFieldValues('Announcement Groups');
my @groups;
@@ -129,6 +131,7 @@ while( my $ticket = $tickets->Next ){
unless (@groups) {
# No groups defined, everyone sees announcement
+ RT->Logger->debug("Showing announcement #$tid to $who: not limited to any groups");
push @tickets, $ticket;
next;
}
@@ -138,18 +141,20 @@ while( my $ticket = $tickets->Next ){
$group_obj->LoadUserDefinedGroup($group_name);
unless( $group_obj->Id && $group_obj->Name eq $group_name ){
- $RT::Logger->error("$group_name is not a valid group. Not showing this announcement.");
+ $RT::Logger->error("Cannot find group '$group_name' for announcement #$tid (for $who)");
next;
}
if ( $group_obj->HasMemberRecursively($session{'CurrentUser'}->PrincipalObj) ) {
# User can see this announcement.
+ RT->Logger->debug("Showing announcement #$tid to $who: member of '$group_name'");
push @tickets, $ticket;
}
else{
- $RT::Logger->debug('Not showing announcement ticket ' . $ticket->Id
- . ' to user ' . $session{'CurrentUser'}->Name . ' because they are not '
- . 'in group ' . $group_name );
+ $RT::Logger->debug(
+ "Not showing announcement ticket #$tid to user $who "
+ . "because they are not in group $group_name"
+ );
}
}
}
@@ -163,7 +168,7 @@ my $show_ticket_links = $tickets[0]->HasRight(
Principal => $session{'CurrentUser'} );
unless( $show_ticket_links ){
- $RT::Logger->debug('User ' . $session{'CurrentUser'}->Name . ' does not have '
+ $RT::Logger->debug("User $who does not have "
. "the ShowTicket right on the $AnnounceQueue queue and will not see links to "
. 'announcement tickets.');
}
commit bf2b5ef593a932e3633ebeb04a8376adf14bc643
Author: Thomas Sibley <trs at bestpractical.com>
Date: Thu Oct 4 13:02:19 2012 -0700
Update M::I
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
index 73b9cda..2eba7ad 100644
--- a/inc/Module/Install/RTx.pm
+++ b/inc/Module/Install/RTx.pm
@@ -8,7 +8,7 @@ no warnings 'once';
use Module::Install::Base;
use base 'Module::Install::Base';
-our $VERSION = '0.29';
+our $VERSION = '0.29_02';
use FindBin;
use File::Glob ();
@@ -129,18 +129,7 @@ install ::
my %has_etc;
if ( File::Glob::bsd_glob("$FindBin::Bin/etc/schema.*") ) {
-
- # got schema, load factory module
$has_etc{schema}++;
- $self->load('RTxFactory');
- $self->postamble(<< ".");
-factory ::
-\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxFactory(qw($RTx $name))"
-
-dropdb ::
-\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxFactory(qw($RTx $name drop))"
-
-.
}
if ( File::Glob::bsd_glob("$FindBin::Bin/etc/acl.*") ) {
$has_etc{acl}++;
@@ -164,28 +153,19 @@ dropdb ::
print "For first-time installation, type 'make initdb'.\n";
my $initdb = '';
$initdb .= <<"." if $has_etc{schema};
-\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(schema))"
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(schema \$(NAME) \$(VERSION)))"
.
$initdb .= <<"." if $has_etc{acl};
-\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(acl))"
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(acl \$(NAME) \$(VERSION)))"
.
$initdb .= <<"." if $has_etc{initialdata};
-\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(insert))"
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(insert \$(NAME) \$(VERSION)))"
.
$self->postamble("initdb ::\n$initdb\n");
$self->postamble("initialize-database ::\n$initdb\n");
}
}
-sub RTxInit {
- unshift @INC, substr( delete( $INC{'RT.pm'} ), 0, -5 ) if $INC{'RT.pm'};
- require RT;
- RT::LoadConfig();
- RT::ConnectToDatabase();
-
- die "Cannot load RT" unless $RT::Handle and $RT::DatabaseType;
-}
-
# stolen from RT::Handle so we work on 3.6 (cmp_versions came in with 3.8)
{ my %word = (
a => -4,
@@ -228,4 +208,4 @@ sub requires_rt {
__END__
-#line 348
+#line 328
diff --git a/inc/Module/Install/RTx/Factory.pm b/inc/Module/Install/RTx/Factory.pm
index 23ce911..a8702e4 100644
--- a/inc/Module/Install/RTx/Factory.pm
+++ b/inc/Module/Install/RTx/Factory.pm
@@ -6,7 +6,7 @@ use strict;
use File::Basename ();
sub RTxInitDB {
- my ($self, $action) = @_;
+ my ($self, $action, $name, $version) = @_;
unshift @INC, substr(delete($INC{'RT.pm'}), 0, -5) if $INC{'RT.pm'};
@@ -23,6 +23,8 @@ sub RTxInitDB {
RT::LoadConfig();
+ require RT::System;
+
my $lib_path = File::Basename::dirname($INC{'RT.pm'});
my @args = ("-Ilib");
push @args, "-I$RT::LocalPath/lib" if $RT::LocalPath;
@@ -33,451 +35,12 @@ sub RTxInitDB {
"--datadir" => "etc",
(($action eq 'insert') ? ("--datafile" => "etc/initialdata") : ()),
"--dba" => $RT::DatabaseUser,
- "--prompt-for-dba-password" => ''
+ "--prompt-for-dba-password" => '',
+ (RT::System->can('AddUpgradeHistory') ? ("--package" => $name, "--ext-version" => $version) : ()),
);
+
print "$^X @args\n";
(system($^X, @args) == 0) or die "...returned with error: $?\n";
}
-sub RTxFactory {
- my ($self, $RTx, $name, $drop) = @_;
- my $namespace = "$RTx\::$name";
-
- $self->RTxInit;
-
- my $dbh = $RT::Handle->dbh;
- # get all tables out of database
- my @tables = $dbh->tables;
- my ( %tablemap, %typemap, %modulemap );
- my $driver = $RT::DatabaseType;
-
- my $CollectionBaseclass = 'RT::SearchBuilder';
- my $RecordBaseclass = 'RT::Record';
- my $LicenseBlock = << '.';
-# BEGIN LICENSE BLOCK
-#
-# END LICENSE BLOCK
-.
- my $Attribution = << '.';
-# Autogenerated by Module::Intall::RTx::Factory
-# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
-#
-# !! DO NOT EDIT THIS FILE !!
-#
-
-use strict;
-.
- my $RecordInit = '';
-
- @tables = map { do { {
- my $table = $_;
- $table =~ s/.*\.//g;
- $table =~ s/\W//g;
- $table =~ s/^\Q$name\E_//i or next;
- $table ne 'sessions' or next;
-
- $table = ucfirst(lc($table));
- $table =~ s/$_/\u$_/ for qw(field group custom member value);
- $table =~ s/(?<=Scrip)$_/\u$_/ for qw(action condition);
- $table =~ s/$_/\U$_/ for qw(Acl);
- $table = $name . '_' . $table;
-
- $tablemap{$table} = $table;
- $modulemap{$table} = $table;
- if ( $table =~ /^(.*)s$/ ) {
- $tablemap{$1} = $table;
- $modulemap{$1} = $1;
- }
- $table;
- } } } @tables;
-
- $tablemap{'CreatedBy'} = 'User';
- $tablemap{'UpdatedBy'} = 'User';
-
- $typemap{'id'} = 'ro';
- $typemap{'Creator'} = 'auto';
- $typemap{'Created'} = 'auto';
- $typemap{'Updated'} = 'auto';
- $typemap{'UpdatedBy'} = 'auto';
- $typemap{'LastUpdated'} = 'auto';
- $typemap{'LastUpdatedBy'} = 'auto';
-
- $typemap{lc($_)} = $typemap{$_} for keys %typemap;
-
- foreach my $table (@tables) {
- if ($drop) {
- $dbh->do("DROP TABLE $table");
- $dbh->do("DROP sequence ${table}_id_seq") if $driver eq 'Pg';
- $dbh->do("DROP sequence ${table}_seq") if $driver eq 'Oracle';
- next;
- }
-
- my $tablesingle = $table;
- $tablesingle =~ s/^\Q$name\E_//i;
- $tablesingle =~ s/s$//;
- my $tableplural = $tablesingle . "s";
-
- if ( $tablesingle eq 'ACL' ) {
- $tablesingle = "ACE";
- $tableplural = "ACL";
- }
-
- my %requirements;
-
- my $CollectionClassName = $namespace . "::" . $tableplural;
- my $RecordClassName = $namespace . "::" . $tablesingle;
-
- my $path = $namespace;
- $path =~ s/::/\//g;
-
- my $RecordClassPath = $path . "/" . $tablesingle . ".pm";
- my $CollectionClassPath = $path . "/" . $tableplural . ".pm";
-
- #create a collection class
- my $CreateInParams;
- my $CreateOutParams;
- my $ClassAccessible = "";
- my $FieldsPod = "";
- my $CreatePod = "";
- my $CreateSub = "";
- my %fields;
- my $sth = $dbh->prepare("DESCRIBE $table");
-
- if ( $driver eq 'Pg' ) {
- $sth = $dbh->prepare(<<".");
- SELECT a.attname, format_type(a.atttypid, a.atttypmod),
- a.attnotnull, a.atthasdef, a.attnum
- FROM pg_class c, pg_attribute a
- WHERE c.relname ILIKE '$table'
- AND a.attnum > 0
- AND a.attrelid = c.oid
-ORDER BY a.attnum
-.
- }
- elsif ( $driver eq 'mysql' ) {
- $sth = $dbh->prepare("DESCRIBE $table");
- }
- else {
- die "$driver is currently unsupported";
- }
-
- $sth->execute;
-
- while ( my $row = $sth->fetchrow_hashref() ) {
- my ( $field, $type, $default );
- if ( $driver eq 'Pg' ) {
-
- $field = $row->{'attname'};
- $type = $row->{'format_type'};
- $default = $row->{'atthasdef'};
-
- if ( $default != 0 ) {
- my $tth = $dbh->prepare(<<".");
-SELECT substring(d.adsrc for 128)
- FROM pg_attrdef d, pg_class c
- WHERE c.relname = 'acct'
- AND c.oid = d.adrelid
- AND d.adnum = $row->{'attnum'}
-.
- $tth->execute();
- my @default = $tth->fetchrow_array;
- $default = $default[0];
- }
-
- }
- elsif ( $driver eq 'mysql' ) {
- $field = $row->{'Field'};
- $type = $row->{'Type'};
- $default = $row->{'Default'};
- }
-
- $fields{$field} = 1;
-
- #generate the 'accessible' datastructure
-
- if ( $typemap{$field} eq 'auto' ) {
- $ClassAccessible .= " $field =>
- {read => 1, auto => 1,";
- }
- elsif ( $typemap{$field} eq 'ro' ) {
- $ClassAccessible .= " $field =>
- {read => 1,";
- }
- else {
- $ClassAccessible .= " $field =>
- {read => 1, write => 1,";
-
- }
-
- $ClassAccessible .= " type => '$type', default => '$default'},\n";
-
- #generate pod for the accessible fields
- $FieldsPod .= $self->_pod(<<".");
-^head2 $field
-
-Returns the current value of $field.
-(In the database, $field is stored as $type.)
-
-.
-
- unless ( $typemap{$field} eq 'auto' || $typemap{$field} eq 'ro' ) {
- $FieldsPod .= $self->_pod(<<".");
-
-^head2 Set$field VALUE
-
-
-Set $field to VALUE.
-Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
-(In the database, $field will be stored as a $type.)
-
-.
- }
-
- $FieldsPod .= $self->_pod(<<".");
-^cut
-
-.
-
- if ( $modulemap{$field} ) {
- $FieldsPod .= $self->_pod(<<".");
-^head2 ${field}Obj
-
-Returns the $modulemap{$field} Object which has the id returned by $field
-
-
-^cut
-
-sub ${field}Obj {
- my \$self = shift;
- my \$$field = ${namespace}::$modulemap{$field}->new(\$self->CurrentUser);
- \$$field->Load(\$self->__Value('$field'));
- return(\$$field);
-}
-.
- $requirements{ $tablemap{$field} } =
- "use ${namespace}::$modulemap{$field};";
-
- }
-
- unless ( $typemap{$field} eq 'auto' || $field eq 'id' ) {
-
- #generate create statement
- $CreateInParams .= " $field => '$default',\n";
- $CreateOutParams .=
- " $field => \$args{'$field'},\n";
-
- #gerenate pod for the create statement
- $CreatePod .= " $type '$field'";
- $CreatePod .= " defaults to '$default'" if ($default);
- $CreatePod .= ".\n";
-
- }
-
- }
-
- $CreateSub = <<".";
-sub Create {
- my \$self = shift;
- my \%args = (
-$CreateInParams
- \@_);
- \$self->SUPER::Create(
-$CreateOutParams);
-
-}
-.
- $CreatePod .= "\n=cut\n\n";
-
- my $CollectionClass = $LicenseBlock . $Attribution . $self->_pod(<<".") . $self->_magic_import($CollectionClassName);
-
-^head1 NAME
-
-$CollectionClassName -- Class Description
-
-^head1 SYNOPSIS
-
-use $CollectionClassName
-
-^head1 DESCRIPTION
-
-
-^head1 METHODS
-
-^cut
-
-package $CollectionClassName;
-
-use $CollectionBaseclass;
-use $RecordClassName;
-
-use vars qw( \@ISA );
-\@ISA= qw($CollectionBaseclass);
-
-
-sub _Init {
- my \$self = shift;
- \$self->{'table'} = '$table';
- \$self->{'primary_key'} = 'id';
-
-.
-
- if ( $fields{'SortOrder'} ) {
-
- $CollectionClass .= $self->_pod(<<".");
-
-# By default, order by name
-\$self->OrderBy( ALIAS => 'main',
- FIELD => 'SortOrder',
- ORDER => 'ASC');
-.
- }
- $CollectionClass .= $self->_pod(<<".");
- return ( \$self->SUPER::_Init(\@_) );
-}
-
-
-^head2 NewItem
-
-Returns an empty new $RecordClassName item
-
-^cut
-
-sub NewItem {
- my \$self = shift;
- return($RecordClassName->new(\$self->CurrentUser));
-}
-.
-
- my $RecordClassHeader = $Attribution . "
-
-^head1 NAME
-
-$RecordClassName
-
-
-^head1 SYNOPSIS
-
-^head1 DESCRIPTION
-
-^head1 METHODS
-
-^cut
-
-package $RecordClassName;
-use $RecordBaseclass;
-";
-
- foreach my $key ( keys %requirements ) {
- $RecordClassHeader .= $requirements{$key} . "\n";
- }
- $RecordClassHeader .= <<".";
-
-use vars qw( \@ISA );
-\@ISA= qw( $RecordBaseclass );
-
-sub _Init {
-my \$self = shift;
-
-\$self->Table('$table');
-\$self->SUPER::_Init(\@_);
-}
-
-.
-
- my $RecordClass = $LicenseBlock . $RecordClassHeader . $self->_pod(<<".") . $self->_magic_import($RecordClassName);
-
-$RecordInit
-
-^head2 Create PARAMHASH
-
-Create takes a hash of values and creates a row in the database:
-
-$CreatePod
-
-$CreateSub
-
-$FieldsPod
-
-sub _CoreAccessible {
- {
-
-$ClassAccessible
-}
-};
-
-.
-
- print "About to make $RecordClassPath, $CollectionClassPath\n";
- `mkdir -p $path`;
-
- open( RECORD, ">$RecordClassPath" );
- print RECORD $RecordClass;
- close(RECORD);
-
- open( COL, ">$CollectionClassPath" );
- print COL $CollectionClass;
- close(COL);
-
- }
-}
-
-sub _magic_import {
- my $self = shift;
- my $class = ref($self) || $self;
-
- #if (exists \$warnings::{unimport}) {
- # no warnings qw(redefine);
-
- my $path = $class;
- $path =~ s#::#/#gi;
-
-
- my $content = $self->_pod(<<".");
- eval \"require ${class}_Overlay\";
- if (\$@ && \$@ !~ qr{^Can't locate ${path}_Overlay.pm}) {
- die \$@;
- };
-
- eval \"require ${class}_Vendor\";
- if (\$@ && \$@ !~ qr{^Can't locate ${path}_Vendor.pm}) {
- die \$@;
- };
-
- eval \"require ${class}_Local\";
- if (\$@ && \$@ !~ qr{^Can't locate ${path}_Local.pm}) {
- die \$@;
- };
-
-
-
-
-^head1 SEE ALSO
-
-This class allows \"overlay\" methods to be placed
-into the following files _Overlay is for a System overlay by the original author,
-_Vendor is for 3rd-party vendor add-ons, while _Local is for site-local customizations.
-
-These overlay files can contain new subs or subs to replace existing subs in this module.
-
-If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
-
- no warnings qw(redefine);
-
-so that perl does not kick and scream when you redefine a subroutine or variable in your overlay.
-
-${class}_Overlay, ${class}_Vendor, ${class}_Local
-
-^cut
-
-
1;
-.
-
- return $content;
-}
-
-sub _pod {
- my ($self, $text) = @_;
- $text =~ s/^\^/=/mg;
- return $text;
-}
commit 0aabd9145044d308c08d08a52e492cdff86a0bf0
Author: Thomas Sibley <trs at bestpractical.com>
Date: Thu Oct 4 13:03:13 2012 -0700
Bump version
diff --git a/META.yml b/META.yml
index 12c5e46..854fca1 100644
--- a/META.yml
+++ b/META.yml
@@ -22,4 +22,4 @@ no_index:
- t
resources:
license: http://opensource.org/licenses/gpl-license.php
-version: 0.03
+version: 0.04
diff --git a/lib/RT/Extension/Announce.pm b/lib/RT/Extension/Announce.pm
index 5320f14..287b0fe 100644
--- a/lib/RT/Extension/Announce.pm
+++ b/lib/RT/Extension/Announce.pm
@@ -2,7 +2,7 @@ use strict;
use warnings;
package RT::Extension::Announce;
-our $VERSION = '0.03';
+our $VERSION = '0.04';
RT->AddJavaScript('announce.js');
RT->AddStyleSheets('announce.css');
commit 2519fdf557c51f9e35197ce1c7b96a5daaa28f77
Author: Thomas Sibley <trs at bestpractical.com>
Date: Fri Oct 5 12:20:55 2012 -0700
Avoid false negatives on group matching because of case
If we loaded the group by the name, then it's the right group.
Comparing with eq is unnecessary and asking for problems with case.
diff --git a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
index 96921ee..ce8cec9 100644
--- a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
+++ b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
@@ -140,7 +140,7 @@ while( my $ticket = $tickets->Next ){
my $group_obj = RT::Group->new(RT->SystemUser);
$group_obj->LoadUserDefinedGroup($group_name);
- unless( $group_obj->Id && $group_obj->Name eq $group_name ){
+ unless ($group_obj->Id) {
$RT::Logger->error("Cannot find group '$group_name' for announcement #$tid (for $who)");
next;
}
commit 638cc6fff81de10b190be87523db37f129cd1ef2
Author: Jim Brandt <jbrandt at bestpractical.com>
Date: Fri Oct 5 16:59:20 2012 -0400
Check ShowTicket on every announce ticket
diff --git a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
index ce8cec9..53bebc2 100644
--- a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
+++ b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
@@ -51,7 +51,7 @@
%my $rows = 1;
%foreach my $ticket ( @tickets ){
<tr><td class="announce_subject">
-% if( $show_ticket_links ){
+% if( $show_ticket_links{$ticket->Id} ){
<a class="announce_subject"
href="<% RT->Config->Get('WebPath') %>/Ticket/Display.html?id=<% $ticket->Id %>">
<% $ticket->Subject %></a>
@@ -78,7 +78,7 @@
}
</%perl>
<% $content %>
-%if( $show_ticket_links){
+%if( $show_ticket_links{$ticket->Id} ){
(<a class="announcements_detail" href="<% RT->Config->Get('WebPath') %>/Ticket/Display.html?id=<% $ticket->Id %>">more</a>)
%}
</td></tr>
@@ -163,14 +163,17 @@ while( my $ticket = $tickets->Next ){
return if @tickets == 0;
# Don't show links if users can't view the announce tickets.
-my $show_ticket_links = $tickets[0]->HasRight(
- Right => 'ShowTicket',
- Principal => $session{'CurrentUser'} );
-
-unless( $show_ticket_links ){
- $RT::Logger->debug("User $who does not have "
- . "the ShowTicket right on the $AnnounceQueue queue and will not see links to "
- . 'announcement tickets.');
+my %show_ticket_links;
+foreach my $ticket ( @tickets ){
+ if ( $ticket->HasRight( Right => 'ShowTicket',
+ Principal => $session{'CurrentUser'} )){
+ $show_ticket_links{$ticket->Id} = 1;
+ }
+ else{
+ $RT::Logger->debug("User $who does not have "
+ . "the ShowTicket right for ticket " . $ticket->Id . " and will not see links to "
+ . 'this announcement ticket.');
+ }
}
</%INIT>
commit 77cd781f978f6f4d72fe9b63da717bb2de8b5671
Author: sunnavy <sunnavy at bestpractical.com>
Date: Mon Oct 22 22:24:18 2012 +0800
abstract GetAnnouncements so we can use it for mobile ui
diff --git a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
index 53bebc2..9caa044 100644
--- a/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
+++ b/html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
@@ -99,71 +99,15 @@
# Only display on Homepage
return unless ( $m->request_comp->path =~ /^\/index.html$/ );
-my $Queue = RT::Queue->new( RT->SystemUser );
-$Queue->Load($AnnounceQueue);
-unless( $Queue->Id ){
- $RT::Logger->error('RTAnnounce queue not found for Announce extension. Did you run make initdb?');
- return;
-}
-
-my @tickets;
-
-# Get announce tickets.
-my $tickets = RT::Tickets->new( RT->SystemUser );
-$tickets->OrderBy( FIELD => 'LastUpdated', ORDER => 'DESC' );
-my @statuses = $Queue->ActiveStatusArray();
- at statuses = map {s/(['\\])/\\$1/g; "Status = '$_'"} @statuses;
-my $status_query = join(' OR ', @statuses );
-$tickets->FromSQL("Queue = '$AnnounceQueue' AND ( $status_query )");
-return if $tickets->Count == 0;
-
-my $who = $session{CurrentUser}->Name;
-
-# Get groups for each ticket
-while( my $ticket = $tickets->Next ){
- my $tid = $ticket->id;
- my $groups = $ticket->CustomFieldValues('Announcement Groups');
-
- my @groups;
- while ( my $group = $groups->Next ){
- push @groups, $group->Content;
- }
-
- unless (@groups) {
- # No groups defined, everyone sees announcement
- RT->Logger->debug("Showing announcement #$tid to $who: not limited to any groups");
- push @tickets, $ticket;
- next;
- }
-
- foreach my $group_name ( @groups ){
- my $group_obj = RT::Group->new(RT->SystemUser);
- $group_obj->LoadUserDefinedGroup($group_name);
-
- unless ($group_obj->Id) {
- $RT::Logger->error("Cannot find group '$group_name' for announcement #$tid (for $who)");
- next;
- }
-
- if ( $group_obj->HasMemberRecursively($session{'CurrentUser'}->PrincipalObj) ) {
- # User can see this announcement.
- RT->Logger->debug("Showing announcement #$tid to $who: member of '$group_name'");
- push @tickets, $ticket;
- }
- else{
- $RT::Logger->debug(
- "Not showing announcement ticket #$tid to user $who "
- . "because they are not in group $group_name"
- );
- }
- }
-}
+my @tickets = RT::Extension::Announce::GetAnnouncements($session{CurrentUser});
# Current user isn't in any groups that can see tickets.
return if @tickets == 0;
# Don't show links if users can't view the announce tickets.
my %show_ticket_links;
+
+my $who = $session{CurrentUser}->Name;
foreach my $ticket ( @tickets ){
if ( $ticket->HasRight( Right => 'ShowTicket',
Principal => $session{'CurrentUser'} )){
@@ -180,5 +124,4 @@ foreach my $ticket ( @tickets ){
<%ARGS>
$ShowTickets => 2
$MaxMessageLength => 300
-$AnnounceQueue => RT->Config->Get('RTAnnounceQueue') || 'RTAnnounce'
</%ARGS>
diff --git a/lib/RT/Extension/Announce.pm b/lib/RT/Extension/Announce.pm
index 287b0fe..4a3fa4e 100644
--- a/lib/RT/Extension/Announce.pm
+++ b/lib/RT/Extension/Announce.pm
@@ -7,6 +7,83 @@ our $VERSION = '0.04';
RT->AddJavaScript('announce.js');
RT->AddStyleSheets('announce.css');
+sub GetAnnouncements {
+ my $current_user = shift;
+
+ my $AnnounceQueue = RT->Config->Get('RTAnnounceQueue') || 'RTAnnounce';
+ my $Queue = RT::Queue->new( RT->SystemUser );
+ $Queue->Load($AnnounceQueue);
+ unless ( $Queue->Id ) {
+ $RT::Logger->error(
+'RTAnnounce queue not found for Announce extension. Did you run make initdb?'
+ );
+ return;
+ }
+
+ my @tickets;
+
+ # Get announce tickets.
+ my $tickets = RT::Tickets->new( RT->SystemUser );
+ $tickets->OrderBy( FIELD => 'LastUpdated', ORDER => 'DESC' );
+ my @statuses = $Queue->ActiveStatusArray();
+ @statuses = map { s/(['\\])/\\$1/g; "Status = '$_'" } @statuses;
+ my $status_query = join( ' OR ', @statuses );
+ $tickets->FromSQL("Queue = '$AnnounceQueue' AND ( $status_query )");
+ return if $tickets->Count == 0;
+
+ my $who = $current_user->Name;
+
+ # Get groups for each ticket
+ while ( my $ticket = $tickets->Next ) {
+ my $tid = $ticket->id;
+ my $groups = $ticket->CustomFieldValues('Announcement Groups');
+
+ my @groups;
+ while ( my $group = $groups->Next ) {
+ push @groups, $group->Content;
+ }
+
+ unless (@groups) {
+
+ # No groups defined, everyone sees announcement
+ RT->Logger->debug(
+ "Showing announcement #$tid to $who: not limited to any groups"
+ );
+ push @tickets, $ticket;
+ next;
+ }
+
+ foreach my $group_name (@groups) {
+ my $group_obj = RT::Group->new( RT->SystemUser );
+ $group_obj->LoadUserDefinedGroup($group_name);
+
+ unless ( $group_obj->Id ) {
+ $RT::Logger->error(
+"Cannot find group '$group_name' for announcement #$tid (for $who)"
+ );
+ next;
+ }
+
+ if ( $group_obj->HasMemberRecursively( $current_user->PrincipalObj )
+ )
+ {
+ # User can see this announcement.
+ RT->Logger->debug(
+"Showing announcement #$tid to $who: member of '$group_name'"
+ );
+ push @tickets, $ticket;
+ }
+ else {
+ $RT::Logger->debug(
+ "Not showing announcement ticket #$tid to user $who "
+ . "because they are not in group $group_name" );
+ }
+ }
+ }
+ return @tickets;
+}
+
+
=head1 NAME
RT-Extension-Announce - Display announcements as a banner on RT pages.
commit bff8046ddbef0b525eb8994bcf82cb979ec018f3
Author: sunnavy <sunnavy at bestpractical.com>
Date: Mon Oct 22 23:01:43 2012 +0800
announcements for mobile ui
diff --git a/html/Callbacks/RT-Extension-Announce/m/_elements/menu/MassageMenu b/html/Callbacks/RT-Extension-Announce/m/_elements/menu/MassageMenu
new file mode 100644
index 0000000..bada968
--- /dev/null
+++ b/html/Callbacks/RT-Extension-Announce/m/_elements/menu/MassageMenu
@@ -0,0 +1,6 @@
+<%init>
+my @tickets = RT::Extension::Announce::GetAnnouncements($session{CurrentUser});
+return unless @tickets;
+unshift @{$ARGS{Menu}}, { label => loc("Announcements"), url => '/m/announcements', };
+</%init>
+
diff --git a/html/m/announcements b/html/m/announcements
new file mode 100644
index 0000000..5af2581
--- /dev/null
+++ b/html/m/announcements
@@ -0,0 +1,110 @@
+%# BEGIN BPS TAGGED BLOCK {{{
+%#
+%# COPYRIGHT:
+%#
+%# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC
+%# <sales at bestpractical.com>
+%#
+%# (Except where explicitly superseded by other copyright notices)
+%#
+%#
+%# LICENSE:
+%#
+%# This work is made available to you under the terms of Version 2 of
+%# the GNU General Public License. A copy of that license should have
+%# been provided with this software, but in any event can be snarfed
+%# from www.gnu.org.
+%#
+%# This work is distributed in the hope that it will be useful, but
+%# WITHOUT ANY WARRANTY; without even the implied warranty of
+%# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+%# General Public License for more details.
+%#
+%# You should have received a copy of the GNU General Public License
+%# along with this program; if not, write to the Free Software
+%# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+%# 02110-1301 or visit their web page on the internet at
+%# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
+%#
+%#
+%# CONTRIBUTION SUBMISSION POLICY:
+%#
+%# (The following paragraph is not intended to limit the rights granted
+%# to you to modify and distribute this software under the terms of
+%# the GNU General Public License and is only of importance to you if
+%# you choose to contribute your changes and enhancements to the
+%# community by submitting them to Best Practical Solutions, LLC.)
+%#
+%# By intentionally submitting any modifications, corrections or
+%# derivatives to this work, or any other work intended for use with
+%# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+%# you are the copyright holder for those contributions and you grant
+%# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+%# royalty-free, perpetual, license to use, copy, create derivative
+%# works based on those contributions, and sublicense and distribute
+%# those contributions and any derivatives thereof.
+%#
+%# END BPS TAGGED BLOCK }}}
+
+<&| _elements/wrapper, title => loc("Found [quant,_1,announcement]", scalar @tickets)&>
+<&|/Widgets/TitleBox, class => 'search' &>
+<ul class="ticketlist">
+% for my $ticket ( @tickets ) {
+<li class="ticket">
+% if ( $show_ticket_links{$ticket->id} ) {
+<a class="ticket" href="<%RT->Config->Get('WebPath')%>/m/ticket/show?id=<%$ticket->id%>"><%$ticket->Subject%></a>
+% } else {
+<%$ticket->Subject%>
+% }
+<div class="meta">
+<%perl>
+ my $txns = $ticket->Transactions;
+ for my $type ( qw(Create Correspond) ){
+ $txns->Limit( FIELD => 'Type', VALUE => $type );
+ }
+ $txns->OrderBy( FIELD => 'Created', ORDER => 'DESC' );
+ $txns->RowsPerPage(1);
+ my $content_obj = $txns->First->ContentObj;
+ my $content = $content_obj->Content;
+ if( length $content > $MaxMessageLength ){
+ $content = substr($content, 0, $MaxMessageLength);
+ # Try to break at a word boundary.
+ $content =~ s/^(.*)\b\w+$/$1/g;
+ $content =~ s/\s+$//g; # Remove trailing space
+ $content .= chr(8230); # Ellipsis character
+ }
+</%perl>
+<%$content%>
+</div>
+</li>
+% }
+</ul>
+</&>
+</&>
+
+<%init>
+my @tickets = RT::Extension::Announce::GetAnnouncements($session{CurrentUser});
+return if @tickets == 0;
+
+# Don't show links if users can't view the announce tickets.
+my %show_ticket_links;
+
+my $who = $session{CurrentUser}->Name;
+foreach my $ticket ( @tickets ){
+ if ( $ticket->HasRight( Right => 'ShowTicket',
+ Principal => $session{'CurrentUser'} )){
+ $show_ticket_links{$ticket->Id} = 1;
+ }
+ else{
+ $RT::Logger->debug("User $who does not have "
+ . "the ShowTicket right for ticket " . $ticket->Id . " and will not
+see links to "
+ . 'this announcement ticket.');
+ }
+}
+
+</%init>
+
+<%args>
+$MaxMessageLength => 300
+</%args>
commit 6b17b337d508910d6c6cad9f7cfebdf8c4b11450
Author: sunnavy <sunnavy at bestpractical.com>
Date: Tue Oct 30 22:41:10 2012 +0800
mobile ui tweak: to make link left-justified with content
diff --git a/html/m/announcements b/html/m/announcements
index 5af2581..c03ab7b 100644
--- a/html/m/announcements
+++ b/html/m/announcements
@@ -52,7 +52,7 @@
% for my $ticket ( @tickets ) {
<li class="ticket">
% if ( $show_ticket_links{$ticket->id} ) {
-<a class="ticket" href="<%RT->Config->Get('WebPath')%>/m/ticket/show?id=<%$ticket->id%>"><%$ticket->Subject%></a>
+<a href="<%RT->Config->Get('WebPath')%>/m/ticket/show?id=<%$ticket->id%>"><%$ticket->Subject%></a>
% } else {
<%$ticket->Subject%>
% }
commit a2be0de49fd388b787dc93b7cf06ed8775fab355
Author: sunnavy <sunnavy at bestpractical.com>
Date: Wed Oct 31 11:13:28 2012 +0800
colorize for mobile ui
diff --git a/html/Callbacks/RT-Extension-Announce/m/_elements/menu/MassageMenu b/html/Callbacks/RT-Extension-Announce/m/_elements/menu/MassageMenu
index bada968..43041de 100644
--- a/html/Callbacks/RT-Extension-Announce/m/_elements/menu/MassageMenu
+++ b/html/Callbacks/RT-Extension-Announce/m/_elements/menu/MassageMenu
@@ -1,6 +1,12 @@
+<link rel="stylesheet" href="<%RT->Config->Get('WebPath')%>/NoAuth/css/announce.css" type="text/css" />
<%init>
my @tickets = RT::Extension::Announce::GetAnnouncements($session{CurrentUser});
return unless @tickets;
-unshift @{$ARGS{Menu}}, { label => loc("Announcements"), url => '/m/announcements', };
+unshift @{ $ARGS{Menu} },
+ { html => q{<a class="announce" href="}
+ . RT->Config->Get('WebPath')
+ . q{/m/announcements">}
+ . loc("Announcements")
+ . '</a>' };
</%init>
diff --git a/html/NoAuth/css/announce.css b/html/NoAuth/css/announce.css
index 9081d6f..eeba072 100644
--- a/html/NoAuth/css/announce.css
+++ b/html/NoAuth/css/announce.css
@@ -56,7 +56,7 @@ td.announce_subject {
font-weight: bold;
}
-a.announce_subject:link {
+a.announce_subject:link, span.announce_subject {
color: red;
font-weight: bold;
}
@@ -65,3 +65,15 @@ a.announce_subject:visited {
color: red;
font-weight: bold;
}
+
+ul.menu li:first-child {
+ background-color: #fcc;
+ margin-top: -1em;
+ padding-top: 1.4em; /* to fill the background for parent margin-top */
+ border-top-left-radius: 1em;
+ border-top-right-radius: 1em;
+}
+
+ul.menu a.announce {
+ background-color: #fcc;
+}
diff --git a/html/m/announcements b/html/m/announcements
index c03ab7b..0fdcbf8 100644
--- a/html/m/announcements
+++ b/html/m/announcements
@@ -45,16 +45,16 @@
%# those contributions and any derivatives thereof.
%#
%# END BPS TAGGED BLOCK }}}
-
+<link rel="stylesheet" href="<%RT->Config->Get('WebPath')%>/NoAuth/css/announce.css" type="text/css" />
<&| _elements/wrapper, title => loc("Found [quant,_1,announcement]", scalar @tickets)&>
<&|/Widgets/TitleBox, class => 'search' &>
-<ul class="ticketlist">
+<ul class="ticketlist announce">
% for my $ticket ( @tickets ) {
<li class="ticket">
% if ( $show_ticket_links{$ticket->id} ) {
-<a href="<%RT->Config->Get('WebPath')%>/m/ticket/show?id=<%$ticket->id%>"><%$ticket->Subject%></a>
+<a class="announce_subject" href="<%RT->Config->Get('WebPath')%>/m/ticket/show?id=<%$ticket->id%>"><%$ticket->Subject%></a>
% } else {
-<%$ticket->Subject%>
+<span class="announce_subject"><%$ticket->Subject%></span>
% }
<div class="meta">
<%perl>
commit 20a61f04c2faca3499c2d551b82dfea01b86cebb
Author: Jim Brandt <jbrandt at bestpractical.com>
Date: Wed Oct 31 11:02:15 2012 -0400
Set version to 0.05 for new mobile interface release.
diff --git a/MANIFEST b/MANIFEST
index 07df030..4155180 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,5 +1,7 @@
etc/initialdata
html/Callbacks/RT-Extension-Announce/Elements/PageLayout/BeforeBody
+html/Callbacks/RT-Extension-Announce/m/_elements/menu/MassageMenu
+html/m/announcements
html/NoAuth/css/announce.css
html/NoAuth/js/announce.js
inc/Module/Install.pm
diff --git a/META.yml b/META.yml
index 854fca1..bf1006b 100644
--- a/META.yml
+++ b/META.yml
@@ -22,4 +22,4 @@ no_index:
- t
resources:
license: http://opensource.org/licenses/gpl-license.php
-version: 0.04
+version: 0.05
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
index 2eba7ad..73b9cda 100644
--- a/inc/Module/Install/RTx.pm
+++ b/inc/Module/Install/RTx.pm
@@ -8,7 +8,7 @@ no warnings 'once';
use Module::Install::Base;
use base 'Module::Install::Base';
-our $VERSION = '0.29_02';
+our $VERSION = '0.29';
use FindBin;
use File::Glob ();
@@ -129,7 +129,18 @@ install ::
my %has_etc;
if ( File::Glob::bsd_glob("$FindBin::Bin/etc/schema.*") ) {
+
+ # got schema, load factory module
$has_etc{schema}++;
+ $self->load('RTxFactory');
+ $self->postamble(<< ".");
+factory ::
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxFactory(qw($RTx $name))"
+
+dropdb ::
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxFactory(qw($RTx $name drop))"
+
+.
}
if ( File::Glob::bsd_glob("$FindBin::Bin/etc/acl.*") ) {
$has_etc{acl}++;
@@ -153,19 +164,28 @@ install ::
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)))"
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(schema))"
.
$initdb .= <<"." if $has_etc{acl};
-\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(acl \$(NAME) \$(VERSION)))"
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(acl))"
.
$initdb .= <<"." if $has_etc{initialdata};
-\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(insert \$(NAME) \$(VERSION)))"
+\t\$(NOECHO) \$(PERL) -Ilib -I"$local_lib_path" -I"$lib_path" -Minc::Module::Install -e"RTxInitDB(qw(insert))"
.
$self->postamble("initdb ::\n$initdb\n");
$self->postamble("initialize-database ::\n$initdb\n");
}
}
+sub RTxInit {
+ unshift @INC, substr( delete( $INC{'RT.pm'} ), 0, -5 ) if $INC{'RT.pm'};
+ require RT;
+ RT::LoadConfig();
+ RT::ConnectToDatabase();
+
+ die "Cannot load RT" unless $RT::Handle and $RT::DatabaseType;
+}
+
# stolen from RT::Handle so we work on 3.6 (cmp_versions came in with 3.8)
{ my %word = (
a => -4,
@@ -208,4 +228,4 @@ sub requires_rt {
__END__
-#line 328
+#line 348
diff --git a/inc/Module/Install/RTx/Factory.pm b/inc/Module/Install/RTx/Factory.pm
index a8702e4..23ce911 100644
--- a/inc/Module/Install/RTx/Factory.pm
+++ b/inc/Module/Install/RTx/Factory.pm
@@ -6,7 +6,7 @@ use strict;
use File::Basename ();
sub RTxInitDB {
- my ($self, $action, $name, $version) = @_;
+ my ($self, $action) = @_;
unshift @INC, substr(delete($INC{'RT.pm'}), 0, -5) if $INC{'RT.pm'};
@@ -23,8 +23,6 @@ sub RTxInitDB {
RT::LoadConfig();
- require RT::System;
-
my $lib_path = File::Basename::dirname($INC{'RT.pm'});
my @args = ("-Ilib");
push @args, "-I$RT::LocalPath/lib" if $RT::LocalPath;
@@ -35,12 +33,451 @@ sub RTxInitDB {
"--datadir" => "etc",
(($action eq 'insert') ? ("--datafile" => "etc/initialdata") : ()),
"--dba" => $RT::DatabaseUser,
- "--prompt-for-dba-password" => '',
- (RT::System->can('AddUpgradeHistory') ? ("--package" => $name, "--ext-version" => $version) : ()),
+ "--prompt-for-dba-password" => ''
);
-
print "$^X @args\n";
(system($^X, @args) == 0) or die "...returned with error: $?\n";
}
+sub RTxFactory {
+ my ($self, $RTx, $name, $drop) = @_;
+ my $namespace = "$RTx\::$name";
+
+ $self->RTxInit;
+
+ my $dbh = $RT::Handle->dbh;
+ # get all tables out of database
+ my @tables = $dbh->tables;
+ my ( %tablemap, %typemap, %modulemap );
+ my $driver = $RT::DatabaseType;
+
+ my $CollectionBaseclass = 'RT::SearchBuilder';
+ my $RecordBaseclass = 'RT::Record';
+ my $LicenseBlock = << '.';
+# BEGIN LICENSE BLOCK
+#
+# END LICENSE BLOCK
+.
+ my $Attribution = << '.';
+# Autogenerated by Module::Intall::RTx::Factory
+# WARNING: THIS FILE IS AUTOGENERATED. ALL CHANGES TO THIS FILE WILL BE LOST.
+#
+# !! DO NOT EDIT THIS FILE !!
+#
+
+use strict;
+.
+ my $RecordInit = '';
+
+ @tables = map { do { {
+ my $table = $_;
+ $table =~ s/.*\.//g;
+ $table =~ s/\W//g;
+ $table =~ s/^\Q$name\E_//i or next;
+ $table ne 'sessions' or next;
+
+ $table = ucfirst(lc($table));
+ $table =~ s/$_/\u$_/ for qw(field group custom member value);
+ $table =~ s/(?<=Scrip)$_/\u$_/ for qw(action condition);
+ $table =~ s/$_/\U$_/ for qw(Acl);
+ $table = $name . '_' . $table;
+
+ $tablemap{$table} = $table;
+ $modulemap{$table} = $table;
+ if ( $table =~ /^(.*)s$/ ) {
+ $tablemap{$1} = $table;
+ $modulemap{$1} = $1;
+ }
+ $table;
+ } } } @tables;
+
+ $tablemap{'CreatedBy'} = 'User';
+ $tablemap{'UpdatedBy'} = 'User';
+
+ $typemap{'id'} = 'ro';
+ $typemap{'Creator'} = 'auto';
+ $typemap{'Created'} = 'auto';
+ $typemap{'Updated'} = 'auto';
+ $typemap{'UpdatedBy'} = 'auto';
+ $typemap{'LastUpdated'} = 'auto';
+ $typemap{'LastUpdatedBy'} = 'auto';
+
+ $typemap{lc($_)} = $typemap{$_} for keys %typemap;
+
+ foreach my $table (@tables) {
+ if ($drop) {
+ $dbh->do("DROP TABLE $table");
+ $dbh->do("DROP sequence ${table}_id_seq") if $driver eq 'Pg';
+ $dbh->do("DROP sequence ${table}_seq") if $driver eq 'Oracle';
+ next;
+ }
+
+ my $tablesingle = $table;
+ $tablesingle =~ s/^\Q$name\E_//i;
+ $tablesingle =~ s/s$//;
+ my $tableplural = $tablesingle . "s";
+
+ if ( $tablesingle eq 'ACL' ) {
+ $tablesingle = "ACE";
+ $tableplural = "ACL";
+ }
+
+ my %requirements;
+
+ my $CollectionClassName = $namespace . "::" . $tableplural;
+ my $RecordClassName = $namespace . "::" . $tablesingle;
+
+ my $path = $namespace;
+ $path =~ s/::/\//g;
+
+ my $RecordClassPath = $path . "/" . $tablesingle . ".pm";
+ my $CollectionClassPath = $path . "/" . $tableplural . ".pm";
+
+ #create a collection class
+ my $CreateInParams;
+ my $CreateOutParams;
+ my $ClassAccessible = "";
+ my $FieldsPod = "";
+ my $CreatePod = "";
+ my $CreateSub = "";
+ my %fields;
+ my $sth = $dbh->prepare("DESCRIBE $table");
+
+ if ( $driver eq 'Pg' ) {
+ $sth = $dbh->prepare(<<".");
+ SELECT a.attname, format_type(a.atttypid, a.atttypmod),
+ a.attnotnull, a.atthasdef, a.attnum
+ FROM pg_class c, pg_attribute a
+ WHERE c.relname ILIKE '$table'
+ AND a.attnum > 0
+ AND a.attrelid = c.oid
+ORDER BY a.attnum
+.
+ }
+ elsif ( $driver eq 'mysql' ) {
+ $sth = $dbh->prepare("DESCRIBE $table");
+ }
+ else {
+ die "$driver is currently unsupported";
+ }
+
+ $sth->execute;
+
+ while ( my $row = $sth->fetchrow_hashref() ) {
+ my ( $field, $type, $default );
+ if ( $driver eq 'Pg' ) {
+
+ $field = $row->{'attname'};
+ $type = $row->{'format_type'};
+ $default = $row->{'atthasdef'};
+
+ if ( $default != 0 ) {
+ my $tth = $dbh->prepare(<<".");
+SELECT substring(d.adsrc for 128)
+ FROM pg_attrdef d, pg_class c
+ WHERE c.relname = 'acct'
+ AND c.oid = d.adrelid
+ AND d.adnum = $row->{'attnum'}
+.
+ $tth->execute();
+ my @default = $tth->fetchrow_array;
+ $default = $default[0];
+ }
+
+ }
+ elsif ( $driver eq 'mysql' ) {
+ $field = $row->{'Field'};
+ $type = $row->{'Type'};
+ $default = $row->{'Default'};
+ }
+
+ $fields{$field} = 1;
+
+ #generate the 'accessible' datastructure
+
+ if ( $typemap{$field} eq 'auto' ) {
+ $ClassAccessible .= " $field =>
+ {read => 1, auto => 1,";
+ }
+ elsif ( $typemap{$field} eq 'ro' ) {
+ $ClassAccessible .= " $field =>
+ {read => 1,";
+ }
+ else {
+ $ClassAccessible .= " $field =>
+ {read => 1, write => 1,";
+
+ }
+
+ $ClassAccessible .= " type => '$type', default => '$default'},\n";
+
+ #generate pod for the accessible fields
+ $FieldsPod .= $self->_pod(<<".");
+^head2 $field
+
+Returns the current value of $field.
+(In the database, $field is stored as $type.)
+
+.
+
+ unless ( $typemap{$field} eq 'auto' || $typemap{$field} eq 'ro' ) {
+ $FieldsPod .= $self->_pod(<<".");
+
+^head2 Set$field VALUE
+
+
+Set $field to VALUE.
+Returns (1, 'Status message') on success and (0, 'Error Message') on failure.
+(In the database, $field will be stored as a $type.)
+
+.
+ }
+
+ $FieldsPod .= $self->_pod(<<".");
+^cut
+
+.
+
+ if ( $modulemap{$field} ) {
+ $FieldsPod .= $self->_pod(<<".");
+^head2 ${field}Obj
+
+Returns the $modulemap{$field} Object which has the id returned by $field
+
+
+^cut
+
+sub ${field}Obj {
+ my \$self = shift;
+ my \$$field = ${namespace}::$modulemap{$field}->new(\$self->CurrentUser);
+ \$$field->Load(\$self->__Value('$field'));
+ return(\$$field);
+}
+.
+ $requirements{ $tablemap{$field} } =
+ "use ${namespace}::$modulemap{$field};";
+
+ }
+
+ unless ( $typemap{$field} eq 'auto' || $field eq 'id' ) {
+
+ #generate create statement
+ $CreateInParams .= " $field => '$default',\n";
+ $CreateOutParams .=
+ " $field => \$args{'$field'},\n";
+
+ #gerenate pod for the create statement
+ $CreatePod .= " $type '$field'";
+ $CreatePod .= " defaults to '$default'" if ($default);
+ $CreatePod .= ".\n";
+
+ }
+
+ }
+
+ $CreateSub = <<".";
+sub Create {
+ my \$self = shift;
+ my \%args = (
+$CreateInParams
+ \@_);
+ \$self->SUPER::Create(
+$CreateOutParams);
+
+}
+.
+ $CreatePod .= "\n=cut\n\n";
+
+ my $CollectionClass = $LicenseBlock . $Attribution . $self->_pod(<<".") . $self->_magic_import($CollectionClassName);
+
+^head1 NAME
+
+$CollectionClassName -- Class Description
+
+^head1 SYNOPSIS
+
+use $CollectionClassName
+
+^head1 DESCRIPTION
+
+
+^head1 METHODS
+
+^cut
+
+package $CollectionClassName;
+
+use $CollectionBaseclass;
+use $RecordClassName;
+
+use vars qw( \@ISA );
+\@ISA= qw($CollectionBaseclass);
+
+
+sub _Init {
+ my \$self = shift;
+ \$self->{'table'} = '$table';
+ \$self->{'primary_key'} = 'id';
+
+.
+
+ if ( $fields{'SortOrder'} ) {
+
+ $CollectionClass .= $self->_pod(<<".");
+
+# By default, order by name
+\$self->OrderBy( ALIAS => 'main',
+ FIELD => 'SortOrder',
+ ORDER => 'ASC');
+.
+ }
+ $CollectionClass .= $self->_pod(<<".");
+ return ( \$self->SUPER::_Init(\@_) );
+}
+
+
+^head2 NewItem
+
+Returns an empty new $RecordClassName item
+
+^cut
+
+sub NewItem {
+ my \$self = shift;
+ return($RecordClassName->new(\$self->CurrentUser));
+}
+.
+
+ my $RecordClassHeader = $Attribution . "
+
+^head1 NAME
+
+$RecordClassName
+
+
+^head1 SYNOPSIS
+
+^head1 DESCRIPTION
+
+^head1 METHODS
+
+^cut
+
+package $RecordClassName;
+use $RecordBaseclass;
+";
+
+ foreach my $key ( keys %requirements ) {
+ $RecordClassHeader .= $requirements{$key} . "\n";
+ }
+ $RecordClassHeader .= <<".";
+
+use vars qw( \@ISA );
+\@ISA= qw( $RecordBaseclass );
+
+sub _Init {
+my \$self = shift;
+
+\$self->Table('$table');
+\$self->SUPER::_Init(\@_);
+}
+
+.
+
+ my $RecordClass = $LicenseBlock . $RecordClassHeader . $self->_pod(<<".") . $self->_magic_import($RecordClassName);
+
+$RecordInit
+
+^head2 Create PARAMHASH
+
+Create takes a hash of values and creates a row in the database:
+
+$CreatePod
+
+$CreateSub
+
+$FieldsPod
+
+sub _CoreAccessible {
+ {
+
+$ClassAccessible
+}
+};
+
+.
+
+ print "About to make $RecordClassPath, $CollectionClassPath\n";
+ `mkdir -p $path`;
+
+ open( RECORD, ">$RecordClassPath" );
+ print RECORD $RecordClass;
+ close(RECORD);
+
+ open( COL, ">$CollectionClassPath" );
+ print COL $CollectionClass;
+ close(COL);
+
+ }
+}
+
+sub _magic_import {
+ my $self = shift;
+ my $class = ref($self) || $self;
+
+ #if (exists \$warnings::{unimport}) {
+ # no warnings qw(redefine);
+
+ my $path = $class;
+ $path =~ s#::#/#gi;
+
+
+ my $content = $self->_pod(<<".");
+ eval \"require ${class}_Overlay\";
+ if (\$@ && \$@ !~ qr{^Can't locate ${path}_Overlay.pm}) {
+ die \$@;
+ };
+
+ eval \"require ${class}_Vendor\";
+ if (\$@ && \$@ !~ qr{^Can't locate ${path}_Vendor.pm}) {
+ die \$@;
+ };
+
+ eval \"require ${class}_Local\";
+ if (\$@ && \$@ !~ qr{^Can't locate ${path}_Local.pm}) {
+ die \$@;
+ };
+
+
+
+
+^head1 SEE ALSO
+
+This class allows \"overlay\" methods to be placed
+into the following files _Overlay is for a System overlay by the original author,
+_Vendor is for 3rd-party vendor add-ons, while _Local is for site-local customizations.
+
+These overlay files can contain new subs or subs to replace existing subs in this module.
+
+If you'll be working with perl 5.6.0 or greater, each of these files should begin with the line
+
+ no warnings qw(redefine);
+
+so that perl does not kick and scream when you redefine a subroutine or variable in your overlay.
+
+${class}_Overlay, ${class}_Vendor, ${class}_Local
+
+^cut
+
+
1;
+.
+
+ return $content;
+}
+
+sub _pod {
+ my ($self, $text) = @_;
+ $text =~ s/^\^/=/mg;
+ return $text;
+}
diff --git a/lib/RT/Extension/Announce.pm b/lib/RT/Extension/Announce.pm
index 4a3fa4e..7841bcd 100644
--- a/lib/RT/Extension/Announce.pm
+++ b/lib/RT/Extension/Announce.pm
@@ -2,7 +2,7 @@ use strict;
use warnings;
package RT::Extension::Announce;
-our $VERSION = '0.04';
+our $VERSION = '0.05';
RT->AddJavaScript('announce.js');
RT->AddStyleSheets('announce.css');
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list