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 # FIXME: add boilerplate
  21 our %module_licenses= (
  22     "public domain" => "",
  23     "unlimited" =>
  24         "This file is free software; the Free Software Foundation\n" .
  25         "gives unlimited permission to copy and/or distribute it,\n" .
  26         "with or without modifications, as long as this notice is preserved.\n",
  27     "LGPL" => "",
  28     "LGPLv2+" => "",
  29     "unmodifiable license text" =>
  30         "Everyone is permitted to copy and distribute verbatim copies\n" .
  31         "of this license document, but changing it is not allowed.\n",
  32     "GPLed build tool" => "",
  33     "GPL" => "",
  34 );
  35
  36 our @filenames=();
  37 our %overrides=();
  38 our $files={};
  39 our $new={};
  40
  41 my $scan=0;
  42 my $merge=0;
  43 my $writecopyright=0;
  44
  45 usage() unless(@ARGV);
  46 usage() unless GetOptions("scan|s" => \$scan,
  47                           "merge|m" => \$merge,
  48                           "write|w" => \$writecopyright,
  49                           "help|h" => sub { usage(); });
  50
  51 load_cache();
  52 scan() if($scan);
  53 merge() if($merge);
  54 write_copyright() if ($merge || $writecopyright);
  55
  56 sub scan
  57 {
  58     get_filenames();
  59     for my $file (@filenames)
  60     {
  61         scan_file($file);
  62     }
  63     write_new();
  64     find_deleted();
  65 }
  66
  67 sub merge
  68 {
  69     merge_new();
  70     load_overrides();
  71     save_cache();
  72 }
  73
  74 sub write_copyright
  75 {
  76     unless(keys(%$files))
  77     {
  78         die("$me: no files known, run $0 --scan\n");
  79     }
  80     unless(copy($COPYRIGHTSTUB, "debian/copyright"))
  81     {
  82         die("$me: cannot copy $COPYRIGHTSTUB to debian/copyright: $!\n");
  83     }
  84     unless(open(COPYRIGHT, ">>debian/copyright"))
  85     {
  86         die("$me: cannot append to debian/copyright: $!\n");
  87     }
  88
  89     # group files by license/license_text/copyright
  90     my $licenses={};
  91     for my $file (sort keys(%$files))
  92     {
  93         my $license=$files->{$file}->{license};
  94         my $copyright=$files->{$file}->{copyright};
  95         my $license_text=$files->{$file}->{license_text};
  96         push(@{$licenses->{$license}->{$license_text}->{$copyright}}, $file);
  97     }
  98     my %refs=();
  99     my $refnum="00";
 100     for my $license (sort keys(%$licenses))
 101     {
 102         for my $license_text (sort keys(%{$licenses->{$license}}))
 103         {
 104             my $licensestr=$license;
 105             if(length($license_text))
 106             {
 107                 $refnum++;
 108                 # license_text + empty license = License: other
 109                 if(!length($license))
 110                 {
 111                     $licensestr = "other";
 112                 }
 113                 $licensestr .= " [REF$refnum]";
 114                 $refs{$licensestr}=$license_text;
 115             }
 116             for my $copyright (sort keys(%{$licenses->{$license}->{$license_text}}))
 117             {
 118                 next if(!length($license) && !length($copyright) && !length($license_text));
 119                 my @filelist=sort @{$licenses->{$license}->{$license_text}->{$copyright}};
 120                 print COPYRIGHT "Files: ", join(', ', @filelist), "\n";
 121                 print COPYRIGHT "Copyright: $copyright\n" if length($copyright);
 122                 print COPYRIGHT "License: $licensestr\n" if length($licensestr);
 123                 print COPYRIGHT "\n";
 124             }
 125         }
 126     }
 127     for my $ref (sort keys(%refs))
 128     {
 129         print COPYRIGHT "License: $ref\n";
 130         my @text=split(/\n/, $refs{$ref});
 131         print COPYRIGHT map { "    " . $_ . "\n" } @text;
 132         print COPYRIGHT "\n";
 133     }
 134     print COPYRIGHT license_trailer(sort keys(%$licenses));
 135     close(COPYRIGHT);
 136 }
 137
 138 sub license_trailer
 139 {
 140     my @licenses_used=@_;
 141     my $license_data = {
 142         "Apache-2.0" => "Apache License Version 2.0",
 143         "Artistic" => "Artistic License",
 144         "GFDL-1.2" => "GNU Free Documentation License Version 1.2",
 145         "GFDL-1.3" => "GNU Free Documentation License Version 1.3",
 146         "GFDL" => "GNU Free Documentation License",
 147         "GPL-2" => "GNU General Public License Version 2",
 148         "GPL-3" => "GNU General Public License Version 3",
 149         "GPL" => "GNU General Public License",
 150         "LGPL-2" => "GNU Library General Public License Version 2",
 151         "LGPL-2.1" => "GNU Lesser General Public License Version 2.1",
 152         "LGPL-3" => "GNU Lesser General Public License Version 3",
 153         "LGPL" => "GNU Lesser General Public License",
 154     };
 155
 156     my %types_found=();
 157 TYPE: for my $type (reverse sort keys(%$license_data))
 158     {
 159         for my $license (@licenses_used)
 160         {
 161             if($license =~ /$type(\+|\b)/i)
 162             {
 163                 $types_found{$type}=1;
 164                 # avoid matching eg GPL-2 *and* GPL
 165                 next TYPE;
 166             }
 167         }
 168     }
 169     my $text="\n";
 170     # if just one, use standard style
 171     if(keys(%types_found) == 1)
 172     {
 173         my ($file, $name)=each(%types_found);
 174         $text .= "The complete text of the $name can be\n";
 175         $text .= "found in /usr/share/common-licenses/$file\n";
 176     }
 177     else
 178     {
 179         # more than one, use table.
 180         $text .= "The complete text of standard licenses referenced above\n";
 181         $text .= "can be found in /usr/share/common-licenses/ as follows:\n\n";
 182         $text .= sprintf("%-70s %s\n", "LICENSE", "FILE");
 183         for my $type (sort keys(%types_found))
 184         {
 185             $text .= sprintf("%-70s %s\n", $license_data->{$type}, $type);
 186         }
 187     }
 188     return $text;
 189 }
 190
 191
 192 sub guess_license
 193 {
 194     my $file=shift;
 195     my $license='';
 196     my $copyright='';
 197     if(open(LICENSECHECK, "licensecheck --copyright \"$file\"|"))
 198     {
 199         while(<LICENSECHECK>)
 200         {
 201             chomp;
 202             if(/^\s+\[(.*)\]$/)
 203             {
 204                 $copyright=$1;
 205             }
 206             elsif(/.*:\s+(.*)/)
 207             {
 208                 $license=$1;
 209             }
 210         }
 211         close(LICENSECHECK);
 212         $copyright =~ s/^\s*Copyright\s*:\s*//;
 213         $license =~ s/.*UNKNOWN.*//;
 214         $license =~ s/(L?GPL) \(v([\.\d]+) or later\)/$1-$2+/i;
 215         $license =~ s/(L?GPL) \(v([\.\d]+)\)/$1-$2/i;
 216         $license =~ s/G?FDL \(v([\.\d]+) or later\)/GFDL-$1+/i;
 217         $license =~ s/G?FDL \(v([\.\d]+)\)/GFDL-$1/i;
 218         $license =~ s/Apache \(v([\.\d]+) or later\)/Apache-$1+/i;
 219         $license =~ s/Apache \(v([\.\d]+)\)/Apache-$1+/i;
 220     }
 221     return($license, $copyright);
 222 }
 223
 224 sub scan_file
 225 {
 226     my $filename=shift;
 227     unless(open(FILE, $filename))
 228     {
 229         warn("$me: $filename: cannot open: $!\n");
 230         return;
 231     }
 232     my $header='';
 233     for(my $i=0; $i < 15; $i++)
 234     {
 235         my $line=<FILE>;
 236         last unless($line);
 237         $header .= $line;
 238     }
 239     close(FILE);
 240     my $hash=sha256_hex($header);
 241     if( (!exists($files->{$filename})) ||
 242         ($files->{$filename}->{hash} ne $hash))
 243     {
 244         filechanged($filename, $hash, $header);
 245     }
 246 }
 247
 248
 249 sub filechanged
 250 {
 251     my($filename, $hash, $header)=@_;
 252     my($license_guess, $copyright_guess)=guess_license($filename);
 253     $new->{$filename}={
 254         hash=>$hash,
 255         license=>$license_guess,
 256         copyright=>$copyright_guess,
 257         header=>$header,
 258     };
 259     if(exists($files->{$filename}))
 260     {
 261         if(exists($files->{$filename}->{copyright}))
 262         {
 263             $new->{$filename}->{copyright_old}=$files->{$filename}->{copyright};
 264         }
 265         if(exists($files->{$filename}->{license}))
 266         {
 267             $new->{$filename}->{license_old}=$files->{$filename}->{license};
 268         }
 269         if(exists($files->{$filename}->{license_text}))
 270         {
 271             $new->{$filename}->{license_text_old}=$files->{$filename}->{license_text};
 272         }
 273     }
 274 }
 275
 276 sub get_filenames
 277 {
 278     find(\&wanted_files, ".");
 279 }
 280
 281 sub wanted_files
 282 {
 283     if(/^\.git/ || /^\.cvs/ || /^debian/ || /^modules$/)
 284     {
 285         $File::Find::prune=1;
 286     }
 287     elsif(-f)
 288     {
 289         push(@filenames, $File::Find::name);
 290     }
 291 }
 292
 293 sub wanted_modules
 294 {
 295     if(/^\.[^\/]/ || /^README$/ || /^COPYING$/)
 296     {
 297         $File::Find::prune=1;
 298         return;
 299     }
 300     elsif(-f)
 301     {
 302         unless(open(MOD, $File::Find::name))
 303         {
 304             warn("$me: cannot open $File::Find::name: $!\n");
 305             return;
 306         }
 307         my $infiles=0;
 308         my $inlicense=0;
 309         my @files=();
 310         while(<MOD>)
 311         {
 312             chomp;
 313             if(/^$/)
 314             {
 315                 $infiles = $inlicense = 0;
 316             }
 317             if($inlicense)
 318             {
 319                 push(@{$overrides{$_}},@files);
 320                 $inlicense=0;
 321             }
 322             elsif($infiles)
 323             {
 324                 push(@files, $_);
 325             }
 326             elsif(/^License:/)
 327             {
 328                 $inlicense=1;
 329             }
 330             elsif(/^Files:/)
 331             {
 332                 $infiles=1;
 333             }
 334         }
 335         close(MOD);
 336     }
 337 }
 338
 339 sub load_overrides
 340 {
 341     find({ wanted => \&wanted_modules, no_chdir => 1}, "modules/");
 342     for my $license (keys(%overrides))
 343     {
 344         print("License: $license\n");
 345         print("Files: \n\t");
 346         print(join("\n\t", @{$overrides{$license}}),"\n");
 347     }
 348 }
 349
 350
 351 sub load_cache
 352 {
 353     unless(open(YAML,$FILESCACHE))
 354     {
 355         warn("$me: cannot load cache $FILESCACHE: $!\n");
 356         return;
 357     }
 358     my $yaml;
 359     {
 360         local $/=undef;
 361         $yaml=<YAML>;
 362     }
 363     close(YAML);
 364     $files=Load($yaml);
 365 }
 366
 367 sub save_cache
 368 {
 369     backup($FILESCACHE);
 370     unless(open(YAML,">$FILESCACHE"))
 371     {
 372         warn("$me: cannot save cache $FILESCACHE: $!\n");
 373         return;
 374     }
 375     print YAML Dump($files);
 376     close(YAML);
 377 }
 378
 379 sub write_new
 380 {
 381     backup($NEWFILES);
 382     unless(keys(%$new))
 383     {
 384         warn("$me: no new/changed files found\n");
 385         return;
 386     }
 387     unless(open(NEW,">$NEWFILES"))
 388     {
 389         die("$me: cannot write to $NEWFILES: $!\n");
 390     }
 391     for my $file (sort keys %$new)
 392     {
 393         print NEW "File: $file\n";
 394         print NEW "Hash: ", $new->{$file}->{hash}, "\n";
 395         print NEW "Copyright: ", $new->{$file}->{copyright}, "\n";
 396         print NEW "License: ", $new->{$file}->{license}, "\n";
 397         print NEW "License_Text: \n";
 398         if($new->{$file}->{license_old})
 399         {
 400             print NEW "#License_old: ", $new->{$file}->{license_old}, "\n";
 401         }
 402         if($new->{$file}->{copyright_old})
 403         {
 404             print NEW "#Copyright_old: ", $new->{$file}->{copyright_old}, "\n";
 405         }
 406         if($new->{$file}->{licence_text_old})
 407         {
 408             print NEW "#License_text_old: ", $new->{$file}->{licence_text_old}, "\n";
 409         }
 410         print NEW "#Header: \n";
 411         my @headerlines=split(/\n/, $new->{$file}->{header});
 412         @headerlines=map { "#" . $_ } grep { defined $_; } @headerlines;
 413         print NEW join("\n", @headerlines);
 414         print NEW "\n\n";
 415     }
 416     close NEW;
 417 }
 418
 419 sub merge_new
 420 {
 421     unless(open(NEW, $NEWFILES))
 422     {
 423         die("$me: $NEWFILES: cannot open: $!\n");
 424     }
 425     my $license='';
 426     my $copyright='';
 427     my $hash='';
 428     my $file='';
 429     my $license_text='';
 430     my $in_license_text=0;
 431     my $line=0;
 432     while(<NEW>)
 433     {
 434         $line++;
 435         chomp;
 436         next if(/^\s*\#/);
 437         if($in_license_text && /^\s+(.*)/)
 438         {
 439             $license_text .= $1 . "\n";
 440         }
 441         elsif(/^\s*$/)
 442         {
 443             next;
 444         }
 445         elsif(/^File:\s*(.*)/)
 446         {
 447             my $newfile=$1;
 448             # save previous entry
 449             if(length($file) && length($hash))
 450             {
 451                 $files->{$file}={ hash=>$hash,
 452                                   copyright=>$copyright,
 453                                   license=>$license,
 454                                   license_text=>$license_text };
 455             }
 456             $file=$newfile;
 457             $license='';
 458             $copyright='';
 459             $hash='';
 460             $license_text='';
 461             $in_license_text = 0;
 462         }
 463         elsif(/^Hash:\s*(.*)/)
 464         {
 465             $hash=$1;
 466         }
 467         elsif(/^Copyright:\s*(.*)/)
 468         {
 469             $copyright=$1;
 470         }
 471         elsif(/^License:\s*(.*)/)
 472         {
 473             $license=$1;
 474             $in_license_text=1;
 475             $license_text='';
 476         }
 477         else
 478         {
 479             warn("$me: $NEWFILES: line $line not recognized\n");
 480         }
 481     }
 482     close(NEW);
 483     # save last entry
 484     if(length($file) && length($hash))
 485     {
 486         $files->{$file}={ hash=>$hash,
 487                           copyright=>$copyright,
 488                           license=>$license,
 489                           license_text=>$license_text };
 490     }
 491 }
 492
 493 sub find_deleted
 494 {
 495     my @deleted=();
 496     my %newnames = map { $_ => 1 } @filenames;
 497     for my $file (sort keys(%$files))
 498     {
 499         unless(exists($newnames{$file}))
 500         {
 501             push(@deleted, $file);
 502         }
 503     }
 504     if(@deleted)
 505     {
 506         print "Removed files:\n";
 507         print join("\n", @deleted),"\n";
 508     }
 509 }
 510
 511 sub backup
 512 {
 513     my $base=shift;
 514     my $old="$base.old";
 515     if(-f $base)
 516     {
 517         unlink($base);
 518         move($base, $old);
 519     }
 520 }
 521
 522 sub usage
 523 {
 524     die("usage: $me [--scan] [--merge]\n",
 525         "scans for changed copyright/licenses\n",
 526         "  -s|-scan      Scan for new files & files with changed copyright headers\n",
 527         "                Writes to debian/clscan/new.txt for manual review.\n",
 528         "  -m|--merge    Merges new data from debian/clscan/new.txt\n",
 529         "  -w|--write    Writes updated debian/copyright.\n",
 530         "                --merge implies --write.\n");
 531 }