summaryrefslogtreecommitdiffstats
path: root/PgCommon.pm
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--PgCommon.pm1665
1 files changed, 1665 insertions, 0 deletions
diff --git a/PgCommon.pm b/PgCommon.pm
new file mode 100644
index 0000000..e51d89e
--- /dev/null
+++ b/PgCommon.pm
@@ -0,0 +1,1665 @@
+=head1 NAME
+
+PgCommon - Common functions for the postgresql-common framework
+
+=head1 COPYRIGHT AND LICENSE
+
+ (C) 2008-2009 Martin Pitt <mpitt@debian.org>
+ (C) 2012-2022 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
+L<version 2 of the License|https://www.gnu.org/licenses/old-licenses/gpl-2.0.html>,
+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.
+
+=cut
+
+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 validate_cluster_owner get_versions get_newest_version version_exists
+ get_version_clusters next_free_port cluster_exists install_file
+ change_ugid system_or_error config_bool replace_v_c
+ 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/;
+
+
+=head1 CONTENTS
+
+=head2 error
+
+ Print an error message to stderr and die with exit status 1
+
+=cut
+
+sub error {
+ $! = 1; # force exit code 1
+ die "Error: $_[0]\n";
+}
+
+=head2 prepare_exec, restore_exec
+
+ Functions for configuration
+
+=cut
+
+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{$_};
+ }
+ }
+ }
+}
+
+
+=head2 config_bool
+
+ 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.
+
+=cut
+
+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;
+}
+
+
+=head2 quote_conf_value
+
+ Quotes a value with single quotes
+
+ Arguments: <value>
+ Returns: quoted string
+
+=cut
+
+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'";
+}
+
+
+=head2 replace_v_c
+
+ Replaces %v and %c placeholders
+
+ Arguments: <string> <version> <cluster>
+ Returns: string
+
+=cut
+
+sub replace_v_c ($$$) {
+ my ($str, $version, $cluster) = @_;
+ $str =~ s/%([vc%])/$1 eq 'v' ? $version :
+ $1 eq 'c' ? $cluster : '%'/eg;
+ return $str;
+}
+
+
+=head2 read_conf_file
+
+ 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)
+
+=cut
+
+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;
+}
+
+=head2 cluster_conf_filename
+
+ 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)
+
+=cut
+
+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;
+}
+
+
+=head2 read_cluster_conf_file
+
+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)
+
+=cut
+
+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;
+}
+
+
+=head2 get_conf_value
+
+ Return parameter from a PostgreSQL configuration file,
+ or undef if the parameter does not exist.
+
+ Arguments: <version> <cluster> <config file name> <parameter name>
+
+=cut
+
+sub get_conf_value {
+ my %conf = (read_cluster_conf_file $_[0], $_[1], $_[2]);
+ return $conf{$_[3]};
+}
+
+
+=head2 set_conffile_value
+
+ Set parameter of a PostgreSQL configuration file.
+
+ Arguments: <config file name> <parameter name> <value>
+
+=cut
+
+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: $!";
+}
+
+
+=head2 set_conf_value
+
+ Set parameter of a PostgreSQL cluster configuration file.
+
+ Arguments: <version> <cluster> <config file name> <parameter name> <value>
+
+=cut
+
+sub set_conf_value {
+ return set_conffile_value(cluster_conf_filename($_[0], $_[1], $_[2]), $_[3], $_[4]);
+}
+
+
+=head2 disable_conffile_value
+
+ 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>
+
+=cut
+
+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";
+ }
+}
+
+
+=head2 disable_conf_value
+
+ 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>
+
+=cut
+
+sub disable_conf_value {
+ return disable_conffile_value(cluster_conf_filename($_[0], $_[1], $_[2]), $_[3], $_[4]);
+}
+
+
+=head2 replace_conf_value
+
+ 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>
+
+=cut
+
+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";
+}
+
+
+=head2 get_cluster_port
+
+ Return the port of a particular cluster
+
+ Arguments: <version> <cluster>
+
+=cut
+
+sub get_cluster_port {
+ return get_conf_value($_[0], $_[1], 'postgresql.conf', 'port') || $defaultport;
+}
+
+
+=head2 set_cluster_port
+
+ Set the port of a particular cluster.
+
+ Arguments: <version> <cluster> <port>
+
+=cut
+
+sub set_cluster_port {
+ set_conf_value $_[0], $_[1], 'postgresql.conf', 'port', $_[2];
+}
+
+
+=head2 cluster_data_directory
+
+ Return cluster data directory.
+
+ Arguments: <version> <cluster name> [<config_hash>]
+
+=cut
+
+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;
+}
+
+
+=head2 get_cluster_socketdir
+
+ Return the socket directory of a particular cluster
+ or undef if the cluster does not exist.
+
+ Arguments: <version> <cluster>
+
+=cut
+
+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;
+}
+
+
+=head2 set_cluster_socketdir
+
+ Set the socket directory of a particular cluster.
+
+ Arguments: <version> <cluster> <directory>
+
+=cut
+
+sub set_cluster_socketdir {
+ set_conf_value $_[0], $_[1], 'postgresql.conf',
+ $_[0] >= 9.3 ? 'unix_socket_directories' : 'unix_socket_directory',
+ $_[2];
+}
+
+
+=head2 get_program_path
+
+ Return the path of a program of a particular version.
+
+ Arguments: <program name> [<version>]
+
+=cut
+
+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 '';
+}
+
+
+=head2 cluster_port_running
+
+ Check whether a postgres server is running at the specified port.
+
+ Arguments: <version> <cluster> <port>
+
+=cut
+
+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;
+}
+
+
+=head2 get_cluster_start_conf
+
+ Read, verify, and return the current start.conf setting.
+
+ Arguments: <version> <cluster>
+ Returns: auto | manual | disabled
+
+=cut
+
+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
+}
+
+
+=head2 set_cluster_start_conf
+
+ Change start.conf setting.
+
+ Arguments: <version> <cluster> <value>
+ <value> = auto | manual | disabled
+
+=cut
+
+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;
+}
+
+
+=head2 set_cluster_pg_ctl_conf
+
+ Change pg_ctl.conf setting.
+
+ Arguments: <version> <cluster> <options>
+ <options> = options passed to pg_ctl(1)
+
+=cut
+
+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;
+}
+
+
+=head2 read_pidfile
+
+ Return the PID from an existing PID file or undef if it does not exist.
+
+ Arguments: <pid file path>
+
+=cut
+
+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;
+ }
+}
+
+
+=head2 check_pidfile_running
+
+ Check whether a pid file is present and belongs to a running postgres.
+ Returns undef if it cannot be determined
+
+ Arguments: <pid file path>
+
+ 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
+
+=cut
+
+sub check_pidfile_running {
+ 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;
+}
+
+
+=head2 cluster_supervisor
+
+ Determine if a cluster is managed by a supervisor (pacemaker, patroni).
+ Returns undef if it cannot be determined
+
+ Arguments: <pid file path>
+
+ 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
+
+=cut
+
+sub cluster_supervisor {
+ 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;
+}
+
+
+=head2 cluster_info
+
+ 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)
+
+=cut
+
+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;
+}
+
+
+=head2 validate_cluster_owner
+
+ Checks if the owner of a cluster is valid, and the owner of the config matches
+ the owner of the data directory.
+
+ Arguments: cluster_info hash reference
+
+=cut
+
+sub validate_cluster_owner($) {
+ my $info = shift;
+
+ unless ($info->{pgdata}) {
+ error "Cluster data directory is unknown";
+ }
+ unless (-d $info->{pgdata}) {
+ error "$info->{pgdata} is not accessible or does not exist";
+ }
+ unless (defined $info->{owneruid}) {
+ error "Could not determine owner of $info->{pgdata}";
+ }
+ if ($info->{owneruid} == 0) {
+ error "Data directory $info->{pgdata} must not be owned by root";
+ }
+ unless (getpwuid $info->{owneruid}) {
+ error "The cluster is owned by user id $info->{owneruid} which does not exist";
+ }
+ unless (getgrgid $info->{ownergid}) {
+ error "The cluster is owned by group id $info->{ownergid} which does not exist";
+ }
+ # owneruid and configuid need to match, unless configuid is root
+ if (($< == 0 or $> == 0) and $info->{configuid} != 0 and
+ $info->{configuid} != $info->{owneruid}) {
+ my $configowner = (getpwuid $info->{configuid})[0] || "(unknown)";
+ my $dataowner = (getpwuid $info->{owneruid})[0];
+ error "Config owner ($configowner:$info->{configuid}) and data owner ($dataowner:$info->{owneruid}) do not match, and config owner is not root";
+ }
+}
+
+
+=head2 get_versions
+
+ Return an array of all available versions (by binaries and postgresql.conf files)
+
+ Arguments: binary to scan for (optional, defaults to postgres), maximum acceptable version (optional)
+
+=cut
+
+sub get_versions {
+ my $program = shift // 'postgres';
+ my $max_version = shift;
+ 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-";
+ my $version;
+ ($version) = $entry =~ /^$pfx(\d+\.?\d+)$/; # untaint
+ next if ($max_version and $version > $max_version);
+ $versions{$version} = 1 if $version and get_program_path ($program, $version);
+ }
+ 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);
+ next if ($max_version and $v > $max_version);
+
+ 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;
+}
+
+
+=head2 get_newest_version
+
+ Return the newest available version
+
+ Arguments: binary to scan for (optional), maximum acceptable version (optional)
+
+=cut
+
+sub get_newest_version {
+ my $program = shift;
+ my $max_version = shift;
+ my @versions = get_versions($program, $max_version);
+ return undef unless (@versions);
+ return $versions[-1];
+}
+
+=head2 version_exists
+
+ Check whether a version exists
+
+=cut
+
+sub version_exists {
+ my ($version) = @_;
+ return get_program_path ('psql', $version);
+}
+
+
+=head2 get_version_clusters
+
+ Return an array of all available clusters of given version
+
+ Arguments: <version>
+
+=cut
+
+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;
+}
+
+
+=head2 cluster_exists
+
+ Check if a cluster exists.
+
+ Arguments: <version> <cluster>
+
+=cut
+
+sub cluster_exists {
+ for my $c (get_version_clusters $_[0]) {
+ return 1 if $c eq $_[1];
+ }
+ return 0;
+}
+
+
+=head2 next_free_port
+
+ Return the next free PostgreSQL port.
+
+=cut
+
+sub next_free_port {
+ # create list of already used ports
+ my %ports;
+ for my $v (get_versions) {
+ for my $c (get_version_clusters $v) {
+ $ports{ get_cluster_port ($v, $c) } = 1;
+ }
+ }
+
+ my $port;
+ for ($port = $defaultport; $port < 65536; ++$port) {
+ # port in use by existing cluster
+ next if (exists $ports{$port});
+
+ # IPv4 port in use
+ my ($have_ip4, $have_ip6);
+ if (socket (SOCK, PF_INET, SOCK_STREAM, getprotobyname('tcp'))) {
+ $have_ip4 = 1;
+ setsockopt(SOCK, Socket::SOL_SOCKET, Socket::SO_REUSEADDR, 1) or error "setsockopt: $!";
+ my $res4 = bind (SOCK, sockaddr_in($port, INADDR_ANY)) and listen (SOCK, 0);
+ my $err = $!;
+ close SOCK;
+ next unless ($res4);
+ }
+
+ # IPv6 port in use
+ if (exists $Socket::{"IN6ADDR_ANY"}) {
+ if (socket (SOCK, PF_INET6, SOCK_STREAM, getprotobyname('tcp'))) {
+ $have_ip6 = 1;
+ setsockopt(SOCK, Socket::SOL_SOCKET, Socket::SO_REUSEADDR, 1) or error "setsockopt: $!";
+ my $res6 = bind (SOCK, sockaddr_in6($port, Socket::IN6ADDR_ANY)) and listen (SOCK, 0);
+ my $err = $!;
+ close SOCK;
+ next unless ($res6);
+ }
+ }
+
+ 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;
+ }
+
+ die "no free port found";
+}
+
+
+=head2 user_cluster_map
+
+ 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.
+
+=cut
+
+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);
+}
+
+
+=head2 install_file
+
+ Copy a file to a destination and setup permissions
+
+ Arguments: <source file> <destination file or dir> <uid> <gid> <permissions>
+
+=cut
+
+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";
+ }
+}
+
+
+=head2 change_ugid
+
+ 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>
+
+=cut
+
+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;
+}
+
+
+=head2 system_or_error
+
+ Run a command and error out if it exits with a non-zero status.
+
+ Arguments: <command ...>
+
+=cut
+
+sub system_or_error {
+ my $ret = system @_;
+ if ($ret) {
+ my $message = "@_ failed with exit code $ret";
+ $message .= ": $!" if ($!);
+ error $message;
+ }
+}
+
+
+=head2 get_db_encoding
+
+ 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.
+
+=cut
+
+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', $version;
+ 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;
+}
+
+
+=head2 get_db_locales
+
+ 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.
+
+=cut
+
+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', $version;
+ 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);
+}
+
+
+=head2 get_cluster_locales
+
+ 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.
+
+=cut
+
+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);
+}
+
+
+=head2 get_cluster_controldata
+
+ Return the pg_control data for a cluster
+
+ Arguments: <version> <cluster>
+ Returns: hashref
+
+=cut
+
+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;
+}
+
+
+=head2 get_cluster_databases
+
+ 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.
+
+=cut
+
+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', $version;
+ 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;
+}
+
+
+=head2 get_file_device
+
+ Return the device name a file is stored at.
+
+ Arguments: <file path>
+ Returns: device name, or '' if it cannot be determined.
+
+=cut
+
+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;
+}
+
+
+=head2 parse_hba_line
+
+ Parse a single pg_hba.conf line.
+
+ Arguments: <line>
+ Returns: Hash reference (or only line and type==undef for invalid lines)
+
+=over 4
+
+=item *
+
+line -> the verbatim pg_hba line
+
+=item *
+
+type -> comment, local, host, hostssl, hostnossl, undef
+
+=item *
+
+db -> database name
+
+=item *
+
+user -> user name
+
+=item *
+
+method -> trust, reject, md5, crypt, password, krb5, ident, pam
+
+=item *
+
+ip -> ip address
+
+=item *
+
+mask -> network mask (either a single number as number of bits, or bit mask)
+
+=back
+
+=cut
+
+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;
+}
+
+
+=head2 read_pg_hba
+
+ Parse given pg_hba.conf file.
+
+ Arguments: <pg_hba.conf path>
+ Returns: Array with hash refs; for hash contents, see parse_hba_line().
+
+=cut
+
+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;
+}
+
+
+=head2 valid_hba_method
+
+ Check if hba method is known
+
+ Argument: hba method
+ Returns: True if method is valid
+
+=cut
+
+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;