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