# Hey emacs! This is a -*- Perl -*- script!
# Util -- Perl utility functions for lintian

# Copyright (C) 1998 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., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.

package Util;
use strict;

use Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(parse_dpkg_control
	read_dpkg_control
	get_deb_info
	get_dsc_info
	slurp_entire_file
	get_file_md5
	file_is_encoded_in_non_utf8
	fail
	system_env
	perm2oct);

use FileHandle;
use Pipeline;
use Digest::MD5;

# general function to read dpkg control files
# this function can parse output of `dpkg-deb -f', .dsc,
# and .changes files (and probably all similar formats)
# arguments:
#    $filehandle 
#    $debconf_flag (true if the file is a debconf template file)
# output:
#    list of hashes
#    (a hash contains one sections,
#    keys in hash are lower case letters of control fields)
sub parse_dpkg_control {
    my ($CONTROL, $debconf_flag) = @_;

    my @data;
    my $cur_section = 0;
    my $open_section = 0;
    my $last_tag;

    while (<$CONTROL>) {
	chomp;

	# tabs at the beginning are illegal, but handle them anyways
	s/^\t/ \t/o;
	next if /^#/; #comment line?

	# empty line?
	if ((!$debconf_flag && m/^\s*$/) or 
	    ($debconf_flag && m/^$/)) {
	    if ($open_section) { # end of current section
		$cur_section++;
		$open_section = 0;
	    }
	}
	# pgp sig?
	elsif (m/^-----BEGIN PGP SIGNATURE/) { # skip until end of signature
	    while (<$CONTROL>) {
		last if m/^-----END PGP SIGNATURE/o;
	    }
	}
	# other pgp control?
	elsif (m/^-----BEGIN PGP/) { # skip until the next blank line
	    while (<$CONTROL>) {
		last if /^\s*$/o;
	    }
	}
	# new empty field?
	elsif (m/^(\S+):\s*$/o) {
	    $open_section = 1;

	    my ($tag) = (lc $1);
	    $data[$cur_section]->{$tag} = '';

	    $last_tag = $tag;
	}
	# new field?
	elsif (m/^(\S+):\s*(.*)$/o) {
	    $open_section = 1;

	    my ($tag,$value) = (lc $1,$2);
	    $data[$cur_section]->{$tag} = $value;

	    $last_tag = $tag;
	}
	# continued field?
	elsif (m/^ (.*)$/o) {
	    $open_section or fail("syntax error in section $cur_section after the tag $last_tag: $_");

	    $data[$cur_section]->{$last_tag} .= "\n".$1;
	}
    }

    return @data;
}

sub read_dpkg_control {
    my ($file, $debconf_flag) = @_;

    if (not _ensure_file_is_sane($file)) {
	return undef;
    }

    my $CONTROL = FileHandle->new;
    open($CONTROL,'<',$file)
	or fail("cannot open control file $file for reading: $!");
    my @data = parse_dpkg_control($CONTROL, $debconf_flag);
    close($CONTROL)
	or fail("pipe for control file $file exited with status: $?");
    return @data;
}

sub get_deb_info {
    my ($file) = @_;

    if (not _ensure_file_is_sane($file)) {
	return undef;
    }

    # `dpkg-deb -f $file' is very slow. Instead, we use ar and tar.
    my $CONTROL = FileHandle->new;
    pipeline_open($CONTROL,
		  (sub { exec 'ar', 'p', $file, 'control.tar.gz' }),
		  (sub { exec 'tar', '--wildcards', '-xzO', '-f', '-', '*control' }))
	or fail("cannot fork to unpack $file: $!\n");
    my @data = parse_dpkg_control($CONTROL);
    close($CONTROL) or fail("broken input pipe for unpacking $file: $!");
    return $data[0];
}

sub get_dsc_info {
    my ($file) = @_;

    if (not _ensure_file_is_sane($file)) {
	return undef;
    }

    my @data = read_dpkg_control($file);
    return $data[0];
}

sub _ensure_file_is_sane {
    my ($file) = @_;

    # if file exists and is not 0 bytes
    if (-f $file and -s $file) {
	return 1;
    }
    return 0;
}

sub slurp_entire_file {
    my $file = shift;
    open(C,$file)
	or fail("cannot open file $file for reading: $!");
    my $save = $/;
    undef $/;
    local $_ = <C>;
    $/ = $save;
    close(C);
    return $_;
}

sub get_file_md5 {
	my $file = shift;
	open FILE, $file or fail("Couldn't open $file");
	my $md5 = Digest::MD5->new;
	$md5->addfile(*FILE);
	close FILE or fail("Couldn't close $file");
	return $md5->hexdigest;
}

sub file_is_encoded_in_non_utf8 {
	my ($file, $type, $pkg) = @_;
	my $non_utf8 = 0;
	
	open ICONV, "env LANG=C iconv -f utf8 -t utf8 \Q$file\E 2>&1 |"
	    or fail("failure while checking encoding of $file for $type package $pkg");
	my $line = 1;
	while (<ICONV>) {
		if (m/iconv: illegal input sequence at position \d+$/) {
			$non_utf8 = 1;
			last;
		}
		$line++
	}
	close ICONV;

	return $line if $non_utf8;
	return 0;
}

# Just like system, except cleanses the environment first to avoid any strange
# side effects due to the user's environment.
sub system_env {
    my @whitelist = qw(PATH INTLTOOL_EXTRACT);
    my %newenv = map { exists $ENV{$_} ? ($_ => $ENV{$_}) : () } @whitelist;
    my $pid = fork;
    if (not defined $pid) {
	return -1;
    } elsif ($pid == 0) {
	%ENV = %newenv;
	exec @_ or die("exec of $_[0] failed: $!\n");
    } else {
	waitpid $pid, 0;
	return $?;
    }
}

# Translate permission strings like `-rwxrwxrwx' into an octal number.
sub perm2oct {
    my ($t) = @_;

    my $o = 0;

    $t =~ m/^.(.)(.)(.)(.)(.)(.)(.)(.)(.)/o;

    $o += 00400 if $1 eq 'r';	# owner read
    $o += 00200 if $2 eq 'w';	# owner write
    $o += 00100 if $3 eq 'x';	# owner execute
    $o += 04000 if $3 eq 'S';	# setuid
    $o += 04100 if $3 eq 's';	# setuid + owner execute
    $o += 00040 if $4 eq 'r';	# group read
    $o += 00020 if $5 eq 'w';	# group write
    $o += 00010 if $6 eq 'x';	# group execute
    $o += 02000 if $6 eq 'S';	# setgid
    $o += 02010 if $6 eq 's';	# setgid + group execute
    $o += 00004 if $7 eq 'r';	# other read
    $o += 00002 if $8 eq 'w';	# other write
    $o += 00001 if $9 eq 'x';	# other execute
    $o += 01000 if $9 eq 'T';	# stickybit
    $o += 01001 if $9 eq 't';	# stickybit + other execute

    return $o;
}

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

sub fail {
    my $str = "internal error";
    if (@_) {
	$str .= ": ".join( "\n", @_)."\n";
    } elsif ($!) {
	$str .= ": $!\n";
    } else {
	$str .= ".\n";
    }
    $! = 2; # set return code outside eval()
    die $str;

}

1;