X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=rt%2Flib%2FRT%2FTest.pm;h=55fd88af9ec8f241317cf6e57e9463df333792ab;hb=7588a4ac90a9b07c08a3107cd1107d773be1c991;hp=3e7c910ecaa83eaf3a2b03986dd822d5ed879263;hpb=98d2b25256055abb0dfcb9f586b434474fa97afd;p=freeside.git

diff --git a/rt/lib/RT/Test.pm b/rt/lib/RT/Test.pm
index 3e7c910ec..55fd88af9 100644
--- a/rt/lib/RT/Test.pm
+++ b/rt/lib/RT/Test.pm
@@ -2,7 +2,7 @@
 #
 # COPYRIGHT:
 #
-# This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC
+# This software is Copyright (c) 1996-2013 Best Practical Solutions, LLC
 #                                          <sales@bestpractical.com>
 #
 # (Except where explicitly superseded by other copyright notices)
@@ -54,12 +54,20 @@ use warnings;
 
 use base 'Test::More';
 
+# We use the Test::NoWarnings catching and reporting functionality, but need to
+# wrap it in our own special handler because of the warn handler installed via
+# RT->InitLogging().
+require Test::NoWarnings;
+
+my $Test_NoWarnings_Catcher = $SIG{__WARN__};
+my $check_warnings_in_end   = 1;
+
 use Socket;
 use File::Temp qw(tempfile);
 use File::Path qw(mkpath);
 use File::Spec;
 
-our @EXPORT = qw(is_empty diag parse_mail works fails);
+our @EXPORT = qw(is_empty diag parse_mail works fails plan done_testing);
 
 my %tmp = (
     directory => undef,
@@ -94,20 +102,27 @@ problem in Perl that hides the top-level optree from L<Devel::Cover>.
 our $port;
 our @SERVERS;
 
+BEGIN {
+    delete $ENV{$_} for qw/LANGUAGE LC_ALL LC_MESSAGES LANG/;
+    $ENV{LANG} = "C";
+};
+
 sub import {
     my $class = shift;
     my %args = %rttest_opt = @_;
 
+    $rttest_opt{'nodb'} = $args{'nodb'} = 1 if $^C;
+
     # Spit out a plan (if we got one) *before* we load modules
     if ( $args{'tests'} ) {
-        $class->builder->plan( tests => $args{'tests'} )
+        plan( tests => $args{'tests'} )
           unless $args{'tests'} eq 'no_declare';
     }
     elsif ( exists $args{'tests'} ) {
         # do nothing if they say "tests => undef" - let them make the plan
     }
     elsif ( $args{'skip_all'} ) {
-        $class->builder->plan(skip_all => $args{'skip_all'});
+        plan(skip_all => $args{'skip_all'});
     }
     else {
         $class->builder->no_plan unless $class->builder->has_plan;
@@ -139,7 +154,7 @@ sub import {
     __reconnect_rt()
         unless $args{nodb};
 
-    RT::InitLogging();
+    __init_logging();
 
     RT->Plugins;
 
@@ -168,12 +183,15 @@ sub import {
     }
 
     Test::More->export_to_level($level);
+    Test::NoWarnings->export_to_level($level);
 
-    # blow away their diag so we can redefine it without warning
+    # Blow away symbols we redefine to avoid warnings.
     # better than "no warnings 'redefine'" because we might accidentally
     # suppress a mistaken redefinition
     no strict 'refs';
     delete ${ caller($level) . '::' }{diag};
+    delete ${ caller($level) . '::' }{plan};
+    delete ${ caller($level) . '::' }{done_testing};
     __PACKAGE__->export_to_level($level);
 }
 
@@ -280,9 +298,15 @@ Set( \$RTAddressRegexp , qr/^bad_re_that_doesnt_match\$/i);
         print $config "Set( \$DatabaseName , '$dbname');\n";
         print $config "Set( \$DatabaseUser , 'u${dbname}');\n";
     }
+    if ( $ENV{'RT_TEST_DB_HOST'} ) {
+        print $config "Set( \$DatabaseHost , '$ENV{'RT_TEST_DB_HOST'}');\n";
+    }
 
     if ( $args{'plugins'} ) {
         print $config "Set( \@Plugins, qw(". join( ' ', @{ $args{'plugins'} } ) .") );\n";
+
+        my $plugin_data = File::Spec->rel2abs("t/data/plugins");
+        print $config qq[\$RT::PluginPath = "$plugin_data";\n];
     }
 
     if ( $INC{'Devel/Cover.pm'} ) {
@@ -421,7 +445,7 @@ sub bootstrap_db {
     $RT::Handle->InsertSchema;
     $RT::Handle->InsertACL unless $db_type eq 'Oracle';
 
-    RT->InitLogging;
+    __init_logging();
     __reconnect_rt();
 
     $RT::Handle->InsertInitialData
@@ -603,6 +627,28 @@ sub __disconnect_rt {
           if DBIx::SearchBuilder::Record::Cachable->can("FlushCache");
 }
 
+sub __init_logging {
+    my $filter;
+    {
+        # We use local to ensure that the $filter we grab is from InitLogging
+        # and not the handler generated by a previous call to this function
+        # itself.
+        local $SIG{__WARN__};
+        RT::InitLogging();
+        $filter = $SIG{__WARN__};
+    }
+    $SIG{__WARN__} = sub {
+        if ($filter) {
+            my $status = $filter->(@_);
+            if ($status and $status eq 'IGNORE') {
+                return; # pretend the bad dream never happened
+            }
+        }
+        # Avoid reporting this anonymous call frame as the source of the warning.
+        goto &$Test_NoWarnings_Catcher;
+    };
+}
+
 
 =head1 UTILITIES
 
@@ -1079,17 +1125,28 @@ sub clean_caught_mails {
 Takes a path relative to the location of the test file that is being
 run and returns a path that takes the invocation path into account.
 
-e.g. RT::Test::get_relocatable_dir(File::Spec->updir(), 'data', 'emails')
+e.g. C<RT::Test::get_relocatable_dir(File::Spec->updir(), 'data', 'emails')>
+
+Parent directory traversals (C<..> or File::Spec->updir()) are naively
+canonicalized based on the test file path (C<$0>) so that symlinks aren't
+followed.  This is the exact opposite behaviour of most filesystems and is
+considered "wrong", however it is necessary for some subsets of tests which are
+symlinked into the testing tree.
 
 =cut
 
 sub get_relocatable_dir {
-    (my $volume, my $directories, my $file) = File::Spec->splitpath($0);
-    if (File::Spec->file_name_is_absolute($directories)) {
-        return File::Spec->catdir($directories, @_);
-    } else {
-        return File::Spec->catdir(File::Spec->curdir(), $directories, @_);
+    my @directories = File::Spec->splitdir(
+        File::Spec->rel2abs((File::Spec->splitpath($0))[1])
+    );
+    push @directories, File::Spec->splitdir($_) for @_;
+
+    my @clean;
+    for (@directories) {
+        if    ($_ eq "..") { pop @clean      }
+        elsif ($_ ne ".")  { push @clean, $_ }
     }
+    return File::Spec->catdir(@clean);
 }
 
 =head2 get_relocatable_file
@@ -1413,6 +1470,8 @@ sub start_inline_server {
     # Clear out squished CSS and JS cache, since it's retained across
     # servers, since it's in-process
     RT::Interface::Web->ClearSquished;
+    require RT::Interface::Web::Request;
+    RT::Interface::Web::Request->clear_callback_cache;
 
     Test::More::ok(1, "psgi test server ok");
     $TEST_APP = $self->test_app(@_);
@@ -1519,15 +1578,38 @@ sub fails {
     Test::More::ok(!$_[0], $_[1] || 'This should fail');
 }
 
+sub plan {
+    my ($cmd, @args) = @_;
+    my $builder = RT::Test->builder;
+
+    if ($cmd eq "skip_all") {
+        $check_warnings_in_end = 0;
+    } elsif ($cmd eq "tests") {
+        # Increment the test count for the warnings check
+        $args[0]++;
+    }
+    $builder->plan($cmd, @args);
+}
+
+sub done_testing {
+    my $builder = RT::Test->builder;
+
+    Test::NoWarnings::had_no_warnings();
+    $check_warnings_in_end = 0;
+
+    $builder->done_testing(@_);
+}
+
 END {
     my $Test = RT::Test->builder;
     return if $Test->{Original_Pid} != $$;
 
-
     # we are in END block and should protect our exit code
     # so calls below may call system or kill that clobbers $?
     local $?;
 
+    Test::NoWarnings::had_no_warnings() if $check_warnings_in_end;
+
     RT::Test->stop_server(1);
 
     # not success