1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2015 Best Practical Solutions, LLC
6 # <sales@bestpractical.com>
8 # (Except where explicitly superseded by other copyright notices)
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
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.
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.
30 # CONTRIBUTION SUBMISSION POLICY:
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.)
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.
47 # END BPS TAGGED BLOCK }}}
56 use base 'Test::More';
59 # Warn about role consumers overriding role methods so we catch it in tests.
60 $ENV{PERL_ROLE_OVERRIDE_WARN} = 1;
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
66 require Test::NoWarnings;
68 my $Test_NoWarnings_Catcher = $SIG{__WARN__};
69 my $check_warnings_in_end = 1;
72 use File::Temp qw(tempfile);
73 use File::Path qw(mkpath);
76 use Scalar::Util qw(blessed);
78 our @EXPORT = qw(is_empty diag parse_mail works fails plan done_testing);
99 To run the rt test suite with coverage support, install L<Devel::Cover> and run:
101 make test RT_DBA_USER=.. RT_DBA_PASSWORD=.. HARNESS_PERL_SWITCHES=-MDevel::Cover
102 cover -ignore_re '^var/mason_data/' -ignore_re '^t/'
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>.
114 delete $ENV{$_} for qw/LANGUAGE LC_ALL LC_MESSAGES LANG/;
123 $rttest_opt{'nodb'} = $args{'nodb'} = 1 if $^C;
125 # Spit out a plan (if we got one) *before* we load modules
126 if ( $args{'tests'} ) {
127 plan( tests => $args{'tests'} )
128 unless $args{'tests'} eq 'no_declare';
130 elsif ( exists $args{'tests'} ) {
131 # do nothing if they say "tests => undef" - let them make the plan
133 elsif ( $args{'skip_all'} ) {
134 plan(skip_all => $args{'skip_all'});
137 $class->builder->no_plan unless $class->builder->has_plan;
140 push @{ $args{'plugins'} ||= [] }, @{ $args{'requires'} }
141 if $args{'requires'};
142 push @{ $args{'plugins'} ||= [] }, $args{'testing'}
144 push @{ $args{'plugins'} ||= [] }, split " ", $ENV{RT_TEST_PLUGINS}
145 if $ENV{RT_TEST_PLUGINS};
147 $class->bootstrap_tempdir;
149 $class->bootstrap_port;
151 $class->bootstrap_plugins_paths( %args );
153 $class->bootstrap_config( %args );
159 RT::InitPluginPaths();
164 $class->set_config_wrapper;
165 $class->bootstrap_db( %args );
174 RT->Config->PostLoadCheck;
176 $class->encode_output;
178 my $screen_logger = $RT::Logger->remove( 'screen' );
179 require Log::Dispatch::Perl;
180 $RT::Logger->add( Log::Dispatch::Perl->new
182 min_level => $screen_logger->min_level,
183 action => { error => 'warn',
184 critical => 'warn' } ) );
186 # XXX: this should really be totally isolated environment so we
187 # can parallelize and be sane
188 mkpath [ $RT::MasonSessionDir ]
189 if RT->Config->Get('DatabaseType');
192 while ( my ($package) = caller($level-1) ) {
193 last unless $package =~ /Test/;
197 # By default we test HTML templates, but text templates are
198 # available on request
199 if ( $args{'text_templates'} ) {
200 $class->switch_templates_ok('text');
203 Test::More->export_to_level($level);
204 Test::NoWarnings->export_to_level($level);
206 # Blow away symbols we redefine to avoid warnings.
207 # better than "no warnings 'redefine'" because we might accidentally
208 # suppress a mistaken redefinition
210 delete ${ caller($level) . '::' }{diag};
211 delete ${ caller($level) . '::' }{plan};
212 delete ${ caller($level) . '::' }{done_testing};
213 __PACKAGE__->export_to_level($level);
218 local $Test::Builder::Level = $Test::Builder::Level + 1;
219 return Test::More::ok(1, $d) unless defined $v;
220 return Test::More::ok(1, $d) unless length $v;
221 return Test::More::is($v, '', $d);
224 my $created_new_db; # have we created new db? mainly for parallel testing
226 sub db_requires_no_dba {
228 my $db_type = RT->Config->Get('DatabaseType');
229 return 1 if $db_type eq 'SQLite';
237 # Determine which ports are in use
238 use Fcntl qw(:DEFAULT :flock);
239 my $portfile = "$tmp{'directory'}/../ports";
240 sysopen(PORTS, $portfile, O_RDWR|O_CREAT)
241 or die "Can't write to ports file $portfile: $!";
242 flock(PORTS, LOCK_EX)
243 or die "Can't write-lock ports file $portfile: $!";
244 $ports{$_}++ for split ' ', join("",<PORTS>);
246 # Pick a random port, checking that the port isn't in our in-use
247 # list, and that something isn't already listening there.
249 $port = 1024 + int rand(10_000) + $$ % 1024;
250 redo if $ports{$port};
252 # There is a race condition in here, where some non-RT::Test
253 # process claims the port after we check here but before our
254 # server binds. However, since we mostly care about race
255 # conditions with ourselves under high concurrency, this is
256 # generally good enough.
257 my $paddr = sockaddr_in( $port, inet_aton('localhost') );
258 socket( SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
260 if ( connect( SOCK, $paddr ) ) {
269 # Write back out the in-use ports
272 print PORTS "$_\n" for sort {$a <=> $b} keys %ports;
273 close(PORTS) or die "Can't close ports file: $!";
276 sub bootstrap_tempdir {
278 my ($test_dir, $test_file) = ('t', '');
280 if (File::Spec->rel2abs($0) =~ m{(?:^|[\\/])(x?t)[/\\](.*)}) {
283 $test_file =~ s{[/\\]}{-}g;
286 my $dir_name = File::Spec->rel2abs("$test_dir/tmp");
288 return $tmp{'directory'} = File::Temp->newdir(
289 "${test_file}XXXXXXXX",
294 sub bootstrap_config {
298 $tmp{'config'}{'RT'} = File::Spec->catfile(
299 "$tmp{'directory'}", 'RT_SiteConfig.pm'
301 open( my $config, '>', $tmp{'config'}{'RT'} )
302 or die "Couldn't open $tmp{'config'}{'RT'}: $!";
304 my $dbname = $ENV{RT_TEST_PARALLEL}? "rt4test_$port" : "rt4test";
306 Set( \$WebDomain, "localhost");
307 Set( \$WebPort, $port);
309 Set( \@LexiconLanguages, qw(en zh_TW zh_CN fr ja));
310 Set( \$RTAddressRegexp , qr/^bad_re_that_doesnt_match\$/i);
311 Set( \$ShowHistory, "always");
313 if ( $ENV{'RT_TEST_DB_SID'} ) { # oracle case
314 print $config "Set( \$DatabaseName , '$ENV{'RT_TEST_DB_SID'}' );\n";
315 print $config "Set( \$DatabaseUser , '$dbname');\n";
317 print $config "Set( \$DatabaseName , '$dbname');\n";
318 print $config "Set( \$DatabaseUser , 'u${dbname}');\n";
320 if ( $ENV{'RT_TEST_DB_HOST'} ) {
321 print $config "Set( \$DatabaseHost , '$ENV{'RT_TEST_DB_HOST'}');\n";
324 if ( $args{'plugins'} ) {
325 print $config "Set( \@Plugins, qw(". join( ' ', @{ $args{'plugins'} } ) .") );\n";
327 my $plugin_data = File::Spec->rel2abs("t/data/plugins");
328 print $config qq[\$RT::PluginPath = "$plugin_data";\n];
331 if ( $INC{'Devel/Cover.pm'} ) {
332 print $config "Set( \$DevelMode, 0 );\n";
334 elsif ( $ENV{RT_TEST_DEVEL} ) {
335 print $config "Set( \$DevelMode, 1 );\n";
338 print $config "Set( \$DevelMode, 0 );\n";
341 $self->bootstrap_logging( $config );
344 my $mail_catcher = $tmp{'mailbox'} = File::Spec->catfile(
345 $tmp{'directory'}->dirname, 'mailbox.eml'
348 Set( \$MailCommand, sub {
351 open( my \$handle, '>>', '$mail_catcher' )
352 or die "Unable to open '$mail_catcher' for appending: \$!";
354 \$MIME->print(\$handle);
355 print \$handle "%% split me! %%\n";
360 $self->bootstrap_more_config($config, \%args);
362 print $config $args{'config'} if $args{'config'};
364 print $config "\n1;\n";
365 $ENV{'RT_SITE_CONFIG'} = $tmp{'config'}{'RT'};
371 sub bootstrap_more_config { }
373 sub bootstrap_logging {
377 # prepare file for logging
378 $tmp{'log'}{'RT'} = File::Spec->catfile(
379 "$tmp{'directory'}", 'rt.debug.log'
381 open( my $fh, '>', $tmp{'log'}{'RT'} )
382 or die "Couldn't open $tmp{'config'}{'RT'}: $!";
383 # make world writable so apache under different user
385 chmod 0666, $tmp{'log'}{'RT'};
388 Set( \$LogToSyslog , undef);
389 Set( \$LogToSTDERR , "warning");
390 Set( \$LogToFile, 'debug' );
391 Set( \$LogDir, q{$tmp{'directory'}} );
392 Set( \$LogToFileNamed, 'rt.debug.log' );
396 sub set_config_wrapper {
399 my $old_sub = \&RT::Config::Set;
400 no warnings 'redefine';
402 *RT::Config::WriteSet = sub {
403 my ($self, $name) = @_;
404 my $type = $RT::Config::META{$name}->{'Type'} || 'SCALAR';
410 my $sigil = $sigils{$type} || $sigils{'SCALAR'};
411 open( my $fh, '<', $tmp{'config'}{'RT'} )
412 or die "Couldn't open config file: $!";
415 if (not @lines or /^Set\(/) {
423 # Traim trailing newlines and "1;"
424 $lines[-1] =~ s/(^1;\n|^\n)*\Z//m;
426 # Remove any previous definitions of this var
427 @lines = grep {not /^Set\(\s*\Q$sigil$name\E\b/} @lines;
429 # Format the new value for output
430 require Data::Dumper;
431 local $Data::Dumper::Terse = 1;
432 my $dump = Data::Dumper::Dumper([@_[2 .. $#_]]);
433 $dump =~ s/;?\s+\Z//;
434 push @lines, "Set( ${sigil}${name}, \@{". $dump ."});\n";
435 push @lines, "\n1;\n";
437 # Re-write the configuration file
438 open( $fh, '>', $tmp{'config'}{'RT'} )
439 or die "Couldn't open config file: $!";
440 print $fh $_ for @lines;
444 warn "you're changing config option in a test file"
445 ." when server is active";
448 return $old_sub->(@_);
451 *RT::Config::Set = sub {
452 # Determine if the caller is either from a test script, or
453 # from helper functions called by test script to alter
454 # configuration that should be written. This is necessary
455 # because some extensions (RTIR, for example) temporarily swap
456 # configuration values out and back in Mason during requests.
457 my @caller = caller(1); # preserve list context
458 @caller = caller(0) unless @caller;
460 return RT::Config::WriteSet(@_)
461 if ($caller[1]||'') =~ /\.t$/;
463 return $old_sub->(@_);
468 my $builder = Test::More->builder;
469 binmode $builder->output, ":encoding(utf8)";
470 binmode $builder->failure_output, ":encoding(utf8)";
471 binmode $builder->todo_output, ":encoding(utf8)";
478 unless (defined $ENV{'RT_DBA_USER'} && defined $ENV{'RT_DBA_PASSWORD'}) {
479 Test::More::BAIL_OUT(
480 "RT_DBA_USER and RT_DBA_PASSWORD environment variables need"
481 ." to be set in order to run 'make test'"
482 ) unless $self->db_requires_no_dba;
486 if (my $forceopt = $ENV{RT_TEST_FORCE_OPT}) {
487 Test::More::diag "forcing $forceopt";
491 # Short-circuit the rest of ourselves if we don't want a db
497 my $db_type = RT->Config->Get('DatabaseType');
499 if ($db_type eq "SQLite") {
500 RT->Config->WriteSet( DatabaseName => File::Spec->catfile( $self->temp_directory, "rt4test" ) );
504 __reconnect_rt('as dba');
505 $RT::Handle->InsertSchema;
506 $RT::Handle->InsertACL unless $db_type eq 'Oracle';
511 $RT::Handle->InsertInitialData
512 unless $args{noinitialdata};
514 $RT::Handle->InsertData( $RT::EtcPath . "/initialdata" )
515 unless $args{noinitialdata} or $args{nodata};
517 $self->bootstrap_plugins_db( %args );
520 sub bootstrap_plugins_paths {
524 return unless $args{'plugins'};
525 my @plugins = @{ $args{'plugins'} };
528 if ( $args{'testing'} ) {
530 $cwd = Cwd::getcwd();
534 my $old_func = \&RT::Plugin::_BasePath;
535 no warnings 'redefine';
536 *RT::Plugin::_BasePath = sub {
537 my $name = $_[0]->{'name'};
539 return $cwd if $args{'testing'} && $name eq $args{'testing'};
541 if ( grep $name eq $_, @plugins ) {
542 my $variants = join "(?:|::|-|_)", map "\Q$_\E", split /::/, $name;
543 my ($path) = map $ENV{$_}, grep /^RT_TEST_PLUGIN_(?:$variants).*_ROOT$/i, keys %ENV;
544 return $path if $path;
546 return $old_func->(@_);
550 sub bootstrap_plugins_db {
554 return unless $args{'plugins'};
558 my @plugins = @{ $args{'plugins'} };
559 foreach my $name ( @plugins ) {
560 my $plugin = RT::Plugin->new( name => $name );
561 Test::More::diag( "Initializing DB for the $name plugin" )
562 if $ENV{'TEST_VERBOSE'};
564 my $etc_path = $plugin->Path('etc');
565 Test::More::diag( "etc path of the plugin is '$etc_path'" )
566 if $ENV{'TEST_VERBOSE'};
568 unless ( -e $etc_path ) {
569 # We can't tell if the plugin has no data, or we screwed up the etc/ path
570 Test::More::ok(1, "There is no etc dir: no schema" );
571 Test::More::ok(1, "There is no etc dir: no ACLs" );
572 Test::More::ok(1, "There is no etc dir: no data" );
576 __reconnect_rt('as dba');
579 my ($ret, $msg) = $RT::Handle->InsertSchema( undef, $etc_path );
580 Test::More::ok($ret || $msg =~ /^Couldn't find schema/, "Created schema: ".($msg||''));
584 my ($ret, $msg) = $RT::Handle->InsertACL( undef, $etc_path );
585 Test::More::ok($ret || $msg =~ /^Couldn't find ACLs/, "Created ACL: ".($msg||''));
589 my $data_file = File::Spec->catfile( $etc_path, 'initialdata' );
590 if ( -e $data_file ) {
592 my ($ret, $msg) = $RT::Handle->InsertData( $data_file );;
593 Test::More::ok($ret, "Inserted data".($msg||''));
595 Test::More::ok(1, "There is no data file" );
602 my ($dsn, $user, $pass) = @_;
603 if ( $dsn =~ /Oracle/i ) {
604 $ENV{'NLS_LANG'} = "AMERICAN_AMERICA.AL32UTF8";
605 $ENV{'NLS_NCHAR'} = "AL32UTF8";
607 my $dbh = DBI->connect(
609 { RaiseError => 0, PrintError => 1 },
612 my $msg = "Failed to connect to $dsn as user '$user': ". $DBI::errstr;
613 print STDERR $msg; exit -1;
618 sub __create_database {
619 # bootstrap with dba cred
621 RT::Handle->SystemDSN,
622 $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD}
625 unless ( $ENV{RT_TEST_PARALLEL} ) {
626 # already dropped db in parallel tests, need to do so for other cases.
627 __drop_database( $dbh );
630 RT::Handle->CreateDatabase( $dbh );
635 sub __drop_database {
638 # Pg doesn't like if you issue a DROP DATABASE while still connected
639 # it's still may fail if web-server is out there and holding a connection
642 my $my_dbh = $dbh? 0 : 1;
644 RT::Handle->SystemDSN,
645 $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD}
648 # We ignore errors intentionally by not checking the return value of
649 # DropDatabase below, so let's also suppress DBI's printing of errors when
650 # we overzealously drop.
651 local $dbh->{PrintError} = 0;
652 local $dbh->{PrintWarn} = 0;
654 RT::Handle->DropDatabase( $dbh );
655 $dbh->disconnect if $my_dbh;
662 # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation
663 $RT::Handle = RT::Handle->new;
664 $RT::Handle->dbh( undef );
665 $RT::Handle->Connect(
667 ? (User => $ENV{RT_DBA_USER}, Password => $ENV{RT_DBA_PASSWORD})
670 $RT::Handle->PrintError;
671 $RT::Handle->dbh->{PrintError} = 1;
672 return $RT::Handle->dbh;
675 sub __disconnect_rt {
676 # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation
677 $RT::Handle->dbh->disconnect if $RT::Handle and $RT::Handle->dbh;
679 %DBIx::SearchBuilder::Handle::DBIHandle = ();
680 $DBIx::SearchBuilder::Handle::PrevHandle = undef;
684 delete $RT::System->{attributes};
686 DBIx::SearchBuilder::Record::Cachable->FlushCache
687 if DBIx::SearchBuilder::Record::Cachable->can("FlushCache");
693 # We use local to ensure that the $filter we grab is from InitLogging
694 # and not the handler generated by a previous call to this function
696 local $SIG{__WARN__};
698 $filter = $SIG{__WARN__};
700 $SIG{__WARN__} = sub {
701 $filter->(@_) if $filter;
702 # Avoid reporting this anonymous call frame as the source of the warning.
703 goto &$Test_NoWarnings_Catcher;
710 =head2 load_or_create_user
714 sub load_or_create_user {
716 my %args = ( Privileged => 1, Disabled => 0, @_ );
718 my $MemberOf = delete $args{'MemberOf'};
719 $MemberOf = [ $MemberOf ] if defined $MemberOf && !ref $MemberOf;
722 my $obj = RT::User->new( RT->SystemUser );
723 if ( $args{'Name'} ) {
724 $obj->LoadByCols( Name => $args{'Name'} );
725 } elsif ( $args{'EmailAddress'} ) {
726 $obj->LoadByCols( EmailAddress => $args{'EmailAddress'} );
728 die "Name or EmailAddress is required";
732 $obj->SetPrivileged( $args{'Privileged'} || 0 )
733 if ($args{'Privileged'}||0) != ($obj->Privileged||0);
734 $obj->SetDisabled( $args{'Disabled'} || 0 )
735 if ($args{'Disabled'}||0) != ($obj->Disabled||0);
737 my ($val, $msg) = $obj->Create( %args );
738 die "$msg" unless $val;
741 # clean group membership
743 require RT::GroupMembers;
744 my $gms = RT::GroupMembers->new( RT->SystemUser );
745 my $groups_alias = $gms->Join(
746 FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id',
749 ALIAS => $groups_alias, FIELD => 'Domain', VALUE => 'UserDefined',
752 $gms->Limit( FIELD => 'MemberId', VALUE => $obj->id );
753 while ( my $group_member_record = $gms->Next ) {
754 $group_member_record->Delete;
758 # add new user to groups
759 foreach ( @$MemberOf ) {
760 my $group = RT::Group->new( RT::SystemUser() );
761 $group->LoadUserDefinedGroup( $_ );
762 die "couldn't load group '$_'" unless $group->id;
763 $group->AddMember( $obj->id );
770 sub load_or_create_group {
775 my $group = RT::Group->new( RT->SystemUser );
776 $group->LoadUserDefinedGroup( $name );
777 unless ( $group->id ) {
778 my ($id, $msg) = $group->CreateUserDefinedGroup(
781 die "$msg" unless $id;
784 if ( $args{Members} ) {
785 my $cur = $group->MembersObj;
786 while ( my $entry = $cur->Next ) {
787 my ($status, $msg) = $entry->Delete;
788 die "$msg" unless $status;
791 foreach my $new ( @{ $args{Members} } ) {
792 my ($status, $msg) = $group->AddMember(
793 ref($new)? $new->id : $new,
795 die "$msg" unless $status;
802 =head2 load_or_create_queue
806 sub load_or_create_queue {
808 my %args = ( Disabled => 0, @_ );
809 my $obj = RT::Queue->new( RT->SystemUser );
810 if ( $args{'Name'} ) {
811 $obj->LoadByCols( Name => $args{'Name'} );
813 die "Name is required";
815 unless ( $obj->id ) {
816 my ($val, $msg) = $obj->Create( %args );
817 die "$msg" unless $val;
819 my @fields = qw(CorrespondAddress CommentAddress);
820 foreach my $field ( @fields ) {
821 next unless exists $args{ $field };
822 next if $args{ $field } eq ($obj->$field || '');
824 no warnings 'uninitialized';
825 my $method = 'Set'. $field;
826 my ($val, $msg) = $obj->$method( $args{ $field } );
827 die "$msg" unless $val;
834 sub delete_queue_watchers {
838 foreach my $q ( @queues ) {
839 foreach my $t (qw(Cc AdminCc) ) {
840 $q->DeleteWatcher( Type => $t, PrincipalId => $_->MemberId )
841 foreach @{ $q->$t()->MembersObj->ItemsArrayRef };
847 local $Test::Builder::Level = $Test::Builder::Level + 1;
850 my $defaults = shift;
852 @data = sort { rand(100) <=> rand(100) } @data
853 if delete $defaults->{'RandomOrder'};
855 $defaults->{'Queue'} ||= 'General';
859 my %args = %{ shift @data };
860 $args{$_} = $res[ $args{$_} ]->id foreach
861 grep $args{ $_ }, keys %RT::Link::TYPEMAP;
862 push @res, $self->create_ticket( %$defaults, %args );
868 local $Test::Builder::Level = $Test::Builder::Level + 1;
873 if ( blessed $args{'Queue'} ) {
874 $args{Queue} = $args{'Queue'}->id;
876 elsif ($args{Queue} && $args{Queue} =~ /\D/) {
877 my $queue = RT::Queue->new(RT->SystemUser);
878 if (my $id = $queue->Load($args{Queue}) ) {
881 die ("Error: Invalid queue $args{Queue}");
885 if ( my $content = delete $args{'Content'} ) {
886 $args{'MIMEObj'} = MIME::Entity->build(
887 From => Encode::encode( "UTF-8", $args{'Requestor'} ),
888 Subject => RT::Interface::Email::EncodeToMIME( String => $args{'Subject'} ),
889 Type => $args{ContentType} // "text/plain",
891 Data => Encode::encode( "UTF-8", $content ),
895 if ( my $cfs = delete $args{'CustomFields'} ) {
896 my $q = RT::Queue->new( RT->SystemUser );
897 $q->Load( $args{'Queue'} );
898 while ( my ($k, $v) = each %$cfs ) {
899 my $cf = $q->CustomField( $k );
901 RT->Logger->error("Couldn't load custom field $k");
905 $args{'CustomField-'. $cf->id} = $v;
909 my $ticket = RT::Ticket->new( RT->SystemUser );
910 my ( $id, undef, $msg ) = $ticket->Create( %args );
911 Test::More::ok( $id, "ticket created" )
912 or Test::More::diag("error: $msg");
914 # hackish, but simpler
915 if ( $args{'LastUpdatedBy'} ) {
916 $ticket->__Set( Field => 'LastUpdatedBy', Value => $args{'LastUpdatedBy'} );
920 for my $field ( keys %args ) {
921 #TODO check links and watchers
923 if ( $field =~ /CustomField-(\d+)/ ) {
925 my $got = join ',', sort map $_->Content,
926 @{ $ticket->CustomFieldValues($cf)->ItemsArrayRef };
927 my $expected = ref $args{$field}
928 ? join( ',', sort @{ $args{$field} } )
930 Test::More::is( $got, $expected, 'correct CF values' );
933 next if ref $args{$field};
934 next unless $ticket->can($field) or $ticket->_Accessible($field,"read");
935 next if ref $ticket->$field();
936 Test::More::is( $ticket->$field(), $args{$field}, "$field is correct" );
946 my $tickets = RT::Tickets->new( RT->SystemUser );
948 $tickets->FromSQL( $query );
953 while ( my $ticket = $tickets->Next ) {
958 =head2 load_or_create_custom_field
962 sub load_or_create_custom_field {
964 my %args = ( Disabled => 0, @_ );
965 my $obj = RT::CustomField->new( RT->SystemUser );
966 if ( $args{'Name'} ) {
968 Name => $args{'Name'},
969 LookupType => RT::Ticket->CustomFieldLookupType,
970 ObjectId => $args{'Queue'},
973 die "Name is required";
975 unless ( $obj->id ) {
976 my ($val, $msg) = $obj->Create( %args );
977 die "$msg" unless $val;
986 $current = $current ? RT::CurrentUser->new($current) : RT->SystemUser;
987 my $tickets = RT::Tickets->new( $current );
988 $tickets->OrderBy( FIELD => 'id', ORDER => 'DESC' );
989 $tickets->Limit( FIELD => 'id', OPERATOR => '>', VALUE => '0' );
990 $tickets->RowsPerPage( 1 );
991 return $tickets->First;
999 RT::ACE->new( RT->SystemUser );
1000 my @fields = keys %{ RT::ACE->_ClassAccessible };
1003 my $acl = RT::ACL->new( RT->SystemUser );
1004 $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
1007 while ( my $ace = $acl->Next ) {
1008 my $obj = $ace->PrincipalObj->Object;
1009 if ( $obj->isa('RT::Group') && $obj->Domain eq 'ACLEquivalence' && $obj->Instance == RT->Nobody->id ) {
1014 foreach my $field( @fields ) {
1015 $tmp{ $field } = $ace->__Value( $field );
1022 sub restore_rights {
1025 foreach my $entry ( @entries ) {
1026 my $ace = RT::ACE->new( RT->SystemUser );
1027 my ($status, $msg) = $ace->RT::Record::Create( %$entry );
1028 unless ( $status ) {
1029 Test::More::diag "couldn't create a record: $msg";
1038 my $acl = RT::ACL->new( RT->SystemUser );
1039 $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
1040 while ( my $ace = $acl->Next ) {
1041 my $obj = $ace->PrincipalObj->Object;
1042 if ( $obj->isa('RT::Group') && $obj->Domain eq 'ACLEquivalence' && $obj->Instance == RT->Nobody->id ) {
1047 return $self->add_rights( @_ );
1052 my @list = ref $_[0]? @_: @_? { @_ }: ();
1055 foreach my $e (@list) {
1056 my $principal = delete $e->{'Principal'};
1057 unless ( ref $principal ) {
1058 if ( $principal =~ /^(everyone|(?:un)?privileged)$/i ) {
1059 $principal = RT::Group->new( RT->SystemUser );
1060 $principal->LoadSystemInternalGroup($1);
1062 my $type = $principal;
1063 $principal = RT::Group->new( RT->SystemUser );
1064 $principal->LoadRoleGroup(
1065 Object => ($e->{'Object'} || RT->System),
1069 die "Principal is not an object nor the name of a system or role group"
1070 unless $principal->id;
1072 unless ( $principal->isa('RT::Principal') ) {
1073 if ( $principal->can('PrincipalObj') ) {
1074 $principal = $principal->PrincipalObj;
1077 my @rights = ref $e->{'Right'}? @{ $e->{'Right'} }: ($e->{'Right'});
1078 foreach my $right ( @rights ) {
1079 my ($status, $msg) = $principal->GrantRight( %$e, Right => $right );
1080 $RT::Logger->debug($msg);
1086 =head2 switch_templates_to TYPE
1088 This runs /opt/rt4/etc/upgrade/switch-templates-to in order to change the templates from
1089 HTML to text or vice versa. TYPE is the type to switch to, either C<html> or
1094 sub switch_templates_to {
1098 return $self->run_and_capture(
1099 command => "$RT::EtcPath/upgrade/switch-templates-to",
1104 =head2 switch_templates_ok TYPE
1106 Calls L<switch_template_to> and tests the return values.
1110 sub switch_templates_ok {
1114 my ($exit, $output) = $self->switch_templates_to($type);
1117 Test::More::fail("Switched templates to $type cleanly");
1118 diag("**** $RT::EtcPath/upgrade/switch-templates-to exited with ".($exit >> 8).":\n$output");
1120 Test::More::pass("Switched templates to $type cleanly");
1123 return ($exit, $output);
1129 require RT::Test::Web;
1131 url => RT::Test::Web->rt_base_url,
1133 action => 'correspond',
1136 command => $RT::BinPath .'/rt-mailgate',
1139 my $message = delete $args{'message'};
1141 $args{after_open} = sub {
1142 my $child_in = shift;
1143 if ( UNIVERSAL::isa($message, 'MIME::Entity') ) {
1144 $message->print( $child_in );
1146 print $child_in $message;
1150 $self->run_and_capture(%args);
1153 sub run_and_capture {
1157 my $after_open = delete $args{after_open};
1159 my $cmd = delete $args{'command'};
1160 die "Couldn't find command ($cmd)" unless -f $cmd;
1162 $cmd .= ' --debug' if delete $args{'debug'};
1164 my $args = delete $args{'args'};
1166 while( my ($k,$v) = each %args ) {
1168 $cmd .= " --$k '$v'";
1170 $cmd .= " $args" if defined $args;
1173 DBIx::SearchBuilder::Record::Cachable->FlushCache;
1176 my ($child_out, $child_in);
1177 my $pid = IPC::Open2::open2($child_out, $child_in, $cmd);
1179 $after_open->($child_in, $child_out) if $after_open;
1183 my $result = do { local $/; <$child_out> };
1186 return ($?, $result);
1189 sub send_via_mailgate_and_http {
1191 my $message = shift;
1194 my ($status, $gate_result) = $self->run_mailgate(
1195 message => $message, %args
1199 unless ( $status >> 8 ) {
1200 ($id) = ($gate_result =~ /Ticket:\s*(\d+)/i);
1202 Test::More::diag "Couldn't find ticket id in text:\n$gate_result"
1203 if $ENV{'TEST_VERBOSE'};
1206 Test::More::diag "Mailgate output:\n$gate_result"
1207 if $ENV{'TEST_VERBOSE'};
1209 return ($status, $id);
1213 sub send_via_mailgate {
1215 my $message = shift;
1216 my %args = ( action => 'correspond',
1221 if ( UNIVERSAL::isa( $message, 'MIME::Entity' ) ) {
1222 $message = $message->as_string;
1225 my ( $status, $error_message, $ticket )
1226 = RT::Interface::Email::Gateway( {%args, message => $message} );
1228 # Invert the status to act like a syscall; failing return code is 1,
1229 # and it will be right-shifted before being examined.
1230 $status = ($status == 1) ? 0
1231 : ($status == -75) ? (-75 << 8)
1234 return ( $status, $ticket ? $ticket->id : 0 );
1239 sub open_mailgate_ok {
1240 local $Test::Builder::Level = $Test::Builder::Level + 1;
1242 my $baseurl = shift;
1243 my $queue = shift || 'general';
1244 my $action = shift || 'correspond';
1245 Test::More::ok(open(my $mail, '|-', "$RT::BinPath/rt-mailgate --url $baseurl --queue $queue --action $action"), "Opened the mailgate - $!");
1250 sub close_mailgate_ok {
1251 local $Test::Builder::Level = $Test::Builder::Level + 1;
1255 Test::More::is ($? >> 8, 0, "The mail gateway exited normally. yay");
1259 local $Test::Builder::Level = $Test::Builder::Level + 1;
1261 my $expected = shift;
1263 my $mailsent = scalar grep /\S/, split /%% split me! %%\n/,
1264 RT::Test->file_content(
1271 $mailsent, $expected,
1272 "The number of mail sent ($expected) matches. yay"
1276 sub fetch_caught_mails {
1278 return grep /\S/, split /%% split me! %%\n/,
1279 RT::Test->file_content(
1286 sub clean_caught_mails {
1287 unlink $tmp{'mailbox'};
1292 my %args = (check => 1, resolve => 0, force => 1, timeout => 0, @_ );
1294 my $cmd = "$RT::SbinPath/rt-validator";
1295 die "Couldn't find $cmd command" unless -f $cmd;
1297 my $timeout = delete $args{timeout};
1299 while( my ($k,$v) = each %args ) {
1301 $cmd .= " --$k '$v'";
1306 my ($child_out, $child_in);
1307 my $pid = IPC::Open2::open2($child_out, $child_in, $cmd);
1310 local $SIG{ALRM} = sub { kill KILL => $pid; die "Timeout!" };
1312 alarm $timeout if $timeout;
1313 my $result = eval { local $/; <$child_out> };
1319 DBIx::SearchBuilder::Record::Cachable->FlushCache
1320 if $args{'resolve'};
1322 return ($?, $result);
1326 local $Test::Builder::Level = $Test::Builder::Level + 1;
1329 my ($ecode, $res) = $self->run_validator;
1330 Test::More::is( $ecode, 0, 'no invalid records' )
1331 or Test::More::diag "errors:\n$res";
1334 =head2 object_scrips_are
1336 Takes an L<RT::Scrip> object or ID as the first argument and an arrayref of
1337 L<RT::Queue> objects and/or Queue IDs as the second argument.
1339 The scrip's applications (L<RT::ObjectScrip> records) are tested to ensure they
1340 exactly match the arrayref.
1342 An optional third arrayref may be passed to enumerate and test the queues the
1343 scrip is B<not> added to. This is most useful for testing the API returns the
1348 sub object_scrips_are {
1349 local $Test::Builder::Level = $Test::Builder::Level + 1;
1352 my $to = shift || [];
1355 unless (blessed($scrip)) {
1357 $scrip = RT::Scrip->new( RT->SystemUser );
1361 $to = [ map { blessed($_) ? $_->id : $_ } @$to ];
1362 Test::More::ok($scrip->IsAdded($_), "added to queue $_" ) foreach @$to;
1363 Test::More::is_deeply(
1364 [sort map $_->id, @{ $scrip->AddedTo->ItemsArrayRef }],
1365 [sort grep $_, @$to ],
1366 'correct list of added to queues',
1370 $not_to = [ map { blessed($_) ? $_->id : $_ } @$not_to ];
1371 Test::More::ok(!$scrip->IsAdded($_), "not added to queue $_" ) foreach @$not_to;
1372 Test::More::is_deeply(
1373 [sort map $_->id, @{ $scrip->NotAddedTo->ItemsArrayRef }],
1374 [sort grep $_, @$not_to ],
1375 'correct list of not added to queues',
1380 =head2 get_relocatable_dir
1382 Takes a path relative to the location of the test file that is being
1383 run and returns a path that takes the invocation path into account.
1385 e.g. C<RT::Test::get_relocatable_dir(File::Spec->updir(), 'data', 'emails')>
1387 Parent directory traversals (C<..> or File::Spec->updir()) are naively
1388 canonicalized based on the test file path (C<$0>) so that symlinks aren't
1389 followed. This is the exact opposite behaviour of most filesystems and is
1390 considered "wrong", however it is necessary for some subsets of tests which are
1391 symlinked into the testing tree.
1395 sub get_relocatable_dir {
1396 my @directories = File::Spec->splitdir(
1397 File::Spec->rel2abs((File::Spec->splitpath($0))[1])
1399 push @directories, File::Spec->splitdir($_) for @_;
1402 for (@directories) {
1403 if ($_ eq "..") { pop @clean }
1404 elsif ($_ ne ".") { push @clean, $_ }
1406 return File::Spec->catdir(@clean);
1409 =head2 get_relocatable_file
1411 Same as get_relocatable_dir, but takes a file and a path instead
1414 e.g. RT::Test::get_relocatable_file('test-email',
1415 (File::Spec->updir(), 'data', 'emails'))
1419 sub get_relocatable_file {
1421 return File::Spec->catfile(get_relocatable_dir(@_), $file);
1424 sub find_relocatable_path {
1427 # A simple strategy to find e.g., t/data/gnupg/keys, from the dir
1428 # where test file lives. We try up to 3 directories up
1429 my $path = File::Spec->catfile( @path );
1430 for my $up ( 0 .. 2 ) {
1431 my $p = get_relocatable_dir($path);
1434 $path = File::Spec->catfile( File::Spec->updir(), $path );
1439 sub get_abs_relocatable_dir {
1440 (my $volume, my $directories, my $file) = File::Spec->splitpath($0);
1441 if (File::Spec->file_name_is_absolute($directories)) {
1442 return File::Spec->catdir($directories, @_);
1444 return File::Spec->catdir(Cwd->getcwd(), $directories, @_);
1451 DIR => $tmp{directory},
1456 sub import_gnupg_key {
1459 my $type = shift || 'secret';
1461 $key =~ s/\@/-at-/g;
1462 $key .= ".$type.key";
1464 my $path = find_relocatable_path( 'data', 'gnupg', 'keys' );
1466 die "can't find the dir where gnupg keys are stored"
1469 return RT::Crypt::GnuPG->ImportKey(
1470 RT::Test->file_content( [ $path, $key ] ) );
1473 sub lsign_gnupg_key {
1477 return RT::Crypt::GnuPG->CallGnuPG(
1478 Command => '--lsign-key',
1479 CommandArgs => [$key],
1482 while ( my $str = readline $handle{'status'} ) {
1483 if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL sign_uid\..*/ ) {
1484 print { $handle{'command'} } "y\n";
1491 sub trust_gnupg_key {
1495 return RT::Crypt::GnuPG->CallGnuPG(
1496 Command => '--edit-key',
1497 CommandArgs => [$key],
1501 while ( my $str = readline $handle{'status'} ) {
1502 if ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE keyedit.prompt/ ) {
1504 print { $handle{'command'} } "quit\n";
1506 print { $handle{'command'} } "trust\n";
1508 } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE edit_ownertrust.value/ ) {
1509 print { $handle{'command'} } "5\n";
1510 } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_BOOL edit_ownertrust.set_ultimate.okay/ ) {
1511 print { $handle{'command'} } "y\n";
1522 require RT::Test::Web;
1524 if ($rttest_opt{nodb} and not $rttest_opt{server_ok}) {
1525 die "You are trying to use a test web server without a database. "
1526 ."You may want noinitialdata => 1 instead. "
1527 ."Pass server_ok => 1 if you know what you're doing.";
1531 $ENV{'RT_TEST_WEB_HANDLER'} = undef
1532 if $rttest_opt{actual_server} && ($ENV{'RT_TEST_WEB_HANDLER'}||'') eq 'inline';
1533 $ENV{'RT_TEST_WEB_HANDLER'} ||= 'plack';
1534 my $which = $ENV{'RT_TEST_WEB_HANDLER'};
1535 my ($server, $variant) = split /\+/, $which, 2;
1537 my $function = 'start_'. $server .'_server';
1538 unless ( $self->can($function) ) {
1539 die "Don't know how to start server '$server'";
1541 return $self->$function( variant => $variant, @_ );
1546 my %server_opt = @_;
1551 open( my $warn_fh, ">", \$warnings );
1552 local *STDERR = $warn_fh;
1554 if ($server_opt{variant} and $server_opt{variant} eq 'rt-server') {
1556 my $file = "$RT::SbinPath/rt-server";
1557 my $psgi = do $file;
1559 die "Couldn't parse $file: $@" if $@;
1560 die "Couldn't do $file: $!" unless defined $psgi;
1561 die "Couldn't run $file" unless $psgi;
1566 require RT::Interface::Web::Handler;
1567 $app = RT::Interface::Web::Handler->PSGIApp;
1570 require Plack::Middleware::Test::StashWarnings;
1571 my $stashwarnings = Plack::Middleware::Test::StashWarnings->new(
1572 $ENV{'RT_TEST_WEB_HANDLER'} && $ENV{'RT_TEST_WEB_HANDLER'} eq 'inline' ? ( verbose => 0 ) : () );
1573 $app = $stashwarnings->wrap($app);
1575 if ($server_opt{basic_auth}) {
1576 require Plack::Middleware::Auth::Basic;
1577 $app = Plack::Middleware::Auth::Basic->wrap(
1579 authenticator => $server_opt{basic_auth} eq 'anon' ? sub { 1 } : sub {
1580 my ($username, $password) = @_;
1581 return $username eq 'root' && $password eq 'password';
1587 $stashwarnings->add_warning( $warnings ) if $warnings;
1592 sub start_plack_server {
1593 local $Test::Builder::Level = $Test::Builder::Level + 1;
1596 require Plack::Loader;
1597 my $plack_server = Plack::Loader->load
1600 server_ready => sub {
1601 kill 'USR1' => getppid();
1604 # We are expecting a USR1 from the child process after it's ready
1605 # to listen. We set this up _before_ we fork to avoid race
1608 local $SIG{USR1} = sub { $handled = 1};
1612 die "failed to fork" unless defined $pid;
1615 sleep 15 unless $handled;
1616 Test::More::diag "did not get expected USR1 for test server readiness"
1618 push @SERVERS, $pid;
1619 my $Tester = Test::Builder->new;
1620 $Tester->ok(1, "started plack server ok");
1623 unless $rttest_opt{nodb};
1624 return ("http://localhost:$port", RT::Test::Web->new);
1629 or die "Can't start a new session: $!";
1631 # stick this in a scope so that when $app is garbage collected,
1632 # StashWarnings can complain about unhandled warnings
1634 $plack_server->run($self->test_app(@_));
1641 sub start_inline_server {
1642 local $Test::Builder::Level = $Test::Builder::Level + 1;
1645 require Test::WWW::Mechanize::PSGI;
1646 unshift @RT::Test::Web::ISA, 'Test::WWW::Mechanize::PSGI';
1648 # Clear out squished CSS and JS cache, since it's retained across
1649 # servers, since it's in-process
1650 RT::Interface::Web->ClearSquished;
1651 require RT::Interface::Web::Request;
1652 RT::Interface::Web::Request->clear_callback_cache;
1654 Test::More::ok(1, "psgi test server ok");
1655 $TEST_APP = $self->test_app(@_);
1656 return ("http://localhost:$port", RT::Test::Web->new);
1659 sub start_apache_server {
1660 local $Test::Builder::Level = $Test::Builder::Level + 1;
1662 my %server_opt = @_;
1663 $server_opt{variant} ||= 'mod_perl';
1664 $ENV{RT_TEST_WEB_HANDLER} = "apache+$server_opt{variant}";
1666 require RT::Test::Apache;
1667 my $pid = RT::Test::Apache->start_server(
1672 push @SERVERS, $pid;
1674 my $url = RT->Config->Get('WebURL');
1676 return ($url, RT::Test::Web->new);
1682 return unless @SERVERS;
1684 kill 'TERM', @SERVERS;
1685 foreach my $pid (@SERVERS) {
1686 if ($ENV{RT_TEST_WEB_HANDLER} =~ /^apache/) {
1687 sleep 1 while kill 0, $pid;
1696 sub temp_directory {
1697 return $tmp{'directory'};
1705 $path = File::Spec->catfile( @$path ) if ref $path eq 'ARRAY';
1707 open( my $fh, "<:raw", $path )
1709 warn "couldn't open file '$path': $!" unless $args{noexist};
1712 my $content = do { local $/; <$fh> };
1715 unlink $path if $args{'unlink'};
1720 sub find_executable {
1723 return File::Which::which( @_ );
1727 return unless $ENV{RT_TEST_VERBOSE} || $ENV{TEST_VERBOSE};
1728 goto \&Test::More::diag;
1733 require RT::EmailParser;
1734 my $parser = RT::EmailParser->new;
1735 $parser->ParseMIMEEntityFromScalar( $mail );
1736 return $parser->Entity;
1740 Test::More::ok($_[0], $_[1] || 'This works');
1744 Test::More::ok(!$_[0], $_[1] || 'This should fail');
1748 my ($cmd, @args) = @_;
1749 my $builder = RT::Test->builder;
1751 if ($cmd eq "skip_all") {
1752 $check_warnings_in_end = 0;
1753 } elsif ($cmd eq "tests") {
1754 # Increment the test count for the warnings check
1757 $builder->plan($cmd, @args);
1761 my $builder = RT::Test->builder;
1763 Test::NoWarnings::had_no_warnings();
1764 $check_warnings_in_end = 0;
1766 $builder->done_testing(@_);
1770 my $Test = RT::Test->builder;
1771 return if $Test->{Original_Pid} != $$;
1773 # we are in END block and should protect our exit code
1774 # so calls below may call system or kill that clobbers $?
1777 Test::NoWarnings::had_no_warnings() if $check_warnings_in_end;
1779 RT::Test->stop_server(1);
1782 if ( !$Test->is_passing ) {
1783 $tmp{'directory'}->unlink_on_destroy(0);
1786 "Some tests failed or we bailed out, tmp directory"
1787 ." '$tmp{directory}' is not cleaned"
1791 if ( $ENV{RT_TEST_PARALLEL} && $created_new_db ) {
1795 # Drop our port from t/tmp/ports; do this after dropping the
1796 # database, as our port lock is also a lock on the database name.
1799 my $portfile = "$tmp{'directory'}/../ports";
1800 sysopen(PORTS, $portfile, O_RDWR|O_CREAT)
1801 or die "Can't write to ports file $portfile: $!";
1802 flock(PORTS, LOCK_EX)
1803 or die "Can't write-lock ports file $portfile: $!";
1804 $ports{$_}++ for split ' ', join("",<PORTS>);
1805 delete $ports{$port};
1808 print PORTS "$_\n" for sort {$a <=> $b} keys %ports;
1809 close(PORTS) or die "Can't close ports file: $!";
1814 # ease the used only once warning
1817 %{'RT::I18N::en_us::Lexicon'};
1818 %{'Win32::Locale::Lexicon'};