#!/usr/bin/perl

#      Copyright (C) Philipp 'ph3-der-loewe' Schafft - 2010-2011
#
#    This program is free software; you can redistribute it and/or modify
#    it under the terms of the GNU General Public License version 3
#    as published by the Free Software Foundation.
#
#    It 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 software; see the file COPYING.gplv3. If not, write to
#    the Free Software Foundation, 51 Franklin Street, Fifth Floor,
#    Boston, MA 02110-1301, USA.

use strict;
use vars qw(%objs %sum %unknown_funcs %warn %pt2msg @ignores $editvim %conf %ignored_targets %call_counts %use_counts $warn_count $call_count);

%conf = (
 'objdump'    => 'objdump',
 'print-mode' => 'default',
 'warn-mode'  => 'default',
 'header'     => 1,
 'fileheader' => 0,
 'mode'       => 'normal',
 'print-internal-pt' => 'internal',
);

%pt2msg = (
 'internal' => 'bad: for internal use only',
 'ignore'   => 'ignored',
 'ok'       => 'no problem',
 'maybe'    => 'maybe a problem',
 'likely'   => 'likely a problem',
 'critical' => 'critical',
 'fail'     => 'fatal',
 'removed'  => 'is removed from specs',
 'legacy'   => 'is marked LEGACY',
 'wip'      => 'is work in process',
 'broken'   => 'bad: function is broken',
);

%warn = map{$_ => 1}(qw(internal likely critical fail removed legacy broken));

@ignores = ('^\.L\d+$');

$editvim = 0;

$warn_count = 0;
$call_count = 0;

my $summery = 1;

foreach (('/usr/lib/ckport/db/', '/usr/local/lib/ckport/db/', $ENV{'HOME'}.'/.ckport/db/')) {
 read_db_dir($_) if -d $_;
}

while (($_ = shift(@ARGV))) {
 if ( $_ eq '--db' ) {
  read_db(shift(@ARGV));
 } elsif ( $_ eq '--db-dir' ) {
  read_db_dir(shift(@ARGV));
 } elsif ( $_ eq '--edit-vim' ) {
  $editvim = 1;
 } elsif ( $_ eq '--conf' ) {
  $_ = shift(@ARGV);
  /^([^=]+)=(.+)$/ or die;
  $conf{$1} = $2;
 } elsif ( $_ eq '--mode' ) {
  $conf{'mode'} = shift(@ARGV);
  if ( $conf{'mode'} eq 'update' || $conf{'mode'} eq 'create' ) {
   %warn = ();
   $summery = 0;
   $conf{'header'} = 0;
   $conf{'fileheader'} = $conf{'mode'} eq 'create' ? 1 : 0;
   $conf{'print-mode'} = 'internal';
   $conf{'print-internal-pt'} = $conf{'mode'} eq 'create' ? 'unknown' : 'internal';
  }
 } elsif ( $_ eq '--warn-mode' ) {
  $conf{'warn-mode'} = shift(@ARGV);
 } elsif ( $_ eq '--warn' ) {
  $warn{shift(@ARGV)} = 1;
 } elsif ( $_ eq '--nowarn' ) {
  $warn{shift(@ARGV)} = 0;
 } elsif ( $_ eq '--nowarns' ) {
  %warn = ();
 } elsif ( $_ eq '--nosummery' ) {
  $summery = 0;
 } elsif ( $_ eq '--summery' ) {
  $summery = 1;
 } elsif ( $_ eq '--summery-on-warn' ) {
  $summery = 2;
 } elsif ( $_ eq '--noheader' ) {
  $conf{'header'} = 0;
 } elsif ( $_ eq '--header' ) {
  $conf{'header'} = 1;
 } elsif ( $_ eq '--nofile-header' ) {
  $conf{'fileheader'} = 0;
 } elsif ( $_ eq '--file-header' ) {
  $conf{'fileheader'} = 1;
 } elsif ( $_ eq '--ignore' ) {
  push(@ignores, shift(@ARGV));
 } elsif ( $_ eq '--ignore-symbol' ) {
  push(@ignores, name_to_regex(shift(@ARGV)));
 } elsif ( $_ eq '--ignore-target' ) {
  $ignored_targets{shift(@ARGV)} = 1;
 } elsif ( $_ eq '--print-mode' ) {
  $conf{'print-mode'} = shift(@ARGV);
 } elsif ( $_ eq '--print-unknown' ) {
  if ( $conf{'header'} ) {
   print "\n";
   print "Unknown functions:\n";
  }
  print_syms([grep{$unknown_funcs{$_} != 2}(keys(%unknown_funcs))]);
 } elsif ( $_ eq '--print-unknown-defined' ) {
  if ( $conf{'header'} ) {
   print "\n";
   print "Unknown defined functions:\n";
  }
  print_syms([grep{$unknown_funcs{$_} == 2 && !defined(lookup_func($_))}(keys(%unknown_funcs))]);
 } elsif ( $_ eq '--print-unused' ) {
  print_syms([grep{defined($unknown_funcs{$_}) && !exists($call_counts{$_}) && !exists($use_counts{$_})}(keys(%unknown_funcs))]);
 } elsif ( $_ eq '--print-known' ) {
  if ( $conf{'header'} ) {
   print "\n";
   print "Known objects:\n";
  }
  print_syms([keys(%objs)]);
 } elsif ( $_ eq '--print-pt' ) {
  if ( $conf{'header'} ) {
   print "\n";
   print "Known pts:\n";
  }
  { local $, = ' ';
    print keys(%pt2msg), "\n";
  }
 } elsif ( $_ eq '--' ) {
  last;
 } elsif ( $_ eq '-h' || $_ eq '--help' ) {
  usage();
  exit(0);
 } elsif ( /^-/ ) {
  die 'Unknown option';
 } else {
  print_fileheader($_) if $conf{'fileheader'};
  read_object($_);
 }
}

foreach (@ARGV) {
 print_fileheader($_) if $conf{'fileheader'};
 read_object($_);
}

if ($conf{'mode'} eq 'update' || $conf{'mode'} eq 'create') {
 print_syms([grep{$unknown_funcs{$_} == 2 && !defined(lookup_func($_))}(keys(%unknown_funcs))])
}

if ( $summery == 1 || ($summery == 2 && $warn_count > 0) ) {
 if ( $conf{'header'} ) {
  print "\n";
  print "Summery:\n";
 }
 my $s = 0;
 $s += $sum{$_} foreach keys %sum;

 printf("Stats: %i warnings, %i(%i) total calls.\n", $warn_count, $s, $call_count);

 printf("calls with pt %s happend %i(%2.2f%%) times\n", $_, $sum{$_}, $sum{$_}*100/$s) foreach keys %sum;
}

#use Data::Dumper;
#print Dumper(\%objs);

if ($warn_count > 0) {
 exit(64);
} else {
 exit(0);
}

#---------

sub usage {
 print "Usage: $0 [OPTIONS]... file [file,...]\n";
 print "\n";
 print <<'__EOH__';
Options:
  --help      -h              - Show this help
  --                          - End of options, only filenames follow
  --mode MODE                 - Mode of operation
  --db DBFILE                 - Load database DBFILE
  --db-dir DBDIR              - Load databases from directory DBDIR
  --edit-vim                  - Show vim command pointing to location of problem
  --conf KEY=VAL              - Set config key KEY to value VAL
  --warn-mode MODE            - Set mode for printing of warnings
  --warn PT                   - Warn about problems of type PT
  --nowarn PT                 - Ignore warnings about problems of type PT
  --nowarns                   - Do not print any warning
  --nosummery                 - Disable summery
  --summery                   - Enable summery
  --summery-on-warn           - Only print summery if warnings has been found
  --noheader                  - Disable printing of headers
  --header                    - Enable printing of headers
  --nofile-header             - Disable printing of headers for each file (operant)
  --file-header               - Enable printing of headers for each file (operant)
  --ignore PATTERN            - Ignore symbols matching this Perl regex pattern
  --ignore-symbol SYMBOL      - Ignore symbol SYMBOL
  --ignore-target TARGET      - Ignore warnings for target TARGET
  --print-mode MODE           - Set mode of symbol printing to MODE
  --print-unknown             - Print unknown symbols found
  --print-unknown-defined     - Print list of unknown but defined (internal) symbols
  --print-unused              - Print list of defined (internal) but unused symbols
  --print-known               - Print list of known symbols
  --print-pt                  - Print list of known problem types

Mode of operation:
  default:  Normal display.
  update:   This prints updates to an existing ckport database.
  create:   This creates a new ckport database for the given object.

Print modes:
  default:  Normal display.
  internal: Print in ckport database format with pt set to 'internal'.

Warn modes:
  default:  Normal display.
  colons:   machine readable format.

Return values:
  0: no program error and no warnings, 64: no progam error but warnings,
  everything else: program error.
__EOH__
}

sub name_to_regex($) {
 my ($name) = @_;

 return "^\Q$name\E\$";
}

sub print_fileheader {
 my ($file) = @_;
 my ($prefix, $name, $suffix, $soversion) = $file =~ /^((?:lib)?)(.+?)\.(so|dll)(?:\.(\d+))$/;

 if ( $conf{'mode'} eq 'create' ) {
  print "#ckport(1) database for $prefix$name:\n";
  print "!NAME: $name library\n";
  print "!TYPE: func\n";
  print "!TARGET: $prefix$name$soversion\n";
  print "\n";
 } else {
  print "Object file: $file\n";
 }
}

sub print_syms {
 my ($syms, $mode) = @_;

 $mode ||= $conf{'print-mode'};

 if ( $mode eq 'default' ) {
  { local $, = ' ';
    local $\ = "\n";
    print sort(@{$syms});
  }
 } elsif ( $mode eq 'internal' ) {
  { local $_;
    my $len;
    my $t;
    foreach (sort(@{$syms})) {
     $len = length($_);
     $len = int($len/8);
     $len = (3 - $len) < 0 ? 0 : 3 - $len;
     $t   = "\t".("\t" x $len);
     print $_, $t, $conf{'print-internal-pt'}, "\n";
    }
  }
 } else {
  die 'unknown print mode';
 }
}

sub read_db_dir($) {
 my ($dir) = @_;
 local $_;

 opendir(my $in, $dir) or die;
 while (($_ = readdir($in))) {
  $_ = $dir.'/'.$_;
  read_db($_) if -f $_;
 }
 closedir($in);

}

sub read_db($) {
 my ($file) = @_;
 my %defs = ('TYPE' => 'unknown', 'NAME' => 'unnamed database', 'TARGET' => '$DEFAULT', 'VERSION' => '');
 my @data;
 my $e;
 my ($k, $v);
 local $_;

 open(my $in, '<', $file) or die;
 while (<$in>) {
  s/\r?\n//;
  s/\s*#.*$//;

  if ( $_ eq '' ) {
   next;
  } elsif ( /^\!([a-zA-Z0-9]+):\s*(.+)$/ ) {
   ($k, $v) = (uc($1), $2);
   if ( $k eq 'TARGET' ) {
    @data = split(/\s+/, $v);
    $defs{'TARGET'}  = $data[0];
    $defs{'VERSION'} = $data[1];
   } else {
    $defs{$k} = $v;
   }
  } else {
   @data = split(/\t+/, $_);

   next unless $data[1];

   $e = [$data[1], $data[2]];

   $objs{$data[0]} ||= {};
   $objs{$data[0]}->{$defs{'TYPE'}} ||= {};
   $objs{$data[0]}->{$defs{'TYPE'}}->{$defs{'TARGET'}} ||= {};
   $objs{$data[0]}->{$defs{'TYPE'}}->{$defs{'TARGET'}}->{$defs{'VERSION'}} = $e;
  }
 }
 close($in);
}

sub read_local_options($) {
 my ($file) = @_;
 my ($k, $v);
 my @ret;
 my @ignores;
 local $_;

# print STDERR "read_local_ignores($file)...\n";

 open(my $in, '<', $file) or return;
 while (<$in>) {
  s/\r?\n//;
  if ( m#^\s*(?://|\s\*|\#|\-\-)\s+ckport:\s+(\S+):\s+(\S+.*?)(?:\s+\-\-.*)?$# ) {
   ($k, $v) = ($1, $2);
   if ( $k eq 'ignore' ) {
    push(@ignores, [$v]);
   } elsif ( $k eq 'ignore-symbol' ) {
    @ret = $v =~ /^(\S+)(?:\s+of\s+target\s+(\S+))?$/;
    push(@ignores, [name_to_regex($ret[0]), ($ret[1] ne '' ? $ret[1] : ())]);
   } else {
    warn "Unknown file-local option: $k: $v";
   }
  }
 }
 close($in);

 return {'ignores' => \@ignores};
}

sub read_object($) {
 my ($file) = @_;
 my ($sfile, $ssym, $sline, $section) = ($file, undef, undef, undef);
 my $tfunc;
 my $ckinfo;
 my ($k, $v);
 my $pt;
 my $ignoreit;
 my $cmd;
 my %local_options;
 local $_;

 open(my $in, '-|', $conf{'objdump'}, '-l', '-d', $file) or die;
 while (<$in>) {
  s/\r?\n//;

  if ( m#^(.+\..+):(\d+)$# ) {
   ($sfile, $sline) = ($1, int($2));
   $local_options{$sfile} = read_local_options($sfile) if !exists($local_options{$sfile}) && -f $sfile;
  } elsif ( m#^Disassembly of section (.+):$# ) {
   $section = $1;
  } elsif ( m#^[0-9a-fA-F]+ \<([^\>]+)\>:$# ) {
   next if $section eq '.plt';
   $ssym = $1;
   $ssym =~ s/\@.+$//;
   $ignoreit = 0;

   foreach (@ignores, @{$local_options{$sfile}->{'ignores'}||[]}) {
    if ( ref($_) eq 'ARRAY' ) {
     next if scalar(@{$_}) != 1;
     $_ = $_->[0];
    }
    if ( $ssym =~ /$_/ ) {
     $ignoreit = 1;
     last;
    }
   }

   $unknown_funcs{$ssym} = 2 unless $ignoreit;
  } elsif ( m#^\s*[0-9a-fA-F]+:\s*.+?\s+[r]?(call|jmp)\s+(?:\.\+\d+\s+;\s+)?(?:0x)?[0-9a-fA-F]+\s+\<([^\>]+)\>$# ) {
   ($cmd, $tfunc) = ($1, $2);
   $tfunc =~ s/\@.+$//;
   $tfunc =~ s/\+0x[a-fA-F0-9]+$//;

   $call_count++;

   $ignoreit = 0;
   foreach (@ignores, @{$local_options{$sfile}->{'ignores'}||[]}) {
    if ( ref($_) eq 'ARRAY' ) {
     next if scalar(@{$_}) != 1;
     $_ = $_->[0];
    }
    if ( $tfunc =~ /$_/ ) {
     $ignoreit = 1;
     last;
    }
   }

   next if $ignoreit;

   $call_counts{$tfunc}++;

   $ckinfo = lookup_func($tfunc);

   unless (defined($ckinfo)) {
    $sum{'unknown'}++;
    $unknown_funcs{$tfunc} ||= 1;
    next;
   }

   foreach $k (keys(%{$ckinfo})) {
    next if $ignored_targets{$k};

    foreach $v (keys(%{$ckinfo->{$k}})) {
     $pt = $ckinfo->{$k}->{$v}->[0];

     foreach (@ignores, @{$local_options{$sfile}->{'ignores'}||[]}) {
      if ( ref($_) eq 'ARRAY' ) {
       next if scalar(@{$_}) == 1;
       if ( $tfunc =~ /$_->[0]/ && $k eq $_->[1] ) {
        $pt = 'ignore';
        last;
       }
      }
     }

     $sum{$pt}++;
     next if $pt eq 'ok' || $pt eq 'ignore';

     foreach (keys %warn) {
      next unless $warn{$_};

      if ( $pt eq $_ ) {
       print_report('sfile'   => $sfile, 'ssym' => $ssym, 'sline' => $sline,
                    'target'  => $k,
                    'version' => $v,
                    'tfunc'   => $tfunc,
                    'section' => $section,
                    'pt' => $pt, 'desc' => $ckinfo->{$k}->{$v}->[1],
                   );
      }
     }
    }
   }

   #printf("Call to %s from %s at %s:%i\n", $tfunc, $ssym, $sfile, $sline);
  }
 }
 close($in);
}

sub lookup_func ($) {
 my ($f) = @_;
 my $r   = $objs{$f};

 return undef unless defined $r;

 $r = $r->{'func'};

 return undef unless defined $r;

 return $r;
}

sub print_report {
 my $info = {@_};
 my $pt   = $info->{'pt'};
 my $pts  = $pt2msg{$pt} || $pt;
 my $mode = $conf{'warn-mode'} || 'default';

 $warn_count++;


 if ( $mode eq 'default' ) {
  if ( $info->{'version'} eq '' ) {
   printf("Call to %s() is %s for target %s:\n", $info->{'tfunc'}, $pts, $info->{'target'});
  } else {
   printf("Call to %s() is %s for target %s version %s:\n", $info->{'tfunc'}, $pts, $info->{'target'}, $info->{'version'});
  }

  printf("  Problem: %s\n", $info->{'desc'}) if $info->{'desc'};

  if ( defined($info->{'section'}) && $info->{'section'} ne '' ) {
   printf("  in function %s() in section %s\n", $info->{'ssym'}, $info->{'section'});
  } else {
   printf("  in function %s()\n", $info->{'ssym'});
  }

  if ( $info->{'sline'} ) {
   printf("  at %s line %i\n", $info->{'sfile'}, $info->{'sline'});
  } else {
   printf("  at %s\n", $info->{'sfile'});
  }
  printf("  edit with: vim +%i %s\n", $info->{'sline'}, $info->{'sfile'}) if $editvim;
  printf("\n");
 } elsif ( $mode eq 'colons' ) {
  {
   my @keys = qw(tfunc pt target version ssym section sfile sline desc);
   my @vals;
   local $, = ':', $\ = "\n";
   local $_;

   @vals = map{$info->{$_}}(@keys);
   s/([\\\n\r:])/\\$1/g foreach @vals;

   print 'WARNING', @vals;
  }
 } else {
  die 'unknown warn mode';
 }
}

#ll
