# 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 ""
# 
#     # modes possibles : silent | warning | exit
#     set opt(-mode) silent; 
#     # source possibles : nom de fichier
#     set opt(-source) ""; 
#     
#     # 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_catch -- evalue une commande avec uplevel et catch
# 
#           xtcl_catch ?-key1 value1 ...? ?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)
# options :
#  TODO  -level level : le contexte d'évaluation au format de uplevel
#               par défaut : 1 (exécution dans le contexte d'appel)
#               on peut mettre #0 pour le contexte glogal
#               
# 
#    -mode exit : si erreur, affiche un message et sort du programme
#    -mode error : si erreur, appel à la commande tcl "error"
#                  (peut quitter ou non suivant tcl ou tk)
#    -mode warning : si erreur, affiche un message sans arreter le programme
#    -mode silent : (=valeur par défaut) : ignore toute erreur
#    
#    PAS FAIT /
#       -source "fileName" : source le parametre (fichier au lieu de l'évaluer)
# 
# 
# 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 pwd   
#       => affiche le répertoire courent dans la ligne d'info stead
#   xtcl_catch #0 [list set stead(Meta) "userProc $w]   
#       => modifie une variable dans le contexte global
#   xtcl_catch "ls -al"   
#       => affiche le listing dans un nouveau stead
#       
#   xtcl_catch "poppopo"   
#       => ne fait rien (l'erreur est ignorée)
#   xtcl_catch -mode warning "poppopo"   
#       => affiche un message d'erreur, mais continue l"exécution
#   xtcl_catch -mode error "poppopo"   
#       => affiche la fenetre d'erreur standard de tk (si diponible)
#          ou bien affiche l'error tcl est sort
#   xtcl_catch -mode exit "poppopo"   
#       => affiche un message d'erreur, et termine le programme
# 
# Variable d'environnement utilisée
# 
#    ::env(XTCL_CATCH_MODE) permet d'initialiser la valeur par défaut du mode
#    Cette variable permet de rendre visible une erreur qui serait masquée
#    par défaut, et facilite donc le debogage d'un programme.
#    Exemple :
#       Dans le shell
#           export XTCL_CATCH_MODE=warning
#       puis :
#           xtcl_catch "poppopo" 
#           => affiche le message d'erreur "commande poppopo inconnu"
#  
# 
proc xtcl_catch { args } {
    set msg ""

    # 1 - intialisation des options
    # modes possibles : silent | warning | error | exit
    if {[info exists ::env(XTCL_CATCH_MODE)]} {
        set opt(-mode) $::env(XTCL_CATCH_MODE); 
    } else {
        set opt(-mode) silent; 
    }
    
    # source possible : nom de fichier, ou ""
    set opt(-source) ""; 
    
    # niveau de contexte souhaité à utiliser dans la pile d'exécution 
    # Par défaut 0 = contexte courant (de l'appelant !!) 
    # ATTENTION : ce niveau devra etre corrigé car cette procédure ajout un
    # niveau
    set opt(-level) 0
    
    # 2 - analyse de la ligne de commande
    while {[llength $args]} {
        switch -exact -- [lindex $args 0] {
          -- {
                set args [lreplace $args 0 0]
                break
          }
          -source {
                set opt(-source) [lindex $args 1]
                set args [lreplace $args 0 1]
                continue
          }
          -level {
                set opt(-level) [lindex $args 1]
                set args [lreplace $args 0 1]
                continue
          }
          -mode {
                set opt(-mode) [lindex $args 1]
                set args [lreplace $args 0 1]
                continue
          }
          default { break  ;# no more options}
        }
    }
    # Ce test doit aussi s'appliquer à la valeur par défaut qui peut être
    # initialisée par une variable d'environnement !
    if {![regexp {^silent|warning|error|exit$} $opt(-mode)]} {
        error "xtcl_catch:  incorrect mode $opt(-mode)"
    }
    # puts "info level = [info level]"
    # 3 - Détection du niveau de la pile d'excution demandé
    # 
    # sera incrémenté, donc le niveau par défaut est 1
    # 2.1 On verifie que le level est dans une forme correct (relatif ou absolu)
    if {[regexp -- {^(#)?(\d+)$} $opt(-level) all diese intVal]} {
    
        # Le contexte est syntaxiquement correct, 
        # 
        # Si ce niveau est relatif, on doit l'incrémenter car cette présente 
        # procédure ajoute artificiellement un niveau supplémentaire. 
        if { ! [string length $diese ]} {
             # opt(-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 intVal
             # puts "=== intVal=$intVal absVal=[xtcl_getAbsLevel $intVal]"
             set opt(-level) [xtcl_getAbsLevel $intVal]
        }
        
    } else {
        set errMsg "xtcl_catch:  incorrect stack level format: $opt(-level)\n"
        append errMsg "Should be like #0, #1, #2, .. or 0, 1, 2, .."
        error regexp
    }
    # puts "===  => opt(-level)=$opt(-level)"
    
    # # set opt(-level) 0
    # # if {[regexp -- {^(#)?\d+$} [lindex $args 0] opt(-level) diese]} {
    # #     if { ! [string length $diese ]} {
    # #          # opt(-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 opt(-level)
    # #     }
    # #     set args [lreplace $args 0 0 ]
    # # }

    # 4 - lecture des arguments obligatoires
    if {[llength $args]} {
        # set msg [lindex $args 1]
        set msg [lrange $args 1 end]
    }
    set cmd [lindex $args 0]
    
    # parray opt
    # puts "info level=[info level]"
    
    # 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 trace contient peu d'info en cas d'erreur !
    # 
    if {[catch {uplevel $opt(-level) $cmd}  result] } {
        if {[info level] == 1} {
            set parentContext "le context global"
        } else {
            set parentContext "la procédure [lindex [info level -1] 0]"
        }
        
        set fullMsg    "\n"
        append fullMsg "\nErreur dans l'exécution de la commande \n"
        append fullMsg "    uplevel $opt(-level) $cmd $msg\n"
        append fullMsg "\nexécutée par $parentContext"
        append fullMsg "\n"
        append fullMsg "\nVoici la trace de l'erreur :"
        append fullMsg "\n"
        append fullMsg "\n$result"
        append fullMsg "\n"

        
        switch -exact -- $opt(-mode) {
            exit {
                puts stderr "$fullMsg"
                exit
            }
            error {
                error "$fullMsg"
            }
            warning {
                puts stderr "$fullMsg"
            }
            - silent
            default {
                # on ignore l'erreur
            }
        }
    } else {
        return $result
    }
}
## xtcl_getAbsLevel -- transforme un level relatif (i.e. 1) en level absolu (e.g. #4)
#    
# 
# 
proc xtcl_getAbsLevel { relLevel } {
    # level absolu du context appelant
    set parentLevel [expr {[info level] -1}]
    set absLevel [expr $parentLevel-$relLevel]
    if {$absLevel < 0} {
        error "absLevel=$absLevel (should be non negative)"
    }
    return "#$absLevel"
}

## xtcl_source -- source le fichier en parametre, s'il existe, au niveau global
# 
#   Si le fichier existe, alors équivalent à :
#      xtcl_catch -level #0 [list source $fileName]
#   sinon 
#       ne fait rien
# 
# # 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"
# #     }
# # }
proc xtcl_source { fileName } {
    if {[file isfile $fileName] && [file readable $fileName]} {
        xtcl_catch -level #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
    }
} 
# ./
# 


