#!/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";
my $dbh = DBIx::SimpleConnect->connect($db);
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
from pg_locks locks_blocked join pg_locks locks_blocking using (locktype, database, relation)
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();
binmode STDOUT, ":encoding(UTF-8)";
say "";
say "";
say "";
say "";
say "";
if (@$locks) {
say "";
say "";
say map {
"| " . xmlencode($_) . " | "
} @{$sth->{NAME}};
say "
";
for my $lk (@$locks) {
say "";
say map {
"| "
. (defined($_) ? xmlencode($_) : 'NULL')
. " | "
} @$lk;
say "
";
}
say "
";
} else {
say "No locks \N{WHITE SMILING FACE}
";
}
say "";
say "