#!/usr/bin/perl
# changelog-file -- lintian check script

# Copyright (C) 1998 by Christian Schwarz
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
# 
# 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.  If not, you can find it on the World Wide
# Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
# Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
# MA 02111-1307, USA.

($#ARGV == 1) or fail("syntax: changelog-file <pkg> <type>");
$pkg = shift;
$type = shift;

$ppkg = quotemeta($pkg);

# Read file info...
open(IN,"file-info") or fail("cannot find file-info for $type package $pkg");
while (<IN>) {
  chop;
  
  /^(.*?):\s+(.*)$/o or fail("syntax error in file-info file: $_");
  my ($file,$info) = ($1,$2);

  next unless $file =~ /doc/o;

  $file_info{$file} = $info;
}
close(IN);

# Modify the file_info by following symbolic links.
for $file (keys %file_info) {
    if ($file_info{$file} =~ m/^symbolic link to (.*)/) {
	# Figure out the link destination.  This algorithm is
	# not perfect but should be good enough.  (If it fails,
	# all that happens is that an evil symlink causes a bogus warning).
	my $link = $1;
	if ($link =~ /^\//) {
	    # absolute path; replace
	    $newfile = $link;
	} else {
	    $newfile = $file;         # relative path; base on $file 
	    $newfile =~ s,/[^/]+$,,;   # strip final pathname component
	    # strip another component for every leading ../ in $link
	    while ($link =~ m,^\.\./,) {
		$newfile =~ s,/[^/]+$,,;
		$link =~ s,^\.\./,,;
	    }
	    # concatenate the results
	    $newfile .= '/' . $link;
	}
	if (exists $file_info{$newfile}) {
	    $file_info{$file} = $file_info{$newfile};
	}
    }
}

# Read package contents...
open(IN,"index") or fail("cannot open index file index: $!");
while (<IN>) {
  chop;

  # skip packages which have a /usr/doc/$pkg -> foo symlink
  if (m, usr/doc/$ppkg -> ,o) {
    exit 0;
  }

  # we are only interested in files or symlinks in /usr/doc/$pkg
  next unless m,^(\S+).*usr/doc/$ppkg/([^/\s]+)( -> [^/\s]+)?$,o;
  my ($perm,$file) = ($1,$2);

  push(@doc_files,$file);
  $perm{$file} = $perm;
}
close(IN);

# ignore packages which don't have a /usr/doc/$pkg directory, since
# the copyright check will complain about this
if ($#doc_files < 0) {
  exit 0;
}

# check if changelog files are compressed with gzip -9
for (@doc_files) {
  # This used to check for m/change/i, but I tightened it because
  # section 5.8 does not mention other changelog files.  See the
  # TODO list for suggested policy changes.
  next unless m/^changelog(\.gz)?$|changelog.debian(\.gz)?$/i;

  $file = "usr/doc/$pkg/$_";

  if (not m/\.gz$/) {
    print "E: $pkg $type: changelog-file-not-compressed $file\n";
  } elsif ($file_info{$file} !~ /max compression/o) {
    print "E: $pkg $type: changelog-not-compressed-with-max-compression $file\n"
  }
}

# is this a native Debian package?
open(IN,"fields/version") or fail("cannot open fields/version file for reading: $!");
chop($version = <IN>);
close(IN);
$native_pkg = ($version !~ m,-,);

if ($native_pkg) {
  # native Debian package
  if (grep /^changelog(\.gz)?$/,@doc_files) {
    # everything is fine
  } elsif (@foo = grep /^changelog\.debian(\.gz)$/i,@doc_files) {
    print "W: $pkg $type: wrong-name-for-changelog-of-native-package usr/doc/$pkg/$foo[0]\n";
  } else {
    print "E: $pkg $type: changelog-file-missing-in-native-package\n";
  }
} else {
  # non-native (foreign :) Debian package
  
  # 1. check for upstream changelog
  if (grep /^changelog(\.gz)?$/,@doc_files) {
    # everything is fine
  } else {
    # search for changelogs with wrong file name
    my $found = 0;
    for (@doc_files) {
      if (/^change/i and not /debian/i) {
	print "W: $pkg $type: wrong-name-for-upstream-changelog usr/doc/$pkg/$_\n";
	$found = 1;
	last;
      }
    }
    if (not $found) {
      # This tag is disabled for now since a lot of packages fail this
      # aspect of policy and I want to clarify policy WRT multi-binary
      # packages first.
      #print "W: $pkg $type: no-upstream-changelog\n";
    }
  }

  # 2. check for Debian changelog
  if (grep /^changelog\.Debian(\.gz)?$/,@doc_files) {
    # everything is fine
  } elsif (@foo = grep /^changelog\.debian(\.gz)?$/i,@doc_files) {
    print "W: $pkg $type: wrong-name-for-debian-changelog-file usr/doc/$pkg/$foo[0]\n";
  } else {
    print "E: $pkg $type: debian-changelog-file-missing\n";
  }
}

exit 0;

# ---------------------------------------------------

sub fail {
  if ($_[0]) {
    print STDERR "error: $_[0]\n";
  } elsif ($!) {
    print STDERR "error: $!\n";
  } else {
    print STDERR "error.\n";
  }
  exit 1;
}
