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

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