home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / perl5 / Dpkg / Arch.pm next >
Encoding:
Perl POD Document  |  2012-09-17  |  7.7 KB  |  356 lines
  1. # This program is free software; you can redistribute it and/or modify
  2. # it under the terms of the GNU General Public License as published by
  3. # the Free Software Foundation; either version 2 of the License, or
  4. # (at your option) any later version.
  5. #
  6. # This program is distributed in the hope that it will be useful,
  7. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  8. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  9. # GNU General Public License for more details.
  10. #
  11. # You should have received a copy of the GNU General Public License
  12. # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  13.  
  14. package Dpkg::Arch;
  15.  
  16. use strict;
  17. use warnings;
  18.  
  19. our $VERSION = "0.01";
  20.  
  21. use base qw(Exporter);
  22. our @EXPORT_OK = qw(get_raw_build_arch get_raw_host_arch
  23.                     get_build_arch get_host_arch get_gcc_host_gnu_type
  24.                     get_valid_arches debarch_eq debarch_is
  25.                     debarch_to_cpuattrs
  26.                     debarch_to_gnutriplet gnutriplet_to_debarch
  27.                     debtriplet_to_gnutriplet gnutriplet_to_debtriplet
  28.                     debtriplet_to_debarch debarch_to_debtriplet);
  29.  
  30. use Dpkg;
  31. use Dpkg::Gettext;
  32. use Dpkg::ErrorHandling;
  33.  
  34. my (@cpu, @os);
  35. my (%cputable, %ostable);
  36. my (%cputable_re, %ostable_re);
  37. my (%cpubits, %cpuendian);
  38.  
  39. my %debtriplet_to_debarch;
  40. my %debarch_to_debtriplet;
  41.  
  42. {
  43.     my $build_arch;
  44.     my $host_arch;
  45.     my $gcc_host_gnu_type;
  46.  
  47.     sub get_raw_build_arch()
  48.     {
  49.     return $build_arch if defined $build_arch;
  50.  
  51.     my $build_arch = `dpkg --print-architecture`;
  52.     # FIXME: Handle bootstrapping
  53.     syserr("dpkg --print-architecture failed") if $? >> 8;
  54.  
  55.     chomp $build_arch;
  56.     return $build_arch;
  57.     }
  58.  
  59.     sub get_build_arch()
  60.     {
  61.     return $ENV{DEB_BUILD_ARCH} || get_raw_build_arch();
  62.     }
  63.  
  64.     sub get_gcc_host_gnu_type()
  65.     {
  66.     return $gcc_host_gnu_type if defined $gcc_host_gnu_type;
  67.  
  68.     my $gcc_host_gnu_type = `\${CC:-gcc} -dumpmachine`;
  69.     if ($? >> 8) {
  70.         $gcc_host_gnu_type = '';
  71.     } else {
  72.         chomp $gcc_host_gnu_type;
  73.     }
  74.  
  75.     return $gcc_host_gnu_type;
  76.     }
  77.  
  78.     sub get_raw_host_arch()
  79.     {
  80.     return $host_arch if defined $host_arch;
  81.  
  82.     $gcc_host_gnu_type = get_gcc_host_gnu_type();
  83.  
  84.     if ($gcc_host_gnu_type eq '') {
  85.         warning(_g("Couldn't determine gcc system type, falling back to " .
  86.                    "default (native compilation)"));
  87.     } else {
  88.         my (@host_archtriplet) = gnutriplet_to_debtriplet($gcc_host_gnu_type);
  89.         $host_arch = debtriplet_to_debarch(@host_archtriplet);
  90.  
  91.         if (defined $host_arch) {
  92.         $gcc_host_gnu_type = debtriplet_to_gnutriplet(@host_archtriplet);
  93.         } else {
  94.         warning(_g("Unknown gcc system type %s, falling back to " .
  95.                    "default (native compilation)"), $gcc_host_gnu_type);
  96.         $gcc_host_gnu_type = '';
  97.         }
  98.     }
  99.  
  100.     if (!defined($host_arch)) {
  101.         # Switch to native compilation.
  102.         $host_arch = get_raw_build_arch();
  103.     }
  104.  
  105.     return $host_arch;
  106.     }
  107.  
  108.     sub get_host_arch()
  109.     {
  110.     return $ENV{DEB_HOST_ARCH} || get_raw_host_arch();
  111.     }
  112. }
  113.  
  114. sub get_valid_arches()
  115. {
  116.     read_cputable() if (!@cpu);
  117.     read_ostable() if (!@os);
  118.  
  119.     my @arches;
  120.  
  121.     foreach my $os (@os) {
  122.     foreach my $cpu (@cpu) {
  123.         my $arch = debtriplet_to_debarch(split(/-/, $os, 2), $cpu);
  124.         push @arches, $arch if defined($arch);
  125.     }
  126.     }
  127.  
  128.     return @arches;
  129. }
  130.  
  131. sub read_cputable
  132. {
  133.     local $_;
  134.     local $/ = "\n";
  135.  
  136.     open CPUTABLE, "$pkgdatadir/cputable"
  137.     or syserr(_g("cannot open %s"), "cputable");
  138.     while (<CPUTABLE>) {
  139.     if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/) {
  140.         $cputable{$1} = $2;
  141.         $cputable_re{$1} = $3;
  142.         $cpubits{$1} = $4;
  143.         $cpuendian{$1} = $5;
  144.         push @cpu, $1;
  145.     }
  146.     }
  147.     close CPUTABLE;
  148. }
  149.  
  150. sub read_ostable
  151. {
  152.     local $_;
  153.     local $/ = "\n";
  154.  
  155.     open OSTABLE, "$pkgdatadir/ostable"
  156.     or syserr(_g("cannot open %s"), "ostable");
  157.     while (<OSTABLE>) {
  158.     if (m/^(?!\#)(\S+)\s+(\S+)\s+(\S+)/) {
  159.         $ostable{$1} = $2;
  160.         $ostable_re{$1} = $3;
  161.         push @os, $1;
  162.     }
  163.     }
  164.     close OSTABLE;
  165. }
  166.  
  167. sub read_triplettable()
  168. {
  169.     read_cputable() if (!@cpu);
  170.  
  171.     local $_;
  172.     local $/ = "\n";
  173.  
  174.     open TRIPLETTABLE, "$pkgdatadir/triplettable"
  175.     or syserr(_g("cannot open %s"), "triplettable");
  176.     while (<TRIPLETTABLE>) {
  177.     if (m/^(?!\#)(\S+)\s+(\S+)/) {
  178.         my $debtriplet = $1;
  179.         my $debarch = $2;
  180.  
  181.         if ($debtriplet =~ /<cpu>/) {
  182.         foreach my $_cpu (@cpu) {
  183.             (my $dt = $debtriplet) =~ s/<cpu>/$_cpu/;
  184.             (my $da = $debarch) =~ s/<cpu>/$_cpu/;
  185.  
  186.             $debarch_to_debtriplet{$da} = $dt;
  187.             $debtriplet_to_debarch{$dt} = $da;
  188.         }
  189.         } else {
  190.         $debarch_to_debtriplet{$2} = $1;
  191.         $debtriplet_to_debarch{$1} = $2;
  192.         }
  193.     }
  194.     }
  195.     close TRIPLETTABLE;
  196. }
  197.  
  198. sub debtriplet_to_gnutriplet(@)
  199. {
  200.     read_cputable() if (!@cpu);
  201.     read_ostable() if (!@os);
  202.  
  203.     my ($abi, $os, $cpu) = @_;
  204.  
  205.     return undef unless defined($abi) && defined($os) && defined($cpu) &&
  206.         exists($cputable{$cpu}) && exists($ostable{"$abi-$os"});
  207.     return join("-", $cputable{$cpu}, $ostable{"$abi-$os"});
  208. }
  209.  
  210. sub gnutriplet_to_debtriplet($)
  211. {
  212.     my ($gnu) = @_;
  213.     return undef unless defined($gnu);
  214.     my ($gnu_cpu, $gnu_os) = split(/-/, $gnu, 2);
  215.     return undef unless defined($gnu_cpu) && defined($gnu_os);
  216.  
  217.     read_cputable() if (!@cpu);
  218.     read_ostable() if (!@os);
  219.  
  220.     my ($os, $cpu);
  221.  
  222.     foreach my $_cpu (@cpu) {
  223.     if ($gnu_cpu =~ /^$cputable_re{$_cpu}$/) {
  224.         $cpu = $_cpu;
  225.         last;
  226.     }
  227.     }
  228.  
  229.     foreach my $_os (@os) {
  230.     if ($gnu_os =~ /^(.*-)?$ostable_re{$_os}$/) {
  231.         $os = $_os;
  232.         last;
  233.     }
  234.     }
  235.  
  236.     return undef if !defined($cpu) || !defined($os);
  237.     return (split(/-/, $os, 2), $cpu);
  238. }
  239.  
  240. sub debtriplet_to_debarch(@)
  241. {
  242.     read_triplettable() if (!%debtriplet_to_debarch);
  243.  
  244.     my ($abi, $os, $cpu) = @_;
  245.  
  246.     if (!defined($abi) || !defined($os) || !defined($cpu)) {
  247.     return undef;
  248.     } elsif (exists $debtriplet_to_debarch{"$abi-$os-$cpu"}) {
  249.     return $debtriplet_to_debarch{"$abi-$os-$cpu"};
  250.     } else {
  251.     return undef;
  252.     }
  253. }
  254.  
  255. sub debarch_to_debtriplet($)
  256. {
  257.     read_triplettable() if (!%debarch_to_debtriplet);
  258.  
  259.     local ($_) = @_;
  260.     my $arch;
  261.  
  262.     if (/^linux-([^-]*)/) {
  263.     # XXX: Might disappear in the future, not sure yet.
  264.     $arch = $1;
  265.     } else {
  266.     $arch = $_;
  267.     }
  268.  
  269.     my $triplet = $debarch_to_debtriplet{$arch};
  270.  
  271.     if (defined($triplet)) {
  272.     return split('-', $triplet, 3);
  273.     } else {
  274.     return undef;
  275.     }
  276. }
  277.  
  278. sub debarch_to_gnutriplet($)
  279. {
  280.     my ($arch) = @_;
  281.  
  282.     return debtriplet_to_gnutriplet(debarch_to_debtriplet($arch));
  283. }
  284.  
  285. sub gnutriplet_to_debarch($)
  286. {
  287.     my ($gnu) = @_;
  288.  
  289.     return debtriplet_to_debarch(gnutriplet_to_debtriplet($gnu));
  290. }
  291.  
  292. sub debwildcard_to_debtriplet($)
  293. {
  294.     local ($_) = @_;
  295.  
  296.     if (/any/) {
  297.     if (/^([^-]*)-([^-]*)-(.*)/) {
  298.         return ($1, $2, $3);
  299.     } elsif (/^([^-]*)-([^-]*)$/) {
  300.         return ('any', $1, $2);
  301.     } else {
  302.         return ($_, $_, $_);
  303.     }
  304.     } else {
  305.     return debarch_to_debtriplet($_);
  306.     }
  307. }
  308.  
  309. sub debarch_to_cpuattrs($)
  310. {
  311.     my ($arch) = @_;
  312.     my ($abi, $os, $cpu) = debarch_to_debtriplet($arch);
  313.  
  314.     if (defined($cpu)) {
  315.         return ($cpubits{$cpu}, $cpuendian{$cpu});
  316.     } else {
  317.         return undef;
  318.     }
  319. }
  320.  
  321. sub debarch_eq($$)
  322. {
  323.     my ($a, $b) = @_;
  324.  
  325.     return 1 if ($a eq $b);
  326.  
  327.     my @a = debarch_to_debtriplet($a);
  328.     my @b = debarch_to_debtriplet($b);
  329.  
  330.     return 0 if grep(!defined, (@a, @b));
  331.  
  332.     return ($a[0] eq $b[0] && $a[1] eq $b[1] && $a[2] eq $b[2]);
  333. }
  334.  
  335. sub debarch_is($$)
  336. {
  337.     my ($real, $alias) = @_;
  338.  
  339.     return 1 if ($alias eq $real or $alias eq 'any');
  340.  
  341.     my @real = debarch_to_debtriplet($real);
  342.     my @alias = debwildcard_to_debtriplet($alias);
  343.  
  344.     return 0 if grep(!defined, (@real, @alias));
  345.  
  346.     if (($alias[0] eq $real[0] || $alias[0] eq 'any') &&
  347.         ($alias[1] eq $real[1] || $alias[1] eq 'any') &&
  348.         ($alias[2] eq $real[2] || $alias[2] eq 'any')) {
  349.     return 1;
  350.     }
  351.  
  352.     return 0;
  353. }
  354.  
  355. 1;
  356.