Tk avancé - Construire son widget

On appelle megawidget un widget comme celui décrit ci-après, construit à partir d'autre widgets.

(2008-01-06: ajout des remerciements dans la doc)

Pourquoi

Parce que c'est (assez) facile et que ça peut rapporter (assez) gros.

Comment

En définissant un package dans un namespace.

Les principes

1. Le nouveau widget est défini dans un package (qui est l'unité de fonctionnalité dans Tcl).
2. Ses variables et procédures sont définies dans un namespace (pour éviter les conflits de nom).
3. Son interface respecte l'interface standard de Tk (pour être facile à contrôler).
4. Sa consommation de ressources est raisonnable (pour être utilisable).

L'interface

1. Une commande a pour nom le nom du package et permet de créer des widgets de ce type.
2. Le nom du widget créé est une commande qui permet de contrôler le widget au moyen de plusieurs opérations.
3. Les opérations cget et configure sont les opérations standards de Tk.
4. Les options sont calquées des options des widgets standards de Tk.
5. Les autres opérations sont calquées des opérations des widgets standards de Tk.

Un exemple

C'est un widget destiné à afficher un dégradé de couleurs en arrière-plan (pas forcément très utile mais peu servir à autre chose).

Il n'a que les deux opérations cget et configure.

Il a cinq options :

• -width la largeur du dégradé
• -height la hauteur du dégradé
• -color1 la couleur de début du dégradé
• -color2 la couleur de fin du dégradé
• -orient la direction du dégradé

Le contenu du package

• gradient.tcl : le code du package
• pkgIndex.tcl : le code d'accès au package
• gradient-doc.txt : la documentation du package
• gradient-test.tcl : le code de test du package
• gradient-demo.tcl : un code de démonstration du package

Tous ces fichiers sont obligatoires pour faire un package décent.

Les fichiers sont ci-après.

Les explications sont après chaque fichier.

Le fichier gradient.tcl

  # test si déjà sourcé
  if {[info exists ::gradient::version]} { return }

  namespace eval ::gradient \
  {
  # ######################
  #
  #      package gradient
  # (un widget qui affiche un gradient de couleurs)
  #
  variable version 1.0.0
  #
  #  (C) 2007, ulis
  # Licence NOL (No Obligation Licence)
  #
  # ######################

    # ---------------------
    # export de la commande
    # ---------------------
    namespace export gradient

    # ---------------------
    # gestion des packages
    # ---------------------
    package require Tk
    package provide gradient $version

    # ---------------------
    # variable globale
    # ---------------------
    variable {}

    # ---------------------
    # valeurs par défaut
    # ---------------------
    array set {} \
    {
      -width  100
      -height 100
      -color1 white
      -color2 gray
      -orient horizontal
    }

    # ---------------------
    # bindings de classe
    # ---------------------
    # (pas de bindings pour ce widget)

    # ---------------------
    # création d'un widget
    # ---------------------
    proc gradient {{w ""} args} \
    {
      # accès à la variable globale
      variable {}
      # test des arguments
      if {![string match .* $w]} \
      { error "use is 'gradient path ?-option value?...'" }
      if {[llength $args] % 2 != 0} \
      { error "use is 'gradient $w ?-option value?...'" }
      # récupération des erreurs
      set code [catch \
      {
        # valeurs par défaut
        foreach key [array names {} -*] { set ($w:$key) $($key) }
        # création du widget
          # un frame permet de définir la classe du widget
        frame $w -class Gradient
          # un label pour afficher l'image
        set img [image create photo]
        label $w.img -image $img
          # l'affichage du label dans le frame
        grid $w.img
        # création de la commande
          # rename pour accéder au frame
        rename $w ::gradient::_$w
          # commande pour contrôler le nouveau widget
          # (doit être une proc et non un alias)
        eval [format \
        {
          proc ::%s {args} { uplevel 1 ::gradient::operation %s $args }
        } $w $w]
        # bindings
        # (pas de bindings pour ce widgets)
        # options de création
        if {$args ne ""} { uplevel 1 ::gradient::config $w $args }
        # résultat de la commande
        set result $w
      } result]
      return -code $code $result
    }

    # ---------------------
    # choix d'une opération
    # ---------------------
    proc operation {w {oper ""} args} \
    {
      # récupération des erreurs
      set code [catch \
      {
        # choix
        switch -glob -- $oper \
        {
          cge*    { uplevel 1 ::gradient::cget    $w $args }
          con*    { uplevel 1 ::gradient::config  $w $args }
          default \
          { error "unknown gradient operation '$oper'" }
        }
      } result]
      return -code $code $result
    }

    # ---------------------
    # opération cget
    # ---------------------
    proc cget {w args} \
    {
      # accès à la variable globale
      variable {}
      # vérifications
      if {[llength $args] != 1} \
      { error "use is '$w cget -option'" }
      # retour de la valeur de l'option
      set key [lindex $args 0]
      switch -glob -- $key \
      {
        -wid*   { return $($w:-width)  }
        -hei*   { return $($w:-height) }
        -color1 { return $($w:-color1) }
        -color2 { return $($w:-color2) }
        -ori*   { return $($w:-orient) }
        default \
        { error "unknown option '$key'" }
      }
    }

    # ---------------------
    # opération configure
    # ---------------------
    proc config {w args} \
    {
      # accès à la variable globale
      variable {}
      # vérifications
      if {[llength $args] % 2 != 0} \
      { error "use is '$w configure ?-option value?...'" }
      # modification de la valeur des options
      foreach {key value} $args \
      {
        switch -glob -- $key \
        {
          -wid*   \
          {
            # test de la valeur
            winfo pixel $w $value
            # mise à jour
            set ($w:-width) $value
          }
          -hei*   \
          {
            # test de la valeur
            winfo pixel $w $value
            # mise à jour
            set ($w:-height) $value
          }
          -color1 \
          {
            # test de la valeur
            winfo rgb $w $value
            # mise à jour
            set ($w:-color1) $value
          }
          -color2 \
          {
            # test de la valeur
            winfo rgb $w $value
            # mise à jour
            set ($w:-color2) $value
          }
          -ori*   \
          {
            switch -glob -- $value \
            {
              hor*    { set ($w:-orient) horizontal }
              ver*    { set ($w:-orient) vertical   }
              default \
              { error "-orient option value should be 'horizontal' or 'vertical'" }
            }
          }
          default \
          { error "unknown option '$key'" }
        }
      }
      # calcul des teintes
      compute $w
    }

    # ---------------------
    # calcul des teintes
    # ---------------------
    proc compute {w} \
    {
      # accès à la variable globale
      variable {}
      # calcul
      if {$($w:-orient) eq "horizontal"} { set size $($w:-width) } \
      else                               { set size $($w:-height) }
      foreach {r1 g1 b1} [winfo rgb . $($w:-color1)] break
      foreach {r2 g2 b2} [winfo rgb . $($w:-color2)] break
      foreach c {r1 g1 b1 r2 g2 b2} { set v [set $c]; set $c [expr {$v & 255}] }
      set gradient [list]
      set fs [expr {double($size)}]
      for {set i 0} {$i < $size} {incr i} \
      {
        set c1 [expr {double($size - $i) / $fs}]
        set c2 [expr {1.0 - $c1}]
        foreach c {r g b} \
        {
          set v1 [set ${c}1]
          set v2 [set ${c}2]
          set v [expr {round($v1 * $c1 + $v2 * $c2)}]
          if {$v < 0} { set v 0 }
          if {$v > 255} { set v 255 }
          set $c $v
        }
        lappend gradient [format #%2.2x%2.2x%2.2x $r $g $b]
      }
      # mise à jour de l'image
      set img [$w.img cget -image]
      $img config -width $($w:-width) -height $($w:-height)
      set data [list]
      if {$($w:-orient) eq "horizontal"} \
      {
        for {set y 0} {$y < $($w:-height)} {incr y} \
        { lappend data $gradient }
      } \
      else \
      {
        for {set y 0} {$y < $($w:-height)} {incr y} \
        {
          set color [lindex $gradient $y]
          set row [split [string trim [string repeat "$color " $($w:-width)]]]
          lappend data $row
        }
      }
      $img put $data
    }
  }

  # exposition de la commande gradient
  namespace import ::gradient::gradient

Explications

• Le premier if teste si le fichier gradient.tcl a déjà été sourcé.
• Le namespace exporte la commande gradient et celle-ci est importée dans le code de l'utilisateur en fin de fichier.
• Le package est versionné.
• La variable globale sert à mémoriser les options des widgets créés par le package.
• La variable globale peut avoir n'importe quel nom (pour les allergiques au nom vide).
• Elle contient des noms de type -option pour les valeurs par défaut.
• Elle contient des noms de type $w:-option pour la valeur des options de chaque widget de nom $w.
• Le widget est enveloppé dans un frame pour pouvoir lui donner une classe de binding.
• Cette classe de binding peut servir pour les bindings généraux (l'exemple ne l'utilise pas).
• ---procédure de création---
• La première procédure a pour nom le nom du package et permet de créer les widgets du package.
• Tous ses paramètres sont optionnels pour maîtriser les messages d'erreur.
• La partie de son code qui peut générer des erreurs non maitrisées est dans un catch.
• Le catch et le return -code $code $result de cette procédure permettent de cacher la mécanique interne.
• Les options d'un widget sont initialisées à partir de la variable globale et sont sauvées dans cette même variable globale.
• Le paramètre w de la première procédure correspond à la fois au nom du widget et au nom du frame qui enveloppe le widget.
• C'est pourquoi la procédure $w est renommée :
• Le nouveau nom, caché dans le namespace, peut servir à contrôler le frame.
• Le nom $w sert à contrôler le widget et appelle la procédure cachée operation.
• Attention à définir la nouvelle procédure $w par la commande proc :
• La définir au moyen de la commande interp alias crée des problèmes si la procédure est à nouveau renommée (le widget servant de base à un nouveau megawidget).
• Une fois le widget créé, on appelle la procédure standard de traitement des options avec les options de création.
• La procédure de création retourne le nom du widget.
• ---procédure de choix d'une opération---
• Tous ses paramètres sont optionnels pour maîtriser les messages d'erreur.
• La partie de son code qui peut générer des erreurs non maitrisées est dans un catch.
• Le catch et le return -code $code $result de cette procédure permettent de cacher la mécanique interne.
• ---opération cget---
• Elle vérifie ses arguments.
• Elle retourne la valeur de l'option qui a été sauvée dans la variable globale.
• ---opération configure---
• Elle vérifie ses arguments.
• Elle modifie la valeur des options qui sont sauvées dans la variable globale.
• Chaque valeur est vérifiée.
• Dans l'exemple, toute modification d'une option déclenche la mise à jour du widget.
• ---calcul des teintes---
• Toutes les informations sont retrouvées dans la variable globale ou dans un des sous-widgets.

Le fichier pkgIndex.tcl

  package ifneeded gradient 1.0.0 [list source [file join $dir gradient.tcl]]

Explications

Il permet à Tcl de sourcer le fichier gradient.tcl lors d'une commande package require.

Le fichier gradient-doc.txt

  Documentation du package gradient

  Description :
  ----
  Le package gradient implémente le widget gradient.
  Le widget gradient affiche un dégradé de couleurs.
  Il est destiné à colorer un fond de fenêtre ou de cadre.

  Usage :
  ----
    frame .f
    package require gradient
    gradient .f.g -width 200 -height 200 -color1 gold -color2 red
    place .f.g -in .f

  Installation :
  ----
    1- Créer un répertoire gradient dans le répertoire lib de Tcl.
    2- Y copier les fichiers :
      - gradient.tcl
      - pkgIndex.tcl
      - gradient-doc.txt
      - gradient-test.tcl
      - gradient-demo.tcl
    3- Exécuter les fichiers :
      - gradient-test.tcl
      - gradient-demo.tcl

  Opérations :
  ----
    . cget : récupération de la valeur d'une option
    . configure : modification de la valeur des options

  Options :
  ----
    . -width : largeur
    . -height : hauteur
    . -color1 : première couleur
    . -color2 : deuxième couleur
    . -orient : orientation du dégradé

  Version :
  ----
  1.0.0 du 28 avril 2007

  Copyright :
  ----
  (C) 2007, ulis

  Licence :
  ----
  NOL (No Obligation Licence)

  Remerciements :
  ----
  A tous les técleux et surtout au premier d'entre eux John Ousterhout

Explications

Toutes les rubriques sont indispensables (sauf la dernière) :

• titre comportant le nom du package
• Description
• Usage
• Installation
• Opérations
• Options
• Version
• Copyright
• Licence

Quant aux remerciements, c'est pour moi la plus importante.

Je recommande chaudement de faire mieux que mon exemple.

Le fichier gradient-test.tcl

  # ###################################
  # test du package gradient v 1.0.0
  # (C) 2007, ulis
  # Licence NOL
  # ###################################

  # -----------------
  # package
  # -----------------
  #lappend auto_path [pwd]
  #lappend auto_path [file join [pwd] ..]
  #lappend auto_path [file join [pwd] ../lib]
  #package require gradient 1.0.0
  source gradient.tcl

  # -----------------
  # procédure de test
  # -----------------

  namespace eval ::test \
  {
    namespace export test
    variable {}
    array set {} \
    {
      count 0
      errors 0
      verbose 1
    }

    proc test {cmd args}  \
    {
      variable {}
      switch -glob -- $cmd \
      {
        get     \
        {
          switch -glob -- $args \
          {
            cou*  { set (count) }
            err*  { set (errors) }
            ver*  { set (verbose) }
          }
        }
        init    \
        {
          set (count) 0
          set (errors) 0
          set (verbose) 1
          if {$(verbose)} { puts "\ntest v 1.0 - $args\n" }
        }
        set     \
        {
          foreach {key value} $args \
          {
            switch -glob -- $args \
            {
              cou*  { set (count) $value }
              err*  { set (errors) $value }
              ver*  { set (verbose) $value }
            }
          }
        }
        default \
        {
          set id $cmd
          foreach {what script result} $args break
          incr (count)
          set rc [catch { set res [uplevel 1 $script] } msg]
          set res [list $rc $msg]
          if {$res == $result} \
          { if {$(verbose)} { puts "$id $what" } } \
          else \
          {
            incr (errors)
            puts "==== $id FAILED ($what)"
            puts "==== script\n$script"
            puts "---- Result was:\n$res"
            puts "---- Result should have been:\n$result"
          }
        }
      }
    }
  }
  namespace import ::test::test

  # -----------------
  # commande gradient
  # -----------------

  test gradient-1.1 \
    {gradient proc, empty} \
    {
      gradient
    } \
    {1 {use is 'gradient path ?-option value?...'}}

  test gradient-1.2 \
    {gradient proc, boggy} \
    {
      gradient buggy
    } \
    {1 {use is 'gradient path ?-option value?...'}}

  test gradient-1.3 \
    {gradient proc, ok} \
    {
      catch { destroy .d }
      gradient .d
    } \
    {0 .d}

  test gradient-1.4 \
    {gradient proc, good option} \
    {
      catch { destroy .d }
      gradient .d -width 100
    } \
    {0 .d}

  test gradient-1.5 \
    {gradient proc, bad option} \
    {
      catch { destroy .d }
      gradient .d -buggy 100
    } \
    {1 {unknown option '-buggy'}}

  test gradient-1.6 \
    {gradient proc, bad syntax} \
    {
      catch { destroy .d }
      gradient .d -width
    } \
    {1 {use is 'gradient .d ?-option value?...'}}

  # -----------------
  # opération cget
  # -----------------

  catch { destroy .d }
  gradient .d -width 100 -height 100 -color1 red -color2 gold -orient vertical

  test gradient-2.1 \
    {cget operation, no option} \
    {
      .d cget
    } \
    {1 {use is '.d cget -option'}}

  test gradient-2.2 \
    {cget operation, bad option} \
    {
      .d cget -buggy
    } \
    {1 {unknown option '-buggy'}}

  # -----------------
  # opération configure
  # -----------------

  catch { destroy .d }
  gradient .d -width 100 -height 100 -color1 red -color2 gold -orient vertical

  test gradient-3.1 \
    {configure operation, bad option} \
    {
      .d configure -buggy 0
    } \
    {1 {unknown option '-buggy'}}

  test gradient-3.2 \
    {configure operation, bad syntax} \
    {
      .d configure -width
    } \
    {1 {use is '.d configure ?-option value?...'}}

  # -----------------
  # opération inconnue
  # -----------------

  test gradient-4.1 \
    {buggy operation} \
    {
      .d buggy
    } \
    {1 {unknown gradient operation 'buggy'}}
  # -----------------
  # options
  # -----------------

  set tests \
  {
    {-width 12 12 bad {bad screen distance "bad"}}
    {-height 12 12 bad {bad screen distance "bad"}}
    {-color1 red red bad {unknown color name "bad"}}
    {-color2 gold gold bad {unknown color name "bad"}}
    {-orient vert vertical bad {-orient option value should be 'horizontal' or 'vertical'}}
  }

  set i 1
  foreach test $tests \
  {
    set rvalue ""
    set rresult ""
    foreach {option value result rvalue rresult} $test break
    if {$value != "" || $result != ""} \
    {
      test gradient-5.$i "option $option $value" \
        {
          .d config $option $value
          .d cget $option
        } \
        [list 0 $result]
      incr i
    }
    if {$rvalue != "" || $rresult != ""} \
    {
      test gradient-5.$i "option $option $rvalue" \
        {
          .d config $option $rvalue
        } \
        [list 1 $rresult]
      incr i
    }
  }

  # -----------------
  # résultats
  # -----------------

  foreach var {count errors} { set $var [test get $var] }
  set passed [expr {$count - $errors}]
  set ppassed [expr {100.0 * $passed / $count}]
  set pp [format %3.1f $ppassed]
  set pfailed [expr {100.0 * $errors / $count}]
  set pf [format %3.1f $pfailed]
  puts "\nresult: count $count, passed $passed ($pp%), failed $errors ($pf%)"

Explications

Ce fichier est très important :

• Il sert à vérifier le fonctionnement du package après chaque modification.
• Il permet à l'utilisateur de vérifier que le package fonctionne correctement dans son environnement.

La procédure de test est implémentée sous forme d'un mini package que je vous encourage à utiliser.

Son interface comprend trois variables et quatre opérations :

• variable count : le nombre total de tests
• variable errors : le nombre de tests en erreur
• variable verbose : drapeau de verbosité
• opération init : réinitialise les variables à zéro
• opération get : retourne la valeur d'une variable
• opération set : positionne la valeur d'une variable
• opération vide : fait un test

Les paramètres d'un test sont :

1. le titre du test
2. le script du test
3. le résultat du test sous la forme d'une liste : code du catch et résultat du catch.

Le fichier gradient-demo.tcl

  # démo du package gradient
  # (C) 2007, ulis
  # Licence NOL
  set auto_path [linsert $auto_path 0 .]
  package require gradient

  gradient .g -width 256 -height 256 -color1 gold -color2 red
  place .g -in .
  proc change {} \
  {
    if {[.g cget -orient] eq "horizontal"} \
    { .g config -orient vertical } \
    else \
    { .g config -orient horizontal }
    after 1000 change
  }
  change

  label .l -text "Que c'est beau !" -width 16 -bg gold
  button .ok -text Ok -command exit -width 16 -bg red -activeb gold

  place .l -in . -anchor center -relx 0.5 -rely 0.33
  place .ok -in . -anchor center -relx 0.5 -rely 0.66

Explications

Il peut y avoir plusieurs démonstrations, dont une sera basique et pourra servir de modèle à l'utilisateur.

Sinon, lâchez-vous et donnez envie d'utiliser votre package.

Exercice

Implémentez et interfacez les orientations diagonales.

Voir Aussi

• Tk facile
• Tk par l'exemple
• Les autres pages de Tk avancé
• -
• Pour construire son widget, mais en C : Construire un widget

Catégorie Cours | Catégorie Encyclopédie Tk

Mis à jour le 6 janvier 2008 à 13:02 CET par ulis  -  Editer Tk avancé - Construire son widget
Rechercher - Dernières modifications - 6 Références - Le Wiki tcl francophone - Aide