vcs.maemo.org Git - maemian/blob - nokia-lintian/unpack/unpack-srcpkg-l1

   1 #!/usr/bin/perl
   2 # unpack-srcpkg-l1 -- lintian unpack script (source packages level 1)
   3 #
   4 # syntax: unpack-srcpkg-l1 <base-dir> <dsc-file>
   5 #
   6 # Note, that <dsc-file> must be specified with absolute path.
   7
   8 # Copyright (C) 1998 Christian Schwarz
   9 #
  10 # This program is free software; you can redistribute it and/or modify
  11 # it under the terms of the GNU General Public License as published by
  12 # the Free Software Foundation; either version 2 of the License, or
  13 # (at your option) any later version.
  14 #
  15 # This program is distributed in the hope that it will be useful,
  16 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 # GNU General Public License for more details.
  19 #
  20 # You should have received a copy of the GNU General Public License
  21 # along with this program.  If not, you can find it on the World Wide
  22 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  23 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  24 # MA 02110-1301, USA.
  25
  26 use strict;
  27 use vars qw($verbose);
  28
  29 ($#ARGV == 1) or die "syntax: unpack-srcpkg-l1 <base-dir> <dsc-file>";
  30 my $base_dir = shift;
  31 my $file = shift;
  32
  33 # import perl libraries
  34 use lib "$ENV{'LINTIAN_ROOT'}/lib";
  35 use Util;
  36
  37 use File::Basename;
  38
  39 # stat $file
  40 (my @stat = stat $file) or fail("$file: cannot stat: $!");
  41
  42 # get package control information
  43 my $data = get_dsc_info($file);
  44
  45 # create directory in lab
  46 print "N: Creating directory $base_dir ...\n" if $verbose;
  47 mkdir("$base_dir", 0777) or fail("mkdir $base_dir: $!");
  48 mkdir("$base_dir/fields", 0777) or fail("mkdir $base_dir/fields: $!");
  49
  50 # create control field files
  51 for my $field (keys %$data) {
  52   my $field_file = "$base_dir/fields/$field";
  53   open(F, '>', $field_file) or fail("cannot open file $field_file for writing: $!");
  54   print F $data->{$field},"\n";
  55   close(F);
  56 }
  57
  58 # Install symbolic links to source package files
  59 my $dir = dirname($file);
  60 my $name = basename($file);
  61 symlink($file,"$base_dir/dsc") or fail("cannot symlink dsc file: $!");
  62 for my $fs (split(/\n/,$data->{'files'})) {
  63   next if $fs =~ /^\s*$/o;
  64   my @t = split(/\s+/o,$fs);
  65   symlink("$dir/$t[2]","$base_dir/$t[2]") or fail("cannot symlink file $t[2]: $!");
  66 }
  67
  68 # Create symbolic links to binary packages
  69 mkdir("$base_dir/binary", 0777) or fail("mkdir $base_dir/binary: $!");
  70 for my $bin (split(/,\s+/o,$data->{'binary'})) {
  71   symlink("../../../binary/$bin", "$base_dir/binary/$bin") or fail("cannot symlink binary package $bin: $!");
  72 }
  73
  74 exit 0;