view release on metacpan or  search on metacpan

lib/DBD/Informix/TechSupport.pm  view on Meta::CPAN

#
#   Technical Support Tools for Informix Database Driver for Perl DBI Version 2018.1031 (2018-10-31)
#
#   Copyright 2000-01 Informix Software Inc
#   Copyright 2002-03 IBM
#   Copyright 2004-15 Jonathan Leffler
#
#   You may distribute under the terms of either the GNU General Public
#   License or the Artistic License, as specified in the Perl README file.

{
    package DBD::Informix::TechSupport;

    use strict;
    use warnings;
    use vars qw( @ISA @EXPORT $VERSION );
    require Exporter;

    @ISA = qw(Exporter);
    @EXPORT = qw(print_versions bug_report it_works);

    $VERSION = "2018.1031";
    $VERSION = "0.97002" if ($VERSION =~ m%[:]VERSION[:]%);

    use Config;
    use DBI;
    use DBD::Informix::Configure;
    use DBD::Informix::TestHarness;

    # Print version numbers for Perl, DBI, DBD::Informix or ESQL/C
    sub print_versions
    {
        my ($items) = @_;
        $items = "Perl DBI DBD::Informix ESQL/C" if ! defined($items) || $items eq "";

        my $drh = DBI->install_driver('Informix');
        print "Perl Version $]\n" if ($items =~ m%\bperl\b%i);
        print "DBI Version $DBI::VERSION\n" if ($items =~ m%\bDBI\b%i);
        print "DBD::Informix Version $drh->{Version}\n" if ($items =~ m%\bDBD::Informix\b%i);
        print "$drh->{ix_ProductName}\n" if ($items =~ m%\bESQL/C\b%i);
    }

    # Produce a Bug Report
    # * By default (no arguments), produces just the most basic bug
    #   reporting info - versions and platform and environment.
    # * If given an argument A or B or C, produces the info for that
    #   type of bug report.
    # * If given an argument D and one or more specific test names,
    #   produces the info for a type D bug report.
    # * It is not unreasonable to build DBD::Informix using:
    #   perl BugReport 2>&1 | tee bugreport.out

    sub bug_report
    {
        my ($opt, @tests) = @_;

        $| = 1;

        # Simulate (Solaris dialect of) 'id' program in Perl.
        my ($id, $name, $gid, @rgrps, $egid, @egrps, $pad);
        $name = getpwuid($<);
        $id = "uid=$<($name)";
        @rgrps = split / /, $(;
        $gid = $rgrps[0];
        shift @rgrps;
        $name = getgrgid($gid);
        $id .= " gid=$gid($name)";
        if ($< != $>)
        {
            $name = getpwuid($>);
            $id .= " euid=$>($name)";
        }
        @egrps = split / /, $);
        $egid = $egrps[0];
        if ($egid != $gid)
        {
            $name = getgrgid($egid);
            $id .= " egid=$egid($name)";
        }
        $pad = " groups=";
        foreach $gid (@rgrps)
        {
            $name = getgrgid($gid);
            $id .= "$pad$gid($name)";
            $pad = ",";
        }

        system qq{
            echo "Command:   $0 $opt @tests"
            echo "Date:      `date`"
            echo "Machine:   `uname -n` (`uname -s -r`)"
            echo "User:      $id"
            echo "Directory: `pwd`"
            echo "Umask:     `umask`"
            echo "Terminal:  `tty 2>/dev/null`"
            };

        print "\n#\n# Perl Version\n";
        system("$^X -V");

        print "\n#\n# Informix Version\n";
        my ($INFORMIXDIR, $ESQLC) = &find_informixdir_and_esql();
        my ($esqlversion, $esqlvernum) = &get_esqlc_version($ESQLC);
        print "INFORMIXDIR = $INFORMIXDIR\n";
        print "ESQLC = $ESQLC\n";
        print "Version = $esqlversion\n";

        my $dbmsversion;
        $dbmsversion = `$INFORMIXDIR/bin/onstat   -V 2>/dev/null`;
        $dbmsversion = `$INFORMIXDIR/bin/tbstat   -V 2>/dev/null` unless $dbmsversion;
        $dbmsversion = `$INFORMIXDIR/bin/dbaccess -V 2>/dev/null` unless $dbmsversion;
        $dbmsversion = `$INFORMIXDIR/lib/sqlturbo -V 2>/dev/null` unless $dbmsversion;
        $dbmsversion = `$INFORMIXDIR/lib/sqlexec  -V 2>/dev/null` unless $dbmsversion;
        $dbmsversion = "*** indeterminate ***" unless $dbmsversion;

        chomp $dbmsversion;
        $dbmsversion =~ s/Software Serial Number.*//m;
        print "DBMS Version = $dbmsversion\n";

        use vars qw($db1 $db2 $server1 $server2 $hosts);
        $db1 = $ENV{DBD_INFORMIX_DATABASE};
        $db2 = $ENV{DBD_INFORMIX_DATABASE2};
        if (defined $db1) { $server1 = ($db1 =~ s/.*@//); } else { $server1 = $ENV{INFORMIXSERVER}; }
        if (defined $db2) { $server2 = ($db2 =~ s/.*@//); } else { $server2 = $ENV{INFORMIXSERVER}; }
        $hosts = $ENV{INFORMIXSQLHOSTS};
        $hosts = "$ENV{INFORMIXDIR}/etc/sqlhosts" unless defined $hosts;
        if (open(HOSTS, "<$hosts"))
        {
            print "Informix Server Entries in sqlhosts file ($hosts)\n";
            while (<HOSTS>)

lib/DBD/Informix/TechSupport.pm  view on Meta::CPAN

                            # JL 2000-02-08: This should work:
                            #execute_command("PERL_DBI_DEBUG=9 sh test.one.sh @tests", "failed on selective tests");
                            # ...but there is a bug in Perl 5.005_03...
                            #
                            # From: Doug Wilson <dougw@safeguard.net>
                            # To: Jonathan Leffler <jleffler@informix.com>
                            # Subject: FW: [ID 20000121.005] System command starting with environment
                            #       [PATCH for tests] DBD::Informix BugReport bug
                            # Date: Tue, 8 Feb 2000 09:43:02 -0800
                            #
                            # Thought you might like to know, the bug in your BugReport script is
                            # really a bug in perl (I thought it was just my system), and happens
                            # whenever you do a system() call that starts with a 'VAR=VALUE' where
                            # the VAR contains a digit or underscore character. I submitted the
                            # bug and got this patch which appears to work:
                            #
                            # From: Dominic Dunlop [mailto:domo@computer.org]
                            # Sent: Monday, January 24, 2000 1:15 AM
                            # To: perl5-porters@perl.org
                            # Cc: Ilya Zakharevich; dougw@safeguard.net
                            # Subject: Re: [ID 20000121.005] System command starting with
                            #       environment [PATCH for tests]
                            #
                            # [...a patch followed...]
                            #
                            # When enough time has elapsed and/or the Perl version requirements for
                            # DBD::Informix are sufficiently stringent for the fix to be universal,
                            # you can replace the workaround below with the code above.
                            # JL 2002-12-09: Replace PERL_DBI_DEBUG with DBI_TRACE.
                            execute_command("sh -c 'DBI_TRACE=9 sh test.one.sh @tests'", "failed on selective tests");
                        }
                    }
                }
            }
            print "\n# End of Bug Report\n";
        }
        else
        {
            print STDERR "Usage: $0 [A|B|C|D] [test cases...]\n";
            return 0;
        }

        1;
    }

    # Execute a command, logging it if $sx is set, and dying with given message
    # if command fails.
    sub execute_command
    {
        my ($cmd, $msg) = @_;
        print "+ $cmd\n";
        warn $msg unless system($cmd) == 0;
    }


    # Print a report that the installation works
    sub it_works
    {
        my ($sec,$min,$hour,$mday,$mon,$year) = gmtime(time);
        my ($date) = sprintf "%04d-%02d-%02d", $year + 1900, $mon + 1, $mday;
        my ($uname,$passwd,$uid,$gid,$quota,$comment,$gcos,$dir,$shell) = getpwuid $>;

        #perl -MConfig -e 'for $key (sort keys %Config) { print "$key = $Config{$key}\n"; }'

        # Try to generate an email name and address
        my ($who) = "$uname\@$Config{myhostname}$Config{mydomain}";
        if ($comment)
        {
            $who = "$comment <$who>";
        }
        elsif ($gcos)
        {
            $who = "$gcos <$who>";
        }

        my ($dbh) = &connect_to_primary(0);

        my (%tags);

        # If you significantly change this list of tags, then change the version
        # number in the WORKING_VERSION open tag.

        $tags{DBD_INFORMIX} = "$dbh->{Driver}->{Version}";
        $tags{DBI} = "$DBI::VERSION";
        $tags{INFORMIX_ESQLC} = "$dbh->{ix_ProductName}";
        my ($server) = ($dbh->{ix_InformixOnLine} == 0) ? "SE"
                     : ($dbh->{ix_ServerVersion} < 600) ? "OnLine"
                     : ($dbh->{ix_ServerVersion} < 730) ? "ODS"
                     : ($dbh->{ix_ServerVersion} < 800) ? "IDS"
                     : ($dbh->{ix_ServerVersion} < 900) ? "XPS"
                     : ($dbh->{ix_ServerVersion} < 920) ? "IUS"
                     :                                    "IDS"
                     ;
        $tags{INFORMIX_SERVER} = sprintf "%.2f (%s)", ($dbh->{ix_ServerVersion}/100),
                                        $server;
        $tags{PERL} = "$] @Config{qw(archname dlsrc)}";
        $tags{SYSTEM} = "@Config{qw(myuname)}";
        $tags{SYS_COMPILER} = "@Config{qw(cc gccversion)}";
        $tags{SYS_LOADER} = "$Config{ld}";
        $tags{WHEN} = "$date";
        $tags{WHO} = "$who";
        $tags{Z_NOTES} = "Optional Notes";

        my ($keylen) = (0);
        my ($key, $tag);

        # Determine longest key
        foreach $key (keys %tags)
        {
            $keylen = length($key) if (length($key) > $keylen);
        }

        my ($fmt) = "    <%s>%s %s </%s>\n";

        print "<WORKING_VERSION VERSION=\"1.00\">\n";
        for $key (sort keys %tags)
        {
            printf $fmt, $key, " " x ($keylen - length($key)), $tags{$key}, $key;
        }
        print "</WORKING_VERSION>\n";