#! /usr/bin/env perl

# Name        : Profiler.pl
# Licence     : GPL v2 or later
# Author      : theo
# Contact     : theocrite free fr
# Version     : 0.0.8-20061113
# Abstract    : Print missing files for a prog using strace (or truss or...)
# Requirements: strace (or any system/signal tracer), perl
# Full descripton : (TODO (later))
# Changelog :
#             0.0.9 - Basename
#                   - Lot of code cleaning
#                   - Benchmarks (but due to the changes, it's much slower than
#                     version 0.0.8)
#                   - Add quiet, files-only, sort, uniq, reverse and both options
#             0.0.8 - Code cleaning & improvements & optimisations (save up to
#                     one second when processing around one minute. Pretty
#                     usefull isn't it ?
#             0.0.7 - Add -f option to trace childs.
#             0.0.6 - regex improvements.
#             0.0.5 - auto choose the toll using uname.
#                   - hacks to prevent [.+] to be interpreted as regex.
#             0.0.4 - I didn't even think that this litte script will take more
#                     than 10 lines. It wasn't supposed to evolute either. So
#                     there s no previous logs.
# TODO :
#   => Full description
#   => Test tracer presence (-p)


#####################
## Declarations
#####################
use strict;
use Switch;
use Getopt::Long;

# global vars
my (
    @not_found,   # Not found opened (failed) files
    $profiler,    # Name of the system tracer (+option)
    $enoent,      # Tracer's tag for enoent files
    $descriptor,  # Redirect stderr
    $both,        # -b argument
    $child,       # -f argument
    $files_only,  # -j argument
    $help,        # -h argument
    $quiet,       # -q argument
    $reverse,     # -r argument
    $sort,        # -s argument
    $uniq         # -u argument
 );


#####################
## functions
#####################
# UNIX basename dumb clone
sub basename ($)
{
  my $base = shift;
  $base =~ s/.*\///;
  return $base;
}


# print help and exit with appropriate status
sub help ($)
{
  my $name = basename ($0);
  print <<EOF
  Use: $name [-f] [-r|-b] [-u] "command"
       $name [-h|--help]

  DESCRIPTION
  Trace the command given on command line. If using options or multiple
  arguments, please use quotes (") to prevent $name to use these options for
  itself.

  COMMAND LINE OPTIONS
  -b|--both             group enoent opened file by both folders and files
  -f|--fork|--child     trace childs.
  -h|--help             display this message
  -j|--files-only       only print missing files
  -q|--quiet            only prints enoent opened files, no other informations
  -r|--reverse          group enoent opened file by folders, not by files
  -s|--sort             sort by files or folders (depending on the context)
  -u|--uniq             do not print more than one time a file for each folder
EOF
 ;
  exit shift;
}


# parse the tracer output in two arrays :
# @found (file ^open and not enoent)
# @not_found (file ^open and enoent)
sub parse_output ($$@)
{
  my $open = shift;
  my $enoent = shift;
  my ($name, $path, $line, $escaped_name, @found);
  foreach $line (@_)
    {
      if ($line =~ /$open/)
        {
          $path = $3;
          $name = $4;
          next if ($name eq "");
          if ($line =~ /$enoent/)
            {push @not_found, "$name $path"}
          else
            {push @found, $name}
        }
    }
    # Delete lines about file getting multiple enoent before an open succeds
    foreach my $name (@found)
      {
        # Quick & dirty patch to prevent + (gtk2+) and . (v2.1) to be interpreted
        # as regex
        ($escaped_name = $name) =~ s/([+.])/\\$&/g;
         @not_found = grep (!/^$escaped_name/, @not_found);
      }
}


# print all enoent files and the folder in which the enoent occured
sub find_enoent_by_files ($$$)
{
  my ($escaped_name, $escaped_folder);
  $sort and @not_found = sort @not_found;

  if ($files_only)
    {
     print "\n\n*** Files only ***\n";
      while (@not_found)
        {
          my ($name) = split / /, @not_found[0];
          print "$name\n";
          ($escaped_name = $name) =~ s/([+.])/\\$&/g;
          @not_found = grep (!/^$escaped_name /, @not_found);
        }
    exit 0;
    }

  print "\n\n*** Grouped by files ***\n";
  while (@not_found)
    {
        my ($name) = split / /, @not_found[0];
        ($escaped_name = $name) =~ s/([+.])/\\$&/g;
        my @paths = grep (/^$escaped_name /, @not_found);
        if ($uniq)
          {
            my @buff;
            while (@paths)
              {
                my ($name, $folder) = split / /, $paths[0];
                ($escaped_folder = $folder) =~ s/([+.])/\\$&/g;
                @paths = grep (!/^$escaped_name $escaped_folder$/, @paths);
                push @buff, $folder;
              }
            @paths = @buff;
          }
        else
         {
             s/^.*? //
           foreach (@paths);
         }
        if (@paths == 1)
          {
            print "[$name] not found in '$paths[0]'\n";
          }
        elsif (@paths > 1)
          {
            print "[$name] not found in :\n";
                print "  => '$_'\n"
            foreach (@paths);
          }
        else
          {
             print STDERR "Error : Impossible configuration (\$#path = $#paths) ";
             print STDERR "name : $name\n";
             print STDERR "Please report this error to the author\n";
           }
        # removing already handeled file
        @not_found = grep (!/^$escaped_name /, @not_found);
    }
  $both or exit 0;
}


sub find_enoent_by_dir ($$$)
{
  my ($escaped_name, $escaped_folder);
  print "\n\n*** Grouped by folders ***\n";

  $sort and @not_found = sort {($a =~ /([^ ]*)$/)[0] cmp ($b =~ /([^ ]*)$/)[0]} @not_found;

  while (@not_found)
    {
      my ($name, $folder) = split / /, @not_found[0];
      ($escaped_folder = $folder) =~ s/([+.])/\\$&/g;
      my @files = grep (/ $escaped_folder$/, @not_found);
      if ($uniq)
        {
          my @buff;
          while (@files)
            {
                my ($name, $folder) = split / /, $files[0];
                ($escaped_name = $name) =~ s/([+.])/\\$&/g;
                @files = grep (!/^$escaped_name $escaped_folder$/, @files);
                push @buff, $name;
            }
          @files = @buff;
        }
      else
       {
           s/ .*$//
         foreach (@files);
       }
      if (@files == 1)
        {
          print "In '$folder', [$files[0]] was not found'\n";
        }
      elsif (@files > 1)
        {
          print "In [$folder] folowing files were not found :\n";
              print "  => '$_'\n"
          foreach (@files);
        }
      else
        {
           print STDERR "Error : Impossible configuration (\$#files = $#files) ";
           print STDERR "name : $name\n";
           print STDERR "Please report this error to the author\n";
         }

      # removing already handeled file
      @not_found = grep (!/ $escaped_folder$/, @not_found);
    }
    $both or exit 0;
}


# guess the tracer and options considering the OS
sub curstom_tracer
{
  my $soft = shift;
  my ($command, $open);
  my $common_pattern = 'open(64)?\("(.*)\/([%a-zA-Z0-9_+.-]*)"';
  open (UNAME, "uname|");
  my @uname = <UNAME>;
  close (UNAME);
  chomp ($uname[0]);
  switch (lc ($uname[0]))
    {
      case /linux/
        {
          $quiet or print "linux\n";
          $descriptor = '2>&1 >&-';
          $enoent = 'ENOENT';
          $open = '^(\[pid \d*\])?' . $common_pattern;
          $profiler = 'strace'.($child and ' -f');
        }
      # case /(sunos)|(bsd)/
      case /sunos/
        {
          $quiet or print "sunos\n";
          $descriptor = '2>&1 >&-';
          $enoent = 'ENOENT';
          $open = '^(\d*:\s*)?' . $common_pattern;
          $profiler = 'truss' . ($child and ' -f');
        }
      case /irix/
        {
          $quiet or print "irix\n";
          $descriptor = '2>&1 2>&-';
          $enoent = 'errno = 2';
          $open = '^()\s+\d+mS[^:]+:\s' . $common_pattern;
          $profiler = 'par' . ($child and ' -i');
        }
      case /hp-ux/
        {
          $quiet or print "hp-ux\n";
          $descriptor = '2>&1 2>&-';
          $enoent = 'ERR#2 ENOENT';
          $open = '^()' . $common_pattern;
          $profiler = 'tusc' . ($child and ' -f');
        }
      print STDERR "The OS '$uname[0]' is not known to be supported\n";
      print STDERR "Please report this error to the author (don't forget to ";
      print STDERR "specify the script version and the OS used)\n";
      # FIXME : let the user define the system tracer
      exit 1;
    }

  $command = "$profiler $soft $descriptor";
  $quiet or print "Command : [$command]\n";
  open (PROFILER, "$command|") or die "Error ($0: $command). Error: $!\n";
  parse_output ($open, $enoent, <PROFILER>);
  close (PROFILER);

   $both and (my @_not_found = @not_found);
   $reverse or find_enoent_by_files ($open, $enoent, "$profiler $soft $descriptor");
   $both and (@not_found = @_not_found);
   ($reverse or $both) and find_enoent_by_dir ($open, $enoent, "$profiler $soft $descriptor");
}


#####################
## core program
#####################
GetOptions(
    "both|b"            => \$both,
    "fork|child|f"      => \$child,
    "help|h"            => \$help,
    "files-only|j"      => \$files_only,
    "quied|q"           => \$quiet,
    "reverse|r"         => \$reverse,
    "sort|s"            => \$sort,
    "uniq|u"            => \$uniq
);

$help and help (0);
my $cpt = 0;
$both       and $cpt++;
$files_only and $cpt++;
$reverse    and $cpt++;
($cpt > 1) and print STDERR "  NOTICE: -j, -r and -b options are exclusive\n\n\n" and help (1);
(@ARGV == 1) or help(2);
curstom_tracer ($ARGV[0]);
