#!/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) 2006-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. #
#                                                                             #
###############################################################################

# Tests KDE source for C++ constructors that should be declared explicit.
# Each constructor that may take only one argument should be marked explicit
# unless the whole point of the constructor is to allow implicit casting.
#
# so the following constructors should all be explicit:
#   ctor(QString str);
#   ctor(QString str=0);
#   ctor(QString str, int i=0);
#   ctor(QString str=0, int i=0);

# 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;

my($Prog) = "explicit";
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$/) && $f !~ m+/tests/+) {
  open(F, "$f") || die "Couldn't open $f";
} else {
  print "okay\n" if (!$quiet);
  exit 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($linecnt) = 0;
my($lstr) = "";
my($cname) = "";
my($ctor) = "";
my($line);
while ($linecnt < $#lines) {
  $linecnt++;
  $line = $lines[$linecnt];

  $cname = &Cname($line,$lines[$linecnt-1]);
  if ($cname ne "") {
    $ctor = "";

    while ($linecnt < $#lines) {
      # search for a constructor
      $linecnt++;
      $line = $lines[$linecnt];
      if (&Cname($line,$lines[$linecnt-1])) { $linecnt--; last; }
      if ($line =~ m/[[:space:]]$cname[[:space:]]*\(/) {
	# we found a constructor
	$ctor = $line;
	$linecnt++;

	if (&Ctor($ctor) &&
	    !&searchBack("private:", $linecnt-1, 5) &&
	    !&searchBack("protected:", $linecnt-1, 5)) {
	  # found a constructor that should be declared explicit
	  $cnt++;
	  if ($cnt == 1) {
	    $lstr = "line\#" . $linecnt;
	  } else {
	    $lstr = $lstr . "," . $linecnt;
	  }
	  print "=> $line\n" if ($verbose);
	}
      }
    }
  }
}
close(F);

if (!$cnt) {
  print "okay\n" if (!$quiet);
  exit 0;
} else {
  print "$lstr ($cnt)\n" if (!$quiet);
  exit $cnt;
}

# 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/);
  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+$//;
    }
  }
  return $cname;
}

# determine if the current line $l has a constructor
sub Ctor {
  my($l) = @_;
  my($args,$a1,$a2);

  #did we find a constructor?
  if ($l) {
    return 0 if ($l =~ m/explicit/);     # already explicit
    return 0 if ($l =~ m/implicit/);     # if implicit in a comment on the line
    return 0 if ($l =~ m+//.*[Kk]razy:exclude=.*$Prog+);
    return 0 if ($l =~ m/$cname[[:space:]]*\([[:space:]]*\)/);  # no args
    return 0 if ($l =~ /\([[:space:]]*const[[:space:]]$cname[[:space:]]*&[[:space:]]*[[:print:]]*[[:space:]]*\)/); # copy constructor
    return 0 if ($l =~ m/[[:space:]]*inline[[:space:]]$cname/);
    return 0 if ($l =~ m/[[:space:]]*return[[:space:]]$cname/);
    return 0 if ($l =~ m/[[:space:]]*return[[:space:]]new[[:space:]]$cname/);
    return 0 if ($l =~ m/\([[:space:]]*void[[:space:]]*\)/);  #skip ctor(void)
    $l =~ s/{.*$//; # remove brace to end-of-line
    if ($l =~ m/,/) {
      # a constructor with more than 1 arg
      $args = $l;
      $args =~ s/^[[:space:]]*$cname[[:space:]]*\(//;
      ($a1,$a2) = split(",",$args);
      return 0 if ($a2 && $a2 !~ m/=/);
    } else {
      # at most 1 arg
      return 0;
    }
  } else {
    # not a constructor
    return 0;
  }
  return 1;
}

# 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 C++ ctors that should be declared \'explicit\'\n";
  exit 0 if $help;
}

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

sub Explain {
  print "Make all C++ class constructors that can be used with only one required argument \'explicit\' to minimize wrong use of the class. Do this to avoid mistaken implicit constructor ambiguities. Copy constructors should not be explicit.\n";
  exit 0 if $explain;
}
