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