README.md

apave

A library for GUI development with Tcl/Tk.

Docs:

Full description

apave.tcl

###########################################################
# Name:    apave.tcl
# Author:  Alex Plotnikov  (aplsimple@gmail.com)
# Date:    12/09/2021
# Brief:   Handles APave class creating input dialogs.
# License: MIT.
###########################################################

package require Tk
package provide apave 4.4.10

source [file join [file dirname [info script]] apavedialog.tcl]

# ________________________ Independent procs _________________________ #

proc ::iswindows {} {
  # Checks for "platform is MS Windows".

  expr {$::tcl_platform(platform) eq {windows}}
}

proc ::isunix {} {
  # Checks for "platform is Unix".

  expr {$::tcl_platform(platform) eq {unix}}
}

proc ::isKDE {} {
  # Checks for "desktop is KDE".

  expr {[info exists ::env(XDG_CURRENT_DESKTOP)] && $::env(XDG_CURRENT_DESKTOP) eq {KDE}}
}

proc ::asKDE {} {
  # Checks for DE behaving as weird as KDE.

  expr {[::isKDE] && ![package vsatisfies [package require Tcl] 8.6.11-]}
}
# ________________________ apave NS _________________________ #

namespace eval ::apave {

  namespace export obj openDoc textsplit focusByForce *TextFile undo* *Option*

  mainWindowOfApp .

  variable _OBJ_ {}

  proc obj {com args} {
    # Calls a method of APave class.
    #   com - a method
    #   args - arguments of the method
    # It can (and must) be used only for temporary tasks.
    # For persistent tasks, use a "normal" apave object.
    # Returns the command's result.

    variable _OBJ_
    if {$_OBJ_ eq {}} {set _OBJ_ [::apave::APave new]}
    if {[set exported [expr {$com eq "EXPORT"}]]} {
      set com [lindex $args 0]
      set args [lrange $args 1 end]
      oo::objdefine $_OBJ_ "export $com"
    }
    set res [$_OBJ_ $com {*}$args]
    if {$exported} {
      oo::objdefine $_OBJ_ "unexport $com"
    }
    return $res
  }
  #_______________________

  proc None {args} {
    # Useful when to do nothing is better than to do something.

  }
  #_______________________

  proc autoexec {comm {ext ""}} {
    # Imitates Tcl's auto_execok.
    #   comm - a command to find
    #   ext - file's extension (for Windows)
    # If it doesn't get the command from Tcl's auto_execok,
    # it tries to knock at its file by itself.

    if {$ext ne {} && [::iswindows]} {append comm $ext}
    set res [auto_execok $comm]
    if {$res eq {} && [file exists $comm]} {
      set res $comm
    }
    return $res
  }
  #_______________________

  proc openDoc {url} {
    # Opens a document.
    #   url - document's file name, www link, e-mail etc.

    set commands {xdg-open open start}
    foreach opener $commands {
      if {$opener eq "start"} {
        set command [list {*}[auto_execok start] {}]
      } else {
        set command [auto_execok $opener]
      }
      if {[string length $command]} {
        break
      }
    }
    if {[string length $command] == 0} {
      puts "ERROR: couldn't find any opener"
    }
    # remove the tailing " &" (as e_menu can set)
    set url [string trimright $url]
    if {[string match "* &" $url]} {set url [string range $url 0 end-2]}
    set url [string trim $url]
    if {[catch {exec -- {*}$command $url &} error]} {
      puts "ERROR: couldn't execute '$command':\n$error"
    }
  }
  #_______________________

  proc countChar {str ch} {
    # Counts a character in a string.
    #   str - a string
    #   ch - a character
    #
    # Returns a number of non-escaped occurences of character *ch* in
    # string *str*.
    #
    # See also:
    # [wiki.tcl-lang.org](https://wiki.tcl-lang.org/page/Reformatting+Tcl+code+indentation)

    set icnt 0
    while {[set idx [string first $ch $str]] >= 0} {
      set backslashes 0
      set nidx $idx
      while {[string equal [string index $str [incr nidx -1]] \\]} {
        incr backslashes
      }
      if {$backslashes % 2 == 0} { incr icnt }
      set str [string range $str [incr idx] end]
    }
    return $icnt
  }
  #_______________________

  proc traceRemove {v} {
    # Cancels tracing of a variable.
    #   v - variable's name

    foreach t [trace info variable $v] {
      lassign $t o c
      trace remove variable $v $o $c
    }
  }
  #_______________________

  proc initBaltip {} {
    # Initializes baltip package.

    if {[info command ::baltip] eq {}} {
      if {$::apave::ISBALTIP} {
        source [file join $::apave::SRCDIR baltip baltip.tcl]
      } else {
        # disabling baltip facilities with stub proc (no source "baltip.src")
        namespace eval ::baltip {
          variable expproc [list configure cget tip update hide repaint \
            optionlist tippath clear sleep showBalloon showTip]
          foreach _ $expproc {
          ; proc $_ {args} {return {}}
            namespace export $_
          }
          namespace ensemble create
          namespace eval my {
          ; proc BindToEvent {args} {}
          }
        }
      }
    }
  }

  ## ________________________ Integers _________________________ ##


  proc getN {sn {defn 0} {min ""} {max ""}} {
    # Gets a number from a string
    #   sn - string containing a number
    #   defn - default value when sn is not a number
    #   min - minimal value allowed
    #   max - maximal value allowed

    if {$sn eq "" || [catch {set sn [expr {$sn}]}]} {set sn $defn}
    if {$max ne ""} {
      set sn [expr {min($max,$sn)}]
    }
    if {$min ne ""} {
      set sn [expr {max($min,$sn)}]
    }
    return $sn
  }
  #_______________________

  proc p+ {p1 p2} {
    # Sums two text positions straightforward: lines & columns separately.
    #   p1 - 1st position
    #   p2 - 2nd position
    # The lines may be with "-".
    # Reasons for this:
    #  1. expr $p1+$p2 doesn't work, e.g. 309.10+1.4=310.5 instead of 310.14
    #  2. do it without a text widget's path (for text's arithmetic)

    lassign [split $p1 .] l11 c11
    lassign [split $p2 .] l21 c21
    foreach n {l11 c11 l21 c21} {
      if {![string is digit -strict [string trimleft [set $n] -]]} {set $n 0}
    }
    return [incr l11 $l21].[incr c11 $c21]
  }
  #_______________________

  proc pint {pos} {
    # Gets int part of text position, e.g. "4" for "4.end".
    #   pos - position in text

    if {[set i [string first . $pos]]>0} {incr i -1} {set i end}
    expr {int([string range $pos 0 $i])}
  }
  #_______________________

  proc intInRange {int min max} {
    # Checks whether an integer is in min-max range.
    #   int - the integer
    #   min - minimum of the range
    #   max - maximum of the range

    expr {[string is integer -strict $int] && $int>=$min && $int<=$max}
  }
  #_______________________

  proc IsRoundInt {i1 i2} {
    # Checks whether an integer equals roundly to other integer.
    #   i1 - integer to compare
    #   i2 - integer to be compared (rounded) to i1

    expr {$i1>($i2-3) && $i1<($i2+3)}
  }

  ## _______________________ Lists, arrays _______________________ ##

  proc lsearchFile {flist fname} {
    # Searches a file name in a list, using normalized file names.
    #   flist - list of file names
    #   fname - file name to find
    # Returns an index of found file name or -1 if it's not found.

    set i 0
    set fname [file normalize $fname]
    foreach fn $flist {
      if {[file normalize $fn] eq $fname} {
        return $i
      }
      incr i
    }
    return -1
  }
  #_______________________

  proc RestoreArray {arName arSave} {
    # Tries restoring an array 1:1.
    #   arName - fully qualified array name
    #   arSave - saved array's value (got with "array get")
    # At restoring, new items of $arName are deleted and existing items are updated,
    # so that after restoring *array get $arName* is equal to $arSave.
    # Note: "array unset $arName *; array set $arName $arSave" doesn't ensure this equality.

    set ar $arName
    array set artmp $arSave
    set tmp1 [array names artmp]
    set tmp2 [array names $arName]
    foreach n $tmp2 {
      if {$n ni $tmp1} {unset [set ar]($n)} {set [set ar]($n) $artmp($n)}
    }
    foreach n $tmp1 {
      # deleted items can break 1:1 equality (not the case with alited)
      if {$n ni $tmp2} {set [set ar]($n) $artmp($n)}
    }
  }
  #_______________________

  proc EnsureArray {arName args} {
    # Ensures restoring an array at calling a proc.
    #   arName - fully qualified array name
    #   args - proc name & arguments

    set arSave [array get $arName]
    {*}$args
    RestoreArray $arName $arSave
  }
  #_______________________

  proc PushInList {listName item {pos 0} {max 16}} {
    # Pushes an item in a list: deletes an old instance, inserts a new one.
    #   listName - the list's variable name
    #   item - item to push
    #   pos - position in the list to push in
    #   max - maximum length of the list

    upvar $listName ln
    if {[set i [lsearch -exact $ln $item]]>-1} {
      set ln [lreplace $ln $i $i]
    }
    set ln [linsert $ln $pos $item]
    catch {set ln [lreplace $ln $max end]}
  }

  ## ________________________ Widgets _________________________ ##

  proc checkGeometry {geo} {
    # Checks a window's geometry.
    #   geo - the geometry
    # Returns a "normalized" geometry (+0+0 if input not correct).

    if {!([regexp {^\d+x\d+\+-?\d+\+-?\d+$} $geo] ||
    [regexp {^\+-?\d+\+-?\d+$} $geo] || [regexp {^\d+x\d+$} $geo])} {
      set geo +0+0
    }
    return $geo
  }
  #_______________________

  proc repaintWindow {win {wfoc ""}} {
    # Shows a window and, optionally, focuses on a widget of it.
    #   win - the window's path
    #   wfoc - the widget's path or a command to get it
    # Returns yes, if the window is shown successfully.

    if {[winfo exists $win]} {
      # esp. for KDE
      if {[isKDE]} { ;# KDE is KDE, Tk is Tk, and never the twain shall meet
        wm withdraw $win
        wm deiconify $win
        wm attributes $win -topmost [wm attributes $win -topmost]
      }
      update
      if {$wfoc ne {}} {
        catch {set wfoc [{*}$wfoc]}
        focus $wfoc
      }
      return yes
    }
    return no
  }
  #_______________________

  proc rootModalWindow {pwin} {
    # Gets a parent modal window for a given one.
    #   pwin - default parent

    set root $pwin
    foreach w [winfo children $pwin] {
      if {[winfo ismapped $w] && [InfoFind $w yes] ne {}} {
        set root [winfo toplevel $w]
      }
    }
    return $root
  }
  #_______________________

  proc splitGeometry {geom {X +0} {Y +0}} {
    # Gets widget's geometry components.
    #   geom - geometry
    #   X - default X-coordinate
    #   Y - default Y-coordinate
    # Returns a list of width, height, X and Y (coordinates are always with + or -)
    # and also a flag "negative coordinates, calculated from bottom right".

    lassign [split $geom x+-] w h
    lassign [regexp -inline -all {([+-][[:digit:]]+)} $geom] -> x y
    if {$geom ne {}} {
      if {$x in {"" 0} || [catch {expr {$x+0}}]} {set x $X}
      if {$y in {"" 0} || [catch {expr {$y+0}}]} {set y $Y}
    }
    set neg [expr {[string first - $geom]>=0 && [string first + $geom]<0}]
    list $w $h $x $y $neg
  }
  #_______________________

  proc focusFirst {w {dofocus yes} {res {}}} {
    # Sets a focus on a first widget of a parent widget.
    #  w - the parent widget
    #  dofocus - if no, means "only return the widget's path"
    #  res - used for recursive call
    # Returns a path to a focused widget or "".

    if {$w ne {}} {
      foreach w [winfo children $w] {
        if {[focusedWidget $w]} {
          if {$dofocus} {after 200 "catch {focus -force $w}"}
          return $w
        } else {
          if {[set res [focusFirst $w $dofocus]] ne {}} break
        }
      }
    }
    return $res
  }
  #_______________________

  proc focusedWidget {w} {
    # Gets a flag "is a widget can be focused".
    #   w - widget's path

    set wclass [string tolower [winfo class $w]]
    foreach c [list entry text button box list view] {
      if {[string match *$c $wclass]} {
        if {[catch {set state [$w cget -state]}]} {set state normal}
        if {$state ne {disabled}} {
          if {[catch {set focus [$w cget -takefocus]}]} {set focus no}
          return [expr {![string is boolean -strict $focus] || $focus}]
        }
        break
      }
    }
    return no
  }
  #_______________________

  proc MouseOnWidget {w1} {
    # Places the mouse pointer on a widget.
    #   w1 - the widget's path

    update
    set w2 [winfo parent $w1]
    set w3 [winfo parent $w2]
    lassign [split [winfo geometry $w1] +x] w h x1 y1
    lassign [split [winfo geometry $w2] +x] - - x2 y2
    event generate $w3 <Motion> -warp 1 \
      -x [expr {$x1+$x2+int($w/2)}] -y [expr {$y1+$y2+int($h/2)}]
  }
  #_______________________

  proc CursorAtEnd {w} {
    # Sets the cursor at the end of a field.
    #   w - the field's path

    focus $w
    $w selection clear
    $w icursor end
  }
  #_______________________

  proc focusByForce {foc {cnt 10}} {
    # Focuses a widget.
    #   foc - widget's path

    if {[incr cnt -1]>0} {
      after idle after 5 ::apave::focusByForce $foc $cnt
    } else {
      catch {focus -force [winfo toplevel $foc]; focus $foc}
    }
  }
  #_______________________

  proc KeyAccelerator {acc} {
    # Returns a key accelerator.
    #   acc - key name, may contain 2 items (e.g. Control-D Control-d)

    set acc [lindex $acc 0]
    string map {Control Ctrl - + bracketleft [ bracketright ]} $acc
  }
  #_______________________

  proc InvertBg {clr {B #000000} {W #FFFFFF}} {
    # Gets a "inverted" color (white/black) for an color.
    #   clr - color (#hhh or #hhhhhh)
    #   B - "black" color
    #   W - "white" color
    # Returns a list of "black/white" and normalized input color

    if {[string length $clr]==4} {
      lassign [split $clr {}] -> r g b
      set clr #$r$r$g$g$b$b
    }
    lassign [winfo rgb . $clr] r g b
    if {($r%256+$b%256)<15 && ($g%256)>180 || $r+1.5*$g+0.5*$b > 100000} {
      set res $B
    } else {
      set res $W
    }
    list $res $clr
  }

  ### ________________________ Blinking widgets _________________________ ###

  proc blinkWidget {w {fg #000} {bg #fff} {fg2 {}} {bg2 red} \
    {pause 1000} {count -1} {mode 1}} {
    # Makes a widget blink.
    #   w - the widget's path
    #   fg - normal foreground color
    #   bg - normal background color
    #   fg2 - blinking foreground color (if {}, stops the blinking)
    #   bg2 - blinking background color
    #   pause - pause in millisec between blinkings
    #   count - means how many times do blinking
    #   mode - for recursive calls

    if {![winfo exists $w]} return
    if {$count==0 || $fg2 eq {}} {
      catch {after cancel $::apave::BLINKWIDGET1}
      catch {after cancel $::apave::BLINKWIDGET2}
      after idle "$w configure -foreground $fg; $w configure -background $bg"
    } elseif {$mode==1} {
      incr count -1
      $w configure -foreground $fg2
      $w configure -background $bg2
      set ::apave::BLINKWIDGET1 [after \
        $pause ::apave::blinkWidget $w $fg $bg $fg2 $bg2 $pause $count 2]
    } elseif {$mode==2} {
      $w configure -foreground $fg
      $w configure -background $bg
      set ::apave::BLINKWIDGET2 [after \
        $pause ::apave::blinkWidget $w $fg $bg $fg2 $bg2 $pause $count 1]
    }
  }
  #_______________________

  proc blinkWidgetImage {w img1 {img2 alimg_none} {cnt 6} {ms 100}} {
    # Makes a widget's image blink.
    #   w - widget's path
    #   img1 - main image
    #   img2 - flashed image
    #   cnt - count of flashes
    #   ms - millisec between flashes

    set imgcur $img1
    if {$cnt>0} {
      if {$cnt % 2} {set imgcur $img2}
      after $ms "::apave::blinkWidgetImage $w $img1 $img2 [incr cnt -1] $ms"
    }
    $w configure -image $imgcur
  }

  ## ________________________ File names _________________________ ##

  proc HomeDir {} {
    # For Tcl 9.0 & Windows: gets a home directory ("~").

    if {[catch {set hd [file home]}]} {
      if {[info exists ::env(HOME)]} {set hd $::env(HOME)} {set hd ~}
    }
    return $hd
  }
  #_______________________

  proc checkHomeDir {com} {
    # For Tcl 9.0 & Windows: checks a command for "~".

    set hd [HomeDir]
    set com [string map [list { ~/} " $hd/" \"~/ \"$hd/ '~/ '$hd/ \\n~/ \\n$hd/ \n~/ \n$hd/ \{~/ \{$hd/] $com]
    if {[string match ~/* $com]} {set com $hd[string range $com 1 end]}
    return $com
  }
  #_______________________

  proc UnixPath {path} {
    # Makes a path "unix-like" to be good for Tcl.
    #   path - the path

    set path [string trim $path "\{\}"]  ;# possibly braced if contains spaces
    set path [string map [list \\ / %H [HomeDir]] $path]
    checkHomeDir $path
  }
  #_______________________

  proc NormalizeName {name} {
    # Removes spec.characters from a name (sort of normalizing it).
    #   name - the name

    string map [list \\ {} \{ {} \} {} \[ {} \] {} \t {} \n {} \r {} \" {}] $name
  }
  #_______________________

  proc NormalizeFileName {name} {
    # Removes spec.characters from a file/dir name (sort of normalizing it).
    #   name - the name of file/dir

    set name [string trim $name]
    string map [list \
      * _ ? _ ~ _ / _ \\ _ \{ _ \} _ \[ _ \] _ \t _ \n _ \r _ \
      | _ < _ > _ & _ , _ : _ \; _ \" _ ' _ ` _] $name
  }
  #_______________________

  proc FileTail {basepath fullpath} {
    # Extracts a tail path from a full file path.
    # E.g. FileTail /a/b /a/b/cd/ef => cd/ef
    #   basepath - base path
    #   fullpath - full path

    set lbase [file split $basepath]
    set lfull [file split $fullpath]
    set ll [expr {[llength $lfull] - [llength $lbase] - 1}]
    if {$ll>-1} {
      return [file join {*}[lrange $lfull end-$ll end]]
    }
    return {}
  }
  #_______________________

  proc FileRelativeTail {basepath fullpath} {
    # Gets a base relative path.
    # E.g. FileRelativeTail /a/b /a/b/cd/ef => ../ef
    #   basepath - base path
    #   fullpath - full path

    set tail [FileTail $basepath $fullpath]
    set lev [llength [file split $tail]]
    set base {}
    for {set i 1} {$i<$lev} {incr i} {append base ../}
    append base [file tail $tail]
  }

  ## ________________________ Borrowed from BWidget _________________________ ##

  #  Command BWidget::place ----> apave::place
  #
  # Notes:
  #  For Windows systems with more than one monitor the available screen area may
  #  have negative positions. Geometry settings with negative numbers are used
  #  under X to place wrt the right or bottom of the screen. On windows, Tk
  #  continues to do this. However, a geometry such as 100x100+-200-100 can be
  #  used to place a window onto a secondary monitor. Passing the + gets Tk
  #  to pass the remainder unchanged so the Windows manager then handles -200
  #  which is a position on the left hand monitor.
  #  I've tested this for left, right, above and below the primary monitor.
  #  Currently there is no way to ask Tk the extent of the Windows desktop in
  #  a multi monitor system. Nor what the legal co-ordinate range might be.
  #

  proc place { path w h args } {

    update idletasks

    # If the window is not mapped, it may have any current size.
    # Then use required size, but bound it to the screen width.
    # This is mostly inexact, because any toolbars will still be removed
    # which may reduce size.
    if { $w == 0 && [winfo ismapped $path] } {
      set w [winfo width $path]
    } else {
      if { $w == 0 } {
        set w [winfo reqwidth $path]
      }
      set vsw [winfo vrootwidth  $path]
      if { $w > $vsw } { set w $vsw }
    }

    if { $h == 0 && [winfo ismapped $path] } {
      set h [winfo height $path]
    } else {
      if { $h == 0 } {
        set h [winfo reqheight $path]
      }
      set vsh [winfo vrootheight $path]
      if { $h > $vsh } { set h $vsh }
    }

    set arglen [llength $args]
    if { $arglen > 3 } {
      return -code error "apave::place: bad number of argument"
    }

    if { $arglen > 0 } {
      set where [lindex $args 0]
      set list  [list at center left right above below]
      set idx   [lsearch $list $where]
      if { $idx == -1 } {
        return -code error "apave::place: bad position: $where $list"
      }
      if { $idx == 0 } {
        set err [catch {
          # purposely removed the {} around these expressions - [PT]
          set x [expr int([lindex $args 1])]
          set y [expr int([lindex $args 2])]
        } e]
        if { $err } {
          return -code error "apave::place: bad position: $e"
        }
        if {$::tcl_platform(platform) eq {windows}} {
          # handle windows multi-screen. -100 != +-100
          if {[string index [lindex $args 1] 0] ne {-}} {
            set x +$x
          }
          if {[string index [lindex $args 2] 0] ne {-}} {
            set y +$y
          }
        } else {
          if { $x >= 0 } {
            set x +$x
          }
          if { $y >= 0 } {
            set y +$y
          }
        }
      } else {
        if { $arglen == 2 } {
          set widget [lindex $args 1]
          if { ![winfo exists $widget] } {
            return -code error "apave::place: \"$widget\" does not exist"
          }
        } else {
          set widget .
        }
        set sw [winfo screenwidth  $path]
        set sh [winfo screenheight $path]
        if { $idx == 1 } {
          if { $arglen == 2 } {
            # center to widget
            set x0 [expr {[winfo rootx $widget] + ([winfo width  $widget] - $w)/2}]
            set y0 [expr {[winfo rooty $widget] + ([winfo height $widget] - $h)/2}]
          } else {
            # center to screen
            set x0 [expr {($sw - $w)/2 - [winfo vrootx $path]}]
            set y0 [expr {($sh - $h)/2 - [winfo vrooty $path]}]
          }
          set x +$x0
          set y +$y0
          if {$::tcl_platform(platform) ne {windows}} {
            if { $x0+$w > $sw } {set x {-0}; set x0 [expr {$sw-$w}]}
            if { $x0 < 0 }      {set x {+0}}
            if { $y0+$h > $sh } {set y {-0}; set y0 [expr {$sh-$h}]}
            if { $y0 < 0 }      {set y {+0}}
          }
        } else {
          set x0 [winfo rootx $widget]
          set y0 [winfo rooty $widget]
          set x1 [expr {$x0 + [winfo width  $widget]}]
          set y1 [expr {$y0 + [winfo height $widget]}]
          if { $idx == 2 || $idx == 3 } {
            set y +$y0
            if {$::tcl_platform(platform) ne {windows}} {
              if { $y0+$h > $sh } {set y {-0}; set y0 [expr {$sh-$h}]}
              if { $y0 < 0 }      {set y {+0}}
            }
            if { $idx == 2 } {
              # try left, then right if out, then 0 if out
              if { $x0 >= $w } {
                set x [expr {$x0-$w}]
              } elseif { $x1+$w <= $sw } {
                set x +$x1
              } else {
                set x {+0}
              }
            } else {
              # try right, then left if out, then 0 if out
              if { $x1+$w <= $sw } {
                set x +$x1
              } elseif { $x0 >= $w } {
                set x [expr {$x0-$w}]
              } else {
                set x {-0}
              }
            }
          } else {
            set x +$x0
            if {$::tcl_platform(platform) ne {windows}} {
              if { $x0+$w > $sw } {set x {-0}; set x0 [expr {$sw-$w}]}
              if { $x0 < 0 }      {set x {+0}}
            }
            if { $idx == 4 } {
              # try top, then bottom, then 0
              if { $h <= $y0 } {
                set y [expr {$y0-$h}]
              } elseif { $y1+$h <= $sh } {
                set y +$y1
              } else {
                set y {+0}
              }
            } else {
              # try bottom, then top, then 0
              if { $y1+$h <= $sh } {
                set y +$y1
              } elseif { $h <= $y0 } {
                set y [expr {$y0-$h}]
              } else {
                set y {-0}
              }
            }
          }
        }
      }

      ## If there's not a + or - in front of the number, we need to add one.
      if {[string is integer [string index $x 0]]} { set x +$x }
      if {[string is integer [string index $y 0]]} { set y +$y }

      wm geometry $path "${w}x${h}${x}${y}"
    } else {
      wm geometry $path "${w}x${h}"
    }
    update idletasks
  }

  ## ________________________ EONS apave _________________________ ##

}

# ________________________ APave _________________________ #

oo::class create ::apave::APave {

  superclass ::apave::APaveDialog

  variable _savedvv

  constructor {args} {
    # Creates APave object.
    #   win - window's name (path)
    #   args - additional arguments

    set _savedvv [list]
    if {[llength [self next]]} { next {*}$args }
  }

  destructor {
    # Clears variables used in the object.

    my initInput
    unset _savedvv
    if {[llength [self next]]} next
  }
  #_______________________

  method initInput {} {
    # Initializes input and clears variables made in previous session.

    foreach {vn vv} $_savedvv {
      catch {unset $vn}
    }
    set _savedvv [list]
    set Widgetopts [list]
  }
  #_______________________

  method varInput {} {
    # Gets variables made and filled in a previous session
    # as a list of "varname varvalue" pairs where varname
    # is of form: namespace::var$widgetname.

    return $_savedvv
  }
  #_______________________

  method valueInput {} {
    # Gets input variables' values.

    set _values {}
    foreach {vnam -} [my varInput] {
      lappend _values [set $vnam]
    }
    return $_values
  }
  #_______________________

  method input {icon ttl iopts args} {
    # Makes and runs an input dialog.
    #  icon - icon (omitted if equals to "")
    #  ttl - title of window
    #  iopts - list of widgets and their attributes
    #  args - list of dialog's attributes
    # The `iopts` contains lists of three items:
    #   name - name of widgets
    #   prompt - prompt for entering data
    #   valopts - value options
    # The `valopts` is a list specific for a widget's type, however
    # a first item of `valopts` is always an initial input value.

    if {$iopts ne {}} {
      my initInput  ;# clear away all internal vars
    }
    set pady "-pady 2"
    if {[set focusopt [::apave::getOption -focus {*}$args]] ne {}} {
      set focusopt "-focus $focusopt"
    }
    lappend inopts [list fraM + T 1 98 "-st nsew $pady -rw 1"]
    set savedvv [list]
    set frameprev {}
    foreach {name prompt valopts} $iopts {
      if {$name eq {}} continue
      lassign $prompt prompt gopts attrs
      lassign [::apave::extractOptions attrs -method {} -toprev {}] ismeth toprev
      if {[string toupper $name 0] eq $name} {
        set ismeth yes  ;# overcomes the above setting
        set name [string tolower $name 0]
      }
      set ismeth [string is true -strict $ismeth]
      set gopts "$pady $gopts"
      set typ [string tolower [string range $name 0 1]]
      if {$typ eq "v_" || $typ eq "se"} {
        lappend inopts [list fraM.$name - - - - "pack -fill x $gopts"]
        continue
      }
      set tvar "-tvar"
      switch -exact -- $typ {
        ch { set tvar "-var" }
        sp { set gopts "$gopts -expand 0 -side left"}
      }
      set framename fraM.fra$name
      if {$typ in {lb te tb}} {  ;# the widgets sized vertically
        lappend inopts [list $framename - - - - "pack -expand 1 -fill both"]
      } else {
        lappend inopts [list $framename - - - - "pack -fill x"]
      }
      set vv [my varName $name]
      set ff [my FieldName $name]
      set Name [string toupper $name 0]
      if {$ismeth && $typ ni {ra}} {
        # -method option forces making "WidgetName" method from "widgetName"
        my MakeWidgetName $ff $Name -
      }
      if {$typ ne {la} && $toprev eq {}} {
        set takfoc [::apave::parseOptions $attrs -takefocus 1]
        if {$focusopt eq {} && $takfoc} {
          if {$typ in {fi di cl fo da}} {
            set _ en*$name  ;# 'entry-like mega-widgets'
          } elseif {$typ eq "ft"} {
            set _ te*$name  ;# ftx - 'text-like mega-widget'
          } else {
            set _ $name
          }
          set focusopt "-focus $_"
        }
        if {$typ in {lb tb te}} {set anc nw} {set anc w}
        lappend inopts [list fraM.fra$name.labB$name - - - - \
          "pack -side left -anchor $anc -padx 3" \
          "-t \"$prompt\" -font \
          \"-family {[my basicTextFont]} -size [my basicFontSize]\""]
      }
      # for most widgets:
      #   1st item of 'valopts' list is the current value
      #   2nd and the rest of 'valopts' are a list of values
      if {$typ ni {fc te la}} {
        # curr.value can be set with a variable, so 'subst' is applied
        set vsel [lindex $valopts 0]
        catch {set vsel [subst -nocommands -nobackslashes $vsel]}
        set vlist [lrange $valopts 1 end]
      }
      if {[set msgLab [::apave::getOption -msgLab {*}$attrs]] ne {}} {
        set attrs [::apave::removeOptions $attrs -msgLab]
      }
      # define a current widget's info
      switch -exact -- $typ {
        lb - tb {
          set $vv $vlist
          lappend attrs -lvar $vv
          if {$vsel ni {{} -}} {
            lappend attrs -lbxsel "$::apave::UFF$vsel$::apave::UFF"
          }
          lappend inopts [list $ff - - - - \
            "pack -side left -expand 1 -fill both $gopts" $attrs]
          lappend inopts [list fraM.fra$name.sbv$name $ff L - - "pack -fill y"]
        }
        cb {
          if {![info exist $vv]} {catch {set $vv $vsel}}
          lappend attrs -tvar $vv -values $vlist
          if {$vsel ni {{} -}} {
            lappend attrs -cbxsel $::apave::UFF$vsel$::apave::UFF
          }
          lappend inopts [list $ff - - - - "pack -side left -expand 1 -fill x $gopts" $attrs]
        }
        fc {
          if {![info exist $vv]} {catch {set $vv {}}}
          lappend inopts [list $ff - - - - "pack -side left -expand 1 -fill x $gopts" "-tvar $vv -values \{$valopts\} $attrs"]
        }
        op {
          set $vv $vsel
          lappend inopts [list $ff - - - - "pack -fill x $gopts" "$vv $vlist"]
        }
        ra {
          if {![info exist $vv]} {catch {set $vv $vsel}}
          set padx 0
          foreach vo $vlist {
            set name $name
            set FF $ff[incr nnn]
            lappend inopts [list $FF - - - - "pack -side left $gopts -padx $padx" "-var $vv -value \"$vo\" -t \"$vo\" $attrs"]
            if {$ismeth} {
              my MakeWidgetName $FF $Name$nnn -
            }
            set padx [expr {$padx ? 0 : 9}]
          }
        }
        te {
          if {![info exist $vv]} {
            set valopts [string map [list \\n \n \\t \t] $valopts]
            set $vv [string map [list \\\\ \\ \\\} \} \\\{ \{] $valopts]
          }
          if {[dict exist $attrs -state] && [dict get $attrs -state] eq "disabled"} \
          {
            # disabled text widget cannot be filled with a text, so we should
            # compensate this through a home-made attribute (-disabledtext)
            set disattr "-disabledtext \{[set $vv]\}"
          } elseif {[dict exist $attrs -readonly] && [dict get $attrs -readonly] || [dict exist $attrs -ro] && [dict get $attrs -ro]} {
            set disattr "-rotext \{[set $vv]\}"
            set attrs [::apave::removeOptions $attrs -readonly -ro]
          } else {
            set disattr {}
          }
          lappend inopts [list $ff - - - - "pack -side left -expand 1 -fill both $gopts" "$attrs $disattr"]
          lappend inopts [list fraM.fra$name.sbv$name $ff L - - "pack -fill y"]
        }
        la {
          if {$prompt ne {}} { set prompt "-t \"$prompt\" " } ;# prompt as -text
          lappend inopts [list $ff - - - - "pack -anchor w $gopts" "$prompt$attrs"]
          continue
        }
        bu - bt - ch {
          set prompt {}
          if {$toprev eq {}} {
            lappend inopts [list $ff - - - - \
              "pack -side left -expand 1 -fill both $gopts" "$tvar $vv $attrs"]
          } else {
            lappend inopts [list $frameprev.$name - - - - \
              "pack -side left $gopts" "$tvar $vv $attrs"]
          }
          if {$vv ne {}} {
            if {![info exist $vv]} {
              catch {
                if {$vsel eq {}} {set vsel 0}
                set $vv $vsel
              }
            }
          }
        }
        default {
          if {$vlist ne {}} {lappend attrs -values $vlist}
          lappend inopts [list $ff - - - - \
            "pack -side left -expand 1 -fill x $gopts" "$tvar $vv $attrs"]
          if {$vv ne {}} {
            if {![info exist $vv]} {catch {set $vv $vsel}}
          }
        }
      }
      if {$msgLab ne {}} {
        lassign $msgLab lab msg attlab
        set lab [my parentWName [lindex $inopts end 0]].$lab
        if {$msg ne {}} {set msg "-t {$msg}"}
        append msg " $attlab"
        lappend inopts [list $lab - - - - "pack -side left -expand 1 -fill x" $msg]
      }
      if {![info exist $vv]} {set $vv {}}
      lappend _savedvv $vv [set $vv]
      set frameprev $framename
    }
    lassign [::apave::parseOptions $args -titleHELP {} -buttons {} -comOK 1 \
      -titleOK OK -titleCANCEL Cancel -centerme {}] \
      titleHELP buttons comOK titleOK titleCANCEL centerme
    if {$titleHELP eq {}} {
      set butHelp {}
    } else {
      lassign $titleHELP title command
      set butHelp [list butHELP $title $command]
    }
    if {$titleCANCEL eq {}} {
      set butCancel {}
    } else {
      set butCancel "butCANCEL $titleCANCEL destroy"
    }
    if {$centerme eq {}} {
      set centerme {-centerme 1}
    } else {
      set centerme "-centerme $centerme"
    }
    set args [::apave::removeOptions $args \
      -titleHELP -buttons -comOK -titleOK -titleCANCEL -centerme -modal]
    lappend args {*}$focusopt
    if {[catch {
      lassign [my PrepArgs {*}$args] args
      set res [my Query $icon $ttl {} \
        "$butHelp $buttons butOK $titleOK $comOK $butCancel" \
        butOK $inopts $args {} {*}$centerme -input yes]} e]
    } then {
      catch {destroy $Dlgpath}  ;# Query's window
      set under \n[string repeat _ 80]\n\n
      ::apave::obj ok err "ERROR" "\n$e$under $inopts$under $args$under $centerme" \
        -t 1 -head "\nAPave error: \n" -hfg red -weight bold -w 80
      return 0
    }
    if {![lindex $res 0]} {  ;# restore old values if OK not chosen
      foreach {vn vv} $_savedvv {
        # tk_optionCascade (destroyed now) was tracing its variable => catch
        catch {set $vn $vv}
      }
    }
    return $res
  }
  #_______________________

  method vieweditFile {fname {prepcom ""} args} {
    # Views or edits a file.
    #   fname - name of file
    #   prepcom - a command performing before and after creating a dialog
    #   args - additional options
    # It's a sort of stub for calling *editfile* method.
    # See also: editfile

    my editfile $fname {} {} {} $prepcom {*}$args
  }
  #_______________________

  method editfile {fname fg bg cc {prepcom ""} args} {
    # Edits or views a file with a set of main colors
    #   fname - name of file
    #   fg - foreground color of text widget
    #   bg - background color of text widget
    #   cc - caret's color of text widget
    #   prepcom - a command performing before and after creating a dialog
    #   args - additional options (`-readonly 1` for viewing the file).
    # If *fg* isn't empty, all three colors are used to color a text.
    # See also:
    # [aplsimple.github.io](https://aplsimple.github.io/en/tcl/pave/index.html)

    if {$fname eq {}} {
      return false
    }
    set newfile 0
    if {[catch {set filetxt [::apave::readTextFile $fname {} yes]}]} {
      return false
    }
    lassign [::apave::parseOptions $args -rotext {} -readonly 1 -ro 1] rotext readonly ro
    lassign [::apave::extractOptions args -buttons {}] buttadd
    set btns {Close 0}  ;# by default 'view' mode
    set oper VIEW
    if {$rotext eq {} && (!$readonly || !$ro)} {
      set btns {Save 1 Close 0}
      set oper EDIT
    }
    if {$fg eq {}} {
      set tclr {}
    } else {
      set tclr "-fg $fg -bg $bg -cc $cc"
    }
    if {$prepcom eq {}} {set aa {}} {set aa [$prepcom filetxt]}
    set res [my misc {} "$oper: $fname" "$filetxt" "$buttadd $btns" \
      TEXT -text 1 -w {100 80} -h 32 {*}$tclr \
      -post $prepcom {*}$aa {*}$args]
    set data [string range $res 2 end]
    if {[set res [string index $res 0]] eq "1"} {
      set data [string range $data [string first " " $data]+1 end]
      set data [string trimright $data]
      set res [::apave::writeTextFile $fname data]
    } elseif {$newfile} {
      file delete $fname
    }
    return $res
  }
  #_______________________

  method onTop {wpar top {wtoplist -} {res ""}} {
    # Sets -topmost attribute for windows or gets a list of topmost windows.
    #   wpar - parent window's path
    #   top - -topmost attribute's value
    #   wtoplist - list of windows to process
    #   res - used to get the result
    # Returns a list of "topmost=$top" windows found on $wpar path.

    if {$wtoplist ne "-"} {
      # sets the attribute
      foreach w $wtoplist {wm attributes $w -topmost $top}
    } else {
      # gets a list of topmost windows
      if {$wpar ne {}} {
        set res [my onTop [winfo parent $wpar] $top - $res]
        catch {
          if {[wm attributes $wpar -topmost]==$top} {lappend res $wpar}
        }
      }
    }
    return $res
  }

# ________________________ EONS _________________________ #

}
# ________________________ EOF _________________________ #

apave.tcl