From: Guillem Jover Date: Fri, 12 Oct 2007 04:16:27 +0000 (+0300) Subject: Switch perl programs to use the new Dpkg/Arch module X-Git-Url: https://err.no/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=997652024cbd4490eb46ea73abc638e168b60c39;p=dpkg Switch perl programs to use the new Dpkg/Arch module --- diff --git a/ChangeLog b/ChangeLog index afd178c1..307e893f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,25 @@ +2007-10-12 Guillem Jover + + * scripts/controllib.pl ($host_arch, get_host_arch, get_valid_arches) + (@cpu, @os, %cputable, %ostable, %cputable_re, %ostable_re) + (%debtriplet_to_debarch, %debarch_to_debtriplet, read_cputable) + (read_ostable, read_triplettable, debtriplet_to_gnutriplet) + (gnutriplet_to_debtriplet, debtriplet_to_debarch) + (debarch_to_debtriplet, debwildcard_to_debtriplet) + (debarch_eq, debarch_is): Move to ... + * scripts/Dpkg/Arch.pm: ... here. New file. + * scripts/Makefile.am (nobase_dist_perllib_DATA): Add 'Dpkg/Arch.pm'. + * scripts/po/POTFILES.in: Add 'scripts/Dpkg/Arch.pm'. + + * scripts/controllib.pl: Use new Dpkg::Arch module. + * scripts/dpkg-architecture.pl: Likewise. + * scripts/dpkg-checkbuilddeps.pl: Likewise. + * scripts/dpkg-genchanges.pl: Likewise. + * scripts/dpkg-gencontrol.pl: Likewise. + * scripts/dpkg-source.pl: Likewise. + + * scripts/dpkg-architecture.pl: Do not require controllib.pl anymore. + 2007-10-12 Frank Lichtenheld * scripts/t/300_Dpkg_BuildOptions.t: New file. diff --git a/debian/changelog b/debian/changelog index 7b9cfec5..49b05191 100644 --- a/debian/changelog +++ b/debian/changelog @@ -43,6 +43,7 @@ dpkg (1.14.8) UNRELEASED; urgency=low [ Guillem Jover ] * Use shipped perl modules when calling perl programs at build time. * Switch perl programs to use the new Dpkg/ErrorHandling module. + * Switch perl programs to use the new Dpkg/Arch module. [ Updated dpkg translations ] * Polish (Robert Luberda). diff --git a/debian/dpkg-dev.install b/debian/dpkg-dev.install index df13a81e..bdee88d7 100644 --- a/debian/dpkg-dev.install +++ b/debian/dpkg-dev.install @@ -17,6 +17,7 @@ usr/bin/dpkg-shlibdeps usr/bin/dpkg-source usr/lib/dpkg/controllib.pl usr/lib/dpkg/parsechangelog +usr/share/perl5/Dpkg/Arch.pm usr/share/perl5/Dpkg/Path.pm usr/share/perl5/Dpkg/Version.pm usr/share/perl5/Dpkg/ErrorHandling.pm diff --git a/scripts/Dpkg/Arch.pm b/scripts/Dpkg/Arch.pm new file mode 100644 index 00000000..3cf7e4dd --- /dev/null +++ b/scripts/Dpkg/Arch.pm @@ -0,0 +1,242 @@ +package Dpkg::Arch; + +use strict; +use warnings; + +use Exporter; +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(get_host_arch get_valid_arches debarch_eq debarch_is + debtriplet_to_gnutriplet gnutriplet_to_debtriplet + debtriplet_to_debarch debarch_to_debtriplet); + +use Dpkg; +use Dpkg::ErrorHandling qw(syserr subprocerr); + +my (@cpu, @os); +my (%cputable, %ostable); +my (%cputable_re, %ostable_re); + +my %debtriplet_to_debarch; +my %debarch_to_debtriplet; + +{ + my $host_arch; + + sub get_host_arch() + { + return $host_arch if defined $host_arch; + + $host_arch = `dpkg-architecture -qDEB_HOST_ARCH`; + $? && subprocerr("dpkg-architecture -qDEB_HOST_ARCH"); + chomp $host_arch; + return $host_arch; + } +} + +sub get_valid_arches() +{ + read_cputable() if (!@cpu); + read_ostable() if (!@os); + + foreach my $os (@os) { + foreach my $cpu (@cpu) { + my $arch = debtriplet_to_debarch(split(/-/, $os, 2), $cpu); + print $arch."\n" if defined($arch); + } + } +} + +sub read_cputable +{ + local $_; + + open CPUTABLE, "$pkgdatadir/cputable" + or syserr(_g("unable to open cputable")); + while () { + if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) { + $cputable{$1} = $2; + $cputable_re{$1} = $3; + push @cpu, $1; + } + } + close CPUTABLE; +} + +sub read_ostable +{ + local $_; + + open OSTABLE, "$pkgdatadir/ostable" + or syserr(_g("unable to open ostable")); + while () { + if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) { + $ostable{$1} = $2; + $ostable_re{$1} = $3; + push @os, $1; + } + } + close OSTABLE; +} + +sub read_triplettable() +{ + read_cputable() if (!@cpu); + + local $_; + + open TRIPLETTABLE, "$pkgdatadir/triplettable" + or syserr(_g("unable to open triplettable")); + while () { + if (m/^(?!\#)(\S+)\s+(\S+)/) { + my $debtriplet = $1; + my $debarch = $2; + + if ($debtriplet =~ //) { + foreach my $_cpu (@cpu) { + (my $dt = $debtriplet) =~ s//$_cpu/; + (my $da = $debarch) =~ s//$_cpu/; + + $debarch_to_debtriplet{$da} = $dt; + $debtriplet_to_debarch{$dt} = $da; + } + } else { + $debarch_to_debtriplet{$2} = $1; + $debtriplet_to_debarch{$1} = $2; + } + } + } + close TRIPLETTABLE; +} + +sub debtriplet_to_gnutriplet(@) +{ + read_cputable() if (!@cpu); + read_ostable() if (!@os); + + my ($abi, $os, $cpu) = @_; + + return undef unless defined($abi) && defined($os) && defined($cpu) && + exists($cputable{$cpu}) && exists($ostable{"$abi-$os"}); + return join("-", $cputable{$cpu}, $ostable{"$abi-$os"}); +} + +sub gnutriplet_to_debtriplet($) +{ + my ($gnu) = @_; + return undef unless defined($gnu); + my ($gnu_cpu, $gnu_os) = split(/-/, $gnu, 2); + return undef unless defined($gnu_cpu) && defined($gnu_os); + + read_cputable() if (!@cpu); + read_ostable() if (!@os); + + my ($os, $cpu); + + foreach my $_cpu (@cpu) { + if ($gnu_cpu =~ /^$cputable_re{$_cpu}$/) { + $cpu = $_cpu; + last; + } + } + + foreach my $_os (@os) { + if ($gnu_os =~ /^(.*-)?$ostable_re{$_os}$/) { + $os = $_os; + last; + } + } + + return undef if !defined($cpu) || !defined($os); + return (split(/-/, $os, 2), $cpu); +} + +sub debtriplet_to_debarch(@) +{ + read_triplettable() if (!%debtriplet_to_debarch); + + my ($abi, $os, $cpu) = @_; + + if (!defined($abi) || !defined($os) || !defined($cpu)) { + return undef; + } elsif (exists $debtriplet_to_debarch{"$abi-$os-$cpu"}) { + return $debtriplet_to_debarch{"$abi-$os-$cpu"}; + } else { + return undef; + } +} + +sub debarch_to_debtriplet($) +{ + read_triplettable() if (!%debarch_to_debtriplet); + + local ($_) = @_; + my $arch; + + if (/^linux-([^-]*)/) { + # XXX: Might disappear in the future, not sure yet. + $arch = $1; + } else { + $arch = $_; + } + + my $triplet = $debarch_to_debtriplet{$arch}; + + if (defined($triplet)) { + return split('-', $triplet, 3); + } else { + return undef; + } +} + +sub debwildcard_to_debtriplet($) +{ + local ($_) = @_; + + if (/any/) { + if (/^([^-]*)-([^-]*)-(.*)/) { + return ($1, $2, $3); + } elsif (/^([^-]*)-([^-]*)$/) { + return ('any', $1, $2); + } else { + return ($_, $_, $_); + } + } else { + return debarch_to_debtriplet($_); + } +} + +sub debarch_eq($$) +{ + my ($a, $b) = @_; + + return 1 if ($a eq $b); + + my @a = debarch_to_debtriplet($a); + my @b = debarch_to_debtriplet($b); + + return 0 if grep(!defined, (@a, @b)); + + return ($a[0] eq $b[0] && $a[1] eq $b[1] && $a[2] eq $b[2]); +} + +sub debarch_is($$) +{ + my ($real, $alias) = @_; + + return 1 if ($alias eq $real or $alias eq 'any'); + + my @real = debarch_to_debtriplet($real); + my @alias = debwildcard_to_debtriplet($alias); + + return 0 if grep(!defined, (@real, @alias)); + + if (($alias[0] eq $real[0] || $alias[0] eq 'any') && + ($alias[1] eq $real[1] || $alias[1] eq 'any') && + ($alias[2] eq $real[2] || $alias[2] eq 'any')) { + return 1; + } + + return 0; +} + +1; diff --git a/scripts/Makefile.am b/scripts/Makefile.am index d3793f6f..9663fdb3 100644 --- a/scripts/Makefile.am +++ b/scripts/Makefile.am @@ -72,6 +72,7 @@ CLEANFILES = \ perllibdir = $(PERL_LIBDIR) nobase_dist_perllib_DATA = \ + Dpkg/Arch.pm \ Dpkg/Shlibs.pm \ Dpkg/Shlibs/Objdump.pm \ Dpkg/Shlibs/SymbolFile.pm \ diff --git a/scripts/controllib.pl b/scripts/controllib.pl index 908455fd..5cd55eb2 100755 --- a/scripts/controllib.pl +++ b/scripts/controllib.pl @@ -8,6 +8,7 @@ use POSIX qw(:errno_h); use Dpkg; use Dpkg::Gettext; use Dpkg::ErrorHandling qw(warning error failure internerr syserr subprocerr); +use Dpkg::Arch qw(get_host_arch debarch_is); textdomain("dpkg-dev"); @@ -83,237 +84,6 @@ sub capit { return join '-', @pieces; } -# -# Architecture library -# - -my (@cpu, @os); -my (%cputable, %ostable); -my (%cputable_re, %ostable_re); - -my %debtriplet_to_debarch; -my %debarch_to_debtriplet; - -{ - my $host_arch; - - sub get_host_arch() - { - return $host_arch if defined $host_arch; - - $host_arch = `dpkg-architecture -qDEB_HOST_ARCH`; - $? && subprocerr("dpkg-architecture -qDEB_HOST_ARCH"); - chomp $host_arch; - return $host_arch; - } -} - -sub get_valid_arches() -{ - read_cputable() if (!@cpu); - read_ostable() if (!@os); - - foreach my $os (@os) { - foreach my $cpu (@cpu) { - my $arch = debtriplet_to_debarch(split(/-/, $os, 2), $cpu); - print $arch."\n" if defined($arch); - } - } -} - -sub read_cputable -{ - local $_; - - open CPUTABLE, "$pkgdatadir/cputable" - or syserr(_g("unable to open cputable")); - while () { - if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) { - $cputable{$1} = $2; - $cputable_re{$1} = $3; - push @cpu, $1; - } - } - close CPUTABLE; -} - -sub read_ostable -{ - local $_; - - open OSTABLE, "$pkgdatadir/ostable" - or syserr(_g("unable to open ostable")); - while () { - if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) { - $ostable{$1} = $2; - $ostable_re{$1} = $3; - push @os, $1; - } - } - close OSTABLE; -} - -sub read_triplettable() -{ - read_cputable() if (!@cpu); - - local $_; - - open TRIPLETTABLE, "$pkgdatadir/triplettable" - or syserr(_g("unable to open triplettable")); - while () { - if (m/^(?!\#)(\S+)\s+(\S+)/) { - my $debtriplet = $1; - my $debarch = $2; - - if ($debtriplet =~ //) { - foreach my $_cpu (@cpu) { - (my $dt = $debtriplet) =~ s//$_cpu/; - (my $da = $debarch) =~ s//$_cpu/; - - $debarch_to_debtriplet{$da} = $dt; - $debtriplet_to_debarch{$dt} = $da; - } - } else { - $debarch_to_debtriplet{$2} = $1; - $debtriplet_to_debarch{$1} = $2; - } - } - } - close TRIPLETTABLE; -} - -sub debtriplet_to_gnutriplet(@) -{ - read_cputable() if (!@cpu); - read_ostable() if (!@os); - - my ($abi, $os, $cpu) = @_; - - return undef unless defined($abi) && defined($os) && defined($cpu) && - exists($cputable{$cpu}) && exists($ostable{"$abi-$os"}); - return join("-", $cputable{$cpu}, $ostable{"$abi-$os"}); -} - -sub gnutriplet_to_debtriplet($) -{ - my ($gnu) = @_; - return undef unless defined($gnu); - my ($gnu_cpu, $gnu_os) = split(/-/, $gnu, 2); - return undef unless defined($gnu_cpu) && defined($gnu_os); - - read_cputable() if (!@cpu); - read_ostable() if (!@os); - - my ($os, $cpu); - - foreach my $_cpu (@cpu) { - if ($gnu_cpu =~ /^$cputable_re{$_cpu}$/) { - $cpu = $_cpu; - last; - } - } - - foreach my $_os (@os) { - if ($gnu_os =~ /^(.*-)?$ostable_re{$_os}$/) { - $os = $_os; - last; - } - } - - return undef if !defined($cpu) || !defined($os); - return (split(/-/, $os, 2), $cpu); -} - -sub debtriplet_to_debarch(@) -{ - read_triplettable() if (!%debtriplet_to_debarch); - - my ($abi, $os, $cpu) = @_; - - if (!defined($abi) || !defined($os) || !defined($cpu)) { - return undef; - } elsif (exists $debtriplet_to_debarch{"$abi-$os-$cpu"}) { - return $debtriplet_to_debarch{"$abi-$os-$cpu"}; - } else { - return undef; - } -} - -sub debarch_to_debtriplet($) -{ - read_triplettable() if (!%debarch_to_debtriplet); - - local ($_) = @_; - my $arch; - - if (/^linux-([^-]*)/) { - # XXX: Might disappear in the future, not sure yet. - $arch = $1; - } else { - $arch = $_; - } - - my $triplet = $debarch_to_debtriplet{$arch}; - - if (defined($triplet)) { - return split('-', $triplet, 3); - } else { - return undef; - } -} - -sub debwildcard_to_debtriplet($) -{ - local ($_) = @_; - - if (/any/) { - if (/^([^-]*)-([^-]*)-(.*)/) { - return ($1, $2, $3); - } elsif (/^([^-]*)-([^-]*)$/) { - return ('any', $1, $2); - } else { - return ($_, $_, $_); - } - } else { - return debarch_to_debtriplet($_); - } -} - -sub debarch_eq($$) -{ - my ($a, $b) = @_; - - return 1 if ($a eq $b); - - my @a = debarch_to_debtriplet($a); - my @b = debarch_to_debtriplet($b); - - return 0 if grep(!defined, (@a, @b)); - - return ($a[0] eq $b[0] && $a[1] eq $b[1] && $a[2] eq $b[2]); -} - -sub debarch_is($$) -{ - my ($real, $alias) = @_; - - return 1 if ($alias eq $real or $alias eq 'any'); - - my @real = debarch_to_debtriplet($real); - my @alias = debwildcard_to_debtriplet($alias); - - return 0 if grep(!defined, (@real, @alias)); - - if (($alias[0] eq $real[0] || $alias[0] eq 'any') && - ($alias[1] eq $real[1] || $alias[1] eq 'any') && - ($alias[2] eq $real[2] || $alias[2] eq 'any')) { - return 1; - } - - return 0; -} - sub substvars { my ($v) = @_; my $lhs; diff --git a/scripts/dpkg-architecture.pl b/scripts/dpkg-architecture.pl index ae643d84..e59ad14d 100755 --- a/scripts/dpkg-architecture.pl +++ b/scripts/dpkg-architecture.pl @@ -25,9 +25,9 @@ use warnings; use Dpkg; use Dpkg::Gettext; use Dpkg::ErrorHandling qw(warning syserr usageerr); - -push(@INC,$dpkglibdir); -require 'controllib.pl'; +use Dpkg::Arch qw(get_valid_arches debarch_eq debarch_is + debtriplet_to_gnutriplet gnutriplet_to_debtriplet + debtriplet_to_debarch debarch_to_debtriplet); textdomain("dpkg-dev"); diff --git a/scripts/dpkg-checkbuilddeps.pl b/scripts/dpkg-checkbuilddeps.pl index 6c14ba47..db28b104 100755 --- a/scripts/dpkg-checkbuilddeps.pl +++ b/scripts/dpkg-checkbuilddeps.pl @@ -8,6 +8,7 @@ use Getopt::Long; use Dpkg; use Dpkg::Gettext; use Dpkg::ErrorHandling qw(error); +use Dpkg::Arch qw(get_host_arch); push(@INC,$dpkglibdir); require 'controllib.pl'; diff --git a/scripts/dpkg-genchanges.pl b/scripts/dpkg-genchanges.pl index ff761240..107c9cfc 100755 --- a/scripts/dpkg-genchanges.pl +++ b/scripts/dpkg-genchanges.pl @@ -9,6 +9,7 @@ use Dpkg; use Dpkg::Gettext; use Dpkg::ErrorHandling qw(warning error failure unknown internerr syserr subprocerr usageerr); +use Dpkg::Arch qw(get_host_arch debarch_eq debarch_is); push(@INC,$dpkglibdir); require 'controllib.pl'; diff --git a/scripts/dpkg-gencontrol.pl b/scripts/dpkg-gencontrol.pl index caf40c80..4cae8e7b 100755 --- a/scripts/dpkg-gencontrol.pl +++ b/scripts/dpkg-gencontrol.pl @@ -9,6 +9,7 @@ use Dpkg; use Dpkg::Gettext; use Dpkg::ErrorHandling qw(warning error failure unknown internerr syserr subprocerr usageerr); +use Dpkg::Arch qw(get_host_arch debarch_eq debarch_is); push(@INC,$dpkglibdir); require 'controllib.pl'; diff --git a/scripts/dpkg-source.pl b/scripts/dpkg-source.pl index ad4bc045..95baed57 100755 --- a/scripts/dpkg-source.pl +++ b/scripts/dpkg-source.pl @@ -8,6 +8,7 @@ use Dpkg::Gettext; use Dpkg::ErrorHandling qw(warning warnerror error failure unknown internerr syserr subprocerr usageerr $warnable_error $quiet_warnings); +use Dpkg::Arch qw(debarch_eq); my @filesinarchive; my %dirincluded; diff --git a/scripts/po/POTFILES.in b/scripts/po/POTFILES.in index 197539e6..55554a1c 100644 --- a/scripts/po/POTFILES.in +++ b/scripts/po/POTFILES.in @@ -15,6 +15,7 @@ scripts/dpkg-scansources.pl scripts/dpkg-shlibdeps.pl scripts/dpkg-source.pl scripts/changelog/debian.pl +scripts/Dpkg/Arch.pm scripts/Dpkg/Shlibs.pm scripts/Dpkg/Shlibs/Objdump.pm scripts/Dpkg/Shlibs/SymbolFile.pm