--- /dev/null
+#!/usr/bin/env perl
+# -*-mode:cperl; indent-tabs-mode: nil-*-
+
+## Gather important information about a box
+## Output in HTML or MediaWiki friendly format
+##
+## Greg Sabino Mullane <greg@endpoint.com>
+## Copyright End Point Corporation 2008-2017
+## BSD licensed
+## See: http://bucardo.org/wiki/Boxinfo
+
+use strict;
+use 5.006001;
+use warnings;
+use Data::Dumper qw{ Dumper };
+use Getopt::Long qw{ GetOptions };
+use File::Basename qw{ basename };
+
+our $VERSION = '1.5.0';
+
+my $USAGE = "Usage: $0 <options>
+ Important options:
+ --verbose
+ --skippgport=#
+ --postgresonly
+Set ENV{PG_CONFIG} if not in the path (or adjust your path!)
+
+For complete help, please visit:
+http://bucardo.org/wiki/Boxinfo
+
+";
+
+my %opt;
+GetOptions(
+ \%opt,
+ 'version',
+ 'verbose',
+ 'quiet',
+ 'help',
+ 'format=s',
+ 'os=s',
+ 'client=s',
+ 'skippgport=s',
+ 'postgresonly',
+ 'nopostgres',
+ 'postgresnohost',
+ 'nohost',
+ 'nomysql',
+ 'nosendmail',
+ 'useballoons',
+ 'timeout=i',
+) or die $USAGE;
+
+$opt{help} and die $USAGE;
+
+if ($opt{version}) {
+ print "$0 version $VERSION\n";
+ exit 0;
+}
+
+my $OS = $opt{os} || $^O;
+my $quiet = $opt{quiet} || 0;
+my $verbose = $opt{verbose} || 0;
+my $use_balloons = exists $opt{useballoons} ? $opt{useballoons} : 1;
+my $timeout = exists $opt{timeout} ? $opt{timeout} : 10;
+my $format = $opt{format} || 'wiki';
+
+$opt{use_su_postgres} = 0;
+
+## Used to identify the version of programs and Perl modules
+my $versionre = qr{\d+\.\d+(?:\S*)};
+
+## Inline CSS
+my $vtop = ' style="vertical-align: top"';
+
+## For ease of writing the HTML later on
+my $wrap = '<br />';
+
+## What to print if we can't figure out what something is
+my $UNKNOWN_VALUE = '?';
+my $UNKNOWN_VERSION = '?';
+
+## Dump the actual output of each command into a debug file
+my $debugfile = 'boxinfo.debug';
+open my $debugfh, '>', $debugfile or die qq{Could not write "$debugfile": $!\n};
+printf {$debugfh} "PROGRAM: $0\nStart: %s\n", scalar localtime();
+
+## When we leave for any reason, close the debug file and remove the temp file
+END {
+ defined $debugfh and (close $debugfh or die qq{Could not close "$debugfile": $!\n});
+ !$quiet and defined $debugfile and print "Raw data is in $debugfile\n";
+ unlink '/tmp/boxinfo.tmp';
+}
+
+## Output messages per language
+my %msg = (
+'en' => {
+ 'time-day' => q{day},
+ 'time-days' => q{days},
+ 'time-hour' => q{hour},
+ 'time-hours' => q{hours},
+ 'time-minute' => q{minute},
+ 'time-minutes' => q{minutes},
+ 'time-month' => q{month},
+ 'time-months' => q{months},
+ 'time-second' => q{second},
+ 'time-seconds' => q{seconds},
+ 'time-week' => q{week},
+ 'time-weeks' => q{weeks},
+ 'time-year' => q{year},
+ 'time-years' => q{years},
+},
+'fr' => {
+ 'time-day' => q{jour},
+ 'time-days' => q{jours},
+ 'time-hour' => q{heure},
+ 'time-hours' => q{heures},
+ 'time-minute' => q{minute},
+ 'time-minutes' => q{minutes},
+ 'time-month' => q{mois},
+ 'time-months' => q{mois},
+ 'time-second' => q{seconde},
+ 'time-seconds' => q{secondes},
+ 'time-week' => q{semaine},
+ 'time-weeks' => q{semaines},
+ 'time-year' => q{année},
+ 'time-years' => q{années},
+},
+'de' => {
+},
+'es' => {
+},
+);
+
+## Figure out which language to use for output
+our $lang = $ENV{LC_ALL} || $ENV{LC_MESSAGES} || $ENV{LANG} || 'en';
+$lang = substr($lang,0,2);
+
+## Figure out our hostname and the short version
+my $hostname = qx{hostname};
+chomp $hostname;
+if (length $hostname) {
+ print {$debugfh} "HOST: $hostname\n";
+}
+my $shorthost = $hostname;
+if ($shorthost =~ m{^(\w+\d\.\w+)\.\w+\.\w+$}) {
+ $shorthost = $1;
+}
+else {
+ $shorthost =~ s/^(.+?)\..+/$1/;
+}
+
+## Pick a client name for use in the page title
+my $clientname = 'ACME';
+if ($opt{client}) {
+ $clientname = $opt{client};
+}
+elsif ($hostname =~ m{([^\.]+)\.\w+$}) {
+ $clientname = ucfirst lc $1;
+}
+
+## We put the current time at the top of the report
+my $nowtime = qx{date};
+chomp $nowtime;
+
+my %data = (
+ program_version => $VERSION,
+ program_name => basename ($0),
+ program_start => $nowtime,
+ OS => $OS,
+ hostname => $hostname,
+ shorthost => $shorthost,
+ clientname => $clientname,
+);
+
+my %distlist = (
+ 'redhat' => ['redhat-release', 'Red Hat', 'release' ],
+ 'fedora' => ['fedora-release', 'Fedora', 'release' ],
+ 'SuSE' => ['SuSE-release', 'SuSE', 'release' ],
+ 'gentoo' => ['gentoo-release', 'Gentoo', 'release' ],
+ 'debian' => ['debian_version', 'Debian', 'version' ],
+ 'slackware' => ['slackware-release', 'Slackware', 'release' ],
+ 'mandrake' => ['mandrake-release', 'Mandrake', 'release' ],
+ 'yellowdog' => ['yellowdog-release', 'Yellowdod', 'release' ],
+);
+
+## Gather versions of all kinds of programs (should be run first)
+gather_versions();
+
+if ($opt{postgresonly}) {
+ ## Postgres information (generic)
+ gather_postgresinfo();
+ goto GATHERDONE;
+}
+
+## yum and apt-get : what's installed?
+gather_package_info();
+
+## Postgres information
+gather_postgresinfo();
+
+## MySQL information
+gather_mysqlinfo();
+
+## uname
+gather_uname();
+
+## lsb-release and redhat-release
+gather_dist() if $OS eq 'linux';
+
+## memory is very OS specific
+gather_memory();
+
+## Is it a VM?
+gather_vminfo();
+
+## RightScale information
+gather_rightscale();
+
+## Grab all cron information we can find
+gather_croninfo();
+
+## All information on disks and filesystems
+gather_mounts();
+
+## Detailed info on each disk
+#gather_disk_settings();
+
+## Size of disks
+gather_disksize();
+
+## User limits
+gather_ulimits();
+
+## Environment variables
+gather_envs();
+
+## Network interface (ethernet cards)
+gather_interfaces();
+
+## Network routing information
+gather_routes();
+
+## What is set to run on boot?
+gather_chkconfig();
+
+## CPU information
+gather_cpuinfo();
+
+## Gather Perl module versions and detailed Perl information
+gather_perlinfo();
+
+## Information on the uptime
+gather_uptime();
+
+## Puppet info
+gather_puppet();
+
+## Loaded modules
+gather_lsmod();
+
+## LifeKeeper information
+gather_lifekeeper();
+
+## Heartbeat (Linux HA information)
+gather_heartbeat();
+
+## Ruby gems (local)
+gather_gems();
+
+GATHERDONE:
+
+## remove any temporary constructs from the hash
+for (keys %data) {
+ delete $data{$_} if $_ =~ /^tmp_/;
+}
+
+if ('wiki' eq $format or 'html' eq $format) {
+ create_html_output();
+}
+else {
+ die "Unknown format: must be 'html' or 'wiki'\n";
+}
+
+exit;
+
+
+sub slurp_table_info {
+ my $arg = shift or die;
+
+ run_command($arg->{command},'tmp_slurp');
+ my $slinfo = $data{tmp_slurp};
+ if ($arg->{failregex} and $slinfo =~ /$arg->{failregex}/) {
+ warn "$arg->{failregexmsg}\n";
+ return;
+ }
+ return unless $slinfo =~ /\w/;
+ my ($n,$v);
+ my $currname = '';
+ for my $line (split /\n/ => $slinfo) {
+ next if $line !~ /^(\w+).*\| (.*)/o;
+ ($n,$v) = (lc $1,$2||'');
+ if ($n eq $arg->{pk}) {
+ $currname = $v;
+ }
+ $arg->{var}{$currname}{$n} = $v;
+ }
+
+ return;
+
+} ## end of slurp_table_info
+
+
+sub gather_uname {
+
+ if ($OS eq 'linux') {
+ run_command('uname --kernel-name' => 'Kernel name');
+ run_command('uname --nodename' => 'Node name');
+ run_command('uname --kernel-release' => 'Kernel release');
+ run_command('uname --kernel-version' => 'Kernel version');
+ run_command('uname --machine' => 'Hardware name');
+ run_command('uname --processor' => 'Processor');
+ run_command('uname --hardware-platform' => 'Hardware platform');
+ }
+ elsif ($OS =~ /bsd/ or $OS =~ /darwin/) {
+ run_command('uname -s' => 'Kernel name');
+ run_command('uname -n' => 'Node name');
+ run_command('uname -r' => 'Kernel release');
+ run_command('uname -v' => 'Kernel version');
+ run_command('uname -p' => 'Processor');
+ run_command('uname -m' => 'Hardware platform');
+ }
+ else {
+ $quiet or warn qq{Cannot gather uname information on OS "$OS"\n};
+ }
+
+ return;
+
+} ## end of gather_uname
+
+
+sub gather_dist {
+
+ my $lsb1 = '/etc/lsb-release';
+ my $lsb2 = '/usr/bin/lsb_release';
+ if (-e $lsb1) {
+ open my $fh, '<', $lsb1 or die qq{Could not open "$lsb1": $!\n};
+ while (<$fh>) {
+ if (/^DISTRIB_(.+?)=(.+)/) {
+ my ($nam,$val) = ($1,$2);
+ $val =~ s/^"(.+)"$/$1/;
+ $data{lsb_release}{$nam} = $val;
+ }
+ elsif (/^LSB_VERSION="(\d[\.\d]*)"/) {
+ $data{lsb_version} = $1;
+ }
+ else {
+ $quiet or warn qq{Unknown line $. in $lsb1: $_\n};
+ }
+ }
+ close $fh or die qq{Could not close "$lsb1": $!\n};
+ }
+ ## Check for lsb_release executable for the codename
+ if (-e $lsb2) {
+ run_command("$lsb2 -a", 'tmp_lsb');
+ if ($data{tmp_lsb} =~ /Codename:\s+(.+)/) {
+ $data{dist_codename} = $1;
+ }
+ }
+
+ for my $dist (keys %distlist) {
+ my $file = "/etc/$distlist{$dist}->[0]";
+ if (-e $file) {
+ open my $fh, '<', $file or die qq{Could not open "$file": $!\n};
+ while (<$fh>) {
+ chomp;
+ $data{dist}{$dist} = $_;
+ last;
+ }
+ close $fh or die qq{Could not close "$file": $!\n};
+ }
+ }
+
+ return;
+
+} ## end of gather_dist
+
+
+sub gather_vminfo {
+
+ $data{VM} = 'No';
+
+ ## Check for a EC2 motd
+ my $file = '/etc/motd';
+ if (-e $file) {
+ if (open my $fh, '<', $file) {
+ my $slurp;
+ { local $/; $slurp = <$fh>; }
+ close $fh or warn qq{Could not close "$file": $!\n};
+ if ($slurp =~ /eip:\s+(\S+)\ninstance id:\s+(\S+)\ntype:\s+(\S+)/) {
+ ($data{EC2}{eip}, $data{EC2}{id}, $data{EC2}{type}) = ($1,$2,$3);
+ }
+ }
+ }
+
+ ## Find the EC2 ami version
+ $file = '/usr/bin/ec2-ami-tools-version';
+ if (-x $file) {
+ run_command($file, 'tmp_ec2');
+ if ($data{tmp_ec2} =~ /\d/) {
+ $data{EC2}{ami} = $data{tmp_ec2};
+ }
+
+ ## Grab the rest of the EC2 information on the fly
+ if (exists $data{version}{curl}) {
+ my %meta;
+ my $uri = 'http://169.254.169.254/latest/meta-data/';
+ parse_ec2_uri(\%meta, $uri);
+ sub parse_ec2_uri {
+ my ($tempname, $tempurl) = @_;
+ my $info = qx{curl -s $tempurl};
+ for my $word (split /\n/ => $info) {
+ if ($word =~ m{/$}) {
+ $tempname->{$word} = {};
+ parse_ec2_uri($tempname->{$word}, "${tempurl}$word");
+ }
+ elsif ($word =~ /\w$/) {
+ my $uri = "${tempurl}$word";
+ $tempname->{$word} = qx{curl -s $uri};
+ }
+ }
+ return;
+ }
+ $data{EC2}{meta} = \%meta;
+ }
+ }
+
+ if ($OS =~ /bsd/ or $OS =~ /darwin/) {
+ run_command('ps -o stat', 'tmp_ps');
+ if ($data{tmp_ps} =~ /J$/m) {
+ $data{VM} = 'BSD jail';
+ return;
+ }
+ }
+
+ run_command('dmidecode', 'tmp_dmi');
+ if ($data{tmp_dmi} =~ /VMware/) {
+ $data{VM} = 'VMware';
+ return;
+ }
+
+ if ($data{tmp_dmi} =~ /Manufacturer: Microsoft/) {
+ $data{VM} = 'VirtualPC';
+ return;
+ }
+
+ if (-e '/proc/xen/capabilities') {
+ $data{VM} = sprintf 'Xen %s', -e '/proc/xen/grant' ? '3.x' : '2.x';
+ return;
+ ## Capture xm list?
+ }
+
+ return;
+
+} ## end of gather_vminfo
+
+
+sub gather_rightscale {
+
+
+ ## If /etc/rightscale.d exists, we can be pretty sure this is a RightScale box
+
+ my $dir = '/etc/rightscale.d';
+
+ return if ! -d $dir;
+
+ $data{RightScale} = {};
+
+ ## What type of cloud?
+ my $file = "$dir/cloud";
+ if (open my $fh, '<', $file) {
+ ## Simply grab the first line
+ $data{RightScale}{cloud} = <$fh>;
+ chomp $data{RightScale}{cloud};
+ close $fh or warn qq{Could not close "$file": $!\n};
+ }
+
+ ## What version?
+ $file = "$dir/rightscale-release";
+ if (open my $fh, '<', $file) {
+ ## Simply grab the first line
+ $data{RightScale}{version} = <$fh>;
+ chomp $data{RightScale}{version};
+ close $fh or warn qq{Could not close "$file": $!\n};
+ }
+
+ return;
+
+} ## end of gather_rightscale
+
+
+sub gather_memory {
+
+ if ($OS eq 'linux') {
+ run_command('cat /proc/meminfo', 'tmp_meminfo');
+ ## Extract ueful bits out and erase the main entry
+ ## Seems to be all in kB
+ my $info = $data{'tmp_meminfo'};
+ my @memstuff = (
+ ['Total', 'MemTotal'],
+ ['Free', 'MemFree'],
+ ['Cached', 'Cached'],
+ ['Active', 'Active'],
+ ['Inactive', 'Inactive|Inact_clean'],
+ ['Swap Total', 'SwapTotal'],
+ ['Swap Free', 'SwapFree'],
+ ['HPsize', 'Hugepagesize'],
+ ['HPtotal', 'HugePages_Total'],
+ ['HPfree', 'HugePages_Free'],
+ ['HPreserved', 'HugePages_Rsvd'],
+ );
+ for (@memstuff) {
+ my ($name,$olabel) = @$_;
+ my $found = 0;
+ for my $label (split /\s*\|\s*/ => $olabel) {
+ if ($info =~ /$label:\s+(\d+) kB/) {
+ my $val = $1 * 1024;
+ $data{memory}{$name} = $val;
+ $data{memory}{pretty}{$name} = pretty_size($val);
+ $found = 1;
+ last;
+ }
+ elsif ($info =~ /$label:\s+(\d+)/) {
+ $data{memory}{$name} = $1;
+ $found = 1;
+ last;
+ }
+ }
+ if (!$found and $name !~ /^HP/) {
+ $quiet or warn qq{Could not determine "$name" from meminfo output\n};
+ }
+ }
+
+ ## Now shared memory settings
+ for my $name (qw/shmmax shmmni shmall/) {
+ run_command("cat /proc/sys/kernel/$name", 'tmp_shm');
+ $data{memory}{$name} = delete $data{'tmp_shm'};
+ if ($name !~ /i$/) {
+ $data{memory}{pretty}{$name} = pretty_size($data{memory}{$name});
+ }
+ }
+ run_command('ipcs -m', 'tmp_active_shared_memory');
+ $data{memory}{active_shared} = ($data{tmp_active_shared_memory} =~ y/\n/\n/) - 3;
+ $data{memory}{active_shared} = 0 if $data{tmp_active_shared_memory} !~ /\d/;
+
+ run_command('ipcs -s', 'tmp_active_semaphores');
+ $data{memory}{active_semaphores} = ($data{tmp_active_semaphores} =~ y/\n/\n/) - 3;
+ $data{memory}{active_semaphores} = 0 if $data{tmp_active_semaphores} !~ /\d/;
+
+ run_command('ipcs -q', 'tmp_active_message_queues');
+ $data{memory}{active_messages} = ($data{tmp_active_message_queues} =~ y/\n/\n/) - 3;
+ $data{memory}{active_messages} = 0 if $data{tmp_active_message_queues} !~ /\d/;
+
+ run_command('ipcs -u', 'tmp_ipcs_summary');
+ ## Future: parse the above
+
+ ## Major VM tunables
+ for my $vm (qw/swappiness dirty_ratio dirty_background_ratio nr_hugepages/) {
+ run_command("cat /proc/sys/vm/$vm", 'tmp_swap');
+ if ($data{'tmp_swap'} =~ /\d/) {
+ $data{vm}{$vm} = $data{'tmp_swap'};
+ }
+ }
+
+ ## Huge pages
+ run_command('cat /sys/kernel/mm/transparent_hugepage/enabled', 'tmp_hugetemp');
+ if ($data{tmp_hugetemp} =~ /always/) {
+ $data{memory}{transparent_hugepages} = $data{tmp_hugetemp};
+ }
+
+ }
+ elsif ($OS =~ /bsd/ or $OS =~ /darwin/) {
+ exists $data{'tmp_sysctl'} or run_command('sysctl -a', 'tmp_sysctl');
+ my $info = $data{'tmp_sysctl'};
+
+ my @memstuff = (
+ ['Total', 'hw.physmem'],
+ ['User', 'hw.usermem'],
+ ['Real', 'hw.realmem'],
+ ['VM kmem', 'vm.kmem_size'],
+ );
+ for (@memstuff) {
+ my ($name,$label) = @$_;
+ if ($info =~ /$label\s*[=:]\s*(\d+)/) {
+ my $val = $1;
+ $data{memory}{$name} = $val;
+ $data{memory}{pretty}{$name} = pretty_size($val);
+ }
+ elsif (!$quiet) {
+ if ($OS !~ /darwin/ or $label !~ /realmem|kmem/) {
+ warn qq{Could not find "$label" in sysctl output\n};
+ }
+ }
+ }
+ run_command('ipcs -m', 'tmp_active_shared_memory');
+ $data{memory}{active_shared} = ($data{tmp_active_shared_memory} =~ y/\n/\n/) - 3;
+ $data{memory}{active_shared} = 0 if $data{tmp_active_shared_memory} !~ /\d/;
+
+ run_command('ipcs -s', 'tmp_active_semaphores');
+ $data{memory}{active_semaphores} = ($data{tmp_active_semaphores} =~ y/\n/\n/) - 3;
+ $data{memory}{active_semaphores} = 0 if $data{tmp_active_semaphores} !~ /\d/;
+
+ run_command('ipcs -q', 'tmp_active_message_queues');
+ $data{memory}{active_message} = ($data{tmp_active_message_queues} =~ y/\n/\n/) - 3;
+ $data{memory}{active_messages} = 0 if
+ (! defined $data{memory}{active_messages} or $data{tmp_active_message_queues} !~ /\d/);
+
+ run_command('ipcs -a', 'tmp_ipcs_all');
+ run_command('ipcs -T', 'tmp_ipcs_T');
+ }
+ else {
+ $quiet or warn qq{Do not know how to check OS "$OS" for memory\n};
+ }
+
+ return;
+
+} ## end of gather_memory
+
+
+sub gather_croninfo {
+
+ if ($OS eq 'linux') {
+ run_command('cat /etc/crontab', 'tmp_etc_crontab');
+ my $info = $data{tmp_etc_crontab};
+ for my $var (qw/d hourly daily weekly monthly/) {
+ my $crondir = "/etc/cron.$var";
+ if (opendir my $dirh, $crondir) {
+ for my $file (grep { /^\w/ } readdir $dirh) {
+ run_command("cat $crondir/$file", 'tmp_cron');
+ $info = $data{tmp_cron};
+ }
+ }
+ }
+ my $crondir = '/var/spool/cron';
+ if (opendir my $dirh, $crondir) {
+ for my $file (grep { /^\w/ } readdir $dirh) {
+ run_command("cat $crondir/$file", 'tmp_cron');
+ $info = $data{tmp_cron};
+ }
+ }
+ }
+ elsif ($OS =~ /bsd/ or $OS =~ /darwin/) {
+ run_command('cat /etc/crontab', 'tmp_crontab');
+ my $info = $data{tmp_crontab};
+ }
+ else {
+ $quiet or warn qq{Do not know how to find cron infomation on OS "$OS"\n};
+ }
+
+ return;
+
+} ## end of gather_croninfo
+
+sub gather_mounts {
+
+ if ($OS eq 'linux') {
+ run_command('mount -l -f', 'tmp_mount');
+ for my $line (split /\n/ => $data{tmp_mount}) {
+ if ($line =~ m{^(.+?) on (.+?) type (.+?) \((.+)\)\s*(.*)}) {
+ my ($dev,$dir,$type,$options,$label) = ($1,$2,$3,$4,$5);
+ $data{fs}{$dev} = {dir => $dir, type => $type, options => $options, readahead => '', scheduler => ''};
+ if ($dev =~ m{^\/dev\/([a-z]+)\d*$}) {
+ my $name = $1;
+ if (! exists $data{block}{$name}) {
+ run_command("cat /sys/block/$name/queue/read_ahead_kb", 'tmp_readahead');
+ if ($data{tmp_readahead} =~ /(\d+)/) {
+ $data{block}{$name}{readahead} = (($1 * 512) / 1024) . ' KB';
+ }
+ else {
+ $data{block}{$name}{readahead} = '?';
+ }
+ run_command("cat /sys/block/$name/queue/scheduler", 'tmp_scheduler');
+ my $sc = $data{tmp_scheduler} || '?';
+ $data{block}{$name}{scheduler} = $sc =~ /^cat/ ? '?' : $sc;
+ ## shows all available
+ }
+ }
+ if ($label =~ s/\[(.+)\]/$1/) {
+ $data{fs}{$dev}{label} = $label;
+ }
+ }
+ else {
+ $quiet or warn qq{Do not know how to parse df line: $line\n};
+ }
+ }
+ if (-f '/proc/mdstat') {
+ run_command('cat /proc/mdstat', 'tmp_mdstat');
+ if ($data{tmp_mdstat} =~ /Personalities : \S/) {
+ $data{mdstat} = $data{tmp_mdstat};
+ }
+ }
+ }
+ elsif ($OS =~ /bsd/ or $OS =~ /darwin/) {
+ run_command('mount -d -v', 'tmp_mount');
+ for my $line (split /\n/ => $data{tmp_mount}) {
+ ## Example: /dev/foo on / (ufs, local)
+ if ($line =~ m{^(.+?) on (.+?)(?: \((.+?)\))*}) {
+ my ($dev,$dir,$type,$options,$label) = ($1,$2,$3||'','','');
+ my @options;
+ ($type, @options) = split /, /, $type;
+ $options = join ', ', @options;
+ $data{fs}{$dev} = {dir => $dir, type => $type, options => $options};
+ if ($label =~ s/\[(.+)\]/$1/) {
+ $data{fs}{$dev}{label} = $label;
+ }
+ }
+ else {
+ $quiet or warn qq{Do not know how to parse df line: $line\n};
+ }
+ }
+ }
+ else {
+ $quiet or die qq{Do not know how to get mount information on OS "$OS"\n};
+ }
+
+ return;
+
+} ## end of gather_mounts
+
+
+sub gather_disksize {
+
+ if ($OS eq 'linux' or $OS =~ /bsd/ or $OS =~ /darwin/) {
+ run_command('df -h -P', 'tmp_disk_space');
+ run_command('df -i -P', 'tmp_disk_space_inodes');
+ my $info = $data{tmp_disk_space};
+ for my $line (split /\n/ => $info) {
+ next if $line =~ /^Filesystem/;
+ next unless $line =~ s{^(.+?)\s+(\d)}{$2};
+ my $name = $1;
+ my @info = split /\s+/ => $line;
+ if ($OS eq 'linux') {
+ $data{fs}{$name}{size} = $info[0];
+ $data{fs}{$name}{used} = $info[1];
+ $data{fs}{$name}{available} = $info[2];
+ $data{fs}{$name}{capacity} = $info[3];
+ $data{fs}{$name}{mounted} = $info[4];
+ }
+ else { ## BSD ... is not dead
+ $data{fs}{$name}{size} = $info[1] + $info[2];
+ $data{fs}{$name}{used} = $info[1];
+ $data{fs}{$name}{available} = $info[2];
+ $data{fs}{$name}{capacity} = $info[3];
+ $data{fs}{$name}{mounted} = $info[4];
+ }
+ }
+ $info = $data{tmp_disk_space_inodes};
+ for my $line (split /\n/ => $info) {
+ next if $line =~ /^Filesystem/;
+ next unless $line =~ s{^(.+?)\s+(\d)}{$2};
+ my $name = $1;
+ my @info = split /\s+/ => $line;
+ if ($OS eq 'linux') {
+ $data{fs}{$name}{inodes} = $info[0];
+ $data{fs}{$name}{inodes_used} = $info[1];
+ $data{fs}{$name}{inodes_free} = $info[2];
+ $data{fs}{$name}{inodes_usage} = $info[3];
+ }
+ else { ##BSD
+ $data{fs}{$name}{inodes} = $info[4] + $info[5];
+ $data{fs}{$name}{inodes_used} = $info[4];
+ $data{fs}{$name}{inodes_free} = $info[5];
+ $data{fs}{$name}{inodes_usage} = $info[6];
+ }
+ }
+ }
+ else {
+ $quiet or die qq{Do not know how to get disk size information on OS "$OS"\n};
+ }
+
+ return;
+
+} ## end of gather_disksize
+
+
+sub gather_ulimits {
+
+ run_command(q{bash -c 'ulimit -a'}, 'tmp_ulimit');
+ for my $line (split /\n/ => $data{tmp_ulimit}) {
+ if ($line =~ /^(.+?)\s+\(.+\) (.+)/) {
+ $data{ulimit}{$1} = $2;
+ }
+ else {
+ $quiet or warn qq{Could not parse line of ulimit output: $line\n};
+ }
+ }
+
+ return;
+
+} ## end of gather_ulimits
+
+
+sub gather_envs {
+
+ for (keys %ENV) {
+ $data{ENV}{$_} = $ENV{$_};
+ }
+
+ return;
+
+} ## end of gather_envs
+
+
+sub gather_interfaces {
+
+ run_command('/sbin/ifconfig -v -a', 'tmp_ifconfig');
+ my $int = '?';
+ my $hwhex = qr{[a-fA-F0-9:\-]};
+ my $ip = qr{[0-9]+\.\d+\.\d+\.\d+};
+ for my $line (split /\n/ => $data{tmp_ifconfig}) {
+ if ($line =~ /^([\w:]+)/) {
+ $int = $1;
+ }
+ if ($line =~ /\s+HWaddr ($hwhex+)/) {
+ $data{interface}{$int}{hardware_address} = $1;
+ }
+ if ($line =~ /\s+ether ($hwhex+)/) {
+ $data{interface}{$int}{hardware_address} = $1;
+ }
+ if ($line =~ /\s+inet (?:addr:)?($ip)/) {
+ $data{interface}{$int}{address} = $1;
+ }
+ if ($line =~ /\s+Bcast:($ip)/i) {
+ $data{interface}{$int}{broadcast} = $1;
+ }
+ if ($line =~ /\s+Broadcast: ($ip)/i) {
+ $data{interface}{$int}{broadcast} = $1;
+ }
+ if ($line =~ /\s+Mask:($ip)/) {
+ $data{interface}{$int}{mask} = $1;
+ }
+ if ($line =~ /\s+netmask 0x(\S+)/) {
+ $data{interface}{$int}{mask} = $1;
+ }
+ if ($line =~ /\s+inet6 addr: (\S+)/) {
+ $data{interface}{$int}{inet6_address} = $1;
+ }
+ if ($line =~ /\bmtu[: ](\d+)/i) {
+ $data{interface}{$int}{mtu} = $1;
+ for my $opt (qw/UP BROADCAST RUNNING MULTICAST ALLMULTI PROMISC POINTOPOINT NOARP/) {
+ if ($line =~ /\b$opt\b/) {
+ $data{interface}{$int}{$opt} = 1;
+ }
+ }
+ }
+ for my $opt ('collisions','txnqueuelen','RX bytes','TX bytes') {
+ if ($line =~ /\s+$opt:(\d+)/) {
+ $data{interface}{$int}{$opt} = $1;
+ }
+
+ }
+ if ($line =~ /\s+([RT])X packets:(\d+)/) {
+ my $x = lc $1;
+ $data{interface}{$int}{"${x}x_packets"} = $2;
+ for my $opt (qw/errors dropped overruns frame carrier/) {
+ if ($line =~ /\b$opt:(\d+)/) {
+ $data{interface}{$int}{"${x}x_$opt"} = $1;
+ }
+ }
+ }
+ if ($line =~ /\boptions=/) {
+ while ($line =~ /([A-Z_]+)/g) {
+ $data{interface}{$int}{$1} = 1;
+ }
+ }
+ }
+
+ ## Check all hostnames for active interfaces, check the speed
+ for my $int (keys %{$data{interface}}) {
+ next if ! exists $data{interface}{$int}{UP};
+
+ run_command("ethtool $int", 'tmp_ethtool');
+ if ($data{tmp_ethtool} =~ /Speed: (\d+)(\S+)/) {
+ $data{interface}{$int}{current_speed} = "$1$2";
+ $data{interface}{$int}{nowspeed} = $1;
+ }
+ if ($data{tmp_ethtool} =~ /Duplex: (\S+)/) {
+ $data{interface}{$int}{duplex} = $1;
+ }
+
+ if ($data{tmp_ethtool} =~ /Supported link modes: (.+?)Sup/ms) {
+ my $sup = $1;
+ my $maxspeed = 0;
+ while ($sup =~ /(\d+)baseT/g) {
+ $maxspeed = $1 if $1 > $maxspeed;
+ }
+ $data{interface}{$int}{maxspeed} = $maxspeed;
+ }
+
+ next if exists $data{interface}{$int}{NOARP};
+ my $ip = $data{interface}{$int}{address};
+ ip2hostname($ip);
+ }
+
+ return;
+
+} ## end of gather_interfaces
+
+
+sub gather_routes {
+
+ if ($OS eq 'linux') {
+ run_command('route -n', 'tmp_route');
+ for my $line (split /\n/ => $data{tmp_route}) {
+ next unless $line =~ /^\d/o;
+ if ($line =~ /^(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\S+)/o) {
+ my ($d,$gw,$m,$f,$mt,$ref,$use,$int) = ($1,$2,$3,$4,$5,$6,$7,$8);
+ push @{$data{route}}, {dest=>$d,gateway=>$gw,mask=>$m,flags=>$f,metric=>$mt,ref=>$ref,use=>$use,int=>$int};
+ }
+ else {
+ $quiet or warn "Could not parse line of route output: $line\n";
+ }
+ }
+ }
+ elsif ($OS =~ /bsd/ or $OS =~ /darwin/) {
+ run_command('netstat -r', 'tmp_route');
+ }
+ else {
+ $quiet or warn qq{Do not know how to determine routing information on OS "$OS"\n};
+ }
+
+ return;
+
+} ## end of gather_routes
+
+
+sub gather_versions {
+
+ ## --version
+ for my $prog (qw/
+ apt-get aptitude autoconf awk bash cc check_postgres.pl chkconfig convert curl cvs dpkg dovecot
+ elinks emacs emerge find gcc gdb geos-config git gnome-panel gpg gzip iconv initdb interchange
+ knock konquerer links make mii-tool nano ntpd pdns_server perl pg_config pg_dump
+ postgres psql puppet python rrdtool rsync ruby s3cmd
+ screen sed service svn syslog syslog-ng tar tail_n_mail.pl tail_n_mail tcbmgr vi vim wget yum /) {
+ my $maxtime = $timeout;
+ if ('yum' eq $prog and 30 > $maxtime) {
+ $maxtime = 30;
+ }
+ run_command("$prog --version", 'tmp_version', $maxtime);
+ $data{version}{$prog} = ($data{tmp_version} =~ /($versionre)/) ? $1 : $UNKNOWN_VERSION;
+ }
+ ## version
+ for my $prog (qw/ openssl /) {
+ run_command("$prog version", 'tmp_version');
+ $data{version}{$prog} = ($data{tmp_version} =~ /($versionre)/) ? $1 : $UNKNOWN_VERSION;
+ }
+ ## -version
+ for my $prog (qw/ sqlite/) {
+ run_command("$prog -version", 'tmp_version');
+ $data{version}{$prog} = ($data{tmp_version} =~ /($versionre)/) ? $1 : $UNKNOWN_VERSION;
+ }
+ ## -v
+ for my $prog (qw/ lighttpd php rsyslogd slonik /) {
+ run_command("$prog -v", 'tmp_version');
+ $data{version}{$prog} = ($data{tmp_version} =~ /($versionre)/) ? $1 : $UNKNOWN_VERSION;
+ }
+ ## -V
+ for my $prog (qw/ nginx pgbouncer rcs sar ssh /) {
+ run_command("$prog -V", 'tmp_version');
+ $data{version}{$prog} = ($data{tmp_version} =~ /($versionre)/) ? $1 : $UNKNOWN_VERSION;
+ }
+ ## -help
+ for my $prog (qw/ zip /) {
+ run_command("$prog -help", 'tmp_version');
+ $data{version}{$prog} = ($data{tmp_version} =~ /($versionre)/) ? $1 : $UNKNOWN_VERSION;
+ }
+ ## --help
+ for my $prog (qw/ bzip2 ethtool nrpe 7zr /) {
+ run_command("$prog --help", 'tmp_version');
+ $data{version}{$prog} = ($data{tmp_version} =~ /($versionre)/) ? $1 : $UNKNOWN_VERSION;
+ }
+ ## -h
+ for my $prog (qw/ memcached /) {
+ run_command("$prog -h", 'tmp_version');
+ $data{version}{$prog} = ($data{tmp_version} =~ /($versionre)/) ? $1 : $UNKNOWN_VERSION;
+ }
+ ## Special cases
+ run_command('postconf mail_version', 'tmp_version');
+ $data{version}{postfix} = ($data{tmp_version} =~ /($versionre)/) ? $1 : $UNKNOWN_VERSION;
+
+ if (! $opt{nosendmail}) {
+ run_command('echo \\\$Z | sendmail -bt -d0', 'tmp_version');
+ $data{version}{sendmail} = ($data{tmp_version} =~ /($versionre)/) ? $1 : $UNKNOWN_VERSION;
+ }
+
+ run_command('exim -bV', 'tmp_version');
+ $data{version}{exim} = ($data{tmp_version} =~ /($versionre)/) ? $1 : $UNKNOWN_VERSION;
+
+ run_command('mysql --version', 'tmp_version');
+ $data{version}{mysql} = ($data{tmp_version} =~ /($versionre) Distrib ([^,]+)/) ? "$2 ($1)" : $UNKNOWN_VERSION;
+
+ run_command('vsftpd -v 0>&1', 'tmp_version');
+ $data{version}{vsftpd} = ($data{tmp_version} =~ /($versionre)/) ? $1 : $UNKNOWN_VERSION;
+
+ run_command('thrift -version', 'tmp_version');
+ $data{version}{thrift} = ($data{tmp_version} =~ /(\d+)/) ? $1 : $UNKNOWN_VERSION;
+
+ ## Sometimes we get a trailing comma: remove
+ ## Also remove unmatched trailing parens
+ for (keys %{$data{version}}) {
+ $data{version}{$_} =~ s/,$//;
+ $data{version}{$_} =~ s/\)$// if $data{version}{$_} !~ /\(/;
+ }
+
+ return;
+
+} ## end of gather_versions
+
+
+sub gather_package_info {
+
+ ## Gather what's been installed via yum
+ if ($data{version}{yum} =~ /\d/) {
+ run_command('yum list installed', 'tmp_yumi');
+ for my $line (split /\n/ => $data{tmp_yumi}) {
+ next if $line !~ /(\S+)\s+(\S+)\s+(\S+)/o;
+ my ($name,$ver,$type) = ($1,$2,$3);
+ if ($type eq 'installed') {
+ $data{yum}{installed}{$name} = $ver;
+ }
+ }
+ }
+
+ ## Gather what's been installed via apt-get / dpkg
+ if ($data{version}{'apt-get'} =~ /\d/ and ! exists $data{tmp_yumi}) {
+ run_command('aptitude search ~i', 'tmp_apti');
+ for my $line (split /\n/ => $data{tmp_apti}) {
+ next if $line !~ /^i(..) (\S+)\s+\- (.+)/o;
+ my ($flag,$name,$desc) = ($1,$2,$3);
+ $data{aptitude}{installed}{$name} = $flag =~ /A/ ? 1 : 0;
+ }
+ }
+
+ return;
+
+} ## end of gather_package_info
+
+
+sub gather_chkconfig {
+
+ my $runlevel = qx{runlevel 2>/dev/null} =~ /(\d)$/ ? $1 : 3;
+
+ run_command(qq{chkconfig --list 2>/dev/null | grep '$runlevel:on'}, 'tmp_chkconfig');
+ for my $line (split /\n/ => $data{tmp_chkconfig}) {
+ if ($line =~ /^(\S+)/) {
+ $data{chkconfig}{$1} = 1;
+ }
+ else {
+ $quiet or warn qq{Could not parse line of chkconfig output: $line\n};
+ }
+ }
+
+ return;
+
+} ## end of gather_chkconfig
+
+
+sub gather_cpuinfo {
+
+ if ($OS eq 'linux') {
+ run_command('cat /proc/cpuinfo', 'tmp_cpuinfo');
+ my $info = $data{tmp_cpuinfo};
+ my $cpu = 0;
+ $data{numcpus} = 0;
+ while ($info =~ /^(.+?)\s+: (.+)/gm) {
+ my ($name,$value) = ($1,$2);
+ if ($name eq 'processor') {
+ $data{numcpus}++;
+ $cpu = $value;
+ }
+ if ($name eq 'cpu MHz') {
+ $data{cpuinfo}{$cpu}{speed} = (int $value) . ' MHz';
+ }
+ else {
+ $data{cpuinfo}{$cpu}{$name} = $value;
+ }
+ }
+ }
+ elsif ($OS =~ /bsd/ or $OS =~ /darwin/) {
+ exists $data{'tmp_sysctl'} or run_command('sysctl -a', 'tmp_sysctl');
+ my $info = $data{'tmp_sysctl'};
+ if ($info =~ /hw.model:\s+(.+)/ or $info =~ /machdep.cpu.brand_string:\s+(.+)/) {
+ $data{cpuinfo}{0}{'model name'} = $1;
+ if ($1 =~ / (.+GHz)/) {
+ $data{cpuinfo}{0}{speed} = $1;
+ }
+ }
+ if ($info =~ /hw.ncpu:\s+(.+)/) {
+ $data{numcpus} = $1;
+ }
+ }
+ else {
+ $quiet or warn qq{Do not know how to gather CPU information for OS "$OS"\n};
+ }
+
+ return;
+
+} ## end of gather_cpuinfo
+
+
+sub gather_perlinfo {
+
+ $data{perl}{INC} = \@INC;
+
+ run_command('perl -V', 'tmp_perl');
+ my $info = $data{tmp_perl};
+
+ $data{perl}{multiplicity} = $UNKNOWN_VALUE;
+ if ($info =~ /\busemultiplicity=(\w+)/) {
+ my $val = $1;
+ if ($val eq 'define') {
+ $data{perl}{multiplicity} = 'Yes';
+ }
+ elsif ($val eq 'undef') {
+ $data{perl}{multiplicity} = 'No';
+ }
+ else {
+ $quiet or warn qq{Unknown perl multiplicity value: $val\n};
+ }
+ }
+
+ $data{perl}{threads} = $UNKNOWN_VALUE;
+ if ($info =~ /\busethreads=(\w+)/) {
+ my $val = $1;
+ if ($val eq 'define') {
+ $data{perl}{threads} = 'Yes';
+ }
+ elsif ($val eq 'undef') {
+ $data{perl}{threads} = 'No';
+ }
+ else {
+ $quiet or warn qq{Unknown perl threads value: $val\n};
+ }
+ }
+
+ $data{perl}{ithreads} = $UNKNOWN_VALUE;
+ if ($info =~ /\buseithreads=(\w+)/) {
+ my $val = $1;
+ if ($val eq 'define') {
+ $data{perl}{ithreads} = 'Yes';
+ }
+ elsif ($val eq 'undef') {
+ $data{perl}{ithreads} = 'No';
+ }
+ else {
+ $quiet or warn qq{Unknown perl ithreads value: $val\n};
+ }
+ }
+
+ ## Modules of interest
+ for my $mod (qw/DBI DBD::Pg DBD::Oracle DBD::Sqlite DBD::mysql Moose Mail::Sendmail Sys::Syslog
+ DBIx::Safe Time::HiRes Digest::MD5 YAML Net::SNMP/) {
+ delete $data{tmp_module};
+ my $COM = qq{perl -M$mod -e 'print \$${mod}::VERSION'};
+ run_command($COM, 'tmp_module');
+ if ($data{tmp_module} =~ /^($versionre)/) {
+ $data{perlmodver}{$mod} = $1;
+ }
+ }
+
+ return;
+
+} ## end of gather_perlinfo
+
+
+sub gather_uptime {
+
+ run_command('uptime', 'tmp_uptime');
+ my $info = $data{tmp_uptime};
+ if ($info =~ / up (\d+ \w+)/) {
+ $data{uptime} = $1;
+ }
+ if ($info =~ /(\d+) user/) {
+ $data{users_logged_in} = $1;
+ }
+ if ($info =~ /load averages?: ([\d\.]+)/) {
+ $data{load_average} = $1;
+ }
+
+ return;
+
+} ## end of gather_uptime
+
+
+sub gather_puppet {
+
+ return if ! exists $data{version}{puppet} or $data{version}{puppet} eq $UNKNOWN_VERSION;
+
+ run_command('puppet --genconfig', 'tmp_puppet');
+ my $info = $data{tmp_puppet};
+
+ if ($info !~ /^\s*classfile = (.+)/m) {
+ warn qq{puppet --genconfig did not reveal a classfile!\n};
+ return;
+ }
+ my $classfile = $1;
+ if (! -e $classfile) {
+ warn qq{puppet classfile "$classfile" does not exist!\n};
+ return;
+ }
+
+ run_command("cat $classfile", 'tmp_puppet_classes');
+ for my $line (split /\n/ => $data{tmp_puppet_classes}) {
+ chomp $line;
+ if ($line =~ /\w/) {
+ push @{$data{puppet}{class}} => $line;
+ }
+ }
+
+ return;
+
+} ## end of gather_puppet
+
+
+sub gather_lsmod {
+
+ run_command('lsmod', 'tmp_lsmod');
+ my $info = $data{tmp_lsmod};
+ while ($info =~ /^(\S+)\s+(\d+)\s+(.+)/gm) {
+ my ($mod,$size,$usedby) = ($1,$2,$3);
+ $data{lsmod}{$mod} = {size => $size, usedby => $usedby};
+ }
+
+ return;
+
+} ## end of gather_lsmod
+
+
+sub gather_lifekeeper {
+
+ run_command('lcdstatus -qu', 'tmp_lk');
+ my $info = $data{tmp_lk};
+ while ($info =~ /^(\S+) (\S+).+?(\S+)\s+(\d+)\s+(\S+)$/gm) {
+ $data{lifekeeper}{service}{$2} =
+ {
+ local => $1,
+ state => $3,
+ prio => $4,
+ primary => $5,
+ };
+ }
+ while ($info =~ /^(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\d+)$/gm) {
+ $data{lifekeeper}{members}{"$1$3"} =
+ {
+ machine => $1,
+ network => $2,
+ address => $3,
+ state => 4,
+ prio => $5,
+ };
+ }
+
+ return;
+
+} ## end of gather_lifekeeper
+
+
+sub gather_heartbeat {
+
+ run_command('cl_status hbstatus', 'tmp_heartbeat');
+ my $info = $data{tmp_heartbeat};
+ if ($info =~ /Heartbeat is/) {
+ $data{heartbeat}{active} = $info;
+ }
+
+ run_command('cl_status listnodes', 'tmp_heartbeat');
+ $info = $data{tmp_heartbeat};
+ if ($info =~ /\w/ and $info !~ /ERROR:/) {
+ while ($info =~ /(\S+)/g) {
+ push @{$data{heartbeat}{node}}, $1;
+ }
+ }
+
+ for my $file (qw{ /etc/ha.cf /etc/ha.d/ha.cf }) {
+ if (-e $file) {
+ run_command("cat $file", 'tmp_heartbeat_config');
+ if (exists $data{tmp_heartbeat_config}) {
+ $data{heartbeat}{config} = $data{tmp_heartbeat_config};
+ last;
+ }
+ }
+ }
+
+ my $dir = '/etc/ha.d/resource.d';
+ if (-d $dir) {
+ my $dh;
+ if (opendir my $dh, $dir) {
+ my @rlist = grep { -f "$dir/$_" } readdir $dh;
+ closedir $dh;
+ $data{heartbeat}{resources} = \@rlist;
+ }
+ }
+
+ my $file = '/etc/ha.d/haresources';
+ if (-e $file) {
+ run_command("cat $file", 'tmp_heartbeat');
+ my $info = $data{tmp_heartbeat};
+ if ($info =~ /\w/) {
+ chomp $info;
+ $data{heartbeat}{haresources} = $info;
+ }
+ }
+
+ return;
+
+} ## end of gather_heartbeat
+
+
+sub gather_gems {
+
+ run_command('gem list --local', 'tmp_gems');
+ my $info = $data{tmp_gems};
+
+ return if $info !~ /\(\d+\.\d+/;
+
+ while ($info =~ m{^(\w+) \((\d+\.\d+\.?\d*)\)}gsm) {
+ $data{gems}{$1} = $2;
+ }
+
+ return;
+
+} ## end of gather_gems
+
+
+sub gather_postgresinfo {
+
+ return if $opt{nopostgres};
+
+ $ENV{PGUSER} ||= 'postgres';
+
+ my $pg_config = $ENV{PG_CONFIG} || 'pg_config';
+
+ run_command($pg_config, 'tmp_pgconfig');
+ my $info = $data{tmp_pgconfig};
+ if ($info !~ /BINDIR/) {
+ $verbose and warn "Call to $pg_config failed: custom path?\n";
+ }
+ else {
+ %{$data{postgres}{pgconfig}} = map { m/(.+?) = (.*)/; $1,$2; } split /\n/ => $info;
+ }
+
+ ## Only Linux, but we'll try all:
+ run_command('netstat -anp', 'tmp_netstat');
+ $info = $data{tmp_netstat};
+ $info =~ s{\d+/postgres: pos \S+PGSQL}{SKIP_OLD_POSTGRES}g;
+ $info =~ s{\d+/pgbouncer\s+\S+PGSQL\.\d}{SKIP_PGBOUNCER}g;
+
+ my ($oldpguser, $oldpgdb) = ('','');
+
+#unix 2 [ ACC ] STREAM LISTENING 568019 17851/postgres socket/.s.PGSQL.5432
+
+ PG: while ($info =~ /^(.+?)((\S+)\.s\.PGSQL\.(\d+))$/mg) {
+ my ($extra,$cluster,$dir,$port) = ($1,$2,$3,$4);
+ next if exists $data{postgres}{active_port}{$cluster};
+ $data{postgres}{active_port}{$cluster} = { socketdir => $dir, port => $port, extra => $extra };
+ my $c = $data{postgres}{active_port}{$cluster};
+ my $pid = ($extra =~ /(\d+)\D+$/) ? $1 : '';
+
+ ## Let's grab the user as well - they may not have created a 'postgres' user within the database
+ run_command(qq{strings /proc/$pid/environ}, 'tmp_environ');
+ if ($data{tmp_environ} =~ /USER=(\w+)/) {
+ $c->{user} = $1;
+ }
+
+ ## Get the full path for this process
+ run_command(qq{pwdx $pid}, 'tmp_pwdx');
+ if ($data{tmp_pwdx} =~ m{\(deleted\)}) {
+ #warn "DELETED: skipping\n";
+ $c->{deleted} = 1;
+ next PG;
+ }
+ if ($data{tmp_pwdx} =~ /^\d+: (\S+)/) {
+ $c->{homedir} = $1;
+ }
+
+ ## If dir is relative, use the full path instead
+ if ($dir !~ m{^/} and $c->{homedir}) {
+ $dir = "$c->{homedir}/$dir";
+ $c->{socketdir} = $dir;
+ }
+
+ ## In case we swapped out the connection information
+ if ($oldpguser) {
+ $ENV{PGUSER} = $oldpguser;
+ $oldpguser = '';
+ }
+ if ($oldpgdb) {
+ $ENV{PGDATABASE} = $oldpgdb;
+ $oldpgdb = '';
+ }
+
+ ## Let's connect and get some information
+ my $usedir = $opt{postgresnohost} ? '' : "-h $dir";
+ my $PSQL = qq{psql -X -Ax -qt $usedir -p $port};
+
+ run_command(qq{psql -X -x -t $usedir -p $port -c "\\l+"}, 'tmp_psql');
+ my $pinfo = $data{tmp_psql};
+ ## Need to figure out the problem, but we cannot set lc_messages first!
+ my $problem = '';
+
+ if ($pinfo =~ /FATAL: Ident authentication failed for user "postgres"/ and 0 == $>) {
+ $problem = 'ident';
+ }
+ elsif ($pinfo =~ /FATAL: role.+does not exist/ and exists $c->{user}) {
+ $problem = 'role';
+ }
+ elsif ($pinfo =~ /ERROR.+shobj_description/) {
+ $problem = 'mismatch';
+ }
+ elsif ($pinfo =~ /FATAL.+postgres/) {
+ $problem = 'ident role mismatch';
+ }
+
+ RERUN: {
+ last if ! $problem;
+
+ $opt{use_su_postgres} = 0;
+
+ if ($problem =~ s/ident//) {
+ warn "Direct psql call failed, trying su -l postgres\n";
+ $opt{use_su_postgres} = 1;
+ run_command(qq{psql -X -x -t $usedir -p $port -c "\\l+"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ }
+ elsif ($problem =~ s/role//) {
+ warn qq{Failed to connect to Postgres, retrying as user "$c->{user}"\n};
+ $ENV{PGUSER} = $c->{user};
+ $ENV{PGDATABASE} = 'postgres';
+ $opt{use_pg_user} = $c->{user};
+ run_command(qq{psql -X -x -t $usedir -p $port -c "\\l+"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ }
+ elsif ($problem =~ s/mismatch//) {
+ ## Mismatched psql version, but non-plussed should work
+ run_command(qq{psql -X -x -t $usedir -p $port -c "\\l"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ }
+ else {
+ warn "Unhandled problem: $problem\n";
+ $problem = '';
+ }
+
+ ## If we still have ways left to try and we failed in certain ways, try again
+ if ($problem =~ /\w/) {
+ if ($pinfo =~ /FATAL/ or $pinfo eq '?') {
+ redo RERUN;
+ }
+ }
+ }
+
+ my $startupstring = 'database system is starting up';
+
+ if ($pinfo =~ /$startupstring/) {
+ warn "DB may be starting up, sleeping for a retry..\n";
+ sleep 2;
+ run_command(qq{psql -X x -t $usedir -p $port -c "\\l+"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ if ($pinfo =~ /$startupstring/) {
+ $c->{startingup} = 1;
+ ## Can we check for a recovery.conf file?
+
+ ## Make a good guess at the current data directory
+ my $datadir = '';
+
+ ## Figure out the PID
+ if ($extra =~ m{(\d+)/postgres}) {
+ my $pid = $1;
+ run_command("ps -Afw | grep $pid", 'tmp_pid');
+ if ($data{tmp_pid} =~ /postgres -D (\S+)/) {
+ $datadir = $1;
+ }
+ }
+ if (! $datadir) {
+ run_command(q{grep postgres /etc/passwd | cut -d":" -f 6}, 'tmp_datadir');
+ if ($data{tmp_datadir} =~ m{^/}) {
+ $datadir = "$data{tmp_datadir}/data";
+ }
+ }
+
+ if ($datadir and -d $datadir) {
+ $c->{datadir} = $datadir;
+ my $recfile = "$datadir/recovery.conf";
+ if (-e $recfile) {
+ run_command("cat $recfile", 'tmp_recfile');
+ $c->{recfile} = $data{tmp_recfile};
+ }
+
+ my $verfile = "$datadir/PG_VERSION";
+ if (-e $verfile) {
+ run_command("cat $verfile", 'tmp_verfile');
+ $c->{version}{full} = $c->{version}{majmin} = $data{tmp_verfile};
+ }
+
+ for my $linkdir (qw/pg_xlog pg_log pg_clog/) {
+ my $xfile = "$datadir/$linkdir";
+ my $xlog = readlink($xfile);
+ if (defined $xlog and $xlog ne $xfile) {
+ $c->{symlink}{$linkdir} = $xlog;
+ }
+ }
+
+ my $conffile = "$datadir/postgresql.conf";
+ if (-e $conffile) {
+ run_command("cat $conffile", 'tmp_conffile');
+ my ($source, $unit) = ('File', '???');
+ for my $line (split /\n/ => $data{tmp_conffile}) {
+ $line =~ s/\s+$//;
+ next if ! length $line;
+ next if $line =~ /^\s*#/;
+ if ($line =~ /^\s*(\w+)\s*=\s*(\w+)/) {
+ $c->{setting}{$1} = { value => $2, source => $source, unit => $unit };
+ }
+ elsif ($line =~ /^\s*(\w+)\s*=\s*'(.*?)'/) {
+ $c->{setting}{$1} = { value => $2, source => $source, unit => $unit };
+ }
+ else {
+ warn ">>Could not parse postgresql.conf line: $line\n";
+ }
+ }
+ if (!exists $c->{setting}{data_directory}) {
+ $c->{setting}{data_directory} = { value => $datadir, source => 'Derived', unit => '' };
+ }
+ run_command("du -hs $datadir", 'tmp_ddsize');
+ if ($data{tmp_ddsize} =~ /^(\d+\S+)/) {
+ $c->{datadirsize}= $1;
+ }
+
+ }
+ } ## end found the data
+
+ ## Cause it to get skipped below:
+ $pinfo = 'FATAL: SKIP';
+ }
+ }
+
+ if (skip_pg_database($pinfo,$port,$dir)) {
+ $opt{use_su_postgres} = 0;
+ next PG;
+ }
+
+ ## If no match, see if we can get the complete socket
+ if ($pinfo !~ /\|/ and $dir !~ m{^/}) {
+ run_command("locate ${dir}.s.PGSQL.$port", 'tmp_psql');
+ if ($data{tmp_psql} =~ /^(.*${dir})\.s\.PGSQL\.$port\b/) {
+ my $newsock = $1;
+ my $sdir = "$newsock.s.PGSQL.$port";
+ if (-S $sdir) {
+ $dir = $c->{largesocketdir} = $newsock;
+ run_command(qq{psql -X -x -t -A $usedir -p $port -c "\\l+"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ if ($pinfo !~ /\|/) {
+ ## Try as the user that owns the database
+ $oldpguser = $ENV{PGUSER} || 'postgres';
+ $oldpgdb = $ENV{PGDATABASE} || 'postgres';
+ run_command(qq{stat -c '\%U' $sdir}, 'tmp_stat');
+ if ($data{tmp_stat} =~ /(\w+)/) {
+ $ENV{PGUSER} = $1;
+ $ENV{PGDATABASE} = 'postgres';
+ }
+ run_command(qq{psql -X -x -t -A $usedir -p $port -c "\\l+"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ }
+ }
+ }
+ }
+ if ($pinfo !~ /\|/) {
+ warn "Could not find database at host $dir and port $port\n";
+ $opt{use_su_postgres} = 0;
+ next PG;
+ }
+
+ my ($n,$v);
+ my $currname = '';
+
+ for my $db (split /\n/ => $pinfo) {
+ if ($db =~ /^(\w+).*\| (.*)/) {
+ ($n,$v) = (lc $1,$2||'');
+ if ($n eq 'name') {
+ $currname = $v;
+ }
+ $c->{db}{$currname}{$n} = $v;
+ }
+ elsif ($db =~ /^\-\-/) {
+ ## EOR
+ }
+ elsif ($db =~ /^\s+[:\|] (.+)/) {
+ $c->{db}{$currname}{$n} .= "\n$1";
+ }
+ else {
+ die "Unknown line: $db";
+ }
+ }
+
+ my $SQL = 'SELECT datname,datistemplate,datallowconn,datconnlimit,age(datfrozenxid),datacl,pg_database_size(oid) FROM pg_database';
+ run_command(qq{psql -X -t -A $usedir -p $port -c "$SQL"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ if ($pinfo =~ /ERROR/ or $pinfo =~ /FATAL/) {
+ warn "Could not connect to Postgres: $pinfo\n";
+ $opt{use_su_postgres} = 0;
+ next PG;
+ }
+
+ for my $db (split /\n/ => $pinfo) {
+ my ($name,$template,$canconn,$limit,$age,$acl,$size) = split /\|/ => $db;
+ my $info = $c->{db}{$name};
+ $info->{template} = $template eq 't' ? 'Yes' : 'No';
+ $info->{canconn} = $canconn eq 't' ? 'Yes' : 'No';
+ $info->{limit} = $limit;
+ $info->{acl} = $acl;
+ $info->{age} = $age;
+ $info->{size} = pretty_size($size,1);
+ ($info->{quoted_db_name} = $name) =~ s/"/\\"/g;
+ }
+
+ $SQL = 'SELECT version()';
+ run_command(qq{psql -X -t -A $usedir -p $port -c "$SQL"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ die $pinfo if $pinfo !~ /PostgreSQL (\S+)/;
+ my $ver = $1;
+ $c->{version}{full} = $ver;
+
+ if ($ver =~ /^(\d+)beta/) { ## e.g. 10beta1
+ $c->{version}{major} = $c->{version}{majmin} = $1;
+ $c->{version}{minor} = 0;
+ }
+ elsif ($ver =~ /^(\d+)\.(\d+)beta/) { ## e.g. 9.4beta1
+ $c->{version}{major} = $1;
+ $c->{version}{minor} = $2;
+ $c->{version}{majmin} = "$1$2";
+ }
+ elsif ($ver =~ /^(\d+)\.(\d+)\.(\d+)/) { ## e.g. 9.4.5
+ $c->{version}{major} = $1;
+ $c->{version}{minor} = $2;
+ $c->{version}{revision} = $3;
+ $ver = $c->{version}{majmin} = "$1.$2";
+ }
+ elsif ($ver =~ /^(\d+)\.(\d+)/) { ## e.g. 10.1
+ $c->{version}{major} = $c->{version}{majmin} = $1;
+ $c->{version}{minor} = 0;
+ $c->{version}{revision} = $2;
+ }
+ else {
+ die "Could not determine Postgres version from: $ver\n";
+ }
+ $c->{version}{revision} ||= 0;
+
+
+ ## Tablespace info
+ if ($c->{version}{majmin} >= 9.2) {
+ $SQL = 'SELECT spcname, spcowner, pg_tablespace_location(oid) as spclocation, spcacl FROM pg_tablespace';
+ } else {
+ $SQL = 'SELECT spcname, spcowner, spclocation, spcacl FROM pg_tablespace';
+ }
+ run_command(qq{psql -X -t -A $usedir -p $port -c "$SQL"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ for my $db (split /\n/ => $pinfo) {
+ my ($name,$owner,$location,$acl) = split /\|/ => $db;
+ next if ($name eq 'pg_default' or $name eq 'pg_global') and $location !~ /\w/;
+ my $info = $c->{dbtablespace}{$name} = [$location,$owner,$acl];
+ $data{gottablespaces} = 1;
+ }
+
+ $SQL = 'SELECT name,source,unit,setting FROM pg_settings';
+ if ($c->{version}{majmin} < 8.2) {
+ $SQL =~ s/unit/'?' AS unit/;
+ }
+ run_command(qq{psql -X -t -A $usedir -p $port -c "$SQL"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ die $pinfo if $pinfo =~ /ERROR/ or $pinfo =~ /FATAL/;
+ for my $line (split /\n/ => $pinfo) {
+ my ($name,$source,$unit,$setting) = split /\|/ => $line => 4;
+ $c->{setting}{$name} = { value => $setting, source => $source, unit => $unit };
+ }
+
+ my $datadir = $c->{setting}{data_directory}{value};
+ for my $linkdir (qw/pg_xlog pg_log pg_clog/) {
+ my $xfile = "$datadir/$linkdir";
+ my $xlog = readlink($xfile);
+ if (defined $xlog and $xlog ne $xfile) {
+ $c->{symlink}{$linkdir} = $xlog;
+ }
+ }
+
+ ## Things individual to each database
+ for my $db (sort keys %{$c->{db}}) {
+ my $info = $c->{db}{$db};
+ my $qdb = $info->{quoted_db_name};
+ next if $info->{canconn} eq 'No';
+ $SQL = 'SELECT relkind, count(*) FROM pg_class c JOIN pg_namespace n ON (n.oid = c.relnamespace) '.
+ q{WHERE n.nspname !~ '^pg_' AND n.nspname <> 'information_schema' GROUP BY 1};
+ run_command(qq{psql -X -t -A $usedir -p $port --dbname "$qdb" -c "$SQL"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ die $pinfo if $pinfo =~ /ERROR/ or $pinfo =~ /FATAL/;
+ for my $line (split /\n/ => $pinfo) {
+ my ($relkind,$count) = split /\|/ => $line;
+ $c->{db}{$db}{relcount}{$relkind} = $count;
+ }
+
+ ## Slony stuff
+ $SQL = q{SELECT nspname FROM pg_attribute a }
+ . q{JOIN pg_class c ON (c.oid = a.attrelid AND c.relname = 'sl_log_1') }
+ . q{JOIN pg_namespace n ON (n.oid = c.relnamespace) }
+ . q{WHERE attname = 'log_xid'};
+ run_command(qq{psql -X -t -A $usedir -p $port -c "$SQL" --dbname "$qdb"}, 'tmp_slony');
+ $pinfo = $data{tmp_slony};
+ if ($pinfo =~ /\w/) {
+ my $slonyschema = $info->{slony}{schema} = $pinfo;
+ $data{gotslony}++;
+ $c->{gotslony}++;
+
+ $SQL = "SELECT pa_server || '-' || pa_client, pa_conninfo FROM $slonyschema.sl_path ORDER BY pa_server, pa_client";
+ run_command(qq{psql -X -t -A $usedir -p $port -c "$SQL" --dbname "$qdb"}, 'tmp_slony');
+ $pinfo = $data{tmp_slony};
+ for my $line (split /\n/ => $pinfo) {
+ push @{$info->{slony}{paths}}, $line;
+ }
+
+ $SQL = "SELECT tab_nspname || '.' || tab_relname FROM $slonyschema.sl_table ORDER BY tab_id";
+ run_command(qq{psql -X -t -A $usedir -p $port -c "$SQL" --dbname "$qdb"}, 'tmp_slony');
+ $pinfo = $data{tmp_slony};
+ for my $line (split /\n/ => $pinfo) {
+ push @{$info->{slony}{tables}}, $line;
+ }
+
+ $SQL = "SELECT seq_nspname || '.' || seq_relname FROM $slonyschema.sl_sequence ORDER BY seq_id";
+ run_command(qq{psql -X -t -A $usedir -p $port -c "$SQL" --dbname "$qdb"}, 'tmp_slony');
+ $pinfo = $data{tmp_slony};
+ for my $line (split /\n/ => $pinfo) {
+ push @{$info->{slony}{sequences}}, $line;
+ }
+ } ## end Slony
+
+ ## Bucardo stuff
+ BUCARDO: {
+ ## Is this a master Bucardo database?
+ if ($qdb eq 'bucardo') {
+
+ $data{gotbucardo}++;
+ $c->{gotbucardo}++;
+
+ ## Slurp in information from various bucardo tables
+ ## Complain if the table does not exist
+ my %bucardo_table = (
+ db => 'name',
+ sync => 'name',
+ goat => 'id',
+ herd => 'name',
+ bucardo_config => 'setting',
+ );
+ for my $tablename (sort keys %bucardo_table) {
+ $info->{bucardo}{$tablename} ||= {};
+ $SQL = qq{SELECT * FROM bucardo.$tablename};
+ slurp_table_info({
+ command => qq{psql -X -x -t $usedir -p $port -c "$SQL" --dbname "$qdb"},
+ var => $info->{bucardo}{$tablename},
+ pk => $bucardo_table{$tablename},
+ failregex => "bucardo.$tablename",
+ failregexmsg => "Odd - database named bucardo has no bucardo.$tablename table!",
+ });
+ }
+
+ } ## end if db named bucardo
+ } ## end BUCARDO
+
+ ## pg_autovacuum settings
+ $SQL = q{SELECT * FROM pg_autovacuum};
+ run_command(qq{psql -X -t -A $usedir -p $port -c "$SQL" --dbname "$qdb"}, 'tmp_slony');
+ $pinfo = $data{tmp_autovac};
+
+ } ## end each db
+
+ $SQL = q{SELECT nspname FROM pg_catalog.pg_namespace WHERE nspname !~ '^pg_' AND nspname <> 'information_schema'};
+ for my $db (sort keys %{$c->{db}}) {
+ my $info = $c->{db}{$db};
+ next if $info->{canconn} eq 'No';
+ my $qdb = $info->{quoted_db_name};
+ run_command(qq{psql -X -t -A $usedir -p $port -c "$SQL" --dbname "$qdb"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ die $pinfo if $pinfo =~ /ERROR/ or $pinfo =~ /FATAL/;
+ for my $line (split /\n/ => $pinfo) {
+ next if $line !~ /\w/;
+ $c->{db}{$db}{relcount}{schema}++;
+ $c->{db}{$db}{schema}{$line} = 1;
+ }
+ }
+
+ $SQL = 'SELECT count(*) FROM pg_proc p JOIN pg_namespace n ON (n.oid = p.pronamespace) '.
+ q{WHERE n.nspname !~ '^pg_' AND n.nspname <> 'information_schema'};
+ for my $db (sort keys %{$c->{db}}) {
+ my $info = $c->{db}{$db};
+ next if $info->{canconn} eq 'No';
+ my $qdb = $info->{quoted_db_name};
+ run_command(qq{psql -X -t -A $usedir -p $port -c "$SQL" --dbname "$qdb"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ die $pinfo if $pinfo =~ /ERROR/ or $pinfo =~ /FATAL/;
+ for my $line (split /\n/ => $pinfo) {
+ next unless $line =~ /(\d+)/;
+ $c->{db}{$db}{relcount}{f} = $1;
+ }
+ }
+
+ ## Languages
+ $SQL = 'SELECT lanname FROM pg_language WHERE lanispl IS TRUE';
+ for my $db (sort keys %{$c->{db}}) {
+ my $info = $c->{db}{$db};
+ next if $info->{canconn} eq 'No';
+ my $qdb = $info->{quoted_db_name};
+ run_command(qq{psql -X -t -A $usedir -p $port -c "$SQL" --dbname "$qdb"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ die $pinfo if $pinfo =~ /ERROR/ or $pinfo =~ /FATAL/;
+ for my $line (split /\n/ => $pinfo) {
+ next unless $line =~ /(\w+)/;
+ $c->{db}{$db}{language}{$1}++;
+ }
+ }
+
+ ## Disabled triggers
+ my $SQL82 = q{SELECT tgrelid::regclass, tgname, tgenabled FROM pg_trigger WHERE tgenabled IS NOT TRUE ORDER BY tgname};
+ my $SQL83 = q{SELECT tgrelid::regclass, tgname, tgenabled FROM pg_trigger WHERE tgenabled = 'D' ORDER BY tgname};
+ for my $db (sort keys %{$c->{db}}) {
+ my $info = $c->{db}{$db};
+ next if $info->{canconn} eq 'No';
+ my $qdb = $info->{quoted_db_name};
+ $SQL = $c->{version}{majmin} >= 8.3 ? $SQL83 : $SQL82;
+ run_command(qq{psql -X -t -A $usedir -p $port -c "$SQL" --dbname "$qdb"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ die $pinfo if $pinfo =~ /ERROR/ or $pinfo =~ /FATAL/;
+ for my $line (split /\n/ => $pinfo) {
+ if ($line !~ /(.+?)\|(.+?)\|(.+)/) {
+ warn "Invalid line for trigger checks: $line\n";
+ next;
+ }
+ push @{$c->{db}{$db}{disabled_triggers}}, [$1,$2,$3];
+ $data{postgres}{problems}++;
+ $c->{problems}++;
+ $c->{db}{$db}{problems}++;
+ }
+ }
+
+ ## Installed modules
+ for my $db (sort keys %{$c->{db}}) {
+ my $info = $c->{db}{$db};
+ next if $info->{canconn} eq 'No';
+ my $qdb = $info->{quoted_db_name};
+ ## PostGIS
+ $SQL = "SELECT 1 FROM pg_proc WHERE proname = 'postgis_full_version'";
+ run_command(qq{psql -X -t -A $usedir -p $port -c "$SQL" --dbname "$qdb"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ if ($pinfo =~ /1/) {
+ for my $name (qw/postgis_full_version postgis_lib_build_date postgis_scripts_build_date/) {
+ $SQL = "SET lc_messages='C'; SELECT $name()";
+ run_command(qq{psql -X -t -A $usedir -p $port -c "$SQL" --dbname "$qdb"}, 'tmp_psql');
+ $pinfo = $data{tmp_psql};
+ if ($pinfo !~ /ERROR/) {
+ $info->{postgis}{$name} = $data{tmp_psql};
+ $c->{gotpostgis}++;
+ $data{gotpostgis}++;
+ }
+ }
+ }
+ ## Others
+ CNAME:
+ my %contrib_modules = (
+ 'citext' => ['F:citext_smaller', ''],
+ 'cube' => ['F:cube_distance', ''],
+ 'dblink' => ['F:dblink_connect', ''],
+ 'earthdistance' => ['F:earth_distance', ''],
+ 'fuzzystrmatch' => ['F:dmetaphone_alt', ''],
+ 'hstore' => ['F:hstore_out', ''],
+ 'intarray' => ['F:intarray_del_elem', ''],
+ 'ltree' => ['F:ltree2text', ''],
+ 'pgcrypto' => ['F:gen_salt', ''],
+ 'pg_freespacemap' => ['F:pg_freespace', ''],
+ 'pgstattuple' => ['F:pgstattuple', ''],
+ 'pg_trgm' => ['F:show_trgm', ''],
+ 'tablefunc' => ['F:crosstab4', ''],
+ 'tsearch2' => ['F:to_tsvector', '8.3'],
+ 'uuid' => ['F:uuid_ns_x500', ''],
+ );
+
+ CNAME: for my $cname (sort keys %contrib_modules) {
+ my ($action,$version) = @{$contrib_modules{$cname}};
+ if ($action =~ s/F://) {
+ $SQL = "SELECT count(*) FROM pg_proc WHERE proname = '$action'";
+ run_command(qq{$PSQL -c "$SQL" --dbname "$qdb"}, 'tmp_psql');
+ if ($data{tmp_psql} =~ /(\d+)/) {
+ my $num = $1;
+ if ($num) {
+ if ($version =~ /(\d+)\.(\d+)/) {
+ my ($maj,$min) = ($1,$2);
+ my ($Maj,$Min) = ($c->{version}{major},$c->{version}{minor});
+ next CNAME if $Maj > $maj or ($Maj==$maj and $Min >= $min);
+ }
+ $info->{contrib}{$cname} = 1;
+ $c->{hascontrib}++;
+ }
+ }
+ }
+ else {
+ die "Do not know how to handle action of $action for contrib module $cname!\n";
+ }
+ }
+ }
+
+
+ $opt{use_su_postgres} = 0;
+
+
+ } ## end each active port
+
+ return;
+
+} ## end of gather_postgresinfo
+
+
+sub gather_mysqlinfo {
+
+ return if $opt{nomysql} or ! exists $data{version}{mysql} or $data{version}{mysql} eq $UNKNOWN_VERSION;
+
+ run_command(q{mysqlshow --verbose}, 'tmp_mysqlshow');
+ my $info = $data{tmp_mysqlshow};
+
+ for my $line (split /\n/ => $info) {
+ next unless $line =~ m{^\| (.+)\s+\|\s+(\d+) \|$};
+ $data{mysql}{database}{$1} = {tables => $2};
+ }
+
+ run_command(q{mysql_config --port}, 'tmp_mysqlport');
+ $data{mysql}{port} = $data{tmp_mysqlport} =~ /(\d+)/ ? $1 : '?';
+
+ run_command(q{mysql_config --socket}, 'tmp_mysqlsocket');
+ $data{mysql}{socket} = $data{tmp_mysqlsocket} || '?';
+
+ run_command(q{mysqladmin status}, 'tmp_mysqladmin');
+ if ($data{tmp_mysqladmin} =~ /Uptime/) {
+ @{$data{mysql}{status}} = split / / => $data{tmp_mysqladmin};
+ }
+
+ return;
+
+} ## end of gather_mysqlinfo
+
+
+sub skip_pg_database {
+
+ ## Return true if we should skip this database
+ ## Pass in the result from run_command
+
+ my $msg = shift;
+
+ return 0 if $msg !~ /ERROR/ and $msg !~ /FATAL/;
+
+ return 1 if $msg =~ /FATAL: SKIP/;
+
+ my $port = shift or die;
+ my $socket = shift or die;
+
+ if (exists $opt{skippgport}) {
+ if ($opt{skippgport} =~ /\b$port\b/) {
+ $verbose and warn "Skipping Postgres database port $port\n";
+ return 1;
+ }
+ }
+
+ my $line = (caller)[2];
+ warn qq{(Line $line) Connection to port $port, socket $socket failed: $msg\n};
+ warn qq{Perhaps skip this cluster with --skippgport=$port?\n};
+ return 1;
+
+} ## end of skip_pg_database
+
+
+sub pretty_size {
+
+ ## Transform number of bytes to a SI display similar to Postgres' format
+
+ my $bytes = shift;
+
+ return "$bytes bytes" if $bytes < 10240;
+
+ my @unit = qw/kB MB GB TB PB EB YB ZB/;
+
+ for my $p (1..@unit) {
+ if ($bytes <= 1024**$p) {
+ $bytes /= (1024**($p-1));
+ my $final = sprintf '%.2f %s', $bytes, $unit[$p-2];
+ $final =~ s/\.00 / /;
+ return $final;
+ }
+ }
+
+ return $bytes;
+
+} ## end of pretty_size
+
+
+sub pretty_conf {
+
+ ## Transform ugly configuration values to something better
+
+ my ($name,$val,$unit) = @_;
+
+ my $newval = $val;
+
+ return $newval if $unit eq '???';
+
+ ## -1 is always 'off'
+ if ('-1' eq $val) {
+ if ($name eq 'autovacuum_vacuum_cost_delay') {
+ $newval = '-1 (use vacuum_cost_delay)';
+ }
+ elsif ($name eq 'autovacuum_vacuum_cost_limit') {
+ $newval = '-1 (use vacuum_cost_limit)';
+ }
+ else {
+ $newval = '-1 (off)';
+ }
+ }
+ ## 0 can have a special meaning, but never gets expanded per below
+ elsif ('0' eq $val) {
+ if ($name eq 'log_temp_files') {
+ $newval = '0 (log all temporary files)';
+ }
+ elsif ($name eq 'log_min_duration_statement') {
+ $newval = '0 (log all durations)';
+ }
+ elsif ($name eq 'log_autovacuum_min_duration') {
+ $newval = '0 (log all autovac activity)';
+ }
+ elsif ($name eq 'archive_timeout' or $name eq 'checkpoint_warning') {
+ $newval = '0 (off)';
+ }
+ elsif ($name eq 'log_rotation_size' or $name eq 'log_rotation_age') {
+ $newval = '0 (no rotation)';
+ }
+ elsif ($name eq 'statement_timeout') {
+ $newval = '0 (disabled)';
+ }
+ else {
+ $newval = '0';
+ }
+ }
+ elsif ($unit eq 's' or $unit eq 'ms' or $unit eq 'min') {
+ if (0 == $val) {
+ $newval = '0';
+ }
+ else {
+ $newval = sprintf '%s (%s)', $val, pretty_time
+ ($unit eq 's' ? $val : $unit eq 'ms' ? ($val/1000) : ($val*60));
+ }
+ }
+ elsif ($unit eq '8kB') {
+ $newval = !$val ? $val : sprintf "$val (%s)", pretty_size($val*8192);
+ }
+ elsif ($unit eq 'kB') {
+ $newval = !$val ? $val : sprintf "$val (%s)", pretty_size($val*1024);
+ }
+
+ return $newval;
+
+} ## end of pretty_conf
+
+
+sub msg { ## no critic
+
+ my $name = shift || '?';
+
+ my $msg = '';
+
+ if (exists $msg{$lang}{$name}) {
+ $msg = $msg{$lang}{$name};
+ }
+ elsif (exists $msg{'en'}{$name}) {
+ $msg = $msg{'en'}{$name};
+ }
+ else {
+ my $line = (caller)[2];
+ die qq{Invalid message "$name" from line $line\n};
+ }
+
+ my $x=1;
+ {
+ my $val = $_[$x-1];
+ $val = '?' if ! defined $val;
+ last unless $msg =~ s/\$$x/$val/g;
+ $x++;
+ redo;
+ }
+ return $msg;
+
+} ## end of msg
+
+
+sub pretty_time {
+
+ ## Transform number of seconds to a more human-readable format
+ ## First argument is number of seconds
+ ## Second optional arg is highest transform: s,m,h,d,w
+ ## If uppercase, it indicates to "round that one out"
+
+ my $sec = shift;
+ my $tweak = shift || '';
+
+ ## Round to two decimal places, then trim the rest
+ $sec = sprintf '%.2f', $sec;
+ $sec =~ s/0+$//o;
+ $sec =~ s/\.$//o;
+
+ ## Just seconds (< 2:00)
+ if ($sec < 120 or $tweak =~ /s/) {
+ return sprintf "$sec %s", $sec==1 ? msg('time-second') : msg('time-seconds');
+ }
+
+ ## Minutes and seconds (< 60:00)
+ if ($sec < 60*60 or $tweak =~ /m/) {
+ my $min = int $sec / 60;
+ $sec %= 60;
+ my $ret = sprintf "$min %s", $min==1 ? msg('time-minute') : msg('time-minutes');
+ $sec and $tweak !~ /S/ and $ret .= sprintf " $sec %s", $sec==1 ? msg('time-second') : msg('time-seconds');
+ return $ret;
+ }
+
+ ## Hours, minutes, and seconds (< 48:00:00)
+ if ($sec < 60*60*24*2 or $tweak =~ /h/) {
+ my $hour = int $sec / (60*60);
+ $sec -= ($hour*60*60);
+ my $min = int $sec / 60;
+ $sec -= ($min*60);
+ my $ret = sprintf "$hour %s", $hour==1 ? msg('time-hour') : msg('time-hours');
+ $min and $tweak !~ /M/ and $ret .= sprintf " $min %s", $min==1 ? msg('time-minute') : msg('time-minutes');
+ $sec and $tweak !~ /[SM]/ and $ret .= sprintf " $sec %s", $sec==1 ? msg('time-second') : msg('time-seconds');
+ return $ret;
+ }
+
+ ## Days, hours, minutes, and seconds (< 28 days)
+ if ($sec < 60*60*24*28 or $tweak =~ /d/) {
+ my $day = int $sec / (60*60*24);
+ $sec -= ($day*60*60*24);
+ my $our = int $sec / (60*60);
+ $sec -= ($our*60*60);
+ my $min = int $sec / 60;
+ $sec -= ($min*60);
+ my $ret = sprintf "$day %s", $day==1 ? msg('time-day') : msg('time-days');
+ $our and $tweak !~ /H/ and $ret .= sprintf " $our %s", $our==1 ? msg('time-hour') : msg('time-hours');
+ $min and $tweak !~ /[HM]/ and $ret .= sprintf " $min %s", $min==1 ? msg('time-minute') : msg('time-minutes');
+ $sec and $tweak !~ /[HMS]/ and $ret .= sprintf " $sec %s", $sec==1 ? msg('time-second') : msg('time-seconds');
+ return $ret;
+ }
+
+ ## Weeks, days, hours, minutes, and seconds (< 28 days)
+ my $week = int $sec / (60*60*24*7);
+ $sec -= ($week*60*60*24*7);
+ my $day = int $sec / (60*60*24);
+ $sec -= ($day*60*60*24);
+ my $our = int $sec / (60*60);
+ $sec -= ($our*60*60);
+ my $min = int $sec / 60;
+ $sec -= ($min*60);
+ my $ret = sprintf "$week %s", $week==1 ? msg('time-week') : msg('time-weeks');
+ $day and $tweak !~ /D/ and $ret .= sprintf " $day %s", $day==1 ? msg('time-day') : msg('time-days');
+ $our and $tweak !~ /[DH]/ and $ret .= sprintf " $our %s", $our==1 ? msg('time-hour') : msg('time-hours');
+ $min and $tweak !~ /[DHM]/ and $ret .= sprintf " $min %s", $min==1 ? msg('time-minute') : msg('time-minutes');
+ $sec and $tweak !~ /[DHMS]/ and $ret .= sprintf " $sec %s", $sec==1 ? msg('time-second') : msg('time-seconds');
+
+ return $ret;
+
+} ## end of pretty_time
+
+
+sub ip2hostname {
+
+ my $ip = shift || '';
+
+ return if exists $data{ip}{$ip};
+
+ return if $opt{nohost};
+
+ if ($ip eq '127.0.0.1') {
+ $data{ip}{$ip} = 'localhost';
+ return;
+ }
+
+ run_command("host -r -t A $ip", "tmp_host_$ip");
+
+ $data{ip}{$ip} = $data{"tmp_host_$ip"};
+
+ if ($data{ip}{$ip} =~ /NXDOMAIN/) {
+ $data{ip}{$ip} = '';
+ }
+
+ return;
+
+} ## end of ip2hostname
+
+
+sub run_command {
+
+ ## Attempt to run a command and gather the input
+ ## We store the raw input, and store pretty info in the main hash
+
+ my $command = shift;
+ my $name = shift or die "Need a name!\n";
+ my $specifictimeout = shift || 0;
+
+ if ($opt{use_su_postgres} and $command =~ /^psql/) {
+ if ($command =~ s{-c "(.+?)"}{}) {
+ my $innercom = $1;
+ my $file = '/tmp/boxinfo.tmp';
+ open my $fh, '>', $file or die qq{Could not open "$file": $!\n};
+ print {$fh} $innercom;
+ close $fh or warn qq{Could not close "$file": $!\n};
+ $command = qq{su -l postgres --command "$command --file $file"};
+ $verbose and warn "New command: $command\n";
+ }
+ }
+
+ $verbose and warn "run_command $command => $name\n";
+
+ printf {$debugfh} "\nCOMMAND: %s\nNAME: $name\nTIME: %s\nRESULT: ", $command, scalar localtime();
+
+ local $ENV{LC_ALL} = 'C';
+
+ my $result;
+ my $madeit = 0;
+ alarm 0;
+ local $SIG{ALRM} = sub { die 'Timed out' };
+ my $localtimeout = $specifictimeout || $timeout;
+ eval {
+ alarm $localtimeout;
+ $result = qx{$command 2>&1};
+ $madeit = 1;
+ };
+ if ($@) {
+ if ($@ =~ /Timed out/o) {
+ warn "Command timed out at $localtimeout seconds!\n";
+ warn "Command: $command\n";
+ $madeit = 0;
+ }
+ }
+ alarm 0;
+ if (!$madeit) {
+ $data{$name} = '?';
+ $data{failed_command}{$command} = $@;
+ print {$debugfh} "FAIL ($@)\n";
+ return;
+ }
+ if (! defined $result) {
+ $data{$name} = $UNKNOWN_VALUE;
+ print {$debugfh} "UNDEFINED\n";
+ return;
+ }
+
+ chomp $result;
+ $data{$name} = $result;
+ print {$debugfh} "OK $result\n";
+
+ $verbose and warn "Command finished OK\n";
+
+ return;
+
+} ## end of run_command
+
+
+sub create_html_output {
+
+ my $file = 'boxinfo.html';
+ open my $fh, '>', $file or die qq{Could not open "$file": $!\n};
+ my $oldselect = select $fh;
+
+ my @ip;
+ for my $int (sort keys %{$data{interface}}) {
+ my $d = $data{interface}{$int};
+ next unless exists $d->{UP} and exists $d->{RUNNING} and exists $d->{address};
+ my $ip = $d->{address};
+ my $host = $data{ip}{$ip} || $UNKNOWN_VALUE;
+ push @ip, qq{<b>$ip</b> $host};
+ }
+ my $iplist = join "<br />\n" => @ip;
+
+ if ('html' eq $format) {
+ print qq{<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
+<head>
+<title>boxinfo: Gather system information</title>
+<meta http-equiv="content-type" content="text/html;charset=utf-8" />
+<meta name="generator" content="boxinfo $VERSION" />
+
+<style type="text/css">
+table.boxinfo th { color: #006600; vertical-align: top; padding-top: 7px; padding-bottom: 15px; text-align: left; padding-left: 5px; padding-right: 5px; }
+
+table { empty-cells: show; margin-bottom: 20px; }
+
+table.bottom { margin-bottom: 30px; }
+
+table.boxinfo2 td { padding-left: 5px; padding-right: 5px; padding-top: 7px; padding-bottom: 15px; vertical-align: middle;}
+
+table.boxinfo td { padding-left: 2px; padding-right: 2px; vertical-align: middle; font-weight: bold;}
+
+table.boxinfo td.numbers { color: black; text-align: right; }
+
+table.plain { border-collapse: collapse; }
+table.plain td { font-weight: normal; border: solid #000000 1px; padding: 5px; }
+table.plain th { border: solid #000000 1px; padding: 5px; }
+
+table.boxinfo td.activeip { color: black; font-weight: bolder; }
+
+</style>
+</head>
+<body>};
+
+ }
+
+ if ('wiki' eq $format) {
+ my $gotpg = exists $data{postgres}{active_port} ? 1 : 0;
+ printf qq{[[Category:%s servers]]\n\n},
+ $gotpg ? 'Postgres' : 'Client';
+ printf qq{<h2>[[%s]] %s %s:</h2>\n\n},
+ $data{clientname},
+ $gotpg ? 'Postgres server' : 'server',
+ $data{shorthost};
+ }
+
+ my $cols = 1;
+ print qq{<table class="boxinfo" style="border: solid black 2px">\n};
+
+ print qq{<tr><th>Date gathered:</th><td><b>$data{program_start}</b></td></tr>\n};
+
+ print qq{<tr><th>Program version:</th><td><b>$data{program_version}</b></td></tr>\n};
+
+ print qq{<tr><th>Hostname:</th><td><b>$data{hostname}</b></td></tr>\n};
+
+ print qq{<tr><th>OS:</th><td><b>$data{OS}</b></td></tr>\n};
+
+ if ($opt{postgresonly}) {
+ html_postgres();
+ goto HTMLEND;
+ }
+
+ html_cpus();
+
+ print qq{<tr><th>RAM:</th><td><b>$data{memory}{pretty}{Total}</b></td></tr>\n};
+
+ html_vm();
+
+ html_rightscale();
+
+ html_ec2();
+
+ html_uptime();
+
+ html_lsb();
+
+ html_dist();
+
+ html_puppet();
+
+ html_kernel();
+
+ html_shared_memory();
+
+ html_shared_active();
+
+ html_hugepages();
+
+ html_lifekeeper();
+
+ html_heartbeat();
+
+ html_interfaces();
+
+ html_routes();
+
+ html_fs();
+
+ html_queues();
+
+ html_disk_settings();
+
+ html_versions();
+
+ html_perlinfo();
+
+ html_perlmodules();
+
+ html_gems();
+
+ html_chkconfig();
+
+ html_postgres();
+
+ html_mysql();
+
+ html_ulimits();
+
+ html_envs();
+
+ html_yum();
+
+ html_aptitude();
+
+ HTMLEND:
+
+print q{
+</table>
+};
+ if ('html' eq $format) {
+ print q{
+</body>
+</html>};
+ }
+
+ select $oldselect;
+ close $fh or die qq{Could not close "$file": $!\n};
+
+ print "Wrote $file\n";
+
+ return;
+
+} ## end of create_html_output
+
+
+sub html_postgres {
+ html_postgres_active();
+ html_postgres_recovery();
+ html_postgres_problems();
+ html_postgres_config();
+ html_postgres_databases();
+ html_postgres_tablespaces();
+ html_postgres_slony();
+ html_postgres_bucardo();
+ html_postgres_postgis();
+ html_postgres_pgconfig();
+ return;
+} ## end of html_postgres
+
+
+sub html_cpus {
+
+ return if ! exists $data{cpuinfo};
+
+ ## CPUs may be different - if so, list individually
+ ## If not, just say <number> x <info>
+
+ my $allthesame = 1;
+ my %cinfo;
+ CPU: for my $cpu (values %{$data{cpuinfo}}) {
+ for my $item ('model name', 'cache size', 'speed', 'cpu cores') {
+ next if ! exists $cpu->{$item};
+ $cpu->{$item} =~ s/\s+/ /g;
+ if (! exists $cinfo{$item}) {
+ $cinfo{$item} = $cpu->{$item};
+ }
+ elsif ($cpu->{$item} ne $cinfo{$item}) {
+ $allthesame=0;
+ last CPU;
+ }
+ }
+ }
+
+
+ if ($allthesame) {
+ my $cache = exists $cinfo{'cache size'} ? " Cache size: $cinfo{'cache size'}" : '';
+ print qq{<tr><th>CPU:</th><td><b>$data{numcpus} x $cinfo{'model name'} ($cinfo{speed})$cache</b></td></tr>\n};
+ return;
+ }
+
+ my @cpulist;
+ for my $num (sort { $a <=> $b } keys %{$data{cpuinfo}}) {
+ my $cpu = $data{cpuinfo}{$num};
+ my $cache = exists $cpu->{'cache size'} ? " Cache size: $cpu->{'cache size'}" : '';
+ push @cpulist => "CPU $num: $cpu->{'model name'} ($cpu->{speed})$cache";
+ }
+ my $cpulist = join '<br />' => @cpulist;
+ print qq{<tr><th>CPUs:</th><td><b>$cpulist</b></td></tr>\n};
+
+ return;
+
+} ## end of html_cpus
+
+
+sub html_vm {
+
+ return if ! exists $data{VM};
+
+ print qq{<tr><th>VM:</th><td><b>$data{VM}</b></td></tr>\n\n};
+
+ return;
+
+} ## end of html_vm
+
+
+sub html_rightscale {
+
+ return if ! exists $data{RightScale};
+
+ ## We assume a version is always provided
+ ## The cloud, however, may not be there
+ print qq{<tr><th>RightScale:</th><td>Release <b>$data{RightScale}{version}</b>};
+
+ if (exists $data{RightScale}{cloud}) {
+ printf ' Cloud: %s',
+ (defined $data{RightScale}{cloud} and length $data{RightScale}{cloud})
+ ? "<b>$data{RightScale}{cloud}</b>" : '?';
+ }
+ print qq{</td></tr>\n\n};
+
+ return;
+
+} ## end of html_rightscale
+
+sub html_ec2 {
+
+ return if ! exists $data{EC2};
+
+ print qq{<tr><th$vtop>${wrap}EC2:</th><td><br /><table border="1" style="border: black solid 1px">};
+ for my $name (sort keys %{$data{EC2}}) {
+ next if $name eq 'meta';
+ print qq{<tr><td>$name: </td><td><b>$data{EC2}{$name}</b></td></tr>\n};
+ }
+ if (exists $data{EC2}{meta}) {
+ for my $name (sort keys %{$data{EC2}{meta}}) {
+ my $value = $data{EC2}{meta}{$name};
+ if (ref $value eq 'HASH') {
+ $value = join '<br />'
+ => map { "$_ = $data{EC2}{meta}{$name}{$_}" }
+ sort keys %{$data{EC2}{meta}{$name}};
+ $name =~ s{/$}{};
+ }
+ else {
+ $value =~ s{\n}{<br />\n}g;
+ }
+ print qq{<tr><td>$name: </td><td><b>$value</b></td></tr>\n};
+ }
+ }
+
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+} ## end of html_ec2
+
+
+sub html_uptime {
+
+ if (exists $data{uptime}) {
+ print qq{<tr><th>Uptime:</th><td><b>$data{uptime}</b></td></tr>\n\n};
+ }
+
+ if (exists $data{users_logged_in}) {
+ print qq{<tr><th>Users:</th><td><b>$data{users_logged_in}</b></td></tr>\n\n};
+ }
+
+ if (exists $data{load_average}) {
+ print qq{<tr><th>Load average:</th><td><b>$data{load_average}</b></td></tr>\n\n};
+ }
+
+ return;
+
+} ## end of html_uptime
+
+
+sub html_lsb {
+
+ return if ! exists $data{lsb_release};
+
+ print qq{<tr><th$vtop>${wrap}LSB info:</th><td><br /><table class="plain">};
+ for my $name (sort keys %{$data{lsb_release}}) {
+ print qq{<tr><td>$name: </td><td><b>$data{lsb_release}{$name}</b></td></tr>\n};
+ }
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+} ## end of html_lsb
+
+
+sub html_dist {
+
+ for my $dist (keys %distlist) {
+ next if ! exists $data{dist}{$dist};
+ my $ver = $data{dist}{$dist};
+ next if $dist eq 'redhat' and exists $data{dist}{fedora} and $ver =~ /Fedora/;
+ if ($distlist{$dist}->[2] eq 'version' and exists $data{dist_codename}) {
+ $ver .= " ($data{dist_codename})";
+ }
+ printf qq{<tr><th>%s %s:</th><td><b>%s</b></td></tr>\n\n},
+ $distlist{$dist}->[1], $distlist{$dist}->[2], $ver;
+ }
+
+ return;
+
+} ## end of html_dist
+
+
+sub html_puppet {
+
+ return if ! exists $data{puppet};
+
+ print q{<tr><th>Puppet classes:</th><td><br /><table class="plain">};
+ for my $name (@{$data{puppet}{class}}) {
+ print qq{<tr><td><b>$name</b></td></tr>\n};
+ }
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+} ## end of html_puppet
+
+
+sub html_kernel {
+
+ return if !exists $data{'Kernel name'};
+
+ print qq{<tr><th$vtop>${wrap}Kernel info:</th><td><br /><table class="plain">};
+ for my $name ('Kernel name', 'Kernel release', 'Kernel version', 'Hardware name', 'Processor', 'Hardware platform') {
+ next if ! exists $data{$name} or $data{$name} eq 'unknown' or $data{$name} =~ /--help/;
+ print qq{<tr><td>$name: </td><td><b>$data{$name}</b></td></tr>};
+ }
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+} ## end of html_kernel
+
+
+sub html_shared_memory {
+
+ return if ! exists $data{memory}{shmmax};
+
+ print qq{<tr><th$vtop>${wrap}Memory:</th><td><br /><table class="plain">};
+ print qq{<tr><td>shmmax: </td><td style="text-align: right"><b>$data{memory}{pretty}{shmmax}</b></td></tr>\n};
+ print qq{<tr><td>shmmni: </td><td style="text-align: right"><b>$data{memory}{shmmni}</b></td></tr>\n};
+ print qq{<tr><td>shmall: </td><td style="text-align: right"><b>$data{memory}{pretty}{shmall}</b></td></tr>\n};
+
+ for my $vm ('swappiness','dirty_ratio','dirty_background_ratio') {
+ if (exists $data{vm}{$vm}) {
+ print qq{<tr><td>$vm: </td><td style="text-align: right"><b>$data{vm}{$vm}</b></td></tr>\n};
+ }
+ }
+
+ for my $m ('Free', 'Cached', 'Active', 'Swap Total') {
+ print qq{<tr><td>$m: </td><td style="text-align: right"><b>$data{memory}{pretty}{$m}</b></td></tr>\n};
+ }
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+} ## end of html_shared_memory
+
+
+sub html_shared_active {
+
+ return if !exists $data{memory}{active_shared};
+
+ print qq{<tr><th$vtop>${wrap}Active shared mem:</th><td><br /><table class="plain">};
+ print qq{<tr><td>Active segments: </td><td style="text-align: right"><b>$data{memory}{active_shared}</b></td></tr>\n};
+ print qq{<tr><td>Active semaphores: </td><td style="text-align: right"><b>$data{memory}{active_semaphores}</b></td></tr>\n};
+ print qq{<tr><td>Active messages: </td><td style="text-align: right"><b>$data{memory}{active_messages}</b></td></tr>\n};
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+} ## end of html_shared_active
+
+
+sub html_hugepages {
+
+ return if ! exists $data{memory}{transparent_hugepages};
+
+ print qq{<tr><th$vtop>${wrap}Huge pages:</th><td><br /><table class="plain">};
+ print qq{<tr><td>Huge Page size: </td><td style="text-align: right"><b>$data{memory}{pretty}{HPsize}</b></td></tr>\n};
+ my $total_huge_pretty = pretty_size($data{memory}{HPtotal} * $data{memory}{HPsize});
+ print qq{<tr><td>Huge Pages total: </td><td style="text-align: right"><b>$data{memory}{HPtotal}</b> ($total_huge_pretty)</td></tr>\n};
+ my $free_huge_pretty = pretty_size($data{memory}{HPfree} * $data{memory}{HPsize});
+ print qq{<tr><td>Huge Pages free: </td><td style="text-align: right"><b>$data{memory}{HPfree}</b> ($free_huge_pretty)</td></tr>\n};
+ my $reserved_huge_pretty = pretty_size($data{memory}{HPreserved} * $data{memory}{HPsize});
+ print qq{<tr><td>Huge Pages reserved: </td><td style="text-align: right"><b>$data{memory}{HPreserved}</b> ($reserved_huge_pretty)</td></tr>\n};
+ print qq{<tr><td>Transparent hugepages: </td><td style="text-align: right"><b>$data{memory}{transparent_hugepages}</b></td></tr>\n};
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+
+
+
+} ## end of html_hugepages
+
+
+sub html_lifekeeper {
+
+ return if !exists $data{lifekeeper};
+
+ print qq{<tr><th$vtop>${wrap}Lifekeeper services:</th><td><br /><table class="plain">\n};
+ print qq{<tr><th>Service</th><th>Primary host</th><th>State</th></tr>\n};
+ my $s = $data{lifekeeper}{service};
+ for my $row (sort { $s->{$b}{prio} <=> $s->{$a}{prio} } keys %$s) {
+ printf "<tr><td><b>$row</b></td><td>%s</td><td>%s</td></tr>\n",
+ $s->{$row}{primary}, $s->{$row}{state};
+ }
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+} ## end of html_lifekeeper
+
+
+sub html_heartbeat {
+
+ return if !exists $data{heartbeat};
+
+ print qq{<tr><th$vtop>${wrap}Linux HA:</th><td><br /><table class="plain">\n};
+
+ if (exists $data{heartbeat}{active}) {
+ print qq{<tr><th colspan="2">$data{heartbeat}{active}</tr>\n};
+ }
+
+ if (exists $data{heartbeat}{haresources}) {
+ my $har = escape_html($data{heartbeat}{haresources});
+ print qq{<tr><td>haresources:</td><td>$har</td></tr>\n};
+ }
+
+ if (exists $data{heartbeat}{node}) {
+ print q{<tr><td>Nodes:</td><td><b>};
+ print join '<br />' => @{$data{heartbeat}{node}};
+ print qq{</b></td></tr>\n};
+ }
+
+ if (exists $data{heartbeat}{config}) {
+ my $config = $data{heartbeat}{config};
+ $config =~ s/\s*$//gm;
+ print qq{<tr><td>Config:</td><td><pre>$config</pre></td></tr>\n};
+ }
+
+ if (exists $data{heartbeat}{resources}) {
+ my $reslist = join '<br />' => sort @{$data{heartbeat}{resources}};
+ print qq{<tr><td>Resources:</td><td>$reslist</td></tr>\n};
+ }
+
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+} ## end of html_heartbeat
+
+
+sub html_interfaces {
+
+ return if ! exists $data{interface};
+
+ my $gotnotes = 0;
+ for my $int (keys %{$data{interface}}) {
+ $gotnotes = 1 if exists $data{interface}{$int}{POINTOPOINT};
+ }
+
+ print qq{<tr><th$vtop>${wrap}Interfaces:</th><td><br /><table class="plain">\n};
+ printf q{<tr><th>Name</th><th>IP</th><th>Status</th><th>Speed</th>%s</tr>},
+ $gotnotes ? q{<th>Notes</th>} : '';
+ my $x;
+ for my $int (map { $_->[0] }
+ sort { $b->[1] <=> $a->[1] or $b->[2] cmp $a->[2] or $a->[0] cmp $b->[0] }
+ map { $x=$data{interface}{$_}; [$_, exists $x->{RUNNING} ? 1 : 0, $x->{address} || 0] }
+ keys %{$data{interface}}) {
+ my $d = $data{interface}{$int};
+ my $ip = $d->{RUNNING} ? ($d->{address} || $d->{inet6_address} || '-') : 'N/A';
+ printf q{<tr><td%s>%s</td><td>%s</td><td>%s</td>},
+ exists $d->{RUNNING} ? q{ class='activeip'} : '',
+ exists $d->{RUNNING} ? qq{<b>$int</b>} : $int,
+ $ip,
+ exists $d->{RUNNING} ? 'Active' : 'Inactive';
+ printf '<td>%s',
+ exists $d->{current_speed} ? "$d->{current_speed} $d->{duplex}" : exists $d->{RUNNING} ?
+ $int =~ /^lo|tun|bond/ ? 'N/A' : $UNKNOWN_VALUE : 'N/A';
+ if (exists $d->{nowspeed} and exists $d->{maxspeed} and $d->{maxspeed} and ($d->{nowspeed} < $d->{maxspeed})) {
+ print " <b>(but max is $d->{maxspeed})</b>";
+ }
+ print '</td>';
+ if ($gotnotes) {
+ printf '<td>%s</td>',
+ exists $d->{POINTOPOINT} ? 'point to point' : ' ';
+ }
+ print "</tr>\n";
+ }
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+} ## end of html_interfaces
+
+
+sub html_routes {
+
+ return if ! exists $data{route};
+
+ print qq{<tr><th$vtop>${wrap}Routes:</th><td><br /><table class="plain">\n};
+ print q{<tr><th>Destination</th><th>Gateway</th><th>Genmask</th><th>Interface</th></tr>};
+ for my $r (@{$data{route}}) {
+ print qq{<tr><td>$r->{dest}</td><td>$r->{gateway}</td><td>$r->{mask}</td><td>$r->{int}</td></tr>\n};
+ }
+ print "</table></td></tr>\n\n";
+
+ return;
+
+} ## end of html_routes
+
+
+sub html_fs {
+
+ return if ! exists $data{fs};
+
+ print qq{<tr><th$vtop>${wrap}Mounting info:</th><td><br /><table class="plain">\n};
+ print q{<tr><th>Name</th><th>Mount</th><th>Size/Used %</th><th>Inode %</th><th>Filesystem (options)</th></tr>};
+ for my $fs (sort keys %{$data{fs}}) {
+ my $d = $data{fs}{$fs};
+ next if ! defined $d->{mounted};
+ next if $fs eq 'none';
+ (my $ffs = escape_html($fs)) =~ s{(.+/)([\w\-]{20,})$}{$1<br />$2};
+ $ffs =~ s{^([^:]{15,}:)(.+)}{$1<br />$2};
+ print qq{<tr><td>$ffs</td><td><b>$d->{mounted}</b></td><td>$d->{size}/$d->{capacity}</td>};
+ print qq{<td>$d->{inodes_usage}</td>\n};
+ $d->{options} = '' if ! exists $d->{options};
+ my $options = $d->{options};
+ if (length $options > 20) {
+ $options =~ s{,}{,<br />}g;
+ }
+ printf qq{<td>%s%s</td></tr>\n},
+ defined $d->{type} ? $d->{type} : '?',
+ $options ? " ($options)" : '';
+ }
+
+ if (exists $data{mdstat}) {
+ printf q{<tr><td>mdstat:</td><td colspan='4'>%s</td></tr>},
+ escape_html($data{mdstat});
+ }
+ print "</table></td></tr>\n\n";
+
+ return;
+
+} ## end of html_fs
+
+
+sub html_queues {
+
+ return if ! exists $data{block};
+
+ print qq{<tr><th$vtop>${wrap}Kernel queue info:</th><td><br /><table class="plain">\n};
+ print q{<tr><th>Block</th><th>Read ahead size</th><th>Scheduler</th></tr>};
+ for my $name (sort keys %{$data{block}}) {
+ my $q = $data{block}{$name};
+ $q->{scheduler} =~ s{(\[\w+\])}{<b>$1</b>};
+ print qq{<tr><td>$name</td><td>$q->{readahead}</td><td>$q->{scheduler}</td></tr>\n};
+ }
+ print "</table></td></tr>\n\n";
+
+ return;
+
+} ## end of html_queues
+
+
+sub html_disk_settings {
+
+ return if ! exists $data{disk};
+
+ print qq{<tr><th$vtop>${wrap}Disk information:</th><td><br /><table class="plain">\n};
+ print q{<tr><th>Name</th><th>Read ahead size</th><th>Scheduler</th></tr>};
+ for my $fs (sort keys %{$data{fs}}) {
+ my $d = $data{fs}{$fs};
+ next if ! defined $d->{mounted};
+ next if $fs eq 'none';
+ print qq{<tr><td>$fs</td><td><b>$d->{mounted}</b></td><td>$d->{size}/$d->{capacity}</td>};
+ print qq{<td>$d->{inodes_usage}</td>\n};
+ print qq{<td>$d->{readahead}</td>\n};
+ print qq{<td>$d->{scheduler}</td>\n};
+ print qq{<td>$d->{type} ($d->{options})</td></tr>\n};
+ }
+
+ if (exists $data{mdstat}) {
+ print q{<tr><td>mdstat:</td><td colspan=5>%s</td></tr>},
+ escape_html($data{mdstat});
+ }
+ print "</table></td></tr>\n\n";
+
+ return;
+
+} ## end of html_disk_settings
+
+
+sub html_versions {
+
+ return if ! exists $data{version};
+
+ my $TWOWRAP = 15;
+ my $THREEWRAP = 30;
+
+ my $count = 0;
+ for my $v (keys %{$data{version}}) {
+ $count++ if $data{version}{$v} ne '?';
+ }
+ return if ! $count;
+
+ print qq{<tr><th$vtop>${wrap}Program versions:</th><td><br /><table class="plain">\n};
+ print q{<tr><th>Name</th><th>Version</th>};
+ if ($count >= $TWOWRAP) {
+ print q{<th>Name</th><th>Version</th>};
+ }
+ if ($count >= $THREEWRAP) {
+ print q{<th>Name</th><th>Version</th>};
+ }
+ print qq{</tr>\n};
+
+ my $offset = 0;
+ for my $prog (sort keys %{$data{version}}) {
+ my $v = $data{version}{$prog};
+ next if $v eq '?';
+ if ($count < $TWOWRAP) {
+ printf qq{<tr><td>$prog</td><td>%s</td></tr>\n},
+ $v eq '?' ? $UNKNOWN_VALUE : qq{<b>$v</b>};
+ }
+ elsif (!$offset) {
+ printf qq{<tr><td>$prog</td><td>%s</td>},
+ $v eq '?' ? $UNKNOWN_VALUE : qq{<b>$v</b> };
+ $offset = 1;
+ }
+ elsif ($count >= $THREEWRAP and $offset < 2) {
+ printf qq{<td>$prog</td><td>%s</td>},
+ $v eq '?' ? $UNKNOWN_VALUE : qq{<b>$v</b> };
+ $offset = 2;
+ }
+ else {
+ printf qq{<td>$prog</td><td>%s</td></tr>},
+ $v eq '?' ? $UNKNOWN_VALUE : qq{<b>$v</b>};
+ $offset = 0;
+ }
+ }
+ if ($offset) {
+ print q{<td> </td><td> </td>};
+ $offset==1 and $count >= $THREEWRAP and print q{<td> </td><td> </td>};
+ print qq{</tr>\n};
+ }
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+} ## end of html_versions
+
+
+sub html_perlinfo {
+
+ return if ! exists $data{perl};
+
+ ## Where installed?
+
+ print qq{<tr><th$vtop>${wrap}Perl info:</th><td><br /><table class="plain">\n};
+ print qq{<tr><td>Version:</td><td><b>$data{version}{perl}</b></td></tr>\n};
+ ## Only one of these is needed
+ (my $pver = $data{version}{perl}) =~ s/^(\d+\.\d+)\..*/$1/e;
+ if ($pver < 5.10) {
+ print qq{<tr><td>Threads:</td><td><b>$data{perl}{threads}</b></td></tr>\n};
+ }
+ else {
+ print qq{<tr><td>IThreads:</td><td><b>$data{perl}{ithreads}</b></td></tr>\n};
+ }
+ print qq{<tr><td>Multiplicity:</td><td><b>$data{perl}{multiplicity}</b></td></tr>\n};
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+} ## end of html_perlinfo
+
+
+sub html_perlmodules {
+
+ return if ! exists $data{perlmodver};
+
+ print qq{<tr><th$vtop>${wrap}Perl modules:</th><td><br /><table class="plain">\n};
+ print q{<tr><th>Module</th><th>Version</th></tr>};
+ my $BASE = 'http://search.cpan.org/dist';
+ for my $mod (sort keys %{$data{perlmodver}}) {
+ my $v = $data{perlmodver}{$mod};
+ (my $safename = $mod) =~ s/::/-/g;
+ my $url = "$BASE/$safename";
+ if ('wiki' eq $format) {
+ printf qq{<tr><td>[$url $mod]</td><td>%s</td></tr>\n},
+ $v eq '?' ? $UNKNOWN_VALUE : qq{<b>$v</b>};
+ }
+ else {
+ printf qq{<tr><td><a href="$url">$mod</a></td><td>%s</td></tr>\n},
+ $v eq '?' ? $UNKNOWN_VALUE : qq{<b>$v</b>};
+ }
+ }
+ print "</table></td></tr>\n\n";
+
+ return;
+
+} ## end of html_perlmodules
+
+
+sub html_chkconfig {
+
+ return if ! exists $data{chkconfig};
+
+ my $TWOWRAP = 10;
+ my $THREEWRAP = 20;
+
+ print qq{<tr><th$vtop>${wrap}Started via chkconfig:</th><td><br /><table class="plain">\n};
+ my $count = keys %{$data{chkconfig}};
+ my $offset = 0;
+ for my $prog (sort keys %{$data{chkconfig}}) {
+ if ($count < $TWOWRAP) {
+ print qq{<tr><td>$prog</td></tr>\n};
+ }
+ elsif (!$offset) {
+ print qq{<tr><td>$prog</td>};
+ $offset = 1;
+ }
+ elsif ($count >= $THREEWRAP and $offset < 2) {
+ print qq{<td>$prog</td>};
+ $offset = 2;
+ }
+ else {
+ print qq{<td>$prog</td></tr>\n};
+ $offset = 0;
+ }
+ }
+ if ($offset) {
+ print q{<td> </td>};
+ $offset==1 and $count >= $THREEWRAP and print q{<td> </td>};
+ print qq{</tr>\n};
+ }
+ print "</table></td></tr>\n\n";
+
+ return;
+
+} ## end of html_chkconfig
+
+
+sub html_postgres_active {
+
+ ## Show active Postgres cluster ports, socket dirs, and version
+
+ return if ! exists $data{postgres} or ! exists $data{postgres}{active_port};
+
+ print qq{<tr><th$vtop>${wrap}Active Postgres clusters:</th><td><br /><table class="plain">\n};
+
+ my ($extrasym, $extranotes) = (0,0);
+ for my $cluster (keys %{$data{postgres}{active_port}}) {
+ if (exists $data{postgres}{active_port}{$cluster}{symlink}) {
+ $extrasym = 1;
+ }
+ if (exists $data{postgres}{active_port}{$cluster}{recfile}
+ or exists $data{postgres}{active_port}{$cluster}{startingup}) {
+ $extranotes = 1;
+ }
+ }
+
+ print q{<tr><th>Port</th><th>Socket dir</th><th>Version</th>};
+ $extrasym and print q{<th>Symlinks</th>};
+ $extranotes and print q{<th>Notes</th>};
+ print qq{</tr>\n};
+ for my $cluster (sort { $a cmp $b } keys %{$data{postgres}{active_port}}) {
+ my $c = $data{postgres}{active_port}{$cluster};
+ next if $c->{deleted};
+ my $port = $c->{port};
+ my $dir = $c->{largesocketdir} || $c->{socketdir};
+ my $ver = $c->{setting}{server_version}{value} || $c->{version}{full} || '?';
+ if ($ver =~ /^\d+\.\d+$/ and exists $data{version}{psql}) {
+ $ver .= "<br />(probably $data{version}{psql})";
+ }
+ print qq{<tr><td><b>$port</b></td><td><b>$dir</b></td><td><b>$ver</b></td>};
+ if ($extrasym) {
+ my $info = ' ';
+ if (exists $c->{symlink}) {
+ $info = join '<br />' =>
+ map { "$_ -> $c->{symlink}{$_}" }
+ sort
+ keys %{$c->{symlink}};
+ }
+ print "<td>$info</td>";
+ }
+ if ($extranotes) {
+ my $info = ' ';
+ if (exists $c->{recfile}) {
+ $info = 'In recovery mode';
+ }
+ elsif (exists $c->{startingup}) {
+ $info = 'Starting up';
+ }
+ if (exists $c->{datadirsize}) {
+ $info .= "<br />DB size: $c->{datadirsize}";
+ }
+ print "<td>$info</td>";
+ }
+ print "</tr>\n";
+ }
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+} ## end of html_postgres_active
+
+
+sub html_postgres_config {
+
+ ## Show active cluster configuration settings (interesting ones only)
+
+ return if ! exists $data{postgres} or ! exists $data{postgres}{active_port};
+
+ ## Make sure we have at least one (may not due to warm standby servers, etc.)
+ my $found = 0;
+ for my $cluster (keys %{$data{postgres}{active_port}}) {
+ if (exists $data{postgres}{active_port}{$cluster}{setting}{lc_time}) {
+ $found = 1;
+ last;
+ }
+ }
+ return if !$found;
+
+ print qq{<tr><th$vtop>${wrap}→ Postgres config:</th><td><br /><table class="plain">\n};
+
+ ## We don't want to report on all config values, just interesting ones
+ ## A = always show
+ ## D = show only if different
+ ## S = skip it
+
+my $pg_settings = q{
+D add_missing_from | off
+D allow_system_table_mods | off
+S application_name |
+D archive_command | (disabled)
+D archive_mode | off
+D archive_timeout | 0
+D array_nulls | on
+D authentication_timeout | 60
+A autovacuum |
+D autovacuum_analyze_scale_factor | 0.1
+D autovacuum_analyze_threshold | 50
+D autovacuum_freeze_max_age | 200000000
+D autovacuum_max_workers | 3
+D autovacuum_naptime | 60
+D autovacuum_vacuum_cost_delay | 20
+D autovacuum_vacuum_cost_limit | -1
+D autovacuum_vacuum_scale_factor | 0.2
+D autovacuum_vacuum_threshold | 50
+D backslash_quote | safe_encoding
+D bgwriter_delay | 200
+D bgwriter_lru_maxpages | 100
+D bgwriter_lru_multiplier | 2
+D block_size | 8192
+D bounjour | off
+D bonjour_name |
+D bytea_output | hex
+D check_function_bodies | on
+D checkpoint_completion_target | 0.5
+A checkpoint_segments | 3
+D checkpoint_timeout | 300
+D checkpoint_warning | 30
+A client_encoding | UTF8
+D client_min_messages | notice
+D commit_delay | 0
+D commit_siblings | 5
+A config_file |
+D constraint_exclusion | off
+D cpu_index_tuple_cost | 0.005
+D cpu_operator_cost | 0.0025
+D cpu_tuple_cost | 0.01
+D cursor_tuple_fraction | 0.1
+D custom_variable_classes |
+A data_directory |
+D DateStyle | ISO, MDY
+D db_user_namespace | off
+D deadlock_timeout | 1000
+D debug_assertions | off
+D debug_pretty_print | off
+D debug_print_parse | off
+D debug_print_plan | off
+D debug_print_rewritten | off
+A default_statistics_target | 10 or 100
+D default_tablespace |
+D default_text_search_config | pg_catalog.english
+D default_transaction_isolation | read committed
+D default_transaction_read_only | off
+D default_with_oids | off
+D dynamic_library_path | $libdir
+A effective_cache_size |
+D effective_io_concurrency | 1
+D enable_bitmapscan | on
+D enable_hashagg | on
+D enable_hashjoin | on
+D enable_indexscan | on
+D enable_material | on
+D enable_mergejoin | on
+D enable_nestloop | on
+D enable_seqscan | on
+D enable_sort | on
+D enable_tidscan | on
+D escape_string_warning | on
+D exit_on_error | off
+D explain_pretty_print | on
+D external_pid_file |
+D extra_float_digits | 0
+D from_collapse_limit | 8
+D fsync | on
+D full_page_writes | on
+D geqo | on
+D geqo_effort | 5
+D geqo_generations | 0
+D geqo_pool_size | 0
+D geqo_seed | 0
+D geqo_selection_bias | 2
+D geqo_threshold | 12
+D gin_fuzzy_search_limit | 0
+A hba_file |
+D hot_standby | off
+D hot_standby_feedback | off
+A ident_file |
+D ignore_system_indexes | off
+A integer_datetimes | on
+D IntervalStyle | postgres
+D join_collapse_limit | 8
+S krb_caseins_users | off
+S krb_realm |
+S krb_server_hostname |
+S krb_server_keyfile |
+S krb_srvname | postgres
+S lc_collate |
+S lc_ctype |
+S lc_messages |
+S lc_monetary |
+S lc_numeric |
+S lc_time |
+D listen_addresses | *
+D lo_compat_privileges | off
+D local_preload_libraries |
+D log_autovacuum_min_duration | -1
+D log_checkpoints | off
+D log_connections | off
+A log_destination | stderr
+D log_directory | pg_log
+D log_disconnections | off
+D log_duration | off
+D log_error_verbosity | default
+D log_executor_stats | off
+D log_file_mode | 0600
+A log_filename |
+D log_hostname | off
+D log_line_prefix |
+D log_lock_waits | off
+A log_min_duration_statement | -1
+D log_min_error_statement | error
+D log_min_messages | warning
+D log_parser_stats | off
+D log_planner_stats | off
+D log_rotation_age | 1440
+D log_rotation_size | 10240
+D log_statement | none
+D log_statement_stats | off
+D log_temp_files | -1
+D log_timezone | US/Eastern
+D log_truncate_on_rotation | off
+A logging_collector | off
+A maintenance_work_mem | 16384
+A max_connections |
+D max_files_per_process | 1000
+A max_fsm_pages |
+D max_fsm_relations | 1000
+D max_function_args | 100
+D max_identifier_length | 63
+D max_index_keys | 32
+D max_locks_per_transaction | 64
+D max_pred_locks_per_transaction | 64
+A max_prepared_transactions | 5
+D max_stack_depth | 2048
+D max_standby_archive_delay | 30000
+D max_standby_streaming_delay | 30000
+A max_wal_senders | 0
+D password_encryption | on
+D port | 5432
+D post_auth_delay | 0
+D pre_auth_delay | 0
+D quote_all_identifiers | off
+A random_page_cost |
+D replication_timeout | 60000
+D restart_after_crash | on
+D regex_flavor | advanced
+D search_path | "$user",public
+D segment_size | 131072
+D seq_page_cost | 1
+A server_encoding | UTF8
+S server_version | 8.something
+S server_version_num | 80303
+D session_replication_role | origin
+A shared_buffers | 3072
+D shared_preload_libraries |
+D silent_mode | off
+D sql_inheritance | on
+D ssl | off
+S ssl_ciphers |
+S ssl_renegotiation_limit | 524288
+D standard_conforming_strings | off
+D statement_timeout | 0
+D stats_temp_directory | pg_stat_tmp
+D superuser_reserved_connections | 3
+D synchronize_seqscans | on
+D synchronous_commit | on
+D synchronous_standby_names |
+D syslog_facility | LOCAL0
+D syslog_ident | postgres
+D tcp_keepalives_count | 0
+D tcp_keepalives_idle | 0
+D tcp_keepalives_interval | 0
+D temp_buffers | 1024
+D temp_tablespaces |
+S TimeZone | US/Eastern
+D timezone_abbreviations | Default
+D trace_notify | off
+D trace_recovery_messages | debug1
+D trace_sort | off
+D track_activities | on
+D track_activity_query_size | 1024
+D track_counts | on
+D track_functions | none
+D transaction_defferable | off
+D transaction_isolation | read committed
+D transaction_read_only | off
+D transform_null_equals | off
+D unix_socket_directory | /tmp
+D unix_socket_group |
+D unix_socket_permissions | 511
+D update_process_title | on
+D vacuum_cost_delay | 0
+D vacuum_cost_limit | 200
+D vacuum_cost_page_dirty | 20
+D vacuum_cost_page_hit | 1
+D vacuum_cost_page_miss | 10
+D vacuum_defer_cleanup_age | 0
+D vacuum_freeze_min_age | 100000000
+D vacuum_freeze_table_age | 150000000
+D wal_block_size | 8192
+D wal_buffers | 8
+D wal_debug | off
+D wal_keep_segments | 0
+A wal_level | minimal
+D wal_receiver_status_interval | 10
+D wal_segment_size | 2048
+D wal_sender_delay | 200
+A wal_sync_method | fdatasync
+D wal_writer_delay | 200
+A work_mem |
+D xmlbinary | base64
+D xmloption | content
+D zero_damaged_pages | off
+};
+
+ my %pgs;
+ for my $line (split /\n/ => $pg_settings) {
+ next unless $line =~ /^([ASD]) (\w+)\s+\|\s*(.+?)\s*$/o;
+ my ($type,$name,$val) = ($1,$2,$3);
+ $pgs{$name} = {type => $type, value => $val};
+ }
+
+ print qq{<tr><th>Cluster</th><th>Config</th><th>Value</th><th>Source</th></tr>\n};
+ for my $cluster (sort { $a cmp $b } keys %{$data{postgres}{active_port}}) {
+ my $info = $data{postgres}{active_port}{$cluster};
+ my $port = $info->{port} || '';
+ next if ! defined $info->{setting}{data_directory};
+ next if exists $opt{skippgport} and $opt{skippgport} =~ /\b$port\b/;
+ my $socketdir = $info->{socketdir};
+ my $set = $info->{setting};
+ my @var;
+ for my $var (sort { lc($a) cmp lc($b) } keys %pgs) {
+ my $type = $pgs{$var}->{type};
+ next if $type eq 'S';
+ next if ! exists $set->{$var};
+ my $source = $set->{$var}{source};
+ my $unit = $set->{$var}{unit} || '';
+ $source = 'Conf' if $source eq 'configuration file';
+ $source = '<b>User</b>' if $source eq 'user';
+ $source = 'Set' if $source eq 'override';
+ $source = 'Def' if $source eq 'default';
+
+ my $value = $set->{$var}{value};
+ my $orig = $pgs{$var}->{value};
+ $orig =~ s/\s+$//;
+ next if $source eq 'Def' and ($var =~ /autovac/ or $var eq 'archive_command' or $var =~ /bgwriter/);
+ next if $source eq 'Def' and $var eq 'unix_socket_directory' and $value !~ /\w/;
+ next if $source eq 'Def' and $value eq 'unset'; ## old style
+ if ($set->{$var}{source} ne 'default') {
+ my $def = $pgs{$var}->{value};
+ $def =~ s/\n/ /g;
+ $def = '(empty string)' if $def =~ /^\s*$/;
+ if ($use_balloons and $format eq 'wiki') {
+ $source = "<balloon title='Default is: $def'>$source</balloon>";
+ }
+ }
+ if ($type eq 'A' or $value ne $orig) {
+ push @var, [$var,$value,$source,$unit];
+ }
+ }
+ my $number = @var;
+ my $firstrow = 1;
+ print qq{<tr><th rowspan="$number">$port<br />$socketdir</th>};
+ for my $var (@var) {
+ printf qq{%s<td>$var->[0]</td><td><b>%s</b></td><td>$var->[2]</td></tr>\n},
+ $firstrow ? '' : '<tr>',
+ pretty_conf($var->[0],$var->[1],$var->[3]);
+ $firstrow and $firstrow = 0;
+ }
+ }
+
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+} ## end of html_postgres_config
+
+
+sub html_postgres_recovery {
+
+ ## Show information for warm-standby clusters (in recovery mode)
+
+ return if ! exists $data{postgres} or ! exists $data{postgres}{active_port};
+
+ ## Make sure we have at least one in recovery mode
+ my $found = 0;
+ for my $cluster (keys %{$data{postgres}{active_port}}) {
+ if (exists $data{postgres}{active_port}{$cluster}{recfile}) {
+ $found = 1;
+ last;
+ }
+ }
+ return if !$found;
+
+ print qq{<tr><th$vtop>${wrap}→ Postgres recovery.conf:</th><td><br /><table class="plain">\n};
+
+ print q{<tr><th>Cluster</th><th>recovery.conf</th></tr>};
+ for my $cluster (sort { $a cmp $b } keys %{$data{postgres}{active_port}}) {
+ my $c = $data{postgres}{active_port}{$cluster};
+ next if ! exists $c->{recfile};
+ my $port = $c->{port} || '';
+ next if exists $opt{skippgport} and $opt{skippgport} =~ /\b$port\b/;
+ my $socketdir = $c->{socketdir};
+ my $recfile = $c->{recfile};
+ $recfile =~ s/ +/ /g;
+ $recfile =~ s{\n}{<br />\n};
+ print qq{<tr><th>$port<br />$socketdir</th><td>$recfile</td></tr>\n};
+ }
+
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+} ## end of html_postgres_recovery
+
+
+sub html_postgres_problems {
+
+ ## Show any known problems that don't fit elsewhere
+
+ return if ! exists $data{postgres} or ! exists $data{postgres}{problems};
+
+ print qq{<tr><th$vtop>${wrap}→ Postgres potential problems:</th><td><br /><table class="plain">\n};
+
+ print q{<tr><th>Cluster/<br />Database</th><th>Problem</th></tr>};
+ for my $cluster (sort { $a cmp $b } keys %{$data{postgres}{active_port}}) {
+ my $c = $data{postgres}{active_port}{$cluster};
+ next if ! exists $c->{problems};
+ my $port = $c->{port} || '';
+ next if exists $opt{skippgport} and $opt{skippgport} =~ /\b$port\b/;
+ my $socketdir = $c->{socketdir};
+ for my $db (keys %{$c->{db}}) {
+ my $info = $c->{db}{$db};
+ next if ! exists $info->{problems};
+ my $problems = '';
+ if ($info->{disabled_triggers}) {
+ $problems .= "<b>DISABLED TRIGGERS:</b><ul>\n";
+ for my $t (@{$info->{disabled_triggers}}) {
+ my ($table,$trigger,$type) = @$t;
+ $problems .= "<li>$trigger on table $table ($type)</li>\n";
+ }
+ $problems .= "</ul>\n";
+ }
+ print qq{<tr><th>$port<br />$socketdir<br />$db</th><td>$problems</td></tr>\n};
+ }
+ }
+
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+} ## end of html_postgres_recovery
+
+
+sub html_postgres_pgconfig {
+
+ ## Show the output of pg_config
+
+ return if ! exists $data{postgres} or ! exists $data{postgres}{pgconfig};
+
+ print qq{<tr><th$vtop>${wrap}→ pg_config info</th><td><br /><table class="plain">\n};
+ for my $row (sort keys %{$data{postgres}{pgconfig}}) {
+ print qq{<tr><th>$row</th>\n};
+ print qq{<td>$data{postgres}{pgconfig}{$row}</td>\n};
+ print qq{</tr>\n};
+ }
+ print "</table></td></tr>\n\n";
+
+ return;
+
+} ## end of html_postgres_pgconfig
+
+
+sub html_postgres_databases {
+
+ ## Show active cluster database information
+
+ return if ! exists $data{postgres} or ! exists $data{postgres}{active_port};
+
+ C: for my $cluster (sort { $a cmp $b } keys %{$data{postgres}{active_port}}) {
+ my $cinfo = $data{postgres}{active_port}{$cluster};
+ my $port = $cinfo->{port} || '';
+ next if exists $opt{skippgport} and $opt{skippgport} =~ /\b$port\b/;
+ next if exists $cinfo->{startingup};
+ next if ! exists $cinfo->{setting}{data_directory};
+ my $socketdir = $cinfo->{socketdir};
+ print qq{<tr><th$vtop>${wrap}→ PG DBs<br />$port<br />$socketdir</th><td><br /><table class="plain">\n};
+
+ my ($usets,$useds,$usesl,$usebc) = (0,0,0,0);
+ for my $db (keys %{$cinfo->{db}}) {
+ my $dinfo = $cinfo->{db}{$db};
+ next if $db eq 'template1';
+ if (defined $dinfo->{tablespace} and length $dinfo->{tablespace} and $dinfo->{tablespace} ne 'pg_default') {
+ $usets = 1;
+ }
+ if (defined $dinfo->{description} and length $dinfo->{description}) {
+ $useds = 1;
+ }
+ if (exists $dinfo->{slony}) {
+ $usesl = 1;
+ }
+ }
+
+ print qq{<tr><th>Name</th>\n};
+ print q{<th>Encoding/<br />Owner</th>};
+ print q{<th>Template/<br />Connectable/<br />Age</th>};
+ print q{<th>Size</th>};
+ print q{<th>Schemas/<br />Tables/<br />Functions</th>};
+ print q{<th>Languages</th>};
+ $cinfo->{hascontrib} and print q{<th>Contrib</th>};
+ $usesl and print q{<th>Slony</th>};
+ $usets and print q{<th>Tablespace</th>};
+ $useds and print q{<th>Description</th>};
+ print qq{</tr>\n};
+
+ for my $db (sort keys %{$data{postgres}{active_port}{$cluster}{db}}) {
+ my $dinfo = $data{postgres}{active_port}{$cluster}{db}{$db};
+ my $enc = qq{<b>$dinfo->{encoding}</b>};
+ my $owner = $dinfo->{owner};
+ my $istemplate = $dinfo->{template} eq 'Yes' ? '<b>Yes</b>' : 'No';
+ my $canconn = $dinfo->{canconn} eq 'No' ? '<b>No</b>' : 'Yes';
+ my $age = $dinfo->{age};
+ my $size = qq{<b>$dinfo->{size}</b>};
+ my $schemas = $dinfo->{relcount}{'schema'} || 0;
+ my $tables = $dinfo->{relcount}{'r'} || 0;
+ my $indexes = $dinfo->{relcount}{'i'} || 0;
+ my $views = $dinfo->{relcount}{'v'} || 0;
+ my $sequences = $dinfo->{relcount}{'S'} || 0;
+ my $funcs = $dinfo->{relcount}{'f'} || 0;
+ if ($dinfo->{canconn} eq 'No') {
+ $schemas = $tables = $indexes = $views = $sequences = $funcs = $UNKNOWN_VALUE;
+ }
+
+ my $stf = "$schemas<br />$tables<br />$funcs";
+ if ($db eq 'template0' and $dinfo->{canconn} eq 'No') {
+ $stf = 'N/A';
+ }
+
+ my $languages = join '<br />' => sort keys %{$dinfo->{language}};
+ $languages ||= ' ';
+
+ my $tablespace = $dinfo->{tablespace};
+ my $description = $dinfo->{tablespace};
+ print qq{<tr><td><b>$db</b></td><td>$enc<br />$owner</td>};
+ print qq{<td>$istemplate<br />$canconn<br />$age</td><td>$size</td>};
+ print qq{<td>$stf</td>};
+ print qq{<td><b>$languages</b></td>};
+ if ($cinfo->{hascontrib}) {
+ my $contribs = ' ';
+ if (exists $dinfo->{contrib}) {
+ $contribs = '<ul>';
+ for my $cname (sort keys %{$dinfo->{contrib}}) {
+ $contribs .= "<li>$cname</li>";
+ }
+ $contribs .= '</ul>';
+ }
+ print qq{<td>$contribs</td>};
+ }
+ printf qq{%s%s%s</tr>\n},
+ $usets ? qq{<td>$dinfo->{tablespace}</td>} : '',
+ $useds ? qq{<td>$dinfo->{description}</td>} : '',
+ $usesl ? (sprintf q{<td>%s</td>}, exists $dinfo->{slony} ? 'Yes' : 'No') : '',
+ }
+ print "</table></td></tr>\n\n";
+ }
+
+ return;
+
+} ## end of html_postgres_databases
+
+
+sub html_postgres_tablespaces {
+
+ ## Show any non-standard tablespaces
+
+ return if ! exists $data{gottablespaces};
+
+ C: for my $cluster (sort { $a cmp $b } keys %{$data{postgres}{active_port}}) {
+ my $info = $data{postgres}{active_port}{$cluster};
+ next if ! exists $info->{dbtablespace};
+ my $port = $info->{port} || '';
+ my $socketdir = $info->{socketdir};
+
+ print qq{<tr><th$vtop>${wrap}→ Tablespace info<br />$port<br />$socketdir</th><td><br /><table class="plain">\n};
+ print qq{<tr><th>Name</th><th>Path</th></tr>\n};
+ for my $name (sort keys %{$info->{dbtablespace}}) {
+ my $path = $info->{dbtablespace}{$name}[0];
+ print qq{<tr><td>$name</td><td><b>$path</b></td></tr>\n};
+ }
+ print "</table></td></tr>\n\n";
+ }
+
+ return;
+
+} ## end of html_postgres_tablespaces
+
+
+sub html_postgres_slony {
+
+ ## Show Slony information for each cluster and database that uses it
+
+ return if ! exists $data{gotslony};
+
+ C: for my $cluster (sort { $a cmp $b } keys %{$data{postgres}{active_port}}) {
+ my $info = $data{postgres}{active_port}{$cluster};
+ next if ! exists $info->{gotslony};
+ my $port = $info->{port} || '';
+ my $socketdir = $info->{socketdir};
+
+ for my $db (sort keys %{$data{postgres}{active_port}{$cluster}{db}}) {
+ my $info = $data{postgres}{active_port}{$cluster}{db}{$db};
+ next if ! exists $info->{slony};
+ print qq{<tr><th$vtop>${wrap}→ Slony info<br />$port<br />$socketdir<br />$db</th><td><br /><table class="plain">\n};
+ my $paths = join '<br />' => @{$info->{slony}{paths}};
+ my $tables = 'NONE!';
+ if (defined $info->{slony}{tables}) {
+ $tables = join '<br />' => @{$info->{slony}{tables}};
+ }
+ my $seqs = 'NONE!';
+ if (defined $info->{slony}{sequences}) {
+ $seqs = exists $info->{slony}{sequences}
+ ? (join '<br />' => @{$info->{slony}{sequences}})
+ : 'none';
+ }
+ print qq{<tr><td>Schema:</td><td><b>$info->{slony}{schema}</b></td></tr>\n};
+ print qq{<tr><td>Paths:</td><td><b>$paths</b></td></tr>\n};
+ print qq{<tr><td>Tables:</td><td><b>$tables</b></td></tr>\n};
+ print qq{<tr><td>Sequences:</td><td><b>$seqs</b></td></tr>\n};
+ print "</table></td></tr>\n\n";
+ }
+ }
+
+ return;
+
+} ## end of html_postgres_slony
+
+
+sub html_postgres_bucardo {
+
+ ## Show Bucardo information
+
+ return if ! exists $data{gotbucardo};
+
+ C: for my $cluster (sort { $a cmp $b } keys %{$data{postgres}{active_port}}) {
+ my $info = $data{postgres}{active_port}{$cluster};
+ next if ! exists $info->{gotbucardo};
+ my $port = $info->{port} || '';
+ my $socketdir = $info->{socketdir};
+
+ for my $db (sort keys %{$data{postgres}{active_port}{$cluster}{db}}) {
+ my $info = $data{postgres}{active_port}{$cluster}{db}{$db};
+ next if ! exists $info->{bucardo};
+ print qq{<tr><th$vtop>${wrap}→ Bucardo info<br />$port<br />$socketdir<br />$db</th><td><br /><table class="plain">\n};
+
+ my $bc = $info->{bucardo};
+
+ my $dbs = '';
+ if (keys %{$bc->{db}}) {
+ $dbs = '';
+ for my $name (sort keys %{$bc->{db}}) {
+ my $i = $bc->{db}{$name};
+ $dbs .= sprintf '%s: %s %s dbname=%s',
+ $name,
+ ($i->{dbhost} ? "dbhost=$i->{dbhost}" : ''),
+ ($i->{dbport}==5432 ? '' : "dbport=$i->{dbport}"),
+ $i->{dbname};
+ $i->{sourcelimit} and $dbs .= " sourcelimit=$i->{sourcelimit}";
+ $i->{targetlimit} and $dbs .= " targetlimit=$i->{targetlimit}";
+ if (exists $i->{server_side_prepares} and $i->{server_side_prepares} ne 't') {
+ $dbs .= ' ssp=FALSE';
+ }
+ if (exists $i->{makedelta} and $i->{makedelta} eq 'on') {
+ $dbs .= ' makedelta=ON';
+ }
+ $dbs .= '<br />';
+ }
+ }
+ $dbs ||= 'NONE';
+
+ ## Only the intereting ones in the future
+ my $configs = 'NONE?!';
+ if (keys %{$bc->{bucardo_config}}) {
+ $configs = join '<br />', map { "$_: $bc->{bucardo_config}{$_}{value}" }
+ sort grep { defined $bc->{bucardo_config}{$_}{value} } keys %{$bc->{bucardo_config}};
+ }
+
+ my $tables = '';
+ if (keys %{$bc->{goat}}) {
+ $tables = join '<br />',
+ sort
+ map { "$db $bc->{goat}{$_}{schemaname}.$bc->{goat}{$_}{tablename}" }
+ grep { $bc->{goat}{$_}{reltype} eq 'table' }
+ keys %{$bc->{goat}};
+ }
+ $tables ||= 'NONE';
+
+ my $sequences = '';
+ if (keys %{$bc->{goat}}) {
+ $sequences = join '<br />',
+ sort
+ map { "$bc->{goat}{$_}{schemaname}.$bc->{goat}{$_}{tablename}" }
+ grep { $bc->{goat}{$_}{reltype} eq 'sequence' }
+ keys %{$bc->{goat}};
+ }
+ $sequences ||= 'NONE';
+
+ my $syncs = '';
+ if (keys %{$bc->{sync}}) {
+ for my $name (sort keys %{$bc->{sync}}) {
+ my $s = $bc->{sync}{$name};
+ my $target = $s->{targetdb} ? "DB $s->{targetdb}"
+ : "DBGROUP $s->{targetgroup}";
+ $syncs .= "$name $s->{synctype} $s->{source} => $target";
+ for my $zero (qw/limitdbs onetimecopy maxkicks rebuild_index/) {
+ $s->{$zero} and $syncs .= " $zero=$s->{$zero}";
+ }
+ $s->{checktime} and $syncs .= " checktime=$s->{checktime}";
+ $syncs .= '<br />';
+ }
+ }
+ $syncs ||= 'NONE';
+
+ print qq{<tr><td>Config:</td><td><b>$configs</b></td></tr>\n};
+ print qq{<tr><td>Databases:</td><td><b>$dbs</b></td></tr>\n};
+ print qq{<tr><td>Tables:</td><td><b>$tables</b></td></tr>\n};
+ print qq{<tr><td>Sequences:</td><td><b>$sequences</b></td></tr>\n};
+ print qq{<tr><td>Syncs:</td><td><b>$syncs</b></td></tr>\n};
+ print "</table></td></tr>\n\n";
+ }
+ }
+
+ return;
+
+} ## end of html_postgres_bucardo
+
+
+sub html_postgres_postgis {
+
+ ## Show some simple Postgis information for each cluster and database that uses it
+
+ return if ! exists $data{gotpostgis};
+
+ C: for my $cluster (sort { $a cmp $b } keys %{$data{postgres}{active_port}}) {
+ my $info = $data{postgres}{active_port}{$cluster};
+ next if ! exists $info->{gotpostgis};
+ my $port = $info->{port} || '';
+ my $socketdir = $info->{socketdir};
+
+ for my $db (sort keys %{$data{postgres}{active_port}{$cluster}{db}}) {
+ my $info = $data{postgres}{active_port}{$cluster}{db}{$db};
+ next if ! exists $info->{postgis} or ! exists $info->{postgis}{postgis_full_version};
+ print qq{<tr><th$vtop>${wrap}→ PostGIS<br />$port<br />$socketdir<br />$db</th><td><br /><table class="plain">\n};
+ print qq{<tr><td>Version:</td><td><b>$info->{postgis}{postgis_full_version}</b></td></tr>\n};
+ print "</table></td></tr>\n\n";
+ }
+ }
+
+ return;
+
+} ## end of html_postgres_postgis
+
+
+sub html_mysql {
+
+ ## Show MySQL information
+
+ return if ! exists $data{mysql};
+
+ print qq{<tr><th$vtop>MySQL:</th><td><br /><table class="plain">\n};
+
+ print qq{<tr><td>Version:</td><td><b>$data{version}{mysql}</b></td></tr>\n};
+ print qq{<tr><td>Port:</td><td><b>$data{mysql}{port}</b></td></tr>\n};
+ print qq{<tr><td>Socket:</td><td><b>$data{mysql}{socket}</b></td></tr>\n};
+ if ($data{mysql}{status}) {
+ my $stat = join '<br />' => @{$data{mysql}{status}};
+ print qq{<tr><td>Status:</td><td>$stat</td></tr>\n};
+ }
+
+ my $dbs = join '<br />' => map { "<b>$_</b> ($data{mysql}{database}{$_}{tables} tables)" }
+ sort keys %{$data{mysql}{database}};
+
+ print qq{<tr><td>Databases:</td><td>$dbs</td></tr>\n};
+
+ print qq{</table></td></tr>\n\n};
+
+ return;
+
+} ## end of html_mysql
+
+
+sub html_ulimits {
+
+ return if ! exists $data{ulimit};
+
+ print qq{<tr><th$vtop>${wrap}User limits:</th><td><br /><table class="plain">\n};
+ print q{<tr><th>Name</th><th>Limit</th></tr>};
+ for my $name (sort keys %{$data{ulimit}}) {
+ my $limit = $data{ulimit}{$name};
+ print qq{<tr><td>$name</td><td><b>$limit</b></td></tr>\n};
+ }
+ print "</table></td></tr>\n\n";
+
+ return;
+
+} ## end of html_ulimits
+
+
+sub html_envs {
+
+ return if ! exists $data{ENV};
+
+ print qq{<tr><th$vtop>${wrap}ENVs:</th><td><br /><table class="plain">\n};
+ print qq{<tr><th>Name</th><th>Value</th></tr>\n};
+
+ my $skipnames = join '|' =>
+ qw/COLORTERM DISPLAY G_BROKEN_FILENAMES LS_COLORS OLDPWD PGUSER PWD SHLVL STY TERM TERMCAP XAUTHORITY GCC_SPECS PS1
+ MAIL USER LOGNAME HOME HIST.* PATH/;
+ my $skipre = qr{\b(?:$skipnames)\b};
+
+ for my $e (sort { $a cmp $b } keys %{$data{ENV}}) {
+ next if $e =~ $skipre;
+ next if $e =~ /^SSH_/;
+ my $val = $data{ENV}{$e} || ' ';
+ if ($e =~ /PATH$/ or $e =~ /_DIRS$/ or $e eq 'TEXINPUTS' or $e eq 'INFODIR') {
+ $val =~ s/^://;
+ $val =~ s{:}{:<br />}g;
+ }
+ if ($e =~ /^CONFIG_PROTECT/) {
+ $val =~ s{ }{<br />}g;
+ }
+ print qq{<tr><td>$e</td><td>$val</td></tr>\n};
+ }
+ print "</table></td></tr>\n\n";
+
+ return;
+
+} ## end of html_envs
+
+
+sub html_yum {
+
+ return if ! exists $data{yum};
+
+ print qq{<tr><th$vtop>${wrap}yum installs:</th><td><br /><table class="plain">\n};
+ print qq{<tr><th>Name</th><th>Version</th>\n};
+ print qq{<th>Name</th><th>Version</th></tr>\n};
+
+ my $set = 1;
+ for my $name (sort { $a cmp $b } keys %{$data{yum}{installed}}) {
+ my $ver = $data{yum}{installed}{$name};
+ if (1==$set) {
+ print qq{<tr><td>$name</td><td>$ver</td>\n};
+ $set = 2;
+ }
+ else {
+ print qq{<td>$name</td><td>$ver</td></tr>\n};
+ $set = 1;
+ }
+ }
+ 2==$set and print '<td> </td></tr>';
+ print "</table></td></tr>\n\n";
+
+ return;
+
+} ## end of html_yum
+
+
+sub html_aptitude {
+
+ return if ! exists $data{aptitude};
+
+ print qq{<tr><th$vtop>${wrap}apt-get installs:</th><td><br /><table class="plain">\n};
+ print qq{<tr><th>Name</th><th>Automatic?</th>\n};
+ print qq{<th>Name</th><th>Automatic</th></tr>\n};
+
+ my $set = 1;
+ for my $name (sort { $a cmp $b } keys %{$data{aptitude}{installed}}) {
+ my $auto = $data{aptitude}{installed}{$name} ? 'Yes' : 'No';
+ if (1==$set) {
+ print qq{<tr><td>$name</td><td>$auto</td>\n};
+ $set = 2;
+ }
+ else {
+ print qq{<td>$name</td><td>$auto</td></tr>\n};
+ $set = 1;
+ }
+ }
+ 2==$set and print '<td> </td></tr>';
+ print "</table></td></tr>\n\n";
+
+ return;
+
+} ## end of html_aptitude
+
+
+sub html_gems {
+
+ return if ! exists $data{gems};
+
+ print qq{<tr><th$vtop>${wrap}Ruby local gems:</th><td><br /><table class="plain">\n};
+
+ my $table = make_table(
+ {
+ header => ['Gem','Version'],
+ data => $data{gems},
+ onecol => 10,
+ });
+
+ print $table;
+
+ print "</table></td></tr>\n\n";
+
+ return;
+
+} ## end of html_gems
+
+
+sub escape_html {
+
+ my $string = shift;
+
+ $string =~ s{<}{<}g;
+ $string =~ s{>}{>}g;
+ $string =~ s{\n}{<br />}g;
+
+ return $string;
+
+} ## end of escape_html
+
+
+sub make_table {
+
+ my $arg = shift;
+
+ my $header = $arg->{header} or die;
+ my $data = $arg->{data} or die;
+ my $numitems = keys %$data;
+
+ ## How many items before we go to multiple columns?
+ my $onecol = $arg->{onecol} || 15;
+
+ ## How many columns?
+ my $cols = $numitems <= $onecol ? 1
+ : $numitems <= $onecol*2 ? 2
+ : 3;
+
+ my $table = q{<tr>};
+ for (1..$cols) {
+ $table .= join '' => map { "<th>$_</th>" } @$header;
+ }
+ $table .= qq{</tr>\n};
+
+ my $pos = 0;
+ for my $name (sort keys %$data) {
+ $pos++;
+ my $val = $data->{$name};
+ $table .= sprintf q{%s<td>%s</td><td>%s</td>%s},
+ 1==$pos ? '<tr>' : '',
+ $name,
+ $val,
+ $pos==$cols ? "</tr>\n" : '';
+ if ($pos >= $cols) {
+ $pos = 0;
+ }
+ }
+
+ if ($pos and $pos < $cols) {
+ for ($pos .. $cols-1) {
+ $table .= '<td> </td>';
+ }
+ $table .= "</tr>\n";
+ }
+
+ return $table;
+
+} ## end of make_table
+
projects / pgrpms.git / commitdiff