vfs/extfs/dpkg

   1 #! /usr/bin/perl
   2 #
   3 # 1999 (c) Piotr Roszatycki <dexter@debian.org>
   4 # This software is under GNU license
   5 # last modification: 1999-12-08
   6 #
   7 # dpkg
   8
   9 sub bt
  10 {
  11     my ($dt) = @_;
  12     my (@time);
  13     @time = localtime($dt);
  14     $bt = sprintf "%02d-%02d-%02d %02d:%02d", $time[4], $time[3], $time[5], $time[2], $time[1];
  15     return $bt;
  16 }
  17
  18
  19 sub ft
  20 {
  21     my ($f) = @_;
  22     return "d" if -d $f;
  23     return "l" if -l $f;
  24     return "p" if -p $f;
  25     return "S" if -S $f;
  26     return "b" if -b $f;
  27     return "c" if -c $f;
  28     return "-";
  29 }
  30
  31 sub fm
  32 {
  33     my ($n) = @_;
  34     my ($m);
  35
  36     if( $n & 0400 ) {
  37        $m .= "r";
  38     } else {
  39        $m .= "-";
  40     }
  41     if( $n & 0200 ) {
  42        $m .= "w";
  43     } else {
  44        $m .= "-";
  45     }
  46     if( $n & 04000 ) {
  47        $m .= "s";
  48     } elsif( $n & 0100 ) {
  49        $m .= "x";
  50     } else {
  51        $m .= "-";
  52     }
  53
  54     if( $n & 0040 ) {
  55        $m .= "r";
  56     } else {
  57        $m .= "-";
  58     }
  59     if( $n & 0020 ) {
  60        $m .= "w";
  61     } else {
  62        $m .= "-";
  63     }
  64     if( $n & 02000 ) {
  65        $m .= "s";
  66     } elsif( $n & 0010 ) {
  67        $m .= "x";
  68     } else {
  69        $m .= "-";
  70     }
  71
  72     if( $n & 0004 ) {
  73        $m .= "r";
  74     } else {
  75        $m .= "-";
  76     }
  77     if( $n & 0002 ) {
  78        $m .= "w";
  79     } else {
  80        $m .= "-";
  81     }
  82     if( $n & 01000 ) {
  83        $m .= "t";
  84     } elsif( $n & 0001 ) {
  85        $m .= "x";
  86     } else {
  87        $m .= "-";
  88     }
  89
  90     return $m;
  91 }
  92
  93 sub ls {
  94     my ($file,$path,$mode) = @_;
  95     my @stat = stat($file);
  96     # mode, nlink, uid, gid, size, mtime, filename
  97     printf "%s %d %d %d %d %s %s\n", $mode || ft($file).fm($stat[2] & 07777),
  98     $stat[3], $stat[4], $stat[5], $stat[7], bt($stat[9]), $path;
  99 }
 100
 101 $DATE=bt(time());
 102
 103 sub list
 104 {
 105     my ($pkg, $fn, $dn, $sz, $bt);
 106     my %debs = ();
 107     my %sects = ();
 108
 109     my($diversions,$architecture);
 110     chop($diversions = `dpkg-divert --list 2>/dev/null`);
 111     chop($architecture = `dpkg-architecture 2>/dev/null`);
 112     chop($list = `dpkg -l '*' 2>/dev/null`);
 113     chop($getselections = `dpkg --get-selections 2>/dev/null`);
 114     chop($audit = `dpkg --audit 2>/dev/null`);
 115     $sz = length($diversions);
 116     print "-r--r--r-- 1 root root $sz $DATE DIVERSIONS\n";
 117     $sz = length($architecture);
 118     print "-r--r--r-- 1 root root $sz $DATE ARCHITECTURE\n";
 119     $sz = length($list);
 120     print "-r--r--r-- 1 root root $sz $DATE LIST\n";
 121     $sz = length($getselections);
 122     print "-r--r--r-- 1 root root $sz $DATE GET-SELECTIONS\n";
 123     $sz = length($audit);
 124     print "-r--r--r-- 1 root root $sz $DATE AUDIT\n";
 125     $sz = length($pressconfigure);
 126     print "-r-xr--r-- 1 root root $sz $DATE CONFIGURE\n";
 127     $sz = length($pressremove);
 128     print "-r-xr--r-- 1 root root $sz $DATE REMOVE\n";
 129     $sz = length($pressclearavail);
 130     print "-r-xr--r-- 1 root root $sz $DATE CLEAR-AVAIL\n";
 131     $sz = length($pressforgetoldunavail);
 132     print "-r-xr--r-- 1 root root $sz $DATE FORGET-OLD-UNAVAIL\n";
 133     ls("/var/lib/dpkg/status","STATUS","-r--r--r--");
 134     # ls("/var/lib/dpkg/available","AVAILABLE","-r--r--r--");
 135
 136     print "drwxr-xr-x 1 root root 0 $DATE all\n";
 137
 138     open STAT, "/var/lib/dpkg/status"
 139        or exit 1;
 140     while( <STAT> ) {
 141        chop;
 142        if( /^([\w-]*): (.*)/ ) {
 143            $pkg = $2 if( lc($1) eq 'package' );
 144            $debs{$pkg}{lc($1)} = $2;
 145        }
 146     }
 147     close STAT;
 148
 149     foreach $pkg (sort keys %debs) {
 150        next if $debs{$pkg}{status} =~ /not-installed/;
 151        $fn = $debs{$pkg}{package}. "_". $debs{$pkg}{version};
 152        $dn = $debs{$pkg}{section};
 153        if( ! $dn ) {
 154            $dn = "unknown";
 155        } elsif( $dn =~ /^(non-us)$/i ) {
 156            $dn .= "/main";
 157        } elsif( $dn !~ /\// ) {
 158            $dn = "main/". $dn;
 159        }
 160        unless( $sects{$dn} ) {
 161            my $sub = $dn;
 162            while( $sub =~ s!^(.*)/[^/]*$!$1! ) {
 163                unless( $sects{$sub} ) {
 164                    print "drwxr-xr-x 1 root root 0 $DATE $sub/\n";
 165                    $sects{$sub} = 1;
 166                }
 167            }
 168            print "drwxr-xr-x 1 root root 0 $DATE $dn/\n";
 169            $sects{$dn} = 1;
 170        }
 171        $sz = $debs{$pkg}{'status'} =~ /config-files/ ? 0 : $debs{$pkg}{'installed-size'} * 1024;
 172        @stat = stat("/var/lib/dpkg/info/".$debs{$pkg}{package}.".list");
 173        $bt = bt($stat[9]);
 174        print "-rw-r--r-- 1 root root $sz $bt $dn/$fn.debd\n";
 175        print "lrwxrwxrwx 1 root root $sz $bt all/$fn.debd -> ../$dn/$fn.debd\n";
 176     }
 177 }
 178
 179 sub copyout
 180 {
 181     my($archive,$filename) = @_;
 182     if( $archive eq 'DIVERSIONS' ) {
 183        system("dpkg-divert --list > $filename 2>/dev/null");
 184     } elsif( $archive eq 'ARCHITECTURE' ) {
 185        system("dpkg-architecture > $filename 2>/dev/null");
 186     } elsif( $archive eq 'LIST' ) {
 187        system("dpkg -l '*' > $filename 2>/dev/null");
 188     } elsif( $archive eq 'AUDIT' ) {
 189        system("dpkg --audit > $filename 2>/dev/null");
 190     } elsif( $archive eq 'GET-SELECTIONS' ) {
 191        system("dpkg --get-selections > $filename 2>/dev/null");
 192     } elsif( $archive eq 'STATUS' ) {
 193        system("cp /var/lib/dpkg/status $filename");
 194     } elsif( $archive eq 'AVAILABLE' ) {
 195        system("cp /var/lib/dpkg/available $filename");
 196     } elsif( $archive eq 'CONFIGURE' ) {
 197        open O, ">$filename";
 198        print O $pressconfigure;
 199        close O;
 200     } elsif( $archive eq 'REMOVE' ) {
 201        open O, ">$filename";
 202        print O $pressremove;
 203        close O;
 204     } elsif( $archive eq 'CLEAR-AVAIL' ) {
 205        open O, ">$filename";
 206        print O $pressclearavail;
 207        close O;
 208     } elsif( $archive eq 'FORGET-OLD-UNAVAIL' ) {
 209        open O, ">$filename";
 210        print O $pressforgetoldunavail;
 211        close O;
 212     } else {
 213        open O, ">$filename";
 214        print O $archive, "\n";
 215        close O;
 216     }
 217 }
 218
 219 # too noisy but less dangerouse
 220 sub copyin
 221 {
 222     my($archive,$filename) = @_;
 223     if( $archive =~ /\.deb$/ ) {
 224        system("dpkg -i $filename>/dev/null");
 225     } else {
 226        die "extfs: cannot create regular file \`$archive\': Permission denied\n";
 227     }
 228 }
 229
 230 sub run
 231 {
 232     my($archive,$filename) = @_;
 233     if( $archive eq 'CONFIGURE' ) {
 234        system("dpkg --pending --configure");
 235     } elsif( $archive eq 'REMOVE' ) {
 236        system("dpkg --pending --remove");
 237     } elsif( $archive eq 'CLEAR-AVAIL' ) {
 238        system("dpkg --clear-avail");
 239     } elsif( $archive eq 'FORGET-OLD-UNAVAIL' ) {
 240        system("dpkg --forget-old-unavail");
 241     } else {
 242        die "extfs: $filename: command not found\n";
 243     }
 244 }
 245
 246 # Disabled - too dangerous and too noisy
 247 sub rm_disabled
 248 {
 249     my($archive) = @_;
 250     if( $archive =~ /\.debd?$/ ) {
 251        my $name = $archive;
 252        $name =~ s%.*/%%g;
 253        $name =~ s%_.*%%g;
 254        system("if dpkg -s $name | grep ^Status | grep -qs config-files; \
 255            then dpkg --purge $name>/dev/null; \
 256            else dpkg --remove $name>/dev/null; fi");
 257        die("extfs: $archive: Operation not permitted\n") if $? != 0;
 258     } else {
 259        die "extfs: $archive: Operation not permitted\n";
 260     }
 261 }
 262
 263
 264 $pressconfigure=<<EOInstall;
 265
 266                               WARNING
 267      Don\'t use this method if you are not willing to configure all
 268                      non configured packages.
 269
 270 This is not a real file. It is a way to configure all non configured packages.
 271
 272 To configure packages go back to the panel and press Enter on this file.
 273
 274 EOInstall
 275
 276 $pressremove=<<EOInstall;
 277
 278                               WARNING
 279      Don\'t use this method if you are not willing to remove all
 280                       unselected packages.
 281
 282 This is not a real file. It is a way to remove all unselected packages.
 283
 284 To remove packages go back to the panel and press Enter on this file.
 285
 286 EOInstall
 287
 288 $pressforgetoldunavail=<<EOInstall;
 289
 290                               WARNING
 291      Don\'t use this method if you are not willing to forget about
 292                  uninstalled unavailable packages.
 293
 294 This is not a real file. It is a way to forget about uninstalled
 295 unavailable packages.
 296
 297 To forget this information go back to the panel and press Enter on this file.
 298
 299 EOInstall
 300
 301 $pressclearavail=<<EOInstall;
 302
 303                               WARNING
 304      Don\'t use this method if you are not willing to erase the existing
 305            information about what packages are available.
 306
 307 This is not a real file. It is a way to erase the existing information
 308 about what packages are available.
 309
 310 To clear this information go back to the panel and press Enter on this file.
 311
 312 EOInstall
 313
 314
 315
 316 # override any locale for dates
 317 $ENV{"LC_ALL"}="C";
 318
 319 if ($ARGV[0] eq "list") { list(); exit(0); }
 320 elsif ($ARGV[0] eq "copyout") { copyout($ARGV[2], $ARGV[3]); exit(0); }
 321 elsif ($ARGV[0] eq "copyin") { copyin($ARGV[2], $ARGV[3]); exit(0); }
 322 elsif ($ARGV[0] eq "run") { run($ARGV[2],$ARGV[3]); exit(0); }
 323 #elsif ($ARGV[0] eq "rm") { rm($ARGV[2]); exit(0); }
 324 exit(1);
 325