2015-09-10 11:33:22 +02:00
#!/usr/bin/perl
use charnames ':full'; # only necessary before v5.16
use strict;
use v5.10;
use warnings;
use DBIx::SimpleConnect;
use Encode qw(:fallbacks encode);
my $db = shift // "default";
2015-09-10 12:21:01 +02:00
my $dbh = DBIx::SimpleConnect->connect($db, {RaiseError => 1});
2015-09-10 11:33:22 +02:00
my $sth
= $dbh->prepare("
select locks_blocking.pid as blocking_pid,
query_blocking.query as blocking_query,
query_blocking.usename as blocking_username,
locks_blocked.pid as blocked_pid,
query_blocked.query as blocked_query,
query_blocked.usename as blocked_username
2015-09-10 12:21:01 +02:00
from pg_locks locks_blocked join pg_locks locks_blocking
on (locks_blocked.locktype='relation' and locks_blocking.locktype='relation' and locks_blocked.database=locks_blocking.database and locks_blocked.relation=locks_blocking.relation
or locks_blocked.locktype='transactionid' and locks_blocking.locktype='transactionid' and locks_blocked.transactionid=locks_blocking.transactionid
-- don't know how to handle virtualxid
)
2015-09-10 11:33:22 +02:00
join pg_stat_activity query_blocked on (locks_blocked.pid=query_blocked.pid)
join pg_stat_activity query_blocking on (locks_blocking.pid = query_blocking.pid)
where locks_blocking.granted and not locks_blocked.granted
"
);
$sth->execute();
my $locks = $sth->fetchall_arrayref();
2015-09-10 11:58:52 +02:00
binmode STDOUT, ":encoding(UTF-8)";
2016-03-01 15:27:59 +01:00
say "<!DOCTYPE html>";
2015-09-10 11:58:52 +02:00
say "<html>";
say "<head>";
say "<meta charset='UTF-8'/>";
2016-03-01 15:27:59 +01:00
say "<style type='text/css'>";
say "table { border-collapse: collapse; border-style: solid; border-width: 1px; }";
say "th { vertical-align: baseline; border-style: solid; border-color: #888; border-width: 1px; }";
say "td {";
say " vertical-align: baseline;";
say " border-style: solid;";
say " border-color: #888;";
say " border-width: 1px;";
say " white-space: pre-wrap }";
say "}";
say "</style>";
2015-09-10 11:58:52 +02:00
say "</head>";
say "<body>";
2015-09-10 11:33:22 +02:00
if (@$locks) {
say "<table>";
say "<tr>";
say map {
"<th>" . xmlencode($_) . "</th>"
} @{$sth->{NAME}};
say "</tr>";
for my $lk (@$locks) {
say "<tr>";
say map {
"<td>"
. (defined($_) ? xmlencode($_) : '<em>NULL</em>')
. "</td>"
} @$lk;
say "</tr>";
}
say "</table>";
} else {
say "<p>No locks \N{WHITE SMILING FACE}</p>";
}
2015-09-10 11:58:52 +02:00
say "</body>";
say "</html>";
exit(0);
2015-09-10 11:33:22 +02:00
sub xmlencode {
my ($s) = @_;
return encode("us-ascii", $s, FB_XMLCREF);
}
2016-03-01 15:27:59 +01:00
sub format_pretty {
my ($s) = @_;
if (!defined $s) { return '<em>NULL</em>' }
$s = xmlencode($s);
my @s = split(/\n/, $s);
while (@s && $s[0] eq "") { shift @s }
while (@s && $s[-1] eq "") { pop @s }
my $leading_space = "+Inf";
for (@s) {
my $sp = /^(\s+)/;
if (length($sp) < $leading_space) {
$leading_space = length($sp);
}
}
for (@s) {
$_ = substr($_, $leading_space);
}
$s = join("\n", @s);
return $s;
}
