PgCommon.pm 37.3 KB
Newer Older
1
# Common functions for the postgresql-common framework
2 3
#
# (C) 2008-2009 Martin Pitt <mpitt@debian.org>
4
# (C) 2012-2019 Christoph Berg <myon@debian.org>
5 6 7 8 9 10 11 12 13 14
#
#  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.
15 16

package PgCommon;
17
use strict;
18
use IPC::Open3;
19
use Socket;
20
use POSIX;
21 22

use Exporter;
23 24 25
our $VERSION = 1.00;
our @ISA = ('Exporter');
our @EXPORT = qw/error user_cluster_map get_cluster_port set_cluster_port
26
    get_cluster_socketdir set_cluster_socketdir cluster_port_running
27
    get_cluster_start_conf set_cluster_start_conf set_cluster_pg_ctl_conf
28
    get_program_path cluster_info get_versions get_newest_version version_exists
29
    get_version_clusters next_free_port cluster_exists install_file
30
    change_ugid config_bool get_db_encoding get_db_locales get_cluster_locales get_cluster_controldata
31 32
    get_cluster_databases cluster_conf_filename read_cluster_conf_file
    read_pg_hba read_pidfile valid_hba_method/;
33
our @EXPORT_OK = qw/$confroot $binroot $rpm quote_conf_value read_conf_file get_conf_value
34
    set_conf_value set_conffile_value disable_conffile_value disable_conf_value
35
    replace_conf_value cluster_data_directory get_file_device
36
    check_pidfile_running/;
37

38 39 40 41 42 43
# Print an error message to stderr and exit with status 1
sub error {
    print STDERR 'Error: ', $_[0], "\n";
    exit 1;
}

44 45 46 47 48
# configuration
our $confroot = '/etc/postgresql';
if ($ENV{'PG_CLUSTER_CONF_ROOT'}) {
    ($confroot) = $ENV{'PG_CLUSTER_CONF_ROOT'} =~ /(.*)/; # untaint
}
49 50 51 52 53
our $common_confdir = "/etc/postgresql-common";
if ($ENV{'PGSYSCONFDIR'}) {
    ($common_confdir) = $ENV{'PGSYSCONFDIR'} =~ /(.*)/; # untaint
}
my $mapfile = "$common_confdir/user_clusters";
54 55
our $binroot = "/usr/lib/postgresql/";
#redhat# $binroot = "/usr/pgsql-";
56 57
our $rpm = 0;
#redhat# $rpm = 1;
58
our $defaultport = 5432;
59

60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80
{
    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) {
81 82 83 84 85
	    if (defined $saved_env{$_}) {
		$ENV{$_} = $saved_env{$_};
	    } else {
		delete $ENV{$_};
	    }
86 87 88 89
	}
    }
}

90 91 92 93 94 95 96 97 98 99
# 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;
}

100 101 102 103 104
# Quotes a value with single quotes
# Arguments: <value>
# Returns: quoted string
sub quote_conf_value ($) {
    my $value = shift;
105
    return $value if ($value =~ /^-?[\d.]+$/); # integer or float
106
    return $value if ($value =~ /^\w+$/); # plain word
107
    $value =~ s/'/''/g; # else quote it
108 109 110
    return "'$value'";
}

111 112
# Read a 'var = value' style configuration file and return a hash with the
# values. Error out if the file cannot be read.
113 114 115
# 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).
116 117 118
# Arguments: <path>
# Returns: hash (empty if file does not exist)
sub read_conf_file {
119
    my ($config_path) = @_;
120
    my %conf;
121
    local (*F);
122

123 124 125 126 127 128 129 130 131
    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) {
132
        while (<F>) {
133 134
            if (/^\s*(?:#.*)?$/) {
                next;
135
            } elsif(/^\s*include_dir\s*=?\s*'([^']+)'\s*(?:#.*)?$/i) {
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150
                # 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);
151
            } elsif (/^\s*include(?:_if_exists)?\s*=?\s*'([^']+)'\s*(?:#.*)?$/i) {
152 153 154 155 156 157 158
                # 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;
                }
159
            } elsif (/^\s*([a-zA-Z0-9_.-]+)\s*(?:=|\s)\s*'((?:[^']|''|(?:(?<=\\)'))*)'\s*(?:#.*)?$/i) {
160
                # string value
161
                my $v = $2;
162
                my $k = $1;
163
                $k = lc $k if $config_path =~ /\.conf$/;
164
                $v =~ s/\\(.)/$1/g;
165
                $v =~ s/''/'/g;
166
                $conf{$k} = $v;
167 168
            } elsif (m{^\s*([a-zA-Z0-9_.-]+)\s*(?:=|\s)\s*(-?[[:alnum:]][[:alnum:]._:/+-]*)\s*(?:\#.*)?$}i) {
                # simple value (string/float)
169
                my $v = $2;
170 171
                my $k = $1;
                $k = lc $k if $config_path =~ /\.conf$/;
172
                $conf{$k} = $v;
173
            } else {
174
                chomp;
175
                error "invalid line $. in $config_path: $_";
176
            }
177 178
        }
        close F;
179
    }
180 181 182 183

    return %conf;
}

184
# Returns path to cluster config file from a cluster configuration
185 186
# directory (with /etc/postgresql-common/<file name> as fallback) and return a
# hash with the values. Error out if the file cannot be read.
187
# If config file name is postgresql.auto.conf, read from PGDATA
188 189
# Arguments: <version> <cluster> <config file name>
# Returns: hash (empty if the file does not exist)
190
sub cluster_conf_filename {
191
    my ($version, $cluster, $configfile) = @_;
192 193 194 195 196
    if ($configfile eq 'postgresql.auto.conf') {
        my $data_directory = cluster_data_directory($version, $cluster);
        return "$data_directory/$configfile";
    }
    my $fname = "$confroot/$version/$cluster/$configfile";
197
    -e $fname or $fname = "$common_confdir/$configfile";
198 199 200 201 202 203 204 205 206
    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));
207

208
    if ($version >= 9.4 and $configfile eq 'postgresql.conf') { # merge settings changed by ALTER SYSTEM
209
        # data_directory cannot be changed by ALTER SYSTEM
210
        my $data_directory = cluster_data_directory($version, $cluster, \%conf);
211 212 213 214 215 216 217
        my %auto_conf = read_conf_file "$data_directory/postgresql.auto.conf";
        foreach my $guc (keys %auto_conf) {
            $conf{$guc} = $auto_conf{$guc};
        }
    }

    return %conf;
218 219 220 221 222 223 224 225
}

# 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]};
226 227
}

228
# Set parameter of a PostgreSQL configuration file.
229
# Arguments: <config file name> <parameter name> <value>
230 231
sub set_conffile_value {
    my ($fname, $key, $value) = ($_[0], $_[1], quote_conf_value($_[2]));
232
    my @lines;
233

234 235 236 237 238 239
    # 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;
240
    # first, search for an uncommented setting
241
    for (my $i=0; $i <= $#lines; ++$i) {
242 243
	if ($lines[$i] =~ /^\s*($key)(\s*(?:=|\s)\s*)\w+\b((?:\s*#.*)?)/i or
	    $lines[$i] =~ /^\s*($key)(\s*(?:=|\s)\s*)'[^']*'((?:\s*#.*)?)/i) {
244
	    $lines[$i] = "$1$2$value$3\n";
245
	    $found = 1;
246
	    last;
247
	}
248
    }
249 250 251 252 253

    # 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) {
254 255
	    if ($lines[$i] =~ /^\s*#\s*($key)(\s*(?:=|\s)\s*)\w+\b((?:\s*#.*)?)/i or
		$lines[$i] =~ /^\s*#\s*($key)(\s*(?:=|\s)\s*)'[^']*'((?:\s*#.*)?)/i) {
256
		$lines[$i] = "$1$2$value$3\n";
257 258 259 260 261 262 263
		$found = 1;
		last;
	    }
	}
    }

    # not found anywhere, append it
264
    push (@lines, "$key = $value\n") unless $found;
265 266

    # write configuration file lines
267
    open (F, ">$fname.new") or die "Error: could not open $fname.new for writing";
268
    foreach (@lines) {
269
	print F $_ or die "writing $fname.new: $!";
270
    }
271
    close F;
272 273 274 275

    # copy permissions
    my @st = stat $fname or die "stat: $!";
    chown $st[4], $st[5], "$fname.new"; # might fail as non-root
276 277 278 279
    chmod $st[2], "$fname.new" or die "chmod: $!";

    rename "$fname.new", "$fname" or die "rename $fname.new $fname: $!";
}
280

281 282 283
# Set parameter of a PostgreSQL cluster configuration file.
# Arguments: <version> <cluster> <config file name> <parameter name> <value>
sub set_conf_value {
284
    return set_conffile_value(cluster_conf_filename($_[0], $_[1], $_[2]), $_[3], $_[4]);
285 286
}

287 288
# Disable a parameter in a PostgreSQL configuration file by prepending it with
# a '#'. Appends an optional explanatory comment <reason> if given.
289 290 291
# Arguments: <config file name> <parameter name> <reason>
sub disable_conffile_value {
    my ($fname, $key, $reason) = @_;
292 293 294 295 296 297 298 299 300
    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) {
301 302 303
	if ($lines[$i] =~ /^\s*$key\s*(?:=|\s)/i) {
            $lines[$i] =~ s/^/#/;
            $lines[$i] =~ s/$/ #$reason/ if $reason;
304 305 306 307 308 309 310
            $changed = 1;
	    last;
	}
    }

    # write configuration file lines
    if ($changed) {
311
        open (F, ">$fname.new") or die "Error: could not open $fname.new for writing";
312
        foreach (@lines) {
313
	    print F $_ or die "writing $fname.new: $!";
314 315
        }
        close F;
316 317 318 319 320 321

	# 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";

322
	rename "$fname.new", "$fname";
323 324 325
    }
}

326 327 328 329
# 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 {
330
    return disable_conffile_value(cluster_conf_filename($_[0], $_[1], $_[2]), $_[3], $_[4]);
331 332
}

333 334 335 336 337 338 339
# 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) = @_;
340
    my $fname = cluster_conf_filename($version, $cluster, $configfile);
341 342 343 344 345 346 347 348 349 350 351 352 353 354
    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) {
355
	if ($lines[$i] =~ /^\s*$oldparam\s*(?:=|\s)/i) {
356 357 358 359 360 361 362 363 364 365 366 367 368
	    $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;
	}
    }

369
    return if !$found;
370 371

    # write configuration file lines
372
    open (F, ">$fname.new") or die "Error: could not open $fname.new for writing";
373
    foreach (@lines) {
374
	print F $_ or die "writing $fname.new: $!";
375 376
    }
    close F;
377 378 379 380 381 382

    # 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";

383
    rename "$fname.new", "$fname";
384 385
}

386
# Return the port of a particular cluster
387 388
# Arguments: <version> <cluster>
sub get_cluster_port {
389
    return get_conf_value($_[0], $_[1], 'postgresql.conf', 'port') || $defaultport;
390 391
}

392
# Set the port of a particular cluster.
393 394 395 396 397
# Arguments: <version> <cluster> <port>
sub set_cluster_port {
    set_conf_value $_[0], $_[1], 'postgresql.conf', 'port', $_[2];
}

398
# Return cluster data directory.
399
# Arguments: <version> <cluster name> [<config_hash>]
400
sub cluster_data_directory {
401 402 403 404 405 406
    my $d;
    if ($_[2]) {
        $d = ${$_[2]}{'data_directory'};
    } else {
        $d = get_conf_value($_[0], $_[1], 'postgresql.conf', 'data_directory');
    }
407
    my $confdir = "$confroot/$_[0]/$_[1]";
408 409
    if (!$d) {
        # fall back to /pgdata symlink (supported by earlier p-common releases)
410 411 412 413 414 415 416
        $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;
417
    }
418 419
    ($d) = $d =~ /(.*)/ if defined $d; #untaint
    return $d;
420 421
}

422 423 424 425
# Return the socket directory of a particular cluster or undef if the cluster
# does not exist.
# Arguments: <version> <cluster>
sub get_cluster_socketdir {
426 427
    # if it is explicitly configured, just return it
    my $socketdir = get_conf_value($_[0], $_[1], 'postgresql.conf',
428
        $_[0] >= 9.3 ? 'unix_socket_directories' : 'unix_socket_directory');
429
    $socketdir =~ s/\s*,.*// if ($socketdir); # ignore additional directories for now
430
    return $socketdir if $socketdir;
431

432
    #redhat# return '/tmp'; # RedHat PGDG packages default to /tmp
433 434 435 436
    # 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;
437

438 439 440 441
    error "Cannot stat $socketdir" unless @socketdirstat;

    if ($_[0] && $_[1]) {
        my $datadir = cluster_data_directory $_[0], $_[1];
442
        error "Invalid data directory for cluster $_[0] $_[1]" unless $datadir;
443
        my @datadirstat = stat $datadir;
444 445 446 447 448
        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;
        }
449 450

        $socketdir = '/tmp' if $socketdirstat[4] != $datadirstat[4];
451
    }
452 453

    return $socketdir;
454 455
}

456
# Set the socket directory of a particular cluster.
457 458
# Arguments: <version> <cluster> <directory>
sub set_cluster_socketdir {
459 460 461
    set_conf_value $_[0], $_[1], 'postgresql.conf',
        $_[0] >= 9.3 ? 'unix_socket_directories' : 'unix_socket_directory',
        $_[2];
462 463
}

464 465 466
# Return the path of a program of a particular version.
# Arguments: <program name> <version>
sub get_program_path {
467
    return '' unless defined($_[0]) && defined($_[1]);
468
    my $path = "$binroot$_[1]/bin/$_[0]";
469
    ($path) = $path =~ /(.*)/; #untaint
470 471 472 473
    return $path if -x $path;
    return '';
}

474
# Check whether a postgres server is running at the specified port.
475
# Arguments: <version> <cluster> <port>
476
sub cluster_port_running {
477
    die "port_running: invalid port $_[2]" if $_[2] !~ /\d+/;
478 479 480 481 482 483 484 485
    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;
486 487
}

488 489 490 491 492
# 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";
493 494 495 496 497 498 499
    if (-e $start_conf) {
	open F, $start_conf or error "Could not open $start_conf: $!";
	while (<F>) {
	    s/#.*$//;
	    s/^\s*//;
	    s/\s*$//;
	    next unless $_;
500 501 502
            close F;
            return $1 if (/^(auto|manual|disabled)/);
            error "Invalid mode in $start_conf, must be one of auto, manual, disabled";
503 504 505
	}
	close F;
    }
506
    return 'auto'; # default
507 508
}

509 510 511 512 513 514
# Change start.conf setting.
# Arguments: <version> <cluster> <value>
# <value> = auto | manual | disabled
sub set_cluster_start_conf {
    my ($v, $c, $val) = @_;

515
    error "Invalid mode: '$val'" unless $val eq 'auto' ||
516 517
	    $val eq 'manual' || $val eq 'disabled';

518 519
    my $perms = 0644;

520 521 522 523 524 525 526 527 528 529 530 531
    # 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 .= $_;
            }
	}
532 533 534 535

        # preserve permissions if it already exists
        $perms = (stat F)[2];
        error "Could not get permissions of $start_conf: $!" unless $perms;
536 537 538
	close F;
    } else {
        $text = "# Automatic startup configuration
539 540 541 542 543
#   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.
544 545 546 547 548 549

$val
";
    }

    open F, '>' . $start_conf or error "Could not open $start_conf for writing: $!";
550
    chmod $perms, $start_conf;
551 552 553 554
    print F $text;
    close F;
}

555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576
# 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;
}

577 578 579 580 581 582 583 584
# 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;
585
        return undef unless ($pid);
586 587 588 589 590 591 592 593
        chomp $pid;
        ($pid) = $pid =~ /^(\d+)\s*$/; # untaint
	return $pid;
    } else {
	return undef;
    }
}

594
# Check whether a pid file is present and belongs to a running postgres.
595 596 597
# Returns undef if it cannot be determined
# Arguments: <pid file path>
sub check_pidfile_running {
598
    # postgres does not clean up the PID file when it stops, and it is
599 600 601 602 603 604 605
    # 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) {
606
	prepare_exec;
607
        my $res = open PS, '-|', '/bin/ps', '-o', 'comm=', '-p', $pid;
608 609
	restore_exec;
	if ($res) {
610 611 612
	    my $process = <PS>;
	    chomp $process if defined $process;
	    close PS;
613
            if (defined $process and ($process eq 'postgres')) {
614 615 616 617 618
                return 1;
            } else {
		return 0;
	    }
        } else {
619
            error "Could not exec /bin/ps";
620 621 622 623 624
        }
    }
    return undef;
}

625
# Return a hash with information about a specific cluster (which needs to exist).
626
# Arguments: <version> <cluster name>
627
# Returns: information hash (keys: pgdata, port, running, logfile [unless it
628
#          has a custom one], configdir, owneruid, ownergid, waldir, socketdir,
629
#          config->postgresql.conf)
630
sub cluster_info {
631 632
    my ($v, $c) = @_;
    error 'cluster_info must be called with <version> <cluster> arguments' unless ($v and $c);
633

634
    my %result;
635 636 637 638
    $result{'configdir'} = "$confroot/$v/$c";
    $result{'configuid'} = (stat "$result{configdir}/postgresql.conf")[4];

    my %postgresql_conf = read_cluster_conf_file $v, $c, 'postgresql.conf';
639
    $result{'config'} = \%postgresql_conf;
640
    $result{'pgdata'} = cluster_data_directory $v, $c, \%postgresql_conf;
641
    return %result unless (keys %postgresql_conf);
642
    $result{'port'} = $postgresql_conf{'port'} || $defaultport;
643
    $result{'socketdir'} = get_cluster_socketdir  $v, $c;
644

645
    # if we can determine the running status with the pid file, prefer that
646
    if ($postgresql_conf{'external_pid_file'} &&
647 648 649 650 651 652 653
	$postgresql_conf{'external_pid_file'} ne '(none)') {
	$result{'running'} = check_pidfile_running $postgresql_conf{'external_pid_file'};
    }

    # 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'})) {
654
	$result{'running'} = cluster_port_running ($v, $c, $result{'port'});
655 656
    }

657
    if ($result{'pgdata'}) {
658
        ($result{'owneruid'}, $result{'ownergid'}) =
659
            (stat $result{'pgdata'})[4,5];
660
        $result{'recovery'} = 1 if (-e "$result{'pgdata'}/recovery.conf");
661 662 663 664
        my $waldirname = $v >= 10 ? 'pg_wal' : 'pg_xlog';
        if (-l "$result{pgdata}/$waldirname") { # custom wal directory
            ($result{waldir}) = readlink("$result{pgdata}/$waldirname") =~ /(.*)/; # untaint
        }
665
    }
666
    $result{'start'} = get_cluster_start_conf $v, $c;
667

668 669 670 671
    # 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
672
    } else {
673
        $result{'logfile'} = "/var/log/postgresql/postgresql-$v-$c.log";
674
    }
675

676 677 678
    return %result;
}

679
# Return an array of all available psql versions
680 681
sub get_versions {
    my @versions = ();
682 683 684
    my $dir = $binroot;
    #redhat# $dir = '/usr';
    if (opendir (D, $dir)) {
685 686
	my $entry;
        while (defined ($entry = readdir D)) {
687
            next if $entry eq '.' || $entry eq '..';
688 689
            my $pfx = '';
            #redhat# $pfx = "pgsql-";
690
            ($entry) = $entry =~ /^$pfx(\d+\.?\d+)$/; # untaint
691
            push @versions, $entry if get_program_path ('psql', $entry);
692 693 694
        }
        closedir D;
    }
695
    return sort { $a <=> $b } @versions;
696 697
}

Martin Pitt's avatar
Martin Pitt committed
698 699
# Return the newest available version
sub get_newest_version {
700 701 702
    my @versions = get_versions;
    return undef unless (@versions);
    return $versions[-1];
Martin Pitt's avatar
Martin Pitt committed
703 704
}

705 706 707 708 709
# Check whether a version exists
sub version_exists {
    return (grep { $_ eq $_[0] } get_versions) ? 1 : 0;
}

710 711 712 713 714 715
# 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)) {
716 717
	my $entry;
        while (defined ($entry = readdir D)) {
718
            next if $entry eq '.' || $entry eq '..';
719
	    ($entry) = $entry =~ /^(.*)$/; # untaint
720 721
            my $conf = "$vdir$entry/postgresql.conf";
            if (-e $conf or -l $conf) { # existing file, or dead symlink
722
                push @clusters, $entry;
723
            }
724 725 726
        }
        closedir D;
    }
727
    return sort @clusters;
728
}
729

730 731 732
# Check if a cluster exists.
# Arguments: <version> <cluster>
sub cluster_exists {
733
    for my $c (get_version_clusters $_[0]) {
734 735 736 737 738
	return 1 if $c eq $_[1];
    }
    return 0;
}

739 740 741
# Return the next free PostgreSQL port.
sub next_free_port {
    # create list of already used ports
742 743 744
    my @ports;
    for my $v (get_versions) {
	for my $c (get_version_clusters $v) {
745
	    push @ports, get_cluster_port ($v, $c);
746 747 748
	}
    }

749
    my $port;
750
    for ($port = $defaultport; $port < 65536; ++$port) {
751 752 753
	next if grep { $_ == $port } @ports;

        # check if port is already in use
754 755 756 757 758
	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));
	}
759 760 761 762 763 764 765
	$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));
	    }
766
	}
767
	use strict;
768 769 770
	unless ($have_ip4 or $have_ip6) {
	    # require at least one protocol to work (PostgreSQL needs it anyway
	    # for the stats collector)
771
            die "could not create socket: $!";
772
	}
773
        close SOCK;
774 775
	# return port if it is available on all supported protocols
	return $port if ($have_ip4 ? $res4 : 1) and ($have_ip6 ? $res6 : 1);
776 777
    }

778
    die "no free port found";
779 780 781 782
}

# 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
783 784
# 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
785 786
# exists, and no matching entry is found in the map files, that cluster is
# returned.
787 788 789 790 791
sub user_cluster_map {
    my ($user, $pwd, $uid, $gid) = getpwuid $>;
    my $group = (getgrgid  $gid)[0];

    # check per-user configuration file
792 793
    my $home = $ENV{"HOME"} || (getpwuid $>)[7];
    my $homemapfile = $home . '/.postgresqlrc';
794 795
    if (open MAP, $homemapfile) {
	while (<MAP>) {
796
	    s/#.*//;
797
	    next if /^\s*$/;
798
	    my ($v,$c,$db) = split;
799
	    if (!version_exists $v) {
800 801
                print "Warning: $homemapfile line $.: version $v does not exist\n";
                next;
802 803
	    }
	    if (!cluster_exists $v, $c and $c !~ /^(\S+):(\d*)$/) {
804 805
                print "Warning: $homemapfile line $.: cluster $v/$c does not exist\n";
                next;
806
	    }
807 808 809 810 811 812 813 814 815 816 817 818
	    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
819 820
    if (open MAP, $mapfile) {
        while (<MAP>) {
821
            s/#.*//;
822 823 824 825 826 827
            next if /^\s*$/;
            my ($u,$g,$v,$c,$db) = split;
            if (!$db) {
                print  "Warning: ignoring invalid line $. in $mapfile\n";
                next;
            }
828
	    if (!version_exists $v) {
829 830
                print "Warning: $mapfile line $.: version $v does not exist\n";
                next;
831 832
	    }
	    if (!cluster_exists $v, $c and $c !~ /^(\S+):(\d*)$/) {
833 834
                print "Warning: $mapfile line $.: cluster $v/$c does not exist\n";
                next;
835
	    }
836 837 838 839
            if (($u eq "*" || $u eq $user) && ($g eq "*" || $g eq $group)) {
                close MAP;
                return ($v,$c, ($db eq "*") ? undef : $db);
            }
840
        }
841
        close MAP;
842 843
    }

844
    # if only one cluster exists, use that
845
    my $count = 0;
846
    my ($last_version, $last_cluster, $defaultport_version, $defaultport_cluster);
847 848
    for my $v (get_versions) {
	for my $c (get_version_clusters $v) {
849
	    my $port = get_cluster_port ($v, $c);
850 851
            $last_version = $v;
            $last_cluster = $c;
852 853 854 855
	    if ($port == $defaultport) {
		$defaultport_version = $v;
		$defaultport_cluster = $c;
	    }
856 857 858 859 860
            ++$count;
	}
    }
    return ($last_version, $last_cluster, undef) if $count == 1;

861 862 863 864 865 866 867 868
    if ($count == 0) {
	# if there are no local clusters, use latest clients for accessing
	# network clusters
	return (get_newest_version, undef, undef);
    }

    # more than one cluster exists, return cluster at default port
    return ($defaultport_version, $defaultport_cluster, undef);
869
}
870 871 872 873

# Copy a file to a destination and setup permissions
# Arguments: <source file> <destination file or dir> <uid> <gid> <permissions>
sub install_file {
874
    my ($source, $dest, $uid, $gid, $perm) = @_;
875

876
    if (system 'install', '-o', $uid, '-g', $gid, '-m', $perm, $source, $dest) {
877 878 879
	error "install_file: could not install $source to $dest";
    }
}
880

881 882 883
# 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.
884 885 886
# Arguments: <user id> <group id>
sub change_ugid {
    my ($uid, $gid) = @_;
887 888 889

    # auxiliary groups
    my $uname = (getpwuid $uid)[0];
890
    prepare_exec;
891
    my $groups = "$gid " . `/usr/bin/id -G $uname`;
892
    restore_exec;
893

894 895 896
    $) = $groups;
    $( = $gid;
    $> = $< = $uid;
897 898 899
    error 'Could not change user id' if $< != $uid;
    error 'Could not change group id' if $( != $gid;
}
900

901 902 903 904 905 906 907 908 909 910 911
# 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', $version;
    return undef unless ($port && $socketdir && $psql);
912 913

    # try to swich to cluster owner
914
    prepare_exec 'LC_ALL';
915
    $ENV{'LC_ALL'} = 'C';
916 917
    my $orig_euid = $>;
    $> = (stat (cluster_data_directory $version, $cluster))[4];
918
    open PSQL, '-|', $psql, '-h', $socketdir, '-p', $port, '-AXtc',
919
        'select getdatabaseencoding()', $db or
920 921 922
        die "Internal error: could not call $psql to determine db encoding: $!";
    my $out = <PSQL>;
    close PSQL;
923
    $> = $orig_euid;
924
    restore_exec;
925
    return undef if $?;
926
    chomp $out;
927
    ($out) = $out =~ /^([\w.-]+)$/; # untaint
928
    return $out;
929
}
930

931 932 933 934 935 936 937 938 939 940 941 942 943
# 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', $version;
    return undef unless ($port && $socketdir && $psql);
    my ($ctype, $collate);

944
    # try to switch to cluster owner
945 946 947 948
    prepare_exec 'LC_ALL';
    $ENV{'LC_ALL'} = 'C';
    my $orig_euid = $>;
    $> = (stat (cluster_data_directory $version, $cluster))[4];
949
    open PSQL, '-|', $psql, '-h', $socketdir, '-p', $port, '-AXtc',
950
        'SHOW lc_ctype', $db or
951
        die "Internal error: could not call $psql to determine db lc_ctype: $!";
952
    my $out = <PSQL> // error 'could not determine db lc_ctype';
953
    close PSQL;
954
    ($ctype) = $out =~ /^([\w.\@-]+)$/; # untaint
955
    open PSQL, '-|', $psql, '-h', $socketdir, '-p', $port, '-AXtc',
956
        'SHOW lc_collate', $db or
957
        die "Internal error: could not call $psql to determine db lc_collate: $!";
958
    $out = <PSQL> // error 'could not determine db lc_collate';
959
    close PSQL;
960
    ($collate) = $out =~ /^([\w.\@-]+)$/; # untaint
961 962 963 964 965 966 967 968
    $> = $orig_euid;
    restore_exec;
    chomp $ctype;
    chomp $collate;
    return ($ctype, $collate) unless $?;
    return (undef, undef);
}

969
# Return the CTYPE and COLLATE locales of a cluster. This needs to be called
970 971
# as root or as the cluster owner. (For versions <= 8.3; for >= 8.4, use
# get_db_locales()).
972
# Arguments: <version> <cluster>
973 974 975 976 977
# 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);

978
    if ($version >= '8.4') {
979 980 981 982
	print STDERR "Error: get_cluster_locales() does not work for 8.4+\n";
	exit 1;
    }

983
    my $pg_controldata = get_program_path 'pg_controldata', $version;
984 985 986 987
    if (! -e $pg_controldata) {
        print STDERR "Error: pg_controldata not found, please install postgresql-$version\n";
        exit 1;
    }
988 989
    prepare_exec ('LC_ALL', 'LANG', 'LANGUAGE');
    $ENV{'LC_ALL'} = 'C';
990
    my $result = open (CTRL, '-|', $pg_controldata, (cluster_data_directory $version, $cluster));
991
    restore_exec;
992
    return (undef, undef) unless defined $result;
993
    while (<CTRL>) {
994
	if (/^LC_CTYPE\W*(\S+)\s*$/) {
995
	    $lc_ctype = $1;
996
	} elsif (/^LC_COLLATE\W*(\S+)\s*$/) {
997 998 999 1000 1001 1002
	    $lc_collate = $1;
	}
    }
    close CTRL;
    return ($lc_ctype, $lc_collate);
}
1003

1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031
# 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;
}

1032 1033 1034
# 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.
1035
# Arguments: <version> <cluster>
1036 1037 1038 1039 1040 1041 1042 1043 1044
# 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', $version;
    return undef unless ($port && $socketdir && $psql);

    # try to swich to cluster owner
1045
    prepare_exec 'LC_ALL';
1046
    $ENV{'LC_ALL'} = 'C';
1047 1048
    my $orig_euid = $>;
    $> = (stat (cluster_data_directory $version, $cluster))[4];
1049 1050

    my @dbs;
1051
    my @fields;
1052
    if (open PSQL, '-|', $psql, '-h', $socketdir, '-p', $port, '-AXtl') {
1053 1054
        while (<PSQL>) {
            chomp;
1055 1056 1057
            @fields = split '\|';
            next if $#fields < 2; # remove access privs which get line broken
            push (@dbs, $fields[0]);
1058 1059 1060 1061
        }
        close PSQL;
    }

1062
    $> = $orig_euid;
1063
    restore_exec;
1064

1065
    return $? ? undef : @dbs;
1066
}
1067 1068 1069 1070 1071 1072

# 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 = '';
1073
    prepare_exec;
1074 1075 1076 1077 1078 1079
    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];
	}
1080
    }
1081
    restore_exec;
1082 1083 1084
    close CHLD_IN;
    close CHLD_OUT;
    close CHLD_ERR;
1085 1086
    return $dev;
}
1087

1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116

# 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;
1117
	goto error unless valid_hba_method($tok[0]);
1118 1119
	$$res{'method'} = join (' ', @tok);
	return $res;
1120
    }
1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136

    # 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;
1137
	goto error unless valid_hba_method($tok[0]);
1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160
	$$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;
}

1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171
# 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});
}

1172
1;