1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2014 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';
58 # We use the Test::NoWarnings catching and reporting functionality, but need to
59 # wrap it in our own special handler because of the warn handler installed via
61 require Test::NoWarnings;
63 my $Test_NoWarnings_Catcher = $SIG{__WARN__};
64 my $check_warnings_in_end = 1;
67 use File::Temp qw(tempfile);
68 use File::Path qw(mkpath);
71 our @EXPORT = qw(is_empty diag parse_mail works fails plan done_testing);
92 To run the rt test suite with coverage support, install L<Devel::Cover> and run:
94 make test RT_DBA_USER=.. RT_DBA_PASSWORD=.. HARNESS_PERL_SWITCHES=-MDevel::Cover
95 cover -ignore_re '^var/mason_data/' -ignore_re '^t/'
97 The coverage tests have DevelMode turned off, and have
98 C<named_component_subs> enabled for L<HTML::Mason> to avoid an optimizer
99 problem in Perl that hides the top-level optree from L<Devel::Cover>.
107 delete $ENV{$_} for qw/LANGUAGE LC_ALL LC_MESSAGES LANG/;
113 my %args = %rttest_opt = @_;
115 $rttest_opt{'nodb'} = $args{'nodb'} = 1 if $^C;
117 # Spit out a plan (if we got one) *before* we load modules
118 if ( $args{'tests'} ) {
119 plan( tests => $args{'tests'} )
120 unless $args{'tests'} eq 'no_declare';
122 elsif ( exists $args{'tests'} ) {
123 # do nothing if they say "tests => undef" - let them make the plan
125 elsif ( $args{'skip_all'} ) {
126 plan(skip_all => $args{'skip_all'});
129 $class->builder->no_plan unless $class->builder->has_plan;
132 push @{ $args{'plugins'} ||= [] }, @{ $args{'requires'} }
133 if $args{'requires'};
134 push @{ $args{'plugins'} ||= [] }, $args{'testing'}
137 $class->bootstrap_tempdir;
139 $class->bootstrap_port;
141 $class->bootstrap_plugins_paths( %args );
143 $class->bootstrap_config( %args );
148 if (RT->Config->Get('DevelMode')) { require Module::Refresh; }
150 RT::InitPluginPaths();
153 $class->bootstrap_db( %args );
163 RT->Config->PostLoadCheck;
165 $class->set_config_wrapper;
167 $class->encode_output;
169 my $screen_logger = $RT::Logger->remove( 'screen' );
170 require Log::Dispatch::Perl;
171 $RT::Logger->add( Log::Dispatch::Perl->new
173 min_level => $screen_logger->min_level,
174 action => { error => 'warn',
175 critical => 'warn' } ) );
177 # XXX: this should really be totally isolated environment so we
178 # can parallelize and be sane
179 mkpath [ $RT::MasonSessionDir ]
180 if RT->Config->Get('DatabaseType');
183 while ( my ($package) = caller($level-1) ) {
184 last unless $package =~ /Test/;
188 Test::More->export_to_level($level);
189 Test::NoWarnings->export_to_level($level);
191 # Blow away symbols we redefine to avoid warnings.
192 # better than "no warnings 'redefine'" because we might accidentally
193 # suppress a mistaken redefinition
195 delete ${ caller($level) . '::' }{diag};
196 delete ${ caller($level) . '::' }{plan};
197 delete ${ caller($level) . '::' }{done_testing};
198 __PACKAGE__->export_to_level($level);
203 local $Test::Builder::Level = $Test::Builder::Level + 1;
204 return Test::More::ok(1, $d) unless defined $v;
205 return Test::More::ok(1, $d) unless length $v;
206 return Test::More::is($v, '', $d);
209 my $created_new_db; # have we created new db? mainly for parallel testing
211 sub db_requires_no_dba {
213 my $db_type = RT->Config->Get('DatabaseType');
214 return 1 if $db_type eq 'SQLite';
222 # Determine which ports are in use
223 use Fcntl qw(:DEFAULT :flock);
224 my $portfile = "$tmp{'directory'}/../ports";
225 sysopen(PORTS, $portfile, O_RDWR|O_CREAT)
226 or die "Can't write to ports file $portfile: $!";
227 flock(PORTS, LOCK_EX)
228 or die "Can't write-lock ports file $portfile: $!";
229 $ports{$_}++ for split ' ', join("",<PORTS>);
231 # Pick a random port, checking that the port isn't in our in-use
232 # list, and that something isn't already listening there.
234 $port = 1024 + int rand(10_000) + $$ % 1024;
235 redo if $ports{$port};
237 # There is a race condition in here, where some non-RT::Test
238 # process claims the port after we check here but before our
239 # server binds. However, since we mostly care about race
240 # conditions with ourselves under high concurrency, this is
241 # generally good enough.
242 my $paddr = sockaddr_in( $port, inet_aton('localhost') );
243 socket( SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
245 if ( connect( SOCK, $paddr ) ) {
254 # Write back out the in-use ports
257 print PORTS "$_\n" for sort {$a <=> $b} keys %ports;
258 close(PORTS) or die "Can't close ports file: $!";
261 sub bootstrap_tempdir {
263 my ($test_dir, $test_file) = ('t', '');
265 if (File::Spec->rel2abs($0) =~ m{(?:^|[\\/])(x?t)[/\\](.*)}) {
268 $test_file =~ s{[/\\]}{-}g;
271 my $dir_name = File::Spec->rel2abs("$test_dir/tmp");
273 return $tmp{'directory'} = File::Temp->newdir(
274 "${test_file}XXXXXXXX",
279 sub bootstrap_config {
283 $tmp{'config'}{'RT'} = File::Spec->catfile(
284 "$tmp{'directory'}", 'RT_SiteConfig.pm'
286 open( my $config, '>', $tmp{'config'}{'RT'} )
287 or die "Couldn't open $tmp{'config'}{'RT'}: $!";
289 my $dbname = $ENV{RT_TEST_PARALLEL}? "rt4test_$port" : "rt4test";
291 Set( \$WebDomain, "localhost");
292 Set( \$WebPort, $port);
294 Set( \@LexiconLanguages, qw(en zh_TW fr ja));
295 Set( \$RTAddressRegexp , qr/^bad_re_that_doesnt_match\$/i);
297 if ( $ENV{'RT_TEST_DB_SID'} ) { # oracle case
298 print $config "Set( \$DatabaseName , '$ENV{'RT_TEST_DB_SID'}' );\n";
299 print $config "Set( \$DatabaseUser , '$dbname');\n";
301 print $config "Set( \$DatabaseName , '$dbname');\n";
302 print $config "Set( \$DatabaseUser , 'u${dbname}');\n";
304 if ( $ENV{'RT_TEST_DB_HOST'} ) {
305 print $config "Set( \$DatabaseHost , '$ENV{'RT_TEST_DB_HOST'}');\n";
308 if ( $args{'plugins'} ) {
309 print $config "Set( \@Plugins, qw(". join( ' ', @{ $args{'plugins'} } ) .") );\n";
311 my $plugin_data = File::Spec->rel2abs("t/data/plugins");
312 print $config qq[\$RT::PluginPath = "$plugin_data";\n];
315 if ( $INC{'Devel/Cover.pm'} ) {
316 print $config "Set( \$DevelMode, 0 );\n";
318 elsif ( $ENV{RT_TEST_DEVEL} ) {
319 print $config "Set( \$DevelMode, 1 );\n";
322 print $config "Set( \$DevelMode, 0 );\n";
325 $self->bootstrap_logging( $config );
328 my $mail_catcher = $tmp{'mailbox'} = File::Spec->catfile(
329 $tmp{'directory'}->dirname, 'mailbox.eml'
332 Set( \$MailCommand, sub {
335 open( my \$handle, '>>', '$mail_catcher' )
336 or die "Unable to open '$mail_catcher' for appending: \$!";
338 \$MIME->print(\$handle);
339 print \$handle "%% split me! %%\n";
344 $self->bootstrap_more_config($config, \%args);
346 print $config $args{'config'} if $args{'config'};
348 print $config "\n1;\n";
349 $ENV{'RT_SITE_CONFIG'} = $tmp{'config'}{'RT'};
355 sub bootstrap_more_config { }
357 sub bootstrap_logging {
361 # prepare file for logging
362 $tmp{'log'}{'RT'} = File::Spec->catfile(
363 "$tmp{'directory'}", 'rt.debug.log'
365 open( my $fh, '>', $tmp{'log'}{'RT'} )
366 or die "Couldn't open $tmp{'config'}{'RT'}: $!";
367 # make world writable so apache under different user
369 chmod 0666, $tmp{'log'}{'RT'};
372 Set( \$LogToSyslog , undef);
373 Set( \$LogToScreen , "warning");
374 Set( \$LogToFile, 'debug' );
375 Set( \$LogDir, q{$tmp{'directory'}} );
376 Set( \$LogToFileNamed, 'rt.debug.log' );
380 sub set_config_wrapper {
383 my $old_sub = \&RT::Config::Set;
384 no warnings 'redefine';
385 *RT::Config::Set = sub {
386 # Determine if the caller is either from a test script, or
387 # from helper functions called by test script to alter
388 # configuration that should be written. This is necessary
389 # because some extensions (RTIR, for example) temporarily swap
390 # configuration values out and back in Mason during requests.
391 my @caller = caller(1); # preserve list context
392 @caller = caller(0) unless @caller;
394 if ( ($caller[1]||'') =~ /\.t$/) {
395 my ($self, $name) = @_;
396 my $type = $RT::Config::META{$name}->{'Type'} || 'SCALAR';
402 my $sigil = $sigils{$type} || $sigils{'SCALAR'};
403 open( my $fh, '>>', $tmp{'config'}{'RT'} )
404 or die "Couldn't open config file: $!";
405 require Data::Dumper;
406 local $Data::Dumper::Terse = 1;
407 my $dump = Data::Dumper::Dumper([@_[2 .. $#_]]);
410 "\nSet(${sigil}${name}, \@{". $dump ."});\n1;\n";
414 warn "you're changing config option in a test file"
415 ." when server is active";
418 return $old_sub->(@_);
423 my $builder = Test::More->builder;
424 binmode $builder->output, ":encoding(utf8)";
425 binmode $builder->failure_output, ":encoding(utf8)";
426 binmode $builder->todo_output, ":encoding(utf8)";
433 unless (defined $ENV{'RT_DBA_USER'} && defined $ENV{'RT_DBA_PASSWORD'}) {
434 Test::More::BAIL_OUT(
435 "RT_DBA_USER and RT_DBA_PASSWORD environment variables need"
436 ." to be set in order to run 'make test'"
437 ) unless $self->db_requires_no_dba;
441 if (my $forceopt = $ENV{RT_TEST_FORCE_OPT}) {
442 Test::More::diag "forcing $forceopt";
446 # Short-circuit the rest of ourselves if we don't want a db
452 my $db_type = RT->Config->Get('DatabaseType');
454 __reconnect_rt('as dba');
455 $RT::Handle->InsertSchema;
456 $RT::Handle->InsertACL unless $db_type eq 'Oracle';
461 $RT::Handle->InsertInitialData
462 unless $args{noinitialdata};
464 $RT::Handle->InsertData( $RT::EtcPath . "/initialdata" )
465 unless $args{noinitialdata} or $args{nodata};
467 $self->bootstrap_plugins_db( %args );
470 sub bootstrap_plugins_paths {
474 return unless $args{'plugins'};
475 my @plugins = @{ $args{'plugins'} };
478 if ( $args{'testing'} ) {
480 $cwd = Cwd::getcwd();
484 my $old_func = \&RT::Plugin::_BasePath;
485 no warnings 'redefine';
486 *RT::Plugin::_BasePath = sub {
487 my $name = $_[0]->{'name'};
489 return $cwd if $args{'testing'} && $name eq $args{'testing'};
491 if ( grep $name eq $_, @plugins ) {
492 my $variants = join "(?:|::|-|_)", map "\Q$_\E", split /::/, $name;
493 my ($path) = map $ENV{$_}, grep /^CHIMPS_(?:$variants).*_ROOT$/i, keys %ENV;
494 return $path if $path;
496 return $old_func->(@_);
500 sub bootstrap_plugins_db {
504 return unless $args{'plugins'};
508 my @plugins = @{ $args{'plugins'} };
509 foreach my $name ( @plugins ) {
510 my $plugin = RT::Plugin->new( name => $name );
511 Test::More::diag( "Initializing DB for the $name plugin" )
512 if $ENV{'TEST_VERBOSE'};
514 my $etc_path = $plugin->Path('etc');
515 Test::More::diag( "etc path of the plugin is '$etc_path'" )
516 if $ENV{'TEST_VERBOSE'};
518 unless ( -e $etc_path ) {
519 # We can't tell if the plugin has no data, or we screwed up the etc/ path
520 Test::More::ok(1, "There is no etc dir: no schema" );
521 Test::More::ok(1, "There is no etc dir: no ACLs" );
522 Test::More::ok(1, "There is no etc dir: no data" );
526 __reconnect_rt('as dba');
529 my ($ret, $msg) = $RT::Handle->InsertSchema( undef, $etc_path );
530 Test::More::ok($ret || $msg =~ /^Couldn't find schema/, "Created schema: ".($msg||''));
534 my ($ret, $msg) = $RT::Handle->InsertACL( undef, $etc_path );
535 Test::More::ok($ret || $msg =~ /^Couldn't find ACLs/, "Created ACL: ".($msg||''));
539 my $data_file = File::Spec->catfile( $etc_path, 'initialdata' );
540 if ( -e $data_file ) {
542 my ($ret, $msg) = $RT::Handle->InsertData( $data_file );;
543 Test::More::ok($ret, "Inserted data".($msg||''));
545 Test::More::ok(1, "There is no data file" );
552 my ($dsn, $user, $pass) = @_;
553 if ( $dsn =~ /Oracle/i ) {
554 $ENV{'NLS_LANG'} = "AMERICAN_AMERICA.AL32UTF8";
555 $ENV{'NLS_NCHAR'} = "AL32UTF8";
557 my $dbh = DBI->connect(
559 { RaiseError => 0, PrintError => 1 },
562 my $msg = "Failed to connect to $dsn as user '$user': ". $DBI::errstr;
563 print STDERR $msg; exit -1;
568 sub __create_database {
569 # bootstrap with dba cred
571 RT::Handle->SystemDSN,
572 $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD}
575 unless ( $ENV{RT_TEST_PARALLEL} ) {
576 # already dropped db in parallel tests, need to do so for other cases.
577 __drop_database( $dbh );
580 RT::Handle->CreateDatabase( $dbh );
585 sub __drop_database {
588 # Pg doesn't like if you issue a DROP DATABASE while still connected
589 # it's still may fail if web-server is out there and holding a connection
592 my $my_dbh = $dbh? 0 : 1;
594 RT::Handle->SystemDSN,
595 $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD}
598 # We ignore errors intentionally by not checking the return value of
599 # DropDatabase below, so let's also suppress DBI's printing of errors when
600 # we overzealously drop.
601 local $dbh->{PrintError} = 0;
602 local $dbh->{PrintWarn} = 0;
604 RT::Handle->DropDatabase( $dbh );
605 $dbh->disconnect if $my_dbh;
612 # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation
613 $RT::Handle = RT::Handle->new;
614 $RT::Handle->dbh( undef );
615 $RT::Handle->Connect(
617 ? (User => $ENV{RT_DBA_USER}, Password => $ENV{RT_DBA_PASSWORD})
620 $RT::Handle->PrintError;
621 $RT::Handle->dbh->{PrintError} = 1;
622 return $RT::Handle->dbh;
625 sub __disconnect_rt {
626 # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation
627 $RT::Handle->dbh->disconnect if $RT::Handle and $RT::Handle->dbh;
629 %DBIx::SearchBuilder::Handle::DBIHandle = ();
630 $DBIx::SearchBuilder::Handle::PrevHandle = undef;
634 delete $RT::System->{attributes};
636 DBIx::SearchBuilder::Record::Cachable->FlushCache
637 if DBIx::SearchBuilder::Record::Cachable->can("FlushCache");
643 # We use local to ensure that the $filter we grab is from InitLogging
644 # and not the handler generated by a previous call to this function
646 local $SIG{__WARN__};
648 $filter = $SIG{__WARN__};
650 $SIG{__WARN__} = sub {
651 $filter->(@_) if $filter;
652 # Avoid reporting this anonymous call frame as the source of the warning.
653 goto &$Test_NoWarnings_Catcher;
660 =head2 load_or_create_user
664 sub load_or_create_user {
666 my %args = ( Privileged => 1, Disabled => 0, @_ );
668 my $MemberOf = delete $args{'MemberOf'};
669 $MemberOf = [ $MemberOf ] if defined $MemberOf && !ref $MemberOf;
672 my $obj = RT::User->new( RT->SystemUser );
673 if ( $args{'Name'} ) {
674 $obj->LoadByCols( Name => $args{'Name'} );
675 } elsif ( $args{'EmailAddress'} ) {
676 $obj->LoadByCols( EmailAddress => $args{'EmailAddress'} );
678 die "Name or EmailAddress is required";
682 $obj->SetPrivileged( $args{'Privileged'} || 0 )
683 if ($args{'Privileged'}||0) != ($obj->Privileged||0);
684 $obj->SetDisabled( $args{'Disabled'} || 0 )
685 if ($args{'Disabled'}||0) != ($obj->Disabled||0);
687 my ($val, $msg) = $obj->Create( %args );
688 die "$msg" unless $val;
691 # clean group membership
693 require RT::GroupMembers;
694 my $gms = RT::GroupMembers->new( RT->SystemUser );
695 my $groups_alias = $gms->Join(
696 FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id',
698 $gms->Limit( ALIAS => $groups_alias, FIELD => 'Domain', VALUE => 'UserDefined' );
699 $gms->Limit( FIELD => 'MemberId', VALUE => $obj->id );
700 while ( my $group_member_record = $gms->Next ) {
701 $group_member_record->Delete;
705 # add new user to groups
706 foreach ( @$MemberOf ) {
707 my $group = RT::Group->new( RT::SystemUser() );
708 $group->LoadUserDefinedGroup( $_ );
709 die "couldn't load group '$_'" unless $group->id;
710 $group->AddMember( $obj->id );
717 sub load_or_create_group {
722 my $group = RT::Group->new( RT->SystemUser );
723 $group->LoadUserDefinedGroup( $name );
724 unless ( $group->id ) {
725 my ($id, $msg) = $group->CreateUserDefinedGroup(
728 die "$msg" unless $id;
731 if ( $args{Members} ) {
732 my $cur = $group->MembersObj;
733 while ( my $entry = $cur->Next ) {
734 my ($status, $msg) = $entry->Delete;
735 die "$msg" unless $status;
738 foreach my $new ( @{ $args{Members} } ) {
739 my ($status, $msg) = $group->AddMember(
740 ref($new)? $new->id : $new,
742 die "$msg" unless $status;
749 =head2 load_or_create_queue
753 sub load_or_create_queue {
755 my %args = ( Disabled => 0, @_ );
756 my $obj = RT::Queue->new( RT->SystemUser );
757 if ( $args{'Name'} ) {
758 $obj->LoadByCols( Name => $args{'Name'} );
760 die "Name is required";
762 unless ( $obj->id ) {
763 my ($val, $msg) = $obj->Create( %args );
764 die "$msg" unless $val;
766 my @fields = qw(CorrespondAddress CommentAddress);
767 foreach my $field ( @fields ) {
768 next unless exists $args{ $field };
769 next if $args{ $field } eq ($obj->$field || '');
771 no warnings 'uninitialized';
772 my $method = 'Set'. $field;
773 my ($val, $msg) = $obj->$method( $args{ $field } );
774 die "$msg" unless $val;
781 sub delete_queue_watchers {
785 foreach my $q ( @queues ) {
786 foreach my $t (qw(Cc AdminCc) ) {
787 $q->DeleteWatcher( Type => $t, PrincipalId => $_->MemberId )
788 foreach @{ $q->$t()->MembersObj->ItemsArrayRef };
794 local $Test::Builder::Level = $Test::Builder::Level + 1;
797 my $defaults = shift;
799 @data = sort { rand(100) <=> rand(100) } @data
800 if delete $defaults->{'RandomOrder'};
802 $defaults->{'Queue'} ||= 'General';
806 my %args = %{ shift @data };
807 $args{$_} = $res[ $args{$_} ]->id foreach
808 grep $args{ $_ }, keys %RT::Ticket::LINKTYPEMAP;
809 push @res, $self->create_ticket( %$defaults, %args );
815 local $Test::Builder::Level = $Test::Builder::Level + 1;
820 if ($args{Queue} && $args{Queue} =~ /\D/) {
821 my $queue = RT::Queue->new(RT->SystemUser);
822 if (my $id = $queue->Load($args{Queue}) ) {
825 die ("Error: Invalid queue $args{Queue}");
829 if ( my $content = delete $args{'Content'} ) {
830 $args{'MIMEObj'} = MIME::Entity->build(
831 From => Encode::encode( "UTF-8", $args{'Requestor'} ),
832 Subject => RT::Interface::Email::EncodeToMIME( String => $args{'Subject'} ),
833 Type => "text/plain",
835 Data => Encode::encode( "UTF-8", $content ),
839 my $ticket = RT::Ticket->new( RT->SystemUser );
840 my ( $id, undef, $msg ) = $ticket->Create( %args );
841 Test::More::ok( $id, "ticket created" )
842 or Test::More::diag("error: $msg");
844 # hackish, but simpler
845 if ( $args{'LastUpdatedBy'} ) {
846 $ticket->__Set( Field => 'LastUpdatedBy', Value => $args{'LastUpdatedBy'} );
850 for my $field ( keys %args ) {
851 #TODO check links and watchers
853 if ( $field =~ /CustomField-(\d+)/ ) {
855 my $got = join ',', sort map $_->Content,
856 @{ $ticket->CustomFieldValues($cf)->ItemsArrayRef };
857 my $expected = ref $args{$field}
858 ? join( ',', sort @{ $args{$field} } )
860 Test::More::is( $got, $expected, 'correct CF values' );
863 next if ref $args{$field};
864 next unless $ticket->can($field) or $ticket->_Accessible($field,"read");
865 next if ref $ticket->$field();
866 Test::More::is( $ticket->$field(), $args{$field}, "$field is correct" );
876 my $tickets = RT::Tickets->new( RT->SystemUser );
878 $tickets->FromSQL( $query );
883 while ( my $ticket = $tickets->Next ) {
888 =head2 load_or_create_custom_field
892 sub load_or_create_custom_field {
894 my %args = ( Disabled => 0, @_ );
895 my $obj = RT::CustomField->new( RT->SystemUser );
896 if ( $args{'Name'} ) {
897 $obj->LoadByName( Name => $args{'Name'}, Queue => $args{'Queue'} );
899 die "Name is required";
901 unless ( $obj->id ) {
902 my ($val, $msg) = $obj->Create( %args );
903 die "$msg" unless $val;
912 $current = $current ? RT::CurrentUser->new($current) : RT->SystemUser;
913 my $tickets = RT::Tickets->new( $current );
914 $tickets->OrderBy( FIELD => 'id', ORDER => 'DESC' );
915 $tickets->Limit( FIELD => 'id', OPERATOR => '>', VALUE => '0' );
916 $tickets->RowsPerPage( 1 );
917 return $tickets->First;
925 RT::ACE->new( RT->SystemUser );
926 my @fields = keys %{ RT::ACE->_ClassAccessible };
929 my $acl = RT::ACL->new( RT->SystemUser );
930 $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
933 while ( my $ace = $acl->Next ) {
934 my $obj = $ace->PrincipalObj->Object;
935 if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == RT->Nobody->id ) {
940 foreach my $field( @fields ) {
941 $tmp{ $field } = $ace->__Value( $field );
951 foreach my $entry ( @entries ) {
952 my $ace = RT::ACE->new( RT->SystemUser );
953 my ($status, $msg) = $ace->RT::Record::Create( %$entry );
955 Test::More::diag "couldn't create a record: $msg";
964 my $acl = RT::ACL->new( RT->SystemUser );
965 $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
966 while ( my $ace = $acl->Next ) {
967 my $obj = $ace->PrincipalObj->Object;
968 if ( $obj->isa('RT::Group') && ($obj->Type||'') eq 'UserEquiv' && $obj->Instance == RT->Nobody->id ) {
973 return $self->add_rights( @_ );
978 my @list = ref $_[0]? @_: @_? { @_ }: ();
981 foreach my $e (@list) {
982 my $principal = delete $e->{'Principal'};
983 unless ( ref $principal ) {
984 if ( $principal =~ /^(everyone|(?:un)?privileged)$/i ) {
985 $principal = RT::Group->new( RT->SystemUser );
986 $principal->LoadSystemInternalGroup($1);
987 } elsif ( $principal =~ /^(Owner|Requestor|(?:Admin)?Cc)$/i ) {
988 $principal = RT::Group->new( RT->SystemUser );
989 $principal->LoadByCols(
990 Domain => (ref($e->{'Object'})||'RT::System').'-Role',
992 ref($e->{'Object'})? (Instance => $e->{'Object'}->id): (),
995 die "principal is not an object, but also is not name of a system group";
998 unless ( $principal->isa('RT::Principal') ) {
999 if ( $principal->can('PrincipalObj') ) {
1000 $principal = $principal->PrincipalObj;
1003 my @rights = ref $e->{'Right'}? @{ $e->{'Right'} }: ($e->{'Right'});
1004 foreach my $right ( @rights ) {
1005 my ($status, $msg) = $principal->GrantRight( %$e, Right => $right );
1006 $RT::Logger->debug($msg);
1015 require RT::Test::Web;
1017 url => RT::Test::Web->rt_base_url,
1019 action => 'correspond',
1022 command => $RT::BinPath .'/rt-mailgate',
1025 my $message = delete $args{'message'};
1027 $args{after_open} = sub {
1028 my $child_in = shift;
1029 if ( UNIVERSAL::isa($message, 'MIME::Entity') ) {
1030 $message->print( $child_in );
1032 print $child_in $message;
1036 $self->run_and_capture(%args);
1041 my %args = (check => 1, resolve => 0, force => 1, timeout => 0, @_ );
1043 my $validator_path = "$RT::SbinPath/rt-validator";
1045 my $cmd = $validator_path;
1046 die "Couldn't find $cmd command" unless -f $cmd;
1048 my $timeout = delete $args{timeout};
1050 while( my ($k,$v) = each %args ) {
1052 $cmd .= " --$k '$v'";
1057 my ($child_out, $child_in);
1058 my $pid = IPC::Open2::open2($child_out, $child_in, $cmd);
1061 local $SIG{ALRM} = sub { kill KILL => $pid; die "Timeout!" };
1063 alarm $timeout if $timeout;
1064 my $result = eval { local $/; <$child_out> };
1070 DBIx::SearchBuilder::Record::Cachable->FlushCache
1071 if $args{'resolve'};
1073 return ($?, $result);
1076 sub run_and_capture {
1080 my $after_open = delete $args{after_open};
1082 my $cmd = delete $args{'command'};
1083 die "Couldn't find command ($cmd)" unless -f $cmd;
1085 $cmd .= ' --debug' if delete $args{'debug'};
1087 while( my ($k,$v) = each %args ) {
1089 $cmd .= " --$k '$v'";
1093 DBIx::SearchBuilder::Record::Cachable->FlushCache;
1096 my ($child_out, $child_in);
1097 my $pid = IPC::Open2::open2($child_out, $child_in, $cmd);
1099 $after_open->($child_in, $child_out) if $after_open;
1103 my $result = do { local $/; <$child_out> };
1106 return ($?, $result);
1109 sub send_via_mailgate_and_http {
1111 my $message = shift;
1114 my ($status, $gate_result) = $self->run_mailgate(
1115 message => $message, %args
1119 unless ( $status >> 8 ) {
1120 ($id) = ($gate_result =~ /Ticket:\s*(\d+)/i);
1122 Test::More::diag "Couldn't find ticket id in text:\n$gate_result"
1123 if $ENV{'TEST_VERBOSE'};
1126 Test::More::diag "Mailgate output:\n$gate_result"
1127 if $ENV{'TEST_VERBOSE'};
1129 return ($status, $id);
1133 sub send_via_mailgate {
1135 my $message = shift;
1136 my %args = ( action => 'correspond',
1141 if ( UNIVERSAL::isa( $message, 'MIME::Entity' ) ) {
1142 $message = $message->as_string;
1145 my ( $status, $error_message, $ticket )
1146 = RT::Interface::Email::Gateway( {%args, message => $message} );
1147 return ( $status, $ticket ? $ticket->id : 0 );
1152 sub open_mailgate_ok {
1154 my $baseurl = shift;
1155 my $queue = shift || 'general';
1156 my $action = shift || 'correspond';
1157 Test::More::ok(open(my $mail, '|-', "$RT::BinPath/rt-mailgate --url $baseurl --queue $queue --action $action"), "Opened the mailgate - $!");
1162 sub close_mailgate_ok {
1166 Test::More::is ($? >> 8, 0, "The mail gateway exited normally. yay");
1171 my $expected = shift;
1173 my $mailsent = scalar grep /\S/, split /%% split me! %%\n/,
1174 RT::Test->file_content(
1181 $mailsent, $expected,
1182 "The number of mail sent ($expected) matches. yay"
1186 sub fetch_caught_mails {
1188 return grep /\S/, split /%% split me! %%\n/,
1189 RT::Test->file_content(
1196 sub clean_caught_mails {
1197 unlink $tmp{'mailbox'};
1200 =head2 get_relocatable_dir
1202 Takes a path relative to the location of the test file that is being
1203 run and returns a path that takes the invocation path into account.
1205 e.g. C<RT::Test::get_relocatable_dir(File::Spec->updir(), 'data', 'emails')>
1207 Parent directory traversals (C<..> or File::Spec->updir()) are naively
1208 canonicalized based on the test file path (C<$0>) so that symlinks aren't
1209 followed. This is the exact opposite behaviour of most filesystems and is
1210 considered "wrong", however it is necessary for some subsets of tests which are
1211 symlinked into the testing tree.
1215 sub get_relocatable_dir {
1216 my @directories = File::Spec->splitdir(
1217 File::Spec->rel2abs((File::Spec->splitpath($0))[1])
1219 push @directories, File::Spec->splitdir($_) for @_;
1222 for (@directories) {
1223 if ($_ eq "..") { pop @clean }
1224 elsif ($_ ne ".") { push @clean, $_ }
1226 return File::Spec->catdir(@clean);
1229 =head2 get_relocatable_file
1231 Same as get_relocatable_dir, but takes a file and a path instead
1234 e.g. RT::Test::get_relocatable_file('test-email',
1235 (File::Spec->updir(), 'data', 'emails'))
1239 sub get_relocatable_file {
1241 return File::Spec->catfile(get_relocatable_dir(@_), $file);
1244 sub get_abs_relocatable_dir {
1245 (my $volume, my $directories, my $file) = File::Spec->splitpath($0);
1246 if (File::Spec->file_name_is_absolute($directories)) {
1247 return File::Spec->catdir($directories, @_);
1249 return File::Spec->catdir(Cwd->getcwd(), $directories, @_);
1256 DIR => $tmp{directory},
1261 sub import_gnupg_key {
1264 my $type = shift || 'secret';
1266 $key =~ s/\@/-at-/g;
1267 $key .= ".$type.key";
1269 require RT::Crypt::GnuPG;
1271 # simple strategy find data/gnupg/keys, from the dir where test file lives
1272 # to updirs, try 3 times in total
1273 my $path = File::Spec->catfile( 'data', 'gnupg', 'keys' );
1275 for my $up ( 0 .. 2 ) {
1276 my $p = get_relocatable_dir($path);
1282 $path = File::Spec->catfile( File::Spec->updir(), $path );
1286 die "can't find the dir where gnupg keys are stored"
1289 return RT::Crypt::GnuPG::ImportKey(
1290 RT::Test->file_content( [ $abs_path, $key ] ) );
1294 sub lsign_gnupg_key {
1298 require RT::Crypt::GnuPG; require GnuPG::Interface;
1299 my $gnupg = GnuPG::Interface->new();
1300 my %opt = RT->Config->Get('GnuPGOptions');
1301 $gnupg->options->hash_init(
1302 RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
1303 meta_interactive => 0,
1307 my $handles = GnuPG::Handles->new(
1308 stdin => ($handle{'input'} = IO::Handle->new()),
1309 stdout => ($handle{'output'} = IO::Handle->new()),
1310 stderr => ($handle{'error'} = IO::Handle->new()),
1311 logger => ($handle{'logger'} = IO::Handle->new()),
1312 status => ($handle{'status'} = IO::Handle->new()),
1313 command => ($handle{'command'} = IO::Handle->new()),
1317 local $SIG{'CHLD'} = 'DEFAULT';
1318 local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
1319 my $pid = $gnupg->wrap_call(
1320 handles => $handles,
1321 commands => ['--lsign-key'],
1322 command_args => [$key],
1324 close $handle{'input'};
1325 while ( my $str = readline $handle{'status'} ) {
1326 if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL sign_uid\..*/ ) {
1327 print { $handle{'command'} } "y\n";
1333 close $handle{'output'};
1336 $res{'exit_code'} = $?;
1337 foreach ( qw(error logger status) ) {
1338 $res{$_} = do { local $/; readline $handle{$_} };
1339 delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1342 $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1343 $RT::Logger->warning( $res{'error'} ) if $res{'error'};
1344 $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1345 if ( $err || $res{'exit_code'} ) {
1346 $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
1351 sub trust_gnupg_key {
1355 require RT::Crypt::GnuPG; require GnuPG::Interface;
1356 my $gnupg = GnuPG::Interface->new();
1357 my %opt = RT->Config->Get('GnuPGOptions');
1358 $gnupg->options->hash_init(
1359 RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
1360 meta_interactive => 0,
1364 my $handles = GnuPG::Handles->new(
1365 stdin => ($handle{'input'} = IO::Handle->new()),
1366 stdout => ($handle{'output'} = IO::Handle->new()),
1367 stderr => ($handle{'error'} = IO::Handle->new()),
1368 logger => ($handle{'logger'} = IO::Handle->new()),
1369 status => ($handle{'status'} = IO::Handle->new()),
1370 command => ($handle{'command'} = IO::Handle->new()),
1374 local $SIG{'CHLD'} = 'DEFAULT';
1375 local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
1376 my $pid = $gnupg->wrap_call(
1377 handles => $handles,
1378 commands => ['--edit-key'],
1379 command_args => [$key],
1381 close $handle{'input'};
1384 while ( my $str = readline $handle{'status'} ) {
1385 if ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE keyedit.prompt/ ) {
1387 print { $handle{'command'} } "quit\n";
1389 print { $handle{'command'} } "trust\n";
1391 } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE edit_ownertrust.value/ ) {
1392 print { $handle{'command'} } "5\n";
1393 } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_BOOL edit_ownertrust.set_ultimate.okay/ ) {
1394 print { $handle{'command'} } "y\n";
1401 close $handle{'output'};
1404 $res{'exit_code'} = $?;
1405 foreach ( qw(error logger status) ) {
1406 $res{$_} = do { local $/; readline $handle{$_} };
1407 delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1410 $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1411 $RT::Logger->warning( $res{'error'} ) if $res{'error'};
1412 $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1413 if ( $err || $res{'exit_code'} ) {
1414 $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
1422 require RT::Test::Web;
1424 if ($rttest_opt{nodb} and not $rttest_opt{server_ok}) {
1425 die "You are trying to use a test web server without a database. "
1426 ."You may want noinitialdata => 1 instead. "
1427 ."Pass server_ok => 1 if you know what you're doing.";
1431 $ENV{'RT_TEST_WEB_HANDLER'} = undef
1432 if $rttest_opt{actual_server} && ($ENV{'RT_TEST_WEB_HANDLER'}||'') eq 'inline';
1433 $ENV{'RT_TEST_WEB_HANDLER'} ||= 'plack';
1434 my $which = $ENV{'RT_TEST_WEB_HANDLER'};
1435 my ($server, $variant) = split /\+/, $which, 2;
1437 my $function = 'start_'. $server .'_server';
1438 unless ( $self->can($function) ) {
1439 die "Don't know how to start server '$server'";
1441 return $self->$function( variant => $variant, @_ );
1446 my %server_opt = @_;
1451 open( my $warn_fh, ">", \$warnings );
1452 local *STDERR = $warn_fh;
1454 if ($server_opt{variant} and $server_opt{variant} eq 'rt-server') {
1456 my $file = "$RT::SbinPath/rt-server";
1457 my $psgi = do $file;
1459 die "Couldn't parse $file: $@" if $@;
1460 die "Couldn't do $file: $!" unless defined $psgi;
1461 die "Couldn't run $file" unless $psgi;
1466 require RT::Interface::Web::Handler;
1467 $app = RT::Interface::Web::Handler->PSGIApp;
1470 require Plack::Middleware::Test::StashWarnings;
1471 my $stashwarnings = Plack::Middleware::Test::StashWarnings->new(
1472 $ENV{'RT_TEST_WEB_HANDLER'} && $ENV{'RT_TEST_WEB_HANDLER'} eq 'inline' ? ( verbose => 0 ) : () );
1473 $app = $stashwarnings->wrap($app);
1475 if ($server_opt{basic_auth}) {
1476 require Plack::Middleware::Auth::Basic;
1477 $app = Plack::Middleware::Auth::Basic->wrap(
1479 authenticator => sub {
1480 my ($username, $password) = @_;
1481 return $username eq 'root' && $password eq 'password';
1487 $stashwarnings->add_warning( $warnings ) if $warnings;
1492 sub start_plack_server {
1495 require Plack::Loader;
1496 my $plack_server = Plack::Loader->load
1499 server_ready => sub {
1500 kill 'USR1' => getppid();
1503 # We are expecting a USR1 from the child process after it's ready
1504 # to listen. We set this up _before_ we fork to avoid race
1507 local $SIG{USR1} = sub { $handled = 1};
1511 die "failed to fork" unless defined $pid;
1514 sleep 15 unless $handled;
1515 Test::More::diag "did not get expected USR1 for test server readiness"
1517 push @SERVERS, $pid;
1518 my $Tester = Test::Builder->new;
1519 $Tester->ok(1, "started plack server ok");
1522 unless $rttest_opt{nodb};
1523 return ("http://localhost:$port", RT::Test::Web->new);
1527 if ( $^O !~ /MSWin32/ ) {
1529 or die "Can't start a new session: $!";
1532 # stick this in a scope so that when $app is garbage collected,
1533 # StashWarnings can complain about unhandled warnings
1535 $plack_server->run($self->test_app(@_));
1542 sub start_inline_server {
1545 require Test::WWW::Mechanize::PSGI;
1546 unshift @RT::Test::Web::ISA, 'Test::WWW::Mechanize::PSGI';
1548 # Clear out squished CSS and JS cache, since it's retained across
1549 # servers, since it's in-process
1550 RT::Interface::Web->ClearSquished;
1551 require RT::Interface::Web::Request;
1552 RT::Interface::Web::Request->clear_callback_cache;
1554 Test::More::ok(1, "psgi test server ok");
1555 $TEST_APP = $self->test_app(@_);
1556 return ("http://localhost:$port", RT::Test::Web->new);
1559 sub start_apache_server {
1561 my %server_opt = @_;
1562 $server_opt{variant} ||= 'mod_perl';
1563 $ENV{RT_TEST_WEB_HANDLER} = "apache+$server_opt{variant}";
1565 require RT::Test::Apache;
1566 my $pid = RT::Test::Apache->start_server(
1571 push @SERVERS, $pid;
1573 my $url = RT->Config->Get('WebURL');
1575 return ($url, RT::Test::Web->new);
1581 return unless @SERVERS;
1583 kill 'TERM', @SERVERS;
1584 foreach my $pid (@SERVERS) {
1585 if ($ENV{RT_TEST_WEB_HANDLER} =~ /^apache/) {
1586 sleep 1 while kill 0, $pid;
1595 sub temp_directory {
1596 return $tmp{'directory'};
1604 $path = File::Spec->catfile( @$path ) if ref $path eq 'ARRAY';
1606 open( my $fh, "<:raw", $path )
1608 warn "couldn't open file '$path': $!" unless $args{noexist};
1611 my $content = do { local $/; <$fh> };
1614 unlink $path if $args{'unlink'};
1619 sub find_executable {
1624 foreach my $dir ( split /:/, $ENV{'PATH'} ) {
1625 my $fpath = File::Spec->catpath(
1626 (File::Spec->splitpath( $dir, 'no file' ))[0..1], $name
1628 next unless -e $fpath && -r _ && -x _;
1635 return unless $ENV{RT_TEST_VERBOSE} || $ENV{TEST_VERBOSE};
1636 goto \&Test::More::diag;
1641 require RT::EmailParser;
1642 my $parser = RT::EmailParser->new;
1643 $parser->ParseMIMEEntityFromScalar( $mail );
1644 return $parser->Entity;
1648 Test::More::ok($_[0], $_[1] || 'This works');
1652 Test::More::ok(!$_[0], $_[1] || 'This should fail');
1656 my ($cmd, @args) = @_;
1657 my $builder = RT::Test->builder;
1659 if ($cmd eq "skip_all") {
1660 $check_warnings_in_end = 0;
1661 } elsif ($cmd eq "tests") {
1662 # Increment the test count for the warnings check
1665 $builder->plan($cmd, @args);
1669 my $builder = RT::Test->builder;
1671 Test::NoWarnings::had_no_warnings();
1672 $check_warnings_in_end = 0;
1674 $builder->done_testing(@_);
1678 my $Test = RT::Test->builder;
1679 return if $Test->{Original_Pid} != $$;
1681 # we are in END block and should protect our exit code
1682 # so calls below may call system or kill that clobbers $?
1685 Test::NoWarnings::had_no_warnings() if $check_warnings_in_end;
1687 RT::Test->stop_server(1);
1690 if ( !$Test->is_passing ) {
1691 $tmp{'directory'}->unlink_on_destroy(0);
1694 "Some tests failed or we bailed out, tmp directory"
1695 ." '$tmp{directory}' is not cleaned"
1699 if ( $ENV{RT_TEST_PARALLEL} && $created_new_db ) {
1703 # Drop our port from t/tmp/ports; do this after dropping the
1704 # database, as our port lock is also a lock on the database name.
1707 my $portfile = "$tmp{'directory'}/../ports";
1708 sysopen(PORTS, $portfile, O_RDWR|O_CREAT)
1709 or die "Can't write to ports file $portfile: $!";
1710 flock(PORTS, LOCK_EX)
1711 or die "Can't write-lock ports file $portfile: $!";
1712 $ports{$_}++ for split ' ', join("",<PORTS>);
1713 delete $ports{$port};
1716 print PORTS "$_\n" for sort {$a <=> $b} keys %ports;
1717 close(PORTS) or die "Can't close ports file: $!";
1722 # ease the used only once warning
1725 %{'RT::I18N::en_us::Lexicon'};
1726 %{'Win32::Locale::Lexicon'};