Add context information to fatal errors.

If a test script does something like:

  my $doing = $self->doing( 'compiling Qt' );
  $self->configure( );
  $self->make( );
  $self->make_install( );

, and a fatal error occurs somewhere in there, parse_build_log.pl can
now produce a nice summary for gerrit:

  Compiling Qt failed :(

    (details here ...)

Change-Id: I91517517c7f5af3a0ce313a485bfde91aa15b3cc
Reviewed-by: Toby Tomkins <toby.tomkins@nokia.com>
Reviewed-by: Kalle Lehtonen <kalle.ju.lehtonen@nokia.com>

6 files changed, 201 insertions, 5 deletions

diff --git a/scripts/generic/parse_build_log.pl b/scripts/generic/parse_build_log.pl
index 92293c4..f1582ba 100755
--- a/scripts/generic/parse_build_log.pl
+++ b/scripts/generic/parse_build_log.pl
@@ -121,7 +121,7 @@ use Getopt::Long qw(GetOptionsFromArray);
 use IO::Uncompress::AnyInflate qw(anyinflate);
 use Lingua::EN::Inflect qw(inflect PL WORDLIST);
 use Lingua::EN::Numbers qw(num2en);
-use List::MoreUtils qw(any);
+use List::MoreUtils qw(any apply);
 use Pod::Usage;
 use Readonly;
 use Text::Wrap;
@@ -2334,6 +2334,35 @@ sub output_summary
                   ."be worthwhile to attempt the build again.";
     }
 
+    # YAML failure from a test script?
+    if ($fail->{ yaml_fail }) {
+
+        # If the test failure has some context (a 'while' stack),
+        # use the top thing from the stack as the human-readable description of
+        # what we were doing when we failed.
+        my @failed_while = map
+            { $_->{ 'while' }
+                ? $_->{ 'while' }[0]
+                : ()
+            } @{ $fail->{ yaml_fail } };
+
+        # capitalize first letter:
+        #
+        #   setting up git repository -> Setting up git repository
+        #
+        @failed_while = apply { $_ =~ s{^([a-z])}{\u$1} } @failed_while;
+
+        # append "failed :("
+        #
+        #   Setting up git repository -> Setting up git repository failed :(
+        #
+        @failed_while = apply { $_ .= " failed :(" } @failed_while;
+
+        if (@failed_while) {
+            $summary = join( qq{\n\n}, @failed_while );
+        }
+    }
+
     # Badly understood glitchy behavior?
     if ($fail->{ glitch }) {
         $summary = "An unexpected error occurred, most likely due to no fault in the tested "
diff --git a/scripts/generic/t/data/parsed-logs/qtjsondb-sync-profile-syntax-error.txt b/scripts/generic/t/data/parsed-logs/qtjsondb-sync-profile-syntax-error.txt
index 7f8b274..40fd2b4 100644
--- a/scripts/generic/t/data/parsed-logs/qtjsondb-sync-profile-syntax-error.txt
+++ b/scripts/generic/t/data/parsed-logs/qtjsondb-sync-profile-syntax-error.txt
@@ -1,4 +1,6 @@
 [ '--summarize', "$DATADIR/raw-logs/qtjsondb-sync-profile-syntax-error.txt" ]
+Reading dependencies from qtjsondb/sync.profile failed :(
+
   I couldn't parse /build/recipes/179081964/base/sync.profile, which I need to determine dependencies.
   The error was syntax error at /build/recipes/179081964/base/sync.profile line 36, near ""libedit""
 
diff --git a/scripts/generic/t/data/raw-logs/qtjsondb-sync-profile-syntax-error.txt b/scripts/generic/t/data/raw-logs/qtjsondb-sync-profile-syntax-error.txt
index a5f3806..9a8a8ac 100644
--- a/scripts/generic/t/data/raw-logs/qtjsondb-sync-profile-syntax-error.txt
+++ b/scripts/generic/t/data/raw-logs/qtjsondb-sync-profile-syntax-error.txt
@@ -149,6 +149,10 @@
 4/12/12 5:33:32 AM EST:   I couldn't parse /build/recipes/179081964/base/sync.profile, which I need to determine dependencies.
 4/12/12 5:33:32 AM EST:   The error was syntax error at /build/recipes/179081964/base/sync.profile line 36, near ""libedit""
 4/12/12 5:33:32 AM EST: 
+4/12/12 5:33:32 AM EST: while:
+4/12/12 5:33:32 AM EST:   - reading dependencies from qtjsondb/sync.profile
+4/12/12 5:33:32 AM EST:   - setting up git repositories
+4/12/12 5:33:32 AM EST:   - testing qtjsondb
 4/12/12 5:33:32 AM EST: ...
 4/12/12 5:33:32 AM EST:  at _qtqa_latest/scripts/qt/qtmod_test.pl line 444
 4/12/12 5:33:32 AM EST:         QtQA::ModuleTest::read_dependencies('QtQA::ModuleTest=HASH(0x9daa310)', '/home/rmcgover/build/qt/qt5/qtsvg/sync.profile') called at ../qtqa/scripts/qt/qtmod_test.pl line 513
diff --git a/scripts/lib/perl5/QtQA/TestScript.pm b/scripts/lib/perl5/QtQA/TestScript.pm
index 0641635..c63c78e 100644
--- a/scripts/lib/perl5/QtQA/TestScript.pm
+++ b/scripts/lib/perl5/QtQA/TestScript.pm
@@ -57,6 +57,7 @@ use List::MoreUtils qw(zip);
 use Params::Validate qw(validate);
 use Pod::Simple::Text;
 use Pod::Usage qw(pod2usage);
+use ReleaseAction qw(on_release);
 use YAML qw();
 use YAML::Node;
 
@@ -96,8 +97,6 @@ sub _croak
 
     local %Carp::Internal = $self->_carp_internal( );
     croak @rest;
-
-    return;
 }
 
 
@@ -441,8 +440,12 @@ sub fatal_error
     my $ynode = YAML::Node->new({}, 'qtqa.qt-project.org/error' );
     %{$ynode} = (
         error => $error,
-        ### what else should go here?
     );
+    my @context = @{ $self->{ _context } || [] };
+
+    if (@context) {
+        $ynode->{'while'} = [reverse @context];
+    }
 
     local $YAML::UseBlock = 1;
     my $formatted = YAML::Dump( $ynode );
@@ -453,6 +456,40 @@ sub fatal_error
 }
 
 
+sub doing
+{
+    my ($self, $thing) = @_;
+
+    if (! defined wantarray) {
+        $self->_warn( 'useless call to doing( ) in void context' );
+        return;
+    }
+
+    $self->_push_context( $thing );
+    return on_release { $self->_pop_context( $thing ) };
+}
+
+sub _push_context
+{
+    my ($self, $thing) = @_;
+
+    push @{ $self->{ _context } }, $thing;
+
+    return;
+}
+
+sub _pop_context
+{
+    my ($self, $thing) = @_;
+
+    my $actual_thing = pop @{ $self->{ _context } || [] };
+    if ($actual_thing ne $thing) {
+        $self->_warn( "scope mismatch: leaving context '$actual_thing', expecting to leave '$thing'" );
+    }
+
+    return;
+}
+
 sub print_when_verbose
 {
     my ($self, $verbosity, @print_list) = @_;
@@ -638,6 +675,8 @@ sub _croak_from_missing_property
     }
 
     $self->_croak( $message );
+
+    return;
 }
 
 # Attempt to return this host's most significant IP address
@@ -816,6 +855,62 @@ Example:
 
 
 
+=item B<doing>( STRING )
+
+Pushes the given STRING onto an internal context stack, which may then be used for
+stack traces produced on error (e.g. by L<fatal_error>).  The STRING should be a
+human-readable summary of a task (e.g. "compiling the autotests").
+
+Returns a reference.  When that reference is destroyed, the task is popped off
+the context stack.  It is invalid to call this function without storing the return
+value.
+
+Example:
+
+  sub run {
+    my ($self) = @_;
+    my $doing = $self->doing( 'testing the frobnitz' );
+    $self->configure( );
+    $self->compile( );
+    $self->compile_autotests( );
+    $self->run_autotests( );
+  }
+
+  ...
+
+  sub compile {
+    my ($self) = @_;
+    my $doing = $self->doing( 'compiling the frobnitz' );
+
+    # sanity check
+    (-e 'Makefile') || $self->fatal_error(
+        'configure succeeded, but no Makefile found!'
+    );
+
+    $self->exe( 'make' );
+  }
+
+  ...
+
+In the above example, if the sanity check for the Makefile failed, the fatal
+error message would include a trace of the form:
+
+  while:
+    - compiling the frobnitz
+    - testing the frobnitz
+
+Usage note: the most important consumer of this information is the
+C<parse_build_log.pl> script in the qtqa repository.  When this script finds
+a fatal error with context information, it uses the topmost part of the context
+stack as the failure summary (which is usually pasted into Gerrit).  The failure
+from the previous example code may be summarized as:
+
+  Compiling the frobnitz failed :(
+
+    configure succeeded, but no Makefile found!
+
+
+
 =item B<fatal_error>( STRING )
 
 Formats the given error STRING into a human and machine-readable value, then dies
@@ -836,6 +931,9 @@ exited with status 123" where the process is expected to output its own error
 messages - it is generally better not to use this function, as the formatted
 error message is unlikely to provide any additional value.
 
+It is highly recommended to make use of this function together with L<doing>.
+See the documentation of that function for more information.
+
 
 
 =item B<get_options_from_array>( ARRAYREF [, LIST ] )
diff --git a/scripts/lib/perl5/QtQA/t/10-TestScript.t b/scripts/lib/perl5/QtQA/t/10-TestScript.t
index cc7f06c..db2d85d 100644
--- a/scripts/lib/perl5/QtQA/t/10-TestScript.t
+++ b/scripts/lib/perl5/QtQA/t/10-TestScript.t
@@ -436,6 +436,45 @@ error: |
     return;
 }
 
+sub test_doing_with_fatal_error
+{
+    my $script = QtQA::TestScript->new;
+
+    my $error_header = qq{--- !qtqa.qt-project.org/error\nerror: };
+
+    my $expected_error_for_scopes = sub {
+        my ($error, @scopes) = @_;
+        @scopes = reverse @scopes;
+        return
+            "${error_header}$error\n"
+           .(@scopes
+                ? "while:\n  - "
+                 .join("\n  - ", @scopes)
+                 ."\n"
+                : q{}
+            )
+           ."...\n";
+    };
+
+    {
+        my $outer = $script->doing( 'outer1' );
+
+        {
+            my $inner1 = $script->doing( 'inner1' );
+            my $expected = $expected_error_for_scopes->( 'quux', 'outer1', 'inner1' );
+            throws_ok { $script->fatal_error( 'quux' ) } qr{\A\Q$expected\E}, 'two scopes';
+        }
+
+        my $expected = $expected_error_for_scopes->( 'bar', 'outer1' );
+        throws_ok { $script->fatal_error( 'bar' ) } qr{\A\Q$expected\E}, 'one scope';
+    }
+
+    my $expected = $expected_error_for_scopes->( 'baz' );
+    throws_ok { $script->fatal_error( 'baz' ) } qr{\A\Q$expected\E}, 'no scope';
+
+    return;
+}
+
 # Run all the tests
 sub run_test
 {
@@ -454,6 +493,7 @@ sub run_test
     test_exe_qx;
 
     test_fatal_error;
+    test_doing_with_fatal_error;
 
     return;
 }
diff --git a/scripts/qt/qtmod_test.pl b/scripts/qt/qtmod_test.pl
index cd1624d..79f8f9c 100755
--- a/scripts/qt/qtmod_test.pl
+++ b/scripts/qt/qtmod_test.pl
@@ -56,7 +56,7 @@ use English qw( -no_match_vars );
 use Env::Path;
 use File::chdir;
 use File::Path;
-use File::Spec::Functions;
+use File::Spec::Functions qw( :ALL );
 use List::MoreUtils qw( any apply );
 use autodie;
 use Readonly;
@@ -208,6 +208,10 @@ sub run
     my ($self) = @_;
 
     $self->read_and_store_configuration;
+
+    my $qt_gitmodule = $self->{ 'qt.gitmodule' };
+    my $doing = $self->doing( "testing $qt_gitmodule" );
+
     $self->run_git_checkout;
     $self->run_configure;
     $self->run_qtqa_autotests( 'prebuild' );
@@ -444,6 +448,9 @@ sub read_and_store_configuration
 sub read_dependencies
 {
     my ($self, $dependency_file) = @_;
+
+    my $doing = $self->doing( "reading dependencies from ".abs2rel( $dependency_file ) );
+
     our (%dependencies);
 
     my %default_dependencies = ( 'qtbase' => 'refs/heads/master' );
@@ -486,6 +493,8 @@ sub run_git_checkout
 {
     my ($self) = @_;
 
+    my $doing = $self->doing( 'setting up git repositories' );
+
     my $base_dir      = $self->{ 'base.dir'      };
     my $qt_init_repository_args
                       = $self->{ 'qt.init-repository.args' };
@@ -597,6 +606,8 @@ sub run_configure
 {
     my ($self) = @_;
 
+    my $doing = $self->doing( 'configuring Qt' );
+
     # properties
     my $qt_dir                  = $self->{ 'qt.dir'                  };
     my $qt_build_dir            = $self->{ 'qt.build.dir'            };
@@ -654,6 +665,8 @@ sub run_compile
 {
     my ($self) = @_;
 
+    my $doing = $self->doing( 'compiling Qt' );
+
     # properties
     my $qt_dir                  = $self->{ 'qt.dir'                  };
     my $qt_build_dir            = $self->{ 'qt.build.dir'            };
@@ -794,6 +807,8 @@ sub run_install
 {
     my ($self) = @_;
 
+    my $doing = $self->doing( 'installing Qt' );
+
     my $make_bin        = $self->{ 'make.bin' };
     my $qt_dir          = $self->{ 'qt.dir' };
     my $qt_build_dir    = $self->{ 'qt.build.dir' };
@@ -842,6 +857,8 @@ sub run_install_check
 {
     my ($self) = @_;
 
+    my $doing = $self->doing( 'checking the installation' );
+
     my $qt_install_dir  = $self->{ 'qt.install.dir' };
     my $qt_make_install = $self->{ 'qt.make_install' };
 
@@ -957,6 +974,8 @@ sub run_autotests
 
     return if (!$self->{ 'qt.tests.enabled' });
 
+    my $doing = $self->doing( 'running the autotests' );
+
     my $qt_gitmodule_build_dir = $self->{ 'qt.gitmodule.build.dir' };
 
     # Add this module's `bin' directory to PATH.
@@ -1003,6 +1022,8 @@ sub run_qtqa_autotests
     my $qt_gitmodule_dir       = $self->{ 'qt.gitmodule.dir' };
     my $qt_gitmodule_build_dir = $self->{ 'qt.gitmodule.build.dir' };
 
+    my $doing = $self->doing( "running the qtqa tests on $qt_gitmodule" );
+
     # path to the qtqa shared autotests.
     my $qtqa_tests_dir = catfile( $FindBin::Bin, qw(.. .. tests), $type );
 
@@ -1171,6 +1192,8 @@ sub run_coverage
 
     return if ((!$self->{ 'qt.tests.enabled' }) or (!$self->{ 'qt.coverage.tool' }));
 
+    my $doing = $self->doing( 'gathering coverage data' );
+
     my $qt_coverage_tool         = $self->{ 'qt.coverage.tool' };
     my $qt_coverage_tests_output = $self->{ 'qt.coverage.tests_output' };
     my $qt_gitmodule             = $self->{ 'qt.gitmodule' };