package App::Licensecheck;

use utf8;
use strictures 2;
use autodie;

use version;
use Path::Tiny;
use Fcntl qw/:seek/;
use Encode;
use String::Copyright;

use Moo;

use experimental "switch";
use namespace::clean;

=head1 NAME

App::Licensecheck - functions for a simple license checker for source files

=head1 VERSION

Version v3.0.14

=cut

our $VERSION = version->declare("v3.0.14");

=head1 SYNOPSIS

    use App::Licensecheck;

    my $app = App::Licensecheck->new;

    $app->lines(0); # Speedup parsing - our file is not huge

    printf "License: %s\nCopyright: %s\n", $app->parse( 'some-file' );

=head1 DESCRIPTION

L<App::Licensecheck> is the core of L<licensecheck> script
to check for licenses of source files.
See the script for casual usage.

=cut

my $default_check_regex = q!
	/[\w-]+$ # executable scripts or README like file
	|\.( # search for file suffix
		c(c|pp|xx)? # c and c++
		|h(h|pp|xx)? # header files for c and c++
		|S
		|css|less # HTML css and similar
		|f(77|90)?
		|go
		|groovy
		|lisp
		|scala
		|clj
		|p(l|m)?6?|t|xs|pod6? # perl5 or perl6
		|sh
		|php
		|py(|x)
		|rb
		|java
		|js
		|vala
		|el
		|sc(i|e)
		|cs
		|pas
		|inc
		|dtd|xsl
		|mod
		|m
		|md|markdown
		|tex
		|mli?
		|(c|l)?hs
	)$
!;

# From dpkg-source
my $default_ignore_regex = q!
	# Ignore general backup files
	~$|
	# Ignore emacs recovery files
	(?:^|/)\.#|
	# Ignore vi swap files
	(?:^|/)\..*\.swp$|
	# Ignore baz-style junk files or directories
	(?:^|/),,.*(?:$|/.*$)|
	# File-names that should be ignored (never directories)
	(?:^|/)(?:DEADJOE|\.cvsignore|\.arch-inventory|\.bzrignore|\.gitignore)$|
	# File or directory names that should be ignored
	(?:^|/)(?:CVS|RCS|\.pc|\.deps|\{arch\}|\.arch-ids|\.svn|\.hg|_darcs|\.git|
	\.shelf|_MTN|\.bzr(?:\.backup|tags)?)(?:$|/.*$)
!;

has check_regex => (
	is     => 'rw',
	lazy   => 1,
	coerce => sub {
		my $value = shift;
		return qr/$default_check_regex/x
			if $value eq 'common source files';
		return $value if ref $value eq 'Regexp';
		return qr/$value/;
	},
	default => sub {qr/$default_check_regex/x},
);

has ignore_regex => (
	is     => 'rw',
	lazy   => 1,
	coerce => sub {
		my $value = shift;
		return qr/$default_ignore_regex/x
			if $value eq 'some backup and VCS files';
		return $value if ref $value eq 'Regexp';
		return qr/$value/;
	},
	default => sub {qr/$default_ignore_regex/x},
);

has recursive => (
	is => 'rw',
);

has lines => (
	is      => 'rw',
	default => sub {60},
);

has tail => (
	is      => 'rw',
	default => sub {5000},    # roughly 60 lines of 80 chars
);

has encoding => (
	is     => 'rw',
	coerce => sub {
		find_encoding( $_[0] ) if ref( $_[0] ) ne 'OBJECT';
	},
);

has verbose => (
	is => 'rw',
);

has skipped => (
	is => 'rw',
);

has deb_fmt => (
	is => 'rw',
);

sub find
{
	my ( $self, @paths ) = @_;

	my @files       = ();
	my $paths_count = @paths;

	foreach (@paths) {
		my $path = path($_);

		if ( $path->is_dir ) {
			$path->visit(
				sub {
					# Silently skip empty files or ignored files
					return if -z $_ or $_ =~ $self->ignore_regex;
					if ( $_ =~ $self->check_regex ) {
						push @files, $_;
					}
					else {
						warn "skipped file $_\n" if $self->skipped;
					}
				},
				{ recurse => $self->recursive }
			);
		}
		elsif ( $path =~ $self->ignore_regex ) {

			# Silently skip ignored files
			next;
		}
		elsif ( $paths_count == 1 or $path =~ $self->check_regex ) {
			push @files, $path;
		}
		else {
			warn "skipped file $path\n" if $self->skipped;
		}
	}
	return @files;
}

sub parse
{
	my $self = shift;
	my $file = path(shift);

	if ( $self->lines == 0 ) {
		return ( $self->parse_file($file) );
	}
	else {
		return ( $self->parse_lines($file) );
	}
}

sub parse_file
{
	my $self = shift;
	my $file = path(shift);

	my $content;

	given ( $self->encoding ) {
		when (undef)  { $content = $file->slurp_raw }
		when ('utf8') { $content = $file->slurp_utf8 }
		default {
			$content
				= $file->slurp(
				{ binmode => sprintf ':encoding(%s)', $self->encoding->name }
				)
		}
	}
	print qq(----- $file content -----\n$content----- end content -----\n\n)
		if $self->verbose;

	my $cleaned_content = clean_comments($content);

	return (
		$self->parse_license( clean_cruft_and_spaces($cleaned_content) ),
		copyright( clean_cruft($cleaned_content) ),
	);
}

sub parse_lines
{
	my $self    = shift;
	my $file    = path(shift);
	my $content = '';

	my $fh;
	my $st = $file->stat;

	given ( $self->encoding ) {
		when (undef)  { $fh = $file->openr_raw }
		when ('utf8') { $fh = $file->openr_utf8 }
		default {
			$fh = $file->openr(
				sprintf ':encoding(%s)',
				$self->encoding->name
				)
		}
	}

	while ( my $line = $fh->getline ) {
		last if ( $fh->input_line_number > $self->lines );
		$content .= $line;
	}
	print qq(----- $file header -----\n$content----- end header -----\n\n)
		if $self->verbose;

	my $cleaned_content = clean_comments($content);

	my $license
		= $self->parse_license( clean_cruft_and_spaces($cleaned_content) );
	my $copyrights = copyright( clean_cruft($cleaned_content) );

	if ( not @{ $copyrights->blocks } and $license eq 'UNKNOWN' ) {
		my $position = $fh->tell;                 # See IO::Seekable
		my $jump     = $st->size - $self->tail;
		$jump = $position if $jump < $position;

		my $tail = '';
		if ( $self->tail and $jump < $st->size ) {
			$fh->seek( $jump, SEEK_SET );         # also IO::Seekable
			$tail .= join( '', $fh->getlines );
		}
		print qq(----- $file tail -----\n$tail----- end tail -----\n\n)
			if $self->verbose;

		my $cleaned_tail = clean_comments($tail);

		$copyrights = copyright( clean_cruft($cleaned_tail) );
		$license
			= $self->parse_license( clean_cruft_and_spaces($cleaned_tail) );
	}

	$fh->close;
	return ( $license, $copyrights );
}

sub clean_comments
{
	local $_ = shift or return q{};

	# Remove generic comments: look for 4 or more lines beginning with
	# regular comment pattern and trim it. Fall back to old algorithm
	# if no such pattern found.
	my @matches = m/^\s*((?:[^a-zA-Z0-9\s]{1,3}|\bREM\b))\s\w/mg;
	if ( @matches >= 4 ) {
		my $comment_re = qr/\s*[\Q$matches[0]\E]{1,3}\s*/;
		s/^$comment_re//mg;
	}

	# Remove other side of "boxed" comments
	s/\s*[*#]\s*$//gm;

	# Remove Fortran comments
	s/^[cC] //gm;

	# Remove C / C++ comments
	s#(\*/|/[/*])##g;

	return $_;
}

sub clean_cruft
{
	local $_ = shift or return q{};

	# TODO: decode latin1/UTF-8/HTML data instead
	s/\xcb\x97|\xe2\x80[\x90-\x95|\xe2\x81\x83|\xe2\x88\x92|\xef\x89\xa3|\xef\xbc\x8d]|[&](?:ndash|mdash|horbar|minus|[#](?:727|820[8-9]|821[0-3]|8259|8722|65123|65293|x727|z201[0-5]|x2043|x2212|xFE63|xFF0D))[;]/-/gm;
	s/\x58\xa9|\xc2\xa9|\xe2\x92\x9e|\xe2\x92\xb8|\xe2\x93\x92|\xf0\x9f\x84\x92|\xf0\x9f\x84\xab|\xf0\x9f\x85\x92|[&](?:copy|[#](?:169|9374|9400|9426|127250|127275|127314|x0A9|x249E|x24b8|x24D2|x0F112|x0F12B|x0F152))[;]/©/gm;

	# TODO: decode nroff files specifically instead
	s/\\//gm;    # de-cruft nroff files

	return $_;
}

sub clean_cruft_and_spaces
{
	local $_ = shift or return q{};

	tr/\t\r\n/ /;

	# this also removes quotes
	tr% A-Za-z.,@;0-9\(\)/-%%cd;
	tr/ //s;

	return $_;
}

sub parse_license
{
	my $self = shift;
	my ($licensetext) = @_;

	my $gplver    = "";
	my $extrainfo = "";
	my $license   = "";
	my @spdx_gplver;

  # @spdx_license contains identifiers from https://spdx.org/licenses/
  # it would be more efficient to store license info only in this
  # array and then convert it to legacy formulation, but there are
  # corner case (like extrainfo) that would not fit. So the old storage scheme
  # is kept with the new (spdx/dep-5) scheme to keep backward compat.
	my @spdx_license;
	my $spdx_extra;
	my $gen_spdx = sub {
		my @ret
			= @spdx_gplver ? ( map { "$_[0]-$_"; } @spdx_gplver ) : ( $_[0] );
		push @ret, $spdx_extra if $spdx_extra;
		return @ret;
	};

	#<<<  do not let perltidy touch this (keep long regex on one line)
	given ($licensetext) {
		when ( /version ([^ ]+)(?: of the License)?,? or(?: \(at your option\))? version (\d(?:[.-]\d+)*)/ ) {
			$gplver = " (v$1 or v$2)";
			@spdx_gplver = ( $1, $2 );
		}
		when ( /version ([^, ]+?)[.,]? (?:\(?only\)?.? )?(?:of the GNU (Affero )?(Lesser |Library )?General Public License )?(as )?published by the Free Software Foundation/i ) {
			$gplver      = " (v$1)";
			@spdx_gplver = ($1)
		}
		when ( /GNU (?:Affero )?(?:Lesser |Library )?General Public License (?:as )?published by the Free Software Foundation[;,] version ([^, ]+?)[.,]? /i ) {
			$gplver      = " (v$1)";
			@spdx_gplver = ($1);
		}
		when ( /GNU (?:Affero )?(?:Lesser |Library )?General Public License\s*(?:[(),GPL]+)\s*version (\d+(?:\.\d+)?)[ \.]/i ) {
			$gplver      = " (v$1)";
			@spdx_gplver = ($1);
		}
		when ( /either version ([^ ]+)(?: of the License)?, or (?:\(at your option\) )?any later version/ ) {
			$gplver      = " (v$1 or later)";
			@spdx_gplver = ( $1 . '+' );
		}
		when ( /GPL\sas\spublished\sby\sthe\sFree\sSoftware\sFoundation,\sversion\s([\d.]+)/i ) {
			$gplver      = " (v$1)";
			@spdx_gplver = ($1)
		}
	}
	given ($licensetext) {
		when ( /(?:675 Mass Ave|59 Temple Place|51 Franklin Steet|02139|02111-1307)/i ) {
			$extrainfo = " (with incorrect FSF address)$extrainfo";
		}
	}
	given ($licensetext) {
		when ( /permission (?:is (also granted|given))? to link (the code of )?this program with (any edition of )?(Qt|the Qt library)/i ) {
			$extrainfo  = " (with Qt exception)$extrainfo";
			$spdx_extra = 'with Qt exception';
		}
	}

	# exclude blurb found in boost license text
	given ($licensetext) {
		when ( /unless such copies or derivative works are solely in the form of machine-executable object code generated by a source language processor/ ) {
			break;
		}
		when ( /(All changes made in this file will be lost|DO NOT ((?:HAND )?EDIT|delete this file|modify)|edit the original|Generated (automatically|by|from|data|with)|generated.*file)/i ) {
			$license = "GENERATED FILE";
			push @spdx_license, 'generated-file';
		}
	}
	given ($licensetext) {
		when ( /(are made available|(is free software.? )?you can redistribute (it|them) and(?:\/|\s+)or modify (it|them)|is licensed) under the terms of (version [^ ]+ of )?the (GNU (Library |Lesser )General Public License|LGPL)/i ) {
			$license = "LGPL$gplver$extrainfo $license";
			push @spdx_license, $gen_spdx->('LGPL');
		}
		# For Perl modules handled by Dist::Zilla
		when ( /this is free software,? licensed under:? (?:the )?(?:GNU (?:Library |Lesser )General Public License|LGPL),? version ([\d\.]+)/i ) {
			$license = "LGPL (v$1) $license";
			push @spdx_license, "LGPL-$1";
		}
	}
	given ($licensetext) {
		when ( /is free software.? you can redistribute (it|them) and(?:\/|\s+)or modify (it|them) under the terms of the (GNU Affero General Public License|AGPL)/i ) {
			$license = "AGPL$gplver$extrainfo $license";
			push @spdx_license, $gen_spdx->('AGPL');
		}
	}
	given ($licensetext) {
		when ( /(is free software.? )?you (can|may) redistribute (it|them) and(?:\/|\s+)or modify (it|them) under the terms of (?:version [^ ]+ (?:\(?only\)? )?of )?the GNU General Public License/i ) {
			$license = "GPL$gplver$extrainfo $license";
			push @spdx_license, $gen_spdx->('GPL');
		}
	}
	if ( $licensetext =~ /is distributed under the terms of the GNU General Public License,/ and length $gplver ) {
		$license = "GPL$gplver$extrainfo $license";
		push @spdx_license, $gen_spdx->('GPL');
	}
	given ($licensetext) {
		when ( /(?:is|may be)\s(?:(?:distributed|used).*?terms|being\s+released).*?\b(L?GPL)\b/ ) {
			my $v = $gplver || ' (unversioned/unknown version)';
			$license = "$1$v $license";
			push @spdx_license, $gen_spdx->($1);
		}
	}
	given ($licensetext) {
		when ( /the rights to distribute and use this software as governed by the terms of the Lisp Lesser General Public License|\bLLGPL\b/ ) {
			$license = "LLGPL $license";
			push @spdx_license, 'LLGPL';
		}
	}
	given ($licensetext) {
		when ( /This file is part of the .*Qt GUI Toolkit. This file may be distributed under the terms of the Q Public License as defined/ ) {
			$license = "QPL (part of Qt) $license";
		}
		when ( /may (be distributed|redistribute it) under the terms of the Q Public License/ ) {
			$license = "QPL $license";
			push @spdx_license, 'QPL';
		}
	}
	given ($licensetext) {
		when ( /opensource\.org\/licenses\/mit-license\.php/ ) {
			$license = "MIT/X11 (BSD like) $license";
			push @spdx_license, 'Expat';
		}
		when ( /Permission is hereby granted, free of charge, to any person obtaining a copy of this software and(\/or)? associated documentation files \(the (Software|Materials)\), to deal in the (Software|Materials)/ ) {
			$license = "MIT/X11 (BSD like) $license";
			push @spdx_license, 'Expat';
		}
		when ( /Permission is hereby granted, without written agreement and without license or royalty fees, to use, copy, modify, and distribute this software and its documentation for any purpose/ ) {
			$license = "MIT/X11 (BSD like) $license";
			push @spdx_license, 'Expat';
		}
	}
	given ($licensetext) {
		when ( /Permission to use, copy, modify, and(\/or)? distribute this software for any purpose with or without fee is hereby granted, provided.*copyright notice.*permission notice.*all copies/ ) {
		$license = "ISC $license";
			push @spdx_license, 'ISC';
		}
	}
	if ( $licensetext =~ /THIS SOFTWARE IS PROVIDED .*AS IS AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY/ ) {
		given ($licensetext) {
			when ( /All advertising materials mentioning features or use of this software must display the following acknowledge?ment.*This product includes software developed by/i ) {
				$license = "BSD (4 clause) $license";
				push @spdx_license, 'BSD-4-Clause';
			}
			when ( /(The name(?:\(s\))? .*? may not|Neither the (names? .*?|authors?) nor the names of( (its|their|other|any))? contributors may) be used to endorse or promote products derived from this software/i ) {
				$license = "BSD (3 clause) $license";
				push @spdx_license, 'BSD-3-Clause';
			}
			when ( /Redistributions in binary form must reproduce the above copyright notice/i ) {
				$license = "BSD (2 clause) $license";
				push @spdx_license, 'BSD-2-Clause';
			}
			default {
				$license = "BSD $license";
				push @spdx_license, 'BSD';
			}
		}
	}
	elsif ( $licensetext =~ /licen[sc]ebsd(?:-(\d)-clause)?/i ) {
		if ($1) {
			$license = "BSD ($1 clause) $license";
			push @spdx_license, "BSD-$1-Clause";
		}
		else {
			$license = "BSD $license";
			push @spdx_license, "BSD";
		}
	}
	given ($licensetext) {
		when ( /Mozilla Public License,? (?:(?:Version|v\.)\s+)?(\d+(?:\.\d+)?)/ ) {
			$license = "MPL (v$1) $license";
			push @spdx_license, "MPL-$1";
		}
		when ( /Mozilla Public License,? \((?:Version|v\.) (\d+(?:\.\d+)?)\)/ ) {
			$license = "MPL (v$1) $license";
			push @spdx_license, "MPL-$1";
		}
	}

# match when either:
# - the text *begins* with "The Artistic license v2.0" which is (hopefully) the actual artistic license v2.0 text.
# - a license grant is found. i.e something like "this is free software, licensed under the artistic license v2.0"
	given ($licensetext) {
		when ( /(?:^\s*|(?:This is free software, licensed|Released|be used|use and modify this (?:module|software)) under (?:the terms of )?)[Tt]he Artistic License ([v\d.]*\d)/ ) {
			$license = "Artistic (v$1) $license";
			push @spdx_license, "Artistic-$1";
		}
	}
	given ($licensetext) {
		when ( /is free software under the Artistic [Ll]icense/ ) {
			$license = "Artistic $license";
			push @spdx_license, 'Artistic';
		}
	}
	given ($licensetext) {
		when ( /This program is free software; you can redistribute it and\/or modify it under the same terms as Perl itself/ ) {
			$license = "Perl $license";
			push @spdx_license, 'Artistic', 'GPL';
		}
	}
	given ($licensetext) {
		when ( /under the Apache License, Version ([^ ]+)/ ) {
			$license = "Apache (v$1) $license";
			push @spdx_license, "Apache-$1";
		}
	}
	given ($licensetext) {
		when ( /(THE BEER-WARE LICENSE)/i ) {
			$license = "Beerware $license";
			push @spdx_license, 'Beerware';
		}
	}
	given ($licensetext) {
		when ( /distributed under the terms of the FreeType project/i )	{
			$license = "FreeType $license";
			push @spdx_license, 'FTL';
		}
	}
	given ($licensetext) {
		when ( /This source file is subject to version ([^ ]+) of the PHP license/ ) {
			$license = "PHP (v$1) $license";
			push @spdx_license, "PHP-$1";
		}
	}
	given ($licensetext) {
		when ( /under the terms of the CeCILL-([^ ]+) / ) {
			$license = "CeCILL-$1 $license";
			push @spdx_license, "CECILL-$1";
		}
		when ( /under the terms of the CeCILL / ) {
			$license = "CeCILL $license";
			push @spdx_license, 'CECILL';
		}
	}
	given ($licensetext) {
		when ( /under the SGI Free Software License B/ ) {
			$license = "SGI Free Software License B $license";
			push @spdx_license, 'SGI-B';
		}
	}
	given ($licensetext) {
		when ( /is in the public domain/i ) {
			$license = "Public domain $license";
			push @spdx_license, 'public-domain';    # not listed by SPDX
		}
	}
	given ($licensetext) {
		when ( /terms of the Common Development and Distribution License(, Version ([^(]+))? \(the License\)/ ) {
			$license = "CDDL " . ( $1 ? "(v$2) " : '' ) . $license;
			push @spdx_license, 'CDDL' . ( $1 ? "-$2" : '' );
		}
	}
	given ($licensetext) {
		when ( /Microsoft Permissive License \(Ms-PL\)/ ) {
			$license = "Ms-PL $license";
			push @spdx_license, 'MS-PL';
		}
	}
	given ($licensetext) {
		when ( /Licensed under the Academic Free License version ([\d.]+)/ ) {
			$license = $1 ? "AFL-$1" : "AFL";
			push @spdx_license, 'AFL' . ( $1 ? "-$1" : '' );
		}
	}
	given ($licensetext) {
		when ( /This program and the accompanying materials are made available under the terms of the Eclipse Public License v?([\d.]+)/ ) {
			$license = $1 ? "EPL-$1" : "EPL";
			push @spdx_license, 'EPL' . ( $1 ? "-$1" : '' );
		}
	}

	# quotes were removed by clean_comments function
	given ($licensetext) {
		when ( /Permission is hereby granted, free of charge, to any person or organization obtaining a copy of the software and accompanying documentation covered by this license \(the Software\)/ ) {
			$license = "BSL " . ( $1 ? "(v$2) " : '' ) . $license;
			push @spdx_license, 'BSL' . ( $1 ? "-$2" : '' );
		}
		when ( /Boost Software License([ ,-]+Version ([^ ]+)?(\.))/i ) {
			$license = "BSL " . ( $1 ? "(v$2) " : '' ) . $license;
			push @spdx_license, 'BSL' . ( $1 ? "-$2" : '' );
		}
	}
	given ($licensetext) {
		when ( /PYTHON SOFTWARE FOUNDATION LICENSE (VERSION ([^ ]+))/i ) {
			$license = "PSF " . ( $1 ? "(v$2) " : '' ) . $license;
			push @spdx_license, 'Python' . ( $1 ? "-$2" : '' );
		}
	}
	given ($licensetext) {
		when ( /The origin of this software must not be misrepresented.*Altered source versions must be plainly marked as such.*This notice may not be removed or altered from any source distribution/ ) {
			$license = "zlib/libpng $license";
			push @spdx_license, 'Zlib';
		}
		when ( /see copyright notice in zlib\.h/ ) {
			$license = "zlib/libpng $license";
			push @spdx_license, 'Zlib';
		}
		when ( /This code is released under the libpng license/ ) {
			$license = "libpng $license";
			push @spdx_license, 'Libpng';
		}
	}
	given ($licensetext) {
		when ( /Do What The Fuck You Want To Public License, Version ([^, ]+)/i ) {
			$license = "WTFPL (v$1) $license";
			push @spdx_license, "WTFPL-$1";
		}
	}
	given ($licensetext) {
		when ( /Do what The Fuck You Want To Public License/i ) {
			$license = "WTFPL $license";
			push @spdx_license, "WTFPL";
		}
	}
	given ($licensetext) {
		when ( /(License WTFPL|Under (the|a) WTFPL)/i ) {
			$license = "WTFPL $license";
			push @spdx_license, "WTFPL";
		}
	}
	#>>>
	$license = "UNKNOWN" if ( !length($license) );
	push @spdx_license, "UNKNOWN" unless @spdx_license;

	# Remove trailing spaces.
	$license =~ s/\s+$//;
	return $self->deb_fmt ? join( ' or ', @spdx_license ) : $license;
}

=encoding UTF-8

=head1 AUTHOR

Jonas Smedegaard C<< <dr@jones.dk> >>

=head1 COPYRIGHT AND LICENSE

This program is based on the script "licensecheck" from the KDE SDK,
originally introduced by Stefan Westerfeld C<< <stefan@space.twc.de> >>.

  Copyright © 2007, 2008 Adam D. Barratt

  Copyright © 2012 Francesco Poli

  Copyright © 2016 Jonas Smedegaard

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 3, 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, see <https://www.gnu.org/licenses/>.

=cut

1;
