[debian-devel:07795] Re: Mini Debian System (Re: 1 CD Debian)

[Kaz Sasayama <Kaz.Sasayama@xxxxxxxxxxxxxxx>]

これもよかったら使ってください。このまま死蔵するには惜しい。

#! /usr/bin/perl

use strict;
use vars qw($opt_arch $opt_lowest @opt_include $opt_altdir $opt_dry_run $opt_verbose);

use Getopt::Long;
use File::Basename;
use File::Path;
use File::Copy;
use Dpkg::Package::List;
use Dpkg::Package::Index;

my %priority = (required => 0,
		important => 20,
		standard => 40,
		optional => 60,
		extra => 80);

Getopt::Long::config qw(bundling);
GetOptions ("sections=s", "architecture=s", "lowest=s", "include=s\@", "altdir=s",
	    "dry-run|n", "verbose|v");

my $release = "slink";
my $sections = "main,contrib";
my $arch = $opt_arch || "i386";
my $lowest = $opt_lowest || "standard";

my $packages;
my $index;

sub do_package ($$) {
    my ($dir, $package) = @_;

    my $filename = $package->{filename};

    # Process intra-section links.
    while (-l "$dir/$filename") {
	my $link = readlink "$dir/$filename";
	print STDERR "$dir/$filename is a link to $link\n" if $opt_verbose;
	last if $link !~ m%^(\.\./)*binary-\w+/%;

	if ($opt_dry_run) {
	    print "ln -s $link $filename\n";
	} else {
	    # Make directory hiers.
	    mkpath dirname $filename
		or die dirname ($filename) . ": mkdir failed: $!\n"
		    if !-d dirname $filename;
	    symlink $link, $filename
		or die "$filename: symlink failed: $!\n";
	}

	$filename = dirname ($filename) . "/$link";
	1 while $filename =~ s%[^/]+/\.\./%%;
    }

    my $filename0 = "$dir/$filename";
    if (-l $filename0) {
	my $link = readlink $filename0;
	if (-f dirname ($filename) . "/$link") {
	    if ($opt_dry_run) {
		print "ln -s $link $filename\n";
	    } else {
		# Make directory hiers.
		mkpath dirname $filename
		    or die dirname ($filename) . ": mkdir failed: $!\n"
			if !-d dirname $filename;
		symlink $link, $filename
		    or die "$filename: symlink failed: $!\n";
	    }
	    return;
	}
    }

  retry:
    while (-l $filename0) {
	my $link = readlink $filename0;
	$filename0 = dirname ($filename0) . "/$link";
	1 while $filename0 =~ s%[^/]+/\.\./%%;
    }
    # Search in altdir.
    if ($opt_altdir && !-e $filename0) {
	my $re = $dir;
	$re =~ s/([^\w])/\\$1/g;
	my $f = $filename0;
	if ($f =~ s%^$re/%$opt_altdir/%
	    && -f $f) {
	    $filename0 = $f;
	    goto retry;
	}
    }

    if ($opt_dry_run) {
	print "cp $filename0 $filename\n";
    } else {
	# Make directory hiers.
	mkpath dirname $filename
	    or die dirname ($filename) . ": mkdir failed: $!\n"
		if !-d dirname $filename;
	if (!link $filename0, $filename) {
	    copy $filename0, $filename
		or warn ("$filename0: copy failed: $!\n"), return;
	    my @stat = stat $filename0;
	    utime $stat[8], $stat[9], $filename
		or warn "$filename: utime failed: $!\n";
	}
    }
}

sub include (\%$) {
    my ($hash, $package) = @_;
    if (!$hash->{$package->{package}}) {
	print STDERR "$package->{package} will be included\n" if $opt_verbose;
	$hash->{$package->{package}} = 1;
	my $depends = $package->{depends};
	while ($depends =~ /([\w-]+)(\s*\([^\)]+\))?/g) {
	    print STDERR "$package->{package} depends $1\n";
	    my $d = $index->lookup ($1);
	    if (!$d) {
		warn "$1 not found\n";
	    } else {
		&include ($hash, $d);
	    }
	}
    }
}

foreach my $dir (@ARGV) {
    foreach my $section (split /,/, $sections) {
	my $binarydir = "$dir/dists/$release/$section/binary-$arch";

	$packages = new Dpkg::Package::List filename => "$binarydir/Packages";
	$index = new Dpkg::Package::Index packages => $packages;

	my %included;
	my %excluded;
	if (@opt_include) {
	    print STDERR "Tracking dependencies in $binarydir...\n" if $opt_verbose;
	    foreach my $package (@{$packages->packages}) {
		if (grep {
		    my $re = $_;
		    $re =~ s/([^\w?*])/\\$1/g;
		    $re =~ s/\?/./g;
		    $re =~ s/\*/.*/g;
		    $package->{package} =~ /^$re$/;
		} @opt_include) {
		    include %included, $package;
		}
	    }
	}

	print STDERR "Copying binary packages in $binarydir...\n" if $opt_verbose;
	foreach my $package (@{$packages->packages}) {
	    next if $priority{$package->{priority}} > $priority{$lowest}
	    && !$included{$package->{package}};
	    next if $excluded{$package->{package}};

	    do_package $dir, $package;
	}
    }
}

-- 
"Free software is not for free."
Kaz Sasayama <Kaz.Sasayama@xxxxxxxxxxxxxxx>
Hypercore Software Design, Ltd. <URL:http://www.hypercore.co.jp/>