--- /dev/null
+#!/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;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 ts=4 et shiftround
projects / maemian / blobdiff