Upgrade to 4.0.8 with mod of ExternalAuth + absolute paths to ticket-menu.
[usit-rt.git] / lib / RT / Test.pm
CommitLineData
84fb5b46
MKG
1# BEGIN BPS TAGGED BLOCK {{{
2#
3# COPYRIGHT:
4#
5# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC
6# <sales@bestpractical.com>
7#
8# (Except where explicitly superseded by other copyright notices)
9#
10#
11# LICENSE:
12#
13# This work is made available to you under the terms of Version 2 of
14# the GNU General Public License. A copy of that license should have
15# been provided with this software, but in any event can be snarfed
16# from www.gnu.org.
17#
18# This work is distributed in the hope that it will be useful, but
19# WITHOUT ANY WARRANTY; without even the implied warranty of
20# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21# General Public License for more details.
22#
23# You should have received a copy of the GNU General Public License
24# along with this program; if not, write to the Free Software
25# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26# 02110-1301 or visit their web page on the internet at
27# http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
28#
29#
30# CONTRIBUTION SUBMISSION POLICY:
31#
32# (The following paragraph is not intended to limit the rights granted
33# to you to modify and distribute this software under the terms of
34# the GNU General Public License and is only of importance to you if
35# you choose to contribute your changes and enhancements to the
36# community by submitting them to Best Practical Solutions, LLC.)
37#
38# By intentionally submitting any modifications, corrections or
39# derivatives to this work, or any other work intended for use with
40# Request Tracker, to Best Practical Solutions, LLC, you confirm that
41# you are the copyright holder for those contributions and you grant
42# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
43# royalty-free, perpetual, license to use, copy, create derivative
44# works based on those contributions, and sublicense and distribute
45# those contributions and any derivatives thereof.
46#
47# END BPS TAGGED BLOCK }}}
48
49package RT::Test;
50
51use strict;
52use warnings;
53
54
55use base 'Test::More';
56
57use Socket;
58use File::Temp qw(tempfile);
59use File::Path qw(mkpath);
60use File::Spec;
61
62our @EXPORT = qw(is_empty diag parse_mail works fails);
63
64my %tmp = (
65 directory => undef,
66 config => {
67 RT => undef,
68 apache => undef,
69 },
70 mailbox => undef,
71);
72
73my %rttest_opt;
74
75=head1 NAME
76
77RT::Test - RT Testing
78
79=head1 NOTES
80
81=head2 COVERAGE
82
83To run the rt test suite with coverage support, install L<Devel::Cover> and run:
84
85 make test RT_DBA_USER=.. RT_DBA_PASSWORD=.. HARNESS_PERL_SWITCHES=-MDevel::Cover
86 cover -ignore_re '^var/mason_data/' -ignore_re '^t/'
87
88The coverage tests have DevelMode turned off, and have
89C<named_component_subs> enabled for L<HTML::Mason> to avoid an optimizer
90problem in Perl that hides the top-level optree from L<Devel::Cover>.
91
92=cut
93
94our $port;
95our @SERVERS;
96
97sub import {
98 my $class = shift;
99 my %args = %rttest_opt = @_;
100
101 # Spit out a plan (if we got one) *before* we load modules
102 if ( $args{'tests'} ) {
103 $class->builder->plan( tests => $args{'tests'} )
104 unless $args{'tests'} eq 'no_declare';
105 }
106 elsif ( exists $args{'tests'} ) {
107 # do nothing if they say "tests => undef" - let them make the plan
108 }
109 elsif ( $args{'skip_all'} ) {
110 $class->builder->plan(skip_all => $args{'skip_all'});
111 }
112 else {
113 $class->builder->no_plan unless $class->builder->has_plan;
114 }
115
116 push @{ $args{'plugins'} ||= [] }, @{ $args{'requires'} }
117 if $args{'requires'};
118 push @{ $args{'plugins'} ||= [] }, $args{'testing'}
119 if $args{'testing'};
120
121 $class->bootstrap_tempdir;
122
123 $class->bootstrap_port;
124
125 $class->bootstrap_plugins_paths( %args );
126
127 $class->bootstrap_config( %args );
128
129 use RT;
130 RT::LoadConfig;
131
132 if (RT->Config->Get('DevelMode')) { require Module::Refresh; }
133
84fb5b46 134 RT::InitPluginPaths();
dab09ea8
MKG
135 RT::InitClasses();
136
137 $class->bootstrap_db( %args );
84fb5b46
MKG
138
139 __reconnect_rt()
140 unless $args{nodb};
141
84fb5b46
MKG
142 RT::InitLogging();
143
144 RT->Plugins;
145
146 RT::I18N->Init();
147 RT->Config->PostLoadCheck;
148
149 $class->set_config_wrapper;
150
151 my $screen_logger = $RT::Logger->remove( 'screen' );
152 require Log::Dispatch::Perl;
153 $RT::Logger->add( Log::Dispatch::Perl->new
154 ( name => 'rttest',
155 min_level => $screen_logger->min_level,
156 action => { error => 'warn',
157 critical => 'warn' } ) );
158
159 # XXX: this should really be totally isolated environment so we
160 # can parallelize and be sane
161 mkpath [ $RT::MasonSessionDir ]
162 if RT->Config->Get('DatabaseType');
163
164 my $level = 1;
165 while ( my ($package) = caller($level-1) ) {
166 last unless $package =~ /Test/;
167 $level++;
168 }
169
170 Test::More->export_to_level($level);
171
172 # blow away their diag so we can redefine it without warning
173 # better than "no warnings 'redefine'" because we might accidentally
174 # suppress a mistaken redefinition
175 no strict 'refs';
176 delete ${ caller($level) . '::' }{diag};
177 __PACKAGE__->export_to_level($level);
178}
179
180sub is_empty($;$) {
181 my ($v, $d) = shift;
182 local $Test::Builder::Level = $Test::Builder::Level + 1;
183 return Test::More::ok(1, $d) unless defined $v;
184 return Test::More::ok(1, $d) unless length $v;
185 return Test::More::is($v, '', $d);
186}
187
188my $created_new_db; # have we created new db? mainly for parallel testing
189
190sub db_requires_no_dba {
191 my $self = shift;
192 my $db_type = RT->Config->Get('DatabaseType');
193 return 1 if $db_type eq 'SQLite';
194}
195
196sub bootstrap_port {
197 my $class = shift;
198
199 my %ports;
200
201 # Determine which ports are in use
202 use Fcntl qw(:DEFAULT :flock);
203 my $portfile = "$tmp{'directory'}/../ports";
204 sysopen(PORTS, $portfile, O_RDWR|O_CREAT)
205 or die "Can't write to ports file $portfile: $!";
206 flock(PORTS, LOCK_EX)
207 or die "Can't write-lock ports file $portfile: $!";
208 $ports{$_}++ for split ' ', join("",<PORTS>);
209
210 # Pick a random port, checking that the port isn't in our in-use
211 # list, and that something isn't already listening there.
212 {
213 $port = 1024 + int rand(10_000) + $$ % 1024;
214 redo if $ports{$port};
215
216 # There is a race condition in here, where some non-RT::Test
217 # process claims the port after we check here but before our
218 # server binds. However, since we mostly care about race
219 # conditions with ourselves under high concurrency, this is
220 # generally good enough.
221 my $paddr = sockaddr_in( $port, inet_aton('localhost') );
222 socket( SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
223 or die "socket: $!";
224 if ( connect( SOCK, $paddr ) ) {
225 close(SOCK);
226 redo;
227 }
228 close(SOCK);
229 }
230
231 $ports{$port}++;
232
233 # Write back out the in-use ports
234 seek(PORTS, 0, 0);
235 truncate(PORTS, 0);
236 print PORTS "$_\n" for sort {$a <=> $b} keys %ports;
237 close(PORTS) or die "Can't close ports file: $!";
238}
239
240sub bootstrap_tempdir {
241 my $self = shift;
242 my ($test_dir, $test_file) = ('t', '');
243
244 if (File::Spec->rel2abs($0) =~ m{(?:^|[\\/])(x?t)[/\\](.*)}) {
245 $test_dir = $1;
246 $test_file = "$2-";
247 $test_file =~ s{[/\\]}{-}g;
248 }
249
250 my $dir_name = File::Spec->rel2abs("$test_dir/tmp");
251 mkpath( $dir_name );
252 return $tmp{'directory'} = File::Temp->newdir(
253 "${test_file}XXXXXXXX",
254 DIR => $dir_name
255 );
256}
257
258sub bootstrap_config {
259 my $self = shift;
260 my %args = @_;
261
262 $tmp{'config'}{'RT'} = File::Spec->catfile(
263 "$tmp{'directory'}", 'RT_SiteConfig.pm'
264 );
265 open( my $config, '>', $tmp{'config'}{'RT'} )
266 or die "Couldn't open $tmp{'config'}{'RT'}: $!";
267
268 my $dbname = $ENV{RT_TEST_PARALLEL}? "rt4test_$port" : "rt4test";
269 print $config qq{
270Set( \$WebDomain, "localhost");
271Set( \$WebPort, $port);
272Set( \$WebPath, "");
273Set( \@LexiconLanguages, qw(en zh_TW fr ja));
274Set( \$RTAddressRegexp , qr/^bad_re_that_doesnt_match\$/i);
275};
276 if ( $ENV{'RT_TEST_DB_SID'} ) { # oracle case
277 print $config "Set( \$DatabaseName , '$ENV{'RT_TEST_DB_SID'}' );\n";
278 print $config "Set( \$DatabaseUser , '$dbname');\n";
279 } else {
280 print $config "Set( \$DatabaseName , '$dbname');\n";
281 print $config "Set( \$DatabaseUser , 'u${dbname}');\n";
282 }
283
284 if ( $args{'plugins'} ) {
285 print $config "Set( \@Plugins, qw(". join( ' ', @{ $args{'plugins'} } ) .") );\n";
286 }
287
288 if ( $INC{'Devel/Cover.pm'} ) {
289 print $config "Set( \$DevelMode, 0 );\n";
290 }
291 elsif ( $ENV{RT_TEST_DEVEL} ) {
292 print $config "Set( \$DevelMode, 1 );\n";
293 }
294 else {
295 print $config "Set( \$DevelMode, 0 );\n";
296 }
297
298 $self->bootstrap_logging( $config );
299
300 # set mail catcher
301 my $mail_catcher = $tmp{'mailbox'} = File::Spec->catfile(
302 $tmp{'directory'}->dirname, 'mailbox.eml'
303 );
304 print $config <<END;
305Set( \$MailCommand, sub {
306 my \$MIME = shift;
307
308 open( my \$handle, '>>', '$mail_catcher' )
309 or die "Unable to open '$mail_catcher' for appending: \$!";
310
311 \$MIME->print(\$handle);
312 print \$handle "%% split me! %%\n";
313 close \$handle;
314} );
315END
316
317 $self->bootstrap_more_config($config, \%args);
318
319 print $config $args{'config'} if $args{'config'};
320
321 print $config "\n1;\n";
322 $ENV{'RT_SITE_CONFIG'} = $tmp{'config'}{'RT'};
323 close $config;
324
325 return $config;
326}
327
328sub bootstrap_more_config { }
329
330sub bootstrap_logging {
331 my $self = shift;
332 my $config = shift;
333
334 # prepare file for logging
335 $tmp{'log'}{'RT'} = File::Spec->catfile(
336 "$tmp{'directory'}", 'rt.debug.log'
337 );
338 open( my $fh, '>', $tmp{'log'}{'RT'} )
339 or die "Couldn't open $tmp{'config'}{'RT'}: $!";
340 # make world writable so apache under different user
341 # can write into it
342 chmod 0666, $tmp{'log'}{'RT'};
343
344 print $config <<END;
345Set( \$LogToSyslog , undef);
346Set( \$LogToScreen , "warning");
347Set( \$LogToFile, 'debug' );
348Set( \$LogDir, q{$tmp{'directory'}} );
349Set( \$LogToFileNamed, 'rt.debug.log' );
350END
351}
352
353sub set_config_wrapper {
354 my $self = shift;
355
356 my $old_sub = \&RT::Config::Set;
357 no warnings 'redefine';
358 *RT::Config::Set = sub {
359 # Determine if the caller is either from a test script, or
360 # from helper functions called by test script to alter
361 # configuration that should be written. This is necessary
362 # because some extensions (RTIR, for example) temporarily swap
363 # configuration values out and back in Mason during requests.
364 my @caller = caller(1); # preserve list context
365 @caller = caller(0) unless @caller;
366
367 if ( ($caller[1]||'') =~ /\.t$/) {
368 my ($self, $name) = @_;
369 my $type = $RT::Config::META{$name}->{'Type'} || 'SCALAR';
370 my %sigils = (
371 HASH => '%',
372 ARRAY => '@',
373 SCALAR => '$',
374 );
375 my $sigil = $sigils{$type} || $sigils{'SCALAR'};
376 open( my $fh, '>>', $tmp{'config'}{'RT'} )
377 or die "Couldn't open config file: $!";
378 require Data::Dumper;
379 local $Data::Dumper::Terse = 1;
380 my $dump = Data::Dumper::Dumper([@_[2 .. $#_]]);
381 $dump =~ s/;\s+$//;
382 print $fh
383 "\nSet(${sigil}${name}, \@{". $dump ."});\n1;\n";
384 close $fh;
385
386 if ( @SERVERS ) {
387 warn "you're changing config option in a test file"
388 ." when server is active";
389 }
390 }
391 return $old_sub->(@_);
392 };
393}
394
395sub bootstrap_db {
396 my $self = shift;
397 my %args = @_;
398
399 unless (defined $ENV{'RT_DBA_USER'} && defined $ENV{'RT_DBA_PASSWORD'}) {
400 Test::More::BAIL_OUT(
401 "RT_DBA_USER and RT_DBA_PASSWORD environment variables need"
402 ." to be set in order to run 'make test'"
403 ) unless $self->db_requires_no_dba;
404 }
405
406 require RT::Handle;
407 if (my $forceopt = $ENV{RT_TEST_FORCE_OPT}) {
408 Test::More::diag "forcing $forceopt";
409 $args{$forceopt}=1;
410 }
411
b5747ff2
MKG
412 # Short-circuit the rest of ourselves if we don't want a db
413 if ($args{nodb}) {
414 __drop_database();
415 return;
416 }
84fb5b46
MKG
417
418 my $db_type = RT->Config->Get('DatabaseType');
419 __create_database();
420 __reconnect_rt('as dba');
421 $RT::Handle->InsertSchema;
422 $RT::Handle->InsertACL unless $db_type eq 'Oracle';
423
424 RT->InitLogging;
425 __reconnect_rt();
426
427 $RT::Handle->InsertInitialData
428 unless $args{noinitialdata};
429
430 $RT::Handle->InsertData( $RT::EtcPath . "/initialdata" )
431 unless $args{noinitialdata} or $args{nodata};
432
433 $self->bootstrap_plugins_db( %args );
434}
435
436sub bootstrap_plugins_paths {
437 my $self = shift;
438 my %args = @_;
439
440 return unless $args{'plugins'};
441 my @plugins = @{ $args{'plugins'} };
442
443 my $cwd;
444 if ( $args{'testing'} ) {
445 require Cwd;
446 $cwd = Cwd::getcwd();
447 }
448
449 require RT::Plugin;
450 my $old_func = \&RT::Plugin::_BasePath;
451 no warnings 'redefine';
452 *RT::Plugin::_BasePath = sub {
453 my $name = $_[0]->{'name'};
454
455 return $cwd if $args{'testing'} && $name eq $args{'testing'};
456
457 if ( grep $name eq $_, @plugins ) {
458 my $variants = join "(?:|::|-|_)", map "\Q$_\E", split /::/, $name;
459 my ($path) = map $ENV{$_}, grep /^CHIMPS_(?:$variants).*_ROOT$/i, keys %ENV;
460 return $path if $path;
461 }
462 return $old_func->(@_);
463 };
464}
465
466sub bootstrap_plugins_db {
467 my $self = shift;
468 my %args = @_;
469
470 return unless $args{'plugins'};
471
472 require File::Spec;
473
474 my @plugins = @{ $args{'plugins'} };
475 foreach my $name ( @plugins ) {
476 my $plugin = RT::Plugin->new( name => $name );
477 Test::More::diag( "Initializing DB for the $name plugin" )
478 if $ENV{'TEST_VERBOSE'};
479
480 my $etc_path = $plugin->Path('etc');
481 Test::More::diag( "etc path of the plugin is '$etc_path'" )
482 if $ENV{'TEST_VERBOSE'};
483
484 unless ( -e $etc_path ) {
485 # We can't tell if the plugin has no data, or we screwed up the etc/ path
486 Test::More::ok(1, "There is no etc dir: no schema" );
487 Test::More::ok(1, "There is no etc dir: no ACLs" );
488 Test::More::ok(1, "There is no etc dir: no data" );
489 next;
490 }
491
492 __reconnect_rt('as dba');
493
494 { # schema
495 my ($ret, $msg) = $RT::Handle->InsertSchema( undef, $etc_path );
496 Test::More::ok($ret || $msg =~ /^Couldn't find schema/, "Created schema: ".($msg||''));
497 }
498
499 { # ACLs
500 my ($ret, $msg) = $RT::Handle->InsertACL( undef, $etc_path );
501 Test::More::ok($ret || $msg =~ /^Couldn't find ACLs/, "Created ACL: ".($msg||''));
502 }
503
504 # data
505 my $data_file = File::Spec->catfile( $etc_path, 'initialdata' );
506 if ( -e $data_file ) {
507 __reconnect_rt();
508 my ($ret, $msg) = $RT::Handle->InsertData( $data_file );;
509 Test::More::ok($ret, "Inserted data".($msg||''));
510 } else {
511 Test::More::ok(1, "There is no data file" );
512 }
513 }
514 __reconnect_rt();
515}
516
517sub _get_dbh {
518 my ($dsn, $user, $pass) = @_;
519 if ( $dsn =~ /Oracle/i ) {
520 $ENV{'NLS_LANG'} = "AMERICAN_AMERICA.AL32UTF8";
521 $ENV{'NLS_NCHAR'} = "AL32UTF8";
522 }
523 my $dbh = DBI->connect(
524 $dsn, $user, $pass,
525 { RaiseError => 0, PrintError => 1 },
526 );
527 unless ( $dbh ) {
528 my $msg = "Failed to connect to $dsn as user '$user': ". $DBI::errstr;
529 print STDERR $msg; exit -1;
530 }
531 return $dbh;
532}
533
534sub __create_database {
535 # bootstrap with dba cred
536 my $dbh = _get_dbh(
537 RT::Handle->SystemDSN,
538 $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD}
539 );
540
541 unless ( $ENV{RT_TEST_PARALLEL} ) {
542 # already dropped db in parallel tests, need to do so for other cases.
543 __drop_database( $dbh );
544
545 }
546 RT::Handle->CreateDatabase( $dbh );
547 $dbh->disconnect;
548 $created_new_db++;
549}
550
551sub __drop_database {
552 my $dbh = shift;
553
554 # Pg doesn't like if you issue a DROP DATABASE while still connected
555 # it's still may fail if web-server is out there and holding a connection
556 __disconnect_rt();
557
558 my $my_dbh = $dbh? 0 : 1;
559 $dbh ||= _get_dbh(
560 RT::Handle->SystemDSN,
561 $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD}
562 );
b5747ff2
MKG
563
564 # We ignore errors intentionally by not checking the return value of
565 # DropDatabase below, so let's also suppress DBI's printing of errors when
566 # we overzealously drop.
567 local $dbh->{PrintError} = 0;
568 local $dbh->{PrintWarn} = 0;
569
84fb5b46
MKG
570 RT::Handle->DropDatabase( $dbh );
571 $dbh->disconnect if $my_dbh;
572}
573
574sub __reconnect_rt {
575 my $as_dba = shift;
576 __disconnect_rt();
577
578 # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation
579 $RT::Handle = RT::Handle->new;
580 $RT::Handle->dbh( undef );
581 $RT::Handle->Connect(
582 $as_dba
583 ? (User => $ENV{RT_DBA_USER}, Password => $ENV{RT_DBA_PASSWORD})
584 : ()
585 );
586 $RT::Handle->PrintError;
587 $RT::Handle->dbh->{PrintError} = 1;
588 return $RT::Handle->dbh;
589}
590
591sub __disconnect_rt {
592 # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation
593 $RT::Handle->dbh->disconnect if $RT::Handle and $RT::Handle->dbh;
594
595 %DBIx::SearchBuilder::Handle::DBIHandle = ();
596 $DBIx::SearchBuilder::Handle::PrevHandle = undef;
597
598 $RT::Handle = undef;
599
600 delete $RT::System->{attributes};
601
602 DBIx::SearchBuilder::Record::Cachable->FlushCache
603 if DBIx::SearchBuilder::Record::Cachable->can("FlushCache");
604}
605
606
607=head1 UTILITIES
608
609=head2 load_or_create_user
610
611=cut
612
613sub load_or_create_user {
614 my $self = shift;
615 my %args = ( Privileged => 1, Disabled => 0, @_ );
616
617 my $MemberOf = delete $args{'MemberOf'};
618 $MemberOf = [ $MemberOf ] if defined $MemberOf && !ref $MemberOf;
619 $MemberOf ||= [];
620
621 my $obj = RT::User->new( RT->SystemUser );
622 if ( $args{'Name'} ) {
623 $obj->LoadByCols( Name => $args{'Name'} );
624 } elsif ( $args{'EmailAddress'} ) {
625 $obj->LoadByCols( EmailAddress => $args{'EmailAddress'} );
626 } else {
627 die "Name or EmailAddress is required";
628 }
629 if ( $obj->id ) {
630 # cool
631 $obj->SetPrivileged( $args{'Privileged'} || 0 )
632 if ($args{'Privileged'}||0) != ($obj->Privileged||0);
633 $obj->SetDisabled( $args{'Disabled'} || 0 )
634 if ($args{'Disabled'}||0) != ($obj->Disabled||0);
635 } else {
636 my ($val, $msg) = $obj->Create( %args );
637 die "$msg" unless $val;
638 }
639
640 # clean group membership
641 {
642 require RT::GroupMembers;
643 my $gms = RT::GroupMembers->new( RT->SystemUser );
644 my $groups_alias = $gms->Join(
645 FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id',
646 );
647 $gms->Limit( ALIAS => $groups_alias, FIELD => 'Domain', VALUE => 'UserDefined' );
648 $gms->Limit( FIELD => 'MemberId', VALUE => $obj->id );
649 while ( my $group_member_record = $gms->Next ) {
650 $group_member_record->Delete;
651 }
652 }
653
654 # add new user to groups
655 foreach ( @$MemberOf ) {
656 my $group = RT::Group->new( RT::SystemUser() );
657 $group->LoadUserDefinedGroup( $_ );
658 die "couldn't load group '$_'" unless $group->id;
659 $group->AddMember( $obj->id );
660 }
661
662 return $obj;
663}
664
665=head2 load_or_create_queue
666
667=cut
668
669sub load_or_create_queue {
670 my $self = shift;
671 my %args = ( Disabled => 0, @_ );
672 my $obj = RT::Queue->new( RT->SystemUser );
673 if ( $args{'Name'} ) {
674 $obj->LoadByCols( Name => $args{'Name'} );
675 } else {
676 die "Name is required";
677 }
678 unless ( $obj->id ) {
679 my ($val, $msg) = $obj->Create( %args );
680 die "$msg" unless $val;
681 } else {
682 my @fields = qw(CorrespondAddress CommentAddress);
683 foreach my $field ( @fields ) {
684 next unless exists $args{ $field };
685 next if $args{ $field } eq ($obj->$field || '');
686
687 no warnings 'uninitialized';
688 my $method = 'Set'. $field;
689 my ($val, $msg) = $obj->$method( $args{ $field } );
690 die "$msg" unless $val;
691 }
692 }
693
694 return $obj;
695}
696
697sub delete_queue_watchers {
698 my $self = shift;
699 my @queues = @_;
700
701 foreach my $q ( @queues ) {
702 foreach my $t (qw(Cc AdminCc) ) {
703 $q->DeleteWatcher( Type => $t, PrincipalId => $_->MemberId )
704 foreach @{ $q->$t()->MembersObj->ItemsArrayRef };
705 }
706 }
707}
708
709sub create_tickets {
710 local $Test::Builder::Level = $Test::Builder::Level + 1;
711
712 my $self = shift;
713 my $defaults = shift;
714 my @data = @_;
715 @data = sort { rand(100) <=> rand(100) } @data
716 if delete $defaults->{'RandomOrder'};
717
718 $defaults->{'Queue'} ||= 'General';
719
720 my @res = ();
721 while ( @data ) {
722 my %args = %{ shift @data };
723 $args{$_} = $res[ $args{$_} ]->id foreach
724 grep $args{ $_ }, keys %RT::Ticket::LINKTYPEMAP;
725 push @res, $self->create_ticket( %$defaults, %args );
726 }
727 return @res;
728}
729
730sub create_ticket {
731 local $Test::Builder::Level = $Test::Builder::Level + 1;
732
733 my $self = shift;
734 my %args = @_;
735
736 if ($args{Queue} && $args{Queue} =~ /\D/) {
737 my $queue = RT::Queue->new(RT->SystemUser);
738 if (my $id = $queue->Load($args{Queue}) ) {
739 $args{Queue} = $id;
740 } else {
741 die ("Error: Invalid queue $args{Queue}");
742 }
743 }
744
745 if ( my $content = delete $args{'Content'} ) {
746 $args{'MIMEObj'} = MIME::Entity->build(
747 From => $args{'Requestor'},
748 Subject => $args{'Subject'},
749 Data => $content,
750 );
751 }
752
753 my $ticket = RT::Ticket->new( RT->SystemUser );
754 my ( $id, undef, $msg ) = $ticket->Create( %args );
755 Test::More::ok( $id, "ticket created" )
756 or Test::More::diag("error: $msg");
757
758 # hackish, but simpler
759 if ( $args{'LastUpdatedBy'} ) {
760 $ticket->__Set( Field => 'LastUpdatedBy', Value => $args{'LastUpdatedBy'} );
761 }
762
763
764 for my $field ( keys %args ) {
765 #TODO check links and watchers
766
767 if ( $field =~ /CustomField-(\d+)/ ) {
768 my $cf = $1;
769 my $got = join ',', sort map $_->Content,
770 @{ $ticket->CustomFieldValues($cf)->ItemsArrayRef };
771 my $expected = ref $args{$field}
772 ? join( ',', sort @{ $args{$field} } )
773 : $args{$field};
774 Test::More::is( $got, $expected, 'correct CF values' );
775 }
776 else {
777 next if ref $args{$field};
778 next unless $ticket->can($field) or $ticket->_Accessible($field,"read");
779 next if ref $ticket->$field();
780 Test::More::is( $ticket->$field(), $args{$field}, "$field is correct" );
781 }
782 }
783
784 return $ticket;
785}
786
787sub delete_tickets {
788 my $self = shift;
789 my $query = shift;
790 my $tickets = RT::Tickets->new( RT->SystemUser );
791 if ( $query ) {
792 $tickets->FromSQL( $query );
793 }
794 else {
795 $tickets->UnLimit;
796 }
797 while ( my $ticket = $tickets->Next ) {
798 $ticket->Delete;
799 }
800}
801
802=head2 load_or_create_custom_field
803
804=cut
805
806sub load_or_create_custom_field {
807 my $self = shift;
808 my %args = ( Disabled => 0, @_ );
809 my $obj = RT::CustomField->new( RT->SystemUser );
810 if ( $args{'Name'} ) {
811 $obj->LoadByName( Name => $args{'Name'}, Queue => $args{'Queue'} );
812 } else {
813 die "Name is required";
814 }
815 unless ( $obj->id ) {
816 my ($val, $msg) = $obj->Create( %args );
817 die "$msg" unless $val;
818 }
819
820 return $obj;
821}
822
823sub last_ticket {
824 my $self = shift;
825 my $current = shift;
826 $current = $current ? RT::CurrentUser->new($current) : RT->SystemUser;
827 my $tickets = RT::Tickets->new( $current );
828 $tickets->OrderBy( FIELD => 'id', ORDER => 'DESC' );
829 $tickets->Limit( FIELD => 'id', OPERATOR => '>', VALUE => '0' );
830 $tickets->RowsPerPage( 1 );
831 return $tickets->First;
832}
833
834sub store_rights {
835 my $self = shift;
836
837 require RT::ACE;
838 # fake construction
839 RT::ACE->new( RT->SystemUser );
840 my @fields = keys %{ RT::ACE->_ClassAccessible };
841
842 require RT::ACL;
843 my $acl = RT::ACL->new( RT->SystemUser );
844 $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
845
846 my @res;
847 while ( my $ace = $acl->Next ) {
848 my $obj = $ace->PrincipalObj->Object;
849 if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == RT->Nobody->id ) {
850 next;
851 }
852
853 my %tmp = ();
854 foreach my $field( @fields ) {
855 $tmp{ $field } = $ace->__Value( $field );
856 }
857 push @res, \%tmp;
858 }
859 return @res;
860}
861
862sub restore_rights {
863 my $self = shift;
864 my @entries = @_;
865 foreach my $entry ( @entries ) {
866 my $ace = RT::ACE->new( RT->SystemUser );
867 my ($status, $msg) = $ace->RT::Record::Create( %$entry );
868 unless ( $status ) {
869 Test::More::diag "couldn't create a record: $msg";
870 }
871 }
872}
873
874sub set_rights {
875 my $self = shift;
876
877 require RT::ACL;
878 my $acl = RT::ACL->new( RT->SystemUser );
879 $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
880 while ( my $ace = $acl->Next ) {
881 my $obj = $ace->PrincipalObj->Object;
882 if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == RT->Nobody->id ) {
883 next;
884 }
885 $ace->Delete;
886 }
887 return $self->add_rights( @_ );
888}
889
890sub add_rights {
891 my $self = shift;
892 my @list = ref $_[0]? @_: @_? { @_ }: ();
893
894 require RT::ACL;
895 foreach my $e (@list) {
896 my $principal = delete $e->{'Principal'};
897 unless ( ref $principal ) {
898 if ( $principal =~ /^(everyone|(?:un)?privileged)$/i ) {
899 $principal = RT::Group->new( RT->SystemUser );
900 $principal->LoadSystemInternalGroup($1);
901 } elsif ( $principal =~ /^(Owner|Requestor|(?:Admin)?Cc)$/i ) {
902 $principal = RT::Group->new( RT->SystemUser );
903 $principal->LoadByCols(
904 Domain => (ref($e->{'Object'})||'RT::System').'-Role',
905 Type => $1,
906 ref($e->{'Object'})? (Instance => $e->{'Object'}->id): (),
907 );
908 } else {
909 die "principal is not an object, but also is not name of a system group";
910 }
911 }
912 unless ( $principal->isa('RT::Principal') ) {
913 if ( $principal->can('PrincipalObj') ) {
914 $principal = $principal->PrincipalObj;
915 }
916 }
917 my @rights = ref $e->{'Right'}? @{ $e->{'Right'} }: ($e->{'Right'});
918 foreach my $right ( @rights ) {
919 my ($status, $msg) = $principal->GrantRight( %$e, Right => $right );
920 $RT::Logger->debug($msg);
921 }
922 }
923 return 1;
924}
925
926sub run_mailgate {
927 my $self = shift;
928
929 require RT::Test::Web;
930 my %args = (
931 url => RT::Test::Web->rt_base_url,
932 message => '',
933 action => 'correspond',
934 queue => 'General',
935 debug => 1,
936 command => $RT::BinPath .'/rt-mailgate',
937 @_
938 );
939 my $message = delete $args{'message'};
940
941 $args{after_open} = sub {
942 my $child_in = shift;
943 if ( UNIVERSAL::isa($message, 'MIME::Entity') ) {
944 $message->print( $child_in );
945 } else {
946 print $child_in $message;
947 }
948 };
949
950 $self->run_and_capture(%args);
951}
952
953sub run_and_capture {
954 my $self = shift;
955 my %args = @_;
956
957 my $after_open = delete $args{after_open};
958
959 my $cmd = delete $args{'command'};
960 die "Couldn't find command ($cmd)" unless -f $cmd;
961
962 $cmd .= ' --debug' if delete $args{'debug'};
963
964 while( my ($k,$v) = each %args ) {
965 next unless $v;
966 $cmd .= " --$k '$v'";
967 }
968 $cmd .= ' 2>&1';
969
970 DBIx::SearchBuilder::Record::Cachable->FlushCache;
971
972 require IPC::Open2;
973 my ($child_out, $child_in);
974 my $pid = IPC::Open2::open2($child_out, $child_in, $cmd);
975
976 $after_open->($child_in, $child_out) if $after_open;
977
978 close $child_in;
979
980 my $result = do { local $/; <$child_out> };
981 close $child_out;
982 waitpid $pid, 0;
983 return ($?, $result);
984}
985
986sub send_via_mailgate_and_http {
987 my $self = shift;
988 my $message = shift;
989 my %args = (@_);
990
991 my ($status, $gate_result) = $self->run_mailgate(
992 message => $message, %args
993 );
994
995 my $id;
996 unless ( $status >> 8 ) {
997 ($id) = ($gate_result =~ /Ticket:\s*(\d+)/i);
998 unless ( $id ) {
999 Test::More::diag "Couldn't find ticket id in text:\n$gate_result"
1000 if $ENV{'TEST_VERBOSE'};
1001 }
1002 } else {
1003 Test::More::diag "Mailgate output:\n$gate_result"
1004 if $ENV{'TEST_VERBOSE'};
1005 }
1006 return ($status, $id);
1007}
1008
1009
1010sub send_via_mailgate {
1011 my $self = shift;
1012 my $message = shift;
1013 my %args = ( action => 'correspond',
1014 queue => 'General',
1015 @_
1016 );
1017
1018 if ( UNIVERSAL::isa( $message, 'MIME::Entity' ) ) {
1019 $message = $message->as_string;
1020 }
1021
1022 my ( $status, $error_message, $ticket )
1023 = RT::Interface::Email::Gateway( {%args, message => $message} );
1024 return ( $status, $ticket ? $ticket->id : 0 );
1025
1026}
1027
1028
1029sub open_mailgate_ok {
1030 my $class = shift;
1031 my $baseurl = shift;
1032 my $queue = shift || 'general';
1033 my $action = shift || 'correspond';
1034 Test::More::ok(open(my $mail, '|-', "$RT::BinPath/rt-mailgate --url $baseurl --queue $queue --action $action"), "Opened the mailgate - $!");
1035 return $mail;
1036}
1037
1038
1039sub close_mailgate_ok {
1040 my $class = shift;
1041 my $mail = shift;
1042 close $mail;
1043 Test::More::is ($? >> 8, 0, "The mail gateway exited normally. yay");
1044}
1045
1046sub mailsent_ok {
1047 my $class = shift;
1048 my $expected = shift;
1049
1050 my $mailsent = scalar grep /\S/, split /%% split me! %%\n/,
1051 RT::Test->file_content(
1052 $tmp{'mailbox'},
1053 'unlink' => 0,
1054 noexist => 1
1055 );
1056
1057 Test::More::is(
1058 $mailsent, $expected,
1059 "The number of mail sent ($expected) matches. yay"
1060 );
1061}
1062
1063sub fetch_caught_mails {
1064 my $self = shift;
1065 return grep /\S/, split /%% split me! %%\n/,
1066 RT::Test->file_content(
1067 $tmp{'mailbox'},
1068 'unlink' => 1,
1069 noexist => 1
1070 );
1071}
1072
1073sub clean_caught_mails {
1074 unlink $tmp{'mailbox'};
1075}
1076
1077=head2 get_relocatable_dir
1078
1079Takes a path relative to the location of the test file that is being
1080run and returns a path that takes the invocation path into account.
1081
1082e.g. RT::Test::get_relocatable_dir(File::Spec->updir(), 'data', 'emails')
1083
1084=cut
1085
1086sub get_relocatable_dir {
1087 (my $volume, my $directories, my $file) = File::Spec->splitpath($0);
1088 if (File::Spec->file_name_is_absolute($directories)) {
1089 return File::Spec->catdir($directories, @_);
1090 } else {
1091 return File::Spec->catdir(File::Spec->curdir(), $directories, @_);
1092 }
1093}
1094
1095=head2 get_relocatable_file
1096
1097Same as get_relocatable_dir, but takes a file and a path instead
1098of just a path.
1099
1100e.g. RT::Test::get_relocatable_file('test-email',
1101 (File::Spec->updir(), 'data', 'emails'))
1102
1103=cut
1104
1105sub get_relocatable_file {
1106 my $file = shift;
1107 return File::Spec->catfile(get_relocatable_dir(@_), $file);
1108}
1109
1110sub get_abs_relocatable_dir {
1111 (my $volume, my $directories, my $file) = File::Spec->splitpath($0);
1112 if (File::Spec->file_name_is_absolute($directories)) {
1113 return File::Spec->catdir($directories, @_);
1114 } else {
1115 return File::Spec->catdir(Cwd->getcwd(), $directories, @_);
1116 }
1117}
1118
1119sub gnupg_homedir {
1120 my $self = shift;
1121 File::Temp->newdir(
1122 DIR => $tmp{directory},
1123 CLEANUP => 0,
1124 );
1125}
1126
1127sub import_gnupg_key {
1128 my $self = shift;
1129 my $key = shift;
1130 my $type = shift || 'secret';
1131
1132 $key =~ s/\@/-at-/g;
1133 $key .= ".$type.key";
1134
1135 require RT::Crypt::GnuPG;
1136
1137 # simple strategy find data/gnupg/keys, from the dir where test file lives
1138 # to updirs, try 3 times in total
1139 my $path = File::Spec->catfile( 'data', 'gnupg', 'keys' );
1140 my $abs_path;
1141 for my $up ( 0 .. 2 ) {
1142 my $p = get_relocatable_dir($path);
1143 if ( -e $p ) {
1144 $abs_path = $p;
1145 last;
1146 }
1147 else {
1148 $path = File::Spec->catfile( File::Spec->updir(), $path );
1149 }
1150 }
1151
1152 die "can't find the dir where gnupg keys are stored"
1153 unless $abs_path;
1154
1155 return RT::Crypt::GnuPG::ImportKey(
1156 RT::Test->file_content( [ $abs_path, $key ] ) );
1157}
1158
1159
1160sub lsign_gnupg_key {
1161 my $self = shift;
1162 my $key = shift;
1163
1164 require RT::Crypt::GnuPG; require GnuPG::Interface;
1165 my $gnupg = GnuPG::Interface->new();
1166 my %opt = RT->Config->Get('GnuPGOptions');
1167 $gnupg->options->hash_init(
1168 RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
1169 meta_interactive => 0,
1170 );
1171
1172 my %handle;
1173 my $handles = GnuPG::Handles->new(
1174 stdin => ($handle{'input'} = IO::Handle->new()),
1175 stdout => ($handle{'output'} = IO::Handle->new()),
1176 stderr => ($handle{'error'} = IO::Handle->new()),
1177 logger => ($handle{'logger'} = IO::Handle->new()),
1178 status => ($handle{'status'} = IO::Handle->new()),
1179 command => ($handle{'command'} = IO::Handle->new()),
1180 );
1181
1182 eval {
1183 local $SIG{'CHLD'} = 'DEFAULT';
1184 local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
1185 my $pid = $gnupg->wrap_call(
1186 handles => $handles,
1187 commands => ['--lsign-key'],
1188 command_args => [$key],
1189 );
1190 close $handle{'input'};
1191 while ( my $str = readline $handle{'status'} ) {
1192 if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL sign_uid\..*/ ) {
1193 print { $handle{'command'} } "y\n";
1194 }
1195 }
1196 waitpid $pid, 0;
1197 };
1198 my $err = $@;
1199 close $handle{'output'};
1200
1201 my %res;
1202 $res{'exit_code'} = $?;
1203 foreach ( qw(error logger status) ) {
1204 $res{$_} = do { local $/; readline $handle{$_} };
1205 delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1206 close $handle{$_};
1207 }
1208 $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1209 $RT::Logger->warning( $res{'error'} ) if $res{'error'};
1210 $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1211 if ( $err || $res{'exit_code'} ) {
1212 $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
1213 }
1214 return %res;
1215}
1216
1217sub trust_gnupg_key {
1218 my $self = shift;
1219 my $key = shift;
1220
1221 require RT::Crypt::GnuPG; require GnuPG::Interface;
1222 my $gnupg = GnuPG::Interface->new();
1223 my %opt = RT->Config->Get('GnuPGOptions');
1224 $gnupg->options->hash_init(
1225 RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
1226 meta_interactive => 0,
1227 );
1228
1229 my %handle;
1230 my $handles = GnuPG::Handles->new(
1231 stdin => ($handle{'input'} = IO::Handle->new()),
1232 stdout => ($handle{'output'} = IO::Handle->new()),
1233 stderr => ($handle{'error'} = IO::Handle->new()),
1234 logger => ($handle{'logger'} = IO::Handle->new()),
1235 status => ($handle{'status'} = IO::Handle->new()),
1236 command => ($handle{'command'} = IO::Handle->new()),
1237 );
1238
1239 eval {
1240 local $SIG{'CHLD'} = 'DEFAULT';
1241 local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
1242 my $pid = $gnupg->wrap_call(
1243 handles => $handles,
1244 commands => ['--edit-key'],
1245 command_args => [$key],
1246 );
1247 close $handle{'input'};
1248
1249 my $done = 0;
1250 while ( my $str = readline $handle{'status'} ) {
1251 if ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE keyedit.prompt/ ) {
1252 if ( $done ) {
1253 print { $handle{'command'} } "quit\n";
1254 } else {
1255 print { $handle{'command'} } "trust\n";
1256 }
1257 } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE edit_ownertrust.value/ ) {
1258 print { $handle{'command'} } "5\n";
1259 } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_BOOL edit_ownertrust.set_ultimate.okay/ ) {
1260 print { $handle{'command'} } "y\n";
1261 $done = 1;
1262 }
1263 }
1264 waitpid $pid, 0;
1265 };
1266 my $err = $@;
1267 close $handle{'output'};
1268
1269 my %res;
1270 $res{'exit_code'} = $?;
1271 foreach ( qw(error logger status) ) {
1272 $res{$_} = do { local $/; readline $handle{$_} };
1273 delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1274 close $handle{$_};
1275 }
1276 $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1277 $RT::Logger->warning( $res{'error'} ) if $res{'error'};
1278 $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1279 if ( $err || $res{'exit_code'} ) {
1280 $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
1281 }
1282 return %res;
1283}
1284
1285sub started_ok {
1286 my $self = shift;
1287
1288 require RT::Test::Web;
1289
b5747ff2
MKG
1290 if ($rttest_opt{nodb} and not $rttest_opt{server_ok}) {
1291 die "You are trying to use a test web server without a database. "
1292 ."You may want noinitialdata => 1 instead. "
1293 ."Pass server_ok => 1 if you know what you're doing.";
84fb5b46
MKG
1294 }
1295
1296
1297 $ENV{'RT_TEST_WEB_HANDLER'} = undef
1298 if $rttest_opt{actual_server} && ($ENV{'RT_TEST_WEB_HANDLER'}||'') eq 'inline';
1299 $ENV{'RT_TEST_WEB_HANDLER'} ||= 'plack';
1300 my $which = $ENV{'RT_TEST_WEB_HANDLER'};
1301 my ($server, $variant) = split /\+/, $which, 2;
1302
1303 my $function = 'start_'. $server .'_server';
1304 unless ( $self->can($function) ) {
1305 die "Don't know how to start server '$server'";
1306 }
1307 return $self->$function( variant => $variant, @_ );
1308}
1309
1310sub test_app {
1311 my $self = shift;
1312 my %server_opt = @_;
1313
b5747ff2
MKG
1314 my $app;
1315
1316 my $warnings = "";
1317 open( my $warn_fh, ">", \$warnings );
1318 local *STDERR = $warn_fh;
1319
1320 if ($server_opt{variant} and $server_opt{variant} eq 'rt-server') {
1321 $app = do {
1322 my $file = "$RT::SbinPath/rt-server";
1323 my $psgi = do $file;
1324 unless ($psgi) {
1325 die "Couldn't parse $file: $@" if $@;
1326 die "Couldn't do $file: $!" unless defined $psgi;
1327 die "Couldn't run $file" unless $psgi;
1328 }
1329 $psgi;
1330 };
1331 } else {
1332 require RT::Interface::Web::Handler;
1333 $app = RT::Interface::Web::Handler->PSGIApp;
1334 }
84fb5b46
MKG
1335
1336 require Plack::Middleware::Test::StashWarnings;
b5747ff2
MKG
1337 my $stashwarnings = Plack::Middleware::Test::StashWarnings->new;
1338 $app = $stashwarnings->wrap($app);
84fb5b46
MKG
1339
1340 if ($server_opt{basic_auth}) {
1341 require Plack::Middleware::Auth::Basic;
1342 $app = Plack::Middleware::Auth::Basic->wrap(
1343 $app,
1344 authenticator => sub {
1345 my ($username, $password) = @_;
1346 return $username eq 'root' && $password eq 'password';
1347 }
1348 );
1349 }
b5747ff2
MKG
1350
1351 close $warn_fh;
1352 $stashwarnings->add_warning( $warnings ) if $warnings;
1353
84fb5b46
MKG
1354 return $app;
1355}
1356
1357sub start_plack_server {
1358 my $self = shift;
1359
1360 require Plack::Loader;
1361 my $plack_server = Plack::Loader->load
1362 ('Standalone',
1363 port => $port,
1364 server_ready => sub {
1365 kill 'USR1' => getppid();
1366 });
1367
1368 # We are expecting a USR1 from the child process after it's ready
1369 # to listen. We set this up _before_ we fork to avoid race
1370 # conditions.
1371 my $handled;
1372 local $SIG{USR1} = sub { $handled = 1};
1373
1374 __disconnect_rt();
1375 my $pid = fork();
1376 die "failed to fork" unless defined $pid;
1377
1378 if ($pid) {
1379 sleep 15 unless $handled;
1380 Test::More::diag "did not get expected USR1 for test server readiness"
1381 unless $handled;
1382 push @SERVERS, $pid;
1383 my $Tester = Test::Builder->new;
1384 $Tester->ok(1, "started plack server ok");
1385
b5747ff2
MKG
1386 __reconnect_rt()
1387 unless $rttest_opt{nodb};
84fb5b46
MKG
1388 return ("http://localhost:$port", RT::Test::Web->new);
1389 }
1390
1391 require POSIX;
1392 if ( $^O !~ /MSWin32/ ) {
1393 POSIX::setsid()
1394 or die "Can't start a new session: $!";
1395 }
1396
1397 # stick this in a scope so that when $app is garbage collected,
1398 # StashWarnings can complain about unhandled warnings
1399 do {
1400 $plack_server->run($self->test_app(@_));
1401 };
1402
1403 exit;
1404}
1405
1406our $TEST_APP;
1407sub start_inline_server {
1408 my $self = shift;
1409
1410 require Test::WWW::Mechanize::PSGI;
1411 unshift @RT::Test::Web::ISA, 'Test::WWW::Mechanize::PSGI';
1412
1413 # Clear out squished CSS and JS cache, since it's retained across
1414 # servers, since it's in-process
1415 RT::Interface::Web->ClearSquished;
1416
1417 Test::More::ok(1, "psgi test server ok");
1418 $TEST_APP = $self->test_app(@_);
1419 return ("http://localhost:$port", RT::Test::Web->new);
1420}
1421
1422sub start_apache_server {
1423 my $self = shift;
1424 my %server_opt = @_;
1425 $server_opt{variant} ||= 'mod_perl';
1426 $ENV{RT_TEST_WEB_HANDLER} = "apache+$server_opt{variant}";
1427
1428 require RT::Test::Apache;
1429 my $pid = RT::Test::Apache->start_server(
1430 %server_opt,
1431 port => $port,
1432 tmp => \%tmp
1433 );
1434 push @SERVERS, $pid;
1435
1436 my $url = RT->Config->Get('WebURL');
1437 $url =~ s!/$!!;
1438 return ($url, RT::Test::Web->new);
1439}
1440
1441sub stop_server {
1442 my $self = shift;
1443 my $in_end = shift;
1444 return unless @SERVERS;
1445
1446 my $sig = 'TERM';
1447 $sig = 'INT' if $ENV{'RT_TEST_WEB_HANDLER'} eq "plack";
1448 kill $sig, @SERVERS;
1449 foreach my $pid (@SERVERS) {
1450 if ($ENV{RT_TEST_WEB_HANDLER} =~ /^apache/) {
1451 sleep 1 while kill 0, $pid;
1452 } else {
1453 waitpid $pid, 0;
1454 }
1455 }
1456
1457 @SERVERS = ();
1458}
1459
1460sub temp_directory {
1461 return $tmp{'directory'};
1462}
1463
1464sub file_content {
1465 my $self = shift;
1466 my $path = shift;
1467 my %args = @_;
1468
1469 $path = File::Spec->catfile( @$path ) if ref $path eq 'ARRAY';
1470
1471 Test::More::diag "reading content of '$path'" if $ENV{'TEST_VERBOSE'};
1472
1473 open( my $fh, "<:raw", $path )
1474 or do {
1475 warn "couldn't open file '$path': $!" unless $args{noexist};
1476 return ''
1477 };
1478 my $content = do { local $/; <$fh> };
1479 close $fh;
1480
1481 unlink $path if $args{'unlink'};
1482
1483 return $content;
1484}
1485
1486sub find_executable {
1487 my $self = shift;
1488 my $name = shift;
1489
1490 require File::Spec;
1491 foreach my $dir ( split /:/, $ENV{'PATH'} ) {
1492 my $fpath = File::Spec->catpath(
1493 (File::Spec->splitpath( $dir, 'no file' ))[0..1], $name
1494 );
1495 next unless -e $fpath && -r _ && -x _;
1496 return $fpath;
1497 }
1498 return undef;
1499}
1500
1501sub diag {
1502 return unless $ENV{RT_TEST_VERBOSE} || $ENV{TEST_VERBOSE};
1503 goto \&Test::More::diag;
1504}
1505
1506sub parse_mail {
1507 my $mail = shift;
1508 require RT::EmailParser;
1509 my $parser = RT::EmailParser->new;
1510 $parser->ParseMIMEEntityFromScalar( $mail );
1511 return $parser->Entity;
1512}
1513
1514sub works {
1515 Test::More::ok($_[0], $_[1] || 'This works');
1516}
1517
1518sub fails {
1519 Test::More::ok(!$_[0], $_[1] || 'This should fail');
1520}
1521
1522END {
1523 my $Test = RT::Test->builder;
1524 return if $Test->{Original_Pid} != $$;
1525
1526
1527 # we are in END block and should protect our exit code
1528 # so calls below may call system or kill that clobbers $?
1529 local $?;
1530
1531 RT::Test->stop_server(1);
1532
1533 # not success
1534 if ( !$Test->is_passing ) {
1535 $tmp{'directory'}->unlink_on_destroy(0);
1536
1537 Test::More::diag(
1538 "Some tests failed or we bailed out, tmp directory"
1539 ." '$tmp{directory}' is not cleaned"
1540 );
1541 }
1542
1543 if ( $ENV{RT_TEST_PARALLEL} && $created_new_db ) {
1544 __drop_database();
1545 }
1546
1547 # Drop our port from t/tmp/ports; do this after dropping the
1548 # database, as our port lock is also a lock on the database name.
1549 if ($port) {
1550 my %ports;
1551 my $portfile = "$tmp{'directory'}/../ports";
1552 sysopen(PORTS, $portfile, O_RDWR|O_CREAT)
1553 or die "Can't write to ports file $portfile: $!";
1554 flock(PORTS, LOCK_EX)
1555 or die "Can't write-lock ports file $portfile: $!";
1556 $ports{$_}++ for split ' ', join("",<PORTS>);
1557 delete $ports{$port};
1558 seek(PORTS, 0, 0);
1559 truncate(PORTS, 0);
1560 print PORTS "$_\n" for sort {$a <=> $b} keys %ports;
1561 close(PORTS) or die "Can't close ports file: $!";
1562 }
1563}
1564
1565{
1566 # ease the used only once warning
1567 no warnings;
1568 no strict 'refs';
1569 %{'RT::I18N::en_us::Lexicon'};
1570 %{'Win32::Locale::Lexicon'};
1571}
1572
15731;