fpc-filter-vt

#!/usr/bin/perl

# Process the extra output generated by an FPC build when the compiler has
# been told to list all paths etc. using the -vt option, for example:
#
#	make GDB_V603=1 PP=ppcsparc-2.6.2 OPT='-O- -gl -Xs- -vt' all | fpc-filter-vt
#
# Note that make should probably not be run with its -j option here since
# doing so will probably result in interleaved output. The shell is assumed
# to be Bash, other shells might differ slightly in their allocation of
# processes to programs associated by a command-line pipe.
#						MarkMLl 6th April 2014.

# Control what lines are listed in an (approximately) raw form in the output
# file. Commands have their paths stripped and are capitalised to show that
# they have been recognised, "noise" commands, in particular rm, may be
# suppressed.

$list_raw = 0;
$raw_prefix = '# ';
$raw_suppress_notfound = 1;
%raw_suppress_commands = (
  'CP' => 1,
  'DIFF' => 1,
  'ECHO' => 1,
  'MKDIR' => 1,
  'MV' => 1,
  'RM' => 1);

# Control intermediate listing.

$list_inter = 0;
$inter_prefix = '| ';

# Control final listing.

$list_final = 1;

# Arrays representing the directory and sourcefile stacks. $directory[0] is
# the current directory, $sourcefile[0] is the current .pas, .pp, .inc etc.
# file.

use Cwd;

$directory[0] = cwd();
@sourcefile = ();
%allfiles = ();
$lastfound = '';
$utilities = ' ';
$assembler = ' ';

# Open a file for output, this will be in the directory that the build was
# started in, typically /usr/local/src/fpc/fpcbuild/fpcsrc, and should at a
# minimum contain all extra messages that the -vt option caused the compiler
# to insert. Abort on error.

$_ = './fpc-vt.log';
open XREF, ">$_" or die "Can't open file $_ for writing: $!\n";

# The first three lines of the output identify the host and compiler, and
# reproduce a sibling process's command line which should be the entire make
# command. Don't expect any of this to work on Windows, it's only tested on
# Linux (Debian v4 "Etch" and v5 "Lenny", and Slackware 8.1) and Solaris (8
# and 10).

$_ = `uname -a`;
if ($? == 0) {
  print XREF "$_";
} else {
  print XREF "[No uname]\n";
}
if ($ENV{PP}) {
  $_ = $ENV{PP};
} else {
  $_ = 'fpc';
}
$_ = `$_ -h|grep '^Free Pascal Compiler version'`;
if ($? == 0) {
  print XREF "Using $_";
} else {
  print XREF "[No compiler]\n";
}

# The code that follows works for Bash, where this filter script and the make
# process share a common parent (the shell). It might not work for other shells,
# in particular the Bourne Shell from Solaris 10 (SunOS 5.10) where the filter
# script's parent might be the make process or where process allocation has not
# settled down by the time this runs.
#
# Expect that the build is being run with a command like:
#
# make GDB_V603=1 OPT='-O- -gl -vt -dEXTDEBUG' all
#
# or
#
# make NOGDB=1 OPT='-O- -gl -vt -dFPC_ARMEL -CfSOFT' all
#
# Find the relevant process in the process tree and extract its command line,
# this might fail if make decides there's nothing worth doing and terminates
# with minimal output. Check whether the quotes (as shewn above) have been
# lost: reinstating the quotes, necessary to allow the command to be cut-and-
# pasted, necessitates making assumptions about the sequence of elements in
# the command line, namely that the OPT string comprises a sequence of options
# each starting with - and that is is terminated by anything that doesn't
# start with - (or --).
#
# For Linux, ps is normally found in /bin/ps. For Solaris it is probably in
# /usr/bin/ps, but we never want to use the Berkeley one in /usr/ucb/ps which
# has neither the --ppid nor the -f option; code below will probably need to
# be refined for BSD.

$_ = getppid;
if ($_ > 1) {
  my $PS = 'ps';
  if (-x '/bin/ps') {			# Typical case for Linux
    $PS = '/bin/ps';
  }
  if (-x '/usr/bin/ps') {		# Typical case for Solaris
    $PS = '/usr/bin/ps';
  }
#  my @ps = split /\n/, `$PS --ppid $_ -f`;
  my @ps = split /\n/, `$PS -f |grep $_`;

# First form above requires ps v3.x for the --ppid option. Second is more
# portable and should be OK unless the parent process has itself got a -vt
# option.
#
# Code below looks for 'make ' (i.e. to include gmake but not makefile), and
# then in order to be useful when compiling simple programs (i.e. without a
# makefile) for ' fpc' and ' ppc' trying to be careful to not be thrown by
# e.g. crosstools with ppc as a suffix.

  my @vt = grep / -vt/, @ps;		# Any command with a -vt option...
  $_ = (grep /make\s/, @vt)[0];		# ...first of those which is a make.
  my @make = split / /, $_;
  while (@make && ($make[0] !~ /make/)) {
    shift @make;
  }
  $_ = join ' ', @make;
  if ($_) {
    if (/^(.*? )OPT=(-.+?) ([^-].+)$/) {
      $_ = "$1OPT='$2' $3";
    }
    print XREF "$_ |$0\n\n";
  } else {
    $_ = (grep /\sfpc/, @vt)[0];	# ...first of those which is an fpc.
    my @fpc = split / /, $_;
    while (@fpc && ($fpc[0] !~ /^fpc/)) {
      shift @fpc;
    }
    $_ = join ' ', @fpc;
    if ($_) {
      print XREF "$_ |$0\n\n";
    } else {
      $_ = (grep /\sppc/, @vt)[0];	# ...first of those which is a ppc.
      my @ppc = split / /, $_;
      while (@ppc && ($ppc[0] !~ /^ppc/)) {
        shift @ppc;
      }
      $_ = join ' ', @ppc;
      if ($_) {
        print XREF "$_ |$0\n\n";
      } else {
        print XREF "[Command line inaccessible]\n\n";
      }
    }
  }
} else {
  print XREF "[Unexpected process tree layout]\n\n";
}

# Process each line of input piped into the script. Line-by-line input
# including trailing \n etc. is in the $_ variable, if list_raw is non-zero
# then echo to the output file. Where appropriate also do "clever stuff" to
# track and output state.

while (<>) {

  if (/^Compiler: /) {
    $list_raw && print XREF "$raw_prefix$_";

  } elsif (/^Path "(.*?)" not found$/) {
    if (! $raw_suppress_notfound) {
      $list_raw && print XREF "$raw_prefix$_";
    }

  } elsif (/^Searching file (.*?)\.\.\. not found$/) {
    if (! $raw_suppress_notfound) {
      $list_raw && print XREF "$raw_prefix$_";
    }

  } elsif (/^Searching file (.*?)\.\.\. found$/) {
    $list_raw && print XREF "$raw_prefix$_";
    &found($1);				# Go do clever stuff

  } elsif (/^Unitsearch: (.*)$/) {
    $list_raw && print XREF "$raw_prefix$_";

  } elsif (/^PPU Loading (.*)$/) {
    $list_raw && print XREF "$raw_prefix$_";

  } elsif (/^Using executable path: (.*)$/) {
    $list_raw && print XREF "$raw_prefix$_";

  } elsif (/^Using unit path: (.*)$/) {
    $list_raw && print XREF "$raw_prefix$_";

  } elsif (/^Using library path: (.*)$/) {
    $list_raw && print XREF "$raw_prefix$_";

  } elsif (/^Using object path: (.*)$/) {
    $list_raw && print XREF "$raw_prefix$_";

  } elsif (/^Using include path: (.*)$/) {
    $list_raw && print XREF "$raw_prefix$_";

  } elsif (/^(.*?)\(\d+,\d+\) +Start reading includefile (.*)$/) {
    unshift @sourcefile, $2;		# Clever stuff
    &start_reading($2);			# Go do clever stuff
    $list_raw && print XREF "$raw_prefix$_";

  } elsif (/^(.*?)\([1234567890,]+\) +Back in (.*)$/) {
    shift @sourcefile;			# Clever stuff
    $list_raw && print XREF "$raw_prefix$_";

# These are standard make messages which should go to stdout, but are
# probably worth logging as well.

  } elsif (/^make\[\d+\]: Entering directory `(.*?)'$/) {
    unshift @directory, $1;		# Clever stuff
    print "$_";
    $list_raw && print XREF "$raw_prefix$_";

  } elsif (/^make\[\d+\]: Leaving directory `(.*?)'$/) {
    shift @directory;			# Clever stuff
    print "$_";
    $list_raw && print XREF "$raw_prefix$_";

# With the exception of make all commands are referred to by absolute paths,
# these are worth saving. We don't need the path so substitute it away, output
# the command capitalised to be easily recognisable except that the various
# passes and variants of the Pascal compiler (ppc1, ppc2, ppc386 etc.) are
# all given as PPC.

  } elsif (/^(\/.*?) (.*)$/) {
    print "$_";
    my $command = $1;
    my $param = $2;
    $command =~ s|^/.*/([^/]+)$|$1|;
    if ($command =~ /ppc/) {
      $command = 'PPC';
    } else {
      $command = uc $command;
    }
    if (! $raw_suppress_commands{$command}) {
      $list_inter && print XREF "${inter_prefix}In $directory[0]\n";
      $list_raw && print XREF "$raw_prefix$command $param\n";
    }
    if ($command eq 'PPC') {
      &ppc($param);			# Go do clever stuff
    }
  } elsif (/^Using util (.*)\n$/) {
    if ($utilities !~ / $1 /) {
      $utilities .= "$1 ";
    }
    $list_raw && print XREF "$raw_prefix$_";
  } elsif (/^Using assembler: (.*)\n$/) {
    if ($assembler !~ / $1 /) {
      $assembler .= "$1 ";
    }
    $list_raw && print XREF "$raw_prefix$_";

# Send anything unrecognised to stdout, attempting to approximate what would
# be seen if the -vt option had not been specified.

  } else {
    print "$_";
  }
}

# Dump the entire list of files. The key of the hash is a full path with the
# value being a simple filename, sorting (note use of cmp rather than the
# numeric <=>) by filename gives us a quick lookup for use with gdb and also
# highlights cases where (what should be) the same file has been fetched from
# distinct locations.

if ($list_final) {
  print XREF "\n\n" . ('%' x 78) . "\n\n";
  my $maxvaluelength = 16;
  foreach $value (values %allfiles) {
    if (length $value >= $maxvaluelength) {
      $maxvaluelength += 2;
    }
  }
  foreach $sortedkey (sort {$allfiles{$a} cmp $allfiles{$b}} (keys %allfiles)) {
    printf XREF "%-${maxvaluelength}s%s\n", $allfiles{$sortedkey}, $sortedkey
  }
  print XREF "\n";
}

print XREF "Utilities:$utilities\n";
print XREF "Assembler:$assembler\n";
print XREF "\n";

if (scalar(@directory) != 1) {
  print STDERR "\nError: stack does not contain precisely one directory at end of run.\n";
} else {
  if ($directory[0] ne cwd()) {
    print STDERR "\nWarning: directory at end of run is not the same as at the start.\n";
  }
} 

close XREF;

# Suggest where to install the binaries in order to keep separate copies of
# the fp IDE etc. If there isn't something that looks like a version number in
# the source directory then look at the PP shell variable, this will only work
# if PP is set before invoking the combined makefile and filter (i.e. rather
# than using  make PP=  etc.).

if ($directory[0] =~ /.*-(\d+\.\d+\.\d+).*/) {
  $v = $1;
} else {
  if ($ENV{PP} && ($ENV{PP} =~ /.*-(\d+\.\d+\.\d+).*/)) {
    $ENV{PP} =~ /.*-(\d+\.\d+\.)(\d+).*/;
    $v = $1 . ($2 + 2);
  } else {
    $v = '2.6.2';
  }
}
$m = `uname -m`;
chomp $m;
print STDERR "\nNow install using something like\n\n";
print STDERR "        sudo INSTALL_BINDIR=/usr/local/bin.fpc/$v make install\n\n";
print STDERR "In /usr/local/bin, optionally create symlinks for e.g. ppc$m by hand using\n\n";
print STDERR "        # sudo rm ppc$m\n";
print STDERR "        sudo ln -s /usr/local/lib/fpc/$v/ppc$m ppc$m-$v\n";
print STDERR "        sudo ln -s ppc$m-$v ppc$m\n\n";
print STDERR "In all cases, adjust version number and architecture name as appropriate.\n\n";
exit;


  ############################################################################
 #       1         2         3         4         5         6         7
# 3456789012345678901234567890123456789012345678901234567890123456789012345678
#


sub ppc {

  my @param = split / /, shift @_;
  my $finalparam = $param[$#param];

# If the parameter doesn't have an absolute path then prefix it with the
# current directory.

  if ($finalparam !~ m|^/|) {
    $finalparam = $directory[0] . '/' . $finalparam;
  }
  $list_inter && print XREF "${inter_prefix}PPC $finalparam\n";
  $list_final && print XREF "= $finalparam\n";

# Set initial (top-level) sourcefile.

  @sourcefile = ($finalparam);
  $lastfound = $finalparam;
} # ppc;


sub found {

  my $filename = shift @_;
  my $qualified = $filename;

# If the filename doesn't have an absolute path then prefix it with the
# current directory.

  if ($filename !~ m|^/|) {
    $qualified = $directory[0] . '/' . $filename;
  }

# If the filename already appears in the list of sourcefiles then skip it.
# Ditto if we've just found it.

  if (grep /$qualified/, @sourcefile) {
    return;
  }
  if ($qualified eq $lastfound) {
    return;
  }
  $lastfound = $qualified;

# Pad for intermediate output depending on the includefile depth.

  if ($list_inter) {
    print XREF $inter_prefix . (' ' x scalar(@sourcefile)) . $qualified;
    if (-r $qualified) {
      print XREF " [OK]\n";
    } else {
      print XREF " [missing]\n";
    }
  }

# Don't list include files here, see start_reading() below.

  if ($list_final) {
    if ($qualified !~ /\.inc$/i) {
      print XREF '+ ' . (' ' x scalar(@sourcefile)) . $qualified ."\n";
    }
  }

# Save the fully-qualified location of the file and, for convenience, the
# name it was referred to by. Note the while here- I've seen cases where this
# type of string-shortening substitution isn't handled reliably by the g
# option.

  while ($qualified =~ s|/\./|/|) {}
  while ($qualified =~ s|/[^/]+/\.\./|/|) {}
  $filename =~ s|^.+?/([^/]+)$|$1|;
  $allfiles{$qualified} = $filename;
} # found


sub start_reading {

  my $filename = shift @_;

# If the filename doesn't have an absolute path then prefix it with the
# current directory.

  if ($filename !~ m|^/|) {
    $filename = $directory[0] . '/' . $filename;
  }

# If the filename already appears in the list of sourcefiles then skip it.

  if (grep /$filename/, @sourcefile) {
    return;
  }

# Pad for intermediate output depending on the includefile depth.

  $list_final && print XREF '+ ' . (' ' x scalar(@sourcefile)) . $filename ."\n";
} # start_reading