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 );
713 sub load_or_create_group {
718 my $group = RT::Group->new( RT->SystemUser );
719 $group->LoadUserDefinedGroup( $name );
720 unless ( $group->id ) {
721 my ($id, $msg) = $group->CreateUserDefinedGroup(
724 die "$msg" unless $id;
727 if ( $args{Members} ) {
728 my $cur = $group->MembersObj;
729 while ( my $entry = $cur->Next ) {
730 my ($status, $msg) = $entry->Delete;
731 die "$msg" unless $status;
734 foreach my $new ( @{ $args{Members} } ) {
735 my ($status, $msg) = $group->AddMember(
736 ref($new)? $new->id : $new,
738 die "$msg" unless $status;
745 =head2 load_or_create_queue
749 sub load_or_create_queue {
751 my %args = ( Disabled => 0, @_ );
752 my $obj = RT::Queue->new( RT->SystemUser );
753 if ( $args{'Name'} ) {
754 $obj->LoadByCols( Name => $args{'Name'} );
756 die "Name is required";
758 unless ( $obj->id ) {
759 my ($val, $msg) = $obj->Create( %args );
760 die "$msg" unless $val;
762 my @fields = qw(CorrespondAddress CommentAddress);
763 foreach my $field ( @fields ) {
764 next unless exists $args{ $field };
765 next if $args{ $field } eq ($obj->$field || '');
767 no warnings 'uninitialized';
768 my $method = 'Set'. $field;
769 my ($val, $msg) = $obj->$method( $args{ $field } );
770 die "$msg" unless $val;
777 sub delete_queue_watchers {
781 foreach my $q ( @queues ) {
782 foreach my $t (qw(Cc AdminCc) ) {
783 $q->DeleteWatcher( Type => $t, PrincipalId => $_->MemberId )
784 foreach @{ $q->$t()->MembersObj->ItemsArrayRef };
790 local $Test::Builder::Level = $Test::Builder::Level + 1;
793 my $defaults = shift;
795 @data = sort { rand(100) <=> rand(100) } @data
796 if delete $defaults->{'RandomOrder'};
798 $defaults->{'Queue'} ||= 'General';
802 my %args = %{ shift @data };
803 $args{$_} = $res[ $args{$_} ]->id foreach
804 grep $args{ $_ }, keys %RT::Ticket::LINKTYPEMAP;
805 push @res, $self->create_ticket( %$defaults, %args );
811 local $Test::Builder::Level = $Test::Builder::Level + 1;
816 if ($args{Queue} && $args{Queue} =~ /\D/) {
817 my $queue = RT::Queue->new(RT->SystemUser);
818 if (my $id = $queue->Load($args{Queue}) ) {
821 die ("Error: Invalid queue $args{Queue}");
825 if ( my $content = delete $args{'Content'} ) {
826 $args{'MIMEObj'} = MIME::Entity->build(
827 From => $args{'Requestor'},
828 Subject => $args{'Subject'},
833 my $ticket = RT::Ticket->new( RT->SystemUser );
834 my ( $id, undef, $msg ) = $ticket->Create( %args );
835 Test::More::ok( $id, "ticket created" )
836 or Test::More::diag("error: $msg");
838 # hackish, but simpler
839 if ( $args{'LastUpdatedBy'} ) {
840 $ticket->__Set( Field => 'LastUpdatedBy', Value => $args{'LastUpdatedBy'} );
844 for my $field ( keys %args ) {
845 #TODO check links and watchers
847 if ( $field =~ /CustomField-(\d+)/ ) {
849 my $got = join ',', sort map $_->Content,
850 @{ $ticket->CustomFieldValues($cf)->ItemsArrayRef };
851 my $expected = ref $args{$field}
852 ? join( ',', sort @{ $args{$field} } )
854 Test::More::is( $got, $expected, 'correct CF values' );
857 next if ref $args{$field};
858 next unless $ticket->can($field) or $ticket->_Accessible($field,"read");
859 next if ref $ticket->$field();
860 Test::More::is( $ticket->$field(), $args{$field}, "$field is correct" );
870 my $tickets = RT::Tickets->new( RT->SystemUser );
872 $tickets->FromSQL( $query );
877 while ( my $ticket = $tickets->Next ) {
882 =head2 load_or_create_custom_field
886 sub load_or_create_custom_field {
888 my %args = ( Disabled => 0, @_ );
889 my $obj = RT::CustomField->new( RT->SystemUser );
890 if ( $args{'Name'} ) {
891 $obj->LoadByName( Name => $args{'Name'}, Queue => $args{'Queue'} );
893 die "Name is required";
895 unless ( $obj->id ) {
896 my ($val, $msg) = $obj->Create( %args );
897 die "$msg" unless $val;
906 $current = $current ? RT::CurrentUser->new($current) : RT->SystemUser;
907 my $tickets = RT::Tickets->new( $current );
908 $tickets->OrderBy( FIELD => 'id', ORDER => 'DESC' );
909 $tickets->Limit( FIELD => 'id', OPERATOR => '>', VALUE => '0' );
910 $tickets->RowsPerPage( 1 );
911 return $tickets->First;
919 RT::ACE->new( RT->SystemUser );
920 my @fields = keys %{ RT::ACE->_ClassAccessible };
923 my $acl = RT::ACL->new( RT->SystemUser );
924 $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 foreach my $field( @fields ) {
935 $tmp{ $field } = $ace->__Value( $field );
945 foreach my $entry ( @entries ) {
946 my $ace = RT::ACE->new( RT->SystemUser );
947 my ($status, $msg) = $ace->RT::Record::Create( %$entry );
949 Test::More::diag "couldn't create a record: $msg";
958 my $acl = RT::ACL->new( RT->SystemUser );
959 $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
960 while ( my $ace = $acl->Next ) {
961 my $obj = $ace->PrincipalObj->Object;
962 if ( $obj->isa('RT::Group') && ($obj->Type||'') eq 'UserEquiv' && $obj->Instance == RT->Nobody->id ) {
967 return $self->add_rights( @_ );
972 my @list = ref $_[0]? @_: @_? { @_ }: ();
975 foreach my $e (@list) {
976 my $principal = delete $e->{'Principal'};
977 unless ( ref $principal ) {
978 if ( $principal =~ /^(everyone|(?:un)?privileged)$/i ) {
979 $principal = RT::Group->new( RT->SystemUser );
980 $principal->LoadSystemInternalGroup($1);
981 } elsif ( $principal =~ /^(Owner|Requestor|(?:Admin)?Cc)$/i ) {
982 $principal = RT::Group->new( RT->SystemUser );
983 $principal->LoadByCols(
984 Domain => (ref($e->{'Object'})||'RT::System').'-Role',
986 ref($e->{'Object'})? (Instance => $e->{'Object'}->id): (),
989 die "principal is not an object, but also is not name of a system group";
992 unless ( $principal->isa('RT::Principal') ) {
993 if ( $principal->can('PrincipalObj') ) {
994 $principal = $principal->PrincipalObj;
997 my @rights = ref $e->{'Right'}? @{ $e->{'Right'} }: ($e->{'Right'});
998 foreach my $right ( @rights ) {
999 my ($status, $msg) = $principal->GrantRight( %$e, Right => $right );
1000 $RT::Logger->debug($msg);
1009 require RT::Test::Web;
1011 url => RT::Test::Web->rt_base_url,
1013 action => 'correspond',
1016 command => $RT::BinPath .'/rt-mailgate',
1019 my $message = delete $args{'message'};
1021 $args{after_open} = sub {
1022 my $child_in = shift;
1023 if ( UNIVERSAL::isa($message, 'MIME::Entity') ) {
1024 $message->print( $child_in );
1026 print $child_in $message;
1030 $self->run_and_capture(%args);
1035 my %args = (check => 1, resolve => 0, force => 1, timeout => 0, @_ );
1037 my $validator_path = "$RT::SbinPath/rt-validator";
1039 my $cmd = $validator_path;
1040 die "Couldn't find $cmd command" unless -f $cmd;
1042 my $timeout = delete $args{timeout};
1044 while( my ($k,$v) = each %args ) {
1046 $cmd .= " --$k '$v'";
1051 my ($child_out, $child_in);
1052 my $pid = IPC::Open2::open2($child_out, $child_in, $cmd);
1055 local $SIG{ALRM} = sub { kill KILL => $pid; die "Timeout!" };
1057 alarm $timeout if $timeout;
1058 my $result = eval { local $/; <$child_out> };
1064 DBIx::SearchBuilder::Record::Cachable->FlushCache
1065 if $args{'resolve'};
1067 return ($?, $result);
1070 sub run_and_capture {
1074 my $after_open = delete $args{after_open};
1076 my $cmd = delete $args{'command'};
1077 die "Couldn't find command ($cmd)" unless -f $cmd;
1079 $cmd .= ' --debug' if delete $args{'debug'};
1081 while( my ($k,$v) = each %args ) {
1083 $cmd .= " --$k '$v'";
1087 DBIx::SearchBuilder::Record::Cachable->FlushCache;
1090 my ($child_out, $child_in);
1091 my $pid = IPC::Open2::open2($child_out, $child_in, $cmd);
1093 $after_open->($child_in, $child_out) if $after_open;
1097 my $result = do { local $/; <$child_out> };
1100 return ($?, $result);
1103 sub send_via_mailgate_and_http {
1105 my $message = shift;
1108 my ($status, $gate_result) = $self->run_mailgate(
1109 message => $message, %args
1113 unless ( $status >> 8 ) {
1114 ($id) = ($gate_result =~ /Ticket:\s*(\d+)/i);
1116 Test::More::diag "Couldn't find ticket id in text:\n$gate_result"
1117 if $ENV{'TEST_VERBOSE'};
1120 Test::More::diag "Mailgate output:\n$gate_result"
1121 if $ENV{'TEST_VERBOSE'};
1123 return ($status, $id);
1127 sub send_via_mailgate {
1129 my $message = shift;
1130 my %args = ( action => 'correspond',
1135 if ( UNIVERSAL::isa( $message, 'MIME::Entity' ) ) {
1136 $message = $message->as_string;
1139 my ( $status, $error_message, $ticket )
1140 = RT::Interface::Email::Gateway( {%args, message => $message} );
1141 return ( $status, $ticket ? $ticket->id : 0 );
1146 sub open_mailgate_ok {
1148 my $baseurl = shift;
1149 my $queue = shift || 'general';
1150 my $action = shift || 'correspond';
1151 Test::More::ok(open(my $mail, '|-', "$RT::BinPath/rt-mailgate --url $baseurl --queue $queue --action $action"), "Opened the mailgate - $!");
1156 sub close_mailgate_ok {
1160 Test::More::is ($? >> 8, 0, "The mail gateway exited normally. yay");
1165 my $expected = shift;
1167 my $mailsent = scalar grep /\S/, split /%% split me! %%\n/,
1168 RT::Test->file_content(
1175 $mailsent, $expected,
1176 "The number of mail sent ($expected) matches. yay"
1180 sub fetch_caught_mails {
1182 return grep /\S/, split /%% split me! %%\n/,
1183 RT::Test->file_content(
1190 sub clean_caught_mails {
1191 unlink $tmp{'mailbox'};
1194 =head2 get_relocatable_dir
1196 Takes a path relative to the location of the test file that is being
1197 run and returns a path that takes the invocation path into account.
1199 e.g. C<RT::Test::get_relocatable_dir(File::Spec->updir(), 'data', 'emails')>
1201 Parent directory traversals (C<..> or File::Spec->updir()) are naively
1202 canonicalized based on the test file path (C<$0>) so that symlinks aren't
1203 followed. This is the exact opposite behaviour of most filesystems and is
1204 considered "wrong", however it is necessary for some subsets of tests which are
1205 symlinked into the testing tree.
1209 sub get_relocatable_dir {
1210 my @directories = File::Spec->splitdir(
1211 File::Spec->rel2abs((File::Spec->splitpath($0))[1])
1213 push @directories, File::Spec->splitdir($_) for @_;
1216 for (@directories) {
1217 if ($_ eq "..") { pop @clean }
1218 elsif ($_ ne ".") { push @clean, $_ }
1220 return File::Spec->catdir(@clean);
1223 =head2 get_relocatable_file
1225 Same as get_relocatable_dir, but takes a file and a path instead
1228 e.g. RT::Test::get_relocatable_file('test-email',
1229 (File::Spec->updir(), 'data', 'emails'))
1233 sub get_relocatable_file {
1235 return File::Spec->catfile(get_relocatable_dir(@_), $file);
1238 sub get_abs_relocatable_dir {
1239 (my $volume, my $directories, my $file) = File::Spec->splitpath($0);
1240 if (File::Spec->file_name_is_absolute($directories)) {
1241 return File::Spec->catdir($directories, @_);
1243 return File::Spec->catdir(Cwd->getcwd(), $directories, @_);
1250 DIR => $tmp{directory},
1255 sub import_gnupg_key {
1258 my $type = shift || 'secret';
1260 $key =~ s/\@/-at-/g;
1261 $key .= ".$type.key";
1263 require RT::Crypt::GnuPG;
1265 # simple strategy find data/gnupg/keys, from the dir where test file lives
1266 # to updirs, try 3 times in total
1267 my $path = File::Spec->catfile( 'data', 'gnupg', 'keys' );
1269 for my $up ( 0 .. 2 ) {
1270 my $p = get_relocatable_dir($path);
1276 $path = File::Spec->catfile( File::Spec->updir(), $path );
1280 die "can't find the dir where gnupg keys are stored"
1283 return RT::Crypt::GnuPG::ImportKey(
1284 RT::Test->file_content( [ $abs_path, $key ] ) );
1288 sub lsign_gnupg_key {
1292 require RT::Crypt::GnuPG; require GnuPG::Interface;
1293 my $gnupg = GnuPG::Interface->new();
1294 my %opt = RT->Config->Get('GnuPGOptions');
1295 $gnupg->options->hash_init(
1296 RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
1297 meta_interactive => 0,
1301 my $handles = GnuPG::Handles->new(
1302 stdin => ($handle{'input'} = IO::Handle->new()),
1303 stdout => ($handle{'output'} = IO::Handle->new()),
1304 stderr => ($handle{'error'} = IO::Handle->new()),
1305 logger => ($handle{'logger'} = IO::Handle->new()),
1306 status => ($handle{'status'} = IO::Handle->new()),
1307 command => ($handle{'command'} = IO::Handle->new()),
1311 local $SIG{'CHLD'} = 'DEFAULT';
1312 local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
1313 my $pid = $gnupg->wrap_call(
1314 handles => $handles,
1315 commands => ['--lsign-key'],
1316 command_args => [$key],
1318 close $handle{'input'};
1319 while ( my $str = readline $handle{'status'} ) {
1320 if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL sign_uid\..*/ ) {
1321 print { $handle{'command'} } "y\n";
1327 close $handle{'output'};
1330 $res{'exit_code'} = $?;
1331 foreach ( qw(error logger status) ) {
1332 $res{$_} = do { local $/; readline $handle{$_} };
1333 delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1336 $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1337 $RT::Logger->warning( $res{'error'} ) if $res{'error'};
1338 $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1339 if ( $err || $res{'exit_code'} ) {
1340 $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
1345 sub trust_gnupg_key {
1349 require RT::Crypt::GnuPG; require GnuPG::Interface;
1350 my $gnupg = GnuPG::Interface->new();
1351 my %opt = RT->Config->Get('GnuPGOptions');
1352 $gnupg->options->hash_init(
1353 RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
1354 meta_interactive => 0,
1358 my $handles = GnuPG::Handles->new(
1359 stdin => ($handle{'input'} = IO::Handle->new()),
1360 stdout => ($handle{'output'} = IO::Handle->new()),
1361 stderr => ($handle{'error'} = IO::Handle->new()),
1362 logger => ($handle{'logger'} = IO::Handle->new()),
1363 status => ($handle{'status'} = IO::Handle->new()),
1364 command => ($handle{'command'} = IO::Handle->new()),
1368 local $SIG{'CHLD'} = 'DEFAULT';
1369 local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
1370 my $pid = $gnupg->wrap_call(
1371 handles => $handles,
1372 commands => ['--edit-key'],
1373 command_args => [$key],
1375 close $handle{'input'};
1378 while ( my $str = readline $handle{'status'} ) {
1379 if ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE keyedit.prompt/ ) {
1381 print { $handle{'command'} } "quit\n";
1383 print { $handle{'command'} } "trust\n";
1385 } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE edit_ownertrust.value/ ) {
1386 print { $handle{'command'} } "5\n";
1387 } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_BOOL edit_ownertrust.set_ultimate.okay/ ) {
1388 print { $handle{'command'} } "y\n";
1395 close $handle{'output'};
1398 $res{'exit_code'} = $?;
1399 foreach ( qw(error logger status) ) {
1400 $res{$_} = do { local $/; readline $handle{$_} };
1401 delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1404 $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1405 $RT::Logger->warning( $res{'error'} ) if $res{'error'};
1406 $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1407 if ( $err || $res{'exit_code'} ) {
1408 $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
1416 require RT::Test::Web;
1418 if ($rttest_opt{nodb} and not $rttest_opt{server_ok}) {
1419 die "You are trying to use a test web server without a database. "
1420 ."You may want noinitialdata => 1 instead. "
1421 ."Pass server_ok => 1 if you know what you're doing.";
1425 $ENV{'RT_TEST_WEB_HANDLER'} = undef
1426 if $rttest_opt{actual_server} && ($ENV{'RT_TEST_WEB_HANDLER'}||'') eq 'inline';
1427 $ENV{'RT_TEST_WEB_HANDLER'} ||= 'plack';
1428 my $which = $ENV{'RT_TEST_WEB_HANDLER'};
1429 my ($server, $variant) = split /\+/, $which, 2;
1431 my $function = 'start_'. $server .'_server';
1432 unless ( $self->can($function) ) {
1433 die "Don't know how to start server '$server'";
1435 return $self->$function( variant => $variant, @_ );
1440 my %server_opt = @_;
1445 open( my $warn_fh, ">", \$warnings );
1446 local *STDERR = $warn_fh;
1448 if ($server_opt{variant} and $server_opt{variant} eq 'rt-server') {
1450 my $file = "$RT::SbinPath/rt-server";
1451 my $psgi = do $file;
1453 die "Couldn't parse $file: $@" if $@;
1454 die "Couldn't do $file: $!" unless defined $psgi;
1455 die "Couldn't run $file" unless $psgi;
1460 require RT::Interface::Web::Handler;
1461 $app = RT::Interface::Web::Handler->PSGIApp;
1464 require Plack::Middleware::Test::StashWarnings;
1465 my $stashwarnings = Plack::Middleware::Test::StashWarnings->new(
1466 $ENV{'RT_TEST_WEB_HANDLER'} && $ENV{'RT_TEST_WEB_HANDLER'} eq 'inline' ? ( verbose => 0 ) : () );
1467 $app = $stashwarnings->wrap($app);
1469 if ($server_opt{basic_auth}) {
1470 require Plack::Middleware::Auth::Basic;
1471 $app = Plack::Middleware::Auth::Basic->wrap(
1473 authenticator => sub {
1474 my ($username, $password) = @_;
1475 return $username eq 'root' && $password eq 'password';
1481 $stashwarnings->add_warning( $warnings ) if $warnings;
1486 sub start_plack_server {
1489 require Plack::Loader;
1490 my $plack_server = Plack::Loader->load
1493 server_ready => sub {
1494 kill 'USR1' => getppid();
1497 # We are expecting a USR1 from the child process after it's ready
1498 # to listen. We set this up _before_ we fork to avoid race
1501 local $SIG{USR1} = sub { $handled = 1};
1505 die "failed to fork" unless defined $pid;
1508 sleep 15 unless $handled;
1509 Test::More::diag "did not get expected USR1 for test server readiness"
1511 push @SERVERS, $pid;
1512 my $Tester = Test::Builder->new;
1513 $Tester->ok(1, "started plack server ok");
1516 unless $rttest_opt{nodb};
1517 return ("http://localhost:$port", RT::Test::Web->new);
1521 if ( $^O !~ /MSWin32/ ) {
1523 or die "Can't start a new session: $!";
1526 # stick this in a scope so that when $app is garbage collected,
1527 # StashWarnings can complain about unhandled warnings
1529 $plack_server->run($self->test_app(@_));
1536 sub start_inline_server {
1539 require Test::WWW::Mechanize::PSGI;
1540 unshift @RT::Test::Web::ISA, 'Test::WWW::Mechanize::PSGI';
1542 # Clear out squished CSS and JS cache, since it's retained across
1543 # servers, since it's in-process
1544 RT::Interface::Web->ClearSquished;
1545 require RT::Interface::Web::Request;
1546 RT::Interface::Web::Request->clear_callback_cache;
1548 Test::More::ok(1, "psgi test server ok");
1549 $TEST_APP = $self->test_app(@_);
1550 return ("http://localhost:$port", RT::Test::Web->new);
1553 sub start_apache_server {
1555 my %server_opt = @_;
1556 $server_opt{variant} ||= 'mod_perl';
1557 $ENV{RT_TEST_WEB_HANDLER} = "apache+$server_opt{variant}";
1559 require RT::Test::Apache;
1560 my $pid = RT::Test::Apache->start_server(
1565 push @SERVERS, $pid;
1567 my $url = RT->Config->Get('WebURL');
1569 return ($url, RT::Test::Web->new);
1575 return unless @SERVERS;
1577 kill 'TERM', @SERVERS;
1578 foreach my $pid (@SERVERS) {
1579 if ($ENV{RT_TEST_WEB_HANDLER} =~ /^apache/) {
1580 sleep 1 while kill 0, $pid;
1589 sub temp_directory {
1590 return $tmp{'directory'};
1598 $path = File::Spec->catfile( @$path ) if ref $path eq 'ARRAY';
1600 open( my $fh, "<:raw", $path )
1602 warn "couldn't open file '$path': $!" unless $args{noexist};
1605 my $content = do { local $/; <$fh> };
1608 unlink $path if $args{'unlink'};
1613 sub find_executable {
1618 foreach my $dir ( split /:/, $ENV{'PATH'} ) {
1619 my $fpath = File::Spec->catpath(
1620 (File::Spec->splitpath( $dir, 'no file' ))[0..1], $name
1622 next unless -e $fpath && -r _ && -x _;
1629 return unless $ENV{RT_TEST_VERBOSE} || $ENV{TEST_VERBOSE};
1630 goto \&Test::More::diag;
1635 require RT::EmailParser;
1636 my $parser = RT::EmailParser->new;
1637 $parser->ParseMIMEEntityFromScalar( $mail );
1638 return $parser->Entity;
1642 Test::More::ok($_[0], $_[1] || 'This works');
1646 Test::More::ok(!$_[0], $_[1] || 'This should fail');
1650 my ($cmd, @args) = @_;
1651 my $builder = RT::Test->builder;
1653 if ($cmd eq "skip_all") {
1654 $check_warnings_in_end = 0;
1655 } elsif ($cmd eq "tests") {
1656 # Increment the test count for the warnings check
1659 $builder->plan($cmd, @args);
1663 my $builder = RT::Test->builder;
1665 Test::NoWarnings::had_no_warnings();
1666 $check_warnings_in_end = 0;
1668 $builder->done_testing(@_);
1672 my $Test = RT::Test->builder;
1673 return if $Test->{Original_Pid} != $$;
1675 # we are in END block and should protect our exit code
1676 # so calls below may call system or kill that clobbers $?
1679 Test::NoWarnings::had_no_warnings() if $check_warnings_in_end;
1681 RT::Test->stop_server(1);
1684 if ( !$Test->is_passing ) {
1685 $tmp{'directory'}->unlink_on_destroy(0);
1688 "Some tests failed or we bailed out, tmp directory"
1689 ." '$tmp{directory}' is not cleaned"
1693 if ( $ENV{RT_TEST_PARALLEL} && $created_new_db ) {
1697 # Drop our port from t/tmp/ports; do this after dropping the
1698 # database, as our port lock is also a lock on the database name.
1701 my $portfile = "$tmp{'directory'}/../ports";
1702 sysopen(PORTS, $portfile, O_RDWR|O_CREAT)
1703 or die "Can't write to ports file $portfile: $!";
1704 flock(PORTS, LOCK_EX)
1705 or die "Can't write-lock ports file $portfile: $!";
1706 $ports{$_}++ for split ' ', join("",<PORTS>);
1707 delete $ports{$port};
1710 print PORTS "$_\n" for sort {$a <=> $b} keys %ports;
1711 close(PORTS) or die "Can't close ports file: $!";
1716 # ease the used only once warning
1719 %{'RT::I18N::en_us::Lexicon'};
1720 %{'Win32::Locale::Lexicon'};