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