TEST INSTANCE of openSUSE Build Service

Overview Repositories Revisions Requests Users Attributes Meta

File changelog2spec of Package build

#!/usr/bin/perl -w

#
# Convert a SUSE or Debian changelog file to rpm format
#

################################################################
#
# Copyright (c) 1995-2014 SUSE Linux Products GmbH
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License version 2 or 3 as
# published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program (see the file COPYING); if not, write to the
# Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA
#
################################################################

BEGIN {
  unshift @INC, ($::ENV{'BUILD_DIR'} || '/usr/lib/build');
}

use Date::Parse;
use Time::Zone;

use strict;

my @wday = qw{Sun Mon Tue Wed Thu Fri Sat};
my @mon = qw{Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec};

my $ok;
my $zone;
my $test;
my $fulltimestamps;
my $emailonly;
my $printtype;
my $input = '';
my $target = 'rpm';

while (@ARGV) {
  if ($ARGV[0] eq '--selftest') {
    shift;
    print map_changes(@ARGV);
    exit 0;
  }
  if ($ARGV[0] eq '--test') {
    $test = 1;
    shift @ARGV;
    next;
  }
  if ($ARGV[0] eq '--type') {
    $printtype = 1;
    shift @ARGV;
    next;
  }
  if ($ARGV[0] eq '--fulltimestamps') {
    $fulltimestamps = 1;
    shift @ARGV;
    next;
  }
  if (@ARGV > 1 && $ARGV[0] eq '--target') {
    shift @ARGV;
    $target = shift @ARGV;
    next;
  }
  if ($ARGV[0] eq '--emailonly') {
    $emailonly = 1;
    shift @ARGV;
    next;
  }
  last;
}

if (@ARGV == 2 && $ARGV[0] eq '--file') {
  die("bad --file arg\n") unless $ARGV[1] =~ /^(.*)\/([^\/]+)$/;
  my ($dir, $file) = ($1, $2);
  $file =~ s/\.(?:spec|dsc)$//;
  opendir(D, $dir) || die("$dir: $!\n");
  my @changes = grep {/\.changes$/} readdir(D);
  closedir(D);
  my $changesfile=map_changes($file, @changes);
  exit(1) unless $changesfile;
  @ARGV = ("$dir/$changesfile");
}

sub map_changes
{
  my ($file, @changes) = @_;
  @changes = sort {length($a) <=> length($b) || $a cmp $b} @changes;
  # support _service: prefixes, they need to be stripped
  $file =~ s/^_service:.*://;
  my %changes = map {/^((?:_service:.*:)?(.*?))$/ ? ($2, $1) : ($_, $_)} @changes;
  @changes = keys %changes;
  return undef unless @changes;	# nothing to do
  @changes = sort {length($a) <=> length($b) || $a cmp $b} @changes;
  if (@changes > 1) {
    while ($file ne '') {
      my @c = grep {/\Q${file}.changes\E/} @changes;
      if (@c) {
	@changes = @c;
	last;
      }
      last unless $file =~ s/[-.][^-.]*$//;
    }
  }
  return $changes{$changes[0]};
}

sub parse_suse {
  $_ = $_[0];

my $dline;
  die("bad changelog heading\n") unless /^(?:\* )?([A-Za-z]+\s+[A-Za-z]+\s+[0-9][^-]*?[0-9][0-9][0-9][0-9])(.*\@.*$)/;
  my $dt = $1;
  my $who = $2;
  $dt = lc($dt);
  $who =~ s/^\s+//;
  $who =~ s/^-\s*//;
  $who = $1 if $emailonly && $who =~ /\<(.*)\>/;
  $dt =~ /([0-9][0-9][0-9][0-9])/;
  $dline = $_;
  my $year = $1;
  if (!defined($zone) && $dt =~ /\s([a-z]{3,4})(dst)?\s[0-9]{4}/) {
    my $dst = $2;
    $zone = tz_offset($1);
    $zone += 3600 if defined($zone) && $dst;
  }
  my $tdt = str2time($dt);
  $dt =~ /([0-9]+)/;
  my $day = $1;
  if (!$tdt) {
    if ($dt =~ /([a-z]{3})\s+([a-z]{3})/) {
      $tdt = str2time("$1 $2 $day $year");
    }
  }
  if (!$tdt) {
    if ($dt =~ /([a-z]{3})/) {
      $tdt = str2time("$1 $day $year");
    }
  }
  if (!$tdt) {
    $tdt = str2time("$year-1-1");
  }
  $tdt += 12 * 3600 unless $dt =~ /\d:\d/;	# 12:00 if not specified
  $tdt += ($zone || 0);
  my $ok = 1;
  my $change = '';
  while(<>) {
    chomp;
    last if /^(?:\* )?([A-Za-z]+\s+[A-Za-z]+\s+[0-9][^-]*?[0-9][0-9][0-9][0-9])(.*\@.*$)/;
    next if (/^--------------/);
    next if (/^========================/);
    s/\s+$//;
    next if $_ eq '';
    s/^\s*-/-/ if $ok == 1;	# obsolete?
    s/^\s*\*\s*/  * /;
    if (!/^-/) {
      s/^\s+-\s*/  - /;
      s/^\s*/  / unless s/^    \s*/    /;
    }
    $change .= "$_\n";
    $ok = 2;
  }
  return ($_, $tdt, $dline, $who, $change);
}

sub parse_debian {
  $_ = $_[0];

die("bad line: $_\n") unless /^(\w[-+0-9a-z.]*) $([^\($ \t]+)\)((\s+[-+0-9a-z.]+)+)\;.*$/;
  my $package = $1;
  my $version = $2;
  my $distribution = $3;
  my $who;
  my $date;
  my $changes = "- version $version\n";
  while(<>) {
    chomp;
    s/\s+$//;
    next if $_ eq '';
    if (/^ --/) {
      die("bad maintainer line\n") unless /^ \-\- (.* <.*>)  (.*)$/;
      $who = $1;
      $date = $2;
      last;
    }
    die("bad change details line: $_\n") unless s/^  //;
    s/^\*/-/;
    s/\s*$closes:\s*(?:bug)?\#?\s?\d+(?:,\s*(?:bug)?\#?\s?\d+)*$//i;
    s/\s+$//;
    next if $_ eq '';
    $changes .= "$_\n";
  }
  die("no maintainer line in last entry\n") unless defined $date;
  if (!defined($zone) && ($date =~ /([-+])(\d\d)(\d\d)$/)) {
    $zone = 60 * ($3 + 60 * $2);
    $zone = -$zone if $1 eq '-';
  }
  my $tdt = str2time($date);
  return ('', $tdt, $_, $who, $changes);
}

my $format;
while (<>) {
  chomp;
  next if /^\s*$/;
  next if (/^--------------/);
  next if (/^========================/);
  if (/^(?:\* )?([A-Za-z]+\s+[A-Za-z]+\s+[0-9][^-]*?[0-9][0-9][0-9][0-9])(.*\@.*$)/) {
    # suse :    * Fri Jun 07 2013 First Last <first.last@example.com>
    # tizen:    * Fri Jun 07 2013 First Last <first.last@example.com> tagname@commitid
    $format = 'suse';
  } elsif (/^(\w[-+0-9a-z.]*) $([^\($ \t]+)\)((\s+[-+0-9a-z.]+)+)\;.*$/) {
    $format = 'debian';
  } else {
    die("unknown changelog format\n");
  }
  last;
}
exit(0) unless $format;

if ($printtype) {
  print "$format\n";
  exit(0);
}

if ($target eq $format) {
  print "$_\n";
  while (<>) {
    print $_;
  }
  exit(0);
}

die("don't know how to convert changelog to format '$target'\n") if $target ne 'rpm';

my ($lastt, $t, $dline, $who, $changes);
while(defined($_)) {
  if (/^\s*$/) {
    $_ = <>;
    last unless $_;
    chomp;
    next;
  }
  if ($format eq 'suse') {
    ($_, $t, $dline, $who, $changes) = parse_suse($_);
  } elsif ($format eq 'debian') {
    ($_, $t, $dline, $who, $changes) = parse_debian($_);
  }
  if (defined($lastt) && $lastt < $t) {
    die("changes file not incremental: $dline\n") if $test;
    warn("changes file not incremental: $dline\n");
  }
  $lastt = $t;
  my @gm = gmtime($t);
  # silly rpm can't hande dates < 1997, so we fold everything to
  # Thu Jan 02 1997
  @gm = (0, 0, 0, 2, 0, 97, 4) if $gm[5] < 97 || ($gm[5] == 97 && $gm[4] == 0 && $gm[3] <= 1);
  $gm[6] = $wday[$gm[6]];
  $gm[5] += 1900;
  $gm[4] = $mon[$gm[4]];
  if($fulltimestamps) {
    printf("* %s %s %2d %02d:%02d:%02d UTC %4d %s\n", @gm[6,4,3,2,1,0,5], $who);
  } else {
    printf("* %s %s %2d %4d %s\n", @gm[6,4,3,5], $who);
  }
  $changes =~ s/%/%%/g;
  $changes =~ s/^(\s*)%%(\S*)/$1\[%%$2\]/;
  $changes =~ s/^(\s*)(\#\d*)/$1\[$2\]/mg;
  $changes =~ s/^\*/  */mg;
  print $changes;
}
exit(0);

Places

File changelog2spec of Package build

Places