2 # unpack-srcpkg-l1 -- maemian unpack script (source packages level 1)
4 # syntax: unpack-srcpkg-l1 <base-dir> <dsc-file>
6 # Note, that <dsc-file> must be specified with absolute path.
8 # Copyright (C) 1998 Christian Schwarz
9 # Copyright (C) 2009 Raphael Geissert
10 # Copyright (C) 2009 Russ Allbery
12 # This program is free software; you can redistribute it and/or modify
13 # it under the terms of the GNU General Public License as published by
14 # the Free Software Foundation; either version 2 of the License, or
15 # (at your option) any later version.
17 # This program is distributed in the hope that it will be useful,
18 # but WITHOUT ANY WARRANTY; without even the implied warranty of
19 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 # GNU General Public License for more details.
22 # You should have received a copy of the GNU General Public License
23 # along with this program. If not, you can find it on the World Wide
24 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
25 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
29 use vars qw($verbose);
31 ($#ARGV == 1) or die "syntax: unpack-srcpkg-l1 <base-dir> <dsc-file>";
35 # import perl libraries
36 use lib "$ENV{'MAEMIAN_ROOT'}/lib";
40 use Maemian::Command qw(spawn reap);
43 (my @stat = stat $file) or fail("$file: cannot stat: $!");
45 # get package control information
46 my $data = get_dsc_info($file);
48 # create directory in lab
49 print "N: Creating directory $base_dir ...\n" if $verbose;
50 mkdir("$base_dir", 0777) or fail("mkdir $base_dir: $!");
51 mkdir("$base_dir/fields", 0777) or fail("mkdir $base_dir/fields: $!");
53 # create control field files
54 for my $field (keys %$data) {
55 my $field_file = "$base_dir/fields/$field";
56 open(F, '>', $field_file)
57 or fail("cannot open file $field_file for writing: $!");
58 print F $data->{$field},"\n";
62 # Install symbolic links to source package files. Version handling is based
63 # on Dpkg::Version::parseversion.
64 my (undef, $dir, $name) = File::Spec->splitpath($file);
65 my $version = $data->{'version'};
66 if ($version =~ /:/) {
67 $version =~ s/^(?:\d+):(.+)/$1/ or fail("bad version number '$version'");
69 my $baserev = $data->{'source'} . '_' . $version;
70 $version =~ s/(.+)-(.*)$/$1/;
71 my $base = $data->{'source'} . '_' . $version;
72 symlink($file,"$base_dir/dsc") or fail("cannot symlink dsc file: $!");
74 for my $fs (split(/\n/,$data->{'files'})) {
77 my @t = split(/\s+/o,$fs);
78 if ($t[2] =~ /^(\Q$base\E\.orig|\Q$baserev\E)\.tar\.(gz|bz2|lzma)$/) {
81 symlink("$dir/$t[2]", "$base_dir/$t[2]")
82 or fail("cannot symlink file $t[2]: $!");
85 fail("could not find the source tarball");
88 # Collect a list of the files in the source package. tar currently doesn't
89 # automatically recognize LZMA, so we need to add the option where it's
90 # needed. Change hard link status (h) to regular files and remove a leading
91 # ./ prefix on filenames while we're reading the tar output. We intentionally
92 # don't parallelize this job because we need to use the output below.
93 my @tar_options = ('-tvf');
94 if ($tarball =~ /\.lzma\z/) {
95 unshift(@tar_options, '--lzma');
100 my @lines = map { split "\n" } @_;
102 $lines[0] = $last . $lines[0];
104 if ($_[-1] !~ /\n\z/) {
109 for my $line (@lines) {
111 if ($line and $line !~ m,^(?:\S+\s+){5}\./$,) {
112 push(@index, $line . "\n");
116 spawn({ fail => 'never', out => $collect, err => "$base_dir/index-errors" },
117 ["tar", @tar_options, "$base_dir/$tarball"]);
119 fail("tar output doesn't end in a newline");
122 # We now need to see if all files in the tarball have a common prefix. If so,
123 # we're going to strip that prefix off each file name. We also remove lines
124 # that consist solely of the prefix.
126 for my $line (@index) {
127 my ($file) = ($line =~ /^(?:\S+\s+){5}(.*)/);
129 my ($dir) = ($file =~ m,^([^/]+),);
130 if (defined($dir) and $dir eq $file and not $line =~ /^d/) {
132 } elsif (defined $dir) {
133 if (not defined $prefix) {
135 } elsif ($dir ne $prefix) {
144 s,^((?:\S+\s+){5})(?:\./+)?\Q$prefix\E(?:/+|\Z),$1,;
145 if (/^(?:\S+\s+){5}\S+/) {
151 open(PREFIX, '>', "$base_dir/source-prefix")
152 or fail("cannot create $base_dir/source-prefix: $!");
153 print PREFIX "$prefix\n";
157 # Now that we have the file names we want, write them out sorted to the index
159 my $job = { fail => 'error', out => "$base_dir/index" };
160 spawn($job, sub { print @index }, '|', ['sort', '-k', '6'], '&');
162 # Create symbolic links to binary packages
163 mkdir("$base_dir/binary", 0777) or fail("mkdir $base_dir/binary: $!");
164 for my $bin (split(/,\s+/o,$data->{'binary'})) {
165 symlink("../../../binary/$bin", "$base_dir/binary/$bin")
166 or fail("cannot symlink binary package $bin: $!");
169 # Wait for all jobs to finish.