Posted to tcl by FLORENTIS at Thu Oct 15 15:41:49 GMT 2026view raw

  1. # bitarray_exemples.tcl --
  2. #
  3. # Trois usages de bitarray(n, ordre) :
  4. #
  5. # 1. l'octet « packed » d'un GIF (écran logique) : msb0, car la
  6. # spécification décrit les bits de gauche à droite ;
  7. # 2. les drapeaux d'un segment TCP : msb0, comme le schéma de la RFC 9293
  8. # (le bit 0 est le premier bit transmis, le plus à gauche) ;
  9. # 3. les permissions Unix (rwxr-xr-x) : lsb0, comme 1 << i en C.
  10. #
  11. # On voit pourquoi les deux ordres existent : le bon est celui du document
  12. # que l'on recopie. Aucun fichier externe n'est nécessaire.
  13.  
  14. # ===========================================================================
  15. # 1. L'octet packed d'un GIF
  16. #
  17. # 7 6 5 4 3 2 1 0
  18. # +---+-----+------+------+
  19. # | G | res | sort | size | G : table de couleurs globale présente
  20. # +---+-----+------+------+ res : résolution - 1 (3 bits)
  21. # sort : palette triée
  22. # size : la palette a 2^(size+1) couleurs
  23. #
  24. # En msb0 on écrit les indices dans l'ordre où la spécification présente les
  25. # champs : 0 | 1:3 | 4 | 5:7.
  26. # ===========================================================================
  27.  
  28. puts "=== 1. octet packed d'un GIF ==="
  29. type def gifpacked {{bitarray(8,msb0)}bits}
  30.  
  31. proc decrire_packed {octet} {
  32. set {bitarray(8,msb0)}p $octet
  33. puts [format " 0x%02X = %s" $octet [join [lmap i {0 1 2 3 4 5 6 7} {set p($i)}] ""]]
  34. puts " table globale : [expr {$p(0) ? "oui" : "non"}]"
  35. puts " résolution : [expr {$p(1:3) + 1}] bit(s) par couleur primaire"
  36. puts " palette triée : [expr {$p(4) ? "oui" : "non"}]"
  37. puts " couleurs : [expr {1 << ($p(5:7) + 1)}]"
  38. }
  39. decrire_packed 0xF7 ;# GCT, 8 bits, non triée, 256 couleurs
  40. decrire_packed 0x80 ;# GCT, 1 bit, 2 couleurs (le GIF 1x1 de gif_somme.tcl)
  41.  
  42. # Construire l'octet champ par champ
  43. set {bitarray(8,msb0)}neuf 0
  44. set neuf(0) 1 ;# palette globale
  45. set neuf(1:3) 5 ;# 6 bit(s) par couleur primaire
  46. set neuf(5:7) 3 ;# 16 couleurs
  47. puts [format " construit : 0x%02X" $neuf]
  48.  
  49. # Le même octet lu en lsb0 : les indices sont à l'envers, c'est le piège.
  50. set {bitarray(8,lsb0)}l 0xF7
  51. puts " lsb0 : l'indicateur de table globale est l(7)=$l(7), la taille l(0:2)=$l(0:2)"
  52.  
  53. # ===========================================================================
  54. # 2. Les drapeaux d'un segment TCP (octets 12 et 13 de l'en-tête)
  55. #
  56. # 0 3 4 6 7 8 9 10 11 12 13 14 15
  57. # +---------+-------+--+---+---+---+---+---+---+---+---+
  58. # | offset | rsv |NS|CWR|ECE|URG|ACK|PSH|RST|SYN|FIN|
  59. # +---------+-------+--+---+---+---+---+---+---+---+---+
  60. # ===========================================================================
  61.  
  62. puts "\n=== 2. drapeaux TCP ==="
  63. set noms_drapeaux {NS CWR ECE URG ACK PSH RST SYN FIN} ;# bits 7 à 15
  64.  
  65. proc drapeaux {mot} {
  66. global noms_drapeaux
  67. set actifs {}
  68. set i 7
  69. foreach nom $noms_drapeaux {
  70. if {$mot($i)} {lappend actifs $nom}
  71. incr i
  72. }
  73. expr {[llength $actifs] ? [join $actifs +] : "-"}
  74. }
  75.  
  76. # fabrication d'un SYN+ACK, en-tête de 5 mots de 32 bits
  77. set {bitarray(16,msb0)}mot 0
  78. set mot(0:3) 5 ;# data offset
  79. set mot(14) 1 ;# SYN
  80. set mot(11) 1 ;# ACK
  81. puts [format " mot construit : 0x%04X offset=%d drapeaux=%s" $mot $mot(0:3) [drapeaux $mot]]
  82.  
  83. # décodage depuis les deux octets bruts, comme dans un vrai paquet
  84. set octets [binary format S $mot]
  85. binary scan $octets Su valeur
  86. set {bitarray(16,msb0)}lu $valeur
  87. puts " relu : offset=$lu(0:3) drapeaux=[drapeaux $lu] (bits à 1 : [expr {popcount($lu)}])"
  88.  
  89. foreach {nom hex} {syn 0x5002 synack 0x5012 fin_ack 0x5011 rst 0x5004 push_ack 0x5018} {
  90. set {bitarray(16,msb0)}w $hex
  91. puts [format " %-9s 0x%04X %s" $nom $w [drapeaux $w]]
  92. }
  93.  
  94. # Le même mot lu avec le MAUVAIS ordre : une erreur de type, pas un résultat faux.
  95. if {[catch {set {bitarray(16,lsb0)}faux $lu} msg]} {
  96. puts " lsb0 <- msb0 : $msg"
  97. }
  98.  
  99. # ===========================================================================
  100. # 3. Les permissions Unix : rwxr-xr-x
  101. #
  102. # bit 8 7 6 5 4 3 2 1 0
  103. # r w x r w x r w x
  104. # user group other
  105. #
  106. # En lsb0, 'other' occupe les bits 0:2, 'group' 3:5, 'user' 6:8 : c'est la
  107. # numération octale (chmod 755 = trois chiffres de 3 bits).
  108. # ===========================================================================
  109.  
  110. puts "\n=== 3. permissions Unix ==="
  111.  
  112. proc symbolique {m} {
  113. set s ""
  114. foreach lettre {r w x r w x r w x} i {8 7 6 5 4 3 2 1 0} {
  115. append s [expr {$m($i) ? $lettre : "-"}]
  116. }
  117. return $s
  118. }
  119.  
  120. proc chmod_octal {m} {
  121. format %o%o%o $m(6:8) $m(3:5) $m(0:2)
  122. }
  123.  
  124. set {bitarray(9)}perm 0o755
  125. puts [format " 0o755 -> %s (octal %s, %d droits accordés)" \
  126. [symbolique $perm] [chmod_octal $perm] [expr {popcount($perm)}]]
  127.  
  128. # chmod g+w : un bit
  129. set perm(4) 1
  130. puts " g+w -> [symbolique $perm] [chmod_octal $perm]"
  131. # chmod o= : une tranche
  132. set perm(0:2) 0
  133. puts " o= -> [symbolique $perm] [chmod_octal $perm]"
  134. # chmod u=rw : une tranche
  135. set perm(6:8) 6
  136. puts " u=rw -> [symbolique $perm] [chmod_octal $perm]"
  137. # un umask 022 appliqué à 0666
  138. set {bitarray(9)}fichier 0o666
  139. set {bitarray(9)}masque 0o22
  140. set resultat [expr {$fichier & ~$masque & 0o777}]
  141. set {bitarray(9)}final $resultat
  142. puts " 0o666 & ~0o22 -> [symbolique $final] [chmod_octal $final]"
  143.  
  144. # La valeur ne peut pas dépasser 9 bits
  145. if {[catch {set {bitarray(9)}trop 0o1000} msg]} {puts " 0o1000 : $msg"}

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