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