/usr/lib/emacsen-common/lib.pl is in emacsen-common 2.0.7.
This file is owned by root:root, with mode 0o755.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 | #!/usr/bin/perl -w
use strict;
use Cwd;
# depends on: dpkg, tsort, perl
my $lib_dir = "/usr/lib/emacsen-common";
my $var_dir = "/var/lib/emacsen-common";
$::installed_package_state_dir = "${var_dir}/state/package/installed";
$::installed_flavor_state_dir = "${var_dir}/state/flavor/installed";
sub ex
{
my(@cmd) = @_;
if(system(@cmd) != 0)
{
die join(" ", @cmd) . " failed";
}
}
sub glob_in_dir
{
my ($dir, $pattern) = @_;
my $oldir = getcwd;
chdir($dir) or die "chdir $dir: $!";
my @files = glob("*[!~]");
chdir($oldir);
return \@files;
}
sub validate_add_on_pkg
{
my ($pkg, $script, $old_invocation_style) = @_;
if($old_invocation_style)
{
if(-e "$lib_dir/packages/compat/$pkg")
{
print STDERR "ERROR: $pkg is broken - called $script as an old-style add-on, but has compat file.\n";
#exit(1);
}
}
else # New invocation style.
{
unless(-e "$lib_dir/packages/compat/$pkg")
{
print STDERR "ERROR: $pkg is broken - called $script as a new-style add-on, but has no compat file.\n";
#exit(1);
}
}
}
sub get_installed_add_on_packages
{
# Return all of the old format packages, plus all of the new-format
# packages that are ready (i.e. have a state/installed file). In
# this case ready means ready for compilation.
my $all_pkgs = glob_in_dir("$lib_dir/packages/install", '*[!~]');
my $new_format_pkgs = glob_in_dir("$lib_dir/packages/compat", '*[!~]');
my %ready_pkgs = map { $_ => 1 } @$all_pkgs;
for my $p (@$new_format_pkgs)
{
delete $ready_pkgs{$p} unless (-e "$::installed_package_state_dir/$p");
}
my @result = keys %ready_pkgs;
return \@result;
}
sub get_installed_flavors
{
my $flavors = glob_in_dir($::installed_flavor_state_dir, '*[!~]');
return @$flavors;
}
sub get_package_status
{
my($pkg) = @_;
my $status = `dpkg --status $pkg`;
die 'emacsen-common: dpkg invocation failed' if($? != 0);
$status =~ s/\n\s+//gmo; # handle any continuation lines...
return $status;
}
sub filter_depends
{
my($depends_string, $installed_add_ons) = @_;
# Filter out all the "noise" (version number dependencies, etc)
# and handle or deps too, i.e. "Depends: foo, bar | baz"
my @relevant_depends = split(/[,|]/, $depends_string);
@relevant_depends = map { /\s*(\S+)/o; $1; } @relevant_depends;
# Filter out all non-add-on packages.
@relevant_depends = grep {
my $candidate = $_;
grep { $_ eq $candidate } @$installed_add_ons;
} @relevant_depends;
return @relevant_depends;
}
sub generate_relevant_tsort_dependencies_internals
{
my($pkglist, $installed_add_ons, $progress_hash) = @_;
# print "GRD: " . join(" ", @$pkglist) . "\n";
my $pkg = shift @$pkglist;
if(!$pkg || $$progress_hash{$pkg}) {
return ();
} else {
my $status = get_package_status($pkg);
$status =~ /^Depends:\s+(.*)/mo;
my $depends = $1; $depends = "" if ! $depends;
my @relevant_depends = filter_depends($depends, $installed_add_ons);
my $newpkglist = [@$pkglist, @relevant_depends];
$$progress_hash{$pkg} = 1;
# pkg is in twice so we don't have to worry about package with no
# relevant dependencies. tsort can't handle that.
my @tsort_strings = "$pkg $pkg\n";
map { push @tsort_strings, "$_ $pkg\n"; } @relevant_depends;
return (@tsort_strings,
generate_relevant_tsort_dependencies_internals($newpkglist,
$installed_add_ons,
$progress_hash));
}
}
sub generate_relevant_tsort_dependencies
{
my($pkglist, $installed_add_ons, $progress_hash) = @_;
# Make a copy because we're going to mangle it.
my @listcopy = @$pkglist;
shift @_;
return(generate_relevant_tsort_dependencies_internals(\@listcopy, @_));
}
sub reorder_add_on_packages
{
my($pkglist, $installed_add_ons) = @_;
my @depends = generate_relevant_tsort_dependencies($pkglist,
$installed_add_ons,
{});
my $pid = open(TSORT, "-|");
die "Couldn't fork for tsort: $!" unless defined($pid);
# What a strange idiom...
if($pid == 0) {
my $sub_pid = open(IN, "|-");
die "Couldn't sub-fork for tsort: $!" unless defined($sub_pid);
if($sub_pid == 0) {
exec 'tsort' or die "Couldn't run tsort: $!";
}
print IN @depends;
exit 0;
}
my @ordered_pkgs = <TSORT>;
chomp @ordered_pkgs;
return @ordered_pkgs
}
sub generate_add_on_install_list
{
my($packages_to_sort) = @_;
my @sorted_pkgs = reorder_add_on_packages($packages_to_sort,
get_installed_add_on_packages());
return(@sorted_pkgs);
}
# Test code
# my @input_packages = <STDIN>;
# my @result = generate_add_on_install_list(@input_packages);
# print " " . join("\n ", @result);
# To make require happy...
1;
|