src/test/regress/dld.pl - hawq - Git at Google

 #!/usr/bin/env perl
 #
 # Licensed to the Apache Software Foundation (ASF) under one
 # or more contributor license agreements.  See the NOTICE file
 # distributed with this work for additional information
 # regarding copyright ownership.  The ASF licenses this file
 # to you under the Apache License, Version 2.0 (the
 # "License"); you may not use this file except in compliance
 # with the License.  You may obtain a copy of the License at
 #
 #   http://www.apache.org/licenses/LICENSE-2.0
 #
 # Unless required by applicable law or agreed to in writing,
 # software distributed under the License is distributed on an
 # "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
 # KIND, either express or implied.  See the License for the
 # specific language governing permissions and limitations
 # under the License.
 #
 #
 # Licensed to the Apache Software Foundation (ASF) under one
 # or more contributor license agreements.  See the NOTICE file
 # distributed with this work for additional information
 # regarding copyright ownership.  The ASF licenses this file
 # to you under the Apache License, Version 2.0 (the
 # "License"); you may not use this file except in compliance
 # with the License.  You may obtain a copy of the License at
 #
 #   http://www.apache.org/licenses/LICENSE-2.0
 #
 # Unless required by applicable law or agreed to in writing,
 # software distributed under the License is distributed on an
 # "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
 # KIND, either express or implied.  See the License for the
 # specific language governing permissions and limitations
 # under the License.
 #
 use Pod::Usage;
 use Getopt::Long;
 use Data::Dumper;
 use strict;
 use warnings;

 =head1 NAME

 B<dld.pl> - [D]ead[L]ock [D]etector

 =head1 SYNOPSIS

 B<dld> [options]

 Options:

     -help            brief help message
     -man             full documentation
     -connect         psql connect parameters

 =head1 OPTIONS

 =over 8

 =item B<-help>

     Print a brief help message and exits.

 =item B<-man>

     Prints the manual page and exits.

 =item B<-connect>

     psql connect string, e.g:

     -connect '-p 11000 template1'

 =back

 =head1 DESCRIPTION

 dld.pl finds (but does not fix) deadlocks

 perl dld.pl -connect '-p 11000 template1'

 Substitute the correct "connect string" for your postgres database.

 =head1 AUTHORS

 Apache HAWQ

 Address bug reports and comments to: dev@hawq.apache.org

 =cut

 my $glob_id = "";

 my $glob_tab;
 my $glob_connect;
 my $glob_verbose = 1;


 BEGIN {
     my $man  = 0;
     my $help = 0;
     my $table;
     my $conn;

     GetOptions(
                'help|?' => \$help, man => \$man,
                "table=s" => \$table,
                "connect=s" => \$conn
                )
         or pod2usage(2);


     pod2usage(-msg => $glob_id, -exitstatus => 1) if $help;
     pod2usage(-msg => $glob_id, -exitstatus => 0, -verbose => 2) if $man;

     $glob_tab = $table;
     $glob_connect = $conn;

     $glob_connect = '-p 11000 template1'
         unless (defined($glob_connect));

     $glob_verbose = 1;

 #    print "loading...\n" ;
 }

 # convert a postgresql psql formatted table into an array of hashes
 sub tablelizer
 {
     my $ini = shift;

     # first, split into separate lines, the find all the column headings

     my @lines = split(/\n/, $ini);

     return undef
         unless (scalar(@lines));

     my $line1 = shift @lines;

     # look for <space>|<space>
     my @colheads = split(/\s+\|\s+/, $line1);

     # fixup first, last column head (remove leading,trailing spaces)

     $colheads[0] =~ s/^\s+//;
     $colheads[0] =~ s/\s+$//;
     $colheads[-1] =~ s/^\s+//;
     $colheads[-1] =~ s/\s+$//;

     return undef
         unless (scalar(@lines));

     shift @lines; # skip dashed separator

     my @rows;

     for my $lin (@lines)
     {
         my @cols = split(/\|/, $lin, scalar(@colheads));
         last
             unless (scalar(@cols) == scalar(@colheads));

         my $rowh = {};

         for my $colhd (@colheads)
         {
             my $rawcol = shift @cols;

             $rawcol =~ s/^\s+//;
             $rawcol =~ s/\s+$//;

             $rowh->{$colhd} = $rawcol;
         }
         push @rows, $rowh;
     }

     return \@rows;
 }

 sub walk_graph
 {
     my ($wfg, $key, $visited) = @_;

     if ($glob_verbose && defined($key))
     {
         print "key: $key\n";
         print "visit: ", join("-> ", @{$visited}), "\n";
     }

     return 0
         unless (defined($wfg) && (ref($wfg) eq 'HASH'));

     my @wfg_keys = keys(%{$wfg});

     unless (defined($visited))
     {
         for my $k1 (@wfg_keys)
         {
             my $stat = walk_graph($wfg, $k1, [$k1]);
             return 0
                 unless ($stat);
         }
         return 1;
     }

     my $k1 = $key;

     return 1
         unless (exists($wfg->{$k1}));

     {
         for my $holder (@{$wfg->{$k1}->{primary}})
         {
             for my $itm (@{$visited})
             {
                 if ($itm eq $holder)
                 {
                     print "cycle detected!\n";
                     my $first = $visited->[0];
                     print join(" -> ", @{$visited}, $first), "\n";
                     return 0;
                 }
             }
             my $v2;
             $v2 = [];
             push @{$v2}, @{$visited}, $holder;
             return 0
                 unless (walk_graph($wfg, $holder, $v2));
         }
     }


     return 1;
 }


 if (1)
 {
     my $psql_str = "psql ";

     $psql_str .= $glob_connect
         if (defined($glob_connect));

     # need to deal with mirrors, etc
 #    $psql_str .= " -c \'select * from gp_configuration where definedprimary is true or content > 0\'";
     $psql_str .= " -c \'select * from gp_segment_configuration where role=" .
 		# use "dollar-quoting" to avoid dealing with nested single-quotes:
 		# $q$p$q$ is equivalent to 'p'
 		'$q$p$q$' . " \'";

 #    print $psql_str, "\n";

     my $tabdef = `$psql_str`;

     print $tabdef
         if ($glob_verbose);

     my $mpp_config_table = tablelizer($tabdef);

     # some locks are on txns, not relations, so no relnames
     my $sel_str = "\'select cl.relname as relname, lk.* from pg_locks as lk left outer join pg_class as cl on cl.relfilenode = lk.relation\'";

     my @combo_tab;
     my @rel_list;
     my @txn_list;

     for my $rowh (@{$mpp_config_table})
     {
 #        print Data::Dumper->Dump([$vv]), "\n";


         my $psql_seg = "PGOPTIONS=\'-c gp_session_role=utility\' psql -h $rowh->{hostname} -p $rowh->{port} template1 -c $sel_str";

         print $psql_seg,"\n"
             if ($glob_verbose);

         my $lk1 = `$psql_seg`;

         print $lk1
             if ($glob_verbose);

         my $tabh = tablelizer($lk1);

 #        print Data::Dumper->Dump([$tabh]), "\n";
         for my $rr (@{$tabh})
         {
             $rr->{segid} = $rowh->{content};

             # look for waiters - "granted = [f]alse"
             if ($rr->{granted} =~ m/\s*f\s*/ )
             {
                 if ($rr->{locktype} =~ m/transactionid/)
                 {
                     push @txn_list, $rr->{transactionid};
                 }
                 else
                 {
                     push @rel_list, $rr->{relation};
                 }
             }

         }

         push @combo_tab, @{$tabh};

     }

     # find all txns with same tables as waiters

     my @wait_tab;

     my $rel_str = join(", ", @rel_list);
     my $txn_str = join(", ", @txn_list);

 #    print "rel_str: $rel_str\ntxn_str: $txn_str\n";

     $sel_str = "\'select cl.relname as relname, lk.* from pg_locks as lk left outer join pg_class as cl on cl.relfilenode = lk.relation ";

     if (scalar(@rel_list) || scalar(@txn_list))
     {
         $sel_str .= " \'";

         for my $rowh (@{$mpp_config_table})
         {
 #        print Data::Dumper->Dump([$vv]), "\n";


             my $psql_seg = "PGOPTIONS=\'-c gp_session_role=utility\' psql -h $rowh->{hostname}  -p $rowh->{port} template1 -c $sel_str";

             my $lk1 = `$psql_seg`;

             print $lk1
                 if ($glob_verbose);

             my $tabh = tablelizer($lk1);

 #        print Data::Dumper->Dump([$tabh]), "\n";
             for my $rr (@{$tabh})
             {
                 $rr->{segid} = $rowh->{content};
 #        map {$_->{segid} = $mpp_config_table->{content} },  @{$tabh};
             }

             push @wait_tab, @{$tabh};

         }
     }

     print "wait_tab:", Data::Dumper->Dump(\@wait_tab), "\n"
         if ($glob_verbose);
 #    print Data::Dumper->Dump(\@combo_tab), "\n";

     my %holders;
     my %waiters;

     # find lock holders and lock waiters per relation

     for my $wrow (@wait_tab)
     {
         my $reltn = $wrow->{relation};

         next
             unless (defined($reltn));

         if ($wrow->{granted} eq 't')
         {
             unless (exists($holders{$reltn}))
             {
                 $holders{$reltn} = [];
             }
             push @{$holders{$reltn}}, $wrow;
         }
         else
         {
             unless (exists($waiters{$reltn}))
             {
                 $waiters{$reltn} = [];
             }
             push @{$waiters{$reltn}}, $wrow;
         }
     }

     my %wfg; # WAIT FOR GRAPH by segment, pid

     while ( my ($kk, $vv) = each(%waiters))
     {
         for my $waititm (@{$vv})
         {
             my $big_id = $waititm->{segid} . "/" . $waititm->{pid};

             unless (exists($wfg{$big_id}))
             {
                 $wfg{$big_id} = {primary => []};
             }

             unless (exists($holders{$kk}))
             {
                 print "no lock holder for relation $kk!!\n";
                 next;
             }

             for my $holditm (@{$holders{$kk}})
             {
                 my $h_id = $holditm->{segid} . "/" . $holditm->{pid};

                 # don't wait on yourself
                 next
                     if ($h_id eq $big_id);

                 push @{$wfg{$big_id}->{primary}}, $h_id;
             }
         }

     }

     if ($glob_verbose)
     {
         print "waiters:\n",Data::Dumper->Dump([%waiters]), "\n";
         print "holders:\n",Data::Dumper->Dump([%holders]), "\n";
         print "wfg:\n",Data::Dumper->Dump([%wfg]), "\n";
     }

     walk_graph(\%wfg);

 }

 exit();
	#!/usr/bin/env perl
	#
	# Licensed to the Apache Software Foundation (ASF) under one
	# or more contributor license agreements. See the NOTICE file
	# distributed with this work for additional information
	# regarding copyright ownership. The ASF licenses this file
	# to you under the Apache License, Version 2.0 (the
	# "License"); you may not use this file except in compliance
	# with the License. You may obtain a copy of the License at
	#
	# http://www.apache.org/licenses/LICENSE-2.0
	#
	# Unless required by applicable law or agreed to in writing,
	# software distributed under the License is distributed on an
	# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
	# KIND, either express or implied. See the License for the
	# specific language governing permissions and limitations
	# under the License.
	#
	#
	# Licensed to the Apache Software Foundation (ASF) under one
	# or more contributor license agreements. See the NOTICE file
	# distributed with this work for additional information
	# regarding copyright ownership. The ASF licenses this file
	# to you under the Apache License, Version 2.0 (the
	# "License"); you may not use this file except in compliance
	# with the License. You may obtain a copy of the License at
	#
	# http://www.apache.org/licenses/LICENSE-2.0
	#
	# Unless required by applicable law or agreed to in writing,
	# software distributed under the License is distributed on an
	# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
	# KIND, either express or implied. See the License for the
	# specific language governing permissions and limitations
	# under the License.
	#
	use Pod::Usage;
	use Getopt::Long;
	use Data::Dumper;
	use strict;
	use warnings;

	=head1 NAME

	B<dld.pl> - [D]ead[L]ock [D]etector

	=head1 SYNOPSIS

	B<dld> [options]

	Options:

	-help brief help message
	-man full documentation
	-connect psql connect parameters

	=head1 OPTIONS

	=over 8

	=item B<-help>

	Print a brief help message and exits.

	=item B<-man>

	Prints the manual page and exits.

	=item B<-connect>

	psql connect string, e.g:

	-connect '-p 11000 template1'

	=back

	=head1 DESCRIPTION

	dld.pl finds (but does not fix) deadlocks

	perl dld.pl -connect '-p 11000 template1'

	Substitute the correct "connect string" for your postgres database.

	=head1 AUTHORS

	Apache HAWQ

	Address bug reports and comments to: dev@hawq.apache.org

	=cut

	my $glob_id = "";

	my $glob_tab;
	my $glob_connect;
	my $glob_verbose = 1;


	BEGIN {
	my $man = 0;
	my $help = 0;
	my $table;
	my $conn;

	GetOptions(
	'help\|?' => \$help, man => \$man,
	"table=s" => \$table,
	"connect=s" => \$conn
	)
	or pod2usage(2);


	pod2usage(-msg => $glob_id, -exitstatus => 1) if $help;
	pod2usage(-msg => $glob_id, -exitstatus => 0, -verbose => 2) if $man;

	$glob_tab = $table;
	$glob_connect = $conn;

	$glob_connect = '-p 11000 template1'
	unless (defined($glob_connect));

	$glob_verbose = 1;

	# print "loading...\n" ;
	}

	# convert a postgresql psql formatted table into an array of hashes
	sub tablelizer
	{
	my $ini = shift;

	# first, split into separate lines, the find all the column headings

	my @lines = split(/\n/, $ini);

	return undef
	unless (scalar(@lines));

	my $line1 = shift @lines;

	# look for <space>\|<space>
	my @colheads = split(/\s+\\|\s+/, $line1);

	# fixup first, last column head (remove leading,trailing spaces)

	$colheads[0] =~ s/^\s+//;
	$colheads[0] =~ s/\s+$//;
	$colheads[-1] =~ s/^\s+//;
	$colheads[-1] =~ s/\s+$//;

	return undef
	unless (scalar(@lines));

	shift @lines; # skip dashed separator

	my @rows;

	for my $lin (@lines)
	{
	my @cols = split(/\\|/, $lin, scalar(@colheads));
	last
	unless (scalar(@cols) == scalar(@colheads));

	my $rowh = {};

	for my $colhd (@colheads)
	{
	my $rawcol = shift @cols;

	$rawcol =~ s/^\s+//;
	$rawcol =~ s/\s+$//;

	$rowh->{$colhd} = $rawcol;
	}
	push @rows, $rowh;
	}

	return \@rows;
	}

	sub walk_graph
	{
	my ($wfg, $key, $visited) = @_;

	if ($glob_verbose && defined($key))
	{
	print "key: $key\n";
	print "visit: ", join("-> ", @{$visited}), "\n";
	}

	return 0
	unless (defined($wfg) && (ref($wfg) eq 'HASH'));

	my @wfg_keys = keys(%{$wfg});

	unless (defined($visited))
	{
	for my $k1 (@wfg_keys)
	{
	my $stat = walk_graph($wfg, $k1, [$k1]);
	return 0
	unless ($stat);
	}
	return 1;
	}

	my $k1 = $key;

	return 1
	unless (exists($wfg->{$k1}));

	{
	for my $holder (@{$wfg->{$k1}->{primary}})
	{
	for my $itm (@{$visited})
	{
	if ($itm eq $holder)
	{
	print "cycle detected!\n";
	my $first = $visited->[0];
	print join(" -> ", @{$visited}, $first), "\n";
	return 0;
	}
	}
	my $v2;
	$v2 = [];
	push @{$v2}, @{$visited}, $holder;
	return 0
	unless (walk_graph($wfg, $holder, $v2));
	}
	}


	return 1;
	}


	if (1)
	{
	my $psql_str = "psql ";

	$psql_str .= $glob_connect
	if (defined($glob_connect));

	# need to deal with mirrors, etc
	# $psql_str .= " -c \'select * from gp_configuration where definedprimary is true or content > 0\'";
	$psql_str .= " -c \'select * from gp_segment_configuration where role=" .
	# use "dollar-quoting" to avoid dealing with nested single-quotes:
	# $q$p$q$ is equivalent to 'p'
	'$q$p$q$' . " \'";

	# print $psql_str, "\n";

	my $tabdef = `$psql_str`;

	print $tabdef
	if ($glob_verbose);

	my $mpp_config_table = tablelizer($tabdef);

	# some locks are on txns, not relations, so no relnames
	my $sel_str = "\'select cl.relname as relname, lk.* from pg_locks as lk left outer join pg_class as cl on cl.relfilenode = lk.relation\'";

	my @combo_tab;
	my @rel_list;
	my @txn_list;

	for my $rowh (@{$mpp_config_table})
	{
	# print Data::Dumper->Dump([$vv]), "\n";


	my $psql_seg = "PGOPTIONS=\'-c gp_session_role=utility\' psql -h $rowh->{hostname} -p $rowh->{port} template1 -c $sel_str";

	print $psql_seg,"\n"
	if ($glob_verbose);

	my $lk1 = `$psql_seg`;

	print $lk1
	if ($glob_verbose);

	my $tabh = tablelizer($lk1);

	# print Data::Dumper->Dump([$tabh]), "\n";
	for my $rr (@{$tabh})
	{
	$rr->{segid} = $rowh->{content};

	# look for waiters - "granted = [f]alse"
	if ($rr->{granted} =~ m/\sf\s/ )
	{
	if ($rr->{locktype} =~ m/transactionid/)
	{
	push @txn_list, $rr->{transactionid};
	}
	else
	{
	push @rel_list, $rr->{relation};
	}
	}

	}

	push @combo_tab, @{$tabh};

	}

	# find all txns with same tables as waiters

	my @wait_tab;

	my $rel_str = join(", ", @rel_list);
	my $txn_str = join(", ", @txn_list);

	# print "rel_str: $rel_str\ntxn_str: $txn_str\n";

	$sel_str = "\'select cl.relname as relname, lk.* from pg_locks as lk left outer join pg_class as cl on cl.relfilenode = lk.relation ";

	if (scalar(@rel_list) \|\| scalar(@txn_list))
	{
	$sel_str .= " \'";

	for my $rowh (@{$mpp_config_table})
	{
	# print Data::Dumper->Dump([$vv]), "\n";


	my $psql_seg = "PGOPTIONS=\'-c gp_session_role=utility\' psql -h $rowh->{hostname} -p $rowh->{port} template1 -c $sel_str";

	my $lk1 = `$psql_seg`;

	print $lk1
	if ($glob_verbose);

	my $tabh = tablelizer($lk1);

	# print Data::Dumper->Dump([$tabh]), "\n";
	for my $rr (@{$tabh})
	{
	$rr->{segid} = $rowh->{content};
	# map {$_->{segid} = $mpp_config_table->{content} }, @{$tabh};
	}

	push @wait_tab, @{$tabh};

	}
	}

	print "wait_tab:", Data::Dumper->Dump(\@wait_tab), "\n"
	if ($glob_verbose);
	# print Data::Dumper->Dump(\@combo_tab), "\n";

	my %holders;
	my %waiters;

	# find lock holders and lock waiters per relation

	for my $wrow (@wait_tab)
	{
	my $reltn = $wrow->{relation};

	next
	unless (defined($reltn));

	if ($wrow->{granted} eq 't')
	{
	unless (exists($holders{$reltn}))
	{
	$holders{$reltn} = [];
	}
	push @{$holders{$reltn}}, $wrow;
	}
	else
	{
	unless (exists($waiters{$reltn}))
	{
	$waiters{$reltn} = [];
	}
	push @{$waiters{$reltn}}, $wrow;
	}
	}

	my %wfg; # WAIT FOR GRAPH by segment, pid

	while ( my ($kk, $vv) = each(%waiters))
	{
	for my $waititm (@{$vv})
	{
	my $big_id = $waititm->{segid} . "/" . $waititm->{pid};

	unless (exists($wfg{$big_id}))
	{
	$wfg{$big_id} = {primary => []};
	}

	unless (exists($holders{$kk}))
	{
	print "no lock holder for relation $kk!!\n";
	next;
	}

	for my $holditm (@{$holders{$kk}})
	{
	my $h_id = $holditm->{segid} . "/" . $holditm->{pid};

	# don't wait on yourself
	next
	if ($h_id eq $big_id);

	push @{$wfg{$big_id}->{primary}}, $h_id;
	}
	}

	}

	if ($glob_verbose)
	{
	print "waiters:\n",Data::Dumper->Dump([%waiters]), "\n";
	print "holders:\n",Data::Dumper->Dump([%holders]), "\n";
	print "wfg:\n",Data::Dumper->Dump([%wfg]), "\n";
	}

	walk_graph(\%wfg);

	}

	exit();