altname-legacy.pl 5.8 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235
  1. #!/usr/bin/perl
  2. ###############################################################################
  3. ##
  4. ## Some legacy, not-quite-working code to automatically find alternative
  5. ## package names based on dependency tracking
  6. ## (Distributions use dependencies to assure smooth upgrades..)
  7. ##
  8. ###############################################################################
  9. use strict;
  10. use warnings;
  11. my @debian_dists = ("potato", "woody", "sarge", "etch", "lenny", "squeeze");
  12. my @ubuntu_dists = ("dapper", "hardy", "jaunty", "karmic", "lucid", "maverick", "natty");
  13. # uniq(\@array)
  14. # returns an array which all unique elements of @array
  15. sub uniq($) {
  16. my %c = map {$_, 1} @{pop()};
  17. return keys %c;
  18. }
  19. sub getfilehandle($) {
  20. my $name = pop;
  21. my $fd;
  22. if ($name =~ /.bz2$/) {
  23. $fd = new IO::Uncompress::Bunzip2 $name or die "$name: $!";
  24. }
  25. elsif ($name =~ /.gz$/) {
  26. $fd = new IO::Uncompress::Gunzip $name or die "$name: $!";
  27. }
  28. # elsif ($name =~ /.lzma$/) {
  29. # $fd new IO::Uncompress::UnLzma $name or die "$name: $!";
  30. else {
  31. open $fd, $name or die "$name: $!";
  32. }
  33. return $fd;
  34. }
  35. sub cachename($;$) {
  36. my $f = shift;
  37. my $suffix = shift;
  38. $suffix = "cache" if ! defined $suffix;
  39. my @a = stat $f;
  40. $f =~ s/\/\//\//g;
  41. $f =~ s/\//_/g;
  42. my $x = $config->{"cache_dir"} . "/" . $f . "_" . $a[9] . "." . $suffix;
  43. return $x;
  44. }
  45. sub getcached ($;$) {
  46. my %file;
  47. my $cachename = cachename shift(), shift();
  48. eval {
  49. my $file = retrieve $cachename;
  50. %file = %{$file};
  51. };
  52. return %file;
  53. }
  54. # intersection (\@array1, \@array2)
  55. # returns intersection of both arrays
  56. sub intersection($$) {
  57. my @arr1 = uniq(pop);
  58. my @arr2 = uniq(pop);
  59. my @common;
  60. my %c;
  61. foreach (@arr1, @arr2){
  62. $c{$_}++;
  63. }
  64. foreach (keys %c) {
  65. if ($c{$_} > 1) {
  66. push @common, $_;
  67. }
  68. }
  69. return @common;
  70. }
  71. # parsefile($filehandle)
  72. # returns hash of the package file given with $filename, key is package name,
  73. # value is a reference to a hash with key: value
  74. sub parsefile($) {
  75. my $filename = pop;
  76. # do we have stuff cached?
  77. my %file = getcached($filename, "parsefile.cache");
  78. return %file if %file;
  79. my $fd = getfilehandle $filename;
  80. # this is the parser
  81. my $savedsl = $/;
  82. $/ = "\n\n";
  83. while (<$fd>) {
  84. my %dict;
  85. $_ = "\n".$_;
  86. ($_, %dict) = split /\n(\w+): /; # first is crap
  87. $file{$dict{"Package"}} = \%dict;
  88. }
  89. $/ = $savedsl;
  90. close $fd;
  91. # cache result
  92. store \%file, cachename ($filename, "parsefile.cache");
  93. return %file;
  94. }
  95. # getarrayofpackeges($field)
  96. # Returns an array of all packages given in @fields (as returned by getfield()
  97. # strips versions
  98. sub getarrayofpackages($) {
  99. $_ = pop or return;
  100. s/(\(.*?\)|\s)//g; # remove everything inside parathesis and whitespaces
  101. return split /,/ or ();
  102. }
  103. # parsesource($filehandle)
  104. # parses the sourcefile represented by the open file in $filehandle
  105. # returns a dict with each binary package name reference to a
  106. # source package hash
  107. sub parsesource($) {
  108. my $filename = pop;
  109. # do we have stuff cached?
  110. my %file = getcached($filename, "parsesource.cache");
  111. return %file if %file;
  112. # if not, parse
  113. my $savedsl = $/;
  114. $/ = "\n\n";
  115. my $fd = getfilehandle $filename;
  116. while (<$fd>) {
  117. my %dict;
  118. $_ = "\n".$_;
  119. ($_, %dict) = split /\n(\w+): /; # first is crap
  120. foreach my $bin (getarrayofpackages ($dict{"Binary"})) {
  121. $file{$bin} = \%dict;
  122. }
  123. }
  124. $/ = $savedsl;
  125. close $fd;
  126. # cache
  127. store \%file, cachename ($filename, "parsesource.cache");
  128. return %file;
  129. }
  130. # old_names_in_file($name, $filehandle)
  131. # returns array of alternative names to $name in the opened Package
  132. # file ($filehandle)
  133. sub old_names_in_file($) {
  134. my %pkg = %{pop()};
  135. my @replaces = getarrayofpackages($pkg{"Replaces"});
  136. my @conflicts = getarrayofpackages($pkg{"Conflicts"});
  137. return intersection(\@replaces, \@conflicts);
  138. }
  139. # pkg2src(%sources, $packagename)
  140. # return the source package to a given binary package
  141. sub pkg2src($$){
  142. my $p = pop;
  143. my %f = %{pop()};
  144. if (!$p || !$f{$p}) {
  145. return ();
  146. }
  147. return $f{$p}->{"Package"};
  148. }
  149. # recursor (\@distris, \@names, $start)
  150. # recursively works through all @dists (filenames of uncompressed Package files
  151. # from debian) from last to first. Tries to find alternative names to the names
  152. # given in @names), if $start = 1, dies if name is not found in the current dist
  153. sub get_aliases($$$$);
  154. sub get_aliases($$$$) {
  155. my @dists = @{shift()};
  156. my @names = @{shift()};
  157. my @sources = @{shift()};
  158. my $start = shift;
  159. my %pkg;
  160. my @list = @names;
  161. my $dist = pop(@dists);
  162. my $dists_dir = $config->{"dists_dir"};
  163. my $arch = $config->{"arch"};
  164. my %pkglist = parsefile "$dists_dir/$dist/main/binary-$arch/Packages.bz2";
  165. my %srclist = parsesource "$dists_dir/$dist/main/source/Sources.bz2";
  166. foreach my $p (@names) {
  167. eval {
  168. push @sources, pkg2src(\%srclist, $p);
  169. @sources = uniq(\@sources);
  170. %pkg = %{$pkglist{$p}};
  171. @list = old_names_in_file(\%pkg);
  172. @names = (@names, @list);
  173. @names = uniq(\@names);
  174. } or do {
  175. die "Could not find any package named '$p'" if grep ($p, @ARGV) && $start;
  176. };
  177. }
  178. @names = uniq(\@names);
  179. if (@dists){
  180. return get_aliases(\@dists, \@names, \@sources, 0);
  181. } else {
  182. return @sources;
  183. }
  184. }
  185. # Tries to find alternative package names by tracking bin pkg dependencies
  186. # through distributions. Does not work. We use unifySrcName() instead.
  187. sub altname {
  188. my $spkg = shift;
  189. my @pkg = ();
  190. my @src = ();
  191. my @dists;
  192. given ($state->{"vendor"}) {
  193. when ($_ eq "debian") { @dists = @debian_dists; }
  194. when ($_ eq "ubuntu") { @dists = @ubuntu_dists; }
  195. #when ($_ eq "redhat") { ($id,$adv) = checkRHSA; }
  196. default { die "Unsupported distribution $_"; }
  197. };
  198. # get all bin pkg for this src pkg
  199. #foreach my $pkg (keys %$pkg2src) {
  200. # push @pkg, $pkg if ($spkg eq $pkg2src->{$pkg} )
  201. #}
  202. @pkg = ($spkg);
  203. @src = get_aliases(\@dists, \@pkg, \@src, 1);
  204. print "Aliases for bin-pkg $spkg: @src\n";
  205. }