Posted to tcl by Florentis at Fri Oct 16 04:37:47 GMT 2026view raw

  1. # executable_elf.tcl --
  2. #
  3. # FR : Un type « fichier exécutable » pour le format ELF (Linux, BSD...).
  4. # On lit le vrai fichier avec binary scan, on remplit des types, puis
  5. # on analyse avec des masques de bits.
  6. # EN : An "executable file" type for the ELF format (Linux, BSD...).
  7. # We read the real file with binary scan, fill typed values, then
  8. # analyse them with bit masks.
  9. #
  10. # usage : tclsh executable_elf.tcl ?file? (default: the running tclsh)
  11. #
  12. # FR : Ce que l'exemple illustre :
  13. # - des produits (segment, section) et un type paramétré elf(n) ;
  14. # - bitarray pour les drapeaux : permissions d'un segment (bit 0 = X,
  15. # bit 1 = W, bit 2 = R, comme p_flags : convention lsb0) ;
  16. # - la structure d'hypergraphe : les sections sont les sommets, les
  17. # segments sont les hyperarêtes (une section peut être dans plusieurs
  18. # segments). La « couverture » est une liste de masques, comme edges
  19. # dans hg(n) (voir hypergraphe.tcl) ;
  20. # - les contrôles entre champs (W^X, point d'entrée) restent des
  21. # procédures : le type vérifie les formes et les plages, pas les liens
  22. # logiques entre champs.
  23. # EN: What the example shows:
  24. # - products (segment, section) and a parameterized type elf(n);
  25. # - bitarray for flags: segment permissions (bit 0 = X, bit 1 = W,
  26. # bit 2 = R, as in p_flags: lsb0 convention);
  27. # - the hypergraph structure: sections are the vertices, segments are
  28. # the hyperedges (a section can belong to several segments). The
  29. # "coverage" is a list of masks, like edges in hg(n) (see
  30. # hypergraphe.tcl);
  31. # - cross-field checks (W^X, entry point) stay in procedures: the type
  32. # checks shapes and ranges, not logical relations between fields.
  33.  
  34. # ---------------------------------------------------------------------------
  35. # FR : Les types / EN: The types
  36. # ---------------------------------------------------------------------------
  37.  
  38. type def segment {
  39. {string}genre; # LOAD, DYNAMIC, NOTE... (segment kind)
  40. {bitarray(3)}perms; # bit0 = X, bit1 = W, bit2 = R
  41. {int}offset; {int}vaddr; {int}filesz; {int}memsz
  42. }
  43. type def section {
  44. {string}nom; {string}genre; # name, kind
  45. {bitarray(64)}flags; # bit0 = WRITE, bit1 = ALLOC, bit2 = EXEC
  46. {int}addr; {int}offset; {int}taille
  47. }
  48. # FR : n = nombre de sections = nombre de sommets de l'hypergraphe.
  49. # EN : n = number of sections = number of vertices of the hypergraph.
  50. type def {elf({int}n)} {
  51. {int}bits; {string}endian; {string}machine; {int}entry;
  52. {list($n).section}sections;
  53. {list.segment}segments;
  54. {list.bitarray($n)}couverture ;# FR: un masque par segment / EN: one mask per segment
  55. }
  56.  
  57. # ---------------------------------------------------------------------------
  58. # FR : Lecture binaire / EN: Binary reading
  59. # ---------------------------------------------------------------------------
  60.  
  61. # FR : lire data off endian w1 w2... : lit des entiers non signés de largeur
  62. # 1, 2, 4 ou 8 octets à partir de off, et rend la liste des valeurs.
  63. # EN : lire data off endian w1 w2... : reads unsigned integers of width
  64. # 1, 2, 4 or 8 bytes starting at off, and returns the list of values.
  65. proc lire {data off endian args} {
  66. set big [expr {$endian eq "big"}]
  67. set fmt "@$off"
  68. set names {}
  69. set i 0
  70. foreach w $args {
  71. append fmt [dict get [expr {$big
  72. ? {1 cu 2 Su 4 Iu 8 Wu}
  73. : {1 cu 2 su 4 iu 8 wu}}] $w]
  74. lappend names v$i
  75. incr i
  76. }
  77. binary scan $data $fmt {*}$names
  78. lmap v $names {set $v}
  79. }
  80.  
  81. # FR : lecture d'une chaîne terminée par un zéro (table de noms)
  82. # EN : reads a NUL-terminated string (name table)
  83. proc chaine {data off} {
  84. set fin [string first \x00 $data $off]
  85. encoding convertfrom ascii [string range $data $off [expr {$fin - 1}]]
  86. }
  87.  
  88. # FR : tables de noms / EN: name tables
  89. set TYPES_SEG {0 NULL 1 LOAD 2 DYNAMIC 3 INTERP 4 NOTE 5 SHLIB 6 PHDR 7 TLS
  90. 1685382480 GNU_EH_FRAME 1685382481 GNU_STACK 1685382482 GNU_RELRO
  91. 1685382483 GNU_PROPERTY}
  92. set TYPES_SEC {0 NULL 1 PROGBITS 2 SYMTAB 3 STRTAB 4 RELA 5 HASH 6 DYNAMIC
  93. 7 NOTE 8 NOBITS 9 REL 11 DYNSYM 14 INIT_ARRAY 15 FINI_ARRAY
  94. 1879048182 GNU_HASH 1879048190 VERNEED 1879048191 VERSYM}
  95. set MACHINES {3 x86 40 ARM 62 x86-64 183 AArch64 243 RISC-V}
  96.  
  97. proc nom_de {table code} {
  98. expr {[dict exists $table $code] ? [dict get $table $code] : "0x[format %x $code]"}
  99. }
  100.  
  101. # ---------------------------------------------------------------------------
  102. # FR : Lecture d'un fichier ELF / EN: Reading an ELF file
  103. # ---------------------------------------------------------------------------
  104.  
  105. # FR : rend un nom de variable-type : le résultat est une valeur elf(n).
  106. # EN : returns a value of type elf(n), as a list {n description}.
  107. proc lire_elf {chemin} {
  108. global TYPES_SEG TYPES_SEC MACHINES
  109. set f [open $chemin rb]
  110. set data [read $f]
  111. close $f
  112.  
  113. binary scan $data a4cc magic classe donnee
  114. if {$magic ne "\x7fELF"} {error "$chemin: not an ELF file"}
  115. set bits [expr {$classe == 2 ? 64 : 32}]
  116. set endian [expr {$donnee == 2 ? "big" : "little"}]
  117. set a [expr {$bits == 64 ? 8 : 4}] ;# FR: largeur d'une adresse / EN: address width
  118.  
  119. # FR : en-tête du fichier / EN: file header
  120. lassign [lire $data 16 $endian 2 2] genre machine
  121. lassign [lire $data [expr {24}] $endian $a $a $a] entry phoff shoff
  122. set apres [expr {24 + 3 * $a}]
  123. lassign [lire $data $apres $endian 4 2 2 2 2 2 2] \
  124. - ehsize phentsize phnum shentsize shnum shstrndx
  125.  
  126. # FR : en-têtes de section / EN: section headers
  127. set sec {}
  128. for {set i 0} {$i < $shnum} {incr i} {
  129. set o [expr {$shoff + $i * $shentsize}]
  130. if {$bits == 64} {
  131. lassign [lire $data $o $endian 4 4 8 8 8 8] nm gen fl addr off tai
  132. } else {
  133. lassign [lire $data $o $endian 4 4 4 4 4 4] nm gen fl addr off tai
  134. }
  135. lappend sec [list $nm $gen $fl $addr $off $tai]
  136. }
  137. # FR : la table des noms est elle-même une section / EN: the name table is itself a section
  138. set tabnoms [lindex $sec $shstrndx 4]
  139. set sections {}
  140. foreach s $sec {
  141. lassign $s nm gen fl addr off tai
  142. lappend sections [list [chaine $data [expr {$tabnoms + $nm}]] \
  143. [nom_de $TYPES_SEC $gen] $fl $addr $off $tai]
  144. }
  145.  
  146. # FR : en-têtes de programme (segments) / EN: program headers (segments)
  147. set segments {}
  148. for {set i 0} {$i < $phnum} {incr i} {
  149. set o [expr {$phoff + $i * $phentsize}]
  150. if {$bits == 64} {
  151. lassign [lire $data $o $endian 4 4 8 8 8 8 8] gen fl off va pa fs ms
  152. } else {
  153. lassign [lire $data $o $endian 4 4 4 4 4 4 4] gen off va pa fs ms fl
  154. }
  155. lappend segments [list [nom_de $TYPES_SEG $gen] [expr {$fl & 7}] $off $va $fs $ms]
  156. }
  157.  
  158. set n [llength $sections]
  159. set couverture [remplir_couverture $sections $segments]
  160. return [list $n [list $bits $endian [nom_de $MACHINES $machine] $entry \
  161. $sections $segments $couverture]]
  162. }
  163.  
  164. # FR : couverture = hypergraphe section/segment. Le bit i du masque d'un
  165. # segment vaut 1 si la section i y est contenue (comme readelf :
  166. # section allouée, de taille non nulle, entièrement dans le segment).
  167. # EN : coverage = section/segment hypergraph. Bit i of a segment's mask is
  168. # 1 if section i lies in it (like readelf: allocated section, non-
  169. # empty, fully inside the segment).
  170. proc remplir_couverture {sections segments} {
  171. set masques {}
  172. foreach seg $segments {
  173. lassign $seg gen perms off va fs ms
  174. set m 0
  175. set i 0
  176. foreach s $sections {
  177. lassign $s nom sgen fl addr soff tai
  178. if {($fl & 2) && $tai > 0 && $addr >= $va && $addr + $tai <= $va + $ms} {
  179. set m [expr {$m | (1 << $i)}]
  180. }
  181. incr i
  182. }
  183. lappend masques $m
  184. }
  185. return $masques
  186. }
  187.  
  188. # FR : le programme principal ne s'exécute que si ce fichier est lancé
  189. # directement (pas quand il est chargé par source depuis executable.tcl).
  190. # EN : the main program only runs when this file is launched directly
  191. # (not when sourced from executable.tcl).
  192. if {[file normalize [info script]] eq [file normalize $argv0]} {
  193. # ---------------------------------------------------------------------------
  194. # FR : Programme principal / EN: Main program
  195. # ---------------------------------------------------------------------------
  196.  
  197. set chemin [expr {$argc ? [lindex $argv 0] : [info nameofexecutable]}]
  198. lassign [lire_elf $chemin] n valeurs
  199.  
  200. # FR : le type est choisi à l'exécution : elf(31), elf(28)...
  201. # EN : the type is chosen at run time: elf(31), elf(28)...
  202. # FR : le nom du type contient n, donc on construit la commande en texte.
  203. # EN : the type name contains n, so the command is built as text.
  204. set cmd "set {elf($n)}E"
  205. foreach champ {bits endian machine entry sections segments couverture} v $valeurs {
  206. append cmd " " [list $champ $v]
  207. }
  208. eval $cmd
  209.  
  210. puts "type : [type get $E]"
  211. puts "ELF$E(bits) $E(endian), machine $E(machine), entry [format 0x%x $E(entry)]"
  212. puts "[llength $E(sections)] sections, [llength $E(segments)] segments"
  213.  
  214. # FR : noms des sections dont le bit est à 1 dans un masque
  215. # EN : names of the sections whose bit is 1 in a mask
  216. proc noms_sections {E masque} {
  217. set out {}
  218. for {set i 0} {$i < [llength $E(sections)]} {incr i} {
  219. if {($masque >> $i) & 1} {lappend out $E(sections.$i.nom)}
  220. }
  221. return $out
  222. }
  223.  
  224. # FR : permissions lisibles : lecture bit par bit de bitarray(3)
  225. # EN : readable permissions: bit-by-bit reading of a bitarray(3)
  226. proc rwx {p} {
  227. return "[expr {$p(2) ? "R" : "-"}][expr {$p(1) ? "W" : "-"}][expr {$p(0) ? "X" : "-"}]"
  228. }
  229.  
  230. puts "\n--- FR: segments -> sections / EN: segments -> sections ---"
  231. for {set i 0} {$i < [llength $E(segments)]} {incr i} {
  232. set seg $E(segments.$i)
  233. puts [format "%2d %-13s %s vaddr %#8x %2d sections: %s" $i \
  234. $E(segments.$i.genre) [rwx $E(segments.$i.perms)] $E(segments.$i.vaddr) \
  235. [expr {popcount($E(couverture.$i))}] \
  236. [join [noms_sections $E $E(couverture.$i)] " "]]
  237. }
  238.  
  239. # FR : sections hors de tout segment (le complément de l'union)
  240. # EN : sections outside any segment (the complement of the union)
  241. set n [llength $E(sections)]
  242. set union 0
  243. for {set i 0} {$i < [llength $E(couverture)]} {incr i} {
  244. set union [expr {$union | $E(couverture.$i)}]
  245. }
  246. set hors [expr {$union ^ ((1 << $n) - 1)}]
  247. puts "\nFR: sections non chargées en mémoire / EN: sections not loaded in memory ([expr {popcount($hors)}]):"
  248. puts " [join [noms_sections $E $hors] " "]"
  249.  
  250. # FR : intersection de deux hyperarêtes : sections communes à deux segments
  251. # EN : intersection of two hyperedges: sections shared by two segments
  252. puts "\nFR: sections partagées par deux segments / EN: sections shared by two segments"
  253. for {set i 0} {$i < [llength $E(couverture)]} {incr i} {
  254. for {set j [expr {$i + 1}]} {$j < [llength $E(couverture)]} {incr j} {
  255. set c [expr {$E(couverture.$i) & $E(couverture.$j)}]
  256. if {$c} {
  257. puts " $E(segments.$i.genre)#$i & $E(segments.$j.genre)#$j : [join [noms_sections $E $c] " "]"
  258. }
  259. }
  260. }
  261.  
  262. # FR : degré d'une section = nombre de segments qui la contiennent
  263. # EN : degree of a section = number of segments containing it
  264. puts "\nFR: sections dans au moins 3 segments / EN: sections in at least 3 segments"
  265. for {set k 0} {$k < $n} {incr k} {
  266. set deg 0
  267. for {set i 0} {$i < [llength $E(couverture)]} {incr i} {
  268. incr deg $E(couverture.$i.$k)
  269. }
  270. if {$deg >= 3} {puts " $E(sections.$k.nom) : $deg"}
  271. }
  272.  
  273. # ---------------------------------------------------------------------------
  274. # FR : contrôles entre champs (hors du type) / EN: cross-field checks (outside the type)
  275. # ---------------------------------------------------------------------------
  276.  
  277. puts "\n--- FR: contrôles / EN: checks ---"
  278.  
  279. # W^X : aucun segment à la fois inscriptible et exécutable
  280. # W^X: no segment both writable and executable
  281. set wx {}
  282. for {set i 0} {$i < [llength $E(segments)]} {incr i} {
  283. if {($E(segments.$i.perms) & 3) == 3} {lappend wx $i}
  284. }
  285. puts "W^X : [expr {[llength $wx] ? "VIOLATION segments $wx" : "ok"}]"
  286.  
  287. # FR : le point d'entrée doit tomber dans un segment LOAD exécutable
  288. # EN : the entry point must fall in an executable LOAD segment
  289. set trouve ""
  290. for {set i 0} {$i < [llength $E(segments)]} {incr i} {
  291. set va $E(segments.$i.vaddr)
  292. if {$E(segments.$i.genre) eq "LOAD" && $E(entry) >= $va
  293. && $E(entry) < $va + $E(segments.$i.memsz)} {
  294. set trouve $i
  295. }
  296. }
  297. if {$trouve ne "" && $E(segments.$trouve.perms.0)} {
  298. puts "entry point : ok (segment $trouve, [rwx $E(segments.$trouve.perms)])"
  299. } else {
  300. puts "entry point : PROBLEM"
  301. }
  302.  
  303. # FR : garanties du typage / EN: guarantees of the typing
  304. puts "\n--- FR: refus du typage / EN: what typing refuses ---"
  305. puts "perms=9 : [catch {set {segment}P genre LOAD perms 9 offset 0 vaddr 0 filesz 0 memsz 0} msg] $msg"
  306. puts "bad count : [catch {set {elf(3)}Z bits 64 endian little machine x entry 0 sections {} segments {} couverture {}} msg] $msg"
  307. }

Add a comment

Please note that this site uses the meta tags nofollow,noindex for all pages that contain comments.
Items are closed for new comments after 1 week