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