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     for my $type (reverse sort keys(%$license_data))
 158     {
 159         for my $license (@licenses_used)
 160         {
 161             if($license =~ /$type(\+|\s|$)/i)
 162             {
 163                 $types_found{$type}=1;
 164                 print "FOUND $type [$license]\n";
 165             }
 166         }
 167     }
 168     my $text="\n";
 169     # if just one, use standard style
 170     if(keys(%types_found) == 1)
 171     {
 172         my ($file, $name)=each(%types_found);
 173         $text .= "The complete text of the $name can be\n";
 174         $text .= "found in /usr/share/common-licenses/$file\n";
 175     }
 176     else
 177     {
 178         # more than one, use table.
 179         $text .= "The complete text of standard licenses referenced above\n";
 180         $text .= "can be found in /usr/share/common-licenses/ as follows:\n\n";
 181         $text .= sprintf("%-60s %s\n", "LICENSE", "FILE");
 182         for my $type (sort keys(%types_found))
 183         {
 184             $text .= sprintf("%-60s %s\n", $license_data->{$type}, $type);
 185         }
 186     }
 187     return $text;
 188 }
 189
 190
 191 sub guess_license
 192 {
 193     my $file=shift;
 194     my $license='';
 195     my $copyright='';
 196     if(open(LICENSECHECK, "licensecheck --copyright \"$file\"|"))
 197     {
 198         while(<LICENSECHECK>)
 199         {
 200             chomp;
 201             if(/^\s+\[(.*)\]$/)
 202             {
 203                 $copyright=$1;
 204             }
 205             elsif(/.*:\s+(.*)/)
 206             {
 207                 $license=$1;
 208             }
 209         }
 210         close(LICENSECHECK);
 211         $copyright =~ s/^\s*Copyright\s*:\s*//;
 212         $license =~ s/.*UNKNOWN.*//;
 213         $license =~ s/(L?GPL) \(v([\.\d]+) or later\)/$1-$2+/i;
 214         $license =~ s/(L?GPL) \(v([\.\d]+)\)/$1-$2/i;
 215         $license =~ s/G?FDL \(v([\.\d]+) or later\)/GFDL-$1+/i;
 216         $license =~ s/G?FDL \(v([\.\d]+)\)/GFDL-$1/i;
 217         $license =~ s/Apache \(v([\.\d]+) or later\)/Apache-$1+/i;
 218         $license =~ s/Apache \(v([\.\d]+)\)/Apache-$1+/i;
 219     }
 220     return($license, $copyright);
 221 }
 222
 223 sub scan_file
 224 {
 225     my $filename=shift;
 226     unless(open(FILE, $filename))
 227     {
 228         warn("$me: $filename: cannot open: $!\n");
 229         return;
 230     }
 231     my $header='';
 232     for(my $i=0; $i < 15; $i++)
 233     {
 234         my $line=<FILE>;
 235         last unless($line);
 236         $header .= $line;
 237     }
 238     close(FILE);
 239     my $hash=sha256_hex($header);
 240     if( (!exists($files->{$filename})) ||
 241         ($files->{$filename}->{hash} ne $hash))
 242     {
 243         filechanged($filename, $hash, $header);
 244     }
 245 }
 246
 247
 248 sub filechanged
 249 {
 250     my($filename, $hash, $header)=@_;
 251     my($license_guess, $copyright_guess)=guess_license($filename);
 252     $new->{$filename}={
 253         hash=>$hash,
 254         license=>$license_guess,
 255         copyright=>$copyright_guess,
 256         header=>$header,
 257     };
 258     if(exists($files->{$filename}))
 259     {
 260         if(exists($files->{$filename}->{copyright}))
 261         {
 262             $new->{$filename}->{copyright_old}=$files->{$filename}->{copyright};
 263         }
 264         if(exists($files->{$filename}->{license}))
 265         {
 266             $new->{$filename}->{license_old}=$files->{$filename}->{license};
 267         }
 268         if(exists($files->{$filename}->{license_text}))
 269         {
 270             $new->{$filename}->{license_text_old}=$files->{$filename}->{license_text};
 271         }
 272     }
 273 }
 274
 275 sub get_filenames
 276 {
 277     find(\&wanted_files, ".");
 278 }
 279
 280 sub wanted_files
 281 {
 282     if(/^\.git/ || /^\.cvs/ || /^debian/ || /^modules$/)
 283     {
 284         $File::Find::prune=1;
 285     }
 286     elsif(-f)
 287     {
 288         push(@filenames, $File::Find::name);
 289     }
 290 }
 291
 292 sub wanted_modules
 293 {
 294     if(/^\.[^\/]/ || /^README$/ || /^COPYING$/)
 295     {
 296         $File::Find::prune=1;
 297         return;
 298     }
 299     elsif(-f)
 300     {
 301         unless(open(MOD, $File::Find::name))
 302         {
 303             warn("$me: cannot open $File::Find::name: $!\n");
 304             return;
 305         }
 306         my $infiles=0;
 307         my $inlicense=0;
 308         my @files=();
 309         while(<MOD>)
 310         {
 311             chomp;
 312             if(/^$/)
 313             {
 314                 $infiles = $inlicense = 0;
 315             }
 316             if($inlicense)
 317             {
 318                 push(@{$overrides{$_}},@files);
 319                 $inlicense=0;
 320             }
 321             elsif($infiles)
 322             {
 323                 push(@files, $_);
 324             }
 325             elsif(/^License:/)
 326             {
 327                 $inlicense=1;
 328             }
 329             elsif(/^Files:/)
 330             {
 331                 $infiles=1;
 332             }
 333         }
 334         close(MOD);
 335     }
 336 }
 337
 338 sub load_overrides
 339 {
 340     find({ wanted => \&wanted_modules, no_chdir => 1}, "modules/");
 341     for my $license (keys(%overrides))
 342     {
 343 #       print("License: $license\n");
 344 #       print("Files: \n\t");
 345 #       print(join("\n\t", @{$overrides{$license}}),"\n");
 346     }
 347 }
 348
 349
 350 sub load_cache
 351 {
 352     unless(open(YAML,$FILESCACHE))
 353     {
 354         warn("$me: cannot load cache $FILESCACHE: $!\n");
 355         return;
 356     }
 357     my $yaml;
 358     {
 359         local $/=undef;
 360         $yaml=<YAML>;
 361     }
 362     close(YAML);
 363     $files=Load($yaml);
 364 }
 365
 366 sub save_cache
 367 {
 368     backup($FILESCACHE);
 369     unless(open(YAML,">$FILESCACHE"))
 370     {
 371         warn("$me: cannot save cache $FILESCACHE: $!\n");
 372         return;
 373     }
 374     print YAML Dump($files);
 375     close(YAML);
 376 }
 377
 378 sub write_new
 379 {
 380     backup($NEWFILES);
 381     unless(keys(%$new))
 382     {
 383         warn("$me: no new/changed files found\n");
 384         return;
 385     }
 386     unless(open(NEW,">$NEWFILES"))
 387     {
 388         die("$me: cannot write to $NEWFILES: $!\n");
 389     }
 390     for my $file (sort keys %$new)
 391     {
 392         print NEW "File: $file\n";
 393         print NEW "Hash: ", $new->{$file}->{hash}, "\n";
 394         print NEW "Copyright: ", $new->{$file}->{copyright}, "\n";
 395         print NEW "License: ", $new->{$file}->{license}, "\n";
 396         print NEW "License_Text: \n";
 397         if($new->{$file}->{license_old})
 398         {
 399             print NEW "#License_old: ", $new->{$file}->{license_old}, "\n";
 400         }
 401         if($new->{$file}->{copyright_old})
 402         {
 403             print NEW "#Copyright_old: ", $new->{$file}->{copyright_old}, "\n";
 404         }
 405         if($new->{$file}->{licence_text_old})
 406         {
 407             print NEW "#License_text_old: ", $new->{$file}->{licence_text_old}, "\n";
 408         }
 409         print NEW "#Header: \n";
 410         my @headerlines=split(/\n/, $new->{$file}->{header});
 411         @headerlines=map { "#" . $_ } grep { defined $_; } @headerlines;
 412         print NEW join("\n", @headerlines);
 413         print NEW "\n\n";
 414     }
 415     close NEW;
 416 }
 417
 418 sub merge_new
 419 {
 420     unless(open(NEW, $NEWFILES))
 421     {
 422         die("$me: $NEWFILES: cannot open: $!\n");
 423     }
 424     my $license='';
 425     my $copyright='';
 426     my $hash='';
 427     my $file='';
 428     my $license_text='';
 429     my $in_license_text=0;
 430     my $line=0;
 431     while(<NEW>)
 432     {
 433         $line++;
 434         chomp;
 435         next if(/^\s*\#/);
 436         if($in_license_text && /^\s+(.*)/)
 437         {
 438             $license_text .= $1 . "\n";
 439         }
 440         elsif(/^\s*$/)
 441         {
 442             next;
 443         }
 444         elsif(/^File:\s*(.*)/)
 445         {
 446             my $newfile=$1;
 447             # save previous entry
 448             if(length($file) && length($hash))
 449             {
 450                 $files->{$file}={ hash=>$hash,
 451                                   copyright=>$copyright,
 452                                   license=>$license,
 453                                   license_text=>$license_text };
 454             }
 455             $file=$newfile;
 456             $license='';
 457             $copyright='';
 458             $hash='';
 459             $license_text='';
 460             $in_license_text = 0;
 461         }
 462         elsif(/^Hash:\s*(.*)/)
 463         {
 464             $hash=$1;
 465         }
 466         elsif(/^Copyright:\s*(.*)/)
 467         {
 468             $copyright=$1;
 469         }
 470         elsif(/^License:\s*(.*)/)
 471         {
 472             $license=$1;
 473             $in_license_text=1;
 474             $license_text='';
 475         }
 476         else
 477         {
 478             warn("$me: $NEWFILES: line $line not recognized\n");
 479         }
 480     }
 481     close(NEW);
 482     # save last entry
 483     if(length($file) && length($hash))
 484     {
 485         $files->{$file}={ hash=>$hash,
 486                           copyright=>$copyright,
 487                           license=>$license,
 488                           license_text=>$license_text };
 489     }
 490 }
 491
 492 sub find_deleted
 493 {
 494     my @deleted=();
 495     my %newnames = map { $_ => 1 } @filenames;
 496     for my $file (sort keys(%$files))
 497     {
 498         unless(exists($newnames{$file}))
 499         {
 500             push(@deleted, $file);
 501         }
 502     }
 503     if(@deleted)
 504     {
 505         print "Removed files:\n";
 506         print join("\n", @deleted),"\n";
 507     }
 508 }
 509
 510 sub backup
 511 {
 512     my $base=shift;
 513     my $old="$base.old";
 514     if(-f $base)
 515     {
 516         unlink($base);
 517         move($base, $old);
 518     }
 519 }
 520
 521 sub usage
 522 {
 523     die("usage: $me [--scan] [--merge]\n",
 524         "scans for changed copyright/licenses\n",
 525         "  -s|-scan      Scan for new files & files with changed copyright headers\n",
 526         "                Writes to debian/clscan/new.txt for manual review.\n",
 527         "  -m|--merge    Merges new data from debian/clscan/new.txt\n",
 528         "  -w|--write    Writes updated debian/copyright.\n",
 529         "                --merge implies --write.\n");
 530 }