summaryrefslogtreecommitdiff
path: root/rt/lib/RT/Test
diff options
context:
space:
mode:
Diffstat (limited to 'rt/lib/RT/Test')
-rw-r--r--rt/lib/RT/Test/Apache.pm270
-rw-r--r--rt/lib/RT/Test/Email.pm7
-rw-r--r--rt/lib/RT/Test/GnuPG.pm360
-rw-r--r--rt/lib/RT/Test/Web.pm203
4 files changed, 819 insertions, 21 deletions
diff --git a/rt/lib/RT/Test/Apache.pm b/rt/lib/RT/Test/Apache.pm
new file mode 100644
index 000000000..b2733eadb
--- /dev/null
+++ b/rt/lib/RT/Test/Apache.pm
@@ -0,0 +1,270 @@
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC
+# <sales@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::Test::Apache;
+use strict;
+use warnings;
+
+my %MODULES = (
+ '2.2' => {
+ "mod_perl" => [qw(authz_host env alias perl)],
+ "fastcgi" => [qw(authz_host env alias mime fastcgi)],
+ },
+);
+
+my $apache_module_prefix = $ENV{RT_TEST_APACHE_MODULES};
+my $apxs =
+ $ENV{RT_TEST_APXS}
+ || RT::Test->find_executable('apxs')
+ || RT::Test->find_executable('apxs2');
+
+if ($apxs and not $apache_module_prefix) {
+ $apache_module_prefix = `$apxs -q LIBEXECDIR`;
+ chomp $apache_module_prefix;
+}
+
+$apache_module_prefix ||= 'modules';
+
+sub basic_auth {
+ my $self = shift;
+ my $passwd = File::Spec->rel2abs( File::Spec->catfile(
+ 't', 'data', 'configs', 'passwords' ) );
+
+ return <<"EOT";
+ AuthType Basic
+ AuthName "restricted area"
+ AuthUserFile $passwd
+ Require user root
+EOT
+}
+
+sub start_server {
+ my ($self, %config) = @_;
+ my %tmp = %{$config{tmp}};
+ my %info = $self->apache_server_info( %config );
+
+ RT::Test::diag(do {
+ open( my $fh, '<', $tmp{'config'}{'RT'} ) or die $!;
+ local $/;
+ <$fh>
+ });
+
+ my $tmpl = File::Spec->rel2abs( File::Spec->catfile(
+ 't', 'data', 'configs',
+ 'apache'. $info{'version'} .'+'. $config{variant} .'.conf'
+ ) );
+ my %opt = (
+ listen => $config{port},
+ server_root => $info{'HTTPD_ROOT'} || $ENV{'HTTPD_ROOT'}
+ || Test::More::BAIL_OUT("Couldn't figure out server root"),
+ document_root => $RT::MasonComponentRoot,
+ tmp_dir => "$tmp{'directory'}",
+ rt_bin_path => $RT::BinPath,
+ rt_sbin_path => $RT::SbinPath,
+ rt_site_config => $ENV{'RT_SITE_CONFIG'},
+ load_modules => $info{load_modules},
+ basic_auth => $config{basic_auth} ? $self->basic_auth : "",
+ );
+ foreach (qw(log pid lock)) {
+ $opt{$_ .'_file'} = File::Spec->catfile(
+ "$tmp{'directory'}", "apache.$_"
+ );
+ }
+
+ $tmp{'config'}{'apache'} = File::Spec->catfile(
+ "$tmp{'directory'}", "apache.conf"
+ );
+ $self->process_in_file(
+ in => $tmpl,
+ out => $tmp{'config'}{'apache'},
+ options => \%opt,
+ );
+
+ $self->fork_exec($info{'executable'}, '-f', $tmp{'config'}{'apache'});
+ my $pid = do {
+ my $tries = 15;
+ while ( !-s $opt{'pid_file'} ) {
+ $tries--;
+ last unless $tries;
+ sleep 1;
+ }
+ my $pid_fh;
+ unless (-e $opt{'pid_file'} and open($pid_fh, '<', $opt{'pid_file'})) {
+ Test::More::BAIL_OUT("Couldn't start apache server, no pid file (unknown error)")
+ unless -e $opt{log_file};
+
+ open my $log, "<", $opt{log_file};
+ my $error = do {local $/; <$log>};
+ close $log;
+ $RT::Logger->error($error) if $error;
+ Test::More::BAIL_OUT("Couldn't start apache server!");
+ }
+
+ my $pid = <$pid_fh>;
+ chomp $pid;
+ $pid;
+ };
+
+ Test::More::ok($pid, "Started apache server #$pid");
+ return $pid;
+}
+
+sub apache_server_info {
+ my $self = shift;
+ my %res = @_;
+
+ my $bin = $res{'executable'} = $ENV{'RT_TEST_APACHE'}
+ || $self->find_apache_server
+ || Test::More::BAIL_OUT("Couldn't find apache server, use RT_TEST_APACHE");
+
+ Test::More::BAIL_OUT(
+ "Couldn't find apache modules directory (set APXS= or RT_TEST_APACHE_MODULES=)"
+ ) unless -d $apache_module_prefix;
+
+
+ RT::Test::diag("Using '$bin' apache executable for testing");
+
+ my $info = `$bin -V`;
+ ($res{'version'}) = ($info =~ m{Server\s+version:\s+Apache/(\d+\.\d+)\.});
+ Test::More::BAIL_OUT(
+ "Couldn't figure out version of the server"
+ ) unless $res{'version'};
+
+ my %opts = ($info =~ m/^\s*-D\s+([A-Z_]+?)(?:="(.*)")$/mg);
+ %res = (%res, %opts);
+
+ $res{'modules'} = [
+ map {s/^\s+//; s/\s+$//; $_}
+ grep $_ !~ /Compiled in modules/i,
+ split /\r*\n/, `$bin -l`
+ ];
+
+ Test::More::BAIL_OUT(
+ "Unsupported apache version $res{version}"
+ ) unless exists $MODULES{$res{version}};
+
+ Test::More::BAIL_OUT(
+ "Unsupported apache variant $res{variant}"
+ ) unless exists $MODULES{$res{version}}{$res{variant}};
+
+ my @mlist = @{$MODULES{$res{version}}{$res{variant}}};
+ push @mlist, "authn_file", "auth_basic", "authz_user" if $res{basic_auth};
+
+ $res{'load_modules'} = '';
+ foreach my $mod ( @mlist ) {
+ next if grep $_ =~ /^(mod_|)$mod\.c$/, @{ $res{'modules'} };
+
+ my $so_file = $apache_module_prefix."/mod_".$mod.".so";
+ Test::More::BAIL_OUT( "Couldn't load $mod module (expected in $so_file)" )
+ unless -f $so_file;
+ $res{'load_modules'} .=
+ "LoadModule ${mod}_module $so_file\n";
+ }
+ return %res;
+}
+
+sub find_apache_server {
+ my $self = shift;
+ return $_ foreach grep defined,
+ map RT::Test->find_executable($_),
+ qw(httpd apache apache2 apache1);
+ return undef;
+}
+
+sub apache_mpm_type {
+ my $self = shift;
+ my $apache = $self->find_apache_server;
+ my $out = `$apache -l`;
+ if ( $out =~ /^\s*(worker|prefork|event|itk)\.c\s*$/m ) {
+ return $1;
+ }
+}
+
+sub fork_exec {
+ my $self = shift;
+
+ RT::Test::__disconnect_rt();
+ my $pid = fork;
+ unless ( defined $pid ) {
+ die "cannot fork: $!";
+ } elsif ( !$pid ) {
+ exec @_;
+ die "can't exec `". join(' ', @_) ."` program: $!";
+ } else {
+ RT::Test::__reconnect_rt();
+ return $pid;
+ }
+}
+
+sub process_in_file {
+ my $self = shift;
+ my %args = ( in => undef, options => undef, @_ );
+
+ my $text = RT::Test->file_content( $args{'in'} );
+ while ( my ($opt) = ($text =~ /\%\%(.+?)\%\%/) ) {
+ my $value = $args{'options'}{ lc $opt };
+ die "no value for $opt" unless defined $value;
+
+ $text =~ s/\%\%\Q$opt\E\%\%/$value/g;
+ }
+
+ my ($out_fh, $out_conf);
+ unless ( $args{'out'} ) {
+ ($out_fh, $out_conf) = tempfile();
+ } else {
+ $out_conf = $args{'out'};
+ open( $out_fh, '>', $out_conf )
+ or die "couldn't open '$out_conf': $!";
+ }
+ print $out_fh $text;
+ seek $out_fh, 0, 0;
+
+ return ($out_fh, $out_conf);
+}
+
+1;
diff --git a/rt/lib/RT/Test/Email.pm b/rt/lib/RT/Test/Email.pm
index 3905d82cb..a8170c981 100644
--- a/rt/lib/RT/Test/Email.pm
+++ b/rt/lib/RT/Test/Email.pm
@@ -2,7 +2,7 @@
#
# COPYRIGHT:
#
-# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC
+# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC
# <sales@bestpractical.com>
#
# (Except where explicitly superseded by other copyright notices)
@@ -56,8 +56,6 @@ use Email::Abstract;
use base 'Exporter';
our @EXPORT = qw(mail_ok);
-RT::Test->set_mail_catcher;
-
=head1 NAME
RT::Test::Email -
@@ -122,7 +120,8 @@ END {
if (scalar @mail) {
diag ((scalar @mail)." uncaught notification email at end of test: ");
diag "From: @{[ $_->header('From' ) ]}, Subject: @{[ $_->header('Subject') ]}"
- for @mail;
+ for map { Email::Abstract->new($_)->cast('Email::Simple') } @mail;
+
die;
}
}
diff --git a/rt/lib/RT/Test/GnuPG.pm b/rt/lib/RT/Test/GnuPG.pm
new file mode 100644
index 000000000..6cebb775b
--- /dev/null
+++ b/rt/lib/RT/Test/GnuPG.pm
@@ -0,0 +1,360 @@
+# BEGIN BPS TAGGED BLOCK {{{
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC
+# <sales@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::Test::GnuPG;
+use strict;
+use Test::More;
+use base qw(RT::Test);
+use File::Temp qw(tempdir);
+
+our @EXPORT =
+ qw(create_a_ticket update_ticket cleanup_headers set_queue_crypt_options
+ check_text_emails send_email_and_check_transaction
+ create_and_test_outgoing_emails
+ );
+
+sub import {
+ my $class = shift;
+ my %args = @_;
+ my $t = $class->builder;
+
+ $t->plan( skip_all => 'GnuPG required.' )
+ unless eval { require GnuPG::Interface; 1 };
+ $t->plan( skip_all => 'gpg executable is required.' )
+ unless RT::Test->find_executable('gpg');
+
+ require RT::Crypt::GnuPG;
+ $class->SUPER::import(%args);
+
+ RT::Test::diag "GnuPG --homedir " . RT->Config->Get('GnuPGOptions')->{'homedir'};
+
+ $class->set_rights(
+ Principal => 'Everyone',
+ Right => ['CreateTicket', 'ShowTicket', 'SeeQueue', 'ReplyToTicket', 'ModifyTicket'],
+ );
+
+ $class->export_to_level(1);
+}
+
+sub bootstrap_more_config {
+ my $self = shift;
+ my $handle = shift;
+ my $args = shift;
+
+ $self->SUPER::bootstrap_more_config($handle, $args, @_);
+
+ my %gnupg_options = (
+ 'no-permission-warning' => undef,
+ $args->{gnupg_options} ? %{ $args->{gnupg_options} } : (),
+ );
+ $gnupg_options{homedir} ||= scalar tempdir( CLEANUP => 1 );
+
+ use Data::Dumper;
+ local $Data::Dumper::Terse = 1; # "{...}" instead of "$VAR1 = {...};"
+ my $dumped_gnupg_options = Dumper(\%gnupg_options);
+
+ print $handle qq{
+Set(\%GnuPG, (
+ Enable => 1,
+ OutgoingMessagesFormat => 'RFC',
+));
+Set(\%GnuPGOptions => \%{ $dumped_gnupg_options });
+Set(\@MailPlugins => qw(Auth::MailFrom Auth::GnuPG));
+};
+
+}
+
+sub create_a_ticket {
+ my $queue = shift;
+ my $mail = shift;
+ my $m = shift;
+ my %args = (@_);
+
+ RT::Test->clean_caught_mails;
+
+ $m->goto_create_ticket( $queue );
+ $m->form_name('TicketCreate');
+ $m->field( Subject => 'test' );
+ $m->field( Requestors => 'rt-test@example.com' );
+ $m->field( Content => 'Some content' );
+
+ foreach ( qw(Sign Encrypt) ) {
+ if ( $args{ $_ } ) {
+ $m->tick( $_ => 1 );
+ } else {
+ $m->untick( $_ => 1 );
+ }
+ }
+
+ $m->submit;
+ is $m->status, 200, "request successful";
+
+ $m->content_lacks("unable to sign outgoing email messages");
+
+
+ my @mail = RT::Test->fetch_caught_mails;
+ check_text_emails(\%args, @mail );
+ categorize_emails($mail, \%args, @mail );
+}
+
+sub update_ticket {
+ my $tid = shift;
+ my $mail = shift;
+ my $m = shift;
+ my %args = (@_);
+
+ RT::Test->clean_caught_mails;
+
+ $m->get( $m->rt_base_url . "/Ticket/Update.html?Action=Respond&id=$tid" );
+ $m->form_number(3);
+ $m->field( UpdateContent => 'Some content' );
+
+ foreach ( qw(Sign Encrypt) ) {
+ if ( $args{ $_ } ) {
+ $m->tick( $_ => 1 );
+ } else {
+ $m->untick( $_ => 1 );
+ }
+ }
+
+ $m->click('SubmitTicket');
+ is $m->status, 200, "request successful";
+ $m->content_contains("Message recorded", 'Message recorded') or diag $m->content;
+
+
+ my @mail = RT::Test->fetch_caught_mails;
+ check_text_emails(\%args, @mail );
+ categorize_emails($mail, \%args, @mail );
+}
+
+sub categorize_emails {
+ my $mail = shift;
+ my $args = shift;
+ my @mail = @_;
+
+ if ( $args->{'Sign'} && $args->{'Encrypt'} ) {
+ push @{ $mail->{'signed_encrypted'} }, @mail;
+ }
+ elsif ( $args->{'Sign'} ) {
+ push @{ $mail->{'signed'} }, @mail;
+ }
+ elsif ( $args->{'Encrypt'} ) {
+ push @{ $mail->{'encrypted'} }, @mail;
+ }
+ else {
+ push @{ $mail->{'plain'} }, @mail;
+ }
+}
+
+sub check_text_emails {
+ my %args = %{ shift @_ };
+ my @mail = @_;
+
+ ok scalar @mail, "got some mail";
+ for my $mail (@mail) {
+ for my $type ('email', 'attachment') {
+ next if $type eq 'attachment' && !$args{'Attachment'};
+
+ my $content = $type eq 'email'
+ ? "Some content"
+ : "Attachment content";
+
+ if ( $args{'Encrypt'} ) {
+ unlike $mail, qr/$content/, "outgoing $type was encrypted";
+ } else {
+ like $mail, qr/$content/, "outgoing $type was not encrypted";
+ }
+
+ next unless $type eq 'email';
+
+ if ( $args{'Sign'} && $args{'Encrypt'} ) {
+ like $mail, qr/BEGIN PGP MESSAGE/, 'outgoing email was signed';
+ } elsif ( $args{'Sign'} ) {
+ like $mail, qr/SIGNATURE/, 'outgoing email was signed';
+ } else {
+ unlike $mail, qr/SIGNATURE/, 'outgoing email was not signed';
+ }
+ }
+ }
+}
+
+sub cleanup_headers {
+ my $mail = shift;
+ # strip id from subject to create new ticket
+ $mail =~ s/^(Subject:)\s*\[.*?\s+#\d+\]\s*/$1 /m;
+ # strip several headers
+ foreach my $field ( qw(Message-ID X-RT-Original-Encoding RT-Originator RT-Ticket X-RT-Loop-Prevention) ) {
+ $mail =~ s/^$field:.*?\n(?! |\t)//gmsi;
+ }
+ return $mail;
+}
+
+sub set_queue_crypt_options {
+ my $queue = shift;
+ my %args = @_;
+ $queue->SetEncrypt($args{'Encrypt'});
+ $queue->SetSign($args{'Sign'});
+}
+
+sub send_email_and_check_transaction {
+ my $mail = shift;
+ my $type = shift;
+
+ my ( $status, $id ) = RT::Test->send_via_mailgate($mail);
+ is( $status >> 8, 0, "The mail gateway exited normally" );
+ ok( $id, "got id of a newly created ticket - $id" );
+
+ my $tick = RT::Ticket->new( RT->SystemUser );
+ $tick->Load($id);
+ ok( $tick->id, "loaded ticket #$id" );
+
+ my $txn = $tick->Transactions->First;
+ my ( $msg, @attachments ) = @{ $txn->Attachments->ItemsArrayRef };
+
+ if ( $attachments[0] ) {
+ like $attachments[0]->Content, qr/Some content/,
+ "RT's mail includes copy of ticket text";
+ }
+ else {
+ like $msg->Content, qr/Some content/,
+ "RT's mail includes copy of ticket text";
+ }
+
+ if ( $type eq 'plain' ) {
+ ok !$msg->GetHeader('X-RT-Privacy'), "RT's outgoing mail has no crypto";
+ is $msg->GetHeader('X-RT-Incoming-Encryption'), 'Not encrypted',
+ "RT's outgoing mail looks not encrypted";
+ ok !$msg->GetHeader('X-RT-Incoming-Signature'),
+ "RT's outgoing mail looks not signed";
+ }
+ elsif ( $type eq 'signed' ) {
+ is $msg->GetHeader('X-RT-Privacy'), 'PGP',
+ "RT's outgoing mail has crypto";
+ is $msg->GetHeader('X-RT-Incoming-Encryption'), 'Not encrypted',
+ "RT's outgoing mail looks not encrypted";
+ like $msg->GetHeader('X-RT-Incoming-Signature'),
+ qr/<rt-recipient\@example.com>/,
+ "RT's outgoing mail looks signed";
+ }
+ elsif ( $type eq 'encrypted' ) {
+ is $msg->GetHeader('X-RT-Privacy'), 'PGP',
+ "RT's outgoing mail has crypto";
+ is $msg->GetHeader('X-RT-Incoming-Encryption'), 'Success',
+ "RT's outgoing mail looks encrypted";
+ ok !$msg->GetHeader('X-RT-Incoming-Signature'),
+ "RT's outgoing mail looks not signed";
+
+ }
+ elsif ( $type eq 'signed_encrypted' ) {
+ is $msg->GetHeader('X-RT-Privacy'), 'PGP',
+ "RT's outgoing mail has crypto";
+ is $msg->GetHeader('X-RT-Incoming-Encryption'), 'Success',
+ "RT's outgoing mail looks encrypted";
+ like $msg->GetHeader('X-RT-Incoming-Signature'),
+ qr/<rt-recipient\@example.com>/,
+ "RT's outgoing mail looks signed";
+ }
+ else {
+ die "unknown type: $type";
+ }
+}
+
+sub create_and_test_outgoing_emails {
+ my $queue = shift;
+ my $m = shift;
+ my @variants =
+ ( {}, { Sign => 1 }, { Encrypt => 1 }, { Sign => 1, Encrypt => 1 }, );
+
+ # collect emails
+ my %mail;
+
+ # create a ticket for each combination
+ foreach my $ticket_set (@variants) {
+ create_a_ticket( $queue, \%mail, $m, %$ticket_set );
+ }
+
+ my $tid;
+ {
+ my $ticket = RT::Ticket->new( RT->SystemUser );
+ ($tid) = $ticket->Create(
+ Subject => 'test',
+ Queue => $queue->id,
+ Requestor => 'rt-test@example.com',
+ );
+ ok $tid, 'ticket created';
+ }
+
+ # again for each combination add a reply message
+ foreach my $ticket_set (@variants) {
+ update_ticket( $tid, \%mail, $m, %$ticket_set );
+ }
+
+# ------------------------------------------------------------------------------
+# now delete all keys from the keyring and put back secret/pub pair for rt-test@
+# and only public key for rt-recipient@ so we can verify signatures and decrypt
+# like we are on another side recieve emails
+# ------------------------------------------------------------------------------
+
+ unlink $_
+ foreach glob( RT->Config->Get('GnuPGOptions')->{'homedir'} . "/*" );
+ RT::Test->import_gnupg_key( 'rt-recipient@example.com', 'public' );
+ RT::Test->import_gnupg_key('rt-test@example.com');
+
+ $queue = RT::Test->load_or_create_queue(
+ Name => 'Regression',
+ CorrespondAddress => 'rt-test@example.com',
+ CommentAddress => 'rt-test@example.com',
+ );
+ ok $queue && $queue->id, 'changed props of the queue';
+
+ for my $type ( keys %mail ) {
+ for my $mail ( map cleanup_headers($_), @{ $mail{$type} } ) {
+ send_email_and_check_transaction( $mail, $type );
+ }
+ }
+}
diff --git a/rt/lib/RT/Test/Web.pm b/rt/lib/RT/Test/Web.pm
index 62432d333..c2d9ac314 100644
--- a/rt/lib/RT/Test/Web.pm
+++ b/rt/lib/RT/Test/Web.pm
@@ -2,7 +2,7 @@
#
# COPYRIGHT:
#
-# This software is Copyright (c) 1996-2011 Best Practical Solutions, LLC
+# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC
# <sales@bestpractical.com>
#
# (Except where explicitly superseded by other copyright notices)
@@ -52,10 +52,24 @@ use strict;
use warnings;
use base qw(Test::WWW::Mechanize);
+use Scalar::Util qw(weaken);
-require RT::Test;
+BEGIN { require RT::Test; }
require Test::More;
+my $instance;
+
+sub new {
+ my ($class, @args) = @_;
+
+ push @args, app => $RT::Test::TEST_APP if $RT::Test::TEST_APP;
+ my $self = $instance = $class->SUPER::new(@args);
+ weaken $instance;
+ $self->cookie_jar(HTTP::Cookies->new);
+
+ return $self;
+}
+
sub get_ok {
my $self = shift;
my $url = shift;
@@ -76,8 +90,9 @@ sub login {
my $self = shift;
my $user = shift || 'root';
my $pass = shift || 'password';
+ my %args = @_;
- $self->logout;
+ $self->logout if $args{logout};
my $url = $self->rt_base_url;
$self->get($url . "?user=$user;pass=$pass");
@@ -85,11 +100,12 @@ sub login {
Test::More::diag( "error: status is ". $self->status );
return 0;
}
- unless ( $self->content =~ qr/Logout/i ) {
+ unless ( $self->content =~ m/Logout/i ) {
Test::More::diag("error: page has no Logout");
return 0;
}
- unless ( $self->content =~ m{<span>\Q$user\E</span>}i ) {
+ RT::Interface::Web::EscapeUTF8(\$user);
+ unless ( $self->content =~ m{<span class="current-user">\Q$user\E</span>}i ) {
Test::More::diag("Page has no user name");
return 0;
}
@@ -104,7 +120,7 @@ sub logout {
Test::More::diag( "error: status is ". $self->status )
unless $self->status == 200;
- if ( $self->content =~ qr/Logout/i ) {
+ if ( $self->content =~ /Logout/i ) {
$self->follow_link( text => 'Logout' );
Test::More::diag( "error: status is ". $self->status ." when tried to logout" )
unless $self->status == 200;
@@ -114,7 +130,7 @@ sub logout {
}
$self->get($url);
- if ( $self->content =~ qr/Logout/i ) {
+ if ( $self->content =~ /Logout/i ) {
Test::More::diag( "error: couldn't logout" );
return 0;
}
@@ -130,7 +146,7 @@ sub goto_ticket {
}
my $url = $self->rt_base_url;
- $url .= "/Ticket/Display.html?id=$id";
+ $url .= "Ticket/Display.html?id=$id";
$self->get($url);
unless ( $self->status == 200 ) {
Test::More::diag( "error: status is ". $self->status );
@@ -152,24 +168,26 @@ sub goto_create_ticket {
die "not yet implemented";
}
- $self->get('/');
- $self->form_name('CreateTicketInQueue');
- $self->select( 'Queue', $id );
- $self->submit;
+ $self->get($self->rt_base_url . 'Ticket/Create.html?Queue='.$id);
return 1;
}
sub get_warnings {
my $self = shift;
- my $server_class = 'RT::Interface::Web::Standalone';
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
- my $url = $server_class->test_warning_path;
+ # We clone here so that when we fetch warnings, we don't disrupt the state
+ # of the test's mech. If we reuse the original mech then you can't
+ # test warnings immediately after fetching page XYZ, then fill out
+ # forms on XYZ. This is because the most recently fetched page has changed
+ # from XYZ to /__test_warnings, which has no form.
+ my $clone = $self->clone;
+ return unless $clone->get_ok('/__test_warnings');
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- return unless $self->get_ok($url);
+ use Storable 'thaw';
- my @warnings = $server_class->decode_warnings($self->content);
+ my @warnings = @{ thaw $clone->content };
return @warnings;
}
@@ -196,6 +214,26 @@ sub warning_like {
return Test::More::like($warnings[0], $re, $name);
}
+sub next_warning_like {
+ my $self = shift;
+ my $re = shift;
+ my $name = shift;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ if (@{ $self->{stashed_server_warnings} || [] } == 0) {
+ my @warnings = $self->get_warnings;
+ if (@warnings == 0) {
+ Test::More::fail("no warnings emitted; expected 1");
+ return 0;
+ }
+ $self->{stashed_server_warnings} = \@warnings;
+ }
+
+ my $warning = shift @{ $self->{stashed_server_warnings} };
+ return Test::More::like($warning, $re, $name);
+}
+
sub no_warnings_ok {
my $self = shift;
my $name = shift || "no warnings emitted";
@@ -212,4 +250,135 @@ sub no_warnings_ok {
return @warnings == 0 ? 1 : 0;
}
+sub no_leftover_warnings_ok {
+ my $self = shift;
+
+ my $name = shift || "no leftover warnings";
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ # we clear the warnings because we don't want to break later tests
+ # in case there *are* leftover warnings
+ my @warnings = splice @{ $self->{stashed_server_warnings} || [] };
+
+ Test::More::is(@warnings, 0, $name);
+ for (@warnings) {
+ Test::More::diag("leftover warning: $_");
+ }
+
+ return @warnings == 0 ? 1 : 0;
+}
+
+sub ticket_status {
+ my $self = shift;
+ my $id = shift;
+
+ $self->display_ticket( $id);
+ my ($got) = ($self->content =~ m{Status:\s*</td>\s*<td[^>]*?class="value"[^>]*?>\s*([\w ]+?)\s*</td>}ism);
+ unless ( $got ) {
+ Test::More::diag("Error: couldn't find status value on the page, may be regexp problem");
+ }
+ return $got;
+}
+
+sub ticket_status_is {
+ my $self = shift;
+ my $id = shift;
+ my $status = shift;
+ my $desc = shift || "Status of the ticket #$id is '$status'";
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ return Test::More::is($self->ticket_status( $id), $status, $desc);
+}
+
+sub get_ticket_id {
+ my $self = shift;
+ my $content = $self->content;
+ my $id = 0;
+ if ($content =~ /.*Ticket (\d+) created.*/g) {
+ $id = $1;
+ }
+ elsif ($content =~ /.*No permission to view newly created ticket #(\d+).*/g) {
+ Test::More::diag("\nNo permissions to view the ticket.\n") if($ENV{'TEST_VERBOSE'});
+ $id = $1;
+ }
+ return $id;
+}
+
+sub set_custom_field {
+ my $self = shift;
+ my $queue = shift;
+ my $cf_name = shift;
+ my $val = shift;
+
+ my $field_name = $self->custom_field_input( $queue, $cf_name )
+ or return 0;
+
+ $self->field($field_name, $val);
+ return 1;
+}
+
+sub custom_field_input {
+ my $self = shift;
+ my $queue = shift;
+ my $cf_name = shift;
+
+ my $cf_obj = RT::CustomField->new( $RT::SystemUser );
+ $cf_obj->LoadByName( Queue => $queue, Name => $cf_name );
+ unless ( $cf_obj->id ) {
+ Test::More::diag("Can not load custom field '$cf_name' in queue '$queue'");
+ return undef;
+ }
+ my $cf_id = $cf_obj->id;
+
+ my ($res) =
+ grep /^Object-RT::Ticket-\d*-CustomField-$cf_id-Values?$/,
+ map $_->name,
+ $self->current_form->inputs;
+ unless ( $res ) {
+ Test::More::diag("Can not find input for custom field '$cf_name' #$cf_id");
+ return undef;
+ }
+ return $res;
+}
+
+sub check_links {
+ my $self = shift;
+ my %args = @_;
+
+ my %has = map {$_ => 1} @{ $args{'has'} };
+ my %has_no = map {$_ => 1} @{ $args{'has_no'} };
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ my @found;
+
+ my @links = $self->followable_links;
+ foreach my $text ( grep defined && length, map $_->text, @links ) {
+ push @found, $text if $has_no{ $text };
+ delete $has{ $text };
+ }
+ if ( @found || keys %has ) {
+ Test::More::ok( 0, "expected links" );
+ Test::More::diag( "didn't expect, but found: ". join ', ', map "'$_'", @found )
+ if @found;
+ Test::More::diag( "didn't find, but expected: ". join ', ', map "'$_'", keys %has )
+ if keys %has;
+ return 0;
+ }
+ return Test::More::ok( 1, "expected links" );
+}
+
+sub DESTROY {
+ my $self = shift;
+ if ( !$RT::Test::Web::DESTROY++ ) {
+ $self->no_warnings_ok;
+ }
+}
+
+END {
+ return unless $instance;
+ return if RT::Test->builder->{Original_Pid} != $$;
+ $instance->no_warnings_ok if !$RT::Test::Web::DESTROY++;
+}
+
1;
generated by cgit v1.2.1 (git 2.18.0) at 2025-12-25 09:40:14 +0000