File: //usr/share/duck/lib/checks/copyright_file.pm
# duck - check for debian/copyright files
# Copyright (C) 2016 Simon Kainz <skainz@debian.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
# he 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.
#
# On Debian GNU/Linux systems, the complete text of the GNU General
# Public License can be found in `/usr/share/common-licenses/GPL-2'.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, you can find it on the World Wide
# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.
package DUCK::copyright_file;
use strict;
use warnings;
use autodie;
use Data::Dumper;
use Parse::DebControl qw(parse_file);
use Regexp::Common qw /URI Email::Address/;
use Mail::Address;
use DUCK;
my %options=(
"c:" => " -c file\tspecify path to copyright file",
"C" => " -C\t\tskip processing of copyright file");
sub opts()
{
return keys %options;
}
sub desc()
{
my $r;
foreach (sort keys %options)
{
$r.=$options{$_}."\n";
}
return $r;
}
sub run()
{
my ($sname,$params,$entries_ref)=@_;
my %opt=%$params;
if ($opt{c})
{
if (! -r $opt{c})
{
print STDERR "Unable to open user-specified copyright file: ".$opt{c}."\n";
exit(2);
}
}
if (!$opt{c})
{
if (! -r "debian/copyright")
{
return;
}
}
if (!$opt{C}) {
#processing copyright file
my $copy_fn=($opt{c} or "debian/copyright");
my @copy_raw;
if (open my $fh,"<",$copy_fn)
{
@copy_raw=<$fh>;
close($fh);
chomp @copy_raw;
}
my $linenum=0;
foreach my $copyright_line (@copy_raw)
{
$linenum++;
$copyright_line =~ s/^[*\s#\-|\/\.]*//;
$copyright_line =~ s/[\s#\-|\)*]*$//;
next unless length($copyright_line);
my $cc=DUCK->extract_url($copyright_line);
if ($cc)
{
my $copyright_line_mangled =$cc;
$copyright_line_mangled =~ s/,$//; #Strip trailing commas.
my $check_method="URL";
my $guess_info="";
my $certainty="possible";
my $verbose="";
my $svn_string=$copyright_line;
my $rep= quotemeta $copyright_line_mangled;
$svn_string =~ s/$rep/x/g;
if ($svn_string =~ /\s*svn\s*/)
{
$check_method="SVN";
$guess_info="(SVN method guessed) ";
$certainty="wild-guess";
}
push (@$entries_ref, [$guess_info.$copy_fn.":".$linenum,$check_method,$copyright_line_mangled,$copyright_line,
{filename => $copy_fn,
linenumber => $linenum,
checkmethod =>$check_method,
orig_line => $copyright_line,
url=>$copyright_line_mangled,
verbose =>$verbose,
certainty=>$certainty}
]);
}
else
{
if ($copyright_line =~ /[^\s.]@[^\s.]/)
{
my $copyright_line_mangled =$copyright_line;
$copyright_line_mangled =~ s/[\*\#|<>\(\)\/]/ /g;
$copyright_line_mangled =~ s/\s\s*/ /g;
next unless length($copyright_line_mangled);
my @emails = ($copyright_line_mangled =~ /$RE{Email}{Address}{-keep}/go );
if (@emails && (!($copyright_line =~ /Message-id:/i )))
{
my @parsed = map $_->address,Mail::Address->parse(@emails);
foreach (@parsed)
{
push (@$entries_ref, [$copy_fn.":".$linenum,"Email",$_,$copyright_line_mangled,
{filename => $copy_fn,
linenumber => $linenum,
checkmethod =>"Email",
orig_line => $copyright_line,
url=>$_,
# verbose =>'$verbose',
certainty=>"possible"}
]);
}
}
}
}
}
}
return;
}
1;