debian/clscan/clscan

   1 #!/usr/bin/perl -w
   2 # Copyright 2009 Ian Beckwith <ianb@erislabs.net>
   3 # License: GPL v2 or later.
   4
   5 use strict;
   6 use vars qw($me);
   7 $me=($0=~/(?:.*\/)?(.*)/)[0];
   8
   9 use Getopt::Long;
  10 use YAML::Any;
  11 use Digest::SHA qw(sha256_hex);
  12 use File::Find;
  13 use File::Copy;
  14
  15 our $CLSCANDIR="debian/clscan";
  16 our $FILESCACHE="$CLSCANDIR/files.yaml";
  17 our $NEWFILES="$CLSCANDIR/new.txt";
  18 our $COPYRIGHTSTUB="$CLSCANDIR/copyright.in";
  19
  20 my $gpl_boilerplate=<<"EOL";
  21 This program is free software: you can redistribute it and/or modify
  22 it under the terms of the GNU General Public License as published by
  23 the Free Software Foundation; either version 3 of the License, or
  24 (at your option) any later version.
  25
  26 This program is distributed in the hope that it will be useful,
  27 but WITHOUT ANY WARRANTY; without even the implied warranty of
  28 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  29 GNU General Public License for more details.
  30
  31 You should have received a copy of the GNU General Public License
  32 along with this program.  If not, see <http://www.gnu.org/licenses/>.
  33 EOL
  34
  35 my $lgpl_boilerplate=<<"EOL";
  36 This program is free software; you can redistribute it and/or modify it
  37 under the terms of the GNU Library General Public License as published
  38 by the Free Software Foundation; either version 2, or (at your option)
  39 any later version.
  40
  41 This program is distributed in the hope that it will be useful,
  42 but WITHOUT ANY WARRANTY; without even the implied warranty of
  43 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  44 Library General Public License for more details.
  45
  46 You should have received a copy of the GNU Library General Public
  47 License along with this program; if not, write to the Free Software
  48 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301,
  49 USA.
  50 EOL
  51
  52 # license overrides as specified in modules/*
  53 our $module_licenses = {
  54     "public domain" => {
  55         license => "PD",
  56         license_text => "",
  57     },
  58     "unlimited" => {
  59         license => "other",
  60         license_text => "This file is free software; the Free Software Foundation\n" .
  61                         "gives unlimited permission to copy and/or distribute it,\n" .
  62                         "with or without modifications, as long as this notice is preserved.\n",
  63     },
  64     "LGPL" => {
  65         license => "LGPL",
  66         license_text => $lgpl_boilerplate,
  67     },
  68     "LGPLv2+" => {
  69         license => "LGPL-2+",
  70         license_text => $lgpl_boilerplate,
  71     },
  72     "unmodifiable license text" => {
  73         license => "other",
  74         license_text => "Everyone is permitted to copy and distribute verbatim copies\n" .
  75                         "of this license document, but changing it is not allowed.\n",
  76     },
  77     "GPLed build tool" => {
  78         license => "GPL",
  79         license_text => $gpl_boilerplate,
  80     },
  81     "GPL" => {
  82         license => "GPL",
  83         license_text => $gpl_boilerplate,
  84     },
  85 };
  86
  87 our @filenames=();
  88 our %overrides=();
  89 our $files={};
  90 our $new={};
  91 our @deleted_files=();
  92
  93 # actions
  94 my $scan=0;
  95 my $merge=0;
  96 my $writecopyright=0;
  97
  98 usage() unless(@ARGV);
  99 usage() unless GetOptions("scan|s" => \$scan,
 100                           "merge|m" => \$merge,
 101                           "write|w" => \$writecopyright,
 102                           "help|h" => sub { usage(); });
 103
 104 load_cache();
 105 scan() if($scan);
 106 merge() if($merge);
 107 write_copyright() if ($merge || $writecopyright);
 108
 109
 110
 111 sub scan
 112 {
 113     get_filenames();
 114     for my $file (@filenames)
 115     {
 116         scan_file($file);
 117     }
 118     find_deleted();
 119     write_new();
 120 }
 121
 122 sub merge
 123 {
 124     merge_new();
 125     load_overrides();
 126     save_cache();
 127 }
 128
 129 sub write_copyright
 130 {
 131     unless(keys(%$files))
 132     {
 133         die("$me: no files known, run $0 --scan\n");
 134     }
 135     unless(copy($COPYRIGHTSTUB, "debian/copyright"))
 136     {
 137         die("$me: cannot copy $COPYRIGHTSTUB to debian/copyright: $!\n");
 138     }
 139     unless(open(COPYRIGHT, ">>debian/copyright"))
 140     {
 141         die("$me: cannot append to debian/copyright: $!\n");
 142     }
 143
 144     # group files by license/license_text/copyright
 145     my $licenses={};
 146     for my $file (sort keys(%$files))
 147     {
 148         my $license=$files->{$file}->{license_override} || $files->{$file}->{license};
 149         my $copyright=$files->{$file}->{copyright};
 150         my $license_text=$files->{$file}->{license_text_override} ||
 151             $files->{$file}->{license_text};
 152         push(@{$licenses->{$license}->{$license_text}->{$copyright}}, $file);
 153     }
 154     my %refs=();
 155     my $refnum="00";
 156     for my $license (sort keys(%$licenses))
 157     {
 158         for my $license_text (sort keys(%{$licenses->{$license}}))
 159         {
 160             my $licensestr=$license;
 161             if(length($license_text))
 162             {
 163                 $refnum++;
 164                 # license_text + empty license = License: other
 165                 if(!length($license))
 166                 {
 167                     $licensestr = "other";
 168                 }
 169                 $licensestr .= " [REF$refnum]";
 170                 $refs{$licensestr}=$license_text;
 171             }
 172             for my $copyright (sort keys(%{$licenses->{$license}->{$license_text}}))
 173             {
 174                 next if(!length($license) && !length($copyright) && !length($license_text));
 175                 my @filelist=sort @{$licenses->{$license}->{$license_text}->{$copyright}};
 176                 print COPYRIGHT "Files: ", join(', ', @filelist), "\n";
 177                 print COPYRIGHT "Copyright: $copyright\n" if length($copyright);
 178                 print COPYRIGHT "License: $licensestr\n" if length($licensestr);
 179                 print COPYRIGHT "\n";
 180             }
 181         }
 182     }
 183     for my $ref (sort byref keys(%refs))
 184     {
 185         print COPYRIGHT "License: $ref\n";
 186         my @text=split(/\n/, $refs{$ref});
 187         print COPYRIGHT map { "    " . $_ . "\n" } @text;
 188         print COPYRIGHT "\n";
 189     }
 190     print COPYRIGHT license_trailer(sort keys(%$licenses));
 191     close(COPYRIGHT);
 192 }
 193
 194 sub byref
 195 {
 196     my $aref=($a=~/\[REF(\d+)\]/)[0];
 197     my $bref=($b=~/\[REF(\d+)\]/)[0];
 198     if($aref && $bref)
 199     {
 200         return($aref <=> $bref);
 201     }
 202     return($a cmp $b);
 203 }
 204
 205 sub license_trailer
 206 {
 207     my @licenses_used=@_;
 208     my $license_data = {
 209         "Apache-2.0" => "Apache License Version 2.0",
 210         "Artistic" => "Artistic License",
 211         "GFDL-1.2" => "GNU Free Documentation License Version 1.2",
 212         "GFDL-1.3" => "GNU Free Documentation License Version 1.3",
 213         "GFDL" => "GNU Free Documentation License",
 214         "GPL-2" => "GNU General Public License Version 2",
 215         "GPL-3" => "GNU General Public License Version 3",
 216         "GPL" => "GNU General Public License",
 217         "LGPL-2" => "GNU Library General Public License Version 2",
 218         "LGPL-2.1" => "GNU Lesser General Public License Version 2.1",
 219         "LGPL-3" => "GNU Lesser General Public License Version 3",
 220         "LGPL" => "GNU Lesser General Public License",
 221     };
 222
 223     my %types_found=();
 224     for my $type (reverse sort keys(%$license_data))
 225     {
 226         for my $license (@licenses_used)
 227         {
 228             if($license =~ /$type(\+|\s|$)/i)
 229             {
 230                 $types_found{$type}=1;
 231             }
 232         }
 233     }
 234     my $text="\n";
 235     # if just one, use standard style
 236     if(keys(%types_found) == 1)
 237     {
 238         my ($file, $name)=each(%types_found);
 239         $text .= "The complete text of the $name can be\n";
 240         $text .= "found in /usr/share/common-licenses/$file\n";
 241     }
 242     else
 243     {
 244         # more than one, use table.
 245         $text .= "The complete text of standard licenses referenced above\n";
 246         $text .= "can be found in /usr/share/common-licenses/ as follows:\n\n";
 247         $text .= sprintf("%-60s %s\n", "LICENSE", "FILE");
 248         for my $type (sort keys(%types_found))
 249         {
 250             $text .= sprintf("%-60s %s\n", $license_data->{$type}, $type);
 251         }
 252     }
 253     return $text;
 254 }
 255
 256
 257 sub guess_license
 258 {
 259     my $file=shift;
 260     my $license='';
 261     my $copyright='';
 262     if(open(LICENSECHECK, "licensecheck --copyright \"$file\"|"))
 263     {
 264         while(<LICENSECHECK>)
 265         {
 266             chomp;
 267             if(/^\s+\[(.*)\]$/)
 268             {
 269                 $copyright=$1;
 270             }
 271             elsif(/.*:\s+(.*)/)
 272             {
 273                 $license=$1;
 274             }
 275         }
 276         close(LICENSECHECK);
 277         $copyright =~ s/^\s*Copyright\s*:\s*//;
 278         $license =~ s/.*UNKNOWN.*//;
 279         $license =~ s/(L?GPL) \(v([\.\d]+) or later\)/$1-$2+/i;
 280         $license =~ s/(L?GPL) \(v([\.\d]+)\)/$1-$2/i;
 281         $license =~ s/G?FDL \(v([\.\d]+) or later\)/GFDL-$1+/i;
 282         $license =~ s/G?FDL \(v([\.\d]+)\)/GFDL-$1/i;
 283         $license =~ s/Apache \(v([\.\d]+) or later\)/Apache-$1+/i;
 284         $license =~ s/Apache \(v([\.\d]+)\)/Apache-$1+/i;
 285     }
 286     return($license, $copyright);
 287 }
 288
 289 sub scan_file
 290 {
 291     my $filename=shift;
 292     unless(open(FILE, $filename))
 293     {
 294         warn("$me: $filename: cannot open: $!\n");
 295         return;
 296     }
 297     my $header='';
 298     for(my $i=0; $i < 15; $i++)
 299     {
 300         my $line=<FILE>;
 301         last unless($line);
 302         $header .= $line;
 303     }
 304     close(FILE);
 305     my $hash=sha256_hex($header);
 306     if( (!exists($files->{$filename})) ||
 307         ($files->{$filename}->{hash} ne $hash))
 308     {
 309         filechanged($filename, $hash, $header);
 310     }
 311 }
 312
 313
 314 sub filechanged
 315 {
 316     my($filename, $hash, $header)=@_;
 317     my($license_guess, $copyright_guess)=guess_license($filename);
 318     $new->{$filename}={
 319         hash=>$hash,
 320         license=>$license_guess,
 321         copyright=>$copyright_guess,
 322         header=>$header,
 323     };
 324     if(exists($files->{$filename}))
 325     {
 326         if(exists($files->{$filename}->{copyright}))
 327         {
 328             $new->{$filename}->{copyright}=$files->{$filename}->{copyright};
 329             $new->{$filename}->{copyright_guess}=$copyright_guess;
 330         }
 331         if(exists($files->{$filename}->{license}))
 332         {
 333             $new->{$filename}->{license}=$files->{$filename}->{license};
 334             $new->{$filename}->{license_guess}=$license_guess;
 335         }
 336         if(exists($files->{$filename}->{license_text}))
 337         {
 338             $new->{$filename}->{license_text}=$files->{$filename}->{license_text};
 339         }
 340     }
 341 }
 342
 343 sub get_filenames
 344 {
 345     find(\&wanted_files, ".");
 346 }
 347
 348 sub wanted_files
 349 {
 350     if(/^\.git/ || /^\.cvs/ || /^debian/ || /^modules$/)
 351     {
 352         $File::Find::prune=1;
 353     }
 354     elsif(-f)
 355     {
 356         push(@filenames, $File::Find::name);
 357     }
 358 }
 359
 360 sub wanted_modules
 361 {
 362     if(/^\.[^\/]/ || /^README$/ || /^COPYING$/)
 363     {
 364         $File::Find::prune=1;
 365         return;
 366     }
 367     elsif(-f)
 368     {
 369         unless(open(MOD, $File::Find::name))
 370         {
 371             warn("$me: cannot open $File::Find::name: $!\n");
 372             return;
 373         }
 374         my $infiles=0;
 375         my $inlicense=0;
 376         my @files=();
 377         while(<MOD>)
 378         {
 379             chomp;
 380             if(/^$/)
 381             {
 382                 $infiles = $inlicense = 0;
 383             }
 384             if($inlicense)
 385             {
 386                 push(@{$overrides{$_}},@files);
 387                 $inlicense=0;
 388             }
 389             elsif($infiles)
 390             {
 391                 push(@files, $_);
 392             }
 393             elsif(/^License:/)
 394             {
 395                 $inlicense=1;
 396             }
 397             elsif(/^Files:/)
 398             {
 399                 $infiles=1;
 400             }
 401         }
 402         close(MOD);
 403     }
 404 }
 405
 406 sub load_overrides
 407 {
 408     find({ wanted => \&wanted_modules, no_chdir => 1}, "modules/");
 409     for my $license (keys(%overrides))
 410     {
 411         if(!exists($module_licenses->{$license}))
 412         {
 413             die("$me: license override \"$license\" not found in \$module_licenses\n");
 414         }
 415         my @overridden_files=map { "./" . $_; } @{$overrides{$license}};
 416         for my $file (@overridden_files)
 417         {
 418             my $override=$module_licenses->{$license};
 419             if(length($override->{license}))
 420             {
 421                 $files->{$file}->{license_override}=$override->{license};
 422             }
 423             if(length($override->{license_text}))
 424             {
 425                 $files->{$file}->{license_text_override}=$override->{license_text};
 426             }
 427         }
 428     }
 429 }
 430
 431
 432 sub load_cache
 433 {
 434     unless(open(YAML,$FILESCACHE))
 435     {
 436         warn("$me: cannot load cache $FILESCACHE: $!\n");
 437         return;
 438     }
 439     my $yaml;
 440     {
 441         local $/=undef;
 442         $yaml=<YAML>;
 443     }
 444     close(YAML);
 445     $files=Load($yaml);
 446 }
 447
 448 sub save_cache
 449 {
 450     backup($FILESCACHE);
 451     unless(open(YAML,">$FILESCACHE"))
 452     {
 453         warn("$me: cannot save cache $FILESCACHE: $!\n");
 454         return;
 455     }
 456     print YAML Dump($files);
 457     close(YAML);
 458 }
 459
 460 sub write_new
 461 {
 462     backup($NEWFILES);
 463     unless(keys(%$new))
 464     {
 465         warn("$me: no new/changed files found\n");
 466     }
 467     unless(open(NEW,">$NEWFILES"))
 468     {
 469         die("$me: cannot write to $NEWFILES: $!\n");
 470     }
 471     for my $file (sort keys %$new)
 472     {
 473         print NEW "File: $file\n";
 474         print NEW "Hash: ", $new->{$file}->{hash}, "\n";
 475         print NEW "Copyright: ", $new->{$file}->{copyright}, "\n";
 476         if($new->{$file}->{copyright_guess})
 477         {
 478             print NEW "#Copyright_guess: ", $new->{$file}->{copyright_guess}, "\n";
 479         }
 480         print NEW "License: ", $new->{$file}->{license}, "\n";
 481         if($new->{$file}->{license_guess})
 482         {
 483             print NEW "#License_guess: ", $new->{$file}->{license_guess}, "\n";
 484         }
 485         if($new->{$file}->{license_text})
 486         {
 487             my @text=split(/\n/, $new->{$file}->{license_text});
 488             print NEW "\t" . join("\n\t", @text), "\n";
 489         }
 490         print NEW "#Header: \n";
 491         my @headerlines=split(/\n/, $new->{$file}->{header});
 492         @headerlines=map { "#" . $_ } grep { defined $_; } @headerlines;
 493         print NEW join("\n", @headerlines);
 494         print NEW "\n\n";
 495     }
 496     if(@deleted_files)
 497     {
 498         print NEW map { "Deleted: $_\n"; } @deleted_files;
 499     }
 500     close NEW;
 501 }
 502
 503 sub merge_new
 504 {
 505     unless(open(NEW, $NEWFILES))
 506     {
 507         die("$me: $NEWFILES: cannot open: $!\n");
 508     }
 509     my $license='';
 510     my $copyright='';
 511     my $hash='';
 512     my $file='';
 513     my $license_text='';
 514     my $in_license_text=0;
 515     my $line=0;
 516     while(<NEW>)
 517     {
 518         $line++;
 519         chomp;
 520         next if(/^\s*\#/);
 521         if($in_license_text && /^\s+(.*)/)
 522         {
 523             $license_text .= $1 . "\n";
 524         }
 525         elsif(/^\s*$/)
 526         {
 527             next;
 528         }
 529         elsif(/^File:\s*(.*)/)
 530         {
 531             my $newfile=$1;
 532             # save previous entry
 533             if(length($file) && length($hash))
 534             {
 535                 $files->{$file}={ hash=>$hash,
 536                                   copyright=>$copyright,
 537                                   license=>$license,
 538                                   license_text=>$license_text };
 539             }
 540             $file=$newfile;
 541             $license='';
 542             $copyright='';
 543             $hash='';
 544             $license_text='';
 545             $in_license_text = 0;
 546         }
 547         elsif(/^Hash:\s*(.*)/)
 548         {
 549             $hash=$1;
 550         }
 551         elsif(/^Copyright:\s*(.*)/)
 552         {
 553             $copyright=$1;
 554         }
 555         elsif(/^License:\s*(.*)/)
 556         {
 557             $license=$1;
 558             $in_license_text=1;
 559             $license_text='';
 560         }
 561         elsif(/^Deleted:\s*(.*)/)
 562         {
 563             if(exists($files->{$1}))
 564             {
 565                 delete($files->{$1});
 566             }
 567         }
 568         else
 569         {
 570             warn("$me: $NEWFILES: line $line not recognized\n");
 571         }
 572     }
 573     close(NEW);
 574     # save last entry
 575     if(length($file) && length($hash))
 576     {
 577         $files->{$file}={ hash=>$hash,
 578                           copyright=>$copyright,
 579                           license=>$license,
 580                           license_text=>$license_text };
 581     }
 582 }
 583
 584 sub find_deleted
 585 {
 586     my %newnames = map { $_ => 1 } @filenames;
 587     for my $file (sort keys(%$files))
 588     {
 589         unless(exists($newnames{$file}))
 590         {
 591             push(@deleted_files, $file);
 592         }
 593     }
 594     if(@deleted_files)
 595     {
 596         print "Removed files:\n";
 597         print join("\n", @deleted_files),"\n";
 598     }
 599 }
 600
 601 sub backup
 602 {
 603     my $base=shift;
 604     my $old="$base.old";
 605     if(-f $base)
 606     {
 607         unlink($base);
 608         move($base, $old);
 609     }
 610 }
 611
 612 sub usage
 613 {
 614     die("usage: $me [--scan] [--merge]\n",
 615         "scans for changed copyright/licenses\n",
 616         "  -s|-scan      Scan for new files & files with changed copyright headers\n",
 617         "                Writes to debian/clscan/new.txt for manual review.\n",
 618         "  -m|--merge    Merges new data from debian/clscan/new.txt\n",
 619         "  -w|--write    Writes updated debian/copyright.\n",
 620         "                --merge implies --write.\n");
 621 }