# copyright (C) 1997-2006 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu

# $Id: utility.tcl,v 1.90 2006/03/22 22:37:22 jfontain Exp $


proc commaSeparatedString {words} {
    for {set index 0} {$index < ([llength $words] - 1)} {incr index} {
        append string "[lindex $words $index], "
    }
    append string [lindex $words $index]
    return $string
}

proc startGatheringPackageDirectories {} {   ;# note: the first package requirement triggers the search for packages by the Tcl core
    catch {rename source _source}
    proc source {file} {
        if {![string equal [file tail $file] pkgIndex.tcl]} {   ;# moodss modules must use pkgIndex.tcl files for package management
            return [uplevel 1 _source [list $file]]
        }
        foreach name [package names] {
            set versions($name) [package versions $name]                ;# note: can be an empty list (for Tcl package, for example)
        }
        uplevel 1 _source [list $file]                                                       ;# most of the time a pkgIndex.tcl file
        set directory [file dirname $file]
        foreach name [package names] {                                                        ;# see what new packages are available
            set available [package versions $name]
            if {[info exists versions($name)]} {
                if {[llength $available] > [llength $versions($name)]} {     ;# there exists another version of that package already
                    set ::package(exact,$name) {}                   ;# the exact version is thus required to load the chosen package
                    if {![info exists ::package(moodss,$name)]} {
                        set ::package(directory,$name) $directory
                        set ::package(version,$name) [lindex $available end]               ;# the new package version is always last
                    }                       ;# else there is a confirmed moodss module package by that name already so load that one
                }
            } else {                                                                              ;# first time this package is seen
                set ::package(directory,$name) $directory
                set ::package(version,$name) $available
                if {[string match *moodss* $directory]} {                                         ;# must be a moodss module package
                    set ::package(moodss,$name) {}
                }
            }
        }
    }
}

proc temporaryFileName {{extension {}} {identifier {}}} {
    if {[string length $identifier] == 0} {
        set identifier [pid]                                                              ;# use process identifier as unique string
    }
    switch $::tcl_platform(platform) {
        macintosh {
            error {not implemented yet}
        }
        unix {
            foreach directory {/var/tmp /usr/tmp /tmp} {                                             ;# assume /tmp is always usable
                if {[file isdirectory $directory] && [file writable $directory]} break
            }
        }
        windows {
            set directory c:/windows/temp
            catch {set directory $::env(TEMP)}
        }
    }
    set name [file join $directory moodss$identifier]
    if {[string length $extension] > 0} {
        append name .$extension
    }
    return $name
}

proc linesCount {string} {
    return [llength [split $string \n]]
}

proc compareClocks {value1 value2} {
    return [expr {[clock scan $value1 -base 0] - [clock scan $value2 -base 0]}]
}

proc emailAddressError {string} {                                          ;# requires tcllib mime package (tested with version 1.2)
    set string [string trim $string]
    if {[string length $string] == 0} {return {blank address}}
    foreach list [mime::parseaddress $string] {
        array set array $list
    }
    return $array(error)                                                                                   ;# empty if valid address
}

proc sendTextEmail {from to subject text} {
    set token [mime::initialize -canonical text/plain -string $text]
    lappend headers -servers [list $global::smtpServers]
    lappend headers -header [list From $from]
    foreach address $to {
        lappend headers -header [list To $address]
    }
    lappend headers -header [list Subject $subject]
    eval smtp::sendmessage $token $headers
}

if {$global::withGUI} { ;# >8

# returns true if the 2 rectangles intersect, false otherwise.
proc intersect {rectangle1 rectangle2} {     ;# a rectangle is a list: left top right bottom (compatible with canvas bounding boxes)
    foreach {left1 top1 right1 bottom1} $rectangle1 {left2 top2 right2 bottom2} $rectangle2 {}
    return [expr {!(($right1 < $left2) || ($left1 > $right2) || ($bottom1 < $top2) || ($top1 > $bottom2))}]
}

proc serialize {document} {            ;# common XML document serialization so that formatting is common to all moodss related files
    return [dom::serialize $document -indent 0 -indentspec {2 {{} {}}}]                           ;# do not replace spaces with tabs
}

proc nodeFromList {parentNode name values} {
    set node [dom::document createElement $parentNode $name]
    foreach value $values {
        dom::document createTextNode [dom::document createElement $node item] $value        ;# use item as generic list element name
    }
    return $node
}

} ;# >8

# From path pointing to node with values (see nodeFromList{}), return values list.
# If path is not specified, assume node is pointing to named list with item children.
proc listFromNode {parentNode {path {}}} {
    if {[string length $path] > 0} {
        append path /                                                                                       ;# separator is required
    }
    append path item                                                                    ;# item is used as generic list element name
    set values {}
    foreach node [dom::selectNode $parentNode $path] {
        lappend values [dom::node stringValue $node]
    }
    return $values
}

if {$global::withGUI} { ;# >8

proc busy {set {paths {}} {cursor watch}} {                         ;# make widgets busy with special mouse cursor for user feedback
    static lifo

    if {[llength $paths] == 0} {                                                                   ;# cover all toplevels by default
        set paths .
        foreach path [winfo children .] {
            if {[string equal [winfo class $path] Toplevel]} {
                lappend paths $path
            }
        }
    }
    if {$set} {
        foreach path $paths {
            if {![info exists lifo($path)]} {
                set lifo($path) [new lifo]
            }
            xifo::in $lifo($path) [$path cget -cursor]
            $path configure -cursor $cursor
        }
        update idletasks
    } else {
        foreach path $paths {
            if {[catch {set stack $lifo($path)}]} continue                                                               ;# user bug
            catch {$path configure -cursor [xifo::out $stack]}                                                 ;# widget may be gone
            if {[xifo::isEmpty $stack]} {
                delete $stack
                unset lifo($path)
            }
        }
    }
    if {[string equal $::tcl_platform(platform) windows]} update                       ;# so that busy cursor really becomes visible
}

proc centerMessage {path text {background {}} {foreground {}}} {                                  ;# use empty text to destroy label
    set label $path.centeredMessage
    if {[string length $text] == 0} {
        catch {destroy $label}                                                                                ;# label may not exist
        set label {}
    } else {
        if {![winfo exists $label]} {
            label $label
        }
        $label configure -text $text -background $background -foreground $foreground
        place $label -relx 0.5 -rely 0.5 -anchor center
    }
    return $label
}

proc 3DBorders {path background} {                                                               ;# algorithm stolen from tkUnix3d.c
    set intensity 65535                                                                                         ;# maximum intensity
    foreach {red green blue} [winfo rgb $path $background] {}
    if {(($red * 0.5 * $red) + ($green * 1.0 * $green) + ($blue * 0.28 * $blue)) < ($intensity * 0.05 * $intensity)} {
        set dark [format {#%04X%04X%04X}\
            [expr {($intensity + (3 * $red)) / 4}] [expr {($intensity + (3 * $green)) / 4}] [expr {($intensity + (3 * $blue)) / 4}]\
        ]
    } else {
        set dark [format {#%04X%04X%04X} [expr {(60 * $red) / 100}] [expr {(60 * $green) / 100}] [expr {(60 * $blue) / 100}]]
    }
    if {$green > ($intensity * 0.95)} {
        set light [format {#%04X%04X%04X} [expr {(90 * $red) / 100}] [expr {(90 * $green) / 100}] [expr {(90 * $blue) / 100}]]
    } else {
        set tmp1 [expr {(14 * $red) / 10}]
        if {$tmp1 > $intensity} {set tmp1 $intensity}
        set tmp2 [expr {($intensity + $red) / 2}]
        set lightRed [expr {($tmp1 > $tmp2)? $tmp1: $tmp2}]
        set tmp1 [expr {(14 * $green) / 10}]
        if {$tmp1 > $intensity} {set tmp1 $intensity}
        set tmp2 [expr {($intensity + $green) / 2}]
        set lightGreen [expr {($tmp1 > $tmp2)? $tmp1: $tmp2}]
        set tmp1 [expr {(14 * $blue) / 10}]
        if {$tmp1 > $intensity} {set tmp1 $intensity}
        set tmp2 [expr {($intensity + $blue) / 2}]
        set lightBlue [expr {($tmp1 > $tmp2)? $tmp1: $tmp2}]
        set light [format {#%04X%04X%04X} $lightRed $lightGreen $lightBlue]
    }
    return [list $dark $light]
}

proc setupTextBindings {path} {
    bind $path <Control-x> [bind Text <<Cut>>]
    bind $path <Control-c> [bind Text <<Copy>>]
    bind $path <Control-v> [bind Text <<Paste>>]
}

proc vectors {left top width height} {                   ;# from rectangle, return its vectors (coordinates and size) in a flat list
    return [list\
        $left $top $width 0 $left [expr {$top + $height}] $width 0 $left $top 0 $height [expr {$left + $width}] $top 0 $height\
    ]
}

proc setupGlobalMouseWheelBindings {} {                                                                             ;# from TIP #171
    set mw_classes [list Text Listbox Table TreeCtrl]
    foreach class $mw_classes { bind $class <MouseWheel> {} }
    if {[tk windowingsystem] eq "x11"} {
        foreach class $mw_classes {
            bind $class <4> {}
            bind $class <5> {}
        }
    }
    bind all <MouseWheel> [list ::tk::MouseWheel %W %D %X %Y]
    if {[tk windowingsystem] eq "x11"} {
        # Support for mousewheels on Linux/Unix commonly comes through
        # mapping the wheel to the extended buttons.
        bind all <4> [list ::tk::MouseWheel %W 120 %X %Y]
        bind all <5> [list ::tk::MouseWheel %W -120 %X %Y]
    }
}
proc ::tk::MouseWheel {wFired D X Y} {
    # do not double-fire in case the class already has a binding
    if {[bind [winfo class $wFired] <MouseWheel>] ne ""} { return }
    # obtain the window the mouse is over
    set w [winfo containing $X $Y]
    # if we are outside the app, try and scroll the focus widget
    if {![winfo exists $w]} { catch {set w [focus]} }
    if {[winfo exists $w]} {
        # scrollbars have different call conventions
        if {[winfo class $w] eq "Scrollbar"} {
            catch {tk::ScrollByUnits $w \
                [string index [$w cget -orient] 0] \
                [expr {-($D / 30)}]}
        } else {
            ### only for the following widgets for now as composite widgets using the canvas react strangely:
            switch [winfo class $w] {Text - Listbox - Table - TreeCtrl {} default return}
            catch {$w yview scroll [expr {-($D / 120) * 4}] units}
        }
    }
}

proc underlineAmpersand {text} {
    return [::tk::UnderlineAmpersand $text]
}

proc dragEcho {data format} {
    return $data
}

proc bounds {canvas} {                                              ;# returns the current canvas bounds (changes when page changes)
    foreach {left top right bottom} [$canvas cget -scrollregion] {}                                                  ;# current page
    # actual size may be larger than user specified size:
    return [list\
        $left $top\
        [expr {$left + [maximum [winfo width $canvas] [expr {$right - $left}]]}]\
        [expr {$top + [maximum [winfo height $canvas] [expr {$bottom - $top}]]}]\
    ]
}

proc fenceRectangle {canvas list} {                                                                   ;# list: left top right bottom
    foreach {xMinimum yMinimum} [pages::closestPageTopLeftCorner [lindex $list 0]] {}
    foreach {left top right bottom} [bounds $canvas] {}
    set xMaximum [expr {$xMinimum + ($right - $left)}]; set yMaximum [expr {$yMinimum + ($bottom - $top)}]
    foreach {left top right bottom} $list {}
    set x 0; set y 0
    if {$left < $xMinimum} {
        set x [expr {$xMinimum - $left}]
    } elseif {$right > $xMaximum} {
        set x [expr {$xMaximum - $right}]
    }
    if {$top < $yMinimum} {
        set y [expr {$yMinimum - $top}]
    } elseif {$bottom > $yMaximum} {
        set y [expr {$yMaximum - $bottom}]
    }
    return [list $x $y]                                                                                      ;# corrections to apply
}

proc fence {canvas itemOrTag} {                          ;# make sure object remains entirely visible within the visible canvas area
    if {([winfo width $canvas] <= 1) || ([winfo height $canvas] <= 1)} return             ;### invalid configuration event (Tk bug?)
    foreach {x y} [fenceRectangle $canvas [$canvas bbox $itemOrTag]] {}
    if {($x != 0) || ($y != 0)} {
        $canvas move $itemOrTag $x $y
    }
}

proc visibleForeground {background {path .}} {
    foreach {red green blue} [winfo rgb $path $background] {}
    if {($red + $green + $blue) >= (32768 * 3)} {                                                                ;# light background
        return black
    } else {                                                                                                      ;# dark background
        return white
    }
}


} ;# >8
