-
Sergio Ahumada authored
Change-Id: I02eaa709ff91d158a3e34f4e719254f2adce873e Reviewed-by:
Simo Fält <simo.falt@digia.com> Reviewed-by:
Janne Anttila <janne.anttila@digia.com>
b2221fac
#!/usr/bin/env perl################################################################################# Copyright (C) 2013 Digia Plc and/or its subsidiary(-ies).## Contact: http://www.qt-project.org/legal#### This file is part of the Quality Assurance module of the Qt Toolkit.#### $QT_BEGIN_LICENSE:LGPL$## Commercial License Usage## Licensees holding valid commercial Qt licenses may use this file in## accordance with the commercial license agreement provided with the## Software or, alternatively, in accordance with the terms contained in## a written agreement between you and Digia. For licensing terms and## conditions see http://qt.digia.com/licensing. For further information## use the contact form at http://qt.digia.com/contact-us.#### GNU Lesser General Public License Usage## Alternatively, this file may be used under the terms of the GNU Lesser## General Public License version 2.1 as published by the Free Software## Foundation and appearing in the file LICENSE.LGPL included in the## packaging of this file. Please review the following information to## ensure the GNU Lesser General Public License version 2.1 requirements## will be met: http://www.gnu.org/licenses/old-licenses/lgpl-2.1.html.#### In addition, as a special exception, Digia gives you certain additional## rights. These rights are described in the Digia Qt LGPL Exception## version 1.1, included in the file LGPL_EXCEPTION.txt in this package.#### GNU General Public License Usage## Alternatively, this file may be used under the terms of the GNU## General Public License version 3.0 as published by the Free Software## Foundation and appearing in the file LICENSE.GPL included in the## packaging of this file. Please review the following information to## ensure the GNU General Public License version 3.0 requirements will be## met: http://www.gnu.org/copyleft/gpl.html.###### $QT_END_LICENSE$###############################################################################package QtQA::App::PrintCallingMakefile;use strict;use warnings;=head1 NAMEprint_calling_makefile - print the name of the currently executing makefile=head1 SYNOPSIS # Within "some-makefile": first: perl print_calling_makefile.pl # then, at command prompt: $ nmake -f some-makefile some-makefileWhen called as a child process of nmake or jom, prints the name of thecurrently processed makefile to standard output, and exits. The name ofthe makefile is printed as passed on the command-line, so it may be anabsolute or relative path.This script is a workaround for nmake's lack of any equivalent to GNU make's$(MAKEFILE_LIST) variable. For example, in a GNU makefile, where one wouldwrite something like:7172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140
echo Current makefile is $(firstword $(MAKEFILE_LIST))
In a makefile for nmake, one may write:
for /f "usebackq tokens=*" %%a in (`perl print_calling_makefile.pl`) do echo Current makefile is %%a
This script only works on Windows.
=cut
use Data::Dumper;
use English qw( -no_match_vars );
use Text::ParseWords qw(shellwords);
use Win32::Process::Info qw(WMI);
use Win32;
# Returns 1 if the given $process looks like it refers to jom/nmake.
sub looks_like_make
{
my ($process) = @_;
return ($process->{ ExecutablePath } =~ m{\b(?:jom|nmake)\.exe}i);
}
# From the given process $info (arrayref), find and return the process
# with the given $pid, or die.
sub extract_process
{
my ($info, $pid) = @_;
my (@process) = grep { $_->{ ProcessId } == $pid } @{ $info };
if (@process > 1) {
die "error: multiple processes with ProcessId $pid";
}
if (@process == 0) {
die "error: cannot find process with ProcessId $pid";
}
return $process[0];
}
# Given an nmake/jom $command line, extracts and returns the Makefile
# argument, or dies.
sub extract_makefile_from_command
{
my ($command) = @_;
my $makefile;
# We use shellwords() to parse the command-line; this is following
# Bourne-style rules, which may be incompatible with the way nmake
# parses its own command line in some respects. In practice, for
# the relatively basic command lines we expect to see, this should
# be acceptable.
my @words = shellwords( $command );
my @argv = @words;
while (my $arg = shift @argv) {
# All known forms are:
#
# [-f] [Makefile]
# [/f] [Makefile]
# [-F] [Makefile]
# [/F] [Makefile]
# [-fMakefile]
# [/fMakefile]
# [-FMakefile]
# [/FMakefile]
#
if ($arg =~ m{\A [-/][fF] (.*) \z}xms) {
if ($1) {
141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204
# makefile is in this argument
$makefile = $1;
} else {
# makefile is in next argument
# (or, if this is the last argument, we'll die later)
$makefile = shift @argv;
}
last;
}
}
if (!$makefile) {
local $LIST_SEPARATOR = '] [';
die "Can't extract makefile from command line $command\n"
."Parsed as: [@words]\n";
}
return $makefile;
}
# Main function.
sub run
{
my $pid = Win32::GetCurrentProcessId();
# $info will contain info for _all_ processes (at least those we have permission to view).
# It would also be possible to do a new query per process; a basic benchmark showed no
# significant difference between the two.
my $info = Win32::Process::Info->new()->GetProcInfo();
$info || die;
# $process_tree holds the known process tree, used purely for debugging when something
# goes wrong.
my ($process_tree, $process);
eval {
$process = extract_process( $info, $pid );
while ($process) {
last if looks_like_make( $process );
$process_tree = { %{$process}, _child => $process_tree };
$pid = $process->{ ParentProcessId } || die Dumper( $process ).' ... has no ParentProcessId';
$process = extract_process( $info, $pid );
}
if (!$process) {
die 'error: could not find any calling nmake/jom';
}
};
if (my $error = $@) {
die "$error\nProcess tree: ".Dumper( $process_tree )."\n";
}
my $command = $process->{ CommandLine } || die Dumper( $process ).' ... has no CommandLine';
my $makefile = extract_makefile_from_command( $command );
print "$makefile\n";
return;
}
run unless caller;
1;