debtransform

   1 #!/usr/bin/perl -w
   2
   3 ################################################################
   4 #
   5 # Copyright (c) 1995-2014 SUSE Linux Products GmbH
   6 #
   7 # This program is free software; you can redistribute it and/or modify
   8 # it under the terms of the GNU General Public License version 2 or 3 as
   9 # published by the Free Software Foundation.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program (see the file COPYING); if not, write to the
  18 # Free Software Foundation, Inc.,
  19 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
  20 #
  21 ################################################################
  22
  23 use strict;
  24 use Digest::MD5;
  25
  26 sub usage
  27 {
  28   die("usage: debtransform [--debug] [--changelog <changelog>] [--release <release number>] <srcdir> <dscfile> <outdir>\n");
  29 }
  30
  31 sub parsedsc {
  32   my ($fn) = @_;
  33   my @control;
  34   local *F;
  35   open(F, '<', $fn) || die("Error in reading $fn: $!\n");
  36   @control = <F>;
  37   close F;
  38   chomp @control;
  39   splice(@control, 0, 3) if @control > 3 && $control[0] =~ /^-----BEGIN/;
  40   my @seq = ();
  41   my %tag;
  42   while (@control) {
  43     my $c = shift @control;
  44     last if $c eq '';   # new paragraph
  45     my ($tag, $data) = split(':', $c, 2);
  46     next unless defined $data;
  47     push @seq, $tag;
  48     $tag = uc($tag);
  49     while (@control && $control[0] =~ /^\s/) {
  50       $data .= "\n".substr(shift @control, 1);
  51     }
  52     $data =~ s/^\s+//s;
  53     $data =~ s/\s+$//s;
  54     $tag{$tag} = $data;
  55   }
  56   $tag{'__seq'} = \@seq;
  57   return \%tag;
  58 }
  59
  60 sub writedsc {
  61   my ($fn, $tags) = @_;
  62   print "Writing $fn\n";
  63   open(F, '>', $fn) || die("open $fn: $!\n");
  64   my @seq = @{$tags->{'__seq'} || []};
  65   my %seq = map {uc($_) => 1} @seq;
  66   for (sort keys %$tags) {
  67     push @seq, ucfirst(lc($_)) unless $seq{$_};
  68   }
  69   for my $seq (@seq) {
  70     my $ucseq = uc($seq);
  71     my $d = $tags->{$ucseq};
  72     next unless defined $d;
  73     $d =~ s/\n/\n /sg;
  74     print F "$seq: $d\n";
  75   }
  76   print F "\n";
  77   close F;
  78 }
  79
  80 sub listtar {
  81   my ($tar, $skipdebiandir) = @_;
  82   print "Scanning $tar...\n";
  83   local *F;
  84   my @c;
  85   unless(defined($skipdebiandir)) {
  86     $skipdebiandir = 1;
  87   }
  88   open(F, '-|', 'tar', '--numeric-owner', '-tvf', $tar) ||
  89     die("Execution of tar subprocess failed: $!\n");
  90   while(<F>) {
  91     next unless /^([-dlbcp])(.........)\s+\d+\/\d+\s+(\S+) \d\d\d\d-\d\d-\d\d \d\d:\d\d(?::\d\d)? (.*)$/;
  92     my ($type, $mode, $size, $name) = ($1, $2, $3, $4);
  93     next if $type eq 'd';
  94     if ($type eq 'l') {
  95       next if $skipdebiandir eq 0;
  96       die("Archive contains a link: $name\n");
  97     }
  98     if ($type ne '-') {
  99       next if $skipdebiandir eq 0;
 100       die("Archive contains an unexpected type for file \"$name\"\n");
 101     }
 102     $name =~ s/^\.\///;
 103     $name =~ s/^debian\/// if $skipdebiandir eq 1;
 104     push @c, {'name' => $name, 'size' => $size};
 105   }
 106   close(F) || die("tar exited with non-zero status: $!\n");
 107   return @c;
 108 }
 109
 110 sub extracttar {
 111   my ($tar, $filename, $s) = @_;
 112   local *F;
 113   print "Extracting $tar...\n";
 114   open(F, '-|', 'tar', '-xOf', $tar, $filename) ||
 115     die("Execution of tar subprocess failed: $!\n");
 116   my $file = '';
 117   while ($s > 0) {
 118     my $l = sysread(F, $file, $s, length($file));
 119     die("Error while reading from tar subprocess: $!\n") unless $l;
 120     $s -= $l;
 121   }
 122   my @file = split("\n", $file);
 123   close(F) || warn("tar exited with non-zero status: $!\n");
 124   return @file;
 125 }
 126
 127 sub dodiff {
 128   my ($oldname, $newname, $origtarfile, @content) = @_;
 129   my @oldcontent;
 130   for my $c (@{$origtarfile->{'content'}}) {
 131       if ($c->{'name'} eq $newname) {
 132           @oldcontent = extracttar($origtarfile->{'name'}, $c->{'name'}, $c->{'size'});
 133       }
 134   }
 135   if ($newname eq $origtarfile->{'tardir'}."/debian/changelog") {
 136     my $firstline = $content[0];
 137     my $version = $firstline;
 138     $version =~ s/.*\((.*)\).*/$1/g;
 139     if ($version ne $origtarfile->{'version'}) {
 140       $firstline =~ s/\(.*\)/($origtarfile->{'version'})/g;
 141       my $date = `date -R`;
 142       chomp($date);
 143       my @newcontent = ($firstline, "", "  * version number update by debtransform", "", " -- debtransform <build\@opensuse.org>  ".$date, "");
 144       push(@newcontent, @content);
 145       @content = @newcontent;
 146     }
 147   }
 148   return unless @content;
 149   print DIFF "--- $oldname\n";
 150   print DIFF "+++ $newname\n";
 151   if (@oldcontent) {
 152     print DIFF "\@\@ -1,".scalar(@oldcontent)." +1,".scalar(@content)." \@\@\n";
 153     print DIFF "-$_\n" for @oldcontent;
 154   } else {
 155     print DIFF "\@\@ -0,0 +1,".scalar(@content)." \@\@\n";
 156   }
 157   print DIFF "+$_\n" for @content;
 158 }
 159
 160 sub dotar {
 161   my ($tar, $tardir, $origin, $origtarfile, @c) = @_;
 162   local *F;
 163   open(F, '-|', 'tar', '-xOf', $tar) || die("tar: $!\n");
 164   for my $c (@c) {
 165     my $s = $c->{'size'};
 166     my $file = '';
 167     while ($s > 0) {
 168       my $l = sysread(F, $file, $s, length($file));
 169       die("tar read error\n") unless $l;
 170       $s -= $l;
 171     }
 172     next if $origin && $origin->{$c->{'name'}} ne $tar;
 173     my @file = split("\n", $file);
 174     dodiff("$tardir.orig/debian/$c->{'name'}", "$tardir/debian/$c->{'name'}", $origtarfile, @file);
 175   }
 176   close(F);
 177 }
 178
 179 sub dofile {
 180   my ($file, $tardir, $dfile, $origtarfile) = @_;
 181   local *F;
 182   print "Processing file \"$file\"...\n";
 183   open(F, '<', $file) || die("Error in reading $file: $!\n");
 184   my @file = <F>;
 185   close F;
 186   chomp(@file);
 187   dodiff("$tardir.orig/$dfile", "$tardir/$dfile", $origtarfile, @file);
 188 }
 189
 190 sub doseries {
 191   my ($series, $tardir) = @_;
 192   my $dir = $series;
 193   $dir =~ s/[^\/]+$//;
 194   $dir =~ s/\/+$//;
 195   $dir = '.' if $dir eq '';
 196   local *F;
 197   open(F, '<', $series) || die("$series: $!\n");
 198   my @series = <F>;
 199   close F;
 200   chomp(@series);
 201   print "Processing series file \"$series\"...\n";
 202   for my $patch (@series) {
 203     $patch =~ s/(^|\s+)#.*//;
 204     next if $patch =~ /^\s*$/;
 205     my $level = 1;
 206     $level = $1 if $patch =~ /\s.*-p\s*(\d+)/;
 207     $patch =~ s/\s.*//;
 208     print "Processing patch $dir/$patch...\n";
 209     open(F, '<', "$dir/$patch") || die("Error in reading $dir/$patch: $!\n");
 210     while(<F>) {
 211       chomp;
 212       if ((/^--- ./ || /^\+\+\+ ./) && !/^... \/dev\/null/) {
 213         my $start = substr($_, 0, 4);
 214         $_ = substr($_, 4);
 215         my $l = $level;
 216         while ($l > 0) {
 217           last unless s/.*?\///;
 218           $l--;
 219         }
 220         if ($start eq '--- ') {
 221           print DIFF "$start$tardir.orig/$_\n";
 222         } else {
 223           print DIFF "$start$tardir/$_\n";
 224         }
 225         next;
 226       }
 227       print DIFF "$_\n";
 228     }
 229     close F;
 230   }
 231 }
 232
 233 sub addfile {
 234   my ($file) = @_;
 235   my $base = $file;
 236   $base =~ s/.*\///;
 237   local *F;
 238   open(F, '<', $file) || die("Error in reading $file: $!\n");
 239   my $size = -s F;
 240   my $ctx = Digest::MD5->new;
 241   $ctx->addfile(*F);
 242   close F;
 243   my $md5 = $ctx->hexdigest();
 244   return "$md5 $size $base";
 245 }
 246
 247 print "** Started: debtransform @ARGV\n";
 248
 249 my $debug = 0;
 250 my $changelog;
 251 my $release;
 252
 253 while (@ARGV > 3) {
 254   if ($ARGV[0] eq '--debug') {
 255     shift @ARGV;
 256     $debug = 1;
 257   } elsif ($ARGV[0] eq '--changelog') {
 258     shift @ARGV;
 259     $changelog = shift @ARGV;
 260   } elsif ($ARGV[0] eq '--release') {
 261     shift @ARGV;
 262     $release = shift @ARGV;
 263   } else {
 264     usage();
 265   }
 266 }
 267
 268 if( @ARGV != 3 ) {
 269   usage();
 270 }
 271
 272 my $dir = $ARGV[0];
 273 my $dsc = $ARGV[1];
 274 my $out = $ARGV[2];
 275
 276 die("$out is not a directory\n") unless -d $out;
 277
 278 my $tags = parsedsc($dsc);
 279
 280 opendir(D, $dir) || die("Could not open $dir: $!\n");
 281 my @dir = grep {$_ ne '.' && $_ ne '..'} readdir(D);
 282 closedir(D);
 283 my %dir = map {$_ => 1} @dir;
 284
 285 my $tarfile = $tags->{'DEBTRANSFORM-TAR'};
 286 my @debtarfiles;
 287 if ($tags->{'DEBTRANSFORM-FILES-TAR'}) {
 288   @debtarfiles = split(' ', $tags->{'DEBTRANSFORM-FILES-TAR'});
 289 }
 290
 291 if (!$tarfile || !@debtarfiles) {
 292   my @tars = grep {/\.tgz$|\.tar(?:\.gz|\.bz2|\.xz)?$/} @dir;
 293   my @debtars = grep {/^debian\.tar(?:\.gz|\.bz2|\.xz)?$/} @tars;
 294   if (!$tarfile) {
 295     print "No DEBTRANSFORM-TAR line in the .dsc file.\n";
 296     print "Attempting automatic discovery of a suitable source archive.\n";
 297     @tars = grep {!/^debian\.tar(?:\.gz|\.bz2|\.xz)?$/} @tars;
 298     if (@debtarfiles) {
 299       my %debtarfiles = map {$_ => 1} @debtarfiles;
 300       @tars = grep {!$debtarfiles{$_}} @tars;
 301     }
 302     die("None of the files looks like a usable source tarball.\n") unless @tars;
 303     die("Too many files looking like a usable source tarball (would not know which to pick): @tars\n") if @tars > 1;
 304     $tarfile = $tars[0];
 305     print "Source archive chosen for transformation: $tarfile\n";
 306   }
 307   if (!exists($tags->{'DEBTRANSFORM-FILES-TAR'})) {
 308     print "No DEBTRANSFORM-FILES-TAR line in the .dsc file.\n";
 309     print "Attempting automatic discovery of a debian archive.\n";
 310   }
 311   if (@debtars && !exists($tags->{'DEBTRANSFORM-FILES-TAR'})) {
 312     die("package contains more than one debian archive\n") if @debtars > 1;
 313     @debtarfiles = ($debtars[0]);
 314     print "Debian archive chosen for transformation: $debtars[0]\n";
 315   }
 316 }
 317
 318 my $name = $tags->{'SOURCE'};
 319 die("dsc file contains no Source: line\n") unless defined($name);
 320 my $version = $tags->{'VERSION'};
 321 die("dsc file contains no Version: line\n") unless defined($version);
 322 # no epoch in version, please
 323 if ($version =~ s/^\d+://) {
 324         print "Stripped epoch from Version field, which is now \"$version\".\n";
 325 }
 326
 327
 328 # debtransform will always generate a 1.0 format type,
 329 # so it has to transform all source archives into weak gzip files.
 330 my $tmptar;
 331 if ($tarfile =~ /\.tar\.bz2/) {
 332     my $old = $tarfile;
 333     $tarfile =~ s/\.tar\.bz2/\.tar\.gz/;
 334     $tmptar = "$out/$tarfile";
 335     print "converting $dir/$old to $tarfile\n";
 336     system( ( "debtransformbz2", "$dir/$old", "$tmptar" )) == 0 || die("cannot transform .tar.bz2 to .tar.gz");
 337 }
 338 if ($tarfile =~ /\.tar\.xz/) {
 339     my $old = $tarfile;
 340     $tarfile =~ s/\.tar\.xz/\.tar\.gz/;
 341     $tmptar = "$out/$tarfile";
 342     print "converting $dir/$old to $tarfile\n";
 343     system( ( "debtransformxz", "$dir/$old", "$tmptar" )) == 0 || die("cannot transform .tar.xz to .tar.gz");
 344 }
 345 if ($tarfile =~ /\.zip/) {
 346     my $old = $tarfile;
 347     $tarfile =~ s/\.zip/\.tar\.gz/;
 348     $tmptar = "$out/$tarfile";
 349     print "converting $dir/$old to $tarfile\n";
 350     system( ( "debtransformzip", "$dir/$old", "$tmptar" )) == 0 || die("cannot transform .zip to .tar.gz");
 351 }
 352 if ($tarfile =~ /\.tgz$/) {
 353     my $old = $tarfile;
 354     $tarfile =~ s/\.tgz/\.tar.gz/;
 355     $tmptar = "$out/$tarfile";
 356     print "renaming $dir/$old to $tarfile\n";
 357     system ( ("mv",  "$dir/$old",  "$tmptar" ) ) == 0 || die("cannot rename .tgz to .tar.gz");
 358 }
 359
 360 my @files;
 361 my $v = $version;
 362 $v =~ s/-[^-]*$//;
 363 $tarfile =~ /.*(\.tar.*?)$/;
 364 my $ntarfile = "${name}_$v.orig$1";
 365 if( $tmptar ) {
 366   print "Moving $dir/$tarfile to $out/$ntarfile\n";
 367   link("$tmptar", "$out/$ntarfile") || die("link: $!\n");
 368   unlink("$tmptar");
 369 } else {
 370   print "Hardlinking $dir/$tarfile to $out/$ntarfile\n";
 371   link("$dir/$tarfile", "$out/$ntarfile") || die("link: $!\n");
 372 }
 373 push @files, addfile("$out/$ntarfile");
 374 print "files @files\n";
 375
 376 if ( $tags->{'DEBTRANSFORM-RELEASE'} && $release ) {
 377     # if dsc file contains the tag DEBTRANSFORM-RELEASE
 378     # and "release" is given as a commad line parameter,
 379     # replace "version" from dsc file by "version-release".
 380     # From "version" the current release is stripped before
 381     # (last "-" and the part after the last "-").
 382     # On OBS, release is incremented automatically
 383     # (same as for RPMs)
 384     $version = $v . "-" . $release;
 385     $tags->{'VERSION'} = $version;
 386     print "Modifying dsc Version field to \"$tags->{VERSION}\"\n";
 387 }
 388
 389 my $tarpath = "$out/$ntarfile";
 390 my $tardir = $tarfile;
 391 $tardir =~ s/\.orig\.tar/\.tar/;
 392 $tardir =~ s/\.tar.*?$//;
 393 my @tarfilecontent = listtar($tarpath, 0);
 394 my $origtarfile = {'name' => $tarpath, 'content' => \@tarfilecontent, 'version' => $tags->{'VERSION'}, 'tardir' => $tardir};
 395
 396 print "Generating $out/${name}_$version.diff\n";
 397 # Since we are generating a unitary diff, we must re-set Format:.
 398 $tags->{"FORMAT"} = "1.0";
 399 open(DIFF, '>', "$out/${name}_$version.diff") || die("Cannot open $out/${name}_$version.diff for write: $!\n");
 400
 401 undef $changelog if $dir{'debian.changelog'};
 402
 403 my %debtarorigin;
 404 my %debtarcontent;
 405 for my $debtarfile (@debtarfiles) {
 406   my @c = listtar("$dir/$debtarfile");
 407   $debtarcontent{$debtarfile} = \@c;
 408   for (@c) {
 409     die("\"$_->{'name'}\" exists in both the debian archive as well as the package source directory.\n") if $dir{"debian.$_->{'name'}"};
 410     undef $changelog if $_->{'name'} eq 'changelog';
 411     $debtarorigin{$_->{'name'}} = "$dir/$debtarfile";
 412   }
 413 }
 414
 415 dofile($changelog, $tardir, 'debian/changelog', $origtarfile) if defined $changelog;
 416
 417 if ($tags->{'DEBTRANSFORM-FILES'}) {
 418   for my $file (split(' ', $tags->{'DEBTRANSFORM-FILES'})) {
 419     dofile("$dir/$file", $tardir, $file, $origtarfile);
 420   }
 421 }
 422
 423 for my $debtarfile (@debtarfiles) {
 424   dotar("$dir/$debtarfile", $tardir, \%debtarorigin, $origtarfile, @{$debtarcontent{$debtarfile} });
 425 }
 426
 427 for my $file (grep {/^debian\./} @dir) {
 428   next if $file eq 'debian.series';
 429   next if $file =~ /\.tar$/;
 430   next if $file =~ /\.tar\./;
 431   dofile("$dir/$file", $tardir, 'debian/'.substr($file, 7), $origtarfile);
 432 }
 433
 434 if ($tags->{'DEBTRANSFORM-SERIES'}) {
 435   doseries("$dir/$tags->{'DEBTRANSFORM-SERIES'}", $tardir);
 436 } elsif ($dir{"debian.series"}) {
 437   doseries("$dir/debian.series", $tardir);
 438 } elsif ($dir{"patches.series"}) {
 439   doseries("$dir/patches.series", $tardir);
 440 }
 441
 442 close(DIFF);
 443
 444 if (! -s "$out/${name}_$version.diff") {
 445   unlink("$out/${name}_$version.diff");
 446 } else {
 447   system('gzip', '-9', "$out/${name}_$version.diff");
 448   if (-f "$out/${name}_$version.diff.gz") {
 449     push @files, addfile("$out/${name}_$version.diff.gz");
 450   } else {
 451     push @files, addfile("$out/${name}_$version.diff");
 452   }
 453 }
 454
 455 $tags->{'FILES'} = "\n".join("\n", @files);
 456 delete $tags->{'DEBTRANSFORM-SERIES'};
 457 delete $tags->{'DEBTRANSFORM-TAR'};
 458 delete $tags->{'DEBTRANSFORM-FILES-TAR'};
 459 delete $tags->{'DEBTRANSFORM-FILES'};
 460 delete $tags->{'DEBTRANSFORM-RELEASE'};
 461 writedsc("$out/${name}_$version.dsc", $tags);
 462
 463 if( $debug ) {
 464   print `ls -la $out`;
 465   print `cat $out/${name}_$version.dsc`;
 466   print `zcat $out/${name}_$version.diff.gz`;
 467 }
 468
 469 exit(0);