| 1 | #!./perl |
| 2 | |
| 3 | # DAPM: this description is from the original commit message: |
| 4 | # this appears to be a HP leak detection thing: |
| 5 | # |
| 6 | # Add a script for cleaning out the "known noise" |
| 7 | # from Third Degree reports: either noise caused |
| 8 | # by libc itself, or Perl_yyparse leaks. |
| 9 | |
| 10 | local $/; |
| 11 | $_ = <ARGV>; |
| 12 | |
| 13 | my @accv = /(^-+ \w+ -- \d+ --(?:.(?!^-))+)/msg; |
| 14 | my @leak = /(\d+ bytes? in \d+ leaks? .+? created at:(?:.(?!^[\d-]))+)/msg; |
| 15 | |
| 16 | $leak[ 0] =~ s/.* were found:\n\n//m; # Snip off totals. |
| 17 | |
| 18 | # Weed out the known access violations. |
| 19 | |
| 20 | @accv = grep { ! /-- ru[hs] --.+setlocale.+Perl_init_i18nl10n/s } @accv; |
| 21 | @accv = grep { ! /-- [rw][ui]s --.+_doprnt_dis/s } @accv; |
| 22 | @accv = grep { ! /-- (?:fon|ris) --.+__strxfrm/s } @accv; |
| 23 | @accv = grep { ! /-- rus --.+__catgets/s } @accv; |
| 24 | @accv = grep { ! /-- rus --.+__execvp/s } @accv; |
| 25 | @accv = grep { ! /-- rus --.+tmpnam.+tmpfile/s } @accv; |
| 26 | @accv = grep { ! /-- rus --.+__gethostbyname/s } @accv; |
| 27 | @accv = grep { ! /-- ris --.+__actual_atof/s } @accv; |
| 28 | @accv = grep { ! /-- ris --.+__strftime/s } @accv; |
| 29 | |
| 30 | # Weed out untraceable access violations. |
| 31 | @accv = grep { ! / ----- /s } @accv; |
| 32 | @accv = grep { ! /-- r[ui][hs] --.+proc_at_/s } @accv; |
| 33 | @accv = grep { ! /-- r[ui][hs] --.+pc = 0x/s } @accv; |
| 34 | |
| 35 | # The following look like being caused by the intrinsic inlined |
| 36 | # string handling functions reading one or few bytes beyond the |
| 37 | # actual length. |
| 38 | @accv = grep { ! /-- rih --.+(?:memmove|strcpy).+moreswitches/s } @accv; |
| 39 | @accv = grep { ! /-- (?:rih|rus) --.+strcpy.+gv_fetchfile/s } @accv; |
| 40 | @accv = grep { ! /-- rih --.+strcmp.+doopen_pm/s } @accv; |
| 41 | @accv = grep { ! /-- rih --.+strcmp.+gv_fetchpv/s } @accv; |
| 42 | @accv = grep { ! /-- r[ui]h --.+strcmp.+gv_fetchmeth/s } @accv; |
| 43 | @accv = grep { ! /-- rih --.+memmove.+my_setenv/s } @accv; |
| 44 | @accv = grep { ! /-- rih --.+memmove.+catpvn_flags/s } @accv; |
| 45 | |
| 46 | # yyparse. |
| 47 | @accv = grep { ! /Perl_yyparse/s } @accv; |
| 48 | |
| 49 | # Weed out the known memory leaks. |
| 50 | |
| 51 | @leak = grep { ! /setlocale.+Perl_init_i18nl10n/s } @leak; |
| 52 | @leak = grep { ! /setlocale.+set_numeric_standard/s } @leak; |
| 53 | @leak = grep { ! /_findiop.+fopen/s } @leak; |
| 54 | @leak = grep { ! /_findiop.+__fdopen/s } @leak; |
| 55 | @leak = grep { ! /__localtime/s } @leak; |
| 56 | @leak = grep { ! /__get_libc_context/s } @leak; |
| 57 | @leak = grep { ! /__sia_init/s } @leak; |
| 58 | |
| 59 | # Weed out untraceable memory leaks. |
| 60 | @leak = grep { ! / ----- /s } @leak; |
| 61 | @leak = grep { ! /pc = 0x/s } @leak; |
| 62 | @leak = grep { ! /_pc_range_table/s } @leak; |
| 63 | @leak = grep { ! /_add_gp_range/s } @leak; |
| 64 | |
| 65 | # yyparse. |
| 66 | @leak = grep { ! /Perl_yyparse/s } @leak; |
| 67 | |
| 68 | # Output the cleaned up report. |
| 69 | |
| 70 | # Access violations. |
| 71 | |
| 72 | for (my $i = 0; $i < @accv; $i++) { |
| 73 | $_ = $accv[$i]; |
| 74 | s/\d+/$i/; |
| 75 | print; |
| 76 | } |
| 77 | |
| 78 | # Memory leaks. |
| 79 | |
| 80 | my ($leakb, $leakn, $leaks); |
| 81 | |
| 82 | for (my $i = 0; $i < @leak; $i++) { |
| 83 | $_ = $leak[$i]; |
| 84 | print $_, "\n"; |
| 85 | /^(\d+) bytes? in (\d+) leak/; |
| 86 | $leakb += $1; |
| 87 | $leakn += $2; |
| 88 | $leaks += $1 if /including (\d+) super/; |
| 89 | } |
| 90 | |
| 91 | print "Bytes $leakb Leaks $leakn Super $leaks\n" if $leakb; |