list-packages 3.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117
  1. #!/usr/bin/perl -w
  2. # -*- mode: cperl; coding: utf-8 -*-
  3. # Most of this code was stolen from Debhelper 7.3.16+. which is:
  4. # Joey Hess, GPL copyright 1997-2009.
  5. # Adapted for CDBS purposes by Colin Walters <walters@debian.org>
  6. # Copyright © 2010-2011, 2015-2016 Jonas Smedegaard <dr@jones.dk>
  7. #
  8. # This program is free software; you can redistribute it and/or modify
  9. # it under the terms of the GNU General Public License as published by
  10. # the Free Software Foundation; either version 3, or (at your option)
  11. # any later version.
  12. #
  13. # This program is distributed in the hope that it will be useful, but
  14. # WITHOUT ANY WARRANTY; without even the implied warranty of
  15. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  16. # General Public License for more details.
  17. #
  18. # You should have received a copy of the GNU General Public License
  19. # along with this program. If not, see <http://www.gnu.org/licenses/>.
  20. sub error {
  21. my $err = shift;
  22. print STDERR $err;
  23. exit 1;
  24. }
  25. sub samearch {
  26. my $arch=shift;
  27. my @archlist=split(/\s+/,shift);
  28. foreach my $a (@archlist) {
  29. system("dpkg-architecture", "-a$arch", "-i$a") == 0 && return 1;
  30. }
  31. return 0;
  32. }
  33. sub buildarch {
  34. my $value=`dpkg-architecture -qDEB_HOST_ARCH` || error("dpkg-architecture failed: $!");
  35. chomp $value;
  36. return $value;
  37. }
  38. sub GetPackages {
  39. my $type=shift;
  40. $type="" if ! defined $type;
  41. my $package="";
  42. my $arch="";
  43. my @list=();
  44. my %seen;
  45. my @profiles=();
  46. my $included_in_build_profile;
  47. if (exists $ENV{'DEB_BUILD_PROFILES'}) {
  48. @profiles=split /\s+/, $ENV{'DEB_BUILD_PROFILES'};
  49. }
  50. open (CONTROL, 'debian/control') ||
  51. error("cannot read debian/control: $!\n");
  52. while (<CONTROL>) {
  53. chomp;
  54. s/\s+$//;
  55. if (/^Package:\s*(.*)/i) {
  56. $package=$1;
  57. # Detect duplicate package names in the same control file.
  58. if (! $seen{$package}) {
  59. $seen{$package}=1;
  60. }
  61. else {
  62. error("debian/control has a duplicate entry for $package");
  63. }
  64. $included_in_build_profile=1;
  65. }
  66. if (/^Architecture:\s*(.*)/i) {
  67. $arch=$1;
  68. }
  69. # rely on libdpkg-perl providing the parsing functions because
  70. # if we work on a package with a Build-Profiles field, then a
  71. # high enough version of dpkg-dev is needed anyways
  72. if (/^Build-Profiles:\s*(.*)/) {
  73. my $build_profiles=$1;
  74. eval {
  75. require Dpkg::BuildProfiles;
  76. my @restrictions=Dpkg::BuildProfiles::parse_build_profiles($build_profiles);
  77. if (@restrictions) {
  78. $included_in_build_profile=Dpkg::BuildProfiles::evaluate_restriction_formula(\@restrictions, \@profiles);
  79. }
  80. };
  81. if ($@) {
  82. error("The control file has a Build-Profiles field. Requires libdpkg-perl >= 1.17.14");
  83. }
  84. }
  85. if (!$_ or eof) { # end of stanza.
  86. if ($package && $included_in_build_profile &&
  87. # (($type eq 'indep' && $arch eq 'all') ||
  88. # ($type eq 'arch' && $arch ne 'all') ||
  89. # ($type eq 'same' && (samearch(buildarch(), $arch))) ||
  90. (($type eq 'indep' && $arch eq 'all') ||
  91. ($type eq 'arch' && $arch ne 'all') ||
  92. ($type eq 'same' && ($arch eq 'any' ||
  93. ($arch ne 'all' &&
  94. samearch(buildarch(), $arch)))) ||
  95. ! $type)) {
  96. push @list, $package;
  97. $package="";
  98. $arch="";
  99. }
  100. }
  101. }
  102. close CONTROL;
  103. return @list;
  104. }
  105. print join(' ', GetPackages($ARGV[0])) . "\n";