
package provide xtcl 0.1


# $Id: divers.tcl,v 1.2 2000/09/28 07:39:36 diam Exp $
# 10/09/99 (diam) : intégration à pist/xtcl



########################################################################
## comment : mais tout ce qui suit en commantaire
# 
# exemple :
# 
#    comment { 
#       Du baratin
#    } 
# 
proc comment args {}

########################################################################
## pset -- parallel set a variable value tu a varial list
# 
# example :
#    pset {x1 y1 x2 y2} $bbox
# 
# Mais dans les cas cas simple utiliser plutot lassign
# et réserver pset pour les manipulation de longue liste
# Elargire cette procédure pour la manipulation
# de tableau bijectif
# 
# (from Graphlet)
# 
proc pset { a b } {
    uplevel 1 "foreach \{ $a \} \{ $b \} {}"
}

########################################################################
## now -- return the current time
# 
# examples :
# 
#    puts "modify at [now]"
#    => modify at Sun Nov 28 10:41:42 CET 1999
# 
#    puts "Nous le [now %d/%m/%Y]  à [ now %Hh%Mmn%Ss] "
#    => Nous le 28/11/1999  à 10h47mn57s
#  
#    set fileName stead-[now %y%m%d-%H%M%S]-[pid].tmp
#    => stead-991128-105022-1461.tmp
# 
#    set backupDir @BACKUP-[now %Y%m%d-%H%M%S]
#    => @BACKUP-20011010-131519
# 
# à faire : demander à scriptics de rajouter "clock now ?format <format>?
# 
proc now { {format "" } } {
    if {[string length $format]} {
        return [clock format [clock second] -format $format  ]
    } {
        return [clock format [clock second] ]
    }
}
## clock_normalize -- make the string as standardized formated date
# 
# arguments:
# 
#   - dateStr : proposed string for a date or time
#   - args : to pass to the formated result
# 
# results:
# 
#   - a well formated string corresponding to the proposed dateStr
#   - error if dateStr canot be recognise as a date/time
# 
# examples
# 
#   clock_normalize "08 sept 00"
#   => Fri Sep 08 00:00:00 CEST 2000
# 
#   clock_normalize "08 sept 00" -format %d/%m/%y
#   => 08/09/00
# 
#   clock_normalize "08 sept" -format %d/%m/%y
#   => 08/09/00
# 
#   clock_normalize "september 8 00" -format %d/%m/%y-%Hh%Mmn%Ss
#   => 08/09/00-00h00mn00s
# 
#   clock_normalize "2 days ago"  -format "jour %j et semaine %W de l'an %Y"
#   => jour 250 et semaine 36 de l'an 2000
# 
#   clock_normalize "September 7, 2000 + 90 days" -format %d/%m/%y
#   => 06/12/00
# 
#   clock_normalize "8 septembre"  -format %d/%m/%y
#   => unable to convert date-time string "8 septembre"  (as ERROR)
# 
proc clock_normalize {dateStr args} {
    eval [list clock format [clock scan $dateStr]  ] $args    
}


## info_username -- Return the name of the user
# 
# 
# 
proc info_username {} {
    global env
    if {[info exists env(USER)]} { return $env(USER) }
    if {[catch {set w [exec whoami]}]} {
	set w [lindex [exec who am i] 0]
    }
    return $w
}

## info_ipAdr -- return the IP adress
# 
# example :
#    info_ipAdr
#    => 147.260.33.135
# 
proc info_ipAdr {} {
     set me [socket -server xxx -myaddr [info hostname] 0]
     set ip [lindex [fconfigure $me -sockname] 0]
     close $me
     return $ip
}





## pist_do -- loop controle (allow use of break, continue, ...)
# 
#  (from http://mini.net/cgi-bin/wikit)
# 
# 
# Recall that the error codes are 
# 
#      0 OK 
#      1 error (should be thrown upwards) 
#      2 return (throw that upwards, too) 
#      3 break {stop execution of our loop) 
#      4 continue {just continue) 
#      anything else is a user defined code. 
# 
# To make this really really really robust, you should consider
# adding the same error handling to the uplevel condition, but that
# is left as an exercise for the reader. 
# 
proc pist_do {body whileword condition} {
    global errorInfor errorCode
    if {![string equal $whileword while]} {
        error "should be \"do body while condition\""
    }
    while {1} {
        set code [catch {uplevel 1 $body} message]
        switch -- $code {
          1 { return  -code      error \
                      -errorinfo $errorInfo \
                      -errorcode $errorCode $message }
          2 { return -code return $message }
          3 { return {} }
          4 { }
          default { return -code $code $message }
        }
        if {![uplevel 1 [list expr $condition]]} {break}
    }
}

## setArrayDefault -- Sets the default value of array elements to 0 whenever
##                    they are read for the first time
# 
# Autor: fredericbonnet@free.fr (10/07/00)
# 
# array set a {1 foo 2 bar}
# trace variable a r setArrayDefault
# 
# Example:
#   % set a(1)
#   foo
#   
#   % set a(2)
#   bar
#   
#   % set a(3)
#   array default for a(3) => 0
#   0
# 
proc setArrayDefault {name1 name2 op} {
    upvar $name1 a
    if {$name2 != {} && ![info exists a($name2)]} {
        # output debug info
        puts "array default for ${name1}($name2) => 0"
        set a($name2) 0
    }
}

## array_foreach -- explore un tableau efficacement
# 
# Exemple (volker.hetzer@ieee.org 10/07/00) :
# 
#     This is a bit of test code:
#     set MyArray(0) A
#     set MyArray(1) B
#     set ScopeCheckVariable "This is to be printed: "
#     
#     array_foreach MyArray MyLoopVar {
#         puts "--$ScopeCheckVariable$MyLoopVar--"
#         puts "--See, this script can contain several lines too: $MyLoopVar--"
#     }
# 
proc array_foreach {Arrayname ValueVar Code} {
    upvar $Arrayname Array
    set Search [array startsearch Array]
    while {[array anymore Array $Search]} {
        uplevel [list set $ValueVar [array nextelement Array $Search]]
        uplevel $Code
        }
    array donesearch Array $Search
}

# ./
