package provide xtcl 0.1


## string_fillTo -- complete une chaine jusqu'à une taille donnée
# 
# parametres
# 
# N :       taille finale de la chaine
# str :     chaine à compléter
# fillCar : caractère de remplissage
# 
# sortie : retourne une chaine complété
# 
proc string_fillTo {N str {fillCar -}} {
    
    while {[string length $str] < $N} {
        append str $fillCar
    }
    
    return $str
}




## string_range -- return sub-string based on pair list of indices
# 
# Do the same as "string range" tcl command, but take a list of 
# two indices instead of two indices as parameters
# (then extended to take an arbitrary pair list)
# 
# example:
#     set txt "aaa123bbb679ccc"
#     set pat {(\d+)\D*(\d+)}
#     regexp  -indices $pat $txt  all  var1_indexes var2_indexes
#     set var1 [string_range $txt $var1_indexes]
#     set var2 [string_range $txt $var2_indexes]
#     set varChunk [string_range $txt "$var1_indexes $var2_indexes" ]
# 
proc string_range {str indices} {
    set res ""
    foreach {first last} $indices {
        append res  [string range $str $first $last]
    }
    set res
}


## string_untabify --
# 
#   removes tabs from a string, replacing with appropriate number of
#   spaces. 
# Arguments:
#   text         input string
#   tabSize      tab length, defaults to 8
# Returns:
#   string sans tabs
# 
# Nota: string must be a single line!!
# 
# proc string_untabify_ORI_Hobbs {str {tablen 8}} {
#    set out {}
#    while {[set i [string first "\t" $str]] != -1} {
#        set j [expr {$tablen-($i%$tablen)}]
#        append out [string range $str 0 [incr i -1]][format %*s $j { }]
#        set str [string range $str [incr i 2] end]
#    }
#    return $out$str
# }
# 
# 
# de Agnar Renolen :
# 
proc string_untabify { text {tabSize 8} } {
    set output ""
    set charNo 0
    foreach char [split $text {}] {
        if {$char == "\t"} {
            set numSpaces [expr $tabSize - ($charNo % $tabSize)]
            append output [string repeat " " $numSpaces]
            incr charNo $numSpaces
        } else {
            append output $char
            if {$char == "\n"} {
                set charNo 0
            } else {
                incr charNo
            }
        }
    }
    return $output
}

## string_tabify --
#   converts excess spaces to tab chars. Arguments:
#   str         input string
#   tablen      tab length, defaults to 8
# Returns:
#   string with tabs replacing excess space where appropriate
#
# (from Jeffrey Hobbs)
# 
proc string_tabify {str {tablen 8}} {
   ## We must first untabify so that \t is not interpreted to be 1 char
   set str [string_untabify $str]
   set out {}
   while {[set i [string first { } $str]] != -1} {
       ## Align i to the upper tablen boundary
       set i [expr {$i+$tablen-($i%$tablen)-1}]
       set s [string range $str 0 $i]
       if {[string match {* } $s]} {
           append out [string trimright $s { }]\t
       } else {
           append out $s
       }
       set str [string range $str [incr i] end]
   }
   return $out$str
}
 

## string_validate -- validates particular types of numbers/formats
# 
#
# Arguments:
# type          - The type of validation (alphabetic, alphanumeric, date,
#               hex, integer, numeric, real).  Date is always strict.
# val           - The value to be validated
#
# Returns:      0 or 1 (whether or not it resembles the type)
#
# Switches:
# -incomplete   enable less precise (strict) pattern matching on number
#               useful for when the number might be half-entered
#
# Example use:  validate real 55e-5
#               validate -incomplete integer -505
# 
# Autor: Jeffrey Hobbs
# 
proc string_validate {args} {
    if {[string match [lindex $args 0]* "-incomplete"]} {
        set strict 0
        set opt *
        set args [lreplace $args 0 0]
    } else {
        set strict 1
        set opt +
    }

    if {[llength $args] != 2} {
        return -code error "wrong \# args: should be\
                \"[lindex [info level 0] 0] ?-incomplete? type value\""
    } else {
        set type [lindex $args 0]
        set val  [lindex $args 1]
    }

    ## This is a big switch for speed reasons
    switch -glob -- $type {
        alphab* { # alphabetic
            return [regexp -nocase "^\[a-z\]$opt\$" $val]
        }
        alphan* { # alphanumeric
            return [regexp -nocase "^\[a-z0-9\]$opt\$" $val]
        }
        b*      { # boolean - would be nice if it were more than 0/1
            return [regexp "^\[01\]$opt\$" $val]
        }
        d*      { # date - always strict
            return [expr {![catch {clock scan $val}]}]
        }
        h*      { # hexadecimal
            return [regexp -nocase "^(0x)?\[0-9a-f\]$opt\$" $val]
        }
        i*      { # integer
            return [regexp "^\[-+\]?\[0-9\]$opt\$" $val]
        }
        n*      { # numeric
            return [regexp "^\[0-9\]$opt\$" $val]
        }
        rea*    { # real
            return [regexp -nocase [expr {$strict
            ?{^[-+]?([0-9]+\.?[0-9]*|[0-9]*\.?[0-9]+)(e[-+]?[0-9]+)?$}
            :{^[-+]?[0-9]*\.?[0-9]*([0-9]\.?e[-+]?[0-9]*)?$}}] $val]
        }
        reg*    { # regexp
            return [expr {![catch {regexp $val {}}]}]
        }
        val*    { # value, any valid number type
            return [expr {![catch {expr {0+$val}}]}]
        }
        l*      { # list
            return [expr {![catch {llength $val}]}]
        }
        w*      { # widget
            return [winfo exists $val]
        }
        default {
            return -code error "bad [lindex [info level 0] 0] type \"$type\":\
                    \nmust be [join [lsort {alphabetic alphanumeric date \
                    hexadecimal integer numeric real value \
                    list boolean}] {, }]"
        }
    }
    return
}


## string_replace -- recherche/remplacement dans une chaine
# 
# Syntaxe :
#   string_replace ?options? ?--? <pat1> <pat2> <text>
#   
# (L'argument <text> est le dernier pour pouvoir servir de filtre tcl 
# dans stead)
# 
# Options :
#   -mode <mode> ( exact, regexp, regexpLine ; défaut : exact)
#               
#   -nocase <bool> (défaut 0)
#   
#   -subst (flag) : si présent : effectue une subtitution tcl sur le résultat
#           (dans le contexte ***global***)
#           DANGER : pour l'instant : on fait un subst sur TOUT le fichier !!!
#           
#   -count <varName> si précisée, cette variable contiendra le nombre de
#           remplacement effectués
# 
# A FAIRE :
# 
#   -from <indice>  (defaut : 0)
#   -to <indice>    (défaut : end)
#   -word (flag) la patterne exacte correspond à un ou des mots complets.
#       (La difficulté est de faire fonctionner ceci en mode "exact" !)
# 
# Rajout d'un argument optionnel pour la variable à affecter.
# Dans ce cas, la commande retourne le nombre de remplacement effectués
# au lieu de la chaine modifiée :
# 
#   string_replace ?options?  -var <textOutVarName> ?--?  <pat1> <pat2> <text> 
#       
# Exemples :
# 
#   string_replace -exact {b(c)d} {\1\1} XXXabcdeXXX
#           => XXXabcdeXXX
#   
#   string_replace -line {b(c)d} {\1\1} XXXabcdeXXX
#           => XXXacceXXX
#   
#   string_replace -regexp {X$} {Y}  XXX\nabcde
#           => XXX\nabcde    (sur deux lignes => inchangé)
# 
#   string_replace -line {X$}  {Y} XXX\nabcde
#           => XXY\nabcde    (sur deux lignes => modif d'un X en Y)
#           
#   set i 6
#   string_replace -regexp -subst {([0-9]+)} {[incr i]}  "_43__0_9898_"
#       => _7__8_9_
#   
#   string_replace -regexp -subst {_([A-Z])}  {[string tolower \1]} \
#                                               "ABD_FJSK_HR_EF"
#       => ABD_fJSK_hR_eF
#   
# 
# IDEE :
#  
#  # Création d'un unique de la seule procédure à substituer
#  set ran "[random 1000000000][random 1000000000][random 1000000000]"
#  set prefix "OPEN_BRACKET_$ran_"
#  set suffix "CLOSE_BRACKET_$ran_"
#  
#  # Le remplacement avec préparation pour la substitution
#  regsub -all -- $pat1 $text $prefix$pat2$suffix newText1
#  
#  
#  # La liste des mapping pour la protection 
#  set map  [list               \
#              \[    \\\[       \
#              \$    \\\$       \
#              \\    \\\\       \
#  ]                
#  
#  # On protège tous les caracteres spéciaux
#  set newText2  [string map $map $newText1]
#  
#  # On déprotège exclusivement la chaine remplacée
#  set newText3  [string map $map $newText1]
#  
#  
#  set fileText [string map [list \[ \\\[ \\ \\\\] $fileText]
#  set fileText [string map [list \\\[newFormat \[newFormat] $fileText]
#  subst $fileText
# 
proc string_replace { args } {
    
    set opt(-debug)         0
    set opt(-mode)          exact
    set opt(-nocase)        0
    set opt(-subst)         0
    set opt(-count)         ""
    set opt(-word)          0   ;# PAS ENCORE IMPLEMENTE !
    set allowsModes         "exact|regexp|lineregexp"
    
    set i  0
    set argc [llength $args]
    #  on n'examine les options que s'il y en a :
    if {"x[string index $args 0]" == "x-"} {
        while {$i < $argc} {
            set arg [lindex $args $i]
            switch -glob -- $arg {
               --  {
                    incr i
                    break
               }
               -e -
               -exact   { 
                    set opt(-mode) exact
               }
               -r -
               -regexp   - 
               -regexpGlobal   { 
                    set opt(-mode) regexpGlobal
               }
               -l -
               -line   -
               -regexpLine   { 
                    set opt(-mode) regexpLine
               }
               -mode {
                    set opt(-mode) [lindex $args [incr i] ]
               }
               -count {
                    set opt(-count) [lindex $args [incr i] ]
               }
               -nc  -
               -nocase   { 
                    set opt(-nocase) 1
               }
               -d -
               -debug { 
                    set opt(-debug) 1
               }
               -word   { 
                    set opt(-word) 1
                    error "\nL'option -word n'est pas encore supportée !\n"
               }
               -s -
               -subst   { 
                    set opt(-subst) 1
               }
               -*       {error "unknow option $arg"}
               default  {break  ;# no more options}
            }
            incr i
        }
    }
    if {![regexp -- {^exact|regexpLine|regexpGlobal$} $opt(-mode)]} {
        error "Option \"-mode $opt(-mode)\" invalide,\
                    options autorisées : $allowsModes"
    }
    
    # i pointe sur le prochain argument non lu :
    set args [lrange $args $i end]
    
    if {[llength $args] != 3} {
        error "syntax: string_replace ?options? ?--? <pat1> <pat2> <text>"
    }
    
    set pat1 [lindex $args 0]
    set pat2 [lindex $args 1]
    set text [lindex $args 2]
    
    if {$opt(-debug)} {
        report "\nApres analmyse des arguments"
        report -v opt pat1 pat2 text          
    }
    
    if {$opt(-mode) == "exact"} {
        
        # Dans le cas d'un mode de recherche exact, on va insérer en tête de 
        # la patterne pseudo-régulière la méta-option (?q)
        
        set pat1 "(?q)$pat1"
        
        # Mais il faut aussi protéger les "\0" à "\9" dans la chaine de 
        # remplacement !
        # En effet (tcl8.3.3) meme en mode exact, les back-référence semblent 
        # prise en considération !
        # Ceci pourrait changer dans les versions suivantes de tcl ?
        # 
        regsub -all {(\B[0-9])} $pat2 {\\\1} pat2
        
        if {$opt(-debug)} {
            report "\nProtection de pat2 des back-références en mode exact"
            report -v  pat2 
        }

    } else {
        # Dans la cas d'une recherche régulière, on veut insérer
        # des caracteres de "méta-option" en tête de l'expression réguliere.
        # La difficulté est de ne pas écraser de telles options si 
        # l'utilisateur en a spécifié dans la patterne qu'il fournit !
        # 
        # Par exemple, la patterne régulière d'entrée :
        #       "(?x)popo"  avec l'option "-line"
        # sera remplacée par la patterne de sortie
        #       "(?nx)popo" 
        # 
        # metaOptions contiendra des options "en ligne" dans l'expression
        # régulière elle-même (voir man tcl "re_syntax").
        # 
        set metaOptions ""
        regexp -expanded {
            ^               # début de la patterne
            (?:\(\?         # début (éventuel) d'options en ligne
                (\w+)       # les éventuels caractères d'options en ligne
            \))?            # fin (éventuel) d'option en ligne
            (.*)            # la partie principale de l'expression
            $               # fin de la patterne
        } $pat1  fullPa1_unused  metaOptions mainPat1

        if {$opt(-debug)} {
            report -v pat1 fullPa1_unused metaOptions mainPat1            
        }
        switch -exact -- $opt(-mode) {
            exact {
                set metaOptions "q$metaOptions"
            }
            regexpLine {
                set metaOptions "n$metaOptions"
            }
            default -
            regexpGlobal {
                # rien à faire
            }
        }
        if {[string length $metaOptions]} {
            set pat1 (?$metaOptions)$mainPat1
        } else {
            set pat1 $mainPat1
        }
        
    }

    if {$opt(-debug)} {
        report "\npat1 modifiée = $pat1"        
    }
    
    # 
    # La patterne est désormais complétée par les méta-option.
    # On va quand même vérifier qu'elle compile sans erreur !
    # 

    if {[catch {regexp -- $pat1 "foo"} result]} {
        set msg "\nBad regular expression\n\n"
        append msg "$pat1 :\n\n$result\n"
        error $msg
    }
    
    # 
    # Il reste à construire la commande tcl "regsub"
    # 
    
    set cmd [list regsub -all]
    if {$opt(-nocase)} {
        lappend cmd "-nocase"
    }
    
    # Si -subst, on encadre la chaine de remplacement par des chaines prefix et
    # suffixe qu'on à peu de risque de trouver naturellement dans le texte
    if {$opt(-subst)} {
        set ran "[random 1000000000][random 1000000000][random 1000000000]"
        set prefix "____BEGIN_$ran\0_"
        set suffix                      "_END_$ran\0____"
        set pat2 $prefix$pat2$suffix
    }
    
    lappend cmd -- $pat1 $text $pat2 textOut
    # Au boulot !
    set count [eval $cmd]

    if {$opt(-debug)} {
        report "\nAu boulot !"
        report -v cmd
        report -v count textOut        
    }
    
    if {$opt(-subst)} {

        # On va remplace le texte :
        #   "aaaBEGIN__[incr i]__ENDbbb-cccBEGIN__[incr i]__ENDddd" 
        # par le texte :
        #   "aaa__5__bbb-ccc__6__ddd"
        #  
        # On doit reextraire les chaines de remplacement (qui sont marquées par
        # les chaines prefix et suffix), puis effectuer une substitution
        # avant de les réinserer dans le texte de sortie.
        # 
        set indicesPairs [regexp -all -inline -indices \
                                    "${prefix}(.*?)${suffix}"   $textOut]
        
        # On commence par construire la liste des sous-chaines de remplacement
        # Attention : **il faut** que les "subst" soient évalués **dans 
        # l'ordre** croissant des indices.

        set replaceStrings [list]
        foreach {wholePair subPair} $indicesPairs {
            set subString [string range $textOut   \
                            [lindex $subPair 0]    \
                            [lindex $subPair 1]] 
            
            # On pourra insérer ici des manipulations plus complexes sur 
            # la chaine  de remplacement !
            set repString [uplevel #0 [list subst $subString]]
            if {$opt(-debug)} {
                report -v subString repString
            }
            lappend replaceStrings $repString
        }
        
        # On contruit le text finale en insérant les chaine de remplacement 
        # au bon endroit
        set currentIndice 0
        set textOut2 ""
        foreach {wholePair subPair} $indicesPairs \
                   { repString  }   $replaceStrings  {
            
            set gap [string range $textOut \
                    $currentIndice \
                    [expr [lindex $wholePair 0] -1]]
            append textOut2 $gap
            append textOut2 $repString
            set currentIndice [expr [lindex $wholePair 1] +1]
            if {$opt(-debug)} {
                report -v gap repString currentIndice
            }
        }
        # On ajoute la partie finale de texte
        # # append $textOut2 [string range $textOut $currentIndice end]
        set textOut $textOut2[string range $textOut $currentIndice end]
        
        # set textOut [uplevel #0 [list subst $textOut] ]
        if {$opt(-debug)} {
            report "\nApres subst !"
            report -v textOut            
        }
    }
    
    # si l'utilisateur souhaite mémoriser le nombre de remplacement effectués :
    if {[string length $opt(-count)]} {
        uplevel [list set $opt(-count) $count ]
    }
    
    return $textOut
}

## string_transcode -- retourne une chaine avec un encodage modifié
# 
# Syntaxe :
#   string_transcode ?options? ?--? ?<mode>? <text>
#   
# retourne
#   Une chaine convertie
# 
# argument :
#   mode : le mode de modification à faire (couple "from-to" prédéfini)
#   text : la chaine à traiter
#   
# Options :
#   -mode : permet de passer le mode sous-forme d'option (syntaxe alternaive)
#   -from (-f) l'encodage de la chaine d'entrée (system par défaut)
#   -to (-t) l'encodage de la chaine de sortie  (system par défaut)
# 
# Cette procédure est une surcouche à la commande encoding de tcl avec 
# des possibilités d'évolution supplémentaires.
# L'argument <text> est le dernier pour pouvoir servir de filtre tcl 
# dans stead
# 
# Rajout d'un argument optionnel pour la variable à affecter.
# Dans ce cas, la commande retourne le nombre de remplacement effectués
# au lieu de la chaine modifiée :
# 
#   string_transcode ?options?  -var <textOutVarName> ?--?  <text> 
# 
# 
# Exemples :
# 
#   A compléter (à implémenter)
#   string_transcode -from utf-8 -to iso8859-1 -- $text
#   string_transcode -mode utf2iso -- $text
#   string_transcode  utf2iso  $text
#   
# A FAIRE :
# 
#   - prévoir encodage par défaut
#   - prévoir des "macro-encodage" pour des cas fréquents
#   - ajouter les fonctionnalités des autre procédure d'accent (dont html, ...)
#     (on POURRA faire appel à string_replace)
# 
# 
proc string_transcode { args } {
    # error "PAS TERMINER (ni commencé !)"
    
    set opt(-debug)         0
    set opt(-from)          [encoding system]
    set opt(-to)            [encoding system]
    set opt(-mode)          tcl
    set allowsModes         "tcl|utf2iso|iso2utf|mac2iso|iso2mac"
    
    set i  0
    set argc [llength $args]
    #  on n'examine les options que s'il y en a :
    if {"x[string index $args 0]" == "x-"} {
        while {$i < $argc} {
            set arg [lindex $args $i]
            switch -glob -- $arg {
               --  {
                    incr i
                    break
               }
               -f       -
               -from    { 
                    set opt(-from) [lindex $args [incr i] ]
               }
               -t       -
               -to      { 
                    set opt(-to) [lindex $args [incr i] ]
               }
               -mode {
                    set opt(-mode) [lindex $args [incr i] ]
               }
               -d -
               -debug { 
                    set opt(-debug) 1
               }
               -h -
               -help -
               --help { 
                    puts "retourne une chaine avec un encodage modifié"
                    puts "Exemple :"
                    puts " string_transcode -from utf-8 -to iso8859-1 -- \$text"
                    puts " string_transcode -mode utf2iso -- \$text"
                    puts " string_transcode  utf2iso  \$text"
                    puts "Mode définis :"
                    puts " $allowsModes"
               } 
               -*       {error "unknow option $arg"}
               default  {break  ;# no more options}
            }
            incr i
        }
    }
    
    # i pointe sur le prochain argument non lu :
    set args [lrange $args $i end]
    
    
    switch -exact -- [llength $args] {
        1 {
             set text [lindex $args 0]
        }
        2 {
             set opt(-mode)  [lindex $args 0]
             set text       [lindex $args 1]
        }
        default {
          set msg     "syntax: string_transcode ?options? ?--? ?<mode>? <text>"
          error $msg
        }
    }
    
    # Traitement de quelques abréviation de mode et remplacement par leur
    # valeur standard
    # 
    switch -exact -- $opt(-mode) {
        utf {
            set opt(-mode) "utf2iso"
        }
        iso {
            set opt(-mode) "iso2utf"
        }
        mac {
            set opt(-mode) "mac2iso"
        }
        default {
            
        }
    }
    
    
    if {![regexp -- "^$allowsModes\$" $opt(-mode)]} {
        error "Option \"-mode $opt(-mode)\" invalide,\
                    options autorisées : $allowsModes"
    }
    
        
    if {$opt(-debug)} {
        report "\nApres analyse des arguments"
        report -v opt  text          
    }
    
    switch -exact -- $opt(-mode) {
        utf2iso {
            set opt(-from) "utf-8"
            set opt(-to) "iso8859-1"
        }
        iso2utf {
            set opt(-from) "iso8859-1"
            set opt(-to) "utf-8"
        }
        nac2iso {
            set opt(-from) "macRoman"
            set opt(-to) "iso8859-1"
        }
        iso2mac {
            set opt(-from) "iso8859-1"
            set opt(-to) "macRoman"
        }
        tcl {
            # rien à faire
        }
        default {
            set msg "Unkown transcoding mode : $opt(-mode)"
            error $msg
        }
    }
    if {$opt(-debug)} {
        report "\nApres exploitation des arguments"
        report -v opt           
    }
    set cmd [list set text1 [encoding convertfrom $opt(-from) $text]]
    # # # puts $cmd
    eval $cmd
    # # # report -v text1
    set cmd [list set text2 [encoding convertto $opt(-to) $text1]]
    # # # puts $cmd
    eval $cmd
    # # # report -v text2
    return $text2
}
# ./

