[Bps-public-commit] RT-Extension-Captcha branch, master, updated. 5af5b4c4e9e0e5c242e5f1da6b2d37362232f01b
Ruslan Zakirov
ruz at bestpractical.com
Mon Mar 29 15:01:58 EDT 2010
The branch, master has been updated
discards e7699ecd6b273a039279fecdeb63e8c46f095e38 (commit)
via 5af5b4c4e9e0e5c242e5f1da6b2d37362232f01b (commit)
via c3d0cd94a86ac8e369cc0c681306d83a904e4f29 (commit)
via 3f7d85c9446658448a21674130759654072783b7 (commit)
via d8a968a053cefbb7c6b12e45fb416aea6149916a (commit)
via 3f68f481ff7e42cb173a80162aad82d51d383284 (commit)
via 7030a8674a518cd094bb9a338473aa822aef64b8 (commit)
via fcdaf48adb51489408a2e95d868eee5f6a68f135 (commit)
via 14b24439245cd0797127f80c2410efb85bfdb91b (commit)
via 7e75e4cb6b81e61e699bfc73adb1ee868e5c0167 (commit)
This update added new revisions after undoing existing revisions. That is
to say, the old revision is not a strict subset of the new revision. This
situation occurs when you --force push a change and generate a repository
containing something like this:
* -- * -- B -- O -- O -- O (e7699ecd6b273a039279fecdeb63e8c46f095e38)
\
N -- N -- N (5af5b4c4e9e0e5c242e5f1da6b2d37362232f01b)
When this happens we assume that you've already had alert emails for all
of the O revisions, and so we here report only the revisions in the N
branch from the common base, B.
Summary of changes:
MANIFEST | 22 +
META.yml | 24 +
Makefile.PL | 16 +
README | 1 +
.../Ticket/Create.html/BeforeCreate | 33 ++
.../Ticket/Create.html/FormStart | 12 +
.../Ticket/Display.html/Initial | 54 +++
.../Ticket/Update.html/FormStart | 14 +
.../Ticket/Update.html/Initial | 28 ++
.../RT-Extension-Captcha/index.html/Initial | 32 ++
html/Elements/Captcha | 12 +
html/Helpers/Captcha | 20 +
inc/Module/Install.pm | 369 +++++++++++++++
inc/Module/Install/Base.pm | 72 +++
inc/Module/Install/Can.pm | 83 ++++
inc/Module/Install/Fetch.pm | 93 ++++
inc/Module/Install/Makefile.pm | 253 ++++++++++
inc/Module/Install/Metadata.pm | 500 ++++++++++++++++++++
inc/Module/Install/RTx.pm | 189 ++++++++
inc/Module/Install/Win32.pm | 64 +++
inc/Module/Install/WriteAll.pm | 40 ++
lib/RT/Extension/Captcha.pm | 58 +++
22 files changed, 1989 insertions(+), 0 deletions(-)
delete mode 100644 .gitignore
create mode 100644 MANIFEST
create mode 100644 META.yml
create mode 100644 Makefile.PL
create mode 100644 README
create mode 100644 html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/BeforeCreate
create mode 100644 html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/FormStart
create mode 100644 html/Callbacks/RT-Extension-Captcha/Ticket/Display.html/Initial
create mode 100644 html/Callbacks/RT-Extension-Captcha/Ticket/Update.html/FormStart
create mode 100644 html/Callbacks/RT-Extension-Captcha/Ticket/Update.html/Initial
create mode 100644 html/Callbacks/RT-Extension-Captcha/index.html/Initial
create mode 100644 html/Elements/Captcha
create mode 100644 html/Helpers/Captcha
create mode 100644 inc/Module/Install.pm
create mode 100644 inc/Module/Install/Base.pm
create mode 100644 inc/Module/Install/Can.pm
create mode 100644 inc/Module/Install/Fetch.pm
create mode 100644 inc/Module/Install/Makefile.pm
create mode 100644 inc/Module/Install/Metadata.pm
create mode 100644 inc/Module/Install/RTx.pm
create mode 100644 inc/Module/Install/Win32.pm
create mode 100644 inc/Module/Install/WriteAll.pm
create mode 100644 lib/RT/Extension/Captcha.pm
- Log -----------------------------------------------------------------
commit 7e75e4cb6b81e61e699bfc73adb1ee868e5c0167
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Aug 21 03:48:05 2008 +0000
solve a CAPTCHA on create
commit 14b24439245cd0797127f80c2410efb85bfdb91b
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Aug 21 04:05:49 2008 +0000
add libs
diff --git a/lib/RT/Extension/Captcha.pm b/lib/RT/Extension/Captcha.pm
new file mode 100644
index 0000000..829d41c
--- /dev/null
+++ b/lib/RT/Extension/Captcha.pm
@@ -0,0 +1,41 @@
+package RT::Extension::Captcha;
+
+use 5.008003;
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use GD::SecurityImage;
+
+=head1 NAME
+
+RT::Extension::Captcha - solve a CAPTCHA before some actions in RT
+
+=head1 DESCRIPTION
+
+This extension for RT 3.8.1 or newer. At this point only captcha is
+required for creating a ticket. Users who have right 'OnCaptchaOnCreate'
+will see no captchas.
+
+As GD's built in font is kinda small, we enabled ttf support and
+it's not configurable at this point. Either hack this extension
+or set an absolute path to a ttf font via 'ChartFont' option in
+the RT config.
+
+=cut
+
+use RT::Queue;
+$RT::Queue::RIGHTS->{'NoCaptchaOnCreate'} = "Don't ask user to solve a CAPTCHA on ticket create"; #loc_pair
+
+=head1 LICENSE
+
+Under the same terms as perl itself.
+
+=head1 AUTHOR
+
+Ruslan Zakirov E<lt>ruz at bestpractical.comE<gt>
+
+=cut
+
+1;
commit fcdaf48adb51489408a2e95d868eee5f6a68f135
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Aug 21 04:06:21 2008 +0000
import html
diff --git a/html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/BeforeCreate b/html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/BeforeCreate
new file mode 100644
index 0000000..8df602b
--- /dev/null
+++ b/html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/BeforeCreate
@@ -0,0 +1,33 @@
+<%ARGS>
+$ARGSRef => {}
+$checks_failure
+$skip_create
+$results => []
+</%ARGS>
+<%INIT>
+return if $$skip_create;
+return if $checks_failure;
+
+my $queue = RT::Queue->new( $session{'CurrentUser'} );
+$queue->Load( $ARGSRef->{'Queue'} );
+return unless $queue->id;
+
+return if $queue->CurrentUserHasRight('NoCaptchaOnCreate');
+
+my ($captcha) = ($ARGSRef->{'CaptchaString'});
+unless ( $captcha ) {
+ push @$results, loc("You have to solve CAPTCHA");
+ $$skip_create = 1;
+}
+elsif ( !$session{'Captcha'}{'String'} ) {
+ push @$results, loc("Don't play with me. You must solve CAPTCHA");
+ $$skip_create = 1;
+}
+elsif ( lc($captcha) ne lc $session{'Captcha'}{'String'} ) {
+ delete $session{'Captcha'};
+ push @$results, loc("Not equal. Give you another CAPTCHA");
+ $$skip_create = 1;
+}
+return;
+</%INIT>
+
diff --git a/html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/FormStart b/html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/FormStart
new file mode 100644
index 0000000..d8a7422
--- /dev/null
+++ b/html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/FormStart
@@ -0,0 +1,22 @@
+<div id="Ticket-Create-captcha">
+<a name="captcha"></a>
+
+<&| /Widgets/TitleBox, title => loc("You must solve a CAPTACHA to create a new ticket") &>
+
+<table border="0" cellpadding="0" cellspacing="0">
+<tr><td><img src="<% RT->Config->Get('WebURL') %>Helpers/Captcha" /></td>
+<td><input type="text" name="CaptchaString" /></td></tr>
+</table>
+
+</&>
+<%ARGS>
+$ARGSRef => {}
+</%ARGS>
+<%INIT>
+my $queue = RT::Queue->new( $session{'CurrentUser'} );
+$queue->Load( $ARGSRef->{'Queue'} );
+return unless $queue->id;
+
+return if $queue->CurrentUserHasRight('NoCaptchaOnCreate');
+
+</%INIT>
diff --git a/html/Callbacks/RT-Extension-Captcha/Ticket/Display.html/Initial b/html/Callbacks/RT-Extension-Captcha/Ticket/Display.html/Initial
new file mode 100644
index 0000000..b35e209
--- /dev/null
+++ b/html/Callbacks/RT-Extension-Captcha/Ticket/Display.html/Initial
@@ -0,0 +1,32 @@
+<%ARGS>
+$ARGSRef => {}
+</%ARGS>
+<%INIT>
+$RT::Logger->crit("woot");
+return unless ($ARGSRef->{'id'}||'') eq 'new';
+
+my $queue = RT::Queue->new( $session{'CurrentUser'} );
+$queue->Load( $ARGSRef->{'Queue'} );
+return unless $queue->id;
+
+return if $queue->CurrentUserHasRight('NoCaptchaOnCreate');
+
+my ($captcha) = ($ARGSRef->{'CaptchaString'});
+
+if ( !$captcha || lc($captcha) ne lc($session{'Captcha'}{'String'}||'') ) {
+ my $key = Digest::MD5::md5_hex( rand(1024) );
+ push @{ $session{"Actions"}->{ $key } ||= [] },
+ loc("You have to solve CAPTCHA");
+ $session{'i'}++;
+ RT::Interface::Web::Redirect(
+ RT->Config->Get('WebURL')
+ ."Ticket/Create.html"
+ ."?Queue=". $m->interp->apply_escapes( $ARGSRef->{'Queue'}, 'u' )
+ ."&results=". $key
+ );
+ $m->abort;
+}
+
+delete $session{'Captcha'};
+return;
+</%INIT>
diff --git a/html/Helpers/Captcha b/html/Helpers/Captcha
new file mode 100644
index 0000000..be7657f
--- /dev/null
+++ b/html/Helpers/Captcha
@@ -0,0 +1,20 @@
+<%INIT>
+my $str = $session{'Captcha'}{'String'}
+ ||= uc $session{'CurrentUser'}->GenerateRandomPassword(6, 9);
+my ($image, $type, $rnd) = GD::SecurityImage->new(
+ width => 320,
+ height => 100,
+ ptsize => 40,
+ lines => 10,
+ font => RT->Config->Get('ChartFont') || '/usr/share/fonts/corefonts/georgia.ttf',
+)->random( $str )->create( 'ttf', 'circle' )->particle->out;
+
+$session{'Captcha'}{'String'} = $str;
+
+$m->clear_buffer;
+$r->content_type( $type );
+$m->out( $image );
+$m->flush_buffer;
+$m->abort;
+
+</%INIT>
commit 7030a8674a518cd094bb9a338473aa822aef64b8
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Aug 21 04:07:03 2008 +0000
M::I things
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..23d868c
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,18 @@
+html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/BeforeCreate
+html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/FormStart
+html/Callbacks/RT-Extension-Captcha/Ticket/Display.html/Initial
+html/Helpers/Captcha
+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/RTx.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/RT/Extension/Captcha.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+README
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..7ac96d9
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,24 @@
+---
+abstract: 'solve a CAPTCHA before some actions in RT'
+author:
+ - 'Ruslan Zakirov <ruz at bestpractical.com>'
+distribution_type: module
+generated_by: 'Module::Install version 0.77'
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: RT-Extension-Captcha
+no_index:
+ directory:
+ - etc
+ - html
+ - po
+ - var
+ - inc
+requires:
+ GD::SecurityImage: 0
+ perl: 5.8.3
+resources:
+ license: http://dev.perl.org/licenses/
+version: 0.01
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..c5a8384
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,16 @@
+use inc::Module::Install;
+
+RTx 'RT-Extension-Captcha';
+all_from 'lib/RT/Extension/Captcha.pm';
+
+{ # check RT version
+ my @v = split /\./, "$RT::VERSION";
+ unless ($v[0]>=3 && $v[1]>=8 && ($v[2]>=1 || $v[2]eq'HEAD')) {
+ die "RTIR 2.4 and newer needs RT 3.8.1 at least, you have $RT::VERSION";
+ }
+}
+
+requires 'GD::SecurityImage';
+
+WriteAll();
+
diff --git a/README b/README
new file mode 100644
index 0000000..bdf5cf9
--- /dev/null
+++ b/README
@@ -0,0 +1 @@
+Read `perldoc lib/RT/Extension/Captcha.pm`
diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm
new file mode 100644
index 0000000..eb449ca
--- /dev/null
+++ b/inc/Module/Install.pm
@@ -0,0 +1,369 @@
+#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
+# }
+
+BEGIN {
+ require 5.004;
+}
+use strict 'vars';
+
+use vars qw{$VERSION};
+BEGIN {
+ # All Module::Install core packages now require synchronised versions.
+ # This will be used to ensure we don't accidentally load old or
+ # different versions of modules.
+ # This is not enforced yet, but will be some time in the next few
+ # releases once we can make sure it won't clash with custom
+ # Module::Install extensions.
+ $VERSION = '0.77';
+
+ *inc::Module::Install::VERSION = *VERSION;
+ @inc::Module::Install::ISA = __PACKAGE__;
+
+}
+
+
+
+
+
+# Whether or not inc::Module::Install is actually loaded, the
+# $INC{inc/Module/Install.pm} is what will still get set as long as
+# the caller loaded module this in the documented manner.
+# If not set, the caller may NOT have loaded the bundled version, and thus
+# they may not have a MI version that works with the Makefile.PL. This would
+# result in false errors or unexpected behaviour. And we don't want that.
+my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
+unless ( $INC{$file} ) { die <<"END_DIE" }
+
+Please invoke ${\__PACKAGE__} with:
+
+ use inc::${\__PACKAGE__};
+
+not:
+
+ use ${\__PACKAGE__};
+
+END_DIE
+
+
+
+
+
+# If the script that is loading Module::Install is from the future,
+# then make will detect this and cause it to re-run over and over
+# again. This is bad. Rather than taking action to touch it (which
+# is unreliable on some platforms and requires write permissions)
+# for now we should catch this and refuse to run.
+if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
+
+Your installer $0 has a modification time in the future.
+
+This is known to create infinite loops in make.
+
+Please correct this, then run $0 again.
+
+END_DIE
+
+
+
+
+
+# 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));
+
+
+
+
+
+use Cwd ();
+use File::Find ();
+use File::Path ();
+use FindBin;
+
+sub autoload {
+ my $self = shift;
+ my $who = $self->_caller;
+ my $cwd = Cwd::cwd();
+ my $sym = "${who}::AUTOLOAD";
+ $sym->{$cwd} = sub {
+ my $pwd = Cwd::cwd();
+ if ( my $code = $sym->{$pwd} ) {
+ # delegate back to parent dirs
+ goto &$code unless $cwd eq $pwd;
+ }
+ $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
+ unless ( uc($1) eq $1 ) {
+ unshift @_, ( $self, $1 );
+ goto &{$self->can('call')};
+ }
+ };
+}
+
+sub import {
+ my $class = shift;
+ my $self = $class->new(@_);
+ my $who = $self->_caller;
+
+ unless ( -f $self->{file} ) {
+ require "$self->{path}/$self->{dispatch}.pm";
+ File::Path::mkpath("$self->{prefix}/$self->{author}");
+ $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
+ $self->{admin}->init;
+ @_ = ($class, _self => $self);
+ goto &{"$self->{name}::import"};
+ }
+
+ *{"${who}::AUTOLOAD"} = $self->autoload;
+ $self->preload;
+
+ # Unregister loader and worker packages so subdirs can use them again
+ delete $INC{"$self->{file}"};
+ delete $INC{"$self->{path}.pm"};
+
+ return 1;
+}
+
+sub preload {
+ my $self = shift;
+ unless ( $self->{extensions} ) {
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ );
+ }
+
+ my @exts = @{$self->{extensions}};
+ unless ( @exts ) {
+ my $admin = $self->{admin};
+ @exts = $admin->load_all_extensions;
+ }
+
+ my %seen;
+ foreach my $obj ( @exts ) {
+ while (my ($method, $glob) = each %{ref($obj) . '::'}) {
+ next unless $obj->can($method);
+ next if $method =~ /^_/;
+ next if $method eq uc($method);
+ $seen{$method}++;
+ }
+ }
+
+ my $who = $self->_caller;
+ foreach my $name ( sort keys %seen ) {
+ *{"${who}::$name"} = sub {
+ ${"${who}::AUTOLOAD"} = "${who}::$name";
+ goto &{"${who}::AUTOLOAD"};
+ };
+ }
+}
+
+sub new {
+ my ($class, %args) = @_;
+
+ # ignore the prefix on extension modules built from top level.
+ my $base_path = Cwd::abs_path($FindBin::Bin);
+ unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
+ delete $args{prefix};
+ }
+
+ return $args{_self} if $args{_self};
+
+ $args{dispatch} ||= 'Admin';
+ $args{prefix} ||= 'inc';
+ $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
+ $args{bundle} ||= 'inc/BUNDLES';
+ $args{base} ||= $base_path;
+ $class =~ s/^\Q$args{prefix}\E:://;
+ $args{name} ||= $class;
+ $args{version} ||= $class->VERSION;
+ unless ( $args{path} ) {
+ $args{path} = $args{name};
+ $args{path} =~ s!::!/!g;
+ }
+ $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
+ $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) = @_;
+
+ unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
+ unshift @INC, $self->{prefix};
+ }
+
+ foreach my $rv ( $self->find_extensions($path) ) {
+ my ($file, $pkg) = @{$rv};
+ next if $self->{pathnames}{$pkg};
+
+ local $@;
+ my $new = eval { require $file; $pkg->can('new') };
+ unless ( $new ) {
+ warn $@ if $@;
+ next;
+ }
+ $self->{pathnames}{$pkg} = delete $INC{$file};
+ push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
+ }
+
+ $self->{extensions} ||= [];
+}
+
+sub find_extensions {
+ my ($self, $path) = @_;
+
+ my @found;
+ File::Find::find( sub {
+ my $file = $File::Find::name;
+ return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
+ my $subpath = $1;
+ return if lc($subpath) eq lc($self->{dispatch});
+
+ $file = "$self->{path}/$subpath.pm";
+ my $pkg = "$self->{name}::$subpath";
+ $pkg =~ s!/!::!g;
+
+ # If we have a mixed-case package name, assume case has been preserved
+ # correctly. Otherwise, root through the file to locate the case-preserved
+ # version of the package name.
+ if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
+ my $content = Module::Install::_read($subpath . '.pm');
+ my $in_pod = 0;
+ foreach ( split //, $content ) {
+ $in_pod = 1 if /^=\w/;
+ $in_pod = 0 if /^=cut/;
+ next if ($in_pod || /^=cut/); # skip pod text
+ next if /^\s*#/; # and comments
+ if ( m/^\s*package\s+($pkg)\s*;/i ) {
+ $pkg = $1;
+ last;
+ }
+ }
+ }
+
+ push @found, [ $file, $pkg ];
+ }, $path ) if -d $path;
+
+ @found;
+}
+
+
+
+
+
+#####################################################################
+# Utility Functions
+
+sub _caller {
+ my $depth = 0;
+ my $call = caller($depth);
+ while ( $call eq __PACKAGE__ ) {
+ $depth++;
+ $call = caller($depth);
+ }
+ return $call;
+}
+
+sub _read {
+ local *FH;
+ open FH, "< $_[0]" or die "open($_[0]): $!";
+ my $str = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $str;
+}
+
+sub _write {
+ local *FH;
+ open FH, "> $_[0]" or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
+ close FH or die "close($_[0]): $!";
+}
+
+# _version is for processing module versions (eg, 1.03_05) not
+# Perl versions (eg, 5.8.1).
+
+sub _version ($) {
+ my $s = shift || 0;
+ $s =~ s/^(\d+)\.?//;
+ my $l = $1 || 0;
+ my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
+ $l = $l . '.' . join '', @v if @v;
+ return $l + 0;
+}
+
+# Cloned from Params::Util::_CLASS
+sub _CLASS ($) {
+ (
+ defined $_[0]
+ and
+ ! ref $_[0]
+ and
+ $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s
+ ) ? $_[0] : undef;
+}
+
+1;
+
+# Copyright 2008 Adam Kennedy.
diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm
new file mode 100644
index 0000000..433ebed
--- /dev/null
+++ b/inc/Module/Install/Base.pm
@@ -0,0 +1,72 @@
+#line 1
+package Module::Install::Base;
+
+$VERSION = '0.77';
+
+# Suspend handler for "redefined" warnings
+BEGIN {
+ my $w = $SIG{__WARN__};
+ $SIG{__WARN__} = sub { $w };
+}
+
+### This is the ONLY module that shouldn't have strict on
+# use strict;
+
+#line 41
+
+sub new {
+ my ($class, %args) = @_;
+
+ foreach my $method ( qw(call load) ) {
+ *{"$class\::$method"} = sub {
+ shift()->_top->$method(@_);
+ } unless defined &{"$class\::$method"};
+ }
+
+ bless( \%args, $class );
+}
+
+#line 61
+
+sub AUTOLOAD {
+ my $self = shift;
+ local $@;
+ my $autoload = eval { $self->_top->autoload } or return;
+ goto &$autoload;
+}
+
+#line 76
+
+sub _top { $_[0]->{_top} }
+
+#line 89
+
+sub admin {
+ $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
+}
+
+#line 101
+
+sub is_admin {
+ $_[0]->admin->VERSION;
+}
+
+sub DESTROY {}
+
+package Module::Install::Base::FakeAdmin;
+
+my $Fake;
+sub new { $Fake ||= bless(\@_, $_[0]) }
+
+sub AUTOLOAD {}
+
+sub DESTROY {}
+
+# Restore warning handler
+BEGIN {
+ $SIG{__WARN__} = $SIG{__WARN__}->();
+}
+
+1;
+
+#line 146
diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm
new file mode 100644
index 0000000..9025607
--- /dev/null
+++ b/inc/Module/Install/Can.pm
@@ -0,0 +1,83 @@
+#line 1
+package Module::Install::Can;
+
+use strict;
+use Module::Install::Base;
+use Config ();
+### This adds a 5.005 Perl version dependency.
+### This is a bug and will be fixed.
+use File::Spec ();
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.77';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+# check if we can load some module
+### Upgrade this to not have to load the module if possible
+sub can_use {
+ my ($self, $mod, $ver) = @_;
+ $mod =~ s{::|\\}{/}g;
+ $mod .= '.pm' unless $mod =~ /\.pm$/i;
+
+ my $pkg = $mod;
+ $pkg =~ s{/}{::}g;
+ $pkg =~ s{\.pm$}{}i;
+
+ local $@;
+ eval { require $mod; $pkg->VERSION($ver || 0); 1 };
+}
+
+# check if we can run some command
+sub can_run {
+ my ($self, $cmd) = @_;
+
+ my $_cmd = $cmd;
+ return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
+
+ for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
+ next if $dir eq '';
+ my $abs = File::Spec->catfile($dir, $_[1]);
+ return $abs if (-x $abs or $abs = MM->maybe_command($abs));
+ }
+
+ return;
+}
+
+# can we locate a (the) C compiler
+sub can_cc {
+ my $self = shift;
+ my @chunks = split(/ /, $Config::Config{cc}) or return;
+
+ # $Config{cc} may contain args; try to find out the program part
+ while (@chunks) {
+ return $self->can_run("@chunks") || (pop(@chunks), next);
+ }
+
+ return;
+}
+
+# Fix Cygwin bug on maybe_command();
+if ( $^O eq 'cygwin' ) {
+ require ExtUtils::MM_Cygwin;
+ require ExtUtils::MM_Win32;
+ if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
+ *ExtUtils::MM_Cygwin::maybe_command = sub {
+ my ($self, $file) = @_;
+ if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
+ ExtUtils::MM_Win32->maybe_command($file);
+ } else {
+ ExtUtils::MM_Unix->maybe_command($file);
+ }
+ }
+ }
+}
+
+1;
+
+__END__
+
+#line 158
diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm
new file mode 100644
index 0000000..d66aba5
--- /dev/null
+++ b/inc/Module/Install/Fetch.pm
@@ -0,0 +1,93 @@
+#line 1
+package Module::Install::Fetch;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.77';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub get_file {
+ my ($self, %args) = @_;
+ my ($scheme, $host, $path, $file) =
+ $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
+
+ if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
+ $args{url} = $args{ftp_url}
+ or (warn("LWP support unavailable!\n"), return);
+ ($scheme, $host, $path, $file) =
+ $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
+ }
+
+ $|++;
+ print "Fetching '$file' from $host... ";
+
+ unless (eval { require Socket; Socket::inet_aton($host) }) {
+ warn "'$host' resolve failed!\n";
+ return;
+ }
+
+ return unless $scheme eq 'ftp' or $scheme eq 'http';
+
+ require Cwd;
+ my $dir = Cwd::getcwd();
+ chdir $args{local_dir} or return if exists $args{local_dir};
+
+ if (eval { require LWP::Simple; 1 }) {
+ LWP::Simple::mirror($args{url}, $file);
+ }
+ elsif (eval { require Net::FTP; 1 }) { eval {
+ # use Net::FTP to get past firewall
+ my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
+ $ftp->login("anonymous", 'anonymous at example.com');
+ $ftp->cwd($path);
+ $ftp->binary;
+ $ftp->get($file) or (warn("$!\n"), return);
+ $ftp->quit;
+ } }
+ elsif (my $ftp = $self->can_run('ftp')) { eval {
+ # no Net::FTP, fallback to ftp.exe
+ require FileHandle;
+ my $fh = FileHandle->new;
+
+ local $SIG{CHLD} = 'IGNORE';
+ unless ($fh->open("|$ftp -n")) {
+ warn "Couldn't open ftp: $!\n";
+ chdir $dir; return;
+ }
+
+ my @dialog = split(/\n/, <<"END_FTP");
+open $host
+user anonymous anonymous\@example.com
+cd $path
+binary
+get $file $file
+quit
+END_FTP
+ foreach (@dialog) { $fh->print("$_\n") }
+ $fh->close;
+ } }
+ else {
+ warn "No working 'ftp' program available!\n";
+ chdir $dir; return;
+ }
+
+ unless (-f $file) {
+ warn "Fetching failed: $@\n";
+ chdir $dir; return;
+ }
+
+ return if exists $args{size} and -s $file != $args{size};
+ system($args{run}) if exists $args{run};
+ unlink($file) if $args{remove};
+
+ print(((!exists $args{check_for} or -e $args{check_for})
+ ? "done!" : "failed! ($!)"), "\n");
+ chdir $dir; return !$?;
+}
+
+1;
diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm
new file mode 100644
index 0000000..92cd1ef
--- /dev/null
+++ b/inc/Module/Install/Makefile.pm
@@ -0,0 +1,253 @@
+#line 1
+package Module::Install::Makefile;
+
+use strict 'vars';
+use Module::Install::Base;
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.77';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub Makefile { $_[0] }
+
+my %seen = ();
+
+sub prompt {
+ shift;
+
+ # Infinite loop protection
+ my @c = caller();
+ if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
+ die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
+ }
+
+ # In automated testing, always use defaults
+ if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
+ local $ENV{PERL_MM_USE_DEFAULT} = 1;
+ goto &ExtUtils::MakeMaker::prompt;
+ } else {
+ goto &ExtUtils::MakeMaker::prompt;
+ }
+}
+
+sub makemaker_args {
+ my $self = shift;
+ my $args = ( $self->{makemaker_args} ||= {} );
+ %$args = ( %$args, @_ );
+ return $args;
+}
+
+# For mm args that take multiple space-seperated args,
+# append an argument to the current list.
+sub makemaker_append {
+ my $self = sShift;
+ my $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 );
+}
+
+my %test_dir = ();
+
+sub _wanted_t {
+ /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
+}
+
+sub tests_recursive {
+ my $self = shift;
+ if ( $self->tests ) {
+ die "tests_recursive will not work if tests are already defined";
+ }
+ my $dir = shift || 't';
+ unless ( -d $dir ) {
+ die "tests_recursive dir '$dir' does not exist";
+ }
+ %test_dir = ();
+ require File::Find;
+ File::Find::find( \&_wanted_t, $dir );
+ $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
+}
+
+sub write {
+ my $self = shift;
+ die "&Makefile->write() takes no arguments\n" if @_;
+
+ # Make sure we have a new enough
+ require ExtUtils::MakeMaker;
+
+ # MakeMaker can complain about module versions that include
+ # an underscore, even though its own version may contain one!
+ # Hence the funny regexp to get rid of it. See RT #35800
+ # for details.
+
+ $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
+
+ # Generate the
+ my $args = $self->makemaker_args;
+ $args->{DISTNAME} = $self->name;
+ $args->{NAME} = $self->module_name || $self->name;
+ $args->{VERSION} = $self->version;
+ $args->{NAME} =~ s/-/::/g;
+ if ( $self->tests ) {
+ $args->{test} = { TESTS => $self->tests };
+ }
+ if ($] >= 5.005) {
+ $args->{ABSTRACT} = $self->abstract;
+ $args->{AUTHOR} = $self->author;
+ }
+ if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
+ $args->{NO_META} = 1;
+ }
+ if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
+ $args->{SIGN} = 1;
+ }
+ unless ( $self->is_admin ) {
+ delete $args->{SIGN};
+ }
+
+ # merge both kinds of requires into prereq_pm
+ my $prereq = ($args->{PREREQ_PM} ||= {});
+ %$prereq = ( %$prereq,
+ map { @$_ }
+ map { @$_ }
+ grep $_,
+ ($self->configure_requires, $self->build_requires, $self->requires)
+ );
+
+ # Remove any reference to perl, PREREQ_PM doesn't support it
+ delete $args->{PREREQ_PM}->{perl};
+
+ # merge both kinds of requires into prereq_pm
+ my $subdirs = ($args->{DIR} ||= []);
+ if ($self->bundles) {
+ foreach my $bundle (@{ $self->bundles }) {
+ my ($file, $dir) = @$bundle;
+ push @$subdirs, $dir if -d $dir;
+ delete $prereq->{$file};
+ }
+ }
+
+ if ( my $perl_version = $self->perl_version ) {
+ eval "use $perl_version; 1"
+ or die "ERROR: perl: Version $] is installed, "
+ . "but we need version >= $perl_version";
+ }
+
+ $args->{INSTALLDIRS} = $self->installdirs;
+
+ my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
+
+ my $user_preop = delete $args{dist}->{PREOP};
+ if (my $preop = $self->admin->preop($user_preop)) {
+ 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: $!";
+ my $makefile = do { local $/; <MAKEFILE> };
+ close MAKEFILE or die $!;
+
+ $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
+ $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
+ $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
+ $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
+ $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
+
+ # Module::Install will never be used to build the Core Perl
+ # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
+ # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
+ $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
+ #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
+
+ # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
+ $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
+
+ # XXX - This is currently unused; not sure if it breaks other MM-users
+ # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
+
+ open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
+ print MAKEFILE "$preamble$makefile$postamble" or die $!;
+ close MAKEFILE or die $!;
+
+ 1;
+}
+
+sub preamble {
+ my ($self, $text) = @_;
+ $self->{preamble} = $text . $self->{preamble} if defined $text;
+ $self->{preamble};
+}
+
+sub postamble {
+ my ($self, $text) = @_;
+ $self->{postamble} ||= $self->admin->postamble;
+ $self->{postamble} .= $text if defined $text;
+ $self->{postamble}
+}
+
+1;
+
+__END__
+
+#line 379
diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm
new file mode 100644
index 0000000..397fb97
--- /dev/null
+++ b/inc/Module/Install/Metadata.pm
@@ -0,0 +1,500 @@
+#line 1
+package Module::Install::Metadata;
+
+use strict 'vars';
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.77';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+my @scalar_keys = qw{
+ name
+ module_name
+ abstract
+ author
+ version
+ distribution_type
+ tests
+ installdirs
+};
+
+my @tuple_keys = qw{
+ configure_requires
+ build_requires
+ requires
+ recommends
+ bundles
+ resources
+};
+
+my @resource_keys = qw{
+ homepage
+ bugtracker
+ repository
+};
+
+sub Meta { shift }
+sub Meta_ScalarKeys { @scalar_keys }
+sub Meta_TupleKeys { @tuple_keys }
+sub Meta_ResourceKeys { @resource_keys }
+
+foreach my $key ( @scalar_keys ) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}{$key} if defined wantarray and !@_;
+ $self->{values}{$key} = shift;
+ return $self;
+ };
+}
+
+foreach my $key ( @resource_keys ) {
+ *$key = sub {
+ my $self = shift;
+ unless ( @_ ) {
+ return () unless $self->{values}{resources};
+ return map { $_->[1] }
+ grep { $_->[0] eq $key }
+ @{ $self->{values}{resources} };
+ }
+ return $self->{values}{resources}{$key} unless @_;
+ my $uri = shift or die(
+ "Did not provide a value to $key()"
+ );
+ $self->resources( $key => $uri );
+ return 1;
+ };
+}
+
+sub requires {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}{requires} }, [ $module, $version ];
+ }
+ $self->{values}{requires};
+}
+
+sub build_requires {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}{build_requires} }, [ $module, $version ];
+ }
+ $self->{values}{build_requires};
+}
+
+sub configure_requires {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}{configure_requires} }, [ $module, $version ];
+ }
+ $self->{values}{configure_requires};
+}
+
+sub recommends {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}{recommends} }, [ $module, $version ];
+ }
+ $self->{values}{recommends};
+}
+
+sub bundles {
+ my $self = shift;
+ while ( @_ ) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ push @{ $self->{values}{bundles} }, [ $module, $version ];
+ }
+ $self->{values}{bundles};
+}
+
+# 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 sign {
+ my $self = shift;
+ return $self->{values}{sign} if defined wantarray and ! @_;
+ $self->{values}{sign} = ( @_ ? $_[0] : 1 );
+ return $self;
+}
+
+sub dynamic_config {
+ my $self = shift;
+ unless ( @_ ) {
+ warn "You MUST provide an explicit true/false value to dynamic_config\n";
+ return $self;
+ }
+ $self->{values}{dynamic_config} = $_[0] ? 1 : 0;
+ return 1;
+}
+
+sub perl_version {
+ my $self = shift;
+ return $self->{values}{perl_version} unless @_;
+ my $version = shift or die(
+ "Did not provide a value to perl_version()"
+ );
+
+ # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
+ # numbers (eg, 5.006001 or 5.008009).
+
+ $version =~ s/^(\d+)\.(\d+)\.(\d+)$/sprintf("%d.%03d%03d",$1,$2,$3)/e;
+
+ $version =~ s/_.+$//;
+ $version = $version + 0; # Numify
+ unless ( $version >= 5.005 ) {
+ die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
+ }
+ $self->{values}{perl_version} = $version;
+ return 1;
+}
+
+sub license {
+ my $self = shift;
+ return $self->{values}{license} unless @_;
+ my $license = shift or die(
+ 'Did not provide a value to license()'
+ );
+ $self->{values}{license} = $license;
+
+ # Automatically fill in license URLs
+ if ( $license eq 'perl' ) {
+ $self->resources( license => 'http://dev.perl.org/licenses/' );
+ }
+
+ return 1;
+}
+
+sub all_from {
+ my ( $self, $file ) = @_;
+
+ unless ( defined($file) ) {
+ my $name = $self->name or die(
+ "all_from called with no args without setting name() first"
+ );
+ $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");
+ }
+
+ # 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) );
+}
+
+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 perl_version_from {
+ my $self = shift;
+ if (
+ Module::Install::_read($_[0]) =~ m/
+ ^
+ (?:use|require) \s*
+ v?
+ ([\d_\.]+)
+ \s* ;
+ /ixms
+ ) {
+ my $perl_version = $1;
+ $perl_version =~ s{_}{}g;
+ $self->perl_version($perl_version);
+ } else {
+ warn "Cannot determine perl version info from $_[0]\n";
+ return;
+ }
+}
+
+sub author_from {
+ my $self = shift;
+ my $content = Module::Install::_read($_[0]);
+ if ($content =~ m/
+ =head \d \s+ (?:authors?)\b \s*
+ ([^\n]*)
+ |
+ =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
+ .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
+ ([^\n]*)
+ /ixms) {
+ my $author = $1 || $2;
+ $author =~ s{E<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ $self->author($author);
+ } else {
+ warn "Cannot determine author info from $_[0]\n";
+ }
+}
+
+sub license_from {
+ my $self = shift;
+ if (
+ Module::Install::_read($_[0]) =~ m/
+ (
+ =head \d \s+
+ (?:licen[cs]e|licensing|copyright|legal)\b
+ .*?
+ )
+ (=head\\d.*|=cut.*|)
+ \z
+ /ixms ) {
+ my $license_text = $1;
+ my @phrases = (
+ 'under the same (?:terms|license) as perl itself' => 'perl', 1,
+ 'GNU general public license' => 'gpl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser general public license' => 'lgpl', 1,
+ 'GNU lesser public license' => 'lgpl', 1,
+ 'GNU library general public license' => 'lgpl', 1,
+ 'GNU library public license' => 'lgpl', 1,
+ 'BSD license' => 'bsd', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 1,
+ 'proprietary' => 'proprietary', 0,
+ );
+ while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
+ $pattern =~ s{\s+}{\\s+}g;
+ if ( $license_text =~ /\b$pattern\b/i ) {
+ if ( $osi and $license_text =~ /All rights reserved/i ) {
+ print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
+ }
+ $self->license($license);
+ return 1;
+ }
+ }
+ }
+
+ warn "Cannot determine license info from $_[0]\n";
+ return 'unknown';
+}
+
+sub bugtracker_from {
+ my $self = shift;
+ my $content = Module::Install::_read($_[0]);
+ my @links = $content =~ m/L\<(http\:\/\/rt\.cpan\.org\/[^>]+)\>/g;
+ unless ( @links ) {
+ warn "Cannot determine bugtracker info from $_[0]\n";
+ return 0;
+ }
+ if ( @links > 1 ) {
+ warn "Found more than on rt.cpan.org link in $_[0]\n";
+ return 0;
+ }
+
+ # Set the bugtracker
+ bugtracker( $links[0] );
+ return 1;
+}
+
+sub install_script {
+ my $self = shift;
+ my $args = $self->makemaker_args;
+ my $exe = $args->{EXE_FILES} ||= [];
+ foreach ( @_ ) {
+ if ( -f $_ ) {
+ push @$exe, $_;
+ } elsif ( -d 'script' and -f "script/$_" ) {
+ push @$exe, "script/$_";
+ } else {
+ die("Cannot find script '$_'");
+ }
+ }
+}
+
+1;
diff --git a/inc/Module/Install/RTx.pm b/inc/Module/Install/RTx.pm
new file mode 100644
index 0000000..7f69cd5
--- /dev/null
+++ b/inc/Module/Install/RTx.pm
@@ -0,0 +1,189 @@
+#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.23';
+
+use FindBin;
+use File::Glob ();
+use File::Basename ();
+
+my @DIRS = qw(etc lib html bin sbin po var);
+my @INDEX_DIRS = qw(lib bin sbin);
+
+sub RTx {
+ my ( $self, $name ) = @_;
+
+ 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 = (
+ @INC,
+ $ENV{RTHOME} ? ( $ENV{RTHOME}, "$ENV{RTHOME}/lib" ) : (),
+ map { ( "$_/rt3/lib", "$_/lib/rt3", "$_/lib" ) } grep $_,
+ @prefixes
+ );
+ until ( eval { require RT; $RT::LocalPath } ) {
+ warn
+ "Cannot find the location of RT.pm that defines \$RT::LocalPath in: @INC\n";
+ $_ = $self->prompt("Path to your RT.pm:") or exit;
+ push @INC, $_, "$_/rt3/lib", "$_/lib/rt3", "$_/lib";
+ }
+ }
+
+ my $lib_path = File::Basename::dirname( $INC{'RT.pm'} );
+ my $local_lib_path = "$RT::LocalPath/lib";
+ print "Using RT configuration from $INC{'RT.pm'}:\n";
+ unshift @INC, "$RT::LocalPath/lib" if $RT::LocalPath;
+
+ $RT::LocalVarPath ||= $RT::VarPath;
+ $RT::LocalPoPath ||= $RT::LocalLexiconPath;
+ $RT::LocalHtmlPath ||= $RT::MasonComponentRoot;
+ $RT::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 ) {
+ $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;
+}
+
+1;
+
+__END__
+
+#line 282
diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm
new file mode 100644
index 0000000..cff76a2
--- /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 = '0.77';
+ @ISA = qw{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..f35620f
--- /dev/null
+++ b/inc/Module/Install/WriteAll.pm
@@ -0,0 +1,40 @@
+#line 1
+package Module::Install::WriteAll;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION @ISA $ISCORE};
+BEGIN {
+ $VERSION = '0.77';
+ @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->Meta->write if $args{meta};
+ $self->admin->WriteAll(%args) if $self->is_admin;
+
+ $self->check_nmake if $args{check_nmake};
+ unless ( $self->makemaker_args->{PL_FILES} ) {
+ $self->makemaker_args( PL_FILES => {} );
+ }
+
+ if ( $args{inline} ) {
+ $self->Inline->write;
+ } else {
+ $self->Makefile->write;
+ }
+}
+
+1;
commit 3f68f481ff7e42cb173a80162aad82d51d383284
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Aug 21 04:09:34 2008 +0000
installation docs
diff --git a/lib/RT/Extension/Captcha.pm b/lib/RT/Extension/Captcha.pm
index 829d41c..f303018 100644
--- a/lib/RT/Extension/Captcha.pm
+++ b/lib/RT/Extension/Captcha.pm
@@ -23,6 +23,16 @@ it's not configurable at this point. Either hack this extension
or set an absolute path to a ttf font via 'ChartFont' option in
the RT config.
+=head1 INSTALLATION
+
+ perl Makefile.PL
+ make
+ make install
+
+In the RT config:
+
+ Set(@Plugins, 'RT::Extension::Captcha', ... other extensions ... );
+
=cut
use RT::Queue;
commit d8a968a053cefbb7c6b12e45fb416aea6149916a
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Thu Aug 21 05:41:27 2008 +0000
protect quick create
diff --git a/html/Callbacks/RT-Extension-Captcha/Ticket/Display.html/Initial b/html/Callbacks/RT-Extension-Captcha/Ticket/Display.html/Initial
index b35e209..482e7d7 100644
--- a/html/Callbacks/RT-Extension-Captcha/Ticket/Display.html/Initial
+++ b/html/Callbacks/RT-Extension-Captcha/Ticket/Display.html/Initial
@@ -2,7 +2,6 @@
$ARGSRef => {}
</%ARGS>
<%INIT>
-$RT::Logger->crit("woot");
return unless ($ARGSRef->{'id'}||'') eq 'new';
my $queue = RT::Queue->new( $session{'CurrentUser'} );
@@ -24,7 +23,7 @@ if ( !$captcha || lc($captcha) ne lc($session{'Captcha'}{'String'}||'') ) {
."?Queue=". $m->interp->apply_escapes( $ARGSRef->{'Queue'}, 'u' )
."&results=". $key
);
- $m->abort;
+ return $m->abort;
}
delete $session{'Captcha'};
diff --git a/html/Callbacks/RT-Extension-Captcha/index.html/Initial b/html/Callbacks/RT-Extension-Captcha/index.html/Initial
new file mode 100644
index 0000000..d4a91b6
--- /dev/null
+++ b/html/Callbacks/RT-Extension-Captcha/index.html/Initial
@@ -0,0 +1,32 @@
+<%ARGS>
+$ARGSRef => {}
+$results => []
+</%ARGS>
+<%INIT>
+return unless $ARGSRef->{'QuickCreate'};
+
+my $queue = RT::Queue->new( $session{'CurrentUser'} );
+$queue->Load( $ARGSRef->{'Queue'} );
+return unless $queue->id;
+
+return if $queue->CurrentUserHasRight('NoCaptchaOnCreate');
+
+delete $session{'Captcha'};
+my $key = Digest::MD5::md5_hex( rand(1024) );
+push @{ $session{"Actions"}->{ $key } ||= [] }, @$results;
+$session{'i'}++;
+RT::Interface::Web::Redirect(
+ RT->Config->Get('WebURL')
+ ."Ticket/Create.html?". $m->comp('/Elements/QueryString',
+ id => 'new',
+ Status => 'new',
+ Requestors => $session{'CurrentUser'}->EmailAddress,
+ Queue => $ARGSRef->{'Queue'},
+ Owner => $ARGSRef->{'Owner'},
+ Subject => $ARGSRef->{'Subject'},
+ Content => $ARGSRef->{'Content'},
+ results => $key,
+ )
+);
+return $m->abort;
+</%INIT>
commit 3f7d85c9446658448a21674130759654072783b7
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri Aug 22 08:34:50 2008 +0000
captcha on update(reply/comment)
diff --git a/MANIFEST b/MANIFEST
index 23d868c..70d065b 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,6 +1,10 @@
+html/Callbacks/RT-Extension-Captcha/index.html/Initial
html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/BeforeCreate
html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/FormStart
html/Callbacks/RT-Extension-Captcha/Ticket/Display.html/Initial
+html/Callbacks/RT-Extension-Captcha/Ticket/Update.html/FormStart
+html/Callbacks/RT-Extension-Captcha/Ticket/Update.html/Initial
+html/Elements/Captcha
html/Helpers/Captcha
inc/Module/Install.pm
inc/Module/Install/Base.pm
diff --git a/html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/FormStart b/html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/FormStart
index d8a7422..6e8a83d 100644
--- a/html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/FormStart
+++ b/html/Callbacks/RT-Extension-Captcha/Ticket/Create.html/FormStart
@@ -1,14 +1,4 @@
-<div id="Ticket-Create-captcha">
-<a name="captcha"></a>
-
-<&| /Widgets/TitleBox, title => loc("You must solve a CAPTACHA to create a new ticket") &>
-
-<table border="0" cellpadding="0" cellspacing="0">
-<tr><td><img src="<% RT->Config->Get('WebURL') %>Helpers/Captcha" /></td>
-<td><input type="text" name="CaptchaString" /></td></tr>
-</table>
-
-</&>
+<div id="Ticket-Create-captcha"><a name="captcha"></a><& /Elements/Captcha &></div>
<%ARGS>
$ARGSRef => {}
</%ARGS>
diff --git a/html/Callbacks/RT-Extension-Captcha/Ticket/Display.html/Initial b/html/Callbacks/RT-Extension-Captcha/Ticket/Display.html/Initial
index 482e7d7..7943611 100644
--- a/html/Callbacks/RT-Extension-Captcha/Ticket/Display.html/Initial
+++ b/html/Callbacks/RT-Extension-Captcha/Ticket/Display.html/Initial
@@ -2,27 +2,50 @@
$ARGSRef => {}
</%ARGS>
<%INIT>
-return unless ($ARGSRef->{'id'}||'') eq 'new';
+my ($is_create, $is_update);
+if ( ($ARGSRef->{'id'}||'') eq 'new' ) {
+ my $queue = RT::Queue->new( $session{'CurrentUser'} );
+ $queue->Load( $ARGSRef->{'Queue'} );
+ return unless $queue->id;
-my $queue = RT::Queue->new( $session{'CurrentUser'} );
-$queue->Load( $ARGSRef->{'Queue'} );
-return unless $queue->id;
-
-return if $queue->CurrentUserHasRight('NoCaptchaOnCreate');
+ return if $queue->CurrentUserHasRight('NoCaptchaOnCreate');
+ $is_create = 1;
+}
+elsif ( $ARGSRef->{'UpdateContent'} ) {
+ my $ticket = LoadTicket( $ARGSRef->{'id'} );
+ return if $ticket->CurrentUserHasRight('NoCaptchaOnUpdate');
+ $is_update = 1;
+}
+else {
+ return;
+}
my ($captcha) = ($ARGSRef->{'CaptchaString'});
-
if ( !$captcha || lc($captcha) ne lc($session{'Captcha'}{'String'}||'') ) {
my $key = Digest::MD5::md5_hex( rand(1024) );
push @{ $session{"Actions"}->{ $key } ||= [] },
loc("You have to solve CAPTCHA");
$session{'i'}++;
- RT::Interface::Web::Redirect(
- RT->Config->Get('WebURL')
- ."Ticket/Create.html"
- ."?Queue=". $m->interp->apply_escapes( $ARGSRef->{'Queue'}, 'u' )
- ."&results=". $key
- );
+
+ if ( $is_create ) {
+ RT::Interface::Web::Redirect(
+ RT->Config->Get('WebURL')
+ ."Ticket/Create.html"
+ ."?Queue=". $m->interp->apply_escapes( $ARGSRef->{'Queue'}, 'u' )
+ ."&results=". $key
+ );
+ }
+ elsif ( $is_update ) {
+ RT::Interface::Web::Redirect(
+ RT->Config->Get('WebURL')
+ ."Ticket/Update.html"
+ ."?id=". $m->interp->apply_escapes( $ARGSRef->{'id'}, 'u' )
+ ."&results=". $key
+ );
+ } else {
+ $RT::Logger->crit("Something wrong in captcha code");
+ return;
+ }
return $m->abort;
}
diff --git a/html/Callbacks/RT-Extension-Captcha/Ticket/Update.html/FormStart b/html/Callbacks/RT-Extension-Captcha/Ticket/Update.html/FormStart
new file mode 100644
index 0000000..4a57a62
--- /dev/null
+++ b/html/Callbacks/RT-Extension-Captcha/Ticket/Update.html/FormStart
@@ -0,0 +1,14 @@
+<div id="Ticket-Update-captcha"><a name="captcha"></a><& /Elements/Captcha &></div>
+<%ARGS>
+$ARGSRef => {}
+$Ticket => undef
+</%ARGS>
+<%INIT>
+
+unless ( $Ticket ) {
+ $Ticket = LoadTicket( $ARGSRef->{'id'} );
+}
+return if $Ticket->CurrentUserHasRight('NoCaptchaOnUpdate');
+
+</%INIT>
+
diff --git a/html/Callbacks/RT-Extension-Captcha/Ticket/Update.html/Initial b/html/Callbacks/RT-Extension-Captcha/Ticket/Update.html/Initial
new file mode 100644
index 0000000..fac221b
--- /dev/null
+++ b/html/Callbacks/RT-Extension-Captcha/Ticket/Update.html/Initial
@@ -0,0 +1,28 @@
+<%ARGS>
+$ARGSRef => {}
+$Ticket
+$results => undef
+</%ARGS>
+<%INIT>
+return if $Ticket->CurrentUserHasRight('NoCaptchaOnUpdate');
+
+unless ( $results ) {
+ $results = $session{"Actions"}->{''} ||= [];
+}
+
+my ($captcha) = ($ARGSRef->{'CaptchaString'});
+unless ( $captcha ) {
+ push @$results, loc("You have to solve CAPTCHA");
+ delete $ARGSRef->{'SubmitTicket'};
+}
+elsif ( !$session{'Captcha'}{'String'} ) {
+ push @$results, loc("Don't play with me. You must solve CAPTCHA");
+ delete $ARGSRef->{'SubmitTicket'};
+}
+elsif ( lc($captcha) ne lc $session{'Captcha'}{'String'} ) {
+ delete $session{'Captcha'};
+ push @$results, loc("Not equal. Give you another CAPTCHA");
+ delete $ARGSRef->{'SubmitTicket'};
+}
+return;
+</%INIT>
diff --git a/html/Elements/Captcha b/html/Elements/Captcha
new file mode 100644
index 0000000..ba90931
--- /dev/null
+++ b/html/Elements/Captcha
@@ -0,0 +1,12 @@
+
+<&| /Widgets/TitleBox, title => loc("You must solve a CAPTACHA to proceed") &>
+
+<table border="0" cellpadding="0" cellspacing="0">
+<tr><td><img src="<% RT->Config->Get('WebURL') %>Helpers/Captcha" /></td>
+<td><input type="text" name="CaptchaString" /></td></tr>
+</table>
+
+</&>
+
+<%ARGS>
+</%ARGS>
diff --git a/lib/RT/Extension/Captcha.pm b/lib/RT/Extension/Captcha.pm
index f303018..8fca854 100644
--- a/lib/RT/Extension/Captcha.pm
+++ b/lib/RT/Extension/Captcha.pm
@@ -37,6 +37,7 @@ In the RT config:
use RT::Queue;
$RT::Queue::RIGHTS->{'NoCaptchaOnCreate'} = "Don't ask user to solve a CAPTCHA on ticket create"; #loc_pair
+$RT::Queue::RIGHTS->{'NoCaptchaOnUpdate'} = "Don't ask user to solve a CAPTCHA on ticket reply or comment"; #loc_pair
=head1 LICENSE
commit c3d0cd94a86ac8e369cc0c681306d83a904e4f29
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri Aug 22 23:56:22 2008 +0000
update docs
diff --git a/lib/RT/Extension/Captcha.pm b/lib/RT/Extension/Captcha.pm
index 8fca854..c6d7bbc 100644
--- a/lib/RT/Extension/Captcha.pm
+++ b/lib/RT/Extension/Captcha.pm
@@ -14,9 +14,11 @@ RT::Extension::Captcha - solve a CAPTCHA before some actions in RT
=head1 DESCRIPTION
-This extension for RT 3.8.1 or newer. At this point only captcha is
-required for creating a ticket. Users who have right 'OnCaptchaOnCreate'
-will see no captchas.
+This extension for RT 3.8.1 or newer. At this point solving captchas is
+required when user create a ticket using either regular interface or
+quick create (with 3.8.2 or newer only) and on replies/comments (updates).
+Users who have right 'OnCaptchaOnCreate' or 'OnCaptchaOnUpdate' will see
+no captchas on corresponding actions.
As GD's built in font is kinda small, we enabled ttf support and
it's not configurable at this point. Either hack this extension
commit 5af5b4c4e9e0e5c242e5f1da6b2d37362232f01b
Author: Ruslan Zakirov <ruz at bestpractical.com>
Date: Fri Dec 5 11:43:03 2008 +0000
register canonic rights
diff --git a/lib/RT/Extension/Captcha.pm b/lib/RT/Extension/Captcha.pm
index c6d7bbc..618e9e9 100644
--- a/lib/RT/Extension/Captcha.pm
+++ b/lib/RT/Extension/Captcha.pm
@@ -41,6 +41,10 @@ use RT::Queue;
$RT::Queue::RIGHTS->{'NoCaptchaOnCreate'} = "Don't ask user to solve a CAPTCHA on ticket create"; #loc_pair
$RT::Queue::RIGHTS->{'NoCaptchaOnUpdate'} = "Don't ask user to solve a CAPTCHA on ticket reply or comment"; #loc_pair
+use RT::ACE;
+$RT::ACE::LOWERCASERIGHTNAMES{ lc $_ } = $_
+ foreach qw(NoCaptchaOnCreate NoCaptchaOnUpdate);
+
=head1 LICENSE
Under the same terms as perl itself.
-----------------------------------------------------------------------
More information about the Bps-public-commit
mailing list