Removing frog.

[maemian] / unpack / unpack-srcpkg-l1

#!/usr/bin/perl
# unpack-srcpkg-l1 -- maemian unpack script (source packages level 1)
#
# syntax: unpack-srcpkg-l1 <base-dir> <dsc-file>
#
# Note, that <dsc-file> must be specified with absolute path.

# Copyright (C) 1998 Christian Schwarz
# Copyright (C) 2009 Raphael Geissert
# Copyright (C) 2009 Russ Allbery
#
# 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.

use strict;
use vars qw($verbose);

($#ARGV == 1) or die "syntax: unpack-srcpkg-l1 <base-dir> <dsc-file>";
my $base_dir = shift;
my $file = shift;

# import perl libraries
use lib "$ENV{'MAEMIAN_ROOT'}/lib";
use Util;

use File::Spec;
use Maemian::Command qw(spawn reap);

# stat $file
(my @stat = stat $file) or fail("$file: cannot stat: $!");

# get package control information
my $data = get_dsc_info($file);

# create directory in lab
print "N: Creating directory $base_dir ...\n" if $verbose;
mkdir("$base_dir", 0777) or fail("mkdir $base_dir: $!");
mkdir("$base_dir/fields", 0777) or fail("mkdir $base_dir/fields: $!");

# create control field files
for my $field (keys %$data) {
    my $field_file = "$base_dir/fields/$field";
    open(F, '>', $field_file)
        or fail("cannot open file $field_file for writing: $!");
    print F $data->{$field},"\n";
    close(F);
}

# Install symbolic links to source package files.  Version handling is based
# on Dpkg::Version::parseversion.
my (undef, $dir, $name) = File::Spec->splitpath($file);
my $version = $data->{'version'};
if ($version =~ /:/) {
    $version =~ s/^(?:\d+):(.+)/$1/ or fail("bad version number '$version'");
}
my $baserev = $data->{'source'} . '_' . $version;
$version =~ s/(.+)-(.*)$/$1/;
my $base = $data->{'source'} . '_' . $version;
symlink($file,"$base_dir/dsc") or fail("cannot symlink dsc file: $!");
my $tarball;
for my $fs (split(/\n/,$data->{'files'})) {
    $fs =~ s/^\s*//;
    next if $fs =~ /^$/o;
    my @t = split(/\s+/o,$fs);
    if ($t[2] =~ /^(\Q$base\E\.orig|\Q$baserev\E)\.tar\.(gz|bz2|lzma)$/) {
        $tarball = $t[2];
    }
    symlink("$dir/$t[2]", "$base_dir/$t[2]")
        or fail("cannot symlink file $t[2]: $!");
}
if (!$tarball) {
    fail("could not find the source tarball");
}

# Collect a list of the files in the source package.  tar currently doesn't
# automatically recognize LZMA, so we need to add the option where it's
# needed.  Change hard link status (h) to regular files and remove a leading
# ./ prefix on filenames while we're reading the tar output.  We intentionally
# don't parallelize this job because we need to use the output below.
my @tar_options = ('-tvf');
if ($tarball =~ /\.lzma\z/) {
    unshift(@tar_options, '--lzma');
}
my @index;
my $last = '';
my $collect = sub {
    my @lines = map { split "\n" } @_;
    if ($last ne '') {
        $lines[0] = $last . $lines[0];
    }
    if ($_[-1] !~ /\n\z/) {
        $last = pop @lines;
    } else {
        $last = '';
    }
    for my $line (@lines) {
        $line =~ s/^h/-/;
        if ($line and $line !~ m,^(?:\S+\s+){5}\./$,) {
            push(@index, $line . "\n");
        }
    }
};
spawn({ fail => 'never', out => $collect, err => "$base_dir/index-errors" },
      ["tar", @tar_options, "$base_dir/$tarball"]);
if ($last) {
    fail("tar output doesn't end in a newline");
}

# We now need to see if all files in the tarball have a common prefix.  If so,
# we're going to strip that prefix off each file name.  We also remove lines
# that consist solely of the prefix.
my $prefix;
for my $line (@index) {
    my ($file) = ($line =~ /^(?:\S+\s+){5}(.*)/);
    $file =~ s,^\./+,,;
    my ($dir) = ($file =~ m,^([^/]+),);
    if (defined($dir) and $dir eq $file and not $line =~ /^d/) {
        $prefix = '';
    } elsif (defined $dir) {
        if (not defined $prefix) {
            $prefix = $dir;
        } elsif ($dir ne $prefix) {
            $prefix = '';
        }
    } else {
        $prefix = '';
    }
}
if ($prefix) {
    @index = map {
        s,^((?:\S+\s+){5})(?:\./+)?\Q$prefix\E(?:/+|\Z),$1,;
        if (/^(?:\S+\s+){5}\S+/) {
            $_;
        } else {
            ();
        }
    } @index;
    open(PREFIX, '>', "$base_dir/source-prefix")
        or fail("cannot create $base_dir/source-prefix: $!");
    print PREFIX "$prefix\n";
    close PREFIX;
}

# Now that we have the file names we want, write them out sorted to the index
# file.
my $job = { fail => 'error', out => "$base_dir/index" };
spawn($job, sub { print @index }, '|', ['sort', '-k', '6'], '&');

# Create symbolic links to binary packages
mkdir("$base_dir/binary", 0777) or fail("mkdir $base_dir/binary: $!");
for my $bin (split(/,\s+/o,$data->{'binary'})) {
    symlink("../../../binary/$bin", "$base_dir/binary/$bin")
        or fail("cannot symlink binary package $bin: $!");
}

# Wait for all jobs to finish.
reap($job);

exit 0;