vcs.maemo.org Git - maemian/blob - nokia-lintian/lib/Lab.pm

   1 # Lab -- Perl laboratory functions for lintian
   2 # $Id$
   3
   4 # Copyright (C) 1998-2004 Various authors
   5 #
   6 # This program is free software; you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation; either version 2 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program.  If not, you can find it on the World Wide
  18 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  19 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  20 # MA 02110-1301, USA.
  21
  22 package Lab;
  23 use strict;
  24
  25 use Pipeline;
  26 use Util;
  27
  28 use File::Temp;
  29
  30 # Quiet "Name "main::LINTIAN_ROOT" used only once"
  31 # The variables comes from 'lintian'
  32 () = ($main::LINTIAN_ROOT, $main::verbose, $main::debug);
  33
  34 my $LINTIAN_ROOT = $main::LINTIAN_ROOT;
  35
  36 # Can also be more precise later on (only verbose with lab actions) but for
  37 # now this will do --Jeroen
  38 my $verbose = $main::verbose;
  39 my $debug   = $main::debug;
  40
  41 sub new {
  42     my ( $class, $dir, $dist ) = @_;
  43
  44     my $self = {};
  45     bless $self, $class;
  46
  47     $self->setup( $dir, $dist );
  48     return $self;
  49 }
  50
  51
  52 sub is_lab {
  53     my ( $self ) = @_;
  54
  55     return unless $self->{dir};
  56     return -d "$self->{dir}/binary"
  57         && -d "$self->{dir}/udeb"
  58         && -d "$self->{dir}/source"
  59         && -d "$self->{dir}/info";
  60 }
  61
  62 sub setup {
  63     my ( $self, $dir, $dist ) = @_;
  64
  65     if ( $dir ) {
  66         $self->{mode} = 'static';
  67         $self->{dir} = $dir;
  68         $self->{dist} = $dist;
  69     } else {
  70         $self->{mode} = 'temporary';
  71
  72         my $created = 0;
  73         for (1..10) {
  74             $dir = tmpnam();
  75
  76             if ($self->setup_force( $dir, $dist )) {
  77                 $created = 1;
  78                 last;
  79             }
  80         }
  81         unless ($created) {
  82             fail("cannot create lab directory $dir");
  83         }
  84     }
  85
  86     return 1;
  87 }
  88
  89 sub setup_static {
  90     my ( $self ) = @_;
  91
  92     unless ( $self->{mode} eq 'static' and $self->{dir} ) {
  93         print STDERR "no laboratory specified (need to define LINTIAN_LAB)";
  94         return 0;
  95     }
  96
  97     return $self->setup_force( $self->{dir}, $self->{dist} );
  98 }
  99
 100
 101 sub setup_force {
 102     my ( $self, $dir, $dist ) = @_;
 103
 104     return unless $dir;
 105
 106     print "N: Setting up lab in $dir ...\n" if $verbose;
 107
 108     # create lab directory
 109     # (Note, that the mode 0777 is reduced by the current umask.)
 110     unless (-d $dir && ( $self->{mode} eq 'static' )) {
 111         mkdir($dir,0777) or return 0;
 112     }
 113
 114     # create base directories
 115     for my $subdir (qw( binary source udeb info )) {
 116         my $fulldir = "$dir/$subdir";
 117         if (not -d $fulldir) {
 118             mkdir($fulldir, 0777)
 119                 or fail("cannot create lab directory $fulldir");
 120         }
 121     }
 122
 123     # Just create empty files if they don't already exist.  If they do already
 124     # exist, we need to keep the old files so that the list-* unpack programs
 125     # can analyze what changed.
 126     for my $pkgtype (qw( binary source udeb )) {
 127         if (not -f "$dir/info/$pkgtype-packages") {
 128             _touch("$dir/info/$pkgtype-packages")
 129                 or fail("cannot create $pkgtype package list");
 130         }
 131     }
 132
 133     $self->{dir} = $dir;
 134     $ENV{'LINTIAN_LAB'} = $dir;
 135     $self->populate_with_dist( $dist );
 136
 137     return 1;
 138 }
 139
 140 sub populate_with_dist {
 141     my ( $self, $dist ) = @_;
 142
 143     return 0 unless $dist;
 144     return 0 unless $self->{dir};
 145
 146     print STDERR "spawning list-binpkg, list-udebpkg and list-srcpkg since LINTIAN_DIST=$dist\n" if ($debug >= 2);
 147
 148     my $v = $verbose ? '-v' : '';
 149
 150     spawn("$LINTIAN_ROOT/unpack/list-binpkg",
 151           "$self->{dir}/info/binary-packages", $v) == 0
 152               or fail("cannot create binary package list");
 153     spawn("$LINTIAN_ROOT/unpack/list-srcpkg",
 154           "$self->{dir}/info/source-packages", $v) == 0
 155               or fail("cannot create source package list");
 156     spawn("$LINTIAN_ROOT/unpack/list-udebpkg",
 157           "$self->{dir}/info/udeb-packages", $v) == 0
 158               or fail("cannot create udeb package list");
 159
 160     return 1;
 161 }
 162
 163 sub delete_static {
 164     my ( $self ) = @_;
 165
 166     unless ( $self->{mode} eq 'static' and $self->{dir} ) {
 167         print STDERR "warning: no laboratory specified (need to define LINTIAN_LAB)";
 168         return 0;
 169     }
 170
 171     return $self->delete_force;
 172 }
 173
 174 sub delete {
 175     my ( $self ) = @_;
 176
 177     return 1 unless $self->{mode} eq 'temporary';
 178
 179     return $self->delete_force;
 180 }
 181
 182 # Remove is apparantly some reserved name...
 183 sub delete_force {
 184     my ( $self ) = @_;
 185
 186     return 0 unless $self->{dir};
 187
 188     print "N: Removing $self->{dir} ...\n" if $verbose;
 189
 190     # since we will chdir in a moment, make the path of the lab absolute
 191     unless ( $self->{dir} =~ m,^/, ) {
 192         require Cwd;
 193         $self->{dir} = Cwd::getcwd() . "/$self->{dir}";
 194     }
 195
 196     # chdir to root (otherwise, the shell will complain if we happen
 197     # to sit in the directory we want to delete :)
 198     chdir('/');
 199
 200     # does the lab exist?
 201     unless (-d $self->{dir}) {
 202                 # no.
 203                 print STDERR "warning: cannot remove lab in directory $self->{dir} ! (directory does not exist)\n";
 204                 return 0;
 205     }
 206
 207     # sanity check if $self->{dir} really points to a lab :)
 208     unless (-d "$self->{dir}/binary") {
 209                 # binary/ subdirectory does not exist--empty directory?
 210                 my @t = glob("$self->{dir}/*");
 211                 if ($#t+1 <= 2) {
 212                         # yes, empty directory--skip it
 213                         return 1;
 214                 } else {
 215                         # non-empty directory that does not look like a lintian lab!
 216                         print STDERR "warning: directory $self->{dir} does not look like a lab! (please remove it yourself)\n";
 217                         return 0;
 218                 }
 219     }
 220
 221     # looks ok.
 222     if (spawn('rm', '-rf', '--',
 223               "$self->{dir}/binary",
 224               "$self->{dir}/source",
 225               "$self->{dir}/udeb",
 226               "$self->{dir}/info") != 0) {
 227                 print STDERR "warning: cannot remove lab directory $self->{dir} (please remove it yourself)\n";
 228     }
 229
 230     # dynamic lab?
 231     if ($self->{mode} eq 'temporary') {
 232                 if (rmdir($self->{dir}) != 1) {
 233                         print STDERR "warning: cannot remove lab directory $self->{dir} (please remove it yourself)\n";
 234                 }
 235     }
 236
 237     $self->{dir} = "";
 238
 239     return 1;
 240 }
 241
 242 # create an empty file
 243 # --okay, okay, this is not exactly what `touch' does :-)
 244 sub _touch {
 245     open(T, '>', $_[0]) or return 0;
 246     close(T) or return 0;
 247
 248     return 1;
 249 }
 250
 251
 252 1;
 253
 254 # vim: ts=4 sw=4 noet