Switch perl programs to use the new Dpkg/Arch module

ChangeLog

@@ -1,3 +1,25 @@
+2007-10-12  Guillem Jover  <guillem@debian.org>
+
+	* 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  <djpig@debian.org>
 
 	* scripts/t/300_Dpkg_BuildOptions.t: New file.

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).

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

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 (<CPUTABLE>) {
+	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 (<OSTABLE>) {
+	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 (<TRIPLETTABLE>) {
+	if (m/^(?!\#)(\S+)\s+(\S+)/) {
+	    my $debtriplet = $1;
+	    my $debarch = $2;
+
+	    if ($debtriplet =~ /<cpu>/) {
+		foreach my $_cpu (@cpu) {
+		    (my $dt = $debtriplet) =~ s/<cpu>/$_cpu/;
+		    (my $da = $debarch) =~ s/<cpu>/$_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;

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 \

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 (<CPUTABLE>) {
-	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 (<OSTABLE>) {
-	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 (<TRIPLETTABLE>) {
-	if (m/^(?!\#)(\S+)\s+(\S+)/) {
-	    my $debtriplet = $1;
-	    my $debarch = $2;
-
-	    if ($debtriplet =~ /<cpu>/) {
-		foreach my $_cpu (@cpu) {
-		    (my $dt = $debtriplet) =~ s/<cpu>/$_cpu/;
-		    (my $da = $debarch) =~ s/<cpu>/$_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;

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");
 

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';

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';

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';

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;

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