package provide xtcl 0.1

## file_mode -- returns something like drwxr--r-- 
# 
# from wikit (RS)
# 
proc file_mode {fileName } {
        file stat $fileName t
        if [file isdirectory $fileName] {
                set prefix "d"
        } else {
                set prefix "-"
        }
        set s [format %o [expr $t(mode)%512]]
        foreach i {  0   1   2   3   4   5   6   7} \
                j {--- --x -w- -wx r-- r-x rw- rwx} {
                        regsub -all $i $s $j s
        }
        return $prefix$s
}

## file_lines --  returns the lines of that file as a list.
# 
# modif :
#   14/08/02 (diam) appelle à file_read (car supporte les memes options) 
# 
proc file_lines {args} {
    split [eval file_read $args] \n
}


## file_normalName -- return normalized name of the parameter
# 
# Cette version DOIT fonctionner avec wish3.6 (à nettoyer
# quand stead36 sera supprimé)
# 
# Cette procédure est une version simplifiée de file:realName.
# car elle fait l'impasse sur le bug d'autodémontage qui est  
# supposé corrigé dans les versions actuelles du syteme sunOS.
# 
# name: file or directory (doesn't have to exist), absolute or relative, 
#       could contain link.
# 
proc file_normalName {name} {
    
    # # puts "file_normalName: name=$name"
    
    # If the name is relative: one make it absolute
    if {[file pathtype $name] == "relative"} {
       set name [file join [pwd] $name]
    }

    # # puts "file_normalName: name=$name"

    # Mac alias already retourn full name, and windows doeas not have link
    # 
    global tcl_platform
    switch -exact -- $tcl_platform(platform) {
        macintosh  -
        windows   {
            return $name
        } 
    } 
    
    if {[file exists $name]} {
        # One follows a possible link (which can be absolute or relative)
        while {[string match "link" [file type $name] ]} {
           set followName [file readlink $name]
           # If the name is relative: one make it absolute
           if {[file pathtype $followName] == "relative"} {
              # 
              # !!! remettre le "join"  dés que [tk8] est toujours vrai !!!
              # set followName \
              #      [file join [ [file dirname $name] $followName]
              set followName "[file dirname $name]/$followName"
           }
           set name $followName
        }
    }  ;# endif
    
    
    # $name could be relative or absolute
    set pwd_ori [pwd]
    cd [file dirname $name]
    set theDir [pwd]
    
    set name [file join $theDir [file tail $name]]
    
    cd $pwd_ori
    
    # # puts "file_normalName: name=$name"
    return $name

} ;# endproc file_normalName

## file_read - lit un fichier et retourne une chaine de caractères 
# 
# retourne le contenu du fichier "filename"
# options possibles :
#   -- : fin des options
#   -nonewline
#   -<translation> avec translation = cr | lf | crlf | auto | binary
#    (voir man tcl : fconfigure, option -translation)
#   -encoding <encoding>  (voir [encoding names])
# exemples : set txt [file_read ?-nonewline? toto.vhd]
#            set txt [file_read toto.vhd ?<nbr_chars>?]
#            
# modif 
#   - (14/08/02 (diam) : ajout option -encoding
#   
proc file_read {args} {

    set ENCODING "auto"
    set TRANSLATION "auto"
    set NONEWLINE {}
    
    # i point on the first unread argument
    set i 0
    if [string match -* $args] {
      set argc [llength $args]
      while {$i < $argc} {
        # lecture du premier argument à examiner
        set arg [lindex $args $i]
        switch -glob -- $arg {
           --       {incr i ; break}
           -nonewline  {
               set NONEWLINE "-nonewline"; incr i ; continue
           }
           -cr      -
           -lf      -
           -crlf    -
           -auto    -
           -binary  { 
              set TRANSLATION [string range $arg 1 end]
              incr i; continue
           }
           -encoding  { 
              set ENCODING [lindex $args [incr i] ]
              incr i; continue
           }
           -*         { error "unknow option $arg"}
           default    { break  ;# no more options}
        }
      }
    }

    set fileName [lindex $args $i]; incr i
    set Nbytes   [lindex $args $i]
    
    set fp [open $fileName]
    if {"x$ENCODING" == "xauto"} {
        fconfigure $fp -translation $TRANSLATION
    } else {
        fconfigure $fp -translation $TRANSLATION -encoding $ENCODING
    }
    
    set stat [catch {
        eval read $NONEWLINE $fp $Nbytes
    } result]
    close $fp
    if {$stat != 0} {
        global errorInfo errorCode
        error $result $errorInfo $errorCode
    }
    return $result
} 
## file_write - créé un fichier avec une chaine de caractere
# 
# file_write <fileName> <string> ?<string> ...?
# 
# crée (ou écrase) le fichier "filename" avec les chaines passer en parametre
# 
# options possibles :
#   -- : fin des options
#   -append : ajoute en fin de fichier s'il existe déja
#   -nonewline 
#   -<translation> avec translation = cr | lf | crlf | auto | binary
#    (voir man tcl : fconfigure, option -translation)
# Nota : se rappeler que args peut contenir plusieurs M octets pour
#        l'extraction des options.
# 
proc file_write {args} {

    set TRANSLATION  auto
    set ENCODING    "auto"
    set APPEND       0
    set NONEWLINE    {}
    # i point on the first unread argument
    set i 0
    if [string match -* $args] {
        while "\$i < [llength $args]" {
            # lecture du premier argument à examiner
            set arg [lindex $args $i]
            switch -glob -- $arg {
                  --       {incr i ; break}
                  -nonewline  {
                      set NONEWLINE "-nonewline"; incr i ; continue
                  }
                  -append  {
                      set APPEND 1; incr i ; continue
                  }
                  -cr      -
                  -lf      -
                  -crlf    -
                  -auto    -
                  -binary  { 
                     set TRANSLATION [string range $arg 1 end]
                     incr i; continue
                  }
                  -encoding  { 
                     set ENCODING [lindex $args [incr i] ]
                     incr i; continue
                  }
                  -*         { error "unknow option $arg"}
                  default    { break  ;# no more options}
            }  
        } 
    } 
    # i point on the next unread argument
    set fileName [lindex   $args   $i]
    set args     [lreplace $args 0 $i]
    
    # Create parent directories if needed
    file mkdir [file dir $fileName]
    
    if {$APPEND} {
        set fp [open $fileName a+]
    } else {
        set fp [open $fileName w]
    }
    
    if {"x$ENCODING" == "xauto"} {
        fconfigure $fp -translation $TRANSLATION
    } else {
        fconfigure $fp -translation $TRANSLATION -encoding $ENCODING
    }
    
    set stat [catch {
        foreach string $args {
            eval puts $NONEWLINE $fp [list $string]
        }
    } result]
    close $fp
    if {$stat != 0} {
        global errorInfo errorCode
        error $result $errorInfo $errorCode
    }
}

## file_applyTclCmd -- applique une commande TCL à un fichier avec backup.
# 
# retourne :
#   1 si fichier modifié (i.e. si l'application de la commande tcl 
#     change le fichier)
#   0 sinon 
# 
# arguments :
#
#   tclCmd : la commande tcl à appliquer (c'est une **liste**)
#   filename : nom du fichier à traiter
# 
# options :
#   
#   -dry : ne pas exécuter : juste pour tester 
#   -backname :  nom éventuel du fichier de sauvegarde (pas de sauvegarde
#     si vide) La sauvegarde n'est effectuée que si le fichier est réellement
#     modifié
# 
# retourne :
#   1 si fichier modifié (ou si non modifié à cause de l'option -dry), 
#   0 sinon.
# 
# La commande TCL est une liste formée d'une commande et éventuellemnt
# d'un ou plusiuers argument prépositionné. Elle recevra en plus une 
# chaine en parametre et doit retourner la chaine modifiée.
# 
proc file_applyTclCmd {args} {

    # intialisation des options
    set opt(-dry)     0
    set opt(-backname) ""
    
    # analyse de la ligne de commande
    while {[llength $args]} {
        switch -exact -- [lindex $args 0] {
          -- {
                set args [lreplace $args 0 0]
                break
          }
          -dry {
                set opt(-dry) 1
                set args [lreplace $args 0 0]
                continue
          }
          -backname {
                set opt(-backname) [lindex $args 1]
                set args [lreplace $args 0 1]
                continue
          }
          default {
                puts stdout "unknow option [lindex $args 0]"
                exit 1
          }
          default { break  ;# no more options}
        }
    }
    
    # lecture des arguments obligatoires
    set tclCmd   [lindex $args 0]
    set fileName [lindex $args 1]
    
    
    # au boulot
    set oldTxt [file_read -binary $fileName]
    set newTxt [uplevel $tclCmd [list $oldTxt] ]

    if {![string equal $oldTxt $newTxt]} {
        # La modif est effective, mais on distiqngue le cas -dry !
        
        if {!$opt(-dry)} {
        
            if {[string length $opt(-backname)]} {
                 if [file exist $opt(-backname)] {
                    puts stderr "$opt(-backname) existe deja :"
                    puts stderr "    $fileName inchangé"
                    return 0
                 }
                 if [catch {file_write -binary \
                                  -nonewline $opt(-backname) $oldTxt} msg] {
                    puts stderr "erreur à l'ecriture de $opt(-backname) :" 
                    puts stderr "    $fileName inchangé :\n$::errorInfo"
                    return 0
                 }
            }
            file_write -nonewline -binary $fileName $newTxt
            
        } else {
        
            if {[string length $opt(-backname)]} {
                 if [file exist $opt(-backname)] {
                    puts stderr "$opt(-backname) existe deja :"
                    puts stderr "    $fileName (serait) inchangé"
                    return 0
                 }
            }
            # puts "POUR INFO file_write -nonewline -binary $fileName <newTxt>"
        }
        return 1
    } else {
        # La modif ne change pas le fichier !
        return 0
    }
}

# ## file_replaceAll - remplacement de chaine dans un fichier - EN DEVELOPPEMENT
# # 
# # pat1 pat2 : les chaines de remplacement
# # filename : fichier à traiter
# # ?filenameBak? : nom du fichier backup
# # 
# # Succeinte pour l'instant, main sera complétéee pour la rech/remplacement
# # multifichier de stead.
# # 
# # A faire : traiter des options :
# #   -backName filenameBak 
# #   -mode exact|glob|regexp|globalregexp|linerexp
# #   -subst : effectue une post substitution permettant des chose come
# #       ra -subst {xtext_([a-z])} {xtext_[capitalise \1]}
# #     
# proc file_replaceAll {pat1 pat2 filename {filenameBak {}}} {
#     set tclCmd [list string_replaceAll $pat1 $pat2]
#     return [file_applyTclCmd -backname $fileBak  $tclCmd $file]
# }

# ./
