1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2013 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 }}}
55 use base 'Test::More';
57 # We use the Test::NoWarnings catching and reporting functionality, but need to
58 # wrap it in our own special handler because of the warn handler installed via
60 require Test::NoWarnings;
62 my $Test_NoWarnings_Catcher = $SIG{__WARN__};
63 my $check_warnings_in_end = 1;
66 use File::Temp qw(tempfile);
67 use File::Path qw(mkpath);
70 our @EXPORT = qw(is_empty diag parse_mail works fails plan done_testing);
91 To run the rt test suite with coverage support, install L<Devel::Cover> and run:
93 make test RT_DBA_USER=.. RT_DBA_PASSWORD=.. HARNESS_PERL_SWITCHES=-MDevel::Cover
94 cover -ignore_re '^var/mason_data/' -ignore_re '^t/'
96 The coverage tests have DevelMode turned off, and have
97 C<named_component_subs> enabled for L<HTML::Mason> to avoid an optimizer
98 problem in Perl that hides the top-level optree from L<Devel::Cover>.
106 delete $ENV{$_} for qw/LANGUAGE LC_ALL LC_MESSAGES LANG/;
112 my %args = %rttest_opt = @_;
114 $rttest_opt{'nodb'} = $args{'nodb'} = 1 if $^C;
116 # Spit out a plan (if we got one) *before* we load modules
117 if ( $args{'tests'} ) {
118 plan( tests => $args{'tests'} )
119 unless $args{'tests'} eq 'no_declare';
121 elsif ( exists $args{'tests'} ) {
122 # do nothing if they say "tests => undef" - let them make the plan
124 elsif ( $args{'skip_all'} ) {
125 plan(skip_all => $args{'skip_all'});
128 $class->builder->no_plan unless $class->builder->has_plan;
131 push @{ $args{'plugins'} ||= [] }, @{ $args{'requires'} }
132 if $args{'requires'};
133 push @{ $args{'plugins'} ||= [] }, $args{'testing'}
136 $class->bootstrap_tempdir;
138 $class->bootstrap_port;
140 $class->bootstrap_plugins_paths( %args );
142 $class->bootstrap_config( %args );
147 if (RT->Config->Get('DevelMode')) { require Module::Refresh; }
149 RT::InitPluginPaths();
152 $class->bootstrap_db( %args );
162 RT->Config->PostLoadCheck;
164 $class->set_config_wrapper;
166 my $screen_logger = $RT::Logger->remove( 'screen' );
167 require Log::Dispatch::Perl;
168 $RT::Logger->add( Log::Dispatch::Perl->new
170 min_level => $screen_logger->min_level,
171 action => { error => 'warn',
172 critical => 'warn' } ) );
174 # XXX: this should really be totally isolated environment so we
175 # can parallelize and be sane
176 mkpath [ $RT::MasonSessionDir ]
177 if RT->Config->Get('DatabaseType');
180 while ( my ($package) = caller($level-1) ) {
181 last unless $package =~ /Test/;
185 Test::More->export_to_level($level);
186 Test::NoWarnings->export_to_level($level);
188 # Blow away symbols we redefine to avoid warnings.
189 # better than "no warnings 'redefine'" because we might accidentally
190 # suppress a mistaken redefinition
192 delete ${ caller($level) . '::' }{diag};
193 delete ${ caller($level) . '::' }{plan};
194 delete ${ caller($level) . '::' }{done_testing};
195 __PACKAGE__->export_to_level($level);
200 local $Test::Builder::Level = $Test::Builder::Level + 1;
201 return Test::More::ok(1, $d) unless defined $v;
202 return Test::More::ok(1, $d) unless length $v;
203 return Test::More::is($v, '', $d);
206 my $created_new_db; # have we created new db? mainly for parallel testing
208 sub db_requires_no_dba {
210 my $db_type = RT->Config->Get('DatabaseType');
211 return 1 if $db_type eq 'SQLite';
219 # Determine which ports are in use
220 use Fcntl qw(:DEFAULT :flock);
221 my $portfile = "$tmp{'directory'}/../ports";
222 sysopen(PORTS, $portfile, O_RDWR|O_CREAT)
223 or die "Can't write to ports file $portfile: $!";
224 flock(PORTS, LOCK_EX)
225 or die "Can't write-lock ports file $portfile: $!";
226 $ports{$_}++ for split ' ', join("",<PORTS>);
228 # Pick a random port, checking that the port isn't in our in-use
229 # list, and that something isn't already listening there.
231 $port = 1024 + int rand(10_000) + $$ % 1024;
232 redo if $ports{$port};
234 # There is a race condition in here, where some non-RT::Test
235 # process claims the port after we check here but before our
236 # server binds. However, since we mostly care about race
237 # conditions with ourselves under high concurrency, this is
238 # generally good enough.
239 my $paddr = sockaddr_in( $port, inet_aton('localhost') );
240 socket( SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
242 if ( connect( SOCK, $paddr ) ) {
251 # Write back out the in-use ports
254 print PORTS "$_\n" for sort {$a <=> $b} keys %ports;
255 close(PORTS) or die "Can't close ports file: $!";
258 sub bootstrap_tempdir {
260 my ($test_dir, $test_file) = ('t', '');
262 if (File::Spec->rel2abs($0) =~ m{(?:^|[\\/])(x?t)[/\\](.*)}) {
265 $test_file =~ s{[/\\]}{-}g;
268 my $dir_name = File::Spec->rel2abs("$test_dir/tmp");
270 return $tmp{'directory'} = File::Temp->newdir(
271 "${test_file}XXXXXXXX",
276 sub bootstrap_config {
280 $tmp{'config'}{'RT'} = File::Spec->catfile(
281 "$tmp{'directory'}", 'RT_SiteConfig.pm'
283 open( my $config, '>', $tmp{'config'}{'RT'} )
284 or die "Couldn't open $tmp{'config'}{'RT'}: $!";
286 my $dbname = $ENV{RT_TEST_PARALLEL}? "rt4test_$port" : "rt4test";
288 Set( \$WebDomain, "localhost");
289 Set( \$WebPort, $port);
291 Set( \@LexiconLanguages, qw(en zh_TW fr ja));
292 Set( \$RTAddressRegexp , qr/^bad_re_that_doesnt_match\$/i);
294 if ( $ENV{'RT_TEST_DB_SID'} ) { # oracle case
295 print $config "Set( \$DatabaseName , '$ENV{'RT_TEST_DB_SID'}' );\n";
296 print $config "Set( \$DatabaseUser , '$dbname');\n";
298 print $config "Set( \$DatabaseName , '$dbname');\n";
299 print $config "Set( \$DatabaseUser , 'u${dbname}');\n";
301 if ( $ENV{'RT_TEST_DB_HOST'} ) {
302 print $config "Set( \$DatabaseHost , '$ENV{'RT_TEST_DB_HOST'}');\n";
305 if ( $args{'plugins'} ) {
306 print $config "Set( \@Plugins, qw(". join( ' ', @{ $args{'plugins'} } ) .") );\n";
308 my $plugin_data = File::Spec->rel2abs("t/data/plugins");
309 print $config qq[\$RT::PluginPath = "$plugin_data";\n];
312 if ( $INC{'Devel/Cover.pm'} ) {
313 print $config "Set( \$DevelMode, 0 );\n";
315 elsif ( $ENV{RT_TEST_DEVEL} ) {
316 print $config "Set( \$DevelMode, 1 );\n";
319 print $config "Set( \$DevelMode, 0 );\n";
322 $self->bootstrap_logging( $config );
325 my $mail_catcher = $tmp{'mailbox'} = File::Spec->catfile(
326 $tmp{'directory'}->dirname, 'mailbox.eml'
329 Set( \$MailCommand, sub {
332 open( my \$handle, '>>', '$mail_catcher' )
333 or die "Unable to open '$mail_catcher' for appending: \$!";
335 \$MIME->print(\$handle);
336 print \$handle "%% split me! %%\n";
341 $self->bootstrap_more_config($config, \%args);
343 print $config $args{'config'} if $args{'config'};
345 print $config "\n1;\n";
346 $ENV{'RT_SITE_CONFIG'} = $tmp{'config'}{'RT'};
352 sub bootstrap_more_config { }
354 sub bootstrap_logging {
358 # prepare file for logging
359 $tmp{'log'}{'RT'} = File::Spec->catfile(
360 "$tmp{'directory'}", 'rt.debug.log'
362 open( my $fh, '>', $tmp{'log'}{'RT'} )
363 or die "Couldn't open $tmp{'config'}{'RT'}: $!";
364 # make world writable so apache under different user
366 chmod 0666, $tmp{'log'}{'RT'};
369 Set( \$LogToSyslog , undef);
370 Set( \$LogToScreen , "warning");
371 Set( \$LogToFile, 'debug' );
372 Set( \$LogDir, q{$tmp{'directory'}} );
373 Set( \$LogToFileNamed, 'rt.debug.log' );
377 sub set_config_wrapper {
380 my $old_sub = \&RT::Config::Set;
381 no warnings 'redefine';
382 *RT::Config::Set = sub {
383 # Determine if the caller is either from a test script, or
384 # from helper functions called by test script to alter
385 # configuration that should be written. This is necessary
386 # because some extensions (RTIR, for example) temporarily swap
387 # configuration values out and back in Mason during requests.
388 my @caller = caller(1); # preserve list context
389 @caller = caller(0) unless @caller;
391 if ( ($caller[1]||'') =~ /\.t$/) {
392 my ($self, $name) = @_;
393 my $type = $RT::Config::META{$name}->{'Type'} || 'SCALAR';
399 my $sigil = $sigils{$type} || $sigils{'SCALAR'};
400 open( my $fh, '>>', $tmp{'config'}{'RT'} )
401 or die "Couldn't open config file: $!";
402 require Data::Dumper;
403 local $Data::Dumper::Terse = 1;
404 my $dump = Data::Dumper::Dumper([@_[2 .. $#_]]);
407 "\nSet(${sigil}${name}, \@{". $dump ."});\n1;\n";
411 warn "you're changing config option in a test file"
412 ." when server is active";
415 return $old_sub->(@_);
423 unless (defined $ENV{'RT_DBA_USER'} && defined $ENV{'RT_DBA_PASSWORD'}) {
424 Test::More::BAIL_OUT(
425 "RT_DBA_USER and RT_DBA_PASSWORD environment variables need"
426 ." to be set in order to run 'make test'"
427 ) unless $self->db_requires_no_dba;
431 if (my $forceopt = $ENV{RT_TEST_FORCE_OPT}) {
432 Test::More::diag "forcing $forceopt";
436 # Short-circuit the rest of ourselves if we don't want a db
442 my $db_type = RT->Config->Get('DatabaseType');
444 __reconnect_rt('as dba');
445 $RT::Handle->InsertSchema;
446 $RT::Handle->InsertACL unless $db_type eq 'Oracle';
451 $RT::Handle->InsertInitialData
452 unless $args{noinitialdata};
454 $RT::Handle->InsertData( $RT::EtcPath . "/initialdata" )
455 unless $args{noinitialdata} or $args{nodata};
457 $self->bootstrap_plugins_db( %args );
460 sub bootstrap_plugins_paths {
464 return unless $args{'plugins'};
465 my @plugins = @{ $args{'plugins'} };
468 if ( $args{'testing'} ) {
470 $cwd = Cwd::getcwd();
474 my $old_func = \&RT::Plugin::_BasePath;
475 no warnings 'redefine';
476 *RT::Plugin::_BasePath = sub {
477 my $name = $_[0]->{'name'};
479 return $cwd if $args{'testing'} && $name eq $args{'testing'};
481 if ( grep $name eq $_, @plugins ) {
482 my $variants = join "(?:|::|-|_)", map "\Q$_\E", split /::/, $name;
483 my ($path) = map $ENV{$_}, grep /^CHIMPS_(?:$variants).*_ROOT$/i, keys %ENV;
484 return $path if $path;
486 return $old_func->(@_);
490 sub bootstrap_plugins_db {
494 return unless $args{'plugins'};
498 my @plugins = @{ $args{'plugins'} };
499 foreach my $name ( @plugins ) {
500 my $plugin = RT::Plugin->new( name => $name );
501 Test::More::diag( "Initializing DB for the $name plugin" )
502 if $ENV{'TEST_VERBOSE'};
504 my $etc_path = $plugin->Path('etc');
505 Test::More::diag( "etc path of the plugin is '$etc_path'" )
506 if $ENV{'TEST_VERBOSE'};
508 unless ( -e $etc_path ) {
509 # We can't tell if the plugin has no data, or we screwed up the etc/ path
510 Test::More::ok(1, "There is no etc dir: no schema" );
511 Test::More::ok(1, "There is no etc dir: no ACLs" );
512 Test::More::ok(1, "There is no etc dir: no data" );
516 __reconnect_rt('as dba');
519 my ($ret, $msg) = $RT::Handle->InsertSchema( undef, $etc_path );
520 Test::More::ok($ret || $msg =~ /^Couldn't find schema/, "Created schema: ".($msg||''));
524 my ($ret, $msg) = $RT::Handle->InsertACL( undef, $etc_path );
525 Test::More::ok($ret || $msg =~ /^Couldn't find ACLs/, "Created ACL: ".($msg||''));
529 my $data_file = File::Spec->catfile( $etc_path, 'initialdata' );
530 if ( -e $data_file ) {
532 my ($ret, $msg) = $RT::Handle->InsertData( $data_file );;
533 Test::More::ok($ret, "Inserted data".($msg||''));
535 Test::More::ok(1, "There is no data file" );
542 my ($dsn, $user, $pass) = @_;
543 if ( $dsn =~ /Oracle/i ) {
544 $ENV{'NLS_LANG'} = "AMERICAN_AMERICA.AL32UTF8";
545 $ENV{'NLS_NCHAR'} = "AL32UTF8";
547 my $dbh = DBI->connect(
549 { RaiseError => 0, PrintError => 1 },
552 my $msg = "Failed to connect to $dsn as user '$user': ". $DBI::errstr;
553 print STDERR $msg; exit -1;
558 sub __create_database {
559 # bootstrap with dba cred
561 RT::Handle->SystemDSN,
562 $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD}
565 unless ( $ENV{RT_TEST_PARALLEL} ) {
566 # already dropped db in parallel tests, need to do so for other cases.
567 __drop_database( $dbh );
570 RT::Handle->CreateDatabase( $dbh );
575 sub __drop_database {
578 # Pg doesn't like if you issue a DROP DATABASE while still connected
579 # it's still may fail if web-server is out there and holding a connection
582 my $my_dbh = $dbh? 0 : 1;
584 RT::Handle->SystemDSN,
585 $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD}
588 # We ignore errors intentionally by not checking the return value of
589 # DropDatabase below, so let's also suppress DBI's printing of errors when
590 # we overzealously drop.
591 local $dbh->{PrintError} = 0;
592 local $dbh->{PrintWarn} = 0;
594 RT::Handle->DropDatabase( $dbh );
595 $dbh->disconnect if $my_dbh;
602 # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation
603 $RT::Handle = RT::Handle->new;
604 $RT::Handle->dbh( undef );
605 $RT::Handle->Connect(
607 ? (User => $ENV{RT_DBA_USER}, Password => $ENV{RT_DBA_PASSWORD})
610 $RT::Handle->PrintError;
611 $RT::Handle->dbh->{PrintError} = 1;
612 return $RT::Handle->dbh;
615 sub __disconnect_rt {
616 # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation
617 $RT::Handle->dbh->disconnect if $RT::Handle and $RT::Handle->dbh;
619 %DBIx::SearchBuilder::Handle::DBIHandle = ();
620 $DBIx::SearchBuilder::Handle::PrevHandle = undef;
624 delete $RT::System->{attributes};
626 DBIx::SearchBuilder::Record::Cachable->FlushCache
627 if DBIx::SearchBuilder::Record::Cachable->can("FlushCache");
633 # We use local to ensure that the $filter we grab is from InitLogging
634 # and not the handler generated by a previous call to this function
636 local $SIG{__WARN__};
638 $filter = $SIG{__WARN__};
640 $SIG{__WARN__} = sub {
642 my $status = $filter->(@_);
643 if ($status and $status eq 'IGNORE') {
644 return; # pretend the bad dream never happened
647 # Avoid reporting this anonymous call frame as the source of the warning.
648 goto &$Test_NoWarnings_Catcher;
655 =head2 load_or_create_user
659 sub load_or_create_user {
661 my %args = ( Privileged => 1, Disabled => 0, @_ );
663 my $MemberOf = delete $args{'MemberOf'};
664 $MemberOf = [ $MemberOf ] if defined $MemberOf && !ref $MemberOf;
667 my $obj = RT::User->new( RT->SystemUser );
668 if ( $args{'Name'} ) {
669 $obj->LoadByCols( Name => $args{'Name'} );
670 } elsif ( $args{'EmailAddress'} ) {
671 $obj->LoadByCols( EmailAddress => $args{'EmailAddress'} );
673 die "Name or EmailAddress is required";
677 $obj->SetPrivileged( $args{'Privileged'} || 0 )
678 if ($args{'Privileged'}||0) != ($obj->Privileged||0);
679 $obj->SetDisabled( $args{'Disabled'} || 0 )
680 if ($args{'Disabled'}||0) != ($obj->Disabled||0);
682 my ($val, $msg) = $obj->Create( %args );
683 die "$msg" unless $val;
686 # clean group membership
688 require RT::GroupMembers;
689 my $gms = RT::GroupMembers->new( RT->SystemUser );
690 my $groups_alias = $gms->Join(
691 FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id',
693 $gms->Limit( ALIAS => $groups_alias, FIELD => 'Domain', VALUE => 'UserDefined' );
694 $gms->Limit( FIELD => 'MemberId', VALUE => $obj->id );
695 while ( my $group_member_record = $gms->Next ) {
696 $group_member_record->Delete;
700 # add new user to groups
701 foreach ( @$MemberOf ) {
702 my $group = RT::Group->new( RT::SystemUser() );
703 $group->LoadUserDefinedGroup( $_ );
704 die "couldn't load group '$_'" unless $group->id;
705 $group->AddMember( $obj->id );
711 =head2 load_or_create_queue
715 sub load_or_create_queue {
717 my %args = ( Disabled => 0, @_ );
718 my $obj = RT::Queue->new( RT->SystemUser );
719 if ( $args{'Name'} ) {
720 $obj->LoadByCols( Name => $args{'Name'} );
722 die "Name is required";
724 unless ( $obj->id ) {
725 my ($val, $msg) = $obj->Create( %args );
726 die "$msg" unless $val;
728 my @fields = qw(CorrespondAddress CommentAddress);
729 foreach my $field ( @fields ) {
730 next unless exists $args{ $field };
731 next if $args{ $field } eq ($obj->$field || '');
733 no warnings 'uninitialized';
734 my $method = 'Set'. $field;
735 my ($val, $msg) = $obj->$method( $args{ $field } );
736 die "$msg" unless $val;
743 sub delete_queue_watchers {
747 foreach my $q ( @queues ) {
748 foreach my $t (qw(Cc AdminCc) ) {
749 $q->DeleteWatcher( Type => $t, PrincipalId => $_->MemberId )
750 foreach @{ $q->$t()->MembersObj->ItemsArrayRef };
756 local $Test::Builder::Level = $Test::Builder::Level + 1;
759 my $defaults = shift;
761 @data = sort { rand(100) <=> rand(100) } @data
762 if delete $defaults->{'RandomOrder'};
764 $defaults->{'Queue'} ||= 'General';
768 my %args = %{ shift @data };
769 $args{$_} = $res[ $args{$_} ]->id foreach
770 grep $args{ $_ }, keys %RT::Ticket::LINKTYPEMAP;
771 push @res, $self->create_ticket( %$defaults, %args );
777 local $Test::Builder::Level = $Test::Builder::Level + 1;
782 if ($args{Queue} && $args{Queue} =~ /\D/) {
783 my $queue = RT::Queue->new(RT->SystemUser);
784 if (my $id = $queue->Load($args{Queue}) ) {
787 die ("Error: Invalid queue $args{Queue}");
791 if ( my $content = delete $args{'Content'} ) {
792 $args{'MIMEObj'} = MIME::Entity->build(
793 From => $args{'Requestor'},
794 Subject => $args{'Subject'},
799 my $ticket = RT::Ticket->new( RT->SystemUser );
800 my ( $id, undef, $msg ) = $ticket->Create( %args );
801 Test::More::ok( $id, "ticket created" )
802 or Test::More::diag("error: $msg");
804 # hackish, but simpler
805 if ( $args{'LastUpdatedBy'} ) {
806 $ticket->__Set( Field => 'LastUpdatedBy', Value => $args{'LastUpdatedBy'} );
810 for my $field ( keys %args ) {
811 #TODO check links and watchers
813 if ( $field =~ /CustomField-(\d+)/ ) {
815 my $got = join ',', sort map $_->Content,
816 @{ $ticket->CustomFieldValues($cf)->ItemsArrayRef };
817 my $expected = ref $args{$field}
818 ? join( ',', sort @{ $args{$field} } )
820 Test::More::is( $got, $expected, 'correct CF values' );
823 next if ref $args{$field};
824 next unless $ticket->can($field) or $ticket->_Accessible($field,"read");
825 next if ref $ticket->$field();
826 Test::More::is( $ticket->$field(), $args{$field}, "$field is correct" );
836 my $tickets = RT::Tickets->new( RT->SystemUser );
838 $tickets->FromSQL( $query );
843 while ( my $ticket = $tickets->Next ) {
848 =head2 load_or_create_custom_field
852 sub load_or_create_custom_field {
854 my %args = ( Disabled => 0, @_ );
855 my $obj = RT::CustomField->new( RT->SystemUser );
856 if ( $args{'Name'} ) {
857 $obj->LoadByName( Name => $args{'Name'}, Queue => $args{'Queue'} );
859 die "Name is required";
861 unless ( $obj->id ) {
862 my ($val, $msg) = $obj->Create( %args );
863 die "$msg" unless $val;
872 $current = $current ? RT::CurrentUser->new($current) : RT->SystemUser;
873 my $tickets = RT::Tickets->new( $current );
874 $tickets->OrderBy( FIELD => 'id', ORDER => 'DESC' );
875 $tickets->Limit( FIELD => 'id', OPERATOR => '>', VALUE => '0' );
876 $tickets->RowsPerPage( 1 );
877 return $tickets->First;
885 RT::ACE->new( RT->SystemUser );
886 my @fields = keys %{ RT::ACE->_ClassAccessible };
889 my $acl = RT::ACL->new( RT->SystemUser );
890 $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
893 while ( my $ace = $acl->Next ) {
894 my $obj = $ace->PrincipalObj->Object;
895 if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == RT->Nobody->id ) {
900 foreach my $field( @fields ) {
901 $tmp{ $field } = $ace->__Value( $field );
911 foreach my $entry ( @entries ) {
912 my $ace = RT::ACE->new( RT->SystemUser );
913 my ($status, $msg) = $ace->RT::Record::Create( %$entry );
915 Test::More::diag "couldn't create a record: $msg";
924 my $acl = RT::ACL->new( RT->SystemUser );
925 $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
926 while ( my $ace = $acl->Next ) {
927 my $obj = $ace->PrincipalObj->Object;
928 if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == RT->Nobody->id ) {
933 return $self->add_rights( @_ );
938 my @list = ref $_[0]? @_: @_? { @_ }: ();
941 foreach my $e (@list) {
942 my $principal = delete $e->{'Principal'};
943 unless ( ref $principal ) {
944 if ( $principal =~ /^(everyone|(?:un)?privileged)$/i ) {
945 $principal = RT::Group->new( RT->SystemUser );
946 $principal->LoadSystemInternalGroup($1);
947 } elsif ( $principal =~ /^(Owner|Requestor|(?:Admin)?Cc)$/i ) {
948 $principal = RT::Group->new( RT->SystemUser );
949 $principal->LoadByCols(
950 Domain => (ref($e->{'Object'})||'RT::System').'-Role',
952 ref($e->{'Object'})? (Instance => $e->{'Object'}->id): (),
955 die "principal is not an object, but also is not name of a system group";
958 unless ( $principal->isa('RT::Principal') ) {
959 if ( $principal->can('PrincipalObj') ) {
960 $principal = $principal->PrincipalObj;
963 my @rights = ref $e->{'Right'}? @{ $e->{'Right'} }: ($e->{'Right'});
964 foreach my $right ( @rights ) {
965 my ($status, $msg) = $principal->GrantRight( %$e, Right => $right );
966 $RT::Logger->debug($msg);
975 require RT::Test::Web;
977 url => RT::Test::Web->rt_base_url,
979 action => 'correspond',
982 command => $RT::BinPath .'/rt-mailgate',
985 my $message = delete $args{'message'};
987 $args{after_open} = sub {
988 my $child_in = shift;
989 if ( UNIVERSAL::isa($message, 'MIME::Entity') ) {
990 $message->print( $child_in );
992 print $child_in $message;
996 $self->run_and_capture(%args);
999 sub run_and_capture {
1003 my $after_open = delete $args{after_open};
1005 my $cmd = delete $args{'command'};
1006 die "Couldn't find command ($cmd)" unless -f $cmd;
1008 $cmd .= ' --debug' if delete $args{'debug'};
1010 while( my ($k,$v) = each %args ) {
1012 $cmd .= " --$k '$v'";
1016 DBIx::SearchBuilder::Record::Cachable->FlushCache;
1019 my ($child_out, $child_in);
1020 my $pid = IPC::Open2::open2($child_out, $child_in, $cmd);
1022 $after_open->($child_in, $child_out) if $after_open;
1026 my $result = do { local $/; <$child_out> };
1029 return ($?, $result);
1032 sub send_via_mailgate_and_http {
1034 my $message = shift;
1037 my ($status, $gate_result) = $self->run_mailgate(
1038 message => $message, %args
1042 unless ( $status >> 8 ) {
1043 ($id) = ($gate_result =~ /Ticket:\s*(\d+)/i);
1045 Test::More::diag "Couldn't find ticket id in text:\n$gate_result"
1046 if $ENV{'TEST_VERBOSE'};
1049 Test::More::diag "Mailgate output:\n$gate_result"
1050 if $ENV{'TEST_VERBOSE'};
1052 return ($status, $id);
1056 sub send_via_mailgate {
1058 my $message = shift;
1059 my %args = ( action => 'correspond',
1064 if ( UNIVERSAL::isa( $message, 'MIME::Entity' ) ) {
1065 $message = $message->as_string;
1068 my ( $status, $error_message, $ticket )
1069 = RT::Interface::Email::Gateway( {%args, message => $message} );
1070 return ( $status, $ticket ? $ticket->id : 0 );
1075 sub open_mailgate_ok {
1077 my $baseurl = shift;
1078 my $queue = shift || 'general';
1079 my $action = shift || 'correspond';
1080 Test::More::ok(open(my $mail, '|-', "$RT::BinPath/rt-mailgate --url $baseurl --queue $queue --action $action"), "Opened the mailgate - $!");
1085 sub close_mailgate_ok {
1089 Test::More::is ($? >> 8, 0, "The mail gateway exited normally. yay");
1094 my $expected = shift;
1096 my $mailsent = scalar grep /\S/, split /%% split me! %%\n/,
1097 RT::Test->file_content(
1104 $mailsent, $expected,
1105 "The number of mail sent ($expected) matches. yay"
1109 sub fetch_caught_mails {
1111 return grep /\S/, split /%% split me! %%\n/,
1112 RT::Test->file_content(
1119 sub clean_caught_mails {
1120 unlink $tmp{'mailbox'};
1123 =head2 get_relocatable_dir
1125 Takes a path relative to the location of the test file that is being
1126 run and returns a path that takes the invocation path into account.
1128 e.g. C<RT::Test::get_relocatable_dir(File::Spec->updir(), 'data', 'emails')>
1130 Parent directory traversals (C<..> or File::Spec->updir()) are naively
1131 canonicalized based on the test file path (C<$0>) so that symlinks aren't
1132 followed. This is the exact opposite behaviour of most filesystems and is
1133 considered "wrong", however it is necessary for some subsets of tests which are
1134 symlinked into the testing tree.
1138 sub get_relocatable_dir {
1139 my @directories = File::Spec->splitdir(
1140 File::Spec->rel2abs((File::Spec->splitpath($0))[1])
1142 push @directories, File::Spec->splitdir($_) for @_;
1145 for (@directories) {
1146 if ($_ eq "..") { pop @clean }
1147 elsif ($_ ne ".") { push @clean, $_ }
1149 return File::Spec->catdir(@clean);
1152 =head2 get_relocatable_file
1154 Same as get_relocatable_dir, but takes a file and a path instead
1157 e.g. RT::Test::get_relocatable_file('test-email',
1158 (File::Spec->updir(), 'data', 'emails'))
1162 sub get_relocatable_file {
1164 return File::Spec->catfile(get_relocatable_dir(@_), $file);
1167 sub get_abs_relocatable_dir {
1168 (my $volume, my $directories, my $file) = File::Spec->splitpath($0);
1169 if (File::Spec->file_name_is_absolute($directories)) {
1170 return File::Spec->catdir($directories, @_);
1172 return File::Spec->catdir(Cwd->getcwd(), $directories, @_);
1179 DIR => $tmp{directory},
1184 sub import_gnupg_key {
1187 my $type = shift || 'secret';
1189 $key =~ s/\@/-at-/g;
1190 $key .= ".$type.key";
1192 require RT::Crypt::GnuPG;
1194 # simple strategy find data/gnupg/keys, from the dir where test file lives
1195 # to updirs, try 3 times in total
1196 my $path = File::Spec->catfile( 'data', 'gnupg', 'keys' );
1198 for my $up ( 0 .. 2 ) {
1199 my $p = get_relocatable_dir($path);
1205 $path = File::Spec->catfile( File::Spec->updir(), $path );
1209 die "can't find the dir where gnupg keys are stored"
1212 return RT::Crypt::GnuPG::ImportKey(
1213 RT::Test->file_content( [ $abs_path, $key ] ) );
1217 sub lsign_gnupg_key {
1221 require RT::Crypt::GnuPG; require GnuPG::Interface;
1222 my $gnupg = GnuPG::Interface->new();
1223 my %opt = RT->Config->Get('GnuPGOptions');
1224 $gnupg->options->hash_init(
1225 RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
1226 meta_interactive => 0,
1230 my $handles = GnuPG::Handles->new(
1231 stdin => ($handle{'input'} = IO::Handle->new()),
1232 stdout => ($handle{'output'} = IO::Handle->new()),
1233 stderr => ($handle{'error'} = IO::Handle->new()),
1234 logger => ($handle{'logger'} = IO::Handle->new()),
1235 status => ($handle{'status'} = IO::Handle->new()),
1236 command => ($handle{'command'} = IO::Handle->new()),
1240 local $SIG{'CHLD'} = 'DEFAULT';
1241 local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
1242 my $pid = $gnupg->wrap_call(
1243 handles => $handles,
1244 commands => ['--lsign-key'],
1245 command_args => [$key],
1247 close $handle{'input'};
1248 while ( my $str = readline $handle{'status'} ) {
1249 if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL sign_uid\..*/ ) {
1250 print { $handle{'command'} } "y\n";
1256 close $handle{'output'};
1259 $res{'exit_code'} = $?;
1260 foreach ( qw(error logger status) ) {
1261 $res{$_} = do { local $/; readline $handle{$_} };
1262 delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1265 $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1266 $RT::Logger->warning( $res{'error'} ) if $res{'error'};
1267 $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1268 if ( $err || $res{'exit_code'} ) {
1269 $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
1274 sub trust_gnupg_key {
1278 require RT::Crypt::GnuPG; require GnuPG::Interface;
1279 my $gnupg = GnuPG::Interface->new();
1280 my %opt = RT->Config->Get('GnuPGOptions');
1281 $gnupg->options->hash_init(
1282 RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
1283 meta_interactive => 0,
1287 my $handles = GnuPG::Handles->new(
1288 stdin => ($handle{'input'} = IO::Handle->new()),
1289 stdout => ($handle{'output'} = IO::Handle->new()),
1290 stderr => ($handle{'error'} = IO::Handle->new()),
1291 logger => ($handle{'logger'} = IO::Handle->new()),
1292 status => ($handle{'status'} = IO::Handle->new()),
1293 command => ($handle{'command'} = IO::Handle->new()),
1297 local $SIG{'CHLD'} = 'DEFAULT';
1298 local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
1299 my $pid = $gnupg->wrap_call(
1300 handles => $handles,
1301 commands => ['--edit-key'],
1302 command_args => [$key],
1304 close $handle{'input'};
1307 while ( my $str = readline $handle{'status'} ) {
1308 if ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE keyedit.prompt/ ) {
1310 print { $handle{'command'} } "quit\n";
1312 print { $handle{'command'} } "trust\n";
1314 } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE edit_ownertrust.value/ ) {
1315 print { $handle{'command'} } "5\n";
1316 } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_BOOL edit_ownertrust.set_ultimate.okay/ ) {
1317 print { $handle{'command'} } "y\n";
1324 close $handle{'output'};
1327 $res{'exit_code'} = $?;
1328 foreach ( qw(error logger status) ) {
1329 $res{$_} = do { local $/; readline $handle{$_} };
1330 delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1333 $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1334 $RT::Logger->warning( $res{'error'} ) if $res{'error'};
1335 $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1336 if ( $err || $res{'exit_code'} ) {
1337 $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
1345 require RT::Test::Web;
1347 if ($rttest_opt{nodb} and not $rttest_opt{server_ok}) {
1348 die "You are trying to use a test web server without a database. "
1349 ."You may want noinitialdata => 1 instead. "
1350 ."Pass server_ok => 1 if you know what you're doing.";
1354 $ENV{'RT_TEST_WEB_HANDLER'} = undef
1355 if $rttest_opt{actual_server} && ($ENV{'RT_TEST_WEB_HANDLER'}||'') eq 'inline';
1356 $ENV{'RT_TEST_WEB_HANDLER'} ||= 'plack';
1357 my $which = $ENV{'RT_TEST_WEB_HANDLER'};
1358 my ($server, $variant) = split /\+/, $which, 2;
1360 my $function = 'start_'. $server .'_server';
1361 unless ( $self->can($function) ) {
1362 die "Don't know how to start server '$server'";
1364 return $self->$function( variant => $variant, @_ );
1369 my %server_opt = @_;
1374 open( my $warn_fh, ">", \$warnings );
1375 local *STDERR = $warn_fh;
1377 if ($server_opt{variant} and $server_opt{variant} eq 'rt-server') {
1379 my $file = "$RT::SbinPath/rt-server";
1380 my $psgi = do $file;
1382 die "Couldn't parse $file: $@" if $@;
1383 die "Couldn't do $file: $!" unless defined $psgi;
1384 die "Couldn't run $file" unless $psgi;
1389 require RT::Interface::Web::Handler;
1390 $app = RT::Interface::Web::Handler->PSGIApp;
1393 require Plack::Middleware::Test::StashWarnings;
1394 my $stashwarnings = Plack::Middleware::Test::StashWarnings->new;
1395 $app = $stashwarnings->wrap($app);
1397 if ($server_opt{basic_auth}) {
1398 require Plack::Middleware::Auth::Basic;
1399 $app = Plack::Middleware::Auth::Basic->wrap(
1401 authenticator => sub {
1402 my ($username, $password) = @_;
1403 return $username eq 'root' && $password eq 'password';
1409 $stashwarnings->add_warning( $warnings ) if $warnings;
1414 sub start_plack_server {
1417 require Plack::Loader;
1418 my $plack_server = Plack::Loader->load
1421 server_ready => sub {
1422 kill 'USR1' => getppid();
1425 # We are expecting a USR1 from the child process after it's ready
1426 # to listen. We set this up _before_ we fork to avoid race
1429 local $SIG{USR1} = sub { $handled = 1};
1433 die "failed to fork" unless defined $pid;
1436 sleep 15 unless $handled;
1437 Test::More::diag "did not get expected USR1 for test server readiness"
1439 push @SERVERS, $pid;
1440 my $Tester = Test::Builder->new;
1441 $Tester->ok(1, "started plack server ok");
1444 unless $rttest_opt{nodb};
1445 return ("http://localhost:$port", RT::Test::Web->new);
1449 if ( $^O !~ /MSWin32/ ) {
1451 or die "Can't start a new session: $!";
1454 # stick this in a scope so that when $app is garbage collected,
1455 # StashWarnings can complain about unhandled warnings
1457 $plack_server->run($self->test_app(@_));
1464 sub start_inline_server {
1467 require Test::WWW::Mechanize::PSGI;
1468 unshift @RT::Test::Web::ISA, 'Test::WWW::Mechanize::PSGI';
1470 # Clear out squished CSS and JS cache, since it's retained across
1471 # servers, since it's in-process
1472 RT::Interface::Web->ClearSquished;
1473 require RT::Interface::Web::Request;
1474 RT::Interface::Web::Request->clear_callback_cache;
1476 Test::More::ok(1, "psgi test server ok");
1477 $TEST_APP = $self->test_app(@_);
1478 return ("http://localhost:$port", RT::Test::Web->new);
1481 sub start_apache_server {
1483 my %server_opt = @_;
1484 $server_opt{variant} ||= 'mod_perl';
1485 $ENV{RT_TEST_WEB_HANDLER} = "apache+$server_opt{variant}";
1487 require RT::Test::Apache;
1488 my $pid = RT::Test::Apache->start_server(
1493 push @SERVERS, $pid;
1495 my $url = RT->Config->Get('WebURL');
1497 return ($url, RT::Test::Web->new);
1503 return unless @SERVERS;
1506 $sig = 'INT' if $ENV{'RT_TEST_WEB_HANDLER'} eq "plack";
1507 kill $sig, @SERVERS;
1508 foreach my $pid (@SERVERS) {
1509 if ($ENV{RT_TEST_WEB_HANDLER} =~ /^apache/) {
1510 sleep 1 while kill 0, $pid;
1519 sub temp_directory {
1520 return $tmp{'directory'};
1528 $path = File::Spec->catfile( @$path ) if ref $path eq 'ARRAY';
1530 Test::More::diag "reading content of '$path'" if $ENV{'TEST_VERBOSE'};
1532 open( my $fh, "<:raw", $path )
1534 warn "couldn't open file '$path': $!" unless $args{noexist};
1537 my $content = do { local $/; <$fh> };
1540 unlink $path if $args{'unlink'};
1545 sub find_executable {
1550 foreach my $dir ( split /:/, $ENV{'PATH'} ) {
1551 my $fpath = File::Spec->catpath(
1552 (File::Spec->splitpath( $dir, 'no file' ))[0..1], $name
1554 next unless -e $fpath && -r _ && -x _;
1561 return unless $ENV{RT_TEST_VERBOSE} || $ENV{TEST_VERBOSE};
1562 goto \&Test::More::diag;
1567 require RT::EmailParser;
1568 my $parser = RT::EmailParser->new;
1569 $parser->ParseMIMEEntityFromScalar( $mail );
1570 return $parser->Entity;
1574 Test::More::ok($_[0], $_[1] || 'This works');
1578 Test::More::ok(!$_[0], $_[1] || 'This should fail');
1582 my ($cmd, @args) = @_;
1583 my $builder = RT::Test->builder;
1585 if ($cmd eq "skip_all") {
1586 $check_warnings_in_end = 0;
1587 } elsif ($cmd eq "tests") {
1588 # Increment the test count for the warnings check
1591 $builder->plan($cmd, @args);
1595 my $builder = RT::Test->builder;
1597 Test::NoWarnings::had_no_warnings();
1598 $check_warnings_in_end = 0;
1600 $builder->done_testing(@_);
1604 my $Test = RT::Test->builder;
1605 return if $Test->{Original_Pid} != $$;
1607 # we are in END block and should protect our exit code
1608 # so calls below may call system or kill that clobbers $?
1611 Test::NoWarnings::had_no_warnings() if $check_warnings_in_end;
1613 RT::Test->stop_server(1);
1616 if ( !$Test->is_passing ) {
1617 $tmp{'directory'}->unlink_on_destroy(0);
1620 "Some tests failed or we bailed out, tmp directory"
1621 ." '$tmp{directory}' is not cleaned"
1625 if ( $ENV{RT_TEST_PARALLEL} && $created_new_db ) {
1629 # Drop our port from t/tmp/ports; do this after dropping the
1630 # database, as our port lock is also a lock on the database name.
1633 my $portfile = "$tmp{'directory'}/../ports";
1634 sysopen(PORTS, $portfile, O_RDWR|O_CREAT)
1635 or die "Can't write to ports file $portfile: $!";
1636 flock(PORTS, LOCK_EX)
1637 or die "Can't write-lock ports file $portfile: $!";
1638 $ports{$_}++ for split ' ', join("",<PORTS>);
1639 delete $ports{$port};
1642 print PORTS "$_\n" for sort {$a <=> $b} keys %ports;
1643 close(PORTS) or die "Can't close ports file: $!";
1648 # ease the used only once warning
1651 %{'RT::I18N::en_us::Lexicon'};
1652 %{'Win32::Locale::Lexicon'};