Cloner des espaces de noms

 

Sarnold -- 29/12/2005

Voici un petit ensemble de procédures pour cloner des namespaces :

au lieu de faire

 namespace eval monPaquet {
     variable a
     ...
     proc init {args} {...}
     proc cleanup {} {...}
     ...
 }
 monPaquet::init arg1 arg2 .. argN
 monPaquet::xxx [...]
 monPaquet::cleanup

vous pourrez écrire, sans modifier fondamentalement le namespace:

 basique::classe monPaquet {
     variable xxx
     ...
     # constructeur
     proc __init__ {args} {...}
     # destructeur
     proc __destroy__ {} {...}
     # différentes procédures
     proc bonjour {qui} {puts "Bonjour $qui !"}
     [...]
 }
 % set a [monPaquet ...]
 ::monPaquet__inst0
 % $a bonjour Stéphane
 Bonjour Stéphane !
 % basique::efface $a

C'est donc à moitié entre une programmation orientée-objet, et des namespaces (pardon, espaces de noms) purs et durs.

A vous de voir si ça vous intéresse.


Le source

    namespace eval ::basique {
        namespace export classe efface local
        variable classes
        array set classes {}
        # le constructeur de classe : une classe est ici un simple namespace
        # il n'y a ni héritage, ni délégation
        # le constructeur est __init__ et le destructeur __destroy__
        proc classe {nom code} {
            if {[string range $nom 0 1] ne "::"} {
                set nom ::$nom
            }
            variable classes
            if {[info exists classes($nom)]} {
                foreach inst [array names classes ${nom}__inst*] {
                    efface $inst
                }
                rename $nom ""
            }
            # quelques accesseurs
            append code {
                proc _set {var args} {
                    variable [::basique::var $var]
                    switch [llength $args] {
                        0 {return [set $var]}
                        1 {return [set $var [lindex $args 0]]}
                        default {error "usage : _set varname ?value?"}
                    }
                    return
                }
                proc _incr {var {increment 1}} {
                    variable [::basique::var $var]
                    incr $var $increment
                }
                proc _append {var chaine} {
                    variable [::basique::var $var]
                    append $var $chaine
                }
                proc _lset {var indice valeur} {
                    variable [::basique::var $var]
                    lset $var $indice $valeur
                }
                proc _lappend {var args} {
                    variable [::basique::var $var]
                    eval [linsert $args 0 lappend $var]
                }
            }
            set classes($nom) $code
            CreerClasse $nom
        }

        # retourne le nom d'une variable indépendamment du fait qu'elle puisse être
        # l'élément d'un tableau associatif de type 'array'
        proc var {nom} {
            if {[set indice [string first ( $nom]]<0} {
                return $nom
            }
            return [string range $nom 0 [incr indice -1]]
        }

        # efface un objet de la mémoire
        proc efface {args} {
            variable classes
            foreach objet $args {
                ${objet}::__destroy__
                unset classes($objet)
                namespace delete $objet
                catch {rename $objet ""}
            }
            return
        }

        # crée la commande qui instanciera les objets
        proc CreerClasse {nom} {
            variable classes
            # le constructeur réel (le constructeur public est __init__)
            proc $nom {args} [string map [list %NOM% $nom] {
                set instance [::basique::Construit %NOM%]
                # invocation du constructeur (initialiseur)
                if {![llength [info procs ${instance}::__init__]]} {
                    error "pas de constructeur : __init__"
                }
                uplevel [linsert $args 0 ${instance}::__init__]
                if {[::basique::NousAvonsNamespaceEnsemble]} {
                    namespace eval $instance {namespace ensemble create}
                } else  {
                    proc $instance {commande args} [string map [list %OBJ% $instance] {
                        uplevel [linsert $args 0 %OBJ%::$commande]
                    }]
                }
                return $instance
            }]
        }
        proc Construit {nom} {
            variable classes
            if {![info exists classes($nom)]} {
                error "pas de classe $nom"
            }
            if {![info exists classes($nom,compteur)]} {
                set classes($nom,compteur) 0
            }
            while {[info exists classes(${nom}__inst$classes($nom,compteur))]} {
                incr classes($nom,compteur)
            }
            Instancier $nom
        }

        proc NousAvonsNamespaceEnsemble {} {
            return [package vsatisfies [package require Tcl] 8.5]
        }
        # Instancie un objet (namespace cloné) et retourne son nom
        proc Instancier {nom} {
            variable classes
            set instance ${nom}__inst$classes($nom,compteur)
            # réinstancie un espace de noms en adaptant le corps au nom de l'instance
            namespace eval $instance [string map \
                    [list [string trim $nom :]:: [string trim $instance :]::] $classes($nom)]
            # export de toutes les procédures du namespace
            set exportees [string map [list ${instance}:: ""] [info procs ${instance}::*]]
            namespace eval $instance "namespace export $exportees"
            set classes($instance) 1
            return $instance
        }
    }

Un exemple:

    package require Tk
    basique::classe Engrenage {
        variable canevas
        variable rayonMin
        variable rayonMax
        variable taille
        variable fond #fff
        variable couleur black
        variable engrenages
        proc __init__ {cheminCanevas vtaille} {
            variable taille
            variable canevas
            variable rayonMin
            variable rayonMax
            set taille $vtaille
            set canevas [canvas $cheminCanevas -width $taille -height $taille -background white]
            set rayonMin [expr {$taille/2.4}]
            set rayonMax [expr {($taille-10)/2.}]
            pack $canevas
            trace add variable Engrenage::couleur write {Engrenage::setCouleur}
            trace add variable Engrenage::fond write {Engrenage::setFond}
            trace add variable Engrenage::engrenages write {Engrenage::mettreAJour}
        }

        proc __destroy__ {} {
            variable canevas
            destroy $canevas
        }

        proc setFond {args} {
            variable canevas
            variable fond
            $canevas configure -background $fond
        }

        proc setCouleur {args} {
            variable couleur
            variable canevas
            catch {$canevas itemconfigure canevas -fill $couleur}
        }

        proc Coins {rayon} {
            variable taille
            incr taille 0
            set rayon [expr {int($rayon-1)}]
            set bordure [expr {$taille/2-$rayon}]
            set dimension [expr {2*$rayon+$bordure}]
            return [list $bordure $bordure $dimension $dimension]
        }
        proc mettreAJour {args} {
            variable engrenages
            variable canevas
            variable couleur
            $canevas delete canevas
            $canevas create polygon [Trace] -tag canevas -fill $couleur
        }
        proc proximite {pt1 pt2} {
            # retourne la proximité de deux points :
            # 0 si bonne, -1 si trop éloignés, 1 si trop proches
            foreach {x1 y1} $pt1 {x2 y2} $pt2 {break}
            set dx [expr {$x2-$x1}]
            set dy [expr {$y2-$y1}]
            if {$dx<1 && $dy<1} {
                # trop proches
                return 1
            }
            if {$dx>2 || $dy>2} {
                # trop éloignés
                return -1
            }
            return 0
        }
        proc Trace {} {
            variable taille
            variable canevas
            set coords [pointdAngle 0]
            set delta [expr {180./$taille}]
            set angle $delta
            do {
                while {[rayon $angle]==0} {
                    set angle [expr {$angle+$delta}]
                }
                set prochainPoint [pointdAngle $angle]
                set angle [expr {$angle+$delta}]
                foreach {x y} [applique int $prochainPoint] {break}
                lappend coords $x $y
            } until {$angle >= 360.0}
            return $coords
        }

        proc int {x} {
            expr {int($x)}
        }

        proc applique {fonction liste} {
            set r ""
            foreach elt $liste {
                lappend r [$fonction $elt]
            }
            set r
        }
        proc rayon {angle} {
            variable engrenages
            variable rayonMax
            variable rayonMin
            # l'angle varie entre 0 et 100 u.n. à chaque engrenage (unité normalisée)
            # donc 100*$engrenages u.n.=360 degrés
            # donc angle u.n. = angle (degrés) *100*$engrenages/360
            #
            set angle [expr {fmod(($angle/3.6)*$engrenages, 100)}]
            if {$angle < 20 || $angle > 80} {
                return $rayonMax
            }
            if {$angle > 30 && $angle < 70} {
                return $rayonMin
            }
            return 0
        }
        proc pointdAngle {angle} {
            set resultat [Pol2Rect [rayon $angle] $angle]
            #puts $angle,$resultat
            return $resultat
        }
        # transformation de coordonnées polaires en rectangulaires
        proc Pol2Rect {rayon angle} {
            foreach {x1 y1 x2 y2} [Coins $rayon] {break}
            set xMilieu [expr {$x1+($x2-$x1)/2}]
            set yMilieu [expr {$y1+($y2-$y1)/2}]
            set angle [expr {$angle*atan(1)/45}]
            set x [expr {round($xMilieu+$rayon*sin($angle))}]
            set y [expr {round($yMilieu-$rayon*cos($angle))}]
            return [list $x $y]
        }

    }
    # do .. until in Tcl
    proc do {body until condition} {
        uplevel $body
        while {![uplevel expr $condition]} {uplevel $body}
    }
    set monEngrenage [Engrenage .engr1 600]
    $monEngrenage _set engrenages 8
    pack .engr1
    update
    after 500
    $monEngrenage _incr engrenages 2
    update
    after 500
    $monEngrenage _set couleur #22a
    update
    after 500
    $monEngrenage _set fond #ddd
    update
    label .libelle -text "Tcl version [package require Tcl]"
    pack .libelle
    button .quitter -text Quitter -command Quitter
    pack .quitter
    proc Quitter {} {
        global monEngrenage
        basique::efface $monEngrenage
        update
        after 1000 exit
    }

Catégorie Orienté-Objet