kdesrc-build/kdesrc-build

#!/usr/bin/env perl

# Script to handle building KDE from source code.  All of the configuration is
# stored in the file ./kdesrc-buildrc (or ~/.kdesrc-buildrc, if that's not
# present).
#
# Please also see the documentation that should be included with this program,
# in the doc/ directory.
#
# Copyright © 2003 - 2018 Michael Pyne. <mpyne@kde.org>
# Home page: https://kdesrc-build.kde.org/
#
# Copyright © 2005, 2006, 2008 - 2011 David Faure <faure@kde.org>
# Copyright © 2005 Thiago Macieira <thiago@kde.org>
# Copyright © 2006 Stephan Kulow <coolo@kde.org>
# Copyright © 2006, 2008 Dirk Mueller <mueller@kde.org>
# ... and possibly others. Check the git source repository for specifics.
#
# This program is free software; you can redistribute it and/or modify it under
# the terms of the GNU General Public License as published by the Free Software
# Foundation; either version 2 of the License, or (at your option) any later
# version.
#
# This program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
# details.
#
# You should have received a copy of the GNU General Public License along with
# this program; if not, write to the Free Software Foundation, Inc., 51
# Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

# Adding an option? Grep for 'defaultGlobalOptions' in ksb::BuildContext --mpyne

use FindBin qw($RealBin);
use lib "$RealBin/../share/kdesrc-build/modules";
use lib "$RealBin/modules";

# Force all symbols to be in this package. We can tell if we're being called
# through require/eval/etc. by using the "caller" function.
package main;

use strict;
use warnings;

use Carp;
use Data::Dumper;
use File::Find; # For our lndir reimplementation.
use File::Path qw(remove_tree);

use ksb::Debug;
use ksb::Util;
use ksb::Version qw(scriptVersion);
use ksb::Application;

use 5.014; # Require Perl 5.14

# Make Perl 'plain die' exceptions use Carp::confess instead of their core
# support. This is not supported by the Perl 5 authors but assuming it works
# will be better than the alternative backtrace we get (which is to say, none)
$SIG{__DIE__} = \&Carp::confess;

$ksb::Version::SCRIPT_PATH = $RealBin;

### Script-global functions.

# These functions might be called at runtime via log_command, using
# log_command's support for symbolic execution of a named subroutine. Because
# of that, they have been left in the top-level script.
#
# Everything else should be in an appropriate class.

# Subroutine to recursively symlink a directory into another location, in a
# similar fashion to how the XFree/X.org lndir() program does it.  This is
# reimplemented here since some systems lndir doesn't seem to work right.
#
# Used from ksb::l10nSystem
#
# As a special exception to the GNU GPL, you may use and redistribute this
# function however you would like (i.e. consider it public domain).
#
# The first parameter is the directory to symlink from.
# The second parameter is the destination directory name.
#
# e.g. if you have $from/foo and $from/bar, lndir would create $to/foo and
# $to/bar.
#
# All intervening directories will be created as needed.  In addition, you
# may safely run this function again if you only want to catch additional files
# in the source directory.
#
# Note that this function will unconditionally output the files/directories
# created, as it is meant to be a close match to lndir.
#
# RETURN VALUE: Boolean true (non-zero) if successful, Boolean false (0, "")
#               if unsuccessful.
sub safe_lndir
{
    my ($from, $to) = @_;

    # Create destination directory.
    if (not -e $to)
    {
        print "$to\n";
        if (not pretending() and not super_mkdir($to))
        {
            error ("Couldn't create directory r[$to]: b[r[$!]");
            return 0;
        }
    }

    # Create closure callback subroutine.
    my $wanted = sub {
        my $dir = $File::Find::dir;
        my $file = $File::Find::fullname;
        $dir =~ s/$from/$to/;

        # Ignore the .svn directory and files.
        return if $dir =~ m,/\.svn,;

        # Create the directory.
        if (not -e $dir)
        {
            print "$dir\n";

            if (not pretending())
            {
                super_mkdir ($dir) or croak_runtime("Couldn't create directory $dir: $!");
            }
        }

        # Symlink the file.  Check if it's a regular file because File::Find
        # has no qualms about telling you you have a file called "foo/bar"
        # before pointing out that it was really a directory.
        if (-f $file and not -e "$dir/$_")
        {
            print "$dir/$_\n";

            if (not pretending())
            {
                symlink $File::Find::fullname, "$dir/$_" or
                    croak_runtime("Couldn't create file $dir/$_: $!");
            }
        }
    };

    # Recursively descend from source dir using File::Find
    eval {
        find ({ 'wanted' => $wanted,
                'follow_fast' => 1,
                'follow_skip' => 2},
              $from);
    };

    if ($@)
    {
        error ("Unable to symlink $from to $to: $@");
        return 0;
    }

    return 1;
}

# Subroutine to delete recursively, everything under the given directory,
# unless we're in pretend mode.
#
# Used from ksb::BuildSystem to handle cleaning a build directory.
#
# i.e. the effect is similar to "rm -r $arg/* $arg/.*".
#
# This assumes we're called from a separate child process.  Therefore the
# normal logging routines are /not used/, since our output will be logged
# by the parent kdesrc-build.
#
# The first parameter should be the absolute path to the directory to delete.
#
# Returns boolean true on success, boolean false on failure.
sub prune_under_directory
{
    my $dir = shift;
    my $errorRef;

    print "starting delete of $dir\n";
    eval {
        remove_tree($dir, { keep_root => 1, error => \$errorRef });
    };

    if ($@ || @$errorRef)
    {
        error ("\tUnable to clean r[$dir]:\n\ty[b[$@]");
        return 0;
    }

    return 1;
}

sub findMissingModules
{
    # should be either strings of module names to be found or a listref containing
    # a list of modules where any one of which will work.
    my @requiredModules = (
        'HTTP::Tiny',
        'IO::Socket::SSL',
        [qw(JSON::XS JSON::PP)],
        [qw(YAML::XS YAML::PP YAML::Syck)]
    );
    my @missingModules;
    my $validateMod = sub {
        return eval "require $_[0]; 1;";
    };

    my $description;
    foreach my $neededModule (@requiredModules) {
        if (ref $neededModule) { # listref of options
            my @moduleOptions = @$neededModule;
            next if (ksb::Util::any (sub { $validateMod->($_); }, $neededModule));
            $description = 'one of (' . join(', ', @moduleOptions) . ')';
        }
        else {
            next if $validateMod->($neededModule);
            $description = $neededModule;
        }

        push @missingModules, $description;
    }

    return @missingModules;
}

# Script starts.

# Ensure some critical Perl modules are available so that the user isn't surprised
# later with a Perl exception
if(my @missingModuleDescriptions = findMissingModules()) {
    say <<EOF;
kdesrc-build requires some minimal support to operate, including support
from the Perl runtime that kdesrc-build is built upon.

Some mandatory Perl modules are missing, and kdesrc-build cannot operate
without them.  Please ensure these modules are installed and available to Perl:
EOF
    say "\t$_" foreach @missingModuleDescriptions;

    # TODO: Built-in mapping to popular distro package names??
    exit 1;
}

# Adding in a way to load all the functions without running the program to
# enable some kind of automated QA testing.
if (defined caller && caller eq 'test')
{
    my $scriptVersion = scriptVersion();
    say "kdesrc-build being run from testing framework, BRING IT.";
    say "kdesrc-build is version $scriptVersion";
    return 1;
}

my $app;
our @atexit_subs;

END {
    # Basically used to call the finish() handler but only when appropriate.
    foreach my $sub (@atexit_subs) {
        &$sub();
    }
}

# Use some exception handling to avoid ucky error messages
eval
{
    $app = ksb::Application->new(@ARGV);

    # Hack for debugging current state.
    if (exists $ENV{KDESRC_BUILD_DUMP_CONTEXT}) {
        local $Data::Dumper::Indent = 1;
        local $Data::Dumper::Sortkeys = 1;

        # This method call dumps the first list with the variables named by the
        # second list.
        print Data::Dumper->Dump([$app->context()], [qw(ctx)]);
    }

    push @atexit_subs, sub { $app->finish(99) };
    my $result = $app->runAllModulePhases();

    @atexit_subs = (); # Clear exit handlers
    $app->finish($result);
};

if (my $err = $@)
{
    if (had_an_exception()) {
        print "kdesrc-build encountered an exceptional error condition:\n";
        print " ========\n";
        print "    $err\n";
        print " ========\n";
        print "\tCan't continue, so stopping now.\n";

        if ($err->{'exception_type'} eq 'Internal') {
            print "\nPlease submit a bug against kdesrc-build on https://bugs.kde.org/\n"
        }
    }
    else {
        # We encountered an error.
        print "Encountered an error in the execution of the script.\n";
        print "The error reported was $err\n";
        print "Please submit a bug against kdesrc-build on https://bugs.kde.org/\n";
    }

    exit 99;
}

# vim: set et sw=4 ts=4 fdm=marker: