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 :


Le contenu 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 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) :

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 :

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 :

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


[Catégorie Cours | Catégorie Encyclopédie Tk | Catégorie Tutoriel ]