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 my $screen_logger = $RT::Logger->remove( 'screen' );
168 require Log::Dispatch::Perl;
169 $RT::Logger->add( Log::Dispatch::Perl->new
171 min_level => $screen_logger->min_level,
172 action => { error => 'warn',
173 critical => 'warn' } ) );
175 # XXX: this should really be totally isolated environment so we
176 # can parallelize and be sane
177 mkpath [ $RT::MasonSessionDir ]
178 if RT->Config->Get('DatabaseType');
181 while ( my ($package) = caller($level-1) ) {
182 last unless $package =~ /Test/;
186 Test::More->export_to_level($level);
187 Test::NoWarnings->export_to_level($level);
189 # Blow away symbols we redefine to avoid warnings.
190 # better than "no warnings 'redefine'" because we might accidentally
191 # suppress a mistaken redefinition
193 delete ${ caller($level) . '::' }{diag};
194 delete ${ caller($level) . '::' }{plan};
195 delete ${ caller($level) . '::' }{done_testing};
196 __PACKAGE__->export_to_level($level);
201 local $Test::Builder::Level = $Test::Builder::Level + 1;
202 return Test::More::ok(1, $d) unless defined $v;
203 return Test::More::ok(1, $d) unless length $v;
204 return Test::More::is($v, '', $d);
207 my $created_new_db; # have we created new db? mainly for parallel testing
209 sub db_requires_no_dba {
211 my $db_type = RT->Config->Get('DatabaseType');
212 return 1 if $db_type eq 'SQLite';
220 # Determine which ports are in use
221 use Fcntl qw(:DEFAULT :flock);
222 my $portfile = "$tmp{'directory'}/../ports";
223 sysopen(PORTS, $portfile, O_RDWR|O_CREAT)
224 or die "Can't write to ports file $portfile: $!";
225 flock(PORTS, LOCK_EX)
226 or die "Can't write-lock ports file $portfile: $!";
227 $ports{$_}++ for split ' ', join("",<PORTS>);
229 # Pick a random port, checking that the port isn't in our in-use
230 # list, and that something isn't already listening there.
232 $port = 1024 + int rand(10_000) + $$ % 1024;
233 redo if $ports{$port};
235 # There is a race condition in here, where some non-RT::Test
236 # process claims the port after we check here but before our
237 # server binds. However, since we mostly care about race
238 # conditions with ourselves under high concurrency, this is
239 # generally good enough.
240 my $paddr = sockaddr_in( $port, inet_aton('localhost') );
241 socket( SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
243 if ( connect( SOCK, $paddr ) ) {
252 # Write back out the in-use ports
255 print PORTS "$_\n" for sort {$a <=> $b} keys %ports;
256 close(PORTS) or die "Can't close ports file: $!";
259 sub bootstrap_tempdir {
261 my ($test_dir, $test_file) = ('t', '');
263 if (File::Spec->rel2abs($0) =~ m{(?:^|[\\/])(x?t)[/\\](.*)}) {
266 $test_file =~ s{[/\\]}{-}g;
269 my $dir_name = File::Spec->rel2abs("$test_dir/tmp");
271 return $tmp{'directory'} = File::Temp->newdir(
272 "${test_file}XXXXXXXX",
277 sub bootstrap_config {
281 $tmp{'config'}{'RT'} = File::Spec->catfile(
282 "$tmp{'directory'}", 'RT_SiteConfig.pm'
284 open( my $config, '>', $tmp{'config'}{'RT'} )
285 or die "Couldn't open $tmp{'config'}{'RT'}: $!";
287 my $dbname = $ENV{RT_TEST_PARALLEL}? "rt4test_$port" : "rt4test";
289 Set( \$WebDomain, "localhost");
290 Set( \$WebPort, $port);
292 Set( \@LexiconLanguages, qw(en zh_TW fr ja));
293 Set( \$RTAddressRegexp , qr/^bad_re_that_doesnt_match\$/i);
295 if ( $ENV{'RT_TEST_DB_SID'} ) { # oracle case
296 print $config "Set( \$DatabaseName , '$ENV{'RT_TEST_DB_SID'}' );\n";
297 print $config "Set( \$DatabaseUser , '$dbname');\n";
299 print $config "Set( \$DatabaseName , '$dbname');\n";
300 print $config "Set( \$DatabaseUser , 'u${dbname}');\n";
302 if ( $ENV{'RT_TEST_DB_HOST'} ) {
303 print $config "Set( \$DatabaseHost , '$ENV{'RT_TEST_DB_HOST'}');\n";
306 if ( $args{'plugins'} ) {
307 print $config "Set( \@Plugins, qw(". join( ' ', @{ $args{'plugins'} } ) .") );\n";
309 my $plugin_data = File::Spec->rel2abs("t/data/plugins");
310 print $config qq[\$RT::PluginPath = "$plugin_data";\n];
313 if ( $INC{'Devel/Cover.pm'} ) {
314 print $config "Set( \$DevelMode, 0 );\n";
316 elsif ( $ENV{RT_TEST_DEVEL} ) {
317 print $config "Set( \$DevelMode, 1 );\n";
320 print $config "Set( \$DevelMode, 0 );\n";
323 $self->bootstrap_logging( $config );
326 my $mail_catcher = $tmp{'mailbox'} = File::Spec->catfile(
327 $tmp{'directory'}->dirname, 'mailbox.eml'
330 Set( \$MailCommand, sub {
333 open( my \$handle, '>>', '$mail_catcher' )
334 or die "Unable to open '$mail_catcher' for appending: \$!";
336 \$MIME->print(\$handle);
337 print \$handle "%% split me! %%\n";
342 $self->bootstrap_more_config($config, \%args);
344 print $config $args{'config'} if $args{'config'};
346 print $config "\n1;\n";
347 $ENV{'RT_SITE_CONFIG'} = $tmp{'config'}{'RT'};
353 sub bootstrap_more_config { }
355 sub bootstrap_logging {
359 # prepare file for logging
360 $tmp{'log'}{'RT'} = File::Spec->catfile(
361 "$tmp{'directory'}", 'rt.debug.log'
363 open( my $fh, '>', $tmp{'log'}{'RT'} )
364 or die "Couldn't open $tmp{'config'}{'RT'}: $!";
365 # make world writable so apache under different user
367 chmod 0666, $tmp{'log'}{'RT'};
370 Set( \$LogToSyslog , undef);
371 Set( \$LogToScreen , "warning");
372 Set( \$LogToFile, 'debug' );
373 Set( \$LogDir, q{$tmp{'directory'}} );
374 Set( \$LogToFileNamed, 'rt.debug.log' );
378 sub set_config_wrapper {
381 my $old_sub = \&RT::Config::Set;
382 no warnings 'redefine';
383 *RT::Config::Set = sub {
384 # Determine if the caller is either from a test script, or
385 # from helper functions called by test script to alter
386 # configuration that should be written. This is necessary
387 # because some extensions (RTIR, for example) temporarily swap
388 # configuration values out and back in Mason during requests.
389 my @caller = caller(1); # preserve list context
390 @caller = caller(0) unless @caller;
392 if ( ($caller[1]||'') =~ /\.t$/) {
393 my ($self, $name) = @_;
394 my $type = $RT::Config::META{$name}->{'Type'} || 'SCALAR';
400 my $sigil = $sigils{$type} || $sigils{'SCALAR'};
401 open( my $fh, '>>', $tmp{'config'}{'RT'} )
402 or die "Couldn't open config file: $!";
403 require Data::Dumper;
404 local $Data::Dumper::Terse = 1;
405 my $dump = Data::Dumper::Dumper([@_[2 .. $#_]]);
408 "\nSet(${sigil}${name}, \@{". $dump ."});\n1;\n";
412 warn "you're changing config option in a test file"
413 ." when server is active";
416 return $old_sub->(@_);
424 unless (defined $ENV{'RT_DBA_USER'} && defined $ENV{'RT_DBA_PASSWORD'}) {
425 Test::More::BAIL_OUT(
426 "RT_DBA_USER and RT_DBA_PASSWORD environment variables need"
427 ." to be set in order to run 'make test'"
428 ) unless $self->db_requires_no_dba;
432 if (my $forceopt = $ENV{RT_TEST_FORCE_OPT}) {
433 Test::More::diag "forcing $forceopt";
437 # Short-circuit the rest of ourselves if we don't want a db
443 my $db_type = RT->Config->Get('DatabaseType');
445 __reconnect_rt('as dba');
446 $RT::Handle->InsertSchema;
447 $RT::Handle->InsertACL unless $db_type eq 'Oracle';
452 $RT::Handle->InsertInitialData
453 unless $args{noinitialdata};
455 $RT::Handle->InsertData( $RT::EtcPath . "/initialdata" )
456 unless $args{noinitialdata} or $args{nodata};
458 $self->bootstrap_plugins_db( %args );
461 sub bootstrap_plugins_paths {
465 return unless $args{'plugins'};
466 my @plugins = @{ $args{'plugins'} };
469 if ( $args{'testing'} ) {
471 $cwd = Cwd::getcwd();
475 my $old_func = \&RT::Plugin::_BasePath;
476 no warnings 'redefine';
477 *RT::Plugin::_BasePath = sub {
478 my $name = $_[0]->{'name'};
480 return $cwd if $args{'testing'} && $name eq $args{'testing'};
482 if ( grep $name eq $_, @plugins ) {
483 my $variants = join "(?:|::|-|_)", map "\Q$_\E", split /::/, $name;
484 my ($path) = map $ENV{$_}, grep /^CHIMPS_(?:$variants).*_ROOT$/i, keys %ENV;
485 return $path if $path;
487 return $old_func->(@_);
491 sub bootstrap_plugins_db {
495 return unless $args{'plugins'};
499 my @plugins = @{ $args{'plugins'} };
500 foreach my $name ( @plugins ) {
501 my $plugin = RT::Plugin->new( name => $name );
502 Test::More::diag( "Initializing DB for the $name plugin" )
503 if $ENV{'TEST_VERBOSE'};
505 my $etc_path = $plugin->Path('etc');
506 Test::More::diag( "etc path of the plugin is '$etc_path'" )
507 if $ENV{'TEST_VERBOSE'};
509 unless ( -e $etc_path ) {
510 # We can't tell if the plugin has no data, or we screwed up the etc/ path
511 Test::More::ok(1, "There is no etc dir: no schema" );
512 Test::More::ok(1, "There is no etc dir: no ACLs" );
513 Test::More::ok(1, "There is no etc dir: no data" );
517 __reconnect_rt('as dba');
520 my ($ret, $msg) = $RT::Handle->InsertSchema( undef, $etc_path );
521 Test::More::ok($ret || $msg =~ /^Couldn't find schema/, "Created schema: ".($msg||''));
525 my ($ret, $msg) = $RT::Handle->InsertACL( undef, $etc_path );
526 Test::More::ok($ret || $msg =~ /^Couldn't find ACLs/, "Created ACL: ".($msg||''));
530 my $data_file = File::Spec->catfile( $etc_path, 'initialdata' );
531 if ( -e $data_file ) {
533 my ($ret, $msg) = $RT::Handle->InsertData( $data_file );;
534 Test::More::ok($ret, "Inserted data".($msg||''));
536 Test::More::ok(1, "There is no data file" );
543 my ($dsn, $user, $pass) = @_;
544 if ( $dsn =~ /Oracle/i ) {
545 $ENV{'NLS_LANG'} = "AMERICAN_AMERICA.AL32UTF8";
546 $ENV{'NLS_NCHAR'} = "AL32UTF8";
548 my $dbh = DBI->connect(
550 { RaiseError => 0, PrintError => 1 },
553 my $msg = "Failed to connect to $dsn as user '$user': ". $DBI::errstr;
554 print STDERR $msg; exit -1;
559 sub __create_database {
560 # bootstrap with dba cred
562 RT::Handle->SystemDSN,
563 $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD}
566 unless ( $ENV{RT_TEST_PARALLEL} ) {
567 # already dropped db in parallel tests, need to do so for other cases.
568 __drop_database( $dbh );
571 RT::Handle->CreateDatabase( $dbh );
576 sub __drop_database {
579 # Pg doesn't like if you issue a DROP DATABASE while still connected
580 # it's still may fail if web-server is out there and holding a connection
583 my $my_dbh = $dbh? 0 : 1;
585 RT::Handle->SystemDSN,
586 $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD}
589 # We ignore errors intentionally by not checking the return value of
590 # DropDatabase below, so let's also suppress DBI's printing of errors when
591 # we overzealously drop.
592 local $dbh->{PrintError} = 0;
593 local $dbh->{PrintWarn} = 0;
595 RT::Handle->DropDatabase( $dbh );
596 $dbh->disconnect if $my_dbh;
603 # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation
604 $RT::Handle = RT::Handle->new;
605 $RT::Handle->dbh( undef );
606 $RT::Handle->Connect(
608 ? (User => $ENV{RT_DBA_USER}, Password => $ENV{RT_DBA_PASSWORD})
611 $RT::Handle->PrintError;
612 $RT::Handle->dbh->{PrintError} = 1;
613 return $RT::Handle->dbh;
616 sub __disconnect_rt {
617 # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation
618 $RT::Handle->dbh->disconnect if $RT::Handle and $RT::Handle->dbh;
620 %DBIx::SearchBuilder::Handle::DBIHandle = ();
621 $DBIx::SearchBuilder::Handle::PrevHandle = undef;
625 delete $RT::System->{attributes};
627 DBIx::SearchBuilder::Record::Cachable->FlushCache
628 if DBIx::SearchBuilder::Record::Cachable->can("FlushCache");
634 # We use local to ensure that the $filter we grab is from InitLogging
635 # and not the handler generated by a previous call to this function
637 local $SIG{__WARN__};
639 $filter = $SIG{__WARN__};
641 $SIG{__WARN__} = sub {
643 my $status = $filter->(@_);
644 if ($status and $status eq 'IGNORE') {
645 return; # pretend the bad dream never happened
648 # Avoid reporting this anonymous call frame as the source of the warning.
649 goto &$Test_NoWarnings_Catcher;
656 =head2 load_or_create_user
660 sub load_or_create_user {
662 my %args = ( Privileged => 1, Disabled => 0, @_ );
664 my $MemberOf = delete $args{'MemberOf'};
665 $MemberOf = [ $MemberOf ] if defined $MemberOf && !ref $MemberOf;
668 my $obj = RT::User->new( RT->SystemUser );
669 if ( $args{'Name'} ) {
670 $obj->LoadByCols( Name => $args{'Name'} );
671 } elsif ( $args{'EmailAddress'} ) {
672 $obj->LoadByCols( EmailAddress => $args{'EmailAddress'} );
674 die "Name or EmailAddress is required";
678 $obj->SetPrivileged( $args{'Privileged'} || 0 )
679 if ($args{'Privileged'}||0) != ($obj->Privileged||0);
680 $obj->SetDisabled( $args{'Disabled'} || 0 )
681 if ($args{'Disabled'}||0) != ($obj->Disabled||0);
683 my ($val, $msg) = $obj->Create( %args );
684 die "$msg" unless $val;
687 # clean group membership
689 require RT::GroupMembers;
690 my $gms = RT::GroupMembers->new( RT->SystemUser );
691 my $groups_alias = $gms->Join(
692 FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id',
694 $gms->Limit( ALIAS => $groups_alias, FIELD => 'Domain', VALUE => 'UserDefined' );
695 $gms->Limit( FIELD => 'MemberId', VALUE => $obj->id );
696 while ( my $group_member_record = $gms->Next ) {
697 $group_member_record->Delete;
701 # add new user to groups
702 foreach ( @$MemberOf ) {
703 my $group = RT::Group->new( RT::SystemUser() );
704 $group->LoadUserDefinedGroup( $_ );
705 die "couldn't load group '$_'" unless $group->id;
706 $group->AddMember( $obj->id );
712 =head2 load_or_create_queue
716 sub load_or_create_queue {
718 my %args = ( Disabled => 0, @_ );
719 my $obj = RT::Queue->new( RT->SystemUser );
720 if ( $args{'Name'} ) {
721 $obj->LoadByCols( Name => $args{'Name'} );
723 die "Name is required";
725 unless ( $obj->id ) {
726 my ($val, $msg) = $obj->Create( %args );
727 die "$msg" unless $val;
729 my @fields = qw(CorrespondAddress CommentAddress);
730 foreach my $field ( @fields ) {
731 next unless exists $args{ $field };
732 next if $args{ $field } eq ($obj->$field || '');
734 no warnings 'uninitialized';
735 my $method = 'Set'. $field;
736 my ($val, $msg) = $obj->$method( $args{ $field } );
737 die "$msg" unless $val;
744 sub delete_queue_watchers {
748 foreach my $q ( @queues ) {
749 foreach my $t (qw(Cc AdminCc) ) {
750 $q->DeleteWatcher( Type => $t, PrincipalId => $_->MemberId )
751 foreach @{ $q->$t()->MembersObj->ItemsArrayRef };
757 local $Test::Builder::Level = $Test::Builder::Level + 1;
760 my $defaults = shift;
762 @data = sort { rand(100) <=> rand(100) } @data
763 if delete $defaults->{'RandomOrder'};
765 $defaults->{'Queue'} ||= 'General';
769 my %args = %{ shift @data };
770 $args{$_} = $res[ $args{$_} ]->id foreach
771 grep $args{ $_ }, keys %RT::Ticket::LINKTYPEMAP;
772 push @res, $self->create_ticket( %$defaults, %args );
778 local $Test::Builder::Level = $Test::Builder::Level + 1;
783 if ($args{Queue} && $args{Queue} =~ /\D/) {
784 my $queue = RT::Queue->new(RT->SystemUser);
785 if (my $id = $queue->Load($args{Queue}) ) {
788 die ("Error: Invalid queue $args{Queue}");
792 if ( my $content = delete $args{'Content'} ) {
793 $args{'MIMEObj'} = MIME::Entity->build(
794 From => $args{'Requestor'},
795 Subject => $args{'Subject'},
800 my $ticket = RT::Ticket->new( RT->SystemUser );
801 my ( $id, undef, $msg ) = $ticket->Create( %args );
802 Test::More::ok( $id, "ticket created" )
803 or Test::More::diag("error: $msg");
805 # hackish, but simpler
806 if ( $args{'LastUpdatedBy'} ) {
807 $ticket->__Set( Field => 'LastUpdatedBy', Value => $args{'LastUpdatedBy'} );
811 for my $field ( keys %args ) {
812 #TODO check links and watchers
814 if ( $field =~ /CustomField-(\d+)/ ) {
816 my $got = join ',', sort map $_->Content,
817 @{ $ticket->CustomFieldValues($cf)->ItemsArrayRef };
818 my $expected = ref $args{$field}
819 ? join( ',', sort @{ $args{$field} } )
821 Test::More::is( $got, $expected, 'correct CF values' );
824 next if ref $args{$field};
825 next unless $ticket->can($field) or $ticket->_Accessible($field,"read");
826 next if ref $ticket->$field();
827 Test::More::is( $ticket->$field(), $args{$field}, "$field is correct" );
837 my $tickets = RT::Tickets->new( RT->SystemUser );
839 $tickets->FromSQL( $query );
844 while ( my $ticket = $tickets->Next ) {
849 =head2 load_or_create_custom_field
853 sub load_or_create_custom_field {
855 my %args = ( Disabled => 0, @_ );
856 my $obj = RT::CustomField->new( RT->SystemUser );
857 if ( $args{'Name'} ) {
858 $obj->LoadByName( Name => $args{'Name'}, Queue => $args{'Queue'} );
860 die "Name is required";
862 unless ( $obj->id ) {
863 my ($val, $msg) = $obj->Create( %args );
864 die "$msg" unless $val;
873 $current = $current ? RT::CurrentUser->new($current) : RT->SystemUser;
874 my $tickets = RT::Tickets->new( $current );
875 $tickets->OrderBy( FIELD => 'id', ORDER => 'DESC' );
876 $tickets->Limit( FIELD => 'id', OPERATOR => '>', VALUE => '0' );
877 $tickets->RowsPerPage( 1 );
878 return $tickets->First;
886 RT::ACE->new( RT->SystemUser );
887 my @fields = keys %{ RT::ACE->_ClassAccessible };
890 my $acl = RT::ACL->new( RT->SystemUser );
891 $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
894 while ( my $ace = $acl->Next ) {
895 my $obj = $ace->PrincipalObj->Object;
896 if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == RT->Nobody->id ) {
901 foreach my $field( @fields ) {
902 $tmp{ $field } = $ace->__Value( $field );
912 foreach my $entry ( @entries ) {
913 my $ace = RT::ACE->new( RT->SystemUser );
914 my ($status, $msg) = $ace->RT::Record::Create( %$entry );
916 Test::More::diag "couldn't create a record: $msg";
925 my $acl = RT::ACL->new( RT->SystemUser );
926 $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
927 while ( my $ace = $acl->Next ) {
928 my $obj = $ace->PrincipalObj->Object;
929 if ( $obj->isa('RT::Group') && ($obj->Type||'') eq 'UserEquiv' && $obj->Instance == RT->Nobody->id ) {
934 return $self->add_rights( @_ );
939 my @list = ref $_[0]? @_: @_? { @_ }: ();
942 foreach my $e (@list) {
943 my $principal = delete $e->{'Principal'};
944 unless ( ref $principal ) {
945 if ( $principal =~ /^(everyone|(?:un)?privileged)$/i ) {
946 $principal = RT::Group->new( RT->SystemUser );
947 $principal->LoadSystemInternalGroup($1);
948 } elsif ( $principal =~ /^(Owner|Requestor|(?:Admin)?Cc)$/i ) {
949 $principal = RT::Group->new( RT->SystemUser );
950 $principal->LoadByCols(
951 Domain => (ref($e->{'Object'})||'RT::System').'-Role',
953 ref($e->{'Object'})? (Instance => $e->{'Object'}->id): (),
956 die "principal is not an object, but also is not name of a system group";
959 unless ( $principal->isa('RT::Principal') ) {
960 if ( $principal->can('PrincipalObj') ) {
961 $principal = $principal->PrincipalObj;
964 my @rights = ref $e->{'Right'}? @{ $e->{'Right'} }: ($e->{'Right'});
965 foreach my $right ( @rights ) {
966 my ($status, $msg) = $principal->GrantRight( %$e, Right => $right );
967 $RT::Logger->debug($msg);
976 require RT::Test::Web;
978 url => RT::Test::Web->rt_base_url,
980 action => 'correspond',
983 command => $RT::BinPath .'/rt-mailgate',
986 my $message = delete $args{'message'};
988 $args{after_open} = sub {
989 my $child_in = shift;
990 if ( UNIVERSAL::isa($message, 'MIME::Entity') ) {
991 $message->print( $child_in );
993 print $child_in $message;
997 $self->run_and_capture(%args);
1000 sub run_and_capture {
1004 my $after_open = delete $args{after_open};
1006 my $cmd = delete $args{'command'};
1007 die "Couldn't find command ($cmd)" unless -f $cmd;
1009 $cmd .= ' --debug' if delete $args{'debug'};
1011 while( my ($k,$v) = each %args ) {
1013 $cmd .= " --$k '$v'";
1017 DBIx::SearchBuilder::Record::Cachable->FlushCache;
1020 my ($child_out, $child_in);
1021 my $pid = IPC::Open2::open2($child_out, $child_in, $cmd);
1023 $after_open->($child_in, $child_out) if $after_open;
1027 my $result = do { local $/; <$child_out> };
1030 return ($?, $result);
1033 sub send_via_mailgate_and_http {
1035 my $message = shift;
1038 my ($status, $gate_result) = $self->run_mailgate(
1039 message => $message, %args
1043 unless ( $status >> 8 ) {
1044 ($id) = ($gate_result =~ /Ticket:\s*(\d+)/i);
1046 Test::More::diag "Couldn't find ticket id in text:\n$gate_result"
1047 if $ENV{'TEST_VERBOSE'};
1050 Test::More::diag "Mailgate output:\n$gate_result"
1051 if $ENV{'TEST_VERBOSE'};
1053 return ($status, $id);
1057 sub send_via_mailgate {
1059 my $message = shift;
1060 my %args = ( action => 'correspond',
1065 if ( UNIVERSAL::isa( $message, 'MIME::Entity' ) ) {
1066 $message = $message->as_string;
1069 my ( $status, $error_message, $ticket )
1070 = RT::Interface::Email::Gateway( {%args, message => $message} );
1071 return ( $status, $ticket ? $ticket->id : 0 );
1076 sub open_mailgate_ok {
1078 my $baseurl = shift;
1079 my $queue = shift || 'general';
1080 my $action = shift || 'correspond';
1081 Test::More::ok(open(my $mail, '|-', "$RT::BinPath/rt-mailgate --url $baseurl --queue $queue --action $action"), "Opened the mailgate - $!");
1086 sub close_mailgate_ok {
1090 Test::More::is ($? >> 8, 0, "The mail gateway exited normally. yay");
1095 my $expected = shift;
1097 my $mailsent = scalar grep /\S/, split /%% split me! %%\n/,
1098 RT::Test->file_content(
1105 $mailsent, $expected,
1106 "The number of mail sent ($expected) matches. yay"
1110 sub fetch_caught_mails {
1112 return grep /\S/, split /%% split me! %%\n/,
1113 RT::Test->file_content(
1120 sub clean_caught_mails {
1121 unlink $tmp{'mailbox'};
1124 =head2 get_relocatable_dir
1126 Takes a path relative to the location of the test file that is being
1127 run and returns a path that takes the invocation path into account.
1129 e.g. C<RT::Test::get_relocatable_dir(File::Spec->updir(), 'data', 'emails')>
1131 Parent directory traversals (C<..> or File::Spec->updir()) are naively
1132 canonicalized based on the test file path (C<$0>) so that symlinks aren't
1133 followed. This is the exact opposite behaviour of most filesystems and is
1134 considered "wrong", however it is necessary for some subsets of tests which are
1135 symlinked into the testing tree.
1139 sub get_relocatable_dir {
1140 my @directories = File::Spec->splitdir(
1141 File::Spec->rel2abs((File::Spec->splitpath($0))[1])
1143 push @directories, File::Spec->splitdir($_) for @_;
1146 for (@directories) {
1147 if ($_ eq "..") { pop @clean }
1148 elsif ($_ ne ".") { push @clean, $_ }
1150 return File::Spec->catdir(@clean);
1153 =head2 get_relocatable_file
1155 Same as get_relocatable_dir, but takes a file and a path instead
1158 e.g. RT::Test::get_relocatable_file('test-email',
1159 (File::Spec->updir(), 'data', 'emails'))
1163 sub get_relocatable_file {
1165 return File::Spec->catfile(get_relocatable_dir(@_), $file);
1168 sub get_abs_relocatable_dir {
1169 (my $volume, my $directories, my $file) = File::Spec->splitpath($0);
1170 if (File::Spec->file_name_is_absolute($directories)) {
1171 return File::Spec->catdir($directories, @_);
1173 return File::Spec->catdir(Cwd->getcwd(), $directories, @_);
1180 DIR => $tmp{directory},
1185 sub import_gnupg_key {
1188 my $type = shift || 'secret';
1190 $key =~ s/\@/-at-/g;
1191 $key .= ".$type.key";
1193 require RT::Crypt::GnuPG;
1195 # simple strategy find data/gnupg/keys, from the dir where test file lives
1196 # to updirs, try 3 times in total
1197 my $path = File::Spec->catfile( 'data', 'gnupg', 'keys' );
1199 for my $up ( 0 .. 2 ) {
1200 my $p = get_relocatable_dir($path);
1206 $path = File::Spec->catfile( File::Spec->updir(), $path );
1210 die "can't find the dir where gnupg keys are stored"
1213 return RT::Crypt::GnuPG::ImportKey(
1214 RT::Test->file_content( [ $abs_path, $key ] ) );
1218 sub lsign_gnupg_key {
1222 require RT::Crypt::GnuPG; require GnuPG::Interface;
1223 my $gnupg = GnuPG::Interface->new();
1224 my %opt = RT->Config->Get('GnuPGOptions');
1225 $gnupg->options->hash_init(
1226 RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
1227 meta_interactive => 0,
1231 my $handles = GnuPG::Handles->new(
1232 stdin => ($handle{'input'} = IO::Handle->new()),
1233 stdout => ($handle{'output'} = IO::Handle->new()),
1234 stderr => ($handle{'error'} = IO::Handle->new()),
1235 logger => ($handle{'logger'} = IO::Handle->new()),
1236 status => ($handle{'status'} = IO::Handle->new()),
1237 command => ($handle{'command'} = IO::Handle->new()),
1241 local $SIG{'CHLD'} = 'DEFAULT';
1242 local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
1243 my $pid = $gnupg->wrap_call(
1244 handles => $handles,
1245 commands => ['--lsign-key'],
1246 command_args => [$key],
1248 close $handle{'input'};
1249 while ( my $str = readline $handle{'status'} ) {
1250 if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL sign_uid\..*/ ) {
1251 print { $handle{'command'} } "y\n";
1257 close $handle{'output'};
1260 $res{'exit_code'} = $?;
1261 foreach ( qw(error logger status) ) {
1262 $res{$_} = do { local $/; readline $handle{$_} };
1263 delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1266 $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1267 $RT::Logger->warning( $res{'error'} ) if $res{'error'};
1268 $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1269 if ( $err || $res{'exit_code'} ) {
1270 $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
1275 sub trust_gnupg_key {
1279 require RT::Crypt::GnuPG; require GnuPG::Interface;
1280 my $gnupg = GnuPG::Interface->new();
1281 my %opt = RT->Config->Get('GnuPGOptions');
1282 $gnupg->options->hash_init(
1283 RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
1284 meta_interactive => 0,
1288 my $handles = GnuPG::Handles->new(
1289 stdin => ($handle{'input'} = IO::Handle->new()),
1290 stdout => ($handle{'output'} = IO::Handle->new()),
1291 stderr => ($handle{'error'} = IO::Handle->new()),
1292 logger => ($handle{'logger'} = IO::Handle->new()),
1293 status => ($handle{'status'} = IO::Handle->new()),
1294 command => ($handle{'command'} = IO::Handle->new()),
1298 local $SIG{'CHLD'} = 'DEFAULT';
1299 local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
1300 my $pid = $gnupg->wrap_call(
1301 handles => $handles,
1302 commands => ['--edit-key'],
1303 command_args => [$key],
1305 close $handle{'input'};
1308 while ( my $str = readline $handle{'status'} ) {
1309 if ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE keyedit.prompt/ ) {
1311 print { $handle{'command'} } "quit\n";
1313 print { $handle{'command'} } "trust\n";
1315 } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE edit_ownertrust.value/ ) {
1316 print { $handle{'command'} } "5\n";
1317 } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_BOOL edit_ownertrust.set_ultimate.okay/ ) {
1318 print { $handle{'command'} } "y\n";
1325 close $handle{'output'};
1328 $res{'exit_code'} = $?;
1329 foreach ( qw(error logger status) ) {
1330 $res{$_} = do { local $/; readline $handle{$_} };
1331 delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1334 $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1335 $RT::Logger->warning( $res{'error'} ) if $res{'error'};
1336 $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1337 if ( $err || $res{'exit_code'} ) {
1338 $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
1346 require RT::Test::Web;
1348 if ($rttest_opt{nodb} and not $rttest_opt{server_ok}) {
1349 die "You are trying to use a test web server without a database. "
1350 ."You may want noinitialdata => 1 instead. "
1351 ."Pass server_ok => 1 if you know what you're doing.";
1355 $ENV{'RT_TEST_WEB_HANDLER'} = undef
1356 if $rttest_opt{actual_server} && ($ENV{'RT_TEST_WEB_HANDLER'}||'') eq 'inline';
1357 $ENV{'RT_TEST_WEB_HANDLER'} ||= 'plack';
1358 my $which = $ENV{'RT_TEST_WEB_HANDLER'};
1359 my ($server, $variant) = split /\+/, $which, 2;
1361 my $function = 'start_'. $server .'_server';
1362 unless ( $self->can($function) ) {
1363 die "Don't know how to start server '$server'";
1365 return $self->$function( variant => $variant, @_ );
1370 my %server_opt = @_;
1375 open( my $warn_fh, ">", \$warnings );
1376 local *STDERR = $warn_fh;
1378 if ($server_opt{variant} and $server_opt{variant} eq 'rt-server') {
1380 my $file = "$RT::SbinPath/rt-server";
1381 my $psgi = do $file;
1383 die "Couldn't parse $file: $@" if $@;
1384 die "Couldn't do $file: $!" unless defined $psgi;
1385 die "Couldn't run $file" unless $psgi;
1390 require RT::Interface::Web::Handler;
1391 $app = RT::Interface::Web::Handler->PSGIApp;
1394 require Plack::Middleware::Test::StashWarnings;
1395 my $stashwarnings = Plack::Middleware::Test::StashWarnings->new;
1396 $app = $stashwarnings->wrap($app);
1398 if ($server_opt{basic_auth}) {
1399 require Plack::Middleware::Auth::Basic;
1400 $app = Plack::Middleware::Auth::Basic->wrap(
1402 authenticator => sub {
1403 my ($username, $password) = @_;
1404 return $username eq 'root' && $password eq 'password';
1410 $stashwarnings->add_warning( $warnings ) if $warnings;
1415 sub start_plack_server {
1418 require Plack::Loader;
1419 my $plack_server = Plack::Loader->load
1422 server_ready => sub {
1423 kill 'USR1' => getppid();
1426 # We are expecting a USR1 from the child process after it's ready
1427 # to listen. We set this up _before_ we fork to avoid race
1430 local $SIG{USR1} = sub { $handled = 1};
1434 die "failed to fork" unless defined $pid;
1437 sleep 15 unless $handled;
1438 Test::More::diag "did not get expected USR1 for test server readiness"
1440 push @SERVERS, $pid;
1441 my $Tester = Test::Builder->new;
1442 $Tester->ok(1, "started plack server ok");
1445 unless $rttest_opt{nodb};
1446 return ("http://localhost:$port", RT::Test::Web->new);
1450 if ( $^O !~ /MSWin32/ ) {
1452 or die "Can't start a new session: $!";
1455 # stick this in a scope so that when $app is garbage collected,
1456 # StashWarnings can complain about unhandled warnings
1458 $plack_server->run($self->test_app(@_));
1465 sub start_inline_server {
1468 require Test::WWW::Mechanize::PSGI;
1469 unshift @RT::Test::Web::ISA, 'Test::WWW::Mechanize::PSGI';
1471 # Clear out squished CSS and JS cache, since it's retained across
1472 # servers, since it's in-process
1473 RT::Interface::Web->ClearSquished;
1474 require RT::Interface::Web::Request;
1475 RT::Interface::Web::Request->clear_callback_cache;
1477 Test::More::ok(1, "psgi test server ok");
1478 $TEST_APP = $self->test_app(@_);
1479 return ("http://localhost:$port", RT::Test::Web->new);
1482 sub start_apache_server {
1484 my %server_opt = @_;
1485 $server_opt{variant} ||= 'mod_perl';
1486 $ENV{RT_TEST_WEB_HANDLER} = "apache+$server_opt{variant}";
1488 require RT::Test::Apache;
1489 my $pid = RT::Test::Apache->start_server(
1494 push @SERVERS, $pid;
1496 my $url = RT->Config->Get('WebURL');
1498 return ($url, RT::Test::Web->new);
1504 return unless @SERVERS;
1506 kill 'TERM', @SERVERS;
1507 foreach my $pid (@SERVERS) {
1508 if ($ENV{RT_TEST_WEB_HANDLER} =~ /^apache/) {
1509 sleep 1 while kill 0, $pid;
1518 sub temp_directory {
1519 return $tmp{'directory'};
1527 $path = File::Spec->catfile( @$path ) if ref $path eq 'ARRAY';
1529 Test::More::diag "reading content of '$path'" if $ENV{'TEST_VERBOSE'};
1531 open( my $fh, "<:raw", $path )
1533 warn "couldn't open file '$path': $!" unless $args{noexist};
1536 my $content = do { local $/; <$fh> };
1539 unlink $path if $args{'unlink'};
1544 sub find_executable {
1549 foreach my $dir ( split /:/, $ENV{'PATH'} ) {
1550 my $fpath = File::Spec->catpath(
1551 (File::Spec->splitpath( $dir, 'no file' ))[0..1], $name
1553 next unless -e $fpath && -r _ && -x _;
1560 return unless $ENV{RT_TEST_VERBOSE} || $ENV{TEST_VERBOSE};
1561 goto \&Test::More::diag;
1566 require RT::EmailParser;
1567 my $parser = RT::EmailParser->new;
1568 $parser->ParseMIMEEntityFromScalar( $mail );
1569 return $parser->Entity;
1573 Test::More::ok($_[0], $_[1] || 'This works');
1577 Test::More::ok(!$_[0], $_[1] || 'This should fail');
1581 my ($cmd, @args) = @_;
1582 my $builder = RT::Test->builder;
1584 if ($cmd eq "skip_all") {
1585 $check_warnings_in_end = 0;
1586 } elsif ($cmd eq "tests") {
1587 # Increment the test count for the warnings check
1590 $builder->plan($cmd, @args);
1594 my $builder = RT::Test->builder;
1596 Test::NoWarnings::had_no_warnings();
1597 $check_warnings_in_end = 0;
1599 $builder->done_testing(@_);
1603 my $Test = RT::Test->builder;
1604 return if $Test->{Original_Pid} != $$;
1606 # we are in END block and should protect our exit code
1607 # so calls below may call system or kill that clobbers $?
1610 Test::NoWarnings::had_no_warnings() if $check_warnings_in_end;
1612 RT::Test->stop_server(1);
1615 if ( !$Test->is_passing ) {
1616 $tmp{'directory'}->unlink_on_destroy(0);
1619 "Some tests failed or we bailed out, tmp directory"
1620 ." '$tmp{directory}' is not cleaned"
1624 if ( $ENV{RT_TEST_PARALLEL} && $created_new_db ) {
1628 # Drop our port from t/tmp/ports; do this after dropping the
1629 # database, as our port lock is also a lock on the database name.
1632 my $portfile = "$tmp{'directory'}/../ports";
1633 sysopen(PORTS, $portfile, O_RDWR|O_CREAT)
1634 or die "Can't write to ports file $portfile: $!";
1635 flock(PORTS, LOCK_EX)
1636 or die "Can't write-lock ports file $portfile: $!";
1637 $ports{$_}++ for split ' ', join("",<PORTS>);
1638 delete $ports{$port};
1641 print PORTS "$_\n" for sort {$a <=> $b} keys %ports;
1642 close(PORTS) or die "Can't close ports file: $!";
1647 # ease the used only once warning
1650 %{'RT::I18N::en_us::Lexicon'};
1651 %{'Win32::Locale::Lexicon'};