]>
Commit | Line | Data |
---|---|---|
e70380f4 AA |
1 | #!/usr/bin/env perl |
2 | # | |
a945c346 | 3 | # Copyright (C) 2022-2024 Free Software Foundation, Inc. |
e70380f4 AA |
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: |