contrib/dg-out-generator.pl

   1 #!/usr/bin/env perl
   2 #
   3 # Copyright (C) 2022-2023 Free Software Foundation, Inc.
   4 # Contributed by Arsen Arsenović.
   5 #
   6 # This script is free software; you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation; either version 3, or (at your option)
   9 # any later version.
  10
  11 # This script reads program output on STDIN, and out of it produces a block of
  12 # dg-output lines that can be yanked at the end of a file.  It will escape
  13 # special ARE and Tcl constructs automatically.
  14 #
  15 # Each argument passed on the standard input is treated as a string to be
  16 # replaced by ``.*'' in the final result.  This is intended to mask out build
  17 # paths, filenames, etc.
  18 #
  19 # Usage example:
  20
  21 # $ g++-13 -fcontracts -o test \
  22 #  'g++.dg/contracts/contracts-access1.C' && \
  23 #   ./test |& dg-out-generator.pl 'g++.dg/contracts/contracts-access1.C'
  24 # // { dg-output {contract violation in function Base::b at .*:11: pub > 0(\n|\r\n|\r)} }
  25 # // { dg-output {\[level:default, role:default, continuation mode:never\](\n|\r\n|\r)} }
  26 # // { dg-output {terminate called without an active exception(\n|\r\n|\r)} }
  27
  28 # You can now freely dump the above into your testcase.
  29
  30 use strict;
  31 use warnings;
  32 use POSIX 'floor';
  33
  34 my $escapees = '(' . join ('|', map { quotemeta } @ARGV) . ')';
  35
  36 sub gboundary($)
  37 {
  38   my $str = shift;
  39   my $sz = 10.0;
  40   for (;;)
  41     {
  42       my $bnd = join '', (map chr 64 + rand 27, 1 .. floor $sz);
  43       return $bnd unless index ($str, $bnd) >= 0;
  44       $sz += 0.1;
  45     }
  46 }
  47
  48 while (<STDIN>)
  49   {
  50     # Escape our escapees.
  51     my $boundary;
  52     if (@ARGV) {
  53       # Checking this is necessary to avoid a spurious .* between all
  54       # characters if no arguments are passed.
  55       $boundary = gboundary $_;
  56       s/$escapees/$boundary/g;
  57     }
  58
  59     # Quote stuff special in Tcl ARE.  This step also effectively nulls any
  60     # concern about escaping.  As long as all curly braces are escaped, the
  61     # string will, when passing through the braces rule of Tcl, be identical to
  62     # the input.
  63     s/([[\]*+?{}()\\])/\\$1/g;
  64
  65     # Newlines should be more tolerant.
  66     s/\n$/(\\n|\\r\\n|\\r)/;
  67
  68     # Then split out the boundary, replacing it with .*.
  69     s/$boundary/.*/g if defined $boundary;
  70
  71     # Then, let's print it in a dg-output block.  If you'd prefer /* keep in
  72     # mind that if your string contains */ it could terminate the comment
  73     # early.  Maybe add an extra s!\*/!*()/!g or something.
  74     print "// { dg-output {$_} }\n";
  75   }
  76
  77 # File Local Vars:
  78 # indent-tabs-mode: nil
  79 # End: