Website : rimsha.abasa.com
backdoor
Home
Console
Upload
information
Create File
Create Folder
About
Tools
:
/
usr
/
share
/
perl5
/
Filename :
PgCommon.pm
back
Copy
=head1 NAME PgCommon - Common functions for the postgresql-common framework =head1 COPYRIGHT AND LICENSE (C) 2008-2009 Martin Pitt <mpitt@debian.org> (C) 2012-2021 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) =cut 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; } =head2 get_newest_version Return the newest available version Arguments: binary to scan for (optional) =cut sub get_newest_version { my $program = shift // undef; my @versions = get_versions($program); 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) { 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"; } =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'; 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'; 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'; 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;