#!/usr/bin/perl
# cpanel - checkperlmodules                       Copyright(c) 2010 cPanel, Inc.
#                                                           All rights Reserved.
# copyright@cpanel.net                                         http://cpanel.net
# This code is subject to the cPanel license. Unauthorized copying is prohibited

BEGIN { unshift @INC, '/usr/local/cpanel'; }

use strict;
use Cpanel::PerlModuleChecker  ();
use Cpanel::Config::LoadCpConf ();
use Cpanel::FindBin            ();
use Cpanel::cPCPAN             ();
use Cpanel::Notify             ();
use Cpanel::Tar                ();
use Cpanel::Sys                ();
use Cwd                        ();

my $force     = @ARGV && grep( /^--force$/,      @ARGV ) ? 1 : 0;
my $argvonly  = @ARGV && grep( /^--argvonly$/,   @ARGV ) ? 1 : 0;
my $nolowmem  = @ARGV && grep( /^--skiplowmem$/, @ARGV ) ? 1 : 0;
my $bootstrap = @ARGV && grep( /^--bootstrap$/,  @ARGV ) ? 1 : 0;
my $no_warn   = @ARGV && grep( /^--nowarn$/,     @ARGV ) ? 1 : 0;
my $full      = @ARGV && grep( /^--full$/,       @ARGV ) ? 1 : 0;
my $update    = @ARGV && grep( /^--update$/,     @ARGV ) ? 1 : 0;    # Generate holdback modules list, internal use only

my $cpconf = Cpanel::Config::LoadCpConf::loadcpconf();

my $program_timeout = 40;
alarm( $program_timeout * 60 );
$SIG{ALRM} = sub {
    print "\n\n";
    print "$0 has been running for over $program_timeout minutes. Terminating\n";
    exit 10;
};

# Allow additional modules to be specified via CLI
my @modules;
if (@ARGV) {
    add_modules_no_dupes( grep( !/^--[a-z]+/, @ARGV ) );
}
add_modules_no_dupes('Locales') if !$argvonly;

# TODO: use $force or --force-gdbm && --skip-gdbm to always/never do this even if it needs it or not ?
if ( !eval 'use GDBM_File; 1' ) {
    print "!! GDBM_File could not be loaded, building manually !!\n";

    my $start = Cwd::cwd();
    chdir "/usr/local/cpanel" or die "Could not chdir to '/usr/locale/cpanel': $!";
    if ( !-d "src/" || !-e "src/gdbm.tar.gz" ) {

        # we're not synced yet apparently so grab tarball
        use Cpanel::Config ();
        use Cpanel::Update ();
        my %CPSRC      = Cpanel::Config::loadcpsources();
        my $upCnf      = Cpanel::Update::loadupdateconfig();
        my $updatepath = Cpanel::Update::getupdatepath( $upCnf->{'CPANEL'} );
        system( '/scripts/cpanelsync', $CPSRC{'HTTPUPDATE'}, "/cpanelsync/$updatepath/src", 'src' );
    }
    chdir "/usr/local/cpanel/src/" or die "Could not chdir to '/usr/local/cpanel/src/': $!";

    my $tar_hr = Cpanel::Tar::load_tarcfg();
    system("rm -rf gdbm && $tar_hr->{'bin'} $tar_hr->{'no_same_owner'} -x -z -f gdbm.tar.gz");
    die "Could not untar libgdbm" if $? != 0;
    chdir "gdbm/gdbm-1.8.3" or die "Could not chdir to 'gdbm/gdbm-1.8.3': $!";

    # build libgdbm in /opt/libgdbm (remove the rm -rf ?)
    system(q{rm -rf /opt/libgdbm && ./configure --prefix=/opt/libgdbm && perl -pi -e 's/BIN(OWN|GRP) = bin/BIN$1 = 0/g;' Makefile && make && make install});

    my $we_have_tried_with_pic = 0;
    if ( $? != 0 ) {
        if ( Cpanel::Sys::get_cpu_bits() eq '64' ) {
            $we_have_tried_with_pic++;
            print "!! Attempting libgdbm build using --with-pic !!\n";
            system(q{rm -rf /opt/libgdbm && make clean && ./configure --prefix=/opt/libgdbm --with-pic && perl -pi -e 's/BIN(OWN|GRP) = bin/BIN$1 = 0/g;' Makefile && make && make install});
        }
    }

    die "Could not build /opt/libgdbm" if $? != 0;

    chdir '..' or die "Could not chdir to '..': $!";

    # build GDBM_File

    system('make clean && rm _has_run') if -e '_has_run';

    # TODO: modify Makefile.PL call to a) still work and b) get rid of
    #   GDBM_File.c: In function ‘boot_GDBM_File’:
    #   GDBM_File.c:828: warning: passing argument 3 of ‘Perl_newXS’ discards qualifiers from pointer target type
    #   ...
    system('perl Makefile.PL CCFLAGS=-I/opt/libgdbm/include LIBS="-L/opt/libgdbm/lib -lgdbm" LDFLAGS=-L/opt/libgdbm/lib && make && make test && make install && touch _has_run');

    if ( $? != 0 ) {
        if ( Cpanel::Sys::get_cpu_bits() eq '64' ) {
            if ($we_have_tried_with_pic) {
                die "Could not build GDBM_File";
            }
            else {
                print "!! Attempting libgdbm build using --with-pic !!\n";
                chdir "/usr/local/cpanel/src/gdbm/gdbm-1.8.3" or die "Could not chdir to '/usr/local/cpanel/src/gdbm/gdbm-1.8.3': $!";

                system(q{rm -rf /opt/libgdbm && make clean && ./configure --prefix=/opt/libgdbm --with-pic && perl -pi -e 's/BIN(OWN|GRP) = bin/BIN$1 = 0/g;' Makefile && make && make install});
                if ( $? != 0 ) {
                    die "Could not build /opt/libgdbm with --with-pic flag";
                }

                chdir '..' or die "Could not chdir to '..': $!";

                # build GDBM_File

                system('make clean && rm _has_run') if -e '_has_run';

                system('perl Makefile.PL CCFLAGS=-I/opt/libgdbm/include LIBS="-L/opt/libgdbm/lib -lgdbm" LDFLAGS=-L/opt/libgdbm/lib && make && make test && make install && touch _has_run');
            }
        }
    }

    die "Could not build GDBM_File" if $? != 0;

    chdir $start or die "Could not chdir to '$start': $!";
    print "!! GDBM_File built successfully !!\n";
}

my $cPCPAN = Cpanel::cPCPAN->new;
if ($update) {
    print "Generating new module holdback list.\n";
    print "This should only be used for informational purposes.\n";
    sleep 10;
    alarm( $program_timeout * 60 );    # sleep zeros out alarm sometimes
    if ( !$cPCPAN->{'update_modversions'} ) {
        mkdir $cPCPAN->{'basedir'} . '/.cpcpan/UPDATE', 0700;

        # Reinitialize
        $cPCPAN = Cpanel::cPCPAN->new;
    }
    $ENV{'CPCPAN_UPDATE'} = 1;
    print "Updating modules.versions file: $cPCPAN->{'basedir'}/.cpcpan/UPDATE/modules.versions\n";
}

# If not update, clear old update files
elsif ( -d $cPCPAN->{'basedir'} . '/.cpcpan/UPDATE' ) {
    system 'rm', '-rf', $cPCPAN->{'basedir'} . '/.cpcpan/UPDATE';
}

if ( !$argvonly ) {
    if ( $bootstrap || $full ) {
        add_modules_no_dupes(
            qw(
              version
              BSD::Resource
              Class::Std
              Digest::MD5::File
              Expect

              Encode::Guess
              Encode::MIME::Name

              Encode::Detect::Detector
              Data::Dump

              File::Copy::Recursive
              File::Find::Rule
              IO::Tty
              Sys::Hostname::Long
              AppConfig
              Template
              YAML::Syck
              JSON::Syck
              cPanel::MemTest
              DateTime
              )
        );
    }

    # Eventually Socket::Class

    # Base Modules - modules common to DNSONLY and full cPanel install
    if ( !$bootstrap ) {
        add_modules_no_dupes(
            qw(
              HTTP::Date
              Scalar::Util
              Bundle::LWP
              DBI
              Bundle::DBD::mysql
              Crypt::SSLeay
              CPAN::SQLite
              Data::Dumper
              Digest::MD5
              Digest::SHA1
              Encode
              ExtUtils::Constant
              ExtUtils::ParseXS
              File::Touch
              Filesys::Df
              Filesys::Virtual
              Filter::Util::Call
              Getopt::Long
              Getopt::Param::Tiny
              Compress::Raw::Zlib
              Authen::Libwrap
              Net::FTPSSL
              Net::SSL
              Net::SSLeay
              IO::Compress::Gzip
              IO::Scalar
              IO::Socket::SSL
              IO::Stty
              IO::Uncompress::Gunzip
              Lchown
              List::Util
              MD5
              Net::DNS
              Net::OSCAR
              Pod::Perldoc
              Storable
              Sys::Syslog
              Term::ReadKey
              Term::ReadLine::Perl
              Time::HiRes
              Tree::MultiNode
              Unix::PID
              Unix::PID::Tiny
              XML::LibXML::Common
              XML::LibXML
              XML::Parser
              XML::SAX
              XML::Simple
              lib::restrict
              YAML::Syck
              )
        );

    }

    #YAML::Syck is checked twice because its used everywhere
    #
    if ( !$bootstrap && -e '/usr/include/sys/statvfs.h' ) {
        add_modules_no_dupes('Filesys::Statvfs');
    }

    # Full Version modules
    if ( !$bootstrap && !-e '/var/cpanel/dnsonly' ) {
        add_modules_no_dupes(
            qw(
              Crypt::GPG
              Class::Accessor
              Class::Accessor::Fast
              File::MMagic::XS
              Email::Valid
              File::ReadBackwards
              ExtUtils::MakeMaker
              Mail::SRS
              Acme::Spork
              Archive::Tar
              Archive::Tar::Streamed
              Archive::Zip
              Encode::Guess
              Bundle::Interchange
              Business::OnlinePayment::AuthorizeNet
              Business::UPS
              CGI
              Class::Std::Utils
              Compress::Bzip2
              Compress::Zlib
              DBIx::MyParsePP
              DBD::SQLite2
              Date::Parse
              File::Tail
              GD::Graph
              GD::Text::Align
              Memoize
              Geo::IPfree
              HTML::Parser
              HTTP::Daemon::App
              IO::Socket::ByteCounter
              Image::Size
              MIME::Base64
              Mail::DomainKeys
              Error
              NetAddr::IP
              Net::DNS::Resolver::Programmable
              Mail::SPF
              Mail::SPF::Query
              Mail::DKIM
              IP::Country
              Graph::Easy
              Graph::Flowchart
              Mail::SpamAssassin
              URI::Escape
              File::Find::Rule::Filesys::Virtual
              File::Slurp
              Net::DAV::Server
              Net::Daemon
              Net::Daemon::SSL
              Net::LDAP
              Net::LDAP::Schema
              Net::LDAP::Server
              GD::Graph
              Parse::RecDescent
              Quota
              SVG::TT::Graph
              Safe::Hole
              Text::CSV
              Spreadsheet::ParseExcel
              Spreadsheet::WriteExcel
              String::CRC32
              SQL::Statement
              Tie::IxHash
              Tie::ShadowHash
              Tie::DBI
              URI::URL
              )
        );

        # ClamAV
        if ( -e '/var/clamd' || -e '/usr/sbin/clamd' ) {
            add_modules_no_dupes('File::Scan::ClamAV');
        }
        add_modules_no_dupes('Devel::PPPort');
    }
}

if ( -e '/var/cpanel/perl_module_update_exclude' ) {
    if ( open my $exclude_fh, '<', '/var/cpanel/perl_module_update_exclude' ) {
        while ( my $module = readline $exclude_fh ) {
            chomp $module;
            $module =~ s/(?:^\s+|\s+$)//g;
            print "!! Excluding $module update (see /var/cpanel/perl_module_update_exclude) !!\n";
            @modules = grep !/^\Q$module\E$/, @modules;
        }
        close $exclude_fh;
    }
}

my $ok_count = 0;
my @failed;
my $nummods = 0;

# Required for upgrading SQL::Statement from <= 1.20 to 1.22
# May want to revisit with later versions of SQL::Statement
$ENV{'SQL_STATEMENT_WARN_UPDATE'} = 'sure' if grep { 'SQL::Statement' eq $_ } @modules;

if ( $] < 5.008008 ) {
    my $thisver = sprintf( '%vd', $^V );
    Cpanel::Notify::notification(
        'application' => 'checkperlmodules',
        'status'      => 'oldperl',
        'priority'    => 1,
        'interval'    => ( 60 * 60 * 12 ),                                                                                                                                                                                                                                                                                                                                                 # Once every 12 hours
        'subject'     => qq{[checkperlmodules] perl version too old (v5.8.8 required, v$thisver is installed.).},
        'message'     => qq{The version of perl you are running (v$thisver) is too old.  There are known problems that cannot be worked around with this version of perl.  It is HIGHLY recommended that you upgrade to v5.8.8 or later.  Any module install failures should be ignored until perl has been upgraded as some modules will not be able to install with this version of perl.
            
You can ensure that each installed module gets carried over to
the updated Perl build with the use of the "autobundle" CPAN feature.

You can create a bundle of the currently installed modules
by executing the following while logged in via SSH as root:

perl -MCPAN -e 'autobundle'

Once completed, you should see the following output before getting
returned to the shell:

'Wrote bundle file /home/.cpan/Bundle/Snapshot_2007_08_16_00.pm'

Once you've made note of this file name, you can proceed with the update.

On linux based systems, you should be able to update Perl using
the installer provided at layer1.cpanel.net:

cd /root
wget http://layer1.cpanel.net/perl588installer.tar.gz
tar -zxf perl588installer.tar.gz
cd perl588installer
./install -optimize-memory

On FreeBSD based systems, you will need to install Perl from ports.

This will take a few minutes, so take a coffee break and check
the status when you return. Once the update has completed, you
can install all previously installed modules from the CPAN bundle
by executing the following (with the bundle name adjusted to the
name of the bundle generated earlier):

    perl -MCPAN -e 'install Bundle::Snapshot_2007_08_16_00'

This should install each of the modules present in the bundle,
assuming there are no issues during the installation (dependencies,
network, etc).

Once this has completed, execute the following to ensure that all modules
required by cPanel are installed, and restart cPanel:

   /usr/local/cpanel/bin/checkperlmodules
   /usr/local/cpanel/startup
  
  },
        'msgtype' => ''
    );
}

if ( $] < 5.008 ) {    #special case (we have a work around for this on perl 5.6)
    @modules = grep { $_ ne 'Encode' } @modules;
}

print "The following modules are now being installed/updated/verified: " . join( ",", @modules ) . "\n";
if ($force) {
    $cPCPAN->install( '--force', @modules );
}
else {
    $cPCPAN->install(@modules);
}

# We only care if there is a perl in /usr/local/bin
if ( -e '/usr/local/bin/perl' ) {
    my $err;
    # If not a symlink, test for hard link
    if ( !-l '/usr/bin/perl' ) {
        $err = 1;
        # Check for hard links.
        my ($dev, $inode) = stat( _ );
        foreach my $perl ( qw(/usr/local/bin/perl /usr/local/cpanel/bin/perl) ) {
            my ($t_dev, $t_inode) = stat $perl;
            next unless defined $t_dev;
            if ( $dev == $t_dev && $inode == $t_inode ) {
                # hard link to correct location.
                $err = undef;
                last;
            }
        }
    }
    else {
        # Check that the symlink is correct.
        my $old_cwd = Cwd::cwd();
        chdir '/usr/bin'; # Need to change directories to resolve releative links
        my $link = Cwd::abs_path( readlink '/usr/bin/perl' );
        chdir $old_cwd;

        if (  '/usr/local/bin/perl' ne $link  # Live systems
           && '/usr/local/cpanel/bin/perl' ne $link  # devel or hybrid
       ) {
           $err = 1;
       }
    }

    # I normally avoid using a flag like this, but I did not want to 
    # duplicate the notify code.
    if ( $err ) {
        Cpanel::Notify::notification(
            'application' => 'checkperlmodules',
            'status'      => 'badperllink',
            'priority'    => 1,
            'interval'    => ( 60 * 60 * 12 ),                                                                                                                                                                                                                                                                                                                                                 # Once every 12 hours
            'subject'     => qq{[checkperlmodules] /usr/bin/perl not properly linked to /usr/local/bin/perl.},
            'message'     => qq{The perl binary at /usr/bin/perl should be a symlink to /usr/local/bin/perl to
ensure that all scripts execute with the same perl version. This condition has
been linked to a number of hard-to-diagnose issues in the past.

To resolve this issue, rename the current /usr/bin/perl and create a symlink
pointing to /usr/local/bin/perl.

    cd /usr/bin
    mv perl perl-backup
    ln -s /usr/local/bin/perl perl
},
            'msgtype' => ''
        );
    }
}

my $nummods = scalar @modules;
my ( $post_install_module_status, $post_install_module_versions ) = Cpanel::PerlModuleChecker::multi_fetch_module_status( \@modules );
foreach my $module (@modules) {
    if ( !$post_install_module_status->{$module} && !$cPCPAN->check_installed($module) ) {
        my $installrun = $cPCPAN->install( '--force', $module );
        my ( $isinstalled, $testrun ) = $cPCPAN->check_installed($module);
        my $hasperl;
        my $needperl;
        my $solution = '';
        if ( $installrun =~ /Perl\s*(\S+)\s*required[\-\s]*this\s*is\s*only\s*(\S+)/mi ) {
            $solution = qq{Solution\n==============\nUpgrade to perl $1.  You currently have $2 installed!\n\n};
        }
        if ( !$isinstalled ) {
            push @failed, $module;
            if ( !$no_warn ) {
                Cpanel::Notify::notification(
                    'app'       => 'checkperlmodules',
                    'status'    => 'failedinstall',
                    'priority'  => 1,
                    'interval'  => ( 60 * 60 * 2 ),
                    'msgheader' => qq{[checkperlmodules] The perl module $module could not be installed.},
                    'message' =>
                      qq{This module is required by cPanel, and the system may not function correctly until it is installed, and functional.  Below is the results of the auto-install attempt:\n\n${solution}Test Run\n==============\n$testrun\n\nInstaller Run\n==============\n$installrun\n},
                );
            }
        }
        else {
            $ok_count++;
        }
    }
    else {
        $ok_count++;
    }
}

my $failed_count = scalar @failed;
print "Tested $nummods, $ok_count ok, $failed_count failed.\n";
for my $fail (@failed) {
    print "\tFailed install: $fail\n";
}

if ( !$nolowmem && -x '/usr/local/cpanel/bin/low_mem_mods' ) {
    system '/usr/local/cpanel/bin/low_mem_mods';
}

# cleanup stale, briefly-in-use, symlinks
foreach my $base ( '/usr/local/cpanel/perl', '/usr/local/cpanel' ) {
    unlink("$base/Locales")    if -l "$base/Locales";
    unlink("$base/Locales.pm") if -l "$base/Locales.pm";
}

if ( $] >= 5.008 ) {
    my $has_encode_config_local;
    eval '
            local $SIG{__DIE__};
            require Encode::ConfigLocal;
            $has_encode_config_local=1;
    ';
    if ( !$has_encode_config_local ) {
        if ( !-e '/var/cpanel/enc2xs_sandbox' ) {
            mkdir( '/var/cpanel/enc2xs_sandbox', 0700 );
        }
        my $enc2xs_bin = Cpanel::FindBin::findbin( 'enc2xs', 'path' => [ '/usr/sbin', '/usr/local/sbin', '/usr/bin', '/usr/local/bin' ] );
        if ($enc2xs_bin) {
            if ( my $pid = fork() ) {
                waitpid( $pid, 0 );
            }
            else {
                chdir('/var/cpanel/enc2xs_sandbox') || die;
                mkdir('Encode');
                open( my $enc_fh, '>', 'Encode/ConfigLocal.pm' );
                print {$enc_fh} "package Encode::ConfigLocal;\n1;\n";
                close($enc_fh);
                exec $enc2xs_bin, '-C';
                print "enc2xs is missing unable to repair Encode::ConfigLocal!\n";
                exit 1;
            }
        }
    }
}

# Add to @modules as long as the string isn't already in the list.
sub add_modules_no_dupes {
    my @new_modules = @_;
    foreach my $module (@new_modules) {
        next if ( grep { $_ eq $module } @modules );
        push @modules, $module;
    }
}

__END__

## PULLED MODULES
# GD::SecurityImage
# IO::Interface
# IO::Interactive
# HTML::Tagset
# HTML::Template
# OLE::Storage_Lite
# Time::Zone