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