1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2012 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';
58 use File::Temp qw(tempfile);
59 use File::Path qw(mkpath);
62 our @EXPORT = qw(is_empty diag parse_mail works fails);
83 To run the rt test suite with coverage support, install L<Devel::Cover> and run:
85 make test RT_DBA_USER=.. RT_DBA_PASSWORD=.. HARNESS_PERL_SWITCHES=-MDevel::Cover
86 cover -ignore_re '^var/mason_data/' -ignore_re '^t/'
88 The coverage tests have DevelMode turned off, and have
89 C<named_component_subs> enabled for L<HTML::Mason> to avoid an optimizer
90 problem in Perl that hides the top-level optree from L<Devel::Cover>.
99 my %args = %rttest_opt = @_;
101 # Spit out a plan (if we got one) *before* we load modules
102 if ( $args{'tests'} ) {
103 $class->builder->plan( tests => $args{'tests'} )
104 unless $args{'tests'} eq 'no_declare';
106 elsif ( exists $args{'tests'} ) {
107 # do nothing if they say "tests => undef" - let them make the plan
109 elsif ( $args{'skip_all'} ) {
110 $class->builder->plan(skip_all => $args{'skip_all'});
113 $class->builder->no_plan unless $class->builder->has_plan;
116 push @{ $args{'plugins'} ||= [] }, @{ $args{'requires'} }
117 if $args{'requires'};
118 push @{ $args{'plugins'} ||= [] }, $args{'testing'}
121 $class->bootstrap_tempdir;
123 $class->bootstrap_port;
125 $class->bootstrap_plugins_paths( %args );
127 $class->bootstrap_config( %args );
132 if (RT->Config->Get('DevelMode')) { require Module::Refresh; }
134 $class->bootstrap_db( %args );
136 RT::InitPluginPaths();
147 RT->Config->PostLoadCheck;
149 $class->set_config_wrapper;
151 my $screen_logger = $RT::Logger->remove( 'screen' );
152 require Log::Dispatch::Perl;
153 $RT::Logger->add( Log::Dispatch::Perl->new
155 min_level => $screen_logger->min_level,
156 action => { error => 'warn',
157 critical => 'warn' } ) );
159 # XXX: this should really be totally isolated environment so we
160 # can parallelize and be sane
161 mkpath [ $RT::MasonSessionDir ]
162 if RT->Config->Get('DatabaseType');
165 while ( my ($package) = caller($level-1) ) {
166 last unless $package =~ /Test/;
170 Test::More->export_to_level($level);
172 # blow away their diag so we can redefine it without warning
173 # better than "no warnings 'redefine'" because we might accidentally
174 # suppress a mistaken redefinition
176 delete ${ caller($level) . '::' }{diag};
177 __PACKAGE__->export_to_level($level);
182 local $Test::Builder::Level = $Test::Builder::Level + 1;
183 return Test::More::ok(1, $d) unless defined $v;
184 return Test::More::ok(1, $d) unless length $v;
185 return Test::More::is($v, '', $d);
188 my $created_new_db; # have we created new db? mainly for parallel testing
190 sub db_requires_no_dba {
192 my $db_type = RT->Config->Get('DatabaseType');
193 return 1 if $db_type eq 'SQLite';
201 # Determine which ports are in use
202 use Fcntl qw(:DEFAULT :flock);
203 my $portfile = "$tmp{'directory'}/../ports";
204 sysopen(PORTS, $portfile, O_RDWR|O_CREAT)
205 or die "Can't write to ports file $portfile: $!";
206 flock(PORTS, LOCK_EX)
207 or die "Can't write-lock ports file $portfile: $!";
208 $ports{$_}++ for split ' ', join("",<PORTS>);
210 # Pick a random port, checking that the port isn't in our in-use
211 # list, and that something isn't already listening there.
213 $port = 1024 + int rand(10_000) + $$ % 1024;
214 redo if $ports{$port};
216 # There is a race condition in here, where some non-RT::Test
217 # process claims the port after we check here but before our
218 # server binds. However, since we mostly care about race
219 # conditions with ourselves under high concurrency, this is
220 # generally good enough.
221 my $paddr = sockaddr_in( $port, inet_aton('localhost') );
222 socket( SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
224 if ( connect( SOCK, $paddr ) ) {
233 # Write back out the in-use ports
236 print PORTS "$_\n" for sort {$a <=> $b} keys %ports;
237 close(PORTS) or die "Can't close ports file: $!";
240 sub bootstrap_tempdir {
242 my ($test_dir, $test_file) = ('t', '');
244 if (File::Spec->rel2abs($0) =~ m{(?:^|[\\/])(x?t)[/\\](.*)}) {
247 $test_file =~ s{[/\\]}{-}g;
250 my $dir_name = File::Spec->rel2abs("$test_dir/tmp");
252 return $tmp{'directory'} = File::Temp->newdir(
253 "${test_file}XXXXXXXX",
258 sub bootstrap_config {
262 $tmp{'config'}{'RT'} = File::Spec->catfile(
263 "$tmp{'directory'}", 'RT_SiteConfig.pm'
265 open( my $config, '>', $tmp{'config'}{'RT'} )
266 or die "Couldn't open $tmp{'config'}{'RT'}: $!";
268 my $dbname = $ENV{RT_TEST_PARALLEL}? "rt4test_$port" : "rt4test";
270 Set( \$WebDomain, "localhost");
271 Set( \$WebPort, $port);
273 Set( \@LexiconLanguages, qw(en zh_TW fr ja));
274 Set( \$RTAddressRegexp , qr/^bad_re_that_doesnt_match\$/i);
276 if ( $ENV{'RT_TEST_DB_SID'} ) { # oracle case
277 print $config "Set( \$DatabaseName , '$ENV{'RT_TEST_DB_SID'}' );\n";
278 print $config "Set( \$DatabaseUser , '$dbname');\n";
280 print $config "Set( \$DatabaseName , '$dbname');\n";
281 print $config "Set( \$DatabaseUser , 'u${dbname}');\n";
284 if ( $args{'plugins'} ) {
285 print $config "Set( \@Plugins, qw(". join( ' ', @{ $args{'plugins'} } ) .") );\n";
288 if ( $INC{'Devel/Cover.pm'} ) {
289 print $config "Set( \$DevelMode, 0 );\n";
291 elsif ( $ENV{RT_TEST_DEVEL} ) {
292 print $config "Set( \$DevelMode, 1 );\n";
295 print $config "Set( \$DevelMode, 0 );\n";
298 $self->bootstrap_logging( $config );
301 my $mail_catcher = $tmp{'mailbox'} = File::Spec->catfile(
302 $tmp{'directory'}->dirname, 'mailbox.eml'
305 Set( \$MailCommand, sub {
308 open( my \$handle, '>>', '$mail_catcher' )
309 or die "Unable to open '$mail_catcher' for appending: \$!";
311 \$MIME->print(\$handle);
312 print \$handle "%% split me! %%\n";
317 $self->bootstrap_more_config($config, \%args);
319 print $config $args{'config'} if $args{'config'};
321 print $config "\n1;\n";
322 $ENV{'RT_SITE_CONFIG'} = $tmp{'config'}{'RT'};
328 sub bootstrap_more_config { }
330 sub bootstrap_logging {
334 # prepare file for logging
335 $tmp{'log'}{'RT'} = File::Spec->catfile(
336 "$tmp{'directory'}", 'rt.debug.log'
338 open( my $fh, '>', $tmp{'log'}{'RT'} )
339 or die "Couldn't open $tmp{'config'}{'RT'}: $!";
340 # make world writable so apache under different user
342 chmod 0666, $tmp{'log'}{'RT'};
345 Set( \$LogToSyslog , undef);
346 Set( \$LogToScreen , "warning");
347 Set( \$LogToFile, 'debug' );
348 Set( \$LogDir, q{$tmp{'directory'}} );
349 Set( \$LogToFileNamed, 'rt.debug.log' );
353 sub set_config_wrapper {
356 my $old_sub = \&RT::Config::Set;
357 no warnings 'redefine';
358 *RT::Config::Set = sub {
359 # Determine if the caller is either from a test script, or
360 # from helper functions called by test script to alter
361 # configuration that should be written. This is necessary
362 # because some extensions (RTIR, for example) temporarily swap
363 # configuration values out and back in Mason during requests.
364 my @caller = caller(1); # preserve list context
365 @caller = caller(0) unless @caller;
367 if ( ($caller[1]||'') =~ /\.t$/) {
368 my ($self, $name) = @_;
369 my $type = $RT::Config::META{$name}->{'Type'} || 'SCALAR';
375 my $sigil = $sigils{$type} || $sigils{'SCALAR'};
376 open( my $fh, '>>', $tmp{'config'}{'RT'} )
377 or die "Couldn't open config file: $!";
378 require Data::Dumper;
379 local $Data::Dumper::Terse = 1;
380 my $dump = Data::Dumper::Dumper([@_[2 .. $#_]]);
383 "\nSet(${sigil}${name}, \@{". $dump ."});\n1;\n";
387 warn "you're changing config option in a test file"
388 ." when server is active";
391 return $old_sub->(@_);
399 unless (defined $ENV{'RT_DBA_USER'} && defined $ENV{'RT_DBA_PASSWORD'}) {
400 Test::More::BAIL_OUT(
401 "RT_DBA_USER and RT_DBA_PASSWORD environment variables need"
402 ." to be set in order to run 'make test'"
403 ) unless $self->db_requires_no_dba;
407 if (my $forceopt = $ENV{RT_TEST_FORCE_OPT}) {
408 Test::More::diag "forcing $forceopt";
412 return if $args{nodb};
414 my $db_type = RT->Config->Get('DatabaseType');
416 __reconnect_rt('as dba');
417 $RT::Handle->InsertSchema;
418 $RT::Handle->InsertACL unless $db_type eq 'Oracle';
423 $RT::Handle->InsertInitialData
424 unless $args{noinitialdata};
426 $RT::Handle->InsertData( $RT::EtcPath . "/initialdata" )
427 unless $args{noinitialdata} or $args{nodata};
429 $self->bootstrap_plugins_db( %args );
432 sub bootstrap_plugins_paths {
436 return unless $args{'plugins'};
437 my @plugins = @{ $args{'plugins'} };
440 if ( $args{'testing'} ) {
442 $cwd = Cwd::getcwd();
446 my $old_func = \&RT::Plugin::_BasePath;
447 no warnings 'redefine';
448 *RT::Plugin::_BasePath = sub {
449 my $name = $_[0]->{'name'};
451 return $cwd if $args{'testing'} && $name eq $args{'testing'};
453 if ( grep $name eq $_, @plugins ) {
454 my $variants = join "(?:|::|-|_)", map "\Q$_\E", split /::/, $name;
455 my ($path) = map $ENV{$_}, grep /^CHIMPS_(?:$variants).*_ROOT$/i, keys %ENV;
456 return $path if $path;
458 return $old_func->(@_);
462 sub bootstrap_plugins_db {
466 return unless $args{'plugins'};
470 my @plugins = @{ $args{'plugins'} };
471 foreach my $name ( @plugins ) {
472 my $plugin = RT::Plugin->new( name => $name );
473 Test::More::diag( "Initializing DB for the $name plugin" )
474 if $ENV{'TEST_VERBOSE'};
476 my $etc_path = $plugin->Path('etc');
477 Test::More::diag( "etc path of the plugin is '$etc_path'" )
478 if $ENV{'TEST_VERBOSE'};
480 unless ( -e $etc_path ) {
481 # We can't tell if the plugin has no data, or we screwed up the etc/ path
482 Test::More::ok(1, "There is no etc dir: no schema" );
483 Test::More::ok(1, "There is no etc dir: no ACLs" );
484 Test::More::ok(1, "There is no etc dir: no data" );
488 __reconnect_rt('as dba');
491 my ($ret, $msg) = $RT::Handle->InsertSchema( undef, $etc_path );
492 Test::More::ok($ret || $msg =~ /^Couldn't find schema/, "Created schema: ".($msg||''));
496 my ($ret, $msg) = $RT::Handle->InsertACL( undef, $etc_path );
497 Test::More::ok($ret || $msg =~ /^Couldn't find ACLs/, "Created ACL: ".($msg||''));
501 my $data_file = File::Spec->catfile( $etc_path, 'initialdata' );
502 if ( -e $data_file ) {
504 my ($ret, $msg) = $RT::Handle->InsertData( $data_file );;
505 Test::More::ok($ret, "Inserted data".($msg||''));
507 Test::More::ok(1, "There is no data file" );
514 my ($dsn, $user, $pass) = @_;
515 if ( $dsn =~ /Oracle/i ) {
516 $ENV{'NLS_LANG'} = "AMERICAN_AMERICA.AL32UTF8";
517 $ENV{'NLS_NCHAR'} = "AL32UTF8";
519 my $dbh = DBI->connect(
521 { RaiseError => 0, PrintError => 1 },
524 my $msg = "Failed to connect to $dsn as user '$user': ". $DBI::errstr;
525 print STDERR $msg; exit -1;
530 sub __create_database {
531 # bootstrap with dba cred
533 RT::Handle->SystemDSN,
534 $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD}
537 unless ( $ENV{RT_TEST_PARALLEL} ) {
538 # already dropped db in parallel tests, need to do so for other cases.
539 __drop_database( $dbh );
542 RT::Handle->CreateDatabase( $dbh );
547 sub __drop_database {
550 # Pg doesn't like if you issue a DROP DATABASE while still connected
551 # it's still may fail if web-server is out there and holding a connection
554 my $my_dbh = $dbh? 0 : 1;
556 RT::Handle->SystemDSN,
557 $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD}
559 RT::Handle->DropDatabase( $dbh );
560 $dbh->disconnect if $my_dbh;
567 # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation
568 $RT::Handle = RT::Handle->new;
569 $RT::Handle->dbh( undef );
570 $RT::Handle->Connect(
572 ? (User => $ENV{RT_DBA_USER}, Password => $ENV{RT_DBA_PASSWORD})
575 $RT::Handle->PrintError;
576 $RT::Handle->dbh->{PrintError} = 1;
577 return $RT::Handle->dbh;
580 sub __disconnect_rt {
581 # look at %DBIHandle and $PrevHandle in DBIx::SB::Handle for explanation
582 $RT::Handle->dbh->disconnect if $RT::Handle and $RT::Handle->dbh;
584 %DBIx::SearchBuilder::Handle::DBIHandle = ();
585 $DBIx::SearchBuilder::Handle::PrevHandle = undef;
589 delete $RT::System->{attributes};
591 DBIx::SearchBuilder::Record::Cachable->FlushCache
592 if DBIx::SearchBuilder::Record::Cachable->can("FlushCache");
598 =head2 load_or_create_user
602 sub load_or_create_user {
604 my %args = ( Privileged => 1, Disabled => 0, @_ );
606 my $MemberOf = delete $args{'MemberOf'};
607 $MemberOf = [ $MemberOf ] if defined $MemberOf && !ref $MemberOf;
610 my $obj = RT::User->new( RT->SystemUser );
611 if ( $args{'Name'} ) {
612 $obj->LoadByCols( Name => $args{'Name'} );
613 } elsif ( $args{'EmailAddress'} ) {
614 $obj->LoadByCols( EmailAddress => $args{'EmailAddress'} );
616 die "Name or EmailAddress is required";
620 $obj->SetPrivileged( $args{'Privileged'} || 0 )
621 if ($args{'Privileged'}||0) != ($obj->Privileged||0);
622 $obj->SetDisabled( $args{'Disabled'} || 0 )
623 if ($args{'Disabled'}||0) != ($obj->Disabled||0);
625 my ($val, $msg) = $obj->Create( %args );
626 die "$msg" unless $val;
629 # clean group membership
631 require RT::GroupMembers;
632 my $gms = RT::GroupMembers->new( RT->SystemUser );
633 my $groups_alias = $gms->Join(
634 FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id',
636 $gms->Limit( ALIAS => $groups_alias, FIELD => 'Domain', VALUE => 'UserDefined' );
637 $gms->Limit( FIELD => 'MemberId', VALUE => $obj->id );
638 while ( my $group_member_record = $gms->Next ) {
639 $group_member_record->Delete;
643 # add new user to groups
644 foreach ( @$MemberOf ) {
645 my $group = RT::Group->new( RT::SystemUser() );
646 $group->LoadUserDefinedGroup( $_ );
647 die "couldn't load group '$_'" unless $group->id;
648 $group->AddMember( $obj->id );
654 =head2 load_or_create_queue
658 sub load_or_create_queue {
660 my %args = ( Disabled => 0, @_ );
661 my $obj = RT::Queue->new( RT->SystemUser );
662 if ( $args{'Name'} ) {
663 $obj->LoadByCols( Name => $args{'Name'} );
665 die "Name is required";
667 unless ( $obj->id ) {
668 my ($val, $msg) = $obj->Create( %args );
669 die "$msg" unless $val;
671 my @fields = qw(CorrespondAddress CommentAddress);
672 foreach my $field ( @fields ) {
673 next unless exists $args{ $field };
674 next if $args{ $field } eq ($obj->$field || '');
676 no warnings 'uninitialized';
677 my $method = 'Set'. $field;
678 my ($val, $msg) = $obj->$method( $args{ $field } );
679 die "$msg" unless $val;
686 sub delete_queue_watchers {
690 foreach my $q ( @queues ) {
691 foreach my $t (qw(Cc AdminCc) ) {
692 $q->DeleteWatcher( Type => $t, PrincipalId => $_->MemberId )
693 foreach @{ $q->$t()->MembersObj->ItemsArrayRef };
699 local $Test::Builder::Level = $Test::Builder::Level + 1;
702 my $defaults = shift;
704 @data = sort { rand(100) <=> rand(100) } @data
705 if delete $defaults->{'RandomOrder'};
707 $defaults->{'Queue'} ||= 'General';
711 my %args = %{ shift @data };
712 $args{$_} = $res[ $args{$_} ]->id foreach
713 grep $args{ $_ }, keys %RT::Ticket::LINKTYPEMAP;
714 push @res, $self->create_ticket( %$defaults, %args );
720 local $Test::Builder::Level = $Test::Builder::Level + 1;
725 if ($args{Queue} && $args{Queue} =~ /\D/) {
726 my $queue = RT::Queue->new(RT->SystemUser);
727 if (my $id = $queue->Load($args{Queue}) ) {
730 die ("Error: Invalid queue $args{Queue}");
734 if ( my $content = delete $args{'Content'} ) {
735 $args{'MIMEObj'} = MIME::Entity->build(
736 From => $args{'Requestor'},
737 Subject => $args{'Subject'},
742 my $ticket = RT::Ticket->new( RT->SystemUser );
743 my ( $id, undef, $msg ) = $ticket->Create( %args );
744 Test::More::ok( $id, "ticket created" )
745 or Test::More::diag("error: $msg");
747 # hackish, but simpler
748 if ( $args{'LastUpdatedBy'} ) {
749 $ticket->__Set( Field => 'LastUpdatedBy', Value => $args{'LastUpdatedBy'} );
753 for my $field ( keys %args ) {
754 #TODO check links and watchers
756 if ( $field =~ /CustomField-(\d+)/ ) {
758 my $got = join ',', sort map $_->Content,
759 @{ $ticket->CustomFieldValues($cf)->ItemsArrayRef };
760 my $expected = ref $args{$field}
761 ? join( ',', sort @{ $args{$field} } )
763 Test::More::is( $got, $expected, 'correct CF values' );
766 next if ref $args{$field};
767 next unless $ticket->can($field) or $ticket->_Accessible($field,"read");
768 next if ref $ticket->$field();
769 Test::More::is( $ticket->$field(), $args{$field}, "$field is correct" );
779 my $tickets = RT::Tickets->new( RT->SystemUser );
781 $tickets->FromSQL( $query );
786 while ( my $ticket = $tickets->Next ) {
791 =head2 load_or_create_custom_field
795 sub load_or_create_custom_field {
797 my %args = ( Disabled => 0, @_ );
798 my $obj = RT::CustomField->new( RT->SystemUser );
799 if ( $args{'Name'} ) {
800 $obj->LoadByName( Name => $args{'Name'}, Queue => $args{'Queue'} );
802 die "Name is required";
804 unless ( $obj->id ) {
805 my ($val, $msg) = $obj->Create( %args );
806 die "$msg" unless $val;
815 $current = $current ? RT::CurrentUser->new($current) : RT->SystemUser;
816 my $tickets = RT::Tickets->new( $current );
817 $tickets->OrderBy( FIELD => 'id', ORDER => 'DESC' );
818 $tickets->Limit( FIELD => 'id', OPERATOR => '>', VALUE => '0' );
819 $tickets->RowsPerPage( 1 );
820 return $tickets->First;
828 RT::ACE->new( RT->SystemUser );
829 my @fields = keys %{ RT::ACE->_ClassAccessible };
832 my $acl = RT::ACL->new( RT->SystemUser );
833 $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
836 while ( my $ace = $acl->Next ) {
837 my $obj = $ace->PrincipalObj->Object;
838 if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == RT->Nobody->id ) {
843 foreach my $field( @fields ) {
844 $tmp{ $field } = $ace->__Value( $field );
854 foreach my $entry ( @entries ) {
855 my $ace = RT::ACE->new( RT->SystemUser );
856 my ($status, $msg) = $ace->RT::Record::Create( %$entry );
858 Test::More::diag "couldn't create a record: $msg";
867 my $acl = RT::ACL->new( RT->SystemUser );
868 $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
869 while ( my $ace = $acl->Next ) {
870 my $obj = $ace->PrincipalObj->Object;
871 if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == RT->Nobody->id ) {
876 return $self->add_rights( @_ );
881 my @list = ref $_[0]? @_: @_? { @_ }: ();
884 foreach my $e (@list) {
885 my $principal = delete $e->{'Principal'};
886 unless ( ref $principal ) {
887 if ( $principal =~ /^(everyone|(?:un)?privileged)$/i ) {
888 $principal = RT::Group->new( RT->SystemUser );
889 $principal->LoadSystemInternalGroup($1);
890 } elsif ( $principal =~ /^(Owner|Requestor|(?:Admin)?Cc)$/i ) {
891 $principal = RT::Group->new( RT->SystemUser );
892 $principal->LoadByCols(
893 Domain => (ref($e->{'Object'})||'RT::System').'-Role',
895 ref($e->{'Object'})? (Instance => $e->{'Object'}->id): (),
898 die "principal is not an object, but also is not name of a system group";
901 unless ( $principal->isa('RT::Principal') ) {
902 if ( $principal->can('PrincipalObj') ) {
903 $principal = $principal->PrincipalObj;
906 my @rights = ref $e->{'Right'}? @{ $e->{'Right'} }: ($e->{'Right'});
907 foreach my $right ( @rights ) {
908 my ($status, $msg) = $principal->GrantRight( %$e, Right => $right );
909 $RT::Logger->debug($msg);
918 require RT::Test::Web;
920 url => RT::Test::Web->rt_base_url,
922 action => 'correspond',
925 command => $RT::BinPath .'/rt-mailgate',
928 my $message = delete $args{'message'};
930 $args{after_open} = sub {
931 my $child_in = shift;
932 if ( UNIVERSAL::isa($message, 'MIME::Entity') ) {
933 $message->print( $child_in );
935 print $child_in $message;
939 $self->run_and_capture(%args);
942 sub run_and_capture {
946 my $after_open = delete $args{after_open};
948 my $cmd = delete $args{'command'};
949 die "Couldn't find command ($cmd)" unless -f $cmd;
951 $cmd .= ' --debug' if delete $args{'debug'};
953 while( my ($k,$v) = each %args ) {
955 $cmd .= " --$k '$v'";
959 DBIx::SearchBuilder::Record::Cachable->FlushCache;
962 my ($child_out, $child_in);
963 my $pid = IPC::Open2::open2($child_out, $child_in, $cmd);
965 $after_open->($child_in, $child_out) if $after_open;
969 my $result = do { local $/; <$child_out> };
972 return ($?, $result);
975 sub send_via_mailgate_and_http {
980 my ($status, $gate_result) = $self->run_mailgate(
981 message => $message, %args
985 unless ( $status >> 8 ) {
986 ($id) = ($gate_result =~ /Ticket:\s*(\d+)/i);
988 Test::More::diag "Couldn't find ticket id in text:\n$gate_result"
989 if $ENV{'TEST_VERBOSE'};
992 Test::More::diag "Mailgate output:\n$gate_result"
993 if $ENV{'TEST_VERBOSE'};
995 return ($status, $id);
999 sub send_via_mailgate {
1001 my $message = shift;
1002 my %args = ( action => 'correspond',
1007 if ( UNIVERSAL::isa( $message, 'MIME::Entity' ) ) {
1008 $message = $message->as_string;
1011 my ( $status, $error_message, $ticket )
1012 = RT::Interface::Email::Gateway( {%args, message => $message} );
1013 return ( $status, $ticket ? $ticket->id : 0 );
1018 sub open_mailgate_ok {
1020 my $baseurl = shift;
1021 my $queue = shift || 'general';
1022 my $action = shift || 'correspond';
1023 Test::More::ok(open(my $mail, '|-', "$RT::BinPath/rt-mailgate --url $baseurl --queue $queue --action $action"), "Opened the mailgate - $!");
1028 sub close_mailgate_ok {
1032 Test::More::is ($? >> 8, 0, "The mail gateway exited normally. yay");
1037 my $expected = shift;
1039 my $mailsent = scalar grep /\S/, split /%% split me! %%\n/,
1040 RT::Test->file_content(
1047 $mailsent, $expected,
1048 "The number of mail sent ($expected) matches. yay"
1052 sub fetch_caught_mails {
1054 return grep /\S/, split /%% split me! %%\n/,
1055 RT::Test->file_content(
1062 sub clean_caught_mails {
1063 unlink $tmp{'mailbox'};
1066 =head2 get_relocatable_dir
1068 Takes a path relative to the location of the test file that is being
1069 run and returns a path that takes the invocation path into account.
1071 e.g. RT::Test::get_relocatable_dir(File::Spec->updir(), 'data', 'emails')
1075 sub get_relocatable_dir {
1076 (my $volume, my $directories, my $file) = File::Spec->splitpath($0);
1077 if (File::Spec->file_name_is_absolute($directories)) {
1078 return File::Spec->catdir($directories, @_);
1080 return File::Spec->catdir(File::Spec->curdir(), $directories, @_);
1084 =head2 get_relocatable_file
1086 Same as get_relocatable_dir, but takes a file and a path instead
1089 e.g. RT::Test::get_relocatable_file('test-email',
1090 (File::Spec->updir(), 'data', 'emails'))
1094 sub get_relocatable_file {
1096 return File::Spec->catfile(get_relocatable_dir(@_), $file);
1099 sub get_abs_relocatable_dir {
1100 (my $volume, my $directories, my $file) = File::Spec->splitpath($0);
1101 if (File::Spec->file_name_is_absolute($directories)) {
1102 return File::Spec->catdir($directories, @_);
1104 return File::Spec->catdir(Cwd->getcwd(), $directories, @_);
1111 DIR => $tmp{directory},
1116 sub import_gnupg_key {
1119 my $type = shift || 'secret';
1121 $key =~ s/\@/-at-/g;
1122 $key .= ".$type.key";
1124 require RT::Crypt::GnuPG;
1126 # simple strategy find data/gnupg/keys, from the dir where test file lives
1127 # to updirs, try 3 times in total
1128 my $path = File::Spec->catfile( 'data', 'gnupg', 'keys' );
1130 for my $up ( 0 .. 2 ) {
1131 my $p = get_relocatable_dir($path);
1137 $path = File::Spec->catfile( File::Spec->updir(), $path );
1141 die "can't find the dir where gnupg keys are stored"
1144 return RT::Crypt::GnuPG::ImportKey(
1145 RT::Test->file_content( [ $abs_path, $key ] ) );
1149 sub lsign_gnupg_key {
1153 require RT::Crypt::GnuPG; require GnuPG::Interface;
1154 my $gnupg = GnuPG::Interface->new();
1155 my %opt = RT->Config->Get('GnuPGOptions');
1156 $gnupg->options->hash_init(
1157 RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
1158 meta_interactive => 0,
1162 my $handles = GnuPG::Handles->new(
1163 stdin => ($handle{'input'} = IO::Handle->new()),
1164 stdout => ($handle{'output'} = IO::Handle->new()),
1165 stderr => ($handle{'error'} = IO::Handle->new()),
1166 logger => ($handle{'logger'} = IO::Handle->new()),
1167 status => ($handle{'status'} = IO::Handle->new()),
1168 command => ($handle{'command'} = IO::Handle->new()),
1172 local $SIG{'CHLD'} = 'DEFAULT';
1173 local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
1174 my $pid = $gnupg->wrap_call(
1175 handles => $handles,
1176 commands => ['--lsign-key'],
1177 command_args => [$key],
1179 close $handle{'input'};
1180 while ( my $str = readline $handle{'status'} ) {
1181 if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL sign_uid\..*/ ) {
1182 print { $handle{'command'} } "y\n";
1188 close $handle{'output'};
1191 $res{'exit_code'} = $?;
1192 foreach ( qw(error logger status) ) {
1193 $res{$_} = do { local $/; readline $handle{$_} };
1194 delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1197 $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1198 $RT::Logger->warning( $res{'error'} ) if $res{'error'};
1199 $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1200 if ( $err || $res{'exit_code'} ) {
1201 $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
1206 sub trust_gnupg_key {
1210 require RT::Crypt::GnuPG; require GnuPG::Interface;
1211 my $gnupg = GnuPG::Interface->new();
1212 my %opt = RT->Config->Get('GnuPGOptions');
1213 $gnupg->options->hash_init(
1214 RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
1215 meta_interactive => 0,
1219 my $handles = GnuPG::Handles->new(
1220 stdin => ($handle{'input'} = IO::Handle->new()),
1221 stdout => ($handle{'output'} = IO::Handle->new()),
1222 stderr => ($handle{'error'} = IO::Handle->new()),
1223 logger => ($handle{'logger'} = IO::Handle->new()),
1224 status => ($handle{'status'} = IO::Handle->new()),
1225 command => ($handle{'command'} = IO::Handle->new()),
1229 local $SIG{'CHLD'} = 'DEFAULT';
1230 local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
1231 my $pid = $gnupg->wrap_call(
1232 handles => $handles,
1233 commands => ['--edit-key'],
1234 command_args => [$key],
1236 close $handle{'input'};
1239 while ( my $str = readline $handle{'status'} ) {
1240 if ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE keyedit.prompt/ ) {
1242 print { $handle{'command'} } "quit\n";
1244 print { $handle{'command'} } "trust\n";
1246 } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE edit_ownertrust.value/ ) {
1247 print { $handle{'command'} } "5\n";
1248 } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_BOOL edit_ownertrust.set_ultimate.okay/ ) {
1249 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);
1277 require RT::Test::Web;
1279 if ($rttest_opt{nodb}) {
1280 die "you are trying to use a test web server without db, try use noinitialdata => 1 instead";
1284 $ENV{'RT_TEST_WEB_HANDLER'} = undef
1285 if $rttest_opt{actual_server} && ($ENV{'RT_TEST_WEB_HANDLER'}||'') eq 'inline';
1286 $ENV{'RT_TEST_WEB_HANDLER'} ||= 'plack';
1287 my $which = $ENV{'RT_TEST_WEB_HANDLER'};
1288 my ($server, $variant) = split /\+/, $which, 2;
1290 my $function = 'start_'. $server .'_server';
1291 unless ( $self->can($function) ) {
1292 die "Don't know how to start server '$server'";
1294 return $self->$function( variant => $variant, @_ );
1299 my %server_opt = @_;
1301 require RT::Interface::Web::Handler;
1302 my $app = RT::Interface::Web::Handler->PSGIApp;
1304 require Plack::Middleware::Test::StashWarnings;
1305 $app = Plack::Middleware::Test::StashWarnings->wrap($app);
1307 if ($server_opt{basic_auth}) {
1308 require Plack::Middleware::Auth::Basic;
1309 $app = Plack::Middleware::Auth::Basic->wrap(
1311 authenticator => sub {
1312 my ($username, $password) = @_;
1313 return $username eq 'root' && $password eq 'password';
1320 sub start_plack_server {
1323 require Plack::Loader;
1324 my $plack_server = Plack::Loader->load
1327 server_ready => sub {
1328 kill 'USR1' => getppid();
1331 # We are expecting a USR1 from the child process after it's ready
1332 # to listen. We set this up _before_ we fork to avoid race
1335 local $SIG{USR1} = sub { $handled = 1};
1339 die "failed to fork" unless defined $pid;
1342 sleep 15 unless $handled;
1343 Test::More::diag "did not get expected USR1 for test server readiness"
1345 push @SERVERS, $pid;
1346 my $Tester = Test::Builder->new;
1347 $Tester->ok(1, "started plack server ok");
1350 return ("http://localhost:$port", RT::Test::Web->new);
1354 if ( $^O !~ /MSWin32/ ) {
1356 or die "Can't start a new session: $!";
1359 # stick this in a scope so that when $app is garbage collected,
1360 # StashWarnings can complain about unhandled warnings
1362 $plack_server->run($self->test_app(@_));
1369 sub start_inline_server {
1372 require Test::WWW::Mechanize::PSGI;
1373 unshift @RT::Test::Web::ISA, 'Test::WWW::Mechanize::PSGI';
1375 # Clear out squished CSS and JS cache, since it's retained across
1376 # servers, since it's in-process
1377 RT::Interface::Web->ClearSquished;
1379 Test::More::ok(1, "psgi test server ok");
1380 $TEST_APP = $self->test_app(@_);
1381 return ("http://localhost:$port", RT::Test::Web->new);
1384 sub start_apache_server {
1386 my %server_opt = @_;
1387 $server_opt{variant} ||= 'mod_perl';
1388 $ENV{RT_TEST_WEB_HANDLER} = "apache+$server_opt{variant}";
1390 require RT::Test::Apache;
1391 my $pid = RT::Test::Apache->start_server(
1396 push @SERVERS, $pid;
1398 my $url = RT->Config->Get('WebURL');
1400 return ($url, RT::Test::Web->new);
1406 return unless @SERVERS;
1409 $sig = 'INT' if $ENV{'RT_TEST_WEB_HANDLER'} eq "plack";
1410 kill $sig, @SERVERS;
1411 foreach my $pid (@SERVERS) {
1412 if ($ENV{RT_TEST_WEB_HANDLER} =~ /^apache/) {
1413 sleep 1 while kill 0, $pid;
1422 sub temp_directory {
1423 return $tmp{'directory'};
1431 $path = File::Spec->catfile( @$path ) if ref $path eq 'ARRAY';
1433 Test::More::diag "reading content of '$path'" if $ENV{'TEST_VERBOSE'};
1435 open( my $fh, "<:raw", $path )
1437 warn "couldn't open file '$path': $!" unless $args{noexist};
1440 my $content = do { local $/; <$fh> };
1443 unlink $path if $args{'unlink'};
1448 sub find_executable {
1453 foreach my $dir ( split /:/, $ENV{'PATH'} ) {
1454 my $fpath = File::Spec->catpath(
1455 (File::Spec->splitpath( $dir, 'no file' ))[0..1], $name
1457 next unless -e $fpath && -r _ && -x _;
1464 return unless $ENV{RT_TEST_VERBOSE} || $ENV{TEST_VERBOSE};
1465 goto \&Test::More::diag;
1470 require RT::EmailParser;
1471 my $parser = RT::EmailParser->new;
1472 $parser->ParseMIMEEntityFromScalar( $mail );
1473 return $parser->Entity;
1477 Test::More::ok($_[0], $_[1] || 'This works');
1481 Test::More::ok(!$_[0], $_[1] || 'This should fail');
1485 my $Test = RT::Test->builder;
1486 return if $Test->{Original_Pid} != $$;
1489 # we are in END block and should protect our exit code
1490 # so calls below may call system or kill that clobbers $?
1493 RT::Test->stop_server(1);
1496 if ( !$Test->is_passing ) {
1497 $tmp{'directory'}->unlink_on_destroy(0);
1500 "Some tests failed or we bailed out, tmp directory"
1501 ." '$tmp{directory}' is not cleaned"
1505 if ( $ENV{RT_TEST_PARALLEL} && $created_new_db ) {
1509 # Drop our port from t/tmp/ports; do this after dropping the
1510 # database, as our port lock is also a lock on the database name.
1513 my $portfile = "$tmp{'directory'}/../ports";
1514 sysopen(PORTS, $portfile, O_RDWR|O_CREAT)
1515 or die "Can't write to ports file $portfile: $!";
1516 flock(PORTS, LOCK_EX)
1517 or die "Can't write-lock ports file $portfile: $!";
1518 $ports{$_}++ for split ' ', join("",<PORTS>);
1519 delete $ports{$port};
1522 print PORTS "$_\n" for sort {$a <=> $b} keys %ports;
1523 close(PORTS) or die "Can't close ports file: $!";
1528 # ease the used only once warning
1531 %{'RT::I18N::en_us::Lexicon'};
1532 %{'Win32::Locale::Lexicon'};