Adding upstream version 225+deb11u1.upstream/225+deb11u1upstream

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 1229 insertions, 0 deletions

diff --git a/PgCommon.pm b/PgCommon.pm
new file mode 100644
index 0000000..769bf06
--- /dev/null
+++ b/PgCommon.pm
@@ -0,0 +1,1229 @@
+# Common functions for the postgresql-common framework
+#
+# (C) 2008-2009 Martin Pitt <mpitt@debian.org>
+# (C) 2012-2020 Christoph Berg <myon@debian.org>
+#
+#  This program is free software; you can redistribute it and/or modify
+#  it under the terms of the GNU General Public License as published by
+#  the Free Software Foundation; either version 2 of the License, or
+#  (at your option) any later version.
+#
+#  This program is distributed in the hope that it will be useful,
+#  but WITHOUT ANY WARRANTY; without even the implied warranty of
+#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+#  GNU General Public License for more details.
+
+package PgCommon;
+use strict;
+use IPC::Open3;
+use Socket;
+use POSIX;
+
+use Exporter;
+our $VERSION = 1.00;
+our @ISA = ('Exporter');
+our @EXPORT = qw/error user_cluster_map get_cluster_port set_cluster_port
+    get_cluster_socketdir set_cluster_socketdir cluster_port_running
+    get_cluster_start_conf set_cluster_start_conf set_cluster_pg_ctl_conf
+    get_program_path cluster_info get_versions get_newest_version version_exists
+    get_version_clusters next_free_port cluster_exists install_file
+    change_ugid config_bool get_db_encoding get_db_locales get_cluster_locales get_cluster_controldata
+    get_cluster_databases cluster_conf_filename read_cluster_conf_file
+    read_pg_hba read_pidfile valid_hba_method/;
+our @EXPORT_OK = qw/$confroot $binroot $rpm $have_python2
+    quote_conf_value read_conf_file get_conf_value
+    set_conf_value set_conffile_value disable_conffile_value disable_conf_value
+    replace_conf_value cluster_data_directory get_file_device
+    check_pidfile_running/;
+
+# Print an error message to stderr and exit with status 1
+sub error {
+    print STDERR 'Error: ', $_[0], "\n";
+    exit 1;
+}
+
+# configuration
+our $confroot = '/etc/postgresql';
+if ($ENV{'PG_CLUSTER_CONF_ROOT'}) {
+    ($confroot) = $ENV{'PG_CLUSTER_CONF_ROOT'} =~ /(.*)/; # untaint
+}
+our $common_confdir = "/etc/postgresql-common";
+if ($ENV{'PGSYSCONFDIR'}) {
+    ($common_confdir) = $ENV{'PGSYSCONFDIR'} =~ /(.*)/; # untaint
+}
+my $mapfile = "$common_confdir/user_clusters";
+our $binroot = "/usr/lib/postgresql/";
+#redhat# $binroot = "/usr/pgsql-";
+our $rpm = 0;
+#redhat# $rpm = 1;
+our $defaultport = 5432;
+our $have_python2 = 0; # python2 removed in bullseye+
+#py2#$have_python2 = 1;
+
+{
+    my %saved_env;
+
+    # untaint the environment for executing an external program
+    # Optional arguments: list of additional variables
+    sub prepare_exec {
+	my @cleanvars = qw/PATH IFS ENV BASH_ENV CDPATH/;
+	push @cleanvars, @_;
+	%saved_env = ();
+
+	foreach (@cleanvars) {
+	    $saved_env{$_} = $ENV{$_};
+	    delete $ENV{$_};
+	}
+
+	$ENV{'PATH'} = '';
+    }
+
+    # restore the environment after prepare_exec()
+    sub restore_exec {
+	foreach (keys %saved_env) {
+	    if (defined $saved_env{$_}) {
+		$ENV{$_} = $saved_env{$_};
+	    } else {
+		delete $ENV{$_};
+	    }
+	}
+    }
+}
+
+# Returns '1' if the argument is a configuration file value that stands for
+# true (ON, TRUE, YES, or 1, case insensitive), '0' if the argument represents
+# a false value (OFF, FALSE, NO, or 0, case insensitive), or undef otherwise.
+sub config_bool {
+    return undef unless defined($_[0]);
+    return 1 if ($_[0] =~ /^(on|true|yes|1)$/i);
+    return 0 if ($_[0] =~ /^(off|false|no|0)$/i);
+    return undef;
+}
+
+# Quotes a value with single quotes
+# Arguments: <value>
+# Returns: quoted string
+sub quote_conf_value ($) {
+    my $value = shift;
+    return $value if ($value =~ /^-?[\d.]+$/); # integer or float
+    return $value if ($value =~ /^\w+$/); # plain word
+    $value =~ s/'/''/g; # else quote it
+    return "'$value'";
+}
+
+# Read a 'var = value' style configuration file and return a hash with the
+# values. Error out if the file cannot be read.
+# If the file name ends with '.conf', the keys will be normalized to lower case
+# (suitable for e. g. postgresql.conf), otherwise kept intact (suitable for
+# environment).
+# Arguments: <path>
+# Returns: hash (empty if file does not exist)
+sub read_conf_file {
+    my ($config_path) = @_;
+    my %conf;
+    local (*F);
+
+    sub get_absolute_path {
+        my ($path, $parent_path) = @_;
+        return $path if ($path =~ m!^/!); # path is absolute
+        # else strip filename component from parent path
+        $parent_path =~ s!/[^/]*$!!;
+        return "$parent_path/$path";
+    }
+
+    if (open F, $config_path) {
+        while (<F>) {
+            if (/^\s*(?:#.*)?$/) {
+                next;
+            } elsif(/^\s*include_dir\s*=?\s*'([^']+)'\s*(?:#.*)?$/i) {
+                # read included configuration directory and merge into %conf
+                # files in the directory will be read in ascending order
+                my $path = $1;
+                my $absolute_path = get_absolute_path($path, $config_path);
+                next unless -e $absolute_path && -d $absolute_path;
+                my $dir;
+                opendir($dir, $absolute_path) or next;
+                foreach my $filename (sort readdir($dir) ) {
+                    next if ($filename =~ m/^\./ or not $filename =~/\.conf$/ );
+                    my %include_conf = read_conf_file("$absolute_path/$filename");
+                    while ( my ($k, $v) = each(%include_conf) ) {
+                        $conf{$k} = $v;
+                    }
+                }
+                closedir($dir);
+            } elsif (/^\s*include(?:_if_exists)?\s*=?\s*'([^']+)'\s*(?:#.*)?$/i) {
+                # read included file and merge into %conf
+                my $path = $1;
+                my $absolute_path = get_absolute_path($path, $config_path);
+                my %include_conf = read_conf_file($absolute_path);
+                while ( my ($k, $v) = each(%include_conf) ) {
+                    $conf{$k} = $v;
+                }
+            } elsif (/^\s*([a-zA-Z0-9_.-]+)\s*(?:=|\s)\s*'((?:[^']|''|(?:(?<=\\)'))*)'\s*(?:#.*)?$/i) {
+                # string value
+                my $v = $2;
+                my $k = $1;
+                $k = lc $k if $config_path =~ /\.conf$/;
+                $v =~ s/\\(.)/$1/g;
+                $v =~ s/''/'/g;
+                $conf{$k} = $v;
+            } elsif (m{^\s*([a-zA-Z0-9_.-]+)\s*(?:=|\s)\s*(-?[[:alnum:]][[:alnum:]._:/+-]*)\s*(?:\#.*)?$}i) {
+                # simple value (string/float)
+                my $v = $2;
+                my $k = $1;
+                $k = lc $k if $config_path =~ /\.conf$/;
+                $conf{$k} = $v;
+            } else {
+                chomp;
+                error "invalid line $. in $config_path: $_";
+            }
+        }
+        close F;
+    }
+
+    return %conf;
+}
+
+# Returns path to cluster config file from a cluster configuration
+# directory (with /etc/postgresql-common/<file name> as fallback) and return a
+# hash with the values. Error out if the file cannot be read.
+# If config file name is postgresql.auto.conf, read from PGDATA
+# Arguments: <version> <cluster> <config file name>
+# Returns: hash (empty if the file does not exist)
+sub cluster_conf_filename {
+    my ($version, $cluster, $configfile) = @_;
+    if ($configfile eq 'postgresql.auto.conf') {
+        my $data_directory = cluster_data_directory($version, $cluster);
+        return "$data_directory/$configfile";
+    }
+    my $fname = "$confroot/$version/$cluster/$configfile";
+    -e $fname or $fname = "$common_confdir/$configfile";
+    return $fname;
+}
+
+# Read a 'var = value' style configuration file from a cluster configuration
+# Arguments: <version> <cluster> <config file name>
+# Returns: hash (empty if the file does not exist)
+sub read_cluster_conf_file {
+    my ($version, $cluster, $configfile) = @_;
+    my %conf = read_conf_file(cluster_conf_filename($version, $cluster, $configfile));
+
+    if ($version >= 9.4 and $configfile eq 'postgresql.conf') { # merge settings changed by ALTER SYSTEM
+        # data_directory cannot be changed by ALTER SYSTEM
+        my $data_directory = cluster_data_directory($version, $cluster, \%conf);
+        my %auto_conf = read_conf_file "$data_directory/postgresql.auto.conf";
+        foreach my $guc (keys %auto_conf) {
+            next if ($guc eq 'data_directory'); # defend against pg_upgradecluster bug in 200..202
+            $conf{$guc} = $auto_conf{$guc};
+        }
+    }
+
+    return %conf;
+}
+
+# Return parameter from a PostgreSQL configuration file, or undef if the parameter
+# does not exist.
+# Arguments: <version> <cluster> <config file name> <parameter name>
+sub get_conf_value {
+    my %conf = (read_cluster_conf_file $_[0], $_[1], $_[2]);
+    return $conf{$_[3]};
+}
+
+# Set parameter of a PostgreSQL configuration file.
+# Arguments: <config file name> <parameter name> <value>
+sub set_conffile_value {
+    my ($fname, $key, $value) = ($_[0], $_[1], quote_conf_value($_[2]));
+    my @lines;
+
+    # read configuration file lines
+    open (F, $fname) or die "Error: could not open $fname for reading";
+    push @lines, $_ while (<F>);
+    close F;
+
+    my $found = 0;
+    # first, search for an uncommented setting
+    for (my $i=0; $i <= $#lines; ++$i) {
+	if ($lines[$i] =~ /^\s*($key)(\s*(?:=|\s)\s*)\w+\b((?:\s*#.*)?)/i or
+	    $lines[$i] =~ /^\s*($key)(\s*(?:=|\s)\s*)'[^']*'((?:\s*#.*)?)/i) {
+	    $lines[$i] = "$1$2$value$3\n";
+	    $found = 1;
+	    last;
+	}
+    }
+
+    # now check if the setting exists as a comment; if so, change that instead
+    # of appending
+    if (!$found) {
+	for (my $i=0; $i <= $#lines; ++$i) {
+	    if ($lines[$i] =~ /^\s*#\s*($key)(\s*(?:=|\s)\s*)\w+\b((?:\s*#.*)?)/i or
+		$lines[$i] =~ /^\s*#\s*($key)(\s*(?:=|\s)\s*)'[^']*'((?:\s*#.*)?)/i) {
+		$lines[$i] = "$1$2$value$3\n";
+		$found = 1;
+		last;
+	    }
+	}
+    }
+
+    # not found anywhere, append it
+    push (@lines, "$key = $value\n") unless $found;
+
+    # write configuration file lines
+    open (F, ">$fname.new") or die "Error: could not open $fname.new for writing";
+    foreach (@lines) {
+	print F $_ or die "writing $fname.new: $!";
+    }
+    close F;
+
+    # copy permissions
+    my @st = stat $fname or die "stat: $!";
+    chown $st[4], $st[5], "$fname.new"; # might fail as non-root
+    chmod $st[2], "$fname.new" or die "chmod: $!";
+
+    rename "$fname.new", "$fname" or die "rename $fname.new $fname: $!";
+}
+
+# Set parameter of a PostgreSQL cluster configuration file.
+# Arguments: <version> <cluster> <config file name> <parameter name> <value>
+sub set_conf_value {
+    return set_conffile_value(cluster_conf_filename($_[0], $_[1], $_[2]), $_[3], $_[4]);
+}
+
+# Disable a parameter in a PostgreSQL configuration file by prepending it with
+# a '#'. Appends an optional explanatory comment <reason> if given.
+# Arguments: <config file name> <parameter name> <reason>
+sub disable_conffile_value {
+    my ($fname, $key, $reason) = @_;
+    my @lines;
+
+    # read configuration file lines
+    open (F, $fname) or die "Error: could not open $fname for reading";
+    push @lines, $_ while (<F>);
+    close F;
+
+    my $changed = 0;
+    for (my $i=0; $i <= $#lines; ++$i) {
+	if ($lines[$i] =~ /^\s*$key\s*(?:=|\s)/i) {
+            $lines[$i] =~ s/^/#/;
+            $lines[$i] =~ s/$/ #$reason/ if $reason;
+            $changed = 1;
+	    last;
+	}
+    }
+
+    # write configuration file lines
+    if ($changed) {
+        open (F, ">$fname.new") or die "Error: could not open $fname.new for writing";
+        foreach (@lines) {
+	    print F $_ or die "writing $fname.new: $!";
+        }
+        close F;
+
+	# copy permissions
+	my @st = stat $fname or die "stat: $!";
+	chown $st[4], $st[5], "$fname.new"; # might fail as non-root
+	chmod $st[2], "$fname.new" or die "chmod: $1";
+
+	rename "$fname.new", "$fname";
+    }
+}
+
+# Disable a parameter in a PostgreSQL cluster configuration file by prepending
+# it with a '#'. Appends an optional explanatory comment <reason> if given.
+# Arguments: <version> <cluster> <config file name> <parameter name> <reason>
+sub disable_conf_value {
+    return disable_conffile_value(cluster_conf_filename($_[0], $_[1], $_[2]), $_[3], $_[4]);
+}
+
+# Replace a parameter in a PostgreSQL configuration file. The old parameter is
+# prepended with a '#' and  gets an optional explanatory comment <reason>
+# appended, if given. The new parameter is inserted directly after the old one.
+# Arguments: <version> <cluster> <config file name> <old parameter name>
+#            <reason> <new parameter name> <new value>
+sub replace_conf_value {
+    my ($version, $cluster, $configfile, $oldparam, $reason, $newparam, $val) = @_;
+    my $fname = cluster_conf_filename($version, $cluster, $configfile);
+    my @lines;
+
+    # quote $val if necessary
+    unless ($val =~ /^\w+$/) {
+	$val = "'$val'";
+    }
+
+    # read configuration file lines
+    open (F, $fname) or die "Error: could not open $fname for reading";
+    push @lines, $_ while (<F>);
+    close F;
+
+    my $found = 0;
+    for (my $i = 0; $i <= $#lines; ++$i) {
+	if ($lines[$i] =~ /^\s*$oldparam\s*(?:=|\s)/i) {
+	    $lines[$i] = '#'.$lines[$i];
+	    chomp $lines[$i];
+            $lines[$i] .= ' #'.$reason."\n" if $reason;
+
+            # insert the new param
+            splice @lines, $i+1, 0, "$newparam = $val\n";
+            ++$i;
+
+            $found = 1;
+	    last;
+	}
+    }
+
+    return if !$found;
+
+    # write configuration file lines
+    open (F, ">$fname.new") or die "Error: could not open $fname.new for writing";
+    foreach (@lines) {
+	print F $_ or die "writing $fname.new: $!";
+    }
+    close F;
+
+    # copy permissions
+    my @st = stat $fname or die "stat: $!";
+    chown $st[4], $st[5], "$fname.new"; # might fail as non-root
+    chmod $st[2], "$fname.new" or die "chmod: $1";
+
+    rename "$fname.new", "$fname";
+}
+
+# Return the port of a particular cluster
+# Arguments: <version> <cluster>
+sub get_cluster_port {
+    return get_conf_value($_[0], $_[1], 'postgresql.conf', 'port') || $defaultport;
+}
+
+# Set the port of a particular cluster.
+# Arguments: <version> <cluster> <port>
+sub set_cluster_port {
+    set_conf_value $_[0], $_[1], 'postgresql.conf', 'port', $_[2];
+}
+
+# Return cluster data directory.
+# Arguments: <version> <cluster name> [<config_hash>]
+sub cluster_data_directory {
+    my $d;
+    if ($_[2]) {
+        $d = ${$_[2]}{'data_directory'};
+    } else {
+        $d = get_conf_value($_[0], $_[1], 'postgresql.conf', 'data_directory');
+    }
+    my $confdir = "$confroot/$_[0]/$_[1]";
+    if (!$d) {
+        # fall back to /pgdata symlink (supported by earlier p-common releases)
+        $d = readlink "$confdir/pgdata";
+    }
+    if (!$d and -l $confdir and -f "$confdir/PG_VERSION") { # symlink from /etc/postgresql
+        $d = readlink $confdir;
+    }
+    if (!$d and -f "$confdir/PG_VERSION") { # PGDATA in /etc/postgresql
+        $d = $confdir;
+    }
+    ($d) = $d =~ /(.*)/ if defined $d; #untaint
+    return $d;
+}
+
+# Return the socket directory of a particular cluster or undef if the cluster
+# does not exist.
+# Arguments: <version> <cluster>
+sub get_cluster_socketdir {
+    # if it is explicitly configured, just return it
+    my $socketdir = get_conf_value($_[0], $_[1], 'postgresql.conf',
+        $_[0] >= 9.3 ? 'unix_socket_directories' : 'unix_socket_directory');
+    $socketdir =~ s/\s*,.*// if ($socketdir); # ignore additional directories for now
+    return $socketdir if $socketdir;
+
+    #redhat# return '/tmp'; # RedHat PGDG packages default to /tmp
+    # try to determine whether this is a postgres owned cluster and we default
+    # to /var/run/postgresql
+    $socketdir = '/var/run/postgresql';
+    my @socketdirstat = stat $socketdir;
+
+    error "Cannot stat $socketdir" unless @socketdirstat;
+
+    if ($_[0] && $_[1]) {
+        my $datadir = cluster_data_directory $_[0], $_[1];
+        error "Invalid data directory for cluster $_[0] $_[1]" unless $datadir;
+        my @datadirstat = stat $datadir;
+        unless (@datadirstat) {
+            my @p = split '/', $datadir;
+            my $parent = join '/', @p[0..($#p-1)];
+            error "$datadir is not accessible; please fix the directory permissions ($parent/ should be world readable)" unless @datadirstat;
+        }
+
+        $socketdir = '/tmp' if $socketdirstat[4] != $datadirstat[4];
+    }
+
+    return $socketdir;
+}
+
+# Set the socket directory of a particular cluster.
+# Arguments: <version> <cluster> <directory>
+sub set_cluster_socketdir {
+    set_conf_value $_[0], $_[1], 'postgresql.conf',
+        $_[0] >= 9.3 ? 'unix_socket_directories' : 'unix_socket_directory',
+        $_[2];
+}
+
+# Return the path of a program of a particular version.
+# Arguments: <program name> [<version>]
+sub get_program_path {
+    my ($program, $version) = @_;
+    return '' unless defined $program;
+    $version //= get_newest_version($program);
+    my $path = "$binroot$version/bin/$program";
+    ($path) = $path =~ /(.*)/; #untaint
+    return $path if -x $path;
+    return '';
+}
+
+# Check whether a postgres server is running at the specified port.
+# Arguments: <version> <cluster> <port>
+sub cluster_port_running {
+    die "port_running: invalid port $_[2]" if $_[2] !~ /\d+/;
+    my $socketdir = get_cluster_socketdir $_[0], $_[1];
+    my $socketpath = "$socketdir/.s.PGSQL.$_[2]";
+    return 0 unless -S $socketpath;
+
+    socket(SRV, PF_UNIX, SOCK_STREAM, 0) or die "socket: $!";
+    my $running = connect(SRV, sockaddr_un($socketpath));
+    close SRV;
+    return $running ? 1 : 0;
+}
+
+# Read, verify, and return the current start.conf setting.
+# Arguments: <version> <cluster>
+# Returns: auto | manual | disabled
+sub get_cluster_start_conf {
+    my $start_conf = "$confroot/$_[0]/$_[1]/start.conf";
+    if (-e $start_conf) {
+	open F, $start_conf or error "Could not open $start_conf: $!";
+	while (<F>) {
+	    s/#.*$//;
+	    s/^\s*//;
+	    s/\s*$//;
+	    next unless $_;
+            close F;
+            return $1 if (/^(auto|manual|disabled)/);
+            error "Invalid mode in $start_conf, must be one of auto, manual, disabled";
+	}
+	close F;
+    }
+    return 'auto'; # default
+}
+
+# Change start.conf setting.
+# Arguments: <version> <cluster> <value>
+# <value> = auto | manual | disabled
+sub set_cluster_start_conf {
+    my ($v, $c, $val) = @_;
+
+    error "Invalid mode: '$val'" unless $val eq 'auto' ||
+	    $val eq 'manual' || $val eq 'disabled';
+
+    my $perms = 0644;
+
+    # start.conf setting
+    my $start_conf = "$confroot/$_[0]/$_[1]/start.conf";
+    my $text;
+    if (-e $start_conf) {
+	open F, $start_conf or error "Could not open $start_conf: $!";
+	while (<F>) {
+            if (/^\s*(?:auto|manual|disabled)\b(.*$)/) {
+                $text .= $val . $1 . "\n";
+            } else {
+                $text .= $_;
+            }
+	}
+
+        # preserve permissions if it already exists
+        $perms = (stat F)[2];
+        error "Could not get permissions of $start_conf: $!" unless $perms;
+	close F;
+    } else {
+        $text = "# Automatic startup configuration
+#   auto: automatically start the cluster
+#   manual: manual startup with pg_ctlcluster/postgresql@.service only
+#   disabled: refuse to start cluster
+# See pg_createcluster(1) for details. When running from systemd,
+# invoke 'systemctl daemon-reload' after editing this file.
+
+$val
+";
+    }
+
+    open F, '>' . $start_conf or error "Could not open $start_conf for writing: $!";
+    chmod $perms, $start_conf;
+    print F $text;
+    close F;
+}
+
+# Change pg_ctl.conf setting.
+# Arguments: <version> <cluster> <options>
+# <options> = options passed to pg_ctl(1)
+sub set_cluster_pg_ctl_conf {
+    my ($v, $c, $opts) = @_;
+    my $perms = 0644;
+
+    # pg_ctl.conf setting
+    my $pg_ctl_conf = "$confroot/$v/$c/pg_ctl.conf";
+    my $text = "# Automatic pg_ctl configuration
+# This configuration file contains cluster specific options to be passed to
+# pg_ctl(1).
+
+pg_ctl_options = '$opts'
+";
+
+    open F, '>' . $pg_ctl_conf or error "Could not open $pg_ctl_conf for writing: $!";
+    chmod $perms, $pg_ctl_conf;
+    print F $text;
+    close F;
+}
+
+# Return the PID from an existing PID file or undef if it does not exist.
+# Arguments: <pid file path>
+sub read_pidfile {
+    return undef unless -e $_[0];
+
+    if (open PIDFILE, $_[0]) {
+	my $pid = <PIDFILE>;
+	close PIDFILE;
+        return undef unless ($pid);
+        chomp $pid;
+        ($pid) = $pid =~ /^(\d+)\s*$/; # untaint
+	return $pid;
+    } else {
+	return undef;
+    }
+}
+
+# Check whether a pid file is present and belongs to a running postgres.
+# Returns undef if it cannot be determined
+# Arguments: <pid file path>
+sub check_pidfile_running {
+    # postgres does not clean up the PID file when it stops, and it is
+    # not world readable, so only its absence is a definitive result; if it
+    # is present, we need to read it and check the PID, which will only
+    # work as root
+    return 0 if ! -e $_[0];
+
+    my $pid = read_pidfile $_[0];
+    if (defined $pid and open CL, "/proc/$pid/cmdline") {
+        my $cmdline = <CL>;
+        close CL;
+        if ($cmdline and $cmdline =~ /\bpostgres\b/) {
+            return 1;
+        } else {
+            return 0;
+        }
+    }
+    return undef;
+}
+
+# Determine if a cluster is managed by a supervisor (pacemaker, patroni).
+# Returns undef if it cannot be determined
+# Arguments: <pid file path>
+sub cluster_supervisor {
+    # postgres does not clean up the PID file when it stops, and it is
+    # not world readable, so only its absence is a definitive result; if it
+    # is present, we need to read it and check the PID, which will only
+    # work as root
+    return undef if ! -e $_[0];
+
+    my $pid = read_pidfile $_[0];
+    if (defined $pid and open(CG, "/proc/$pid/cgroup")) {
+        local $/; # enable localized slurp mode
+        my $cgroup = <CG>;
+        close CG;
+        if ($cgroup and $cgroup =~ /\b(pacemaker|patroni)\b/) {
+            return $1;
+        }
+    }
+    return undef;
+}
+
+# Return a hash with information about a specific cluster (which needs to exist).
+# Arguments: <version> <cluster name>
+# Returns: information hash (keys: pgdata, port, running, logfile [unless it
+#          has a custom one], configdir, owneruid, ownergid, waldir, socketdir,
+#          config->postgresql.conf)
+sub cluster_info {
+    my ($v, $c) = @_;
+    error 'cluster_info must be called with <version> <cluster> arguments' unless ($v and $c);
+
+    my %result;
+    $result{'configdir'} = "$confroot/$v/$c";
+    $result{'configuid'} = (stat "$result{configdir}/postgresql.conf")[4];
+
+    my %postgresql_conf = read_cluster_conf_file $v, $c, 'postgresql.conf';
+    $result{'config'} = \%postgresql_conf;
+    $result{'pgdata'} = cluster_data_directory $v, $c, \%postgresql_conf;
+    return %result unless (keys %postgresql_conf);
+    $result{'port'} = $postgresql_conf{'port'} || $defaultport;
+    $result{'socketdir'} = get_cluster_socketdir  $v, $c;
+
+    # if we can determine the running status with the pid file, prefer that
+    if ($postgresql_conf{'external_pid_file'} &&
+	$postgresql_conf{'external_pid_file'} ne '(none)') {
+	$result{'running'} = check_pidfile_running $postgresql_conf{'external_pid_file'};
+        my $supervisor = cluster_supervisor($postgresql_conf{'external_pid_file'});
+        $result{supervisor} = $supervisor if ($supervisor);
+    }
+
+    # otherwise fall back to probing the port; this is unreliable if the port
+    # was changed in the configuration file in the meantime
+    if (!defined ($result{'running'})) {
+	$result{'running'} = cluster_port_running ($v, $c, $result{'port'});
+    }
+
+    if ($result{'pgdata'}) {
+        ($result{'owneruid'}, $result{'ownergid'}) =
+            (stat $result{'pgdata'})[4,5];
+        if ($v >= 12) {
+            $result{'recovery'} = 1 if (-e "$result{'pgdata'}/recovery.signal"
+                                     or -e "$result{'pgdata'}/standby.signal");
+        } else {
+            $result{'recovery'} = 1 if (-e "$result{'pgdata'}/recovery.conf");
+        }
+        my $waldirname = $v >= 10 ? 'pg_wal' : 'pg_xlog';
+        if (-l "$result{pgdata}/$waldirname") { # custom wal directory
+            ($result{waldir}) = readlink("$result{pgdata}/$waldirname") =~ /(.*)/; # untaint
+        }
+    }
+    $result{'start'} = get_cluster_start_conf $v, $c;
+
+    # default log file (possibly used only for early startup messages)
+    my $log_symlink = $result{'configdir'} . "/log";
+    if (-l $log_symlink) {
+        ($result{'logfile'}) = readlink ($log_symlink) =~ /(.*)/; # untaint
+    } else {
+        $result{'logfile'} = "/var/log/postgresql/postgresql-$v-$c.log";
+    }
+
+    return %result;
+}
+
+# Return an array of all available versions (by binaries and postgresql.conf files)
+# Arguments: binary to scan for (optional, defaults to postgres)
+sub get_versions {
+    my $program = shift // 'postgres';
+    my %versions = ();
+
+    # enumerate psql versions from /usr/lib/postgresql/* (or /usr/pgsql-*)
+    my $dir = $binroot;
+    #redhat# $dir = '/usr';
+    if (opendir (D, $dir)) {
+	my $entry;
+        while (defined ($entry = readdir D)) {
+            next if $entry eq '.' || $entry eq '..';
+            my $pfx = '';
+            #redhat# $pfx = "pgsql-";
+            ($entry) = $entry =~ /^$pfx(\d+\.?\d+)$/; # untaint
+            $versions{$entry} = 1 if $entry and get_program_path ($program, $entry);
+        }
+        closedir D;
+    }
+
+    # enumerate server versions from /etc/postgresql/*
+    if ($program eq 'postgres' and opendir (D, $confroot)) {
+        my $v;
+        while (defined ($v = readdir D)) {
+            next if $v eq '.' || $v eq '..';
+            ($v) = $v =~ /^(\d+\.?\d+)$/; # untaint
+            next unless ($v);
+
+            if (opendir (C, "$confroot/$v")) {
+                my $c;
+                while (defined ($c = readdir C)) {
+                    if (-e "$confroot/$v/$c/postgresql.conf") {
+                        $versions{$v} = 1;
+                        last;
+                    }
+                }
+                closedir C;
+            }
+        }
+        closedir D;
+    }
+
+    return sort { $a <=> $b } keys %versions;
+}
+
+# Return the newest available version
+# Arguments: binary to scan for (optional)
+sub get_newest_version {
+    my $program = shift // undef;
+    my @versions = get_versions($program);
+    return undef unless (@versions);
+    return $versions[-1];
+}
+
+# Check whether a version exists
+sub version_exists {
+    my ($version) = @_;
+    return get_program_path ('psql', $version);
+}
+
+# Return an array of all available clusters of given version
+# Arguments: <version>
+sub get_version_clusters {
+    my $vdir = $confroot.'/'.$_[0].'/';
+    my @clusters = ();
+    if (opendir (D, $vdir)) {
+	my $entry;
+        while (defined ($entry = readdir D)) {
+            next if $entry eq '.' || $entry eq '..';
+	    ($entry) = $entry =~ /^(.*)$/; # untaint
+            my $conf = "$vdir$entry/postgresql.conf";
+            if (-e $conf or -l $conf) { # existing file, or dead symlink
+                push @clusters, $entry;
+            }
+        }
+        closedir D;
+    }
+    return sort @clusters;
+}
+
+# Check if a cluster exists.
+# Arguments: <version> <cluster>
+sub cluster_exists {
+    for my $c (get_version_clusters $_[0]) {
+	return 1 if $c eq $_[1];
+    }
+    return 0;
+}
+
+# Return the next free PostgreSQL port.
+sub next_free_port {
+    # create list of already used ports
+    my @ports;
+    for my $v (get_versions) {
+	for my $c (get_version_clusters $v) {
+	    push @ports, get_cluster_port ($v, $c);
+	}
+    }
+
+    my $port;
+    for ($port = $defaultport; $port < 65536; ++$port) {
+	next if grep { $_ == $port } @ports;
+
+        # check if port is already in use
+	my ($have_ip4, $res4, $have_ip6, $res6);
+	if (socket (SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp'))) { # IPv4
+	    $have_ip4 = 1;
+	    $res4 = bind (SOCK, sockaddr_in($port, INADDR_ANY));
+	}
+	$have_ip6 = 0;
+	no strict; # avoid compilation errors with Perl < 5.14
+	if (exists $Socket::{"IN6ADDR_ANY"}) { # IPv6
+	    if (socket (SOCK, PF_INET6, SOCK_STREAM, getprotobyname('tcp'))) {
+		$have_ip6 = 1;
+		$res6 = bind (SOCK, sockaddr_in6($port, Socket::IN6ADDR_ANY));
+	    }
+	}
+	use strict;
+	unless ($have_ip4 or $have_ip6) {
+	    # require at least one protocol to work (PostgreSQL needs it anyway
+	    # for the stats collector)
+            die "could not create socket: $!";
+	}
+        close SOCK;
+	# return port if it is available on all supported protocols
+	return $port if ($have_ip4 ? $res4 : 1) and ($have_ip6 ? $res6 : 1);
+    }
+
+    die "no free port found";
+}
+
+# Return the PostgreSQL version, cluster, and database to connect to. version
+# is always set (defaulting to the version of the default port if no matching
+# entry is found, or finally to the latest installed version if there are no
+# clusters at all), cluster and database may be 'undef'. If only one cluster
+# exists, and no matching entry is found in the map files, that cluster is
+# returned.
+sub user_cluster_map {
+    my ($user, $pwd, $uid, $gid) = getpwuid $>;
+    my $group = (getgrgid  $gid)[0];
+
+    # check per-user configuration file
+    my $home = $ENV{"HOME"} || (getpwuid $>)[7];
+    my $homemapfile = $home . '/.postgresqlrc';
+    if (open MAP, $homemapfile) {
+	while (<MAP>) {
+	    s/#.*//;
+	    next if /^\s*$/;
+	    my ($v,$c,$db) = split;
+	    if (!version_exists $v) {
+                print "Warning: $homemapfile line $.: version $v does not exist\n";
+                next;
+	    }
+	    if (!cluster_exists $v, $c and $c !~ /^(\S+):(\d*)$/) {
+                print "Warning: $homemapfile line $.: cluster $v/$c does not exist\n";
+                next;
+	    }
+	    if ($db) {
+		close MAP;
+		return ($v, $c, ($db eq "*") ? undef : $db);
+	    } else {
+		print  "Warning: ignoring invalid line $. in $homemapfile\n";
+		next;
+	    }
+	}
+	close MAP;
+    }
+
+    # check global map file
+    if (open MAP, $mapfile) {
+        while (<MAP>) {
+            s/#.*//;
+            next if /^\s*$/;
+            my ($u,$g,$v,$c,$db) = split;
+            if (!$db) {
+                print  "Warning: ignoring invalid line $. in $mapfile\n";
+                next;
+            }
+	    if (!version_exists $v) {
+                print "Warning: $mapfile line $.: version $v does not exist\n";
+                next;
+	    }
+	    if (!cluster_exists $v, $c and $c !~ /^(\S+):(\d*)$/) {
+                print "Warning: $mapfile line $.: cluster $v/$c does not exist\n";
+                next;
+	    }
+            if (($u eq "*" || $u eq $user) && ($g eq "*" || $g eq $group)) {
+                close MAP;
+                return ($v,$c, ($db eq "*") ? undef : $db);
+            }
+        }
+        close MAP;
+    }
+
+    # if only one cluster exists, use that
+    my $count = 0;
+    my ($last_version, $last_cluster, $defaultport_version, $defaultport_cluster);
+    for my $v (get_versions) {
+	for my $c (get_version_clusters $v) {
+	    my $port = get_cluster_port ($v, $c);
+            $last_version = $v;
+            $last_cluster = $c;
+	    if ($port == $defaultport) {
+		$defaultport_version = $v;
+		$defaultport_cluster = $c;
+	    }
+            ++$count;
+	}
+    }
+    return ($last_version, $last_cluster, undef) if $count == 1;
+
+    if ($count == 0) {
+	# if there are no local clusters, use latest clients for accessing
+	# network clusters
+	return (get_newest_version('psql'), undef, undef);
+    }
+
+    # more than one cluster exists, return cluster at default port
+    return ($defaultport_version, $defaultport_cluster, undef);
+}
+
+# Copy a file to a destination and setup permissions
+# Arguments: <source file> <destination file or dir> <uid> <gid> <permissions>
+sub install_file {
+    my ($source, $dest, $uid, $gid, $perm) = @_;
+
+    if (system 'install', '-o', $uid, '-g', $gid, '-m', $perm, $source, $dest) {
+	error "install_file: could not install $source to $dest";
+    }
+}
+
+# Change effective and real user and group id. Also activates all auxiliary
+# groups the user is in. Exits with an error message if user/group ID cannot be
+# changed.
+# Arguments: <user id> <group id>
+sub change_ugid {
+    my ($uid, $gid) = @_;
+
+    # auxiliary groups
+    my $uname = (getpwuid $uid)[0];
+    prepare_exec;
+    my $groups = "$gid " . `/usr/bin/id -G $uname`;
+    restore_exec;
+
+    $) = $groups;
+    $( = $gid;
+    $> = $< = $uid;
+    error 'Could not change user id' if $< != $uid;
+    error 'Could not change group id' if $( != $gid;
+}
+
+# Return the encoding of a particular database in a cluster. This requires
+# access privileges to that database, so this function should be called as the
+# cluster owner.
+# Arguments: <version> <cluster> <database>
+# Returns: Encoding or undef if it cannot be determined.
+sub get_db_encoding {
+    my ($version, $cluster, $db) = @_;
+    my $port = get_cluster_port $version, $cluster;
+    my $socketdir = get_cluster_socketdir $version, $cluster;
+    my $psql = get_program_path 'psql';
+    return undef unless ($port && $socketdir && $psql);
+
+    # try to swich to cluster owner
+    prepare_exec 'LC_ALL';
+    $ENV{'LC_ALL'} = 'C';
+    my $orig_euid = $>;
+    $> = (stat (cluster_data_directory $version, $cluster))[4];
+    open PSQL, '-|', $psql, '-h', $socketdir, '-p', $port, '-AXtc',
+        'select getdatabaseencoding()', $db or
+        die "Internal error: could not call $psql to determine db encoding: $!";
+    my $out = <PSQL>;
+    close PSQL;
+    $> = $orig_euid;
+    restore_exec;
+    return undef if $?;
+    chomp $out;
+    ($out) = $out =~ /^([\w.-]+)$/; # untaint
+    return $out;
+}
+
+# Return locale of a particular database in a cluster. This requires access
+# privileges to that database, so this function should be called as the cluster
+# owner. (For versions >= 8.4; for older versions use get_cluster_locales()).
+# Arguments: <version> <cluster> <database>
+# Returns: (LC_CTYPE, LC_COLLATE) or (undef,undef) if it cannot be determined.
+sub get_db_locales {
+    my ($version, $cluster, $db) = @_;
+    my $port = get_cluster_port $version, $cluster;
+    my $socketdir = get_cluster_socketdir $version, $cluster;
+    my $psql = get_program_path 'psql';
+    return undef unless ($port && $socketdir && $psql);
+    my ($ctype, $collate);
+
+    # try to switch to cluster owner
+    prepare_exec 'LC_ALL';
+    $ENV{'LC_ALL'} = 'C';
+    my $orig_euid = $>;
+    $> = (stat (cluster_data_directory $version, $cluster))[4];
+    open PSQL, '-|', $psql, '-h', $socketdir, '-p', $port, '-AXtc',
+        'SHOW lc_ctype', $db or
+        die "Internal error: could not call $psql to determine db lc_ctype: $!";
+    my $out = <PSQL> // error 'could not determine db lc_ctype';
+    close PSQL;
+    ($ctype) = $out =~ /^([\w.\@-]+)$/; # untaint
+    open PSQL, '-|', $psql, '-h', $socketdir, '-p', $port, '-AXtc',
+        'SHOW lc_collate', $db or
+        die "Internal error: could not call $psql to determine db lc_collate: $!";
+    $out = <PSQL> // error 'could not determine db lc_collate';
+    close PSQL;
+    ($collate) = $out =~ /^([\w.\@-]+)$/; # untaint
+    $> = $orig_euid;
+    restore_exec;
+    chomp $ctype;
+    chomp $collate;
+    return ($ctype, $collate) unless $?;
+    return (undef, undef);
+}
+
+# Return the CTYPE and COLLATE locales of a cluster. This needs to be called
+# as root or as the cluster owner. (For versions <= 8.3; for >= 8.4, use
+# get_db_locales()).
+# Arguments: <version> <cluster>
+# Returns: (LC_CTYPE, LC_COLLATE) or (undef,undef) if it cannot be determined.
+sub get_cluster_locales {
+    my ($version, $cluster) = @_;
+    my ($lc_ctype, $lc_collate) = (undef, undef);
+
+    if ($version >= '8.4') {
+	print STDERR "Error: get_cluster_locales() does not work for 8.4+\n";
+	exit 1;
+    }
+
+    my $pg_controldata = get_program_path 'pg_controldata', $version;
+    if (! -e $pg_controldata) {
+        print STDERR "Error: pg_controldata not found, please install postgresql-$version\n";
+        exit 1;
+    }
+    prepare_exec ('LC_ALL', 'LANG', 'LANGUAGE');
+    $ENV{'LC_ALL'} = 'C';
+    my $result = open (CTRL, '-|', $pg_controldata, (cluster_data_directory $version, $cluster));
+    restore_exec;
+    return (undef, undef) unless defined $result;
+    while (<CTRL>) {
+	if (/^LC_CTYPE\W*(\S+)\s*$/) {
+	    $lc_ctype = $1;
+	} elsif (/^LC_COLLATE\W*(\S+)\s*$/) {
+	    $lc_collate = $1;
+	}
+    }
+    close CTRL;
+    return ($lc_ctype, $lc_collate);
+}
+
+# Return the pg_control data for a cluster
+# Arguments: <version> <cluster>
+# Returns: hashref
+sub get_cluster_controldata {
+    my ($version, $cluster) = @_;
+
+    my $pg_controldata = get_program_path 'pg_controldata', $version;
+    if (! -e $pg_controldata) {
+        print STDERR "Error: pg_controldata not found, please install postgresql-$version\n";
+        exit 1;
+    }
+    prepare_exec ('LC_ALL', 'LANG', 'LANGUAGE');
+    $ENV{'LC_ALL'} = 'C';
+    my $result = open (CTRL, '-|', $pg_controldata, (cluster_data_directory $version, $cluster));
+    restore_exec;
+    return undef unless defined $result;
+    my $data = {};
+    while (<CTRL>) {
+	if (/^(.+?):\s*(.*)/) {
+            $data->{$1} = $2;
+	} else {
+            error "Invalid pg_controldata output: $_";
+	}
+    }
+    close CTRL;
+    return $data;
+}
+
+# Return an array with all databases of a cluster. This requires connection
+# privileges to template1, so this function should be called as the
+# cluster owner.
+# Arguments: <version> <cluster>
+# Returns: array of database names or undef on error.
+sub get_cluster_databases {
+    my ($version, $cluster) = @_;
+    my $port = get_cluster_port $version, $cluster;
+    my $socketdir = get_cluster_socketdir $version, $cluster;
+    my $psql = get_program_path 'psql';
+    return undef unless ($port && $socketdir && $psql);
+
+    # try to swich to cluster owner
+    prepare_exec 'LC_ALL';
+    $ENV{'LC_ALL'} = 'C';
+    my $orig_euid = $>;
+    $> = (stat (cluster_data_directory $version, $cluster))[4];
+
+    my @dbs;
+    my @fields;
+    if (open PSQL, '-|', $psql, '-h', $socketdir, '-p', $port, '-AXtl') {
+        while (<PSQL>) {
+            chomp;
+            @fields = split '\|';
+            next if $#fields < 2; # remove access privs which get line broken
+            push (@dbs, $fields[0]);
+        }
+        close PSQL;
+    }
+
+    $> = $orig_euid;
+    restore_exec;
+
+    return $? ? undef : @dbs;
+}
+
+# Return the device name a file is stored at.
+# Arguments: <file path>
+# Returns:  device name, or '' if it cannot be determined.
+sub get_file_device {
+    my $dev = '';
+    prepare_exec;
+    my $pid = open3(\*CHLD_IN, \*CHLD_OUT, \*CHLD_ERR, '/bin/df', $_[0]);
+    waitpid $pid, 0; # we simply ignore exit code and stderr
+    while (<CHLD_OUT>) {
+	if (/^\/dev/) {
+	    $dev = (split)[0];
+	}
+    }
+    restore_exec;
+    close CHLD_IN;
+    close CHLD_OUT;
+    close CHLD_ERR;
+    return $dev;
+}
+
+
+# Parse a single pg_hba.conf line.
+# Arguments: <line>
+# Returns: Hash reference (only returns line and type==undef for invalid lines)
+# line -> the verbatim pg_hba line
+# type -> comment, local, host, hostssl, hostnossl, undef
+# db -> database name
+# user -> user name
+# method -> trust, reject, md5, crypt, password, krb5, ident, pam
+# ip -> ip address
+# mask -> network mask (either a single number as number of bits, or bit mask)
+sub parse_hba_line {
+    my $l = $_[0];
+    chomp $l;
+
+    # comment line?
+    return { 'type' => 'comment', 'line' => $l } if ($l =~ /^\s*($|#)/);
+
+    my $res = { 'line' => $l };
+    my @tok = split /\s+/, $l;
+    goto error if $#tok < 3;
+
+    $$res{'type'} = shift @tok;
+    $$res{'db'} = shift @tok;
+    $$res{'user'} = shift @tok;
+
+    # local connection?
+    if ($$res{'type'} eq 'local') {
+	goto error if $#tok > 1;
+	goto error unless valid_hba_method($tok[0]);
+	$$res{'method'} = join (' ', @tok);
+	return $res;
+    }
+
+    # host connection?
+    if ($$res{'type'} =~ /^host((no)?ssl)?$/) {
+	my ($i, $c) = split '/', (shift @tok);
+	goto error unless $i;
+	$$res{'ip'} = $i;
+
+	# CIDR mask given?
+	if (defined $c) {
+	    goto error if $c !~ /^(\d+)$/;
+	    $$res{'mask'} = $c;
+	} else {
+	    $$res{'mask'} = shift @tok;
+	}
+
+	goto error if $#tok > 1;
+	goto error unless valid_hba_method($tok[0]);
+	$$res{'method'} = join (' ', @tok);
+	return $res;
+    }
+
+error:
+    $$res{'type'} = undef;
+    return $res;
+}
+
+# Parse given pg_hba.conf file.
+# Arguments: <pg_hba.conf path>
+# Returns: Array with hash refs; for hash contents, see parse_hba_line().
+sub read_pg_hba {
+    open HBA, $_[0] or return undef;
+    my @hba;
+    while (<HBA>) {
+	my $r = parse_hba_line $_;
+	push @hba, $r;
+    }
+    close HBA;
+    return @hba;
+}
+
+# Check if hba method is known
+# Argument: hba method
+# Returns: True if method is valid
+sub valid_hba_method {
+    my $method = $_[0];
+
+    my %valid_methods = qw/trust 1 reject 1 md5 1 crypt 1 password 1 krb5 1 ident 1 pam 1/;
+
+    return exists($valid_methods{$method});
+}
+
+1;