#!/bin/bash
# vim: set et sw=4 sts=4 tw=80:
# Copyright 2005-2021 Gentoo Authors
# Distributed under the terms of the GNU General Public License v2

PERL_CLEANER_VERSION=2.31

SUPPORTED_PMS="portage pkgcore paludis"
PMS_COMMAND=( "emerge" "pmerge" "cave resolve" )
PMS_OPTIONS=( "-v1 --backtrack=200 --selective=n" "-D1" "-x1z" )
PMS_PRETEND=( "-p" "-p" "--no-execute" )

PMS_INSTALLED_COMMAND=( "qlist -IC" "" "cave print-packages --repository installed" )
PMS_DESELECT_COMMAND=( "emerge --deselect" "" "cave update-world --remove" )
PMS_SELECT_COMMAND=( "emerge --noreplace" "" "cave update-world" )
PMS_UPGRADE_COMMAND=( "emerge -u1" "" "cave resolve -x1zU perl-core/*" )

CUSTOM_PMS_COMMAND=""

PKGS_TO_REMERGE=""

PKGS_EXCEPTIONS="dev-lang/perl sys-devel/libperl app-emulation/emul-linux-x86-baselibs"
PKGS_MANUAL=""

PKG_DBDIR="/var/db/pkg"

KNOWN_LEFTOVERS=(
    XML/SAX/ParserDetails.ini _h2ph_pre.ph asm-generic/bitsperlong.ph
    asm-generic/ioctl.ph asm-generic/ioctls.ph asm-generic/posix_types.ph
    asm-generic/socket.ph asm-generic/sockios.ph asm-generic/termbits.ph
    asm-generic/termios.ph asm/bitsperlong.ph asm/ioctl.ph asm/ioctls.ph
    asm/posix_types.ph asm/posix_types_32.ph asm/posix_types_64.ph
    asm/posix_types_x32.ph asm/socket.ph asm/sockios.ph asm/termbits.ph
    asm/termios.ph asm/unistd.ph asm/unistd_32.ph asm/unistd_64.ph asm/unistd_x32.ph
    bits/byteswap-16.ph bits/byteswap.ph bits/endian.ph bits/ioctl-types.ph
    bits/ioctls.ph bits/pthreadtypes.ph bits/select.ph bits/select2.ph
    bits/sigaction.ph bits/sigcontext.ph bits/siginfo.ph bits/signum.ph
    bits/sigset.ph bits/sigstack.ph bits/sigthread.ph bits/sockaddr.ph
    bits/socket.ph bits/socket2.ph bits/socket_type.ph bits/syscall.ph
    bits/syslog-ldbl.ph bits/syslog-path.ph bits/syslog.ph bits/time.ph
    bits/timex.ph bits/types.ph bits/typesizes.ph bits/uio.ph bits/waitflags.ph
    bits/waitstatus.ph bits/wordsize.ph endian.ph features.ph gnu/stubs-32.ph
    gnu/stubs-64.ph gnu/stubs.ph ioctl.ph posix_types.ph signal.ph stdarg.ph
    stdc-predef.ph stddef.ph sys/cdefs.ph sys/ioctl.ph sys/select.ph sys/socket.ph
    sys/syscall.ph sys/syslog.ph sys/sysmacros.ph sys/time.ph sys/ttydefaults.ph
    sys/types.ph sys/ucontext.ph sys/uio.ph sys/wait.ph syscall.ph sysexits.ph
    syslimits.ph syslog.ph time.ph wait.ph xlocale.ph
    PDL/Index.pod PDL/pdldoc.db
)

# See bug 504116 for details
if [ -e "/lib/gentoo/functions.sh" ]; then
    . "/lib/gentoo/functions.sh"
elif [ -e "/etc/init.d/functions.sh" ]; then
    . "/etc/init.d/functions.sh"
else
    echo "$0: Unable to find functions.sh"
    exit 1
fi

# First and foremost - make sure we have a perl to work with...
if ! type -P perl >/dev/null 2>&1 ; then
    ewarn "NO PERL INSTALLED! (at least not in your path)"
    exit 1
fi

veinfo() {
    if [[ VERBOSE -ge $1 ]] ; then
        shift
        einfo "$@"
    fi
}

vecho() {
    if [[ VERBOSE -ge $1 ]] ; then
        shift
        echo "$@"
    fi
}

outdated_path(){
    local path="$1"

    eindent && eindent
    veinfo 4 "Check: ${path}"

    if [[ ${path} == ${path/${version}} ]] ; then
        eindent
        veinfo 4 "Found different version"
        eoutdent
        eoutdent && eoutdent
        return 0
    elif [[ ${path/${version}\/${archname%%-*}-${osname}} != ${path} && ${path} == ${path/${archname}\/} ]] ; then
        eindent
        veinfo 4 "Found different archname"
        eoutdent
        eoutdent && eoutdent
        return 0
    fi
    eoutdent && eoutdent
    return 1
}


# this function removes all perl-core/* entries from your world file
# you should use virtual/perl-* there instead
deselect_perlcore() {
    if [[ ${PMS_COMMAND[${PMS_INDEX}]} != pkgcore ]] ; then

        local perlcorelist
	local perlcorelistoneline
	perlcorelist=$( ${PMS_INSTALLED_COMMAND[${PMS_INDEX}]} | grep '^perl-core/' )
	perlcorelistoneline=$(echo ${perlcorelist} | tr '\n' ' ' )

	veinfo 2 "Installed perl-core packages: ${perlcorelistoneline}"
	if [[ ${perlcorelist} == "" ]] ; then
		veinfo 2 "No perl-core packages installed. Nothing to deselect."
	else
	    if ${PRETEND} ; then
		veinfo 0 "Would try to remove the following perl-core packages from world file"
		veinfo 0 "   ${PMS_DESELECT_COMMAND[${PMS_INDEX}]} ${ADDITIONAL_OPTIONS} ${perlcorelistoneline}"
	    else
		veinfo 0 "Removing perl-core packages from world file"
		veinfo 0 "   ${PMS_DESELECT_COMMAND[${PMS_INDEX}]} ${ADDITIONAL_OPTIONS} ${perlcorelistoneline}"
		${PMS_DESELECT_COMMAND[${PMS_INDEX}]} ${ADDITIONAL_OPTIONS} ${perlcorelistoneline}
	    fi
	fi
    else
        vecho 0
        veinfo 0 "You should deselect all perl-core packages in your configuration before running"
        veinfo 0 "perl-cleaner. They must only be installed as dependency of Perl virtuals."
        veinfo 0 "This is done automatically for portage, but not implemented yet"
        veinfo 0 "for pkgcore. If perl-cleaner fails - you've been warned."
        vecho 0
    fi
}

# this function updates all Perl virtuals (deep)
update_virtuals() {
    if [[ ${PMS_COMMAND[${PMS_INDEX}]} != pkgcore ]] ; then

        local perlvirtuallist
	local perlvirtuallistoneline
	perlvirtuallist=$( ${PMS_INSTALLED_COMMAND[${PMS_INDEX}]} | grep '^virtual/perl-' )
	perlvirtuallistoneline=$(echo ${perlvirtuallist} | tr '\n' ' ' )

	veinfo 2 "Installed Perl virtuals: ${perlvirtuallistoneline}"
	if [[ ${perlvirtuallist} == "" ]] ; then
		veinfo 2 "No Perl virtuals installed. Nothing to update."
	else
	    if ${PRETEND} ; then
		veinfo 0 "Would try to update installed Perl virtuals"
		veinfo 0 "   ${PMS_UPGRADE_COMMAND[${PMS_INDEX}]} ${ADDITIONAL_OPTIONS} ${perlvirtuallistoneline}"
	    else
		veinfo 0 "Updating installed Perl virtuals"
		veinfo 0 "   ${PMS_UPGRADE_COMMAND[${PMS_INDEX}]} ${ADDITIONAL_OPTIONS} ${perlvirtuallistoneline}"
		${PMS_UPGRADE_COMMAND[${PMS_INDEX}]} ${ADDITIONAL_OPTIONS} ${perlvirtuallistoneline}
            fi
	fi
    else
        vecho 0
        veinfo 0 "You should update all the Perl virtuals and their dependencies before running"
        veinfo 0 "perl-cleaner. This is done automatically for portage, but not implemented yet"
        veinfo 0 "for pkgcore. If perl-cleaner fails - you've been warned."
        vecho 0
    fi
}

preclean() {
    deselect_perlcore
    update_virtuals
}

update_packages(){
    local content exp lib broken_libs

    vecho 1
    if ${MODULES} ; then
        veinfo 1 "Locating packages for an update"
    fi
    if ${LIBPERL} ; then
        veinfo 1 "Locating ebuilds linked against libperl"
    fi

    local scanelf=scanelf
    [[ -e ""/usr/lib/libperl.dylib ]] \
        && scanelf=scanmacho
    if ${LIBPERL} ; then
        if ! type -P ${scanelf} >/dev/null 2>&1; then
            ewarn "${scanelf} not found! Install app-misc/pax-utils."
            ewarn "--libperl is disbled."
            LIBPERL=false
        else
            SONAME=$(${scanelf} -qBS $(realpath ""/usr/lib{,32,64,64/lp64,64/lp64d}/libperl.{so,dylib} 2>/dev/null ) | awk '{ print $1 }')
            veinfo 4 SONAME="${SONAME}"
        fi
    fi

    # iterate thru all the installed package's contents
    while IFS= read -r -d $'\0' content; do
        # extract the category, package name and package version
        #CPV=$(sed "s:${PKG_DBDIR}/\(.*\)/CONTENTS:\1:" <<< ${content} )
        CPV=${content#${PKG_DBDIR}/}
        CPV=${CPV%/CONTENTS}
        CATPKG="${CPV%-[0-9]*}"
        veinfo 4 "Checking ${CPV}"

        # exclude packages that are an exception
        exception=0
        for exp in ${PKGS_EXCEPTIONS} ; do
            if [[ -z "${CATPKG##${exp}}" ]]; then
                veinfo 3 "Skipping ${CATPKG}, reason: exception"
                exception=1
                break
            fi
        done

        [[ ${exception} == 1 ]] && continue

        # Replace SLOT by version number when REINSTALL_IDENTICAL_VERSIONS == 1
        # Reinstall identical versions when SLOT doesn't exist, bug #201848
        # Strip subslot part of SLOT because that version may be gone by now, bug #516032
        if ${REINSTALL_IDENTICAL_VERSIONS} || [[ ! -f ${content/CONTENTS/SLOT} ]] ; then
                CATPKGVER="=${CPV}"
        else
                SLOT=$(< ${content/CONTENTS/SLOT})
		MAINSLOT=${SLOT%/*}
		[[ "${SLOT}" != "${MAINSLOT}" ]] && veinfo 5 "$CATPKG : reducing SLOT $SLOT to $MAINSLOT"
                CATPKGVER="${CATPKG}:${MAINSLOT}"
        fi

        if ${MODULES} ; then
            while read -r type file ; do
                shopt -s extglob
                [[ ${type} == obj ]] || [[ ${type} == sym ]] || continue
                [[ ${file} =~ ^""/usr/(share|lib(32|64|x32)?)/perl5 ]] || continue
                file=${file% +(!([[:space:]])) +([[:digit:]])}
                shopt -u extglob
                if ${FORCE} || outdated_path "${file}" ; then
                    PKGS_TO_REMERGE+=" ${CATPKGVER}"
                    exception=3
                    eindent
                    veinfo 1 "Adding to list: ${CATPKGVER}"
                    # Reinstall the virtual for non-identical packages too
                    # else ~cpv results in mismatches too often.
                    # Some perl-core packages do not have a virtual
                    if [[ ${CATPKGVER} == perl-core/* ]] ; then
                        for virtual in "${PKG_DBDIR}"/${CATPKG/perl-core\//virtual/perl-}-[0-9]* ; do
                            if [[ -d ${virtual} ]] ; then
                                PKGS_TO_REMERGE+=" ${CATPKGVER/perl-core\//virtual/perl-}"
                                veinfo 1 "                ${CATPKGVER/perl-core\//virtual/perl-}"
                            else
                                veinfo 2 "No virtual: ${CATPKGVER/perl-core\//virtual/perl-}"
                            fi
                        done
                    fi
                    eindent
                    veinfo 2 "check: module ${file}"
                    eoutdent
                    eoutdent
                    break
                fi
            done < "${content}"
        fi

        [[ ${exception} == 3 ]] && continue

        if ${LIBPERL} ; then
            # We assume the broken libs have all bin or lib in their path
            broken_libs="$(${scanelf} -qBn < <(awk '/^(obj|sym) [^ ]*\/(s?bin|lib(32|64|x32)?)\// && ! /^obj [^ ]*\/usr\/lib\/debug\//{ print $2 }' ${content} ) | grep -o 'libperl\.\(so\|dylib\)\.[0-9.]*' | sort -u )"
            if [[ -n "${broken_libs}" ]] ; then
                if ${FORCE} || [[ ${broken_libs} != ${SONAME} ]] ; then
                    PKGS_TO_REMERGE+=" ${CATPKGVER}"
                    eindent
                    veinfo 1 "Adding to list: ${CATPKGVER}"
                    eindent
                    veinfo 2 "check: libperl ${broken_libs}"
                    eoutdent
                    eoutdent
                else
                    eindent
                    veinfo 3 "Not adding: ${CATPKGVER} because it should be uptodate."
                    veinfo 3 "check: libperl ${broken_libs}"
                    eoutdent
                fi
            fi
        fi
    done < <( find -L ${PKG_DBDIR} -path "*/-MERGING-*" -prune -o -name CONTENTS -print0 )
    # Pipe to command if we have one
    if [[ -n ${PIPE_COMMAND} ]] ; then
        echo "${PKGS_TO_REMERGE}" | ${PIPE_COMMAND}
        exit $?
    fi

    if [[ ${PMS_COMMAND[${PMS_INDEX}]} == emerge && -x ""/usr/bin/portageq ]] ; then
        # Filter out --getbinpkg, --getbinpkgonly, --usepkg and --usepkgonly options in EMERGE_DEFAULT_OPTS
        emerge_default_opts=""
        for option in $(portageq envvar EMERGE_DEFAULT_OPTS ) ; do
            if [[ "${option}" == -[[:alnum:]]* ]]; then
                [[ ${option//[gGkK]/} != - ]] && emerge_default_opts+=" ${option//[gGkK]/}"
            elif [[ "${option}" != "--getbinpkg" && "${option}" != "--getbinpkgonly" && "${option}" != "--usepkg" && "${option}" != "--usepkgonly" ]]; then
                emerge_default_opts+=" ${option}"
            fi
        done
        export EMERGE_DEFAULT_OPTS="${emerge_default_opts# }"
    fi

    # only pretending?
    ${PRETEND} && PMS_OPTIONS[${PMS_INDEX}]="${PMS_OPTIONS[${PMS_INDEX}]} ${PMS_PRETEND[${PMS_INDEX}]}"

    # (Pretend to) remerge packages
    if [[ -n ${PKGS_TO_REMERGE} ]] ; then
        pmscmd="${CUSTOM_PMS_COMMAND}"
        [[ -z ${pmscmd} ]] && pmscmd="${PMS_COMMAND[${PMS_INDEX}]}"
        cmd="${pmscmd} ${PMS_OPTIONS[${PMS_INDEX}]} ${ADDITIONAL_OPTIONS} ${PKGS_TO_REMERGE}"
        veinfo 1 ${cmd}
        if ! ${cmd} ; then
            veinfo 0 "perl-cleaner is stopping here:"
            veinfo 0 "Fix the problem and start perl-cleaner again."
            veinfo 0 ""
            if [[ ${PMS_COMMAND[${PMS_INDEX}]} == emerge ]] ; then
                veinfo 0 ""
                veinfo 0 "Note that upgrading Perl with emerge option --ignore-built-slot-operator-deps=y is not supported."
            fi
            exit 1
        fi
        veinfo 0 ""
        veinfo 0 "It seems like perl-cleaner had to rebuild some packages."
        veinfo 0 ""

        IFS=' ' read -r -a PKGSARRAYRAW <<< "${PKGS_TO_REMERGE}"
    else
        veinfo 1 "No package needs to be reinstalled."
    fi
}

hasr() {
        local filename=$1
        shift

        local x
        for x in "$@"; do
                [[ "${filename/%${x}/}" != "${filename}" ]] && return 0
        done
        return 1
}

hasl() {
        local filename=$1
        shift

        local x
        for x in "$@"; do
                [[ "${filename/#${x}/}" != "${filename}" ]] && return 0
        done
        return 1
}


# Assuming a successful module run, look to see whats left over
leftovers() {
    local path file i perlpath=() outdated_files=()

    for i in ""/usr/{share,lib{,32,64,x32}}/perl5 ; do
        [[ -d $i ]] && perlpath[${#perlpath[*]}]="$(realpath $i 2>/dev/null )"
    done

    [[ ${#perlpath[*]} == 0 ]] && return

    while IFS= read -r -d $'\0' file ; do
        outdated_files=("${outdated_files[@]}" "$file")
    done < <(
        # print out all the leftover files
        while IFS= read -r -d $'\0' path ; do
            if outdated_path "${path}/" ; then
                find "${path}" -type f -print0
            fi
        done <  <( find $( for (( i=0 ; i < ${#perlpath[*]} ; i++ )) do echo ${perlpath[$i]} ; done | sort -u ) -mindepth 2 -maxdepth 2 -type d -print0 2>/dev/null )
    )

    [[ ${#outdated_files[*]} == 0 ]] && return

    vecho 1
    veinfo 1 "The following files remain. These were either installed by hand"
    veinfo 1 "or edited."
    vecho 1

    for file in "${outdated_files[@]}" ; do
        if hasr "$file" "${KNOWN_LEFTOVERS[@]}" ; then
            if ${DELETELEFTOVERS} && ! ${PRETEND} ; then
                veinfo 1 "    $file  : known, deleted"
                rm "$file"
	    else
                veinfo 1 "    $file  : known, can be deleted"
	    fi
        else
            veinfo 1 "    $file"
        fi
    done
}

usage() {
    cat << EOF_USAGE
${0##*/} -- Find & rebuild packages and Perl header files broken due to a perl upgrade

Usage: $0 [OPTION]

Options:
  -h, --help               Print usage
  -V, --version            Print version
  -p, --pretend            Pretend (don't do anything)
  -v, --verbose            Increase verbosity (may be specified multiple times)
  -q, --quiet              Decrease verbosity
  --modules                Rebuild perl modules for old installs of perl
  --allmodules             Rebuild all perl modules
  --libperl                Rebuild anything linked against libperl
  --all                    Short for --modules --libperl
  --reallyall              Short for --allmodules --libperl
  --dont-delete-leftovers  Do not delete known, typical leftover files
  -P PM, --package-manager PM
                           Use package manager PM, where PM can be one of:
$(for p in ${SUPPORTED_PMS} ; do
echo -ne $'\t\t\t\t  '\* ${p}
if [[ ${p} == portage ]] ; then
    echo ' (Default)'
else
    echo
fi
done )
  -- OPTIONS               Pass additional options to PM (not recommended)
EOF_USAGE
exit 0
}

options_warning() {
    cat << EOF_WARNING

***************************************************************************
You are supplying additional command line options for the package manager.
This is NOT RECOMMENDED, not tested, and may lead to incorrect, incomplete,
confusing, and/or nonfunctional results. You are on your own now.
***************************************************************************


EOF_WARNING
}

if [[ -z "$1" ]] ; then
    usage
fi

ADDITIONAL_OPTIONS=""
REINSTALL_IDENTICAL_VERSIONS=false
ASK=false
PRECLEAN=false
MODULES=false
LIBPERL=false
PHCLEAN=false
FORCE=false
LEFTOVERS=true
DELETELEFTOVERS=true
PRETEND=false
VERBOSE=1

while [[ -n "$1" ]] ; do
    case "$1" in
        help|--help|-h)
            usage
            ;;
        version|--version|-V)
            echo "${PERL_CLEANER_VERSION}"
            exit 0
            ;;
        -p|--pretend|--dry-run)
            PRETEND=true
            ;;
        -v|--verbose)
            VERBOSE=$(( ${VERBOSE} + 1 ))
            ;;
        -q|--quiet)
            VERBOSE=$(( ${VERBOSE} - 1 ))
            ;;
        -P|--package-manager)
            shift
            PACKAGE_MANAGER="$1"
            ;;
        --package-manager-command)
            shift
            CUSTOM_PMS_COMMAND="$1"
            ;;
        --reinstall-identical-versions)
            REINSTALL_IDENTICAL_VERSIONS=true
            ;;
        --leftovers|leftovers)
            LEFTOVERS=true
            ;;
        --delete-leftovers|delete-leftovers)
            DELETELEFTOVERS=true
            ;;
        --dont-delete-leftovers|dont-delete-leftovers)
            DELETELEFTOVERS=false
            ;;
        --modules|modules)
            MODULES=true
            ;;
        --allmodules|allmodules)
            MODULES=true
            FORCE=true
            ;;
        --libperl|libperl)
            LIBPERL=true
            ;;
        --ph-clean|ph-clean)
            echo "The --ph-clean option is obsolete and will be ignored"
            ;;
        --phall|phall)
            echo "The --phall option is obsolete and weill be ignored"
            ;;
        --all|all)
            PRECLEAN=true
            MODULES=true
            LIBPERL=true
            LEFTOVERS=true
            ;;
        --reallyall|reallyall)
            PRECLEAN=true
            MODULES=true
            LIBPERL=true
            LEFTOVERS=true
            FORCE=true
            ;;
        --force|force)
            FORCE=true
            ;;
        --)
            shift
            ADDITIONAL_OPTIONS="${ADDITIONAL_OPTIONS} $@"
            break
            ;;
        *)
            usage
            echo "unrecognised option: $1"
            exit 0
            ;;
    esac
    shift
done

# set portage as default if no PM is given
PACKAGE_MANAGER=${PACKAGE_MANAGER:-portage}

case "${PACKAGE_MANAGER}" in
    portage|pkgcore|paludis)
        ;;
    *)
        echo "unrecognised package manager selected. please select between ${SUPPORTED_PMS}"
        exit
        ;;
esac

# PMS_INDEX is used to select the right commands and options for the selected package manager
PMS_INDEX=0
for PM in ${SUPPORTED_PMS} ; do
    [[ ${PM} == ${PACKAGE_MANAGER} ]] && break
    PMS_INDEX=$((${PMS_INDEX} + 1))
done

if [[ ! -z "${ADDITIONAL_OPTIONS}" ]] ; then
    options_warning
fi

# version=
eval $(perl -V:version )
veinfo 3 "Installed perl version: ${version}"
version=$(perl -le 'print $^V =~ /(\d+\.\d+)/')
veinfo 3 "Simplified perl version: ${version}"
# and after 5.36 we can do this unconditionally
# archname=
eval $(perl -V:archname )
veinfo 3 "Installed perl archname: ${archname}"
# osname=
eval $(perl -V:osname )
veinfo 3 "Installed perl osname: ${osname}"
gversion=${version//./\\\.}
# archlibexp=
# vendorarchexp=
# vendorlibexp=
eval $(perl -V:{archlib,vendorlib,vendorarch}exp )
veinfo 3 "archlibexp path: ${archlibexp}"
veinfo 3 "vendorarchexp path: ${vendorarchexp}"
veinfo 3 "vendorlibexp path: ${vendorlibexp}"

${FORCE} && version="0.0.0" && gversion="0\.0\.0"

${PRECLEAN} && preclean

(${MODULES} || ${LIBPERL}) && update_packages

(${LEFTOVERS} || ${DELETELEFTOVERS}) && leftovers

exit 0
