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