# package provide xtcl 0.1
# 
package provide xtcl 0.1

# 
# Quelques procedures utilitaire en tcl pur
# 

## xtcl_every -- Lance un script périodiquement (renommer xtcl_every ??)
# 
# Lance un script périodiquement toute les <second> secondes
# Le parametre <second> peut etre réel
# 
# syntaxe :
#   every <second> <cmd>
# 
# Exemple :
#   every 1.5 update_file
# 
proc xtcl_every {second cmd } {
    eval $cmd
    after [expr {int($second*1000)}] [list xtcl_every $second $cmd]
}


## xtcl_uid -- return Unique IDentier (renommer xtcl_uid ??)
# 
# 
proc xtcl_uid {} {
   global stead
   return [incr stead(uid)]
}
## xtcl_nop -- No OPerator : ne fait rien et retourne ""
## nop      -- No OPerator : ne fait rien et retourne ""
# 
# Utile pour ajouter à un script ou à une commande dont on ne veut pas
# qu'elle retourne le resultat (e.g. une liste d'un million de mots !)
# 
proc      nop {} {}
proc xtcl_nop {} {}

## xtcl_catch -- evalue une commande avec uplevel et catch
# 
#           xtcl_catch ?level? cmd ?msg?
# 
# @return le résultat de l'exécution de la commande
#         ou le message d'erreur en cas de probleme
# @param level : le contexte au format de uplevel
# @param cmd : la commande à exécuter
# @param msg : le texte éventuel à inserer devant le message d'erreur
#              en plus de la trace standard (inutilisé si pas d'erreur)
# 
# Par défaut, la commande est évaluée dans le répertoire parent
# si le premier argument a la forme 2 ou #0, alors la commande
# est evalué dans ce contexte
# 
# BUG (feature :-) : si on veut exécuter un commande de nom "23"
#     il **faut** fournir l'argument level pour éviter toute ambiguÏté.
# 
# Exemple :
#   xtcl_catch #0 [list set stead(Meta) "userProc $w]   
#       => affiche le répertoire courent dans la ligne d'info stead
#   xtcl_catch "ls -al"   
#       => affiche le listing dans un nouveau stead
#   xtcl_catch "poppopo"   
#       => affiche la fenetre d'erreur standard de tk
# 
# TODO :
# options suivantes :
#    -warning : si erreur, affiche un message sans arreter le programme
#    -silent : ignore toute erreur
#    -source : source le parametre (fichier au lieu de l'évaluer)
# 
proc xtcl_catch { args } {
    set msg ""
    
    # sera incrémenté, donc le niveau par défaut est 1
    set level 0
    if {[regexp -- {^(#)?\d+$} [lindex $args 0] level diese]} {
        if { ! [string length $diese ]} {
             # level est relatif, (e.g uplevel 1). Donc il faut tenir
             # compte du niveau supplémentaire introduit par la proc
             # xtcl_catch elle-même !
             incr level
        }
        set args [lreplace $args 0 0 ]
    }
    if {[llength $args]} {
        # set msg [lindex $args 1]
        set msg [lrange $args 1 end]
    }
    set cmd [lindex $args 0]
    
    # Tant qu'on implémente pas les options : pas d'intéret de détailler
    # d'avantage.
    uplevel $level $cmd
    # 
    # A METTRE AU POINT car la trave contient peu d'info en cas d'erreur !
    # 
    # if {[catch {uplevel $level $cmd}  result] } {
    #     set msg    "\n"
    #     append msg "\nErreur dans l'exécution de la commande \n"
    #     append msg "    uplevel $level $cmd\n"
    #     append msg "\nexécutée par la procédure [lindex [info level -1] 0]"
    #     append msg "\n"
    #     append msg "\nVoici la trace de l'erreur :"
    #     append msg "\n"
    #     append msg "\n$result"
    #     append msg "\n"
    #     
    #     error "$msg"
    # } else {
    #     return $result
    # }
}

## xtcl_source -- source le fichier en parametre, s'il existe, au niveau global
# 
# 
proc xtcl_source { fileName } {
    if {[file isfile $fileName] && [file readable $fileName]} {
        xtcl_catch #0 [list source $fileName] \
               "Erreur au cours de la lecture du fichier $fileName"
    }
    
}
## xtcl_needAtLeastTclVersion -- garantie une version minimale de tcl
# 
# interrompt le programme avec message si la version courante de TCL est
# plus ancienne que celle demandée
# 
# exemple :
# 
#    xtcl_needAtLeastTclVersion 8.0
# 
proc xtcl_needAtLeastTclVersion {versionNumber} {
    if {[info tclversion] < $versionNumber} {
        set    msg "\n\n"
        append msg "Ce script nécessite l'utilisation\
                         de TCL version $versionNumber ou ultérieure."
        append msg "\n"
        append msg "  Script :                   [info script] "
        append msg "\n"
        append msg "  Version de TCL utilisée :  [info tcl] "
        append msg "(patch : [info patch])"
        append msg "\n"
        append msg "  Librairie de TCL :         [info lib]\n"
        append msg ""
        puts stderr "$msg"
        exit
    }
} 
# ./
# 