view release on metacpan or  search on metacpan

lib/Test2/Tools/Affix.pm  view on Meta::CPAN

                # https://github.com/Perl/perl5/issues/19949
                # https://github.com/Perl/perl5/issues/20970
                $known->{'https://github.com/Perl/perl5/issues/19949'} = <<'';
{
   <insert_a_suppression_name_here>
   Memcheck:Overlap
   fun:__memcpy_chk
   fun:XS_Cwd_abs_path
   fun:Perl_pp_entersub
   fun:Perl_runops_standard
   fun:S_docatch
   fun:Perl_runops_standard
   fun:Perl_call_sv
}
{
   memmove overlapping source and destination
   Memcheck:Overlap
   fun:__memcpy_chk
}

                $supp = Path::Tiny::tempfile( { realpath => 1 }, 'valgrind_suppression_XXXXXXXXXX' );
                diag 'spewing to ' . $supp;
                diag $supp->spew( join "\n\n", values %$known );
                push @cleanup, $supp;
                Test2::API::test2_stack()->top->{count};

                #~ Test2::API::test2_stack()->top->{count}++;
            }
        }

        sub parse_suppression {
            my $dups  = 0;
            my $known = {};
            require Digest::MD5;
            my @in = split /\R/, shift;
            my $l  = 0;
            while ( $_ = shift @in ) {
                $l++;
                next unless (/^\{/);
                my $block = $_ . "\n";
                while ( $_ = shift @in ) {
                    $l++;
                    $block .= $_ . "\n";
                    last if /^\}/;
                }
                $block // last;
                if ( $block !~ /\}\n/ ) {
                    diag "Unterminated suppression at line $l";
                    last;
                }
                my $key = $block;
                $key =~ s/(\A\{[^\n]*\n)\s*[^\n]*\n/$1/;
                my $sum = Digest::MD5::md5_hex($key);
                $dups++ if exists $known->{$sum};
                $known->{$sum} = $block;
            }
            return ( $known, $dups );
        }

        sub dec_ent {
            return $1 if $_[0] =~ m/^<!\[CDATA\[\{(.*)}]]>$/smg;
            $_[0]              =~ s[&lt;][<]g;
            $_[0]              =~ s[&gt;][>]g;
            $_[0]              =~ s[&amp;][&]g;
            shift;
        }

        sub stacktrace($blah) {
            use Test2::Util::Table qw[table];
            $blah ?
                join "\n", table(
                max_width => 120,
                collapse  => 1,                                # Do not show empty columns
                header    => [ 'function', 'path', 'line' ],
                rows      => [
                    map { [ $_->{fn}, ( defined $_->{dir} && defined $_->{file} ) ? join '/', $_->{dir}, $_->{file} : '', $_->{line} // '' ] } @$blah
                ],
                ) :
                '';
        }

        sub parse_xml {
            my ($xml) = @_;
            my $hash  = {};
            my $re    = qr{<([^>]+)>\s*(.*?)\s*</\1>}sm;
            while ( $xml =~ m/$re/g ) {
                my ( $tag, $content ) = ( $1, $2 );
                $content = parse_xml($content) if $content =~ /$re/;
                $content = dec_ent($content) unless ref $content;
                if ( $tag eq 'error' ) {

                    # use Data::Dump;
                    # ddx $content;
                    diag $content->{what} // $content->{xwhat}{text};
                    if ( ref $content->{auxwhat} eq 'ARRAY' ) {
                        for my $i ( 0 .. scalar @{ $content->{stack} } ) {
                            note $content->{auxwhat}[$i] if $content->{auxwhat}[$i];
                            note stacktrace $content->{stack}[$i]{frame};
                        }
                    }
                    else {
                        note $content->{auxwhat};
                        for my $i ( 0 .. scalar @{ $content->{stack} } ) {
                            note stacktrace $content->{stack}[$i]{frame};
                        }
                    }
                }
                $hash->{$tag}
                    = defined $content ?
                    (
                    defined $hash->{$tag} ?
                        ref $hash->{$tag} eq 'ARRAY' ?
                            [ @{ $hash->{$tag} }, $content ] :
                            [ $hash->{$tag}, $content ] :
                        $tag =~ m/^(error|stack)$/ ? [$content] :
                        dec_ent($content) ) :
                    undef;
            }
            $hash;
        }