#!/usr/bin/perl -w

eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}'
    if 0; # not running under some shell
###############################################################################
# Sanity check plugin for the Krazy project.                                  #
# Copyright (C) 2007 by Allen Winter <winter@kde.org>                         #
#                                                                             #
# 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. #
#                                                                             #
###############################################################################

#NOTE:
# 1. only *require* this check for library headers that are installed.
#    a simple check is to do so in kde*libs modules, but that's not
#    really good enough, but it may have to do.
#    i.e. application libraries don't require this check
# 2. if this is run on an application library header file *and*
#    that header is using d-pointers => run this check
#    if there isn't a d-pointer in an application library header file,
#    then don't bitch at all.

# Tests KDE source for classes that contain private members in a public class.

# Program options:
#   --help:          print one-line help message and exit
#   --version:       print one-line version information and exit
#   --explain:       print an explanation with solving instructions, then exit
#   --quiet:         suppress all output messages
#   --verbose:       print the offending content

# Exits with status=0 if test condition is not present in the source;
# else exits with the number of failures encountered.

use strict;
use Getopt::Long;
use Cwd 'abs_path';

my($Prog) = "dpointer";
my($Version) = "1.0";

my($help) = '';
my($version) = '';
my($explain) = '';
my($quiet) = '';
my($verbose) = '';

exit 1
if (!GetOptions('help' => \$help, 'version' => \$version,
		'explain' => \$explain,
		'verbose' => \$verbose, 'quiet' => \$quiet));

&Help() if $help;
&Version() if $version;
&Explain() if $explain;
if ($#ARGV != 0){ &Help(); exit 0; }

# Check Condition
my($f) = $ARGV[0];

if ($f =~ m/\.h$/ || $f =~ m/\.hxx$/) {
  open(F, "$f") || die "Couldn't open $f";
} else {
  print "okay\n" if (!$quiet);
  exit 0;
}
my($absf) = abs_path($f);
my($LibPath) = ($absf =~ m+/kde.*libs/+ ||
		$absf =~ m+/koffice/libs/+ ||
		$absf =~ m+/kdebase/libkonq/+) ? 1 : 0;
my($IS_EXPORTED) = 0;
my($HAVE_DPOINTER) = 0;

#open file and slurp it in
open(F, "$f") || die "Couldn't open $f";
my(@data_lines) = <F>;
close(F);

#get all the c-style comments from the file
my($data)="@data_lines";
my(@comments) = ($data =~ /\/\*.*?\*\//gs);

#for each comment, remove everything but the linebreaks, so
#our line numbering report does not get screwed up.
foreach my $comment ( @comments ) {
        my($fixed_comment) = $comment;
        $fixed_comment =~ s/[^\n]//gs;
        $fixed_comment =~ s/\n/\n/gs;
        $data =~ s/\Q$comment/$fixed_comment/s;
}

#put it back into an array so we can iterate over it
my(@lines) = split(/\n/, $data);

my($cnt) = 0;
my($ccnt) = 0;
my($mcnt) = 0;
my($linecnt) = 0;
my($lstr) = "";
my($clstr) = "";
my($mlstr) = "";
my($line) = "";
my($sline) = "";
my($cname) = "";
my($pureVirt) = 0;   # count pure virtuals per class
my($qInterfaces) = 0; # count Q_INTERFACES(..) per class
while ($linecnt < $#lines) {
  $linecnt++;
  $line = $lines[$linecnt];

  $cname = &Cname($line,$lines[$linecnt-1]);
  if ($cname ne "" && $line !~ m+//.*[Kk]razy:exclude=.*$Prog+) {

    $sline = $line;
    my($privMembers)=0;
    my($privLinesList)="";
    $HAVE_DPOINTER=0;
    $pureVirt=0;
    $qInterfaces=0;
    while ($linecnt < $#lines) {
      # search for "private:"
      $linecnt++;
      $line = $lines[$linecnt];
      if (&Cname($line,$lines[$linecnt-1])) { $linecnt--; last; }
      last if (&endClass($line,$linecnt));

      if (&isPureVirtual($line)) { $pureVirt++; }
      if (&isQInterfaces($line)) { $qInterfaces++; }
      if ($line =~ m/[[:space:]]*private[[:space:]]*:/ && $IS_EXPORTED) {
	# we are in the private declarations
	while ($linecnt++ < $#lines) {
	  $line = $lines[$linecnt];
	  if (&endClass($line,$linecnt)) { $linecnt--; last; }
	  last if ($line =~ m/[[:space:]]*\}[[:space:]]*;/);
	  last if ($line =~ m/[[:space:]]*private[[:space:]]*:/);
	  last if ($line =~ m/[[:space:]]*private[[:space:]]*Q_SLOTS[[:space:]]*:/);
	  last if ($line =~ m/[[:space:]]*private[[:space:]]*slots[[:space:]]*:/);
	  last if ($line =~ m/[[:space:]]*protected[[:space:]]*:/);
	  last if ($line =~ m/[[:space:]]*protected[[:space:]]*Q_SLOTS[[:space:]]*:/);
	  last if ($line =~ m/[[:space:]]*protected[[:space:]]*slots[[:space:]]*:/);
	  last if ($line =~ m/[[:space:]]*public[[:space:]]*:/);
	  last if ($line =~ m/[[:space:]]*public[[:space:]]*Q_SLOTS[[:space:]]*:/);
	  last if ($line =~ m/[[:space:]]*public[[:space:]]*slots[[:space:]]*:/);
	  last if ($line =~ m/[[:space:]]*signals[[:space:]]*:/);
	  last if ($line =~ m/[[:space:]]*k_dcop_signals[[:space:]]*:/);
	  last if ($line =~ m/[[:space:]]*Q_SIGNALS[[:space:]]*:/);
	  my($ll) = $linecnt+1;
	  if (&Priv($line,$linecnt,$cname)) {
	    # found a private member
	    $privMembers++;
	    if ($privMembers == 1) {
	      $privLinesList = $ll;
	    } else {
	      $privLinesList = $privLinesList . "," . $ll;
	    }
	    print "=> $line\n" if ($verbose);
	  } else {
	    # perhaps a non-const d-pointer
	    if ($line =~ m/Private/ &&
		$line !~ m/class/ && $line !~ m/struct/ &&
		$line !~ m/QSharedDataPointer/ && $line !~ m/KSharedPtr/) {
	      if ($line !~ m/Private[[:alpha:]]*[[:space:]]*\*[[:space:]]*const/) {
		$ccnt++;
		if ($ccnt == 1) {
		  $clstr = "non-const dpointer line\#" . $ll;
		} else {
		  $clstr = $clstr . "," . $ll;
		}
		print "=> $line\n" if ($verbose);
	      }
	    }
	  }
	} # loop over lines in private section
      } # if in private
    } # loop over lines in class

    # non-Library: only complain if mixing d-pointers with private members
    if ($LibPath || (!$LibPath && ($HAVE_DPOINTER && $privMembers))) {
      if ($cnt == 0) {
	$lstr = "private members line\#" . $privLinesList;
      } else {
	$lstr = $lstr . "," . $privLinesList if ($privLinesList);
      }
      $cnt += $privMembers;
    }
# print "LibPath=$LibPath\n";
# print "cname=$cname\n";
# print "IS_EXPORTED=$IS_EXPORTED\n";
# print "HAVE_DPOINTER=$HAVE_DPOINTER\n";
    if ($LibPath && $cname && $IS_EXPORTED && !$HAVE_DPOINTER) {
      # abstract base classes do not require a d-pointer
      # fyi: abstract base classes have at least 1 pure virtual, non-dtor func
      if (!(&searchBack("Q_DECLARE_INTERFACE.*$cname",$#lines-1,10) ||
	  $pureVirt >= 1 || $qInterfaces > 0)) {
	$mcnt++;
	if ($mcnt == 1) {
	  $mlstr = "missing dpointer in classes: " . $cname;
	} else {
	  $mlstr = $mlstr . "," . $cname;
	}
	print "=> $sline\n" if ($verbose);
      }
    }
  } #if in class
} #loop over each line of file
close(F);

if (!$cnt && !$ccnt && !$mcnt) {
  print "okay\n" if (!$quiet);
  exit 0;
} else {
  print "$lstr ($cnt)\n" if (!$quiet && $cnt);
  print "$clstr ($ccnt)\n" if (!$quiet && $ccnt);
  print "$mlstr ($mcnt)\n" if (!$quiet && $mcnt);
  exit $cnt+$ccnt+$mcnt;
}

# determine if the current line $l has a class, checking the previous line $l1
# for classes to ignore (like "template").
# return the class name, or empty if no class is found
sub Cname {
  my($l,$l1) = @_;
  my($cname)="";
  $l =~ s+//.*++; #strip trailing C++ comment
  return 0 if ($l =~ m/_EXPORT_DEPRECATED/);
  return 0 if ($l =~ m/_TEST_EXPORT/);
  if ($l =~ m+^[[:space:]]*class[[:space:]].*+ && $l !~ m/;$/) {
    if ($l1 !~ m/template/ && $l1 !~ m/#define[[:space:]]/) {
      $cname = $l;
      $cname =~ s/:.*$//;
      $cname =~ s/{.*$//;
      $cname =~ s/[[:space:]]*class[[:space:]].*EXPORT[[:space:]]//;
      $cname =~ s/[[:space:]]*class[[:space:]]//;
      $cname =~ s/\s+$//;
      if ($l =~ m/_EXPORT/) {
	$IS_EXPORTED=1;
      } else {
	$IS_EXPORTED=0;
      }
    }
  }
  return $cname;
}

# determine if the current line marks the end of a class
sub endClass {
  my($l,$lc) = @_;
  return 0 if ($l !~ m/^[[:space:]]*}[[:space:]]*;/);
  return 0 if (&searchBack('enum',$lc,10));
  return 1;
}

# determine if the current line $l has a private member
sub Priv {
  my($l,$lc,$cname) = @_;
  my($args,$a1,$a2);

  return 0 if ($l =~ m+//.*[Kk]razy:exclude=.*$Prog+);

  $l =~ s+//.*++; #strip trailing C++ comment
  $l =~ s/\s+$//; #strip trailing whitespace
  return 0 unless(length($l));

  #if we find a dpointer, then also set the global $HAVE_DPOINTER
  if ($l =~ m/Private/) {
    $HAVE_DPOINTER=1;
    return 0;
  }

  #private member stuff we allow
  return 0 if ($l =~ m/[[:space:]]$cname[[:space:]]*\(/);  #private ctor
  return 0 if ($l =~ m/[[:space:]]~$cname[[:space:]]*\(/);  #private dtor
  return 0 if ($l =~ m/Q_DECLARE_PRIVATE/);
  return 0 if ($l =~ m/Q_PRIVATE_SLOT/);
  return 0 if ($l =~ m/QSharedDataPointer/);
  return 0 if ($l =~ m/KSharedPtr/);
  return 0 if ($l =~ m/[[:space:]]*static[[:space:]]/);
  return 0 if ($l =~ m/[[:space:]]*friend[[:space:]]/);
  return 0 if ($l =~ m/[[:space:]]*template[[:space:]]/);
  return 0 if ($l =~ m/\(/); #easy check for functions

  #search back a couple lines for start of function
  return 0 if ($l =~ m/,/ && $l !~ m/\(/ && &searchBack('\(',$lc,2));
  return 0 if ($l =~ m/\)/ && &searchBack('\(',$lc,3));

  #not permitted private member encountered
  return 1;
}

# determine if the current line $l has a pure virtual function.
sub isPureVirtual {
  my($l) = @_;
  $l =~ s+//.*++; #strip trailing C++ comment
  if ($l =~ m+virtual.*=[[:space:]]*0[[:space:]]*;[[:space:]]*+) {
    return 1;
  } else {
    return 0;
  }
}

# determine if the current line $l has a Q_INTERFACES()
sub isQInterfaces {
  my($l) = @_;
  $l =~ s+//.*++; #strip trailing C++ comment
  if ($l =~ m+Q_INTERFACES[[:space:]]*\(.*\)+) {
    return 1;
  } else {
    return 0;
  }
}

# search the previous $n lines for a pattern $p
sub searchBack {
  my($p,$l,$n) = @_;
  my($i);
  for($i=1; $i<=$n; $i++) {
    if ($lines[$l-$i] =~ $p) {
      return 1;
    }
  }
  return 0;
}

sub Help {
  print "Check for public classes with private members or d-pointer problems\n";
  exit 0 if $help;
}

sub Version {
  print "$Prog, version $Version\n";
  exit 0 if $version;
}

sub Explain {
  print "In order to more easily maintain binary compatibility, a public class in an installed header should not contain private members -- use d-pointers instead. Application headers should not mix d-pointers and private members. Also ensure  that the d-pointer is \'const\' to avoid modifying it by mistake. Please follow the guidelines in the d-pointers section of <http://developer.kde.org/policies/librarypolicy.html>.\n";
  exit 0 if $explain;
}
