1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2011 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 }}}
54 use base 'Test::More';
57 use File::Temp qw(tempfile);
58 use File::Path qw(mkpath);
61 our $SKIP_REQUEST_WORK_AROUND = 0;
63 use HTTP::Request::Common ();
65 wrap 'HTTP::Request::Common::form_data',
67 return if $SKIP_REQUEST_WORK_AROUND;
70 $data->[0] = Encode::encode_utf8($data->[0]);
73 $_[-1] = Encode::encode_utf8($_[-1]);
78 our @EXPORT = qw(is_empty);
99 To run the rt test suite with coverage support, install L<Devel::Cover> and run:
101 make test RT_DBA_USER=.. RT_DBA_PASSWORD=.. HARNESS_PERL_SWITCHES=-MDevel::Cover
102 cover -ignore_re '^var/mason_data/' -ignore_re '^t/'
104 The coverage tests have DevelMode turned off, and have
105 C<named_component_subs> enabled for L<HTML::Mason> to avoid an optimizer
106 problem in Perl that hides the top-level optree from L<Devel::Cover>.
112 my $port = 1024 + int rand(10000) + $$ % 1024;
114 my $paddr = sockaddr_in( $port, inet_aton('localhost') );
115 socket( SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
117 if ( connect( SOCK, $paddr ) ) {
119 return generate_port();
127 $port = generate_port();
128 $dbname = $ENV{RT_TEST_PARALLEL}? "rt3test_$port" : "rt3test";
135 # Spit out a plan (if we got one) *before* we load modules
136 if ( $args{'tests'} ) {
137 $class->builder->plan( tests => $args{'tests'} )
138 unless $args{'tests'} eq 'no_declare';
141 $class->builder->no_plan unless $class->builder->has_plan;
144 $class->bootstrap_tempdir;
146 $class->bootstrap_config( %args );
151 if (RT->Config->Get('DevelMode')) { require Module::Refresh; }
153 $class->bootstrap_db( %args );
157 $class->bootstrap_plugins( %args );
159 $class->set_config_wrapper;
161 my $screen_logger = $RT::Logger->remove( 'screen' );
162 require Log::Dispatch::Perl;
163 $RT::Logger->add( Log::Dispatch::Perl->new
165 min_level => $screen_logger->min_level,
166 action => { error => 'warn',
167 critical => 'warn' } ) );
169 # XXX: this should really be totally isolated environment so we
170 # can parallelize and be sane
171 mkpath [ $RT::MasonSessionDir ]
172 if RT->Config->Get('DatabaseType');
175 while ( my ($package) = caller($level-1) ) {
176 last unless $package =~ /Test/;
180 Test::More->export_to_level($level);
181 __PACKAGE__->export_to_level($level);
186 local $Test::Builder::Level = $Test::Builder::Level + 1;
187 return Test::More::ok(1, $d) unless defined $v;
188 return Test::More::ok(1, $d) unless length $v;
189 return Test::More::is($v, '', $d);
192 my $created_new_db; # have we created new db? mainly for parallel testing
194 sub db_requires_no_dba {
196 my $db_type = RT->Config->Get('DatabaseType');
197 return 1 if $db_type eq 'SQLite';
200 sub bootstrap_tempdir {
203 File::Spec->rel2abs((caller)[1])
204 =~ m{(?:^|[\\/])t[/\\](.*)}
206 my $dir_name = File::Spec->rel2abs('t/tmp/'. $test_file);
208 return $tmp{'directory'} = File::Temp->newdir(
213 sub bootstrap_config {
217 $tmp{'config'}{'RT'} = File::Spec->catfile(
218 "$tmp{'directory'}", 'RT_SiteConfig.pm'
220 open my $config, '>', $tmp{'config'}{'RT'}
221 or die "Couldn't open $tmp{'config'}{'RT'}: $!";
224 Set( \$WebDomain, "localhost");
225 Set( \$WebPort, $port);
227 Set( \$RTAddressRegexp , qr/^bad_re_that_doesnt_match\$/);
229 if ( $ENV{'RT_TEST_DB_SID'} ) { # oracle case
230 print $config "Set( \$DatabaseName , '$ENV{'RT_TEST_DB_SID'}' );\n";
231 print $config "Set( \$DatabaseUser , '$dbname');\n";
233 print $config "Set( \$DatabaseName , '$dbname');\n";
234 print $config "Set( \$DatabaseUser , 'u${dbname}');\n";
236 print $config "Set( \$DevelMode, 0 );\n"
237 if $INC{'Devel/Cover.pm'};
239 $self->bootstrap_logging( $config );
242 my $mail_catcher = $tmp{'mailbox'} = File::Spec->catfile(
243 $tmp{'directory'}->dirname, 'mailbox.eml'
246 Set( \$MailCommand, sub {
249 open my \$handle, '>>', '$mail_catcher'
250 or die "Unable to open '$mail_catcher' for appending: \$!";
252 \$MIME->print(\$handle);
253 print \$handle "%% split me! %%\n";
258 print $config $args{'config'} if $args{'config'};
260 print $config "\n1;\n";
261 $ENV{'RT_SITE_CONFIG'} = $tmp{'config'}{'RT'};
267 sub bootstrap_logging {
271 # prepare file for logging
272 $tmp{'log'}{'RT'} = File::Spec->catfile(
273 "$tmp{'directory'}", 'rt.debug.log'
275 open my $fh, '>', $tmp{'log'}{'RT'}
276 or die "Couldn't open $tmp{'config'}{'RT'}: $!";
277 # make world writable so apache under different user
279 chmod 0666, $tmp{'log'}{'RT'};
282 Set( \$LogToSyslog , undef);
283 Set( \$LogToScreen , "warning");
284 Set( \$LogToFile, 'debug' );
285 Set( \$LogDir, q{$tmp{'directory'}} );
286 Set( \$LogToFileNamed, 'rt.debug.log' );
290 sub set_config_wrapper {
293 my $old_sub = \&RT::Config::Set;
294 no warnings 'redefine';
295 *RT::Config::Set = sub {
297 if ( ($caller[1]||'') =~ /\.t$/ ) {
298 my ($self, $name) = @_;
299 my $type = $RT::Config::META{$name}->{'Type'} || 'SCALAR';
305 my $sigil = $sigils{$type} || $sigils{'SCALAR'};
306 open my $fh, '>>', $tmp{'config'}{'RT'}
307 or die "Couldn't open config file: $!";
308 require Data::Dumper;
309 my $dump = Data::Dumper::Dumper([@_[2 .. $#_]]);
312 "\nSet(${sigil}${name}, \@{". $dump ."}); 1;\n";
316 warn "you're changing config option in a test file"
317 ." when server is active";
320 return $old_sub->(@_);
328 unless (defined $ENV{'RT_DBA_USER'} && defined $ENV{'RT_DBA_PASSWORD'}) {
329 Test::More::BAIL_OUT(
330 "RT_DBA_USER and RT_DBA_PASSWORD environment variables need"
331 ." to be set in order to run 'make test'"
332 ) unless $self->db_requires_no_dba;
336 # bootstrap with dba cred
337 my $dbh = _get_dbh(RT::Handle->SystemDSN,
338 $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD});
340 unless ( $ENV{RT_TEST_PARALLEL} ) {
341 # already dropped db in parallel tests, need to do so for other cases.
342 RT::Handle->DropDatabase( $dbh, Force => 1 );
345 RT::Handle->CreateDatabase( $dbh );
349 $dbh = _get_dbh(RT::Handle->DSN,
350 $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD});
352 $RT::Handle = new RT::Handle;
353 $RT::Handle->dbh( $dbh );
354 $RT::Handle->InsertSchema( $dbh );
356 my $db_type = RT->Config->Get('DatabaseType');
357 $RT::Handle->InsertACL( $dbh ) unless $db_type eq 'Oracle';
359 $RT::Handle = new RT::Handle;
360 $RT::Handle->dbh( undef );
361 RT->ConnectToDatabase;
363 RT->InitSystemObjects;
364 $RT::Handle->InsertInitialData;
366 DBIx::SearchBuilder::Record::Cachable->FlushCache;
367 $RT::Handle = new RT::Handle;
368 $RT::Handle->dbh( undef );
371 $RT::Handle->PrintError;
372 $RT::Handle->dbh->{PrintError} = 1;
374 unless ( $args{'nodata'} ) {
375 $RT::Handle->InsertData( $RT::EtcPath . "/initialdata" );
377 DBIx::SearchBuilder::Record::Cachable->FlushCache;
380 sub bootstrap_plugins {
384 return unless $args{'requires'};
386 my @plugins = @{ $args{'requires'} };
387 push @plugins, $args{'testing'}
392 if ( $args{'testing'} ) {
394 $cwd = Cwd::getcwd();
397 my $old_func = \&RT::Plugin::_BasePath;
398 no warnings 'redefine';
399 *RT::Plugin::_BasePath = sub {
400 my $name = $_[0]->{'name'};
402 return $cwd if $args{'testing'} && $name eq $args{'testing'};
404 if ( grep $name eq $_, @plugins ) {
405 my $variants = join "(?:|::|-|_)", map "\Q$_\E", split /::/, $name;
406 my ($path) = map $ENV{$_}, grep /^CHIMPS_(?:$variants).*_ROOT$/i, keys %ENV;
407 return $path if $path;
409 return $old_func->(@_);
412 RT->Config->Set( Plugins => @plugins );
418 $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD},
422 foreach my $name ( @plugins ) {
423 my $plugin = RT::Plugin->new( name => $name );
424 Test::More::diag( "Initializing DB for the $name plugin" )
425 if $ENV{'TEST_VERBOSE'};
427 my $etc_path = $plugin->Path('etc');
428 Test::More::diag( "etc path of the plugin is '$etc_path'" )
429 if $ENV{'TEST_VERBOSE'};
431 if ( -e $etc_path ) {
432 my ($ret, $msg) = $RT::Handle->InsertSchema( $dba_dbh, $etc_path );
433 Test::More::ok($ret || $msg =~ /^Couldn't find schema/, "Created schema: ".($msg||''));
435 ($ret, $msg) = $RT::Handle->InsertACL( $dba_dbh, $etc_path );
436 Test::More::ok($ret || $msg =~ /^Couldn't find ACLs/, "Created ACL: ".($msg||''));
438 my $data_file = File::Spec->catfile( $etc_path, 'initialdata' );
439 if ( -e $data_file ) {
440 ($ret, $msg) = $RT::Handle->InsertData( $data_file );;
441 Test::More::ok($ret, "Inserted data".($msg||''));
443 Test::More::ok(1, "There is no data file" );
447 # we can not say if plugin has no data or we screwed with etc path
448 Test::More::ok(1, "There is no etc dir: no schema" );
449 Test::More::ok(1, "There is no etc dir: no ACLs" );
450 Test::More::ok(1, "There is no etc dir: no data" );
453 $RT::Handle->Connect; # XXX: strange but mysql can loose connection
455 $dba_dbh->disconnect if $dba_dbh;
459 my ($dsn, $user, $pass) = @_;
460 if ( $dsn =~ /Oracle/i ) {
461 $ENV{'NLS_LANG'} = "AMERICAN_AMERICA.AL32UTF8";
462 $ENV{'NLS_NCHAR'} = "AL32UTF8";
464 my $dbh = DBI->connect(
466 { RaiseError => 0, PrintError => 1 },
469 my $msg = "Failed to connect to $dsn as user '$user': ". $DBI::errstr;
470 print STDERR $msg; exit -1;
477 =head2 load_or_create_user
481 sub load_or_create_user {
483 my %args = ( Privileged => 1, Disabled => 0, @_ );
485 my $MemberOf = delete $args{'MemberOf'};
486 $MemberOf = [ $MemberOf ] if defined $MemberOf && !ref $MemberOf;
489 my $obj = RT::User->new( $RT::SystemUser );
490 if ( $args{'Name'} ) {
491 $obj->LoadByCols( Name => $args{'Name'} );
492 } elsif ( $args{'EmailAddress'} ) {
493 $obj->LoadByCols( EmailAddress => $args{'EmailAddress'} );
495 die "Name or EmailAddress is required";
499 $obj->SetPrivileged( $args{'Privileged'} || 0 )
500 if ($args{'Privileged'}||0) != ($obj->Privileged||0);
501 $obj->SetDisabled( $args{'Disabled'} || 0 )
502 if ($args{'Disabled'}||0) != ($obj->Disabled||0);
504 my ($val, $msg) = $obj->Create( %args );
505 die "$msg" unless $val;
508 # clean group membership
510 require RT::GroupMembers;
511 my $gms = RT::GroupMembers->new( $RT::SystemUser );
512 my $groups_alias = $gms->Join(
513 FIELD1 => 'GroupId', TABLE2 => 'Groups', FIELD2 => 'id',
515 $gms->Limit( ALIAS => $groups_alias, FIELD => 'Domain', VALUE => 'UserDefined' );
516 $gms->Limit( FIELD => 'MemberId', VALUE => $obj->id );
517 while ( my $group_member_record = $gms->Next ) {
518 $group_member_record->Delete;
522 # add new user to groups
523 foreach ( @$MemberOf ) {
524 my $group = RT::Group->new( RT::SystemUser() );
525 $group->LoadUserDefinedGroup( $_ );
526 die "couldn't load group '$_'" unless $group->id;
527 $group->AddMember( $obj->id );
533 =head2 load_or_create_queue
537 sub load_or_create_queue {
539 my %args = ( Disabled => 0, @_ );
540 my $obj = RT::Queue->new( $RT::SystemUser );
541 if ( $args{'Name'} ) {
542 $obj->LoadByCols( Name => $args{'Name'} );
544 die "Name is required";
546 unless ( $obj->id ) {
547 my ($val, $msg) = $obj->Create( %args );
548 die "$msg" unless $val;
550 my @fields = qw(CorrespondAddress CommentAddress);
551 foreach my $field ( @fields ) {
552 next unless exists $args{ $field };
553 next if $args{ $field } eq $obj->$field;
555 no warnings 'uninitialized';
556 my $method = 'Set'. $field;
557 my ($val, $msg) = $obj->$method( $args{ $field } );
558 die "$msg" unless $val;
565 =head2 load_or_create_custom_field
569 sub load_or_create_custom_field {
571 my %args = ( Disabled => 0, @_ );
572 my $obj = RT::CustomField->new( $RT::SystemUser );
573 if ( $args{'Name'} ) {
574 $obj->LoadByName( Name => $args{'Name'}, Queue => $args{'Queue'} );
576 die "Name is required";
578 unless ( $obj->id ) {
579 my ($val, $msg) = $obj->Create( %args );
580 die "$msg" unless $val;
589 $current = $current ? RT::CurrentUser->new($current) : $RT::SystemUser;
590 my $tickets = RT::Tickets->new( $current );
591 $tickets->OrderBy( FIELD => 'id', ORDER => 'DESC' );
592 $tickets->Limit( FIELD => 'id', OPERATOR => '>', VALUE => '0' );
593 $tickets->RowsPerPage( 1 );
594 return $tickets->First;
602 RT::ACE->new( $RT::SystemUser );
603 my @fields = keys %{ RT::ACE->_ClassAccessible };
606 my $acl = RT::ACL->new( $RT::SystemUser );
607 $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
610 while ( my $ace = $acl->Next ) {
611 my $obj = $ace->PrincipalObj->Object;
612 if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == $RT::Nobody->id ) {
617 foreach my $field( @fields ) {
618 $tmp{ $field } = $ace->__Value( $field );
628 foreach my $entry ( @entries ) {
629 my $ace = RT::ACE->new( $RT::SystemUser );
630 my ($status, $msg) = $ace->RT::Record::Create( %$entry );
632 Test::More::diag "couldn't create a record: $msg";
641 my $acl = RT::ACL->new( $RT::SystemUser );
642 $acl->Limit( FIELD => 'RightName', OPERATOR => '!=', VALUE => 'SuperUser' );
643 while ( my $ace = $acl->Next ) {
644 my $obj = $ace->PrincipalObj->Object;
645 if ( $obj->isa('RT::Group') && $obj->Type eq 'UserEquiv' && $obj->Instance == $RT::Nobody->id ) {
650 return $self->add_rights( @_ );
655 my @list = ref $_[0]? @_: @_? { @_ }: ();
658 foreach my $e (@list) {
659 my $principal = delete $e->{'Principal'};
660 unless ( ref $principal ) {
661 if ( $principal =~ /^(everyone|(?:un)?privileged)$/i ) {
662 $principal = RT::Group->new( $RT::SystemUser );
663 $principal->LoadSystemInternalGroup($1);
664 } elsif ( $principal =~ /^(Owner|Requestor|(?:Admin)?Cc)$/i ) {
665 $principal = RT::Group->new( $RT::SystemUser );
666 $principal->LoadByCols(
667 Domain => (ref($e->{'Object'})||'RT::System').'-Role',
669 ref($e->{'Object'})? (Instance => $e->{'Object'}->id): (),
672 die "principal is not an object, but also is not name of a system group";
675 unless ( $principal->isa('RT::Principal') ) {
676 if ( $principal->can('PrincipalObj') ) {
677 $principal = $principal->PrincipalObj;
680 my @rights = ref $e->{'Right'}? @{ $e->{'Right'} }: ($e->{'Right'});
681 foreach my $right ( @rights ) {
682 my ($status, $msg) = $principal->GrantRight( %$e, Right => $right );
683 $RT::Logger->debug($msg);
692 require RT::Test::Web;
694 url => RT::Test::Web->rt_base_url,
696 action => 'correspond',
699 command => $RT::BinPath .'/rt-mailgate',
702 my $message = delete $args{'message'};
704 $args{after_open} = sub {
705 my $child_in = shift;
706 if ( UNIVERSAL::isa($message, 'MIME::Entity') ) {
707 $message->print( $child_in );
709 print $child_in $message;
713 $self->run_and_capture(%args);
716 sub run_and_capture {
720 my $after_open = delete $args{after_open};
722 my $cmd = delete $args{'command'};
723 die "Couldn't find command ($cmd)" unless -f $cmd;
725 $cmd .= ' --debug' if delete $args{'debug'};
727 while( my ($k,$v) = each %args ) {
729 $cmd .= " --$k '$v'";
733 DBIx::SearchBuilder::Record::Cachable->FlushCache;
736 my ($child_out, $child_in);
737 my $pid = IPC::Open2::open2($child_out, $child_in, $cmd);
739 $after_open->($child_in, $child_out) if $after_open;
743 my $result = do { local $/; <$child_out> };
746 return ($?, $result);
749 sub send_via_mailgate {
754 my ($status, $gate_result) = $self->run_mailgate(
755 message => $message, %args
759 unless ( $status >> 8 ) {
760 ($id) = ($gate_result =~ /Ticket:\s*(\d+)/i);
762 Test::More::diag "Couldn't find ticket id in text:\n$gate_result"
763 if $ENV{'TEST_VERBOSE'};
766 Test::More::diag "Mailgate output:\n$gate_result"
767 if $ENV{'TEST_VERBOSE'};
769 return ($status, $id);
772 sub open_mailgate_ok {
775 my $queue = shift || 'general';
776 my $action = shift || 'correspond';
777 Test::More::ok(open(my $mail, "|$RT::BinPath/rt-mailgate --url $baseurl --queue $queue --action $action"), "Opened the mailgate - $!");
782 sub close_mailgate_ok {
786 Test::More::is ($? >> 8, 0, "The mail gateway exited normally. yay");
791 my $expected = shift;
793 my $mailsent = scalar grep /\S/, split /%% split me! %%\n/,
794 RT::Test->file_content(
801 $mailsent, $expected,
802 "The number of mail sent ($expected) matches. yay"
806 sub set_mail_catcher {
811 sub fetch_caught_mails {
813 return grep /\S/, split /%% split me! %%\n/,
814 RT::Test->file_content(
821 sub clean_caught_mails {
822 unlink $tmp{'mailbox'};
825 =head2 get_relocatable_dir
827 Takes a path relative to the location of the test file that is being
828 run and returns a path that takes the invocation path into account.
830 e.g. RT::Test::get_relocatable_dir(File::Spec->updir(), 'data', 'emails')
834 sub get_relocatable_dir {
835 (my $volume, my $directories, my $file) = File::Spec->splitpath($0);
836 if (File::Spec->file_name_is_absolute($directories)) {
837 return File::Spec->catdir($directories, @_);
839 return File::Spec->catdir(File::Spec->curdir(), $directories, @_);
843 =head2 get_relocatable_file
845 Same as get_relocatable_dir, but takes a file and a path instead
848 e.g. RT::Test::get_relocatable_file('test-email',
849 (File::Spec->updir(), 'data', 'emails'))
853 sub get_relocatable_file {
855 return File::Spec->catfile(get_relocatable_dir(@_), $file);
858 sub get_abs_relocatable_dir {
859 (my $volume, my $directories, my $file) = File::Spec->splitpath($0);
860 if (File::Spec->file_name_is_absolute($directories)) {
861 return File::Spec->catdir($directories, @_);
863 return File::Spec->catdir(Cwd->getcwd(), $directories, @_);
867 sub import_gnupg_key {
870 my $type = shift || 'secret';
873 $key .= ".$type.key";
875 require RT::Crypt::GnuPG;
877 # simple strategy find data/gnupg/keys, from the dir where test file lives
878 # to updirs, try 3 times in total
879 my $path = File::Spec->catfile( 'data', 'gnupg', 'keys' );
881 for my $up ( 0 .. 2 ) {
882 my $p = get_relocatable_dir($path);
888 $path = File::Spec->catfile( File::Spec->updir(), $path );
892 die "can't find the dir where gnupg keys are stored"
895 return RT::Crypt::GnuPG::ImportKey(
896 RT::Test->file_content( [ $abs_path, $key ] ) );
900 sub lsign_gnupg_key {
904 require RT::Crypt::GnuPG; require GnuPG::Interface;
905 my $gnupg = new GnuPG::Interface;
906 my %opt = RT->Config->Get('GnuPGOptions');
907 $gnupg->options->hash_init(
908 RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
909 meta_interactive => 0,
913 my $handles = GnuPG::Handles->new(
914 stdin => ($handle{'input'} = new IO::Handle),
915 stdout => ($handle{'output'} = new IO::Handle),
916 stderr => ($handle{'error'} = new IO::Handle),
917 logger => ($handle{'logger'} = new IO::Handle),
918 status => ($handle{'status'} = new IO::Handle),
919 command => ($handle{'command'} = new IO::Handle),
923 local $SIG{'CHLD'} = 'DEFAULT';
924 local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
925 my $pid = $gnupg->wrap_call(
927 commands => ['--lsign-key'],
928 command_args => [$key],
930 close $handle{'input'};
931 while ( my $str = readline $handle{'status'} ) {
932 if ( $str =~ /^\[GNUPG:\]\s*GET_BOOL sign_uid\..*/ ) {
933 print { $handle{'command'} } "y\n";
939 close $handle{'output'};
942 $res{'exit_code'} = $?;
943 foreach ( qw(error logger status) ) {
944 $res{$_} = do { local $/; readline $handle{$_} };
945 delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
948 $RT::Logger->debug( $res{'status'} ) if $res{'status'};
949 $RT::Logger->warning( $res{'error'} ) if $res{'error'};
950 $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
951 if ( $err || $res{'exit_code'} ) {
952 $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
957 sub trust_gnupg_key {
961 require RT::Crypt::GnuPG; require GnuPG::Interface;
962 my $gnupg = new GnuPG::Interface;
963 my %opt = RT->Config->Get('GnuPGOptions');
964 $gnupg->options->hash_init(
965 RT::Crypt::GnuPG::_PrepareGnuPGOptions( %opt ),
966 meta_interactive => 0,
970 my $handles = GnuPG::Handles->new(
971 stdin => ($handle{'input'} = new IO::Handle),
972 stdout => ($handle{'output'} = new IO::Handle),
973 stderr => ($handle{'error'} = new IO::Handle),
974 logger => ($handle{'logger'} = new IO::Handle),
975 status => ($handle{'status'} = new IO::Handle),
976 command => ($handle{'command'} = new IO::Handle),
980 local $SIG{'CHLD'} = 'DEFAULT';
981 local @ENV{'LANG', 'LC_ALL'} = ('C', 'C');
982 my $pid = $gnupg->wrap_call(
984 commands => ['--edit-key'],
985 command_args => [$key],
987 close $handle{'input'};
990 while ( my $str = readline $handle{'status'} ) {
991 if ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE keyedit.prompt/ ) {
993 print { $handle{'command'} } "quit\n";
995 print { $handle{'command'} } "trust\n";
997 } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_LINE edit_ownertrust.value/ ) {
998 print { $handle{'command'} } "5\n";
999 } elsif ( $str =~ /^\[GNUPG:\]\s*\QGET_BOOL edit_ownertrust.set_ultimate.okay/ ) {
1000 print { $handle{'command'} } "y\n";
1007 close $handle{'output'};
1010 $res{'exit_code'} = $?;
1011 foreach ( qw(error logger status) ) {
1012 $res{$_} = do { local $/; readline $handle{$_} };
1013 delete $res{$_} unless $res{$_} && $res{$_} =~ /\S/s;
1016 $RT::Logger->debug( $res{'status'} ) if $res{'status'};
1017 $RT::Logger->warning( $res{'error'} ) if $res{'error'};
1018 $RT::Logger->error( $res{'logger'} ) if $res{'logger'} && $?;
1019 if ( $err || $res{'exit_code'} ) {
1020 $res{'message'} = $err? $err : "gpg exitted with error code ". ($res{'exit_code'} >> 8);
1028 require RT::Test::Web;
1030 my $which = $ENV{'RT_TEST_WEB_HANDLER'} || 'standalone';
1031 my ($server, $variant) = split /\+/, $which, 2;
1033 my $function = 'start_'. $server .'_server';
1034 unless ( $self->can($function) ) {
1035 die "Don't know how to start server '$server'";
1037 return $self->$function( $variant, @_ );
1040 sub start_standalone_server {
1044 require RT::Interface::Web::Standalone;
1046 require Test::HTTP::Server::Simple::StashWarnings;
1047 unshift @RT::Interface::Web::Standalone::ISA,
1048 'Test::HTTP::Server::Simple::StashWarnings';
1049 *RT::Interface::Web::Standalone::test_warning_path = sub {
1053 my $s = RT::Interface::Web::Standalone->new($port);
1055 my $ret = $s->started_ok;
1056 push @SERVERS, $s->pids;
1058 $RT::Handle = new RT::Handle;
1059 $RT::Handle->dbh( undef );
1060 RT->ConnectToDatabase;
1062 # the attribute cache holds on to a stale dbh
1063 delete $RT::System->{attributes};
1065 return ($ret, RT::Test::Web->new);
1068 sub start_apache_server {
1070 my $variant = shift || 'mod_perl';
1072 my %info = $self->apache_server_info( variant => $variant );
1074 Test::More::diag(do {
1075 open my $fh, '<', $tmp{'config'}{'RT'};
1080 my $tmpl = File::Spec->rel2abs( File::Spec->catfile(
1081 't', 'data', 'configs',
1082 'apache'. $info{'version'} .'+'. $variant .'.conf'
1086 server_root => $info{'HTTPD_ROOT'} || $ENV{'HTTPD_ROOT'}
1087 || Test::More::BAIL_OUT("Couldn't figure out server root"),
1088 document_root => $RT::MasonComponentRoot,
1089 tmp_dir => "$tmp{'directory'}",
1090 rt_bin_path => $RT::BinPath,
1091 rt_site_config => $ENV{'RT_SITE_CONFIG'},
1093 foreach (qw(log pid lock)) {
1094 $opt{$_ .'_file'} = File::Spec->catfile(
1095 "$tmp{'directory'}", "apache.$_"
1099 my $method = 'apache_'.$variant.'_server_options';
1100 $self->$method( \%info, \%opt );
1102 $tmp{'config'}{'apache'} = File::Spec->catfile(
1103 "$tmp{'directory'}", "apache.conf"
1105 $self->process_in_file(
1107 out => $tmp{'config'}{'apache'},
1111 $self->fork_exec($info{'executable'}, '-f', $tmp{'config'}{'apache'});
1114 while ( !-e $opt{'pid_file'} ) {
1119 Test::More::BAIL_OUT("Couldn't start apache server, no pid file")
1120 unless -e $opt{'pid_file'};
1121 open my $pid_fh, '<', $opt{'pid_file'}
1122 or Test::More::BAIL_OUT("Couldn't open pid file: $!");
1123 my $pid = <$pid_fh>;
1128 Test::More::ok($pid, "Started apache server #$pid");
1130 push @SERVERS, $pid;
1132 return (RT->Config->Get('WebURL'), RT::Test::Web->new);
1135 sub apache_server_info {
1139 my $bin = $res{'executable'} = $ENV{'RT_TEST_APACHE'}
1140 || $self->find_apache_server
1141 || Test::More::BAIL_OUT("Couldn't find apache server, use RT_TEST_APACHE");
1143 Test::More::diag("Using '$bin' apache executable for testing")
1144 if $ENV{'TEST_VERBOSE'};
1146 my $info = `$bin -V`;
1147 ($res{'version'}) = ($info =~ m{Server\s+version:\s+Apache/(\d+\.\d+)\.});
1148 Test::More::BAIL_OUT(
1149 "Couldn't figure out version of the server"
1150 ) unless $res{'version'};
1152 my %opts = ($info =~ m/^\s*-D\s+([A-Z_]+?)(?:="(.*)")$/mg);
1153 %res = (%res, %opts);
1156 map {s/^\s+//; s/\s+$//; $_}
1157 grep $_ !~ /Compiled in modules/i,
1158 split /\r*\n/, `$bin -l`
1164 sub apache_mod_perl_server_options {
1166 my %info = %{ shift() };
1167 my $current = shift;
1169 my %required_modules = (
1170 '2.2' => [qw(authz_host log_config env alias perl)],
1172 my @mlist = @{ $required_modules{ $info{'version'} } };
1174 $current->{'load_modules'} = '';
1175 foreach my $mod ( @mlist ) {
1176 next if grep $_ =~ /^(mod_|)$mod\.c$/, @{ $info{'modules'} };
1178 $current->{'load_modules'} .=
1179 "LoadModule ${mod}_module modules/mod_${mod}.so\n";
1184 sub apache_fastcgi_server_options {
1186 my %info = %{ shift() };
1187 my $current = shift;
1189 my %required_modules = (
1190 '2.2' => [qw(authz_host log_config env alias mime fastcgi)],
1192 my @mlist = @{ $required_modules{ $info{'version'} } };
1194 $current->{'load_modules'} = '';
1195 foreach my $mod ( @mlist ) {
1196 next if grep $_ =~ /^(mod_|)$mod\.c$/, @{ $info{'modules'} };
1198 $current->{'load_modules'} .=
1199 "LoadModule ${mod}_module modules/mod_${mod}.so\n";
1204 sub find_apache_server {
1206 return $_ foreach grep defined,
1207 map $self->find_executable($_),
1208 qw(httpd apache apache2 apache1);
1216 $sig = 'INT' if !$ENV{'RT_TEST_WEB_HANDLER'}
1217 || $ENV{'RT_TEST_WEB_HANDLER'} =~/^standalone(?:\+|\z)/;
1218 kill $sig, @SERVERS;
1219 foreach my $pid (@SERVERS) {
1229 $path = File::Spec->catfile( @$path ) if ref $path eq 'ARRAY';
1231 Test::More::diag "reading content of '$path'" if $ENV{'TEST_VERBOSE'};
1233 open my $fh, "<:raw", $path
1235 warn "couldn't open file '$path': $!" unless $args{noexist};
1238 my $content = do { local $/; <$fh> };
1241 unlink $path if $args{'unlink'};
1246 sub find_executable {
1251 foreach my $dir ( split /:/, $ENV{'PATH'} ) {
1252 my $fpath = File::Spec->catpath(
1253 (File::Spec->splitpath( $dir, 'no file' ))[0..1], $name
1255 next unless -e $fpath && -r _ && -x _;
1265 unless ( defined $pid ) {
1266 die "cannot fork: $!";
1269 die "can't exec `". join(' ', @_) ."` program: $!";
1275 sub process_in_file {
1277 my %args = ( in => undef, options => undef, @_ );
1279 my $text = $self->file_content( $args{'in'} );
1280 while ( my ($opt) = ($text =~ /\%\%(.+?)\%\%/) ) {
1281 my $value = $args{'options'}{ lc $opt };
1282 die "no value for $opt" unless defined $value;
1284 $text =~ s/\%\%\Q$opt\E\%\%/$value/g;
1287 my ($out_fh, $out_conf);
1288 unless ( $args{'out'} ) {
1289 ($out_fh, $out_conf) = tempfile();
1291 $out_conf = $args{'out'};
1292 open $out_fh, '>', $out_conf
1293 or die "couldn't open '$out_conf': $!";
1295 print $out_fh $text;
1298 return ($out_fh, $out_conf);
1302 my $Test = RT::Test->builder;
1303 return if $Test->{Original_Pid} != $$;
1306 # we are in END block and should protect our exit code
1307 # so calls below may call system or kill that clobbers $?
1310 RT::Test->stop_server;
1313 if ( !$Test->summary || grep !$_, $Test->summary ) {
1314 $tmp{'directory'}->unlink_on_destroy(0);
1317 "Some tests failed or we bailed out, tmp directory"
1318 ." '$tmp{directory}' is not cleaned"
1322 if ( $ENV{RT_TEST_PARALLEL} && $created_new_db ) {
1324 # Pg doesn't like if you issue a DROP DATABASE while still connected
1325 my $dbh = $RT::Handle->dbh;
1326 $dbh->disconnect if $dbh;
1328 $dbh = _get_dbh( RT::Handle->SystemDSN, $ENV{RT_DBA_USER}, $ENV{RT_DBA_PASSWORD} );
1329 RT::Handle->DropDatabase( $dbh, Force => 1 );