Source file architecture.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
(******************************************************************************)
(*  This file is part of the Dose library http://www.irill.org/software/dose  *)
(*                                                                            *)
(*  Copyright (C) 2010,2011 Ralf Treinen <ralf.treinen@pps.jussieu.fr>        *)
(*                                                                            *)
(*  This library is free software: you can redistribute it and/or modify      *)
(*  it under the terms of the GNU Lesser General Public License as            *)
(*  published by the Free Software Foundation, either version 3 of the        *)
(*  License, or (at your option) any later version.  A special linking        *)
(*  exception to the GNU Lesser General Public License applies to this        *)
(*  library, see the COPYING file for more information.                       *)
(*                                                                            *)
(*  Work developed with the support of the Mancoosi Project                   *)
(*  http://www.mancoosi.org                                                   *)
(*                                                                            *)
(******************************************************************************)

module Pcre = Re_pcre
open ExtLib
open Dose_common

include Util.Logging (struct
  let label = "dose_deb.architecture"
end)

(* first column of /usr/share/dpkg/cputable *)
(* the line numbers correspond to the line numbers in /usr/share/dpkg/cputable
 * to be quickly able to find changes *)
let cpulist =
  ref
    [ (* lines 19..25 *)
      "i386";
      "ia64";
      "alpha";
      "amd64";
      "armeb";
      "arm";
      "arm64";
      (* lines 26..31 *)
      "avr32";
      "hppa";
      "m32r";
      "m68k";
      "mips";
      "mipsel";
      (* lines 32..36 *)
      "mipsr6";
      "mipsr6el";
      "mips64";
      "mips64el";
      "mips64r6";
      (* lines 37..41 *)
      "mips64r6el";
      "nios2";
      "or1k";
      "powerpc";
      "powerpcel";
      (* lines 42..48 *)
      "ppc64";
      "ppc64el";
      "s390";
      "s390x";
      "sh3";
      "sh3eb";
      "sh4";
      (* lines 49..52 *)
      "sh4eb";
      "sparc";
      "sparc64";
      "tilegx" ]

(* from /usr/share/dpkg/tupletable
 *
 * the line numbers correspond to the line numbers in
 * /usr/share/dpkg/tupletable to be quickly able to find changes
 *
 *   debian tuple (abi,libc,os,cpu)      debian arch *)
let tupletable =
  ref
    [ (("eabi", "uclibc", "linux", "arm"), "uclibc-linux-armel");
      (* line 8  *)
      (("base", "uclibc", "linux", "<cpu>"), "uclibc-linux-<cpu>");
      (("eabihf", "musl", "linux", "arm"), "musl-linux-armhf");
      (* line 10 *)
      (("base", "musl", "linux", "<cpu>"), "musl-linux-<cpu>");
      (("eabihf", "gnu", "linux", "arm"), "armhf");
      (("eabi", "gnu", "linux", "arm"), "armel");
      (("abin32", "gnu", "linux", "mips64r6el"), "mipsn32r6el");
      (("abin32", "gnu", "linux", "mips64r6"), "mipsn32r6");
      (* line 15 *)
      (("abin32", "gnu", "linux", "mips64el"), "mipsn32el");
      (("abin32", "gnu", "linux", "mips64"), "mipsn32");
      (("abi64", "gnu", "linux", "mips64r6el"), "mips64r6el");
      (("abi64", "gnu", "linux", "mips64r6"), "mips64r6");
      (("abi64", "gnu", "linux", "mips64el"), "mips64el");
      (* line 20 *)
      (("abi64", "gnu", "linux", "mips64"), "mips64");
      (("spe", "gnu", "linux", "powerpc"), "powerpcspe");
      (("x32", "gnu", "linux", "amd64"), "x32");
      (("base", "gnu", "linux", "<cpu>"), "<cpu>");
      (("eabihf", "gnu", "kfreebsd", "arm"), "kfreebsd-armhf");
      (* line 25 *)
      (("base", "gnu", "kfreebsd", "<cpu>"), "kfreebsd-<cpu>");
      (("base", "gnu", "knetbsd", "<cpu>"), "knetbsd-<cpu>");
      (("base", "gnu", "kopensolaris", "<cpu>"), "kopensolaris-<cpu>");
      (("base", "gnu", "hurd", "<cpu>"), "hurd-<cpu>");
      (("base", "bsd", "dragonflybsd", "<cpu>"), "dragonflybsd-<cpu>");
      (* line 30 *)
      (("base", "bsd", "freebsd", "<cpu>"), "freebsd-<cpu>");
      (("base", "bsd", "openbsd", "<cpu>"), "openbsd-<cpu>");
      (("base", "bsd", "netbsd", "<cpu>"), "netbsd-<cpu>");
      (("base", "bsd", "darwin", "<cpu>"), "darwin-<cpu>");
      (("base", "sysv", "aix", "<cpu>"), "aix-<cpu>");
      (* line 35 *)
      (("base", "sysv", "solaris", "<cpu>"), "solaris-<cpu>");
      (("eabi", "uclibc", "uclinux", "arm"), "uclinux-armel");
      (("base", "uclibc", "uclinux", "<cpu>"), "uclinux-<cpu>");
      (("base", "tos", "mint", "m68k"), "mint-m68k");
      (("base", "gnu", "linux", "<cpu>"), "linux-<cpu>")
      (* this entry is not from /usr/share/dpkg/tupletable *)
      (* the "linux-" prefix is commented in scripts/Dpkg/Arch.pm with "XXX: Might disappear in the future, not sure yet." *)
    ]

let debarch_to_debtuple =
  Hashtbl.create (List.length !tupletable * List.length !cpulist)

let tupletable_done = ref false

let mangle_cpu_placeholder ((abi, libc, os, cpu), debarch) =
  if cpu = "<cpu>" then
    List.iter
      (fun c ->
        let dt = (abi, libc, os, c) in
        let (_, da) = String.replace ~str:debarch ~sub:"<cpu>" ~by:c in
        Hashtbl.replace debarch_to_debtuple da dt)
      !cpulist
  else Hashtbl.replace debarch_to_debtuple debarch (abi, libc, os, cpu)

let read_tupletable ?(ttfile = None) ?(ctfile = None) () =
  if !tupletable_done && ttfile = None && ctfile = None then ()
  else (
    (* if cputable file was given, overwrite built-in table *)
    (match ctfile with
    | Some fn ->
        cpulist := [] ;
        let ic = open_in fn in
        if input_line ic <> "# Version=1.0" then
          fatal "Require cputable version 1.0" ;
        (* to stay most compatible with dpkg, it would be best to use its
         * regex from from scripts/Dpkg/Arch.pm to parse this file.
         * Unfortunately Re.pcre doesnt support look-ahead/look-behind
         * assertions *)
        let aux line =
          if line.[0] = '#' || not (String.contains line '\t') then ()
          else
            let spacei = String.index line '\t' in
            let cpu = String.sub line 0 spacei in
            if not (List.mem cpu !cpulist) then cpulist := cpu :: !cpulist
        in
        List.iter aux (Std.input_list ic) ;
        close_in ic
    | None -> ()) ;
    (* if tupletable was given, overwrite built-in table, otherwise parse
     * built-in table *)
    (match ttfile with
    | Some fn ->
        (* this is an implicit assumption of dpkg *)
        mangle_cpu_placeholder (("base", "gnu", "linux", "<cpu>"), "linux-<cpu>") ;
        let ic = open_in fn in
        if input_line ic <> "# Version=1.0" then
          fatal "Require tupletable version 1.0" ;
        (* to stay most compatible with dpkg, it would be best to use its
         * regex from from scripts/Dpkg/Arch.pm to parse this file.
         * Unfortunately Re.pcre doesnt support look-ahead/look-behind
         * assertions *)
        let aux line =
          if line.[0] = '#' || not (String.contains line '\t') then ()
          else
            let spaceli = String.index line '\t' in
            let spaceri = String.rindex line '\t' in
            let debtuple = String.sub line 0 spaceli in
            let debarch =
              String.sub line (spaceri + 1) (String.length line - spaceri - 1)
            in
            match String.nsplit debtuple "-" with
            | [abi; libc; os; cpu] ->
                mangle_cpu_placeholder ((abi, libc, os, cpu), debarch)
            | _ -> fatal "Cannot parse debtuple: %s" debtuple
        in
        List.iter aux (Std.input_list ic) ;
        close_in ic
    | None -> List.iter mangle_cpu_placeholder !tupletable) ;
    tupletable_done := true)

(* this function performs what debarch_is form libdpkg-perl does *)
let src_matches_arch alias real =
  read_tupletable () ;
  if alias = real || alias = "any" || alias = "all" then true
  else
    let real = Hashtbl.find_option debarch_to_debtuple real in
    (* see libdpkg-perl function debwildcard_to_debtuple *)
    let alias =
      match String.nsplit alias "-" with
      | ["any"; libc; os; cpu] -> Some ("any", libc, os, cpu)
      | [abi; "any"; os; cpu] -> Some (abi, "any", os, cpu)
      | [abi; libc; "any"; cpu] -> Some (abi, libc, "any", cpu)
      | [abi; libc; os; "any"] -> Some (abi, libc, os, "any")
      | ["any"; os; cpu] -> Some ("any", "any", os, cpu)
      | [libc; "any"; cpu] -> Some ("any", libc, "any", cpu)
      | [libc; os; "any"] -> Some ("any", libc, os, "any")
      | ["any"; cpu] -> Some ("any", "any", "any", cpu)
      | [os; "any"] -> Some ("any", "any", os, "any")
      | ["any"] -> Some ("any", "any", "any", "any")
      | _ ->
          (* only look up in the table if none of the parts is "any" *)
          Hashtbl.find_option debarch_to_debtuple alias
    in
    match (real, alias) with
    | (Some (r1, r2, r3, r4), Some (a1, a2, a3, a4)) ->
        (a1 = r1 || a1 = "any")
        && (a2 = r2 || a2 = "any")
        && (a3 = r3 || a3 = "any")
        && (a4 = r4 || a4 = "any")
    | _ -> false