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