### Copyright (C) 1995 Jesper K. Pedersen
### This program is free software; you can redistribute it and/or modify
### it under the terms of the GNU General Public License as published by
### the Free Software Foundation; either version 2 of the License, or
### (at your option) any later version.
###
### This program is distributed in the hope that it will be useful,
### but WITHOUT ANY WARRANTY; without even the implied warranty of
### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
### GNU General Public License for more details.
###
### You should have received a copy of the GNU General Public License
### along with this program; if not, write to the Free Software
### Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.


############################################################
# This function insert an element from the listbox into
# the entry in a fillout list. If the element have
# parrameters, a dialog box ask for these.
# If new, 'name' is the name of the fillOut
# otherwise 'name' is the name of the fillOutElm
############################################################
proc fillout_list {prefix path name new {counter -1}} {
  global widgetArgs editInfo children activeNivau \
      fillOutCounter fillList answers parent changeFunc initFunc
  set function $editInfo(name)
  
  if {$new} {
    set index [${path}.box curselection]
    if {$index == ""} return
    $path.box selection clear $index
    set entryname [lindex $widgetArgs(${function}__${name}__entries) $index]
  } else {
    set entryname $name
  }
  set entries $widgetArgs(${function}__${entryname}__entries)
  set show $widgetArgs(${function}__${entryname}__show)

  # If there are any entries for the current element, a toplevel
  # is created for these.
  if {$entries != ""} {
    if {[winfo exists .fillout]} return
    toplevel .fillout
    set function $editInfo(name)
    if {$new} {
      set counter $fillOutCounter
    }
    # packing the children
    foreach child $children(${function}__$entryname) {
      set default $widgetArgs(${function}__${child}__default)
      Pack .fillout ${prefix}_$counter $child 1
      if {$new} {
	setVariable $child ${prefix}_$counter $default
      }
    }
    button .fillout.ok -text OK -command "
      set err \[catch \$widgetArgs(${function}__${entryname}__pageEnd) errmsg\]
      if {\$err} {
	tk_dialog .errmsg \"Error in page\" \$errmsg error 0 OK
	return
      }
      destroy .fillout
      grab release .fillout"

    pack .fillout.ok -side left -expand 1
    update
    grab .fillout

    # creating the change function
    set oldChange $changeFunc($function)
    set changeFunc($function) $widgetArgs(${function}__${entryname}__change)
    setChangeFunc

    set activeNivau($entryname) $counter
    # linking the variables
    linkVars ${prefix}_$counter $entryname

    if {$new} {
      # initializing the page the first time.
      if {[info exists widgetArgs(${function}__${entryname}__init)]} {
	uplevel \#0 $widgetArgs(${function}__${entryname}__init)
	if {[info exists initFunc($function)]} {
	  set oldInit $initFunc($function)
	}
	set initFunc($function) $widgetArgs(${function}__${entryname}__init)
      } else {
	changeAll $entryname
      }
    }
  
    # waiting for the window to disappear
    tkwait window .fillout

    set changeFunc($function) $oldChange
    if {[info exists oldInit]} {
      set initFunc($function) $oldInit
    } elseif {[info exists initFunc($function)]} {
      unset initFunc($function)
    }
    setChangeFunc
    if {$new} {
      incr fillOutCounter
    }
  }

  # showing the information
  catch {unset answers}
  set answers ""

  # redefining the print function
  set printbody [info body print]
  set printargs [info args print]
  proc print {args} {
    global answers editInfo
    append answers [join $args]
  }
  
  uplevel \#0 $show

  # redefining the print function to its original.
  proc print $printargs $printbody

  # deleteing the information from activeNivau while the page has been
  # removed.
  if {$entries != ""} {
    unset activeNivau($entryname)
    unlink $entryname
  }
  
  # inserting the element 
  set elmLength [string length $answers]
  set index [$path.2 index insert]
  
  set changeNext 1
  set newList {}
  if {[info exists fillList($prefix)]} {
    foreach elm $fillList($prefix) {
      set start [lindex $elm 0]
      set end [lindex $elm 1]
      set insertNext 1
      if {$start < $index} {
	lappend newList $elm
      } else {
	if {$changeNext} {
	  if {!$new} {
	    $path.2 delete $start [expr $end+1]
	    set insertNext 0
	  }
	  lappend newList \
	      [list $index [expr $index+$elmLength-1] $entryname $counter]
	  if {!$new} {
	    set elmLength [expr $elmLength - ($end-$start)-1]
	  }
	  set changeNext 0
	}
	if {$insertNext} {
	  lappend newList \
	      [lreplace $elm 0 1 \
		   [expr $start+$elmLength] [expr $end+$elmLength]]
	}
      }
    }
  }
  $path.2 insert insert $answers
  tkEntrySeeInsert $path.2
  if {$changeNext} {
    lappend newList [list $index [expr $index+$elmLength-1] $entryname $counter]
  }
  set fillList($prefix) $newList
}

############################################################
# This function takes care of insertion and motion in
# the fillout's entry.
############################################################
proc fillOutInsert {path prefix index key state keysymb} {
  global fillList
  set specialKey ""
  set newList {}
  if {![info exists fillList($prefix)]} {
    set fillList($prefix) {}
  }
  
  # remove modifiers
  foreach k {Mod Shift Alt Lock Control Meta Caps Multi \\?\\? Tab Escape!} {
    if {[string match $k* $keysymb]} {
      return
    }
  }

  # Check for special keys
  if {$keysymb == "BackSpace"} {
    set specialKey BackSpace
    tkEntryBackspace $path.2
  }
  if {$keysymb == "Delete" || ($keysymb == "d" && $state&4)} {
    set specialKey Delete
    $path.2 delete insert
  }
  if {$keysymb == "Left" || ($keysymb == "b" && $state&4)} {
    set specialKey Left
    $path.2 icursor [expr $index-1]
    tkEntrySeeInsert $path.2
  }
  if {$keysymb == "Right" || ($keysymb == "f" && $state&4)} {
    set specialKey Right
    $path.2 icursor [expr $index+1]
    tkEntrySeeInsert $path.2
  }
  if {$keysymb == "e" && $state&4} {
    # end of line
    $path.2 icursor end
    tkEntrySeeInsert $path.2
    return
  }
  if {$keysymb == "a" && $state&4} {
    # start of line
    $path.2 icursor 0
    tkEntrySeeInsert $path.2
    return
  }

  if {$specialKey == "" && ($state&4 || $state&8)} return

  # Set the number of elements to be inserted/erasured
  if {$specialKey == "Delete"} {
    set count -1
  } elseif {$specialKey == "BackSpace"} {
    if {$index != 0} {
      set count -1
    } else {
      set count 0
    }
  } elseif {$specialKey == "Left" || $specialKey == "Right"} {
    set count 0
  } else {
    tkEntryInsert $path.2 $key
    set count 1
  }

  # runs through the list of fill elements
  foreach elm $fillList($prefix) {
    set start [lindex $elm 0]
    set end [lindex $elm 1]
    set insertNext 1

    # BackSpace
    if {$specialKey == "BackSpace" && $end == $index-1} {
      set count [expr -($end-$start+1)]
      $path.2 delete $start $end
      tkEntrySeeInsert $path.2
      set insertNext 0
    }

    # Delete
    if {$specialKey == "Delete" && $start == $index} {
      set count [expr -($end-$start+1)]
      $path.2 delete $start $end
      tkEntrySeeInsert $path.2
      set insertNext 0
    }

    # Left
    if {$specialKey == "Left" && $end == $index-1} {
      $path.2 icursor $start
      tkEntrySeeInsert $path.2
      return
    }

    # Right
    if {$specialKey == "Right" && $start == $index} {
      $path.2 icursor [expr $end+1]
      tkEntrySeeInsert $path.2
      return
    }

    # update the list if elements are inserted or deleted
    if {$start < $index-1} {
      if {$insertNext} {
	lappend newList $elm
      }
    } else {
      if {$insertNext} {
	lappend newList \
	    [lreplace $elm 0 1 [expr $start+$count] [expr $end+$count]]
      }
    }
  }
  set fillList($prefix) $newList
}

############################################################
# This function checks wether the cursor is placed on
# an element
############################################################
proc fillOutSet {path prefix x} {
  global fillList widgetArgs editInfo
  tkEntryButton1 $path.2 $x

  if {![info exists fillList($prefix)]} return
  set index [$path.2 index insert]
  set function $editInfo(name)
  foreach elm $fillList($prefix) {
    set start [lindex $elm 0]
    set end [lindex $elm 1]
    if {$index <= $start} break
    if {$index > $end} continue
    $path.2 icursor $start
    set elmName [lindex $elm 2]
    if {$widgetArgs(${function}__${elmName}__entries) == ""} {
      set text $widgetArgs(${function}__${elmName}__text)
      set help $widgetArgs(${function}__${elmName}__help)
      if {![winfo exists .fillOutInfo]} {
	toplevel .fillOutInfo
	pack [message .fillOutInfo.message]
	pack [button .fillOutInfo.ok -command {destroy .fillOutInfo} -text OK]
      }
      .fillOutInfo.message configure -text "$text\n\n$help"
    } else {
      fillout_list $prefix $path $elmName 0 [lindex $elm 3]
    }
    break
  }
}

############################################################
# This function create the information to save
############################################################
proc fillOutSave {name} {
  global widgetArgs children editInfo fillList fillAnswer activeNivau parent
  upvar \#0 $name result
  set function $editInfo(name)
  
  # redefining the print function
  set printbody [info body print]
  set printargs [info args print]
  proc print {args} {
    global fillAnswer editInfo
    append fillAnswer [join $args]
  }

  set lastend -1
  set result ""
  set prefix [buildPath $name]
  global ${prefix}_$name

  if {[info exists fillList(${prefix}_$name)]} {
    foreach elm $fillList(${prefix}_$name) {
      set start [lindex $elm 0]
      set end [lindex $elm 1]
      set entryname [lindex $elm 2]
      set counter [lindex $elm 3]
      set save $widgetArgs(${function}__${entryname}__save)
      append result \
	  [string range [set ${prefix}_$name] [expr $lastend+1] [expr $start-1]]

      # evaluating the save function.
      set activeNivau($entryname) $counter
      linkVars ${prefix}_${name}_$counter $entryname
      uplevel \#0 $save
      unset activeNivau($entryname)
      unlink $entryname

      append result $fillAnswer
      set fillAnswer ""
      set lastend $end
    }
  }

  append result [string range [set ${prefix}_$name] [expr $lastend+1] end]
 
  # redefining the print function to its original.
  proc print $printargs $printbody
}

############################################################
# This function make help available foreach listbox element
############################################################
proc fillout_help {path name y} {

  global widgetArgs editInfo
  set function $editInfo(name)
  set index [$path.box nearest $y]
  set elmName [lindex $widgetArgs(${function}__${name}__entries) $index]
  set help $widgetArgs(${function}__${elmName}__help)
  if {$help == "No Help"} {
    set help $widgetArgs(${function}__${name}__help)
    set text $widgetArgs(${function}__${name}__text)
  } else {
    set text $widgetArgs(${function}__${elmName}__text)
  }
  set editInfo(desc) "$text\n\n$help"
}

############################################################
# This function set the default value for a fillOut elm.
############################################################
proc fillOut_setDefault {name prefix default} {
  global ${prefix}_$name widgetArgs fillList children answers editInfo
  set percent 0
  set slash 0
  set string ""
  set intext 1
  set child "" ; # name of the next child to handle.
  set counter 0; # element counter.
  set entryIndex 0; # index in the entry
  set function $editInfo(name)
  
  # parsing the default string.
  for {set index 0} {$index < [string length $default]} {incr index} {
    set char [string index $default $index]
    switch -exact -- $char {
      \\ {
	if {$slash} {
	  append string "\\"
	}
	set slash [expr ($slash+1) %2]
      }
      
      % {
	if {$slash} {
	  append string "%"
	  set slash 0
	} else {
	  # The start/end of a elmenet or a variable
	  if {$intext} {
	    # The content of string is just ordanary text which shal be
	    # inserted in the entry
	    append ${prefix}_$name $string
	    set intext 0
	    incr entryIndex [string length $string]
	    set string ""
	  } else {
	    # the content of string is either the name of a element
	    # or the value of a variable
	    if {$child != ""} {
	      # the value of string is the content to the variable,
	      # named '$child'
	      setVariable $child ${prefix}_${name}_$counter $string
	      set child \
		  [lindex $childs [expr [lsearch -exact $childs $child] +1]]
	      
	    } else {
	      # now we got a element.

	      set elmName $string
	      if {[lsearch -exact $children(${function}__$name) $elmName] == -1} {
		error "$elmName was not a element in $name,\nwhile reading default string $default.\nThe error was found when an element name was wanted at string index $index"
	      }

	      # checking whether the element have any children
	      set childs $children(${function}__$elmName)
	      if {$childs != ""} {
		set child [lindex $childs 0]
		incr counter
	      }
	    }

	    if {$child == ""} {
	      # read the last child (if there was any)
	      set intext 1

	      # redefining the print function
	      set printbody [info body print]
	      set printargs [info args print]
	      proc print {args} {
		global answers editInfo
		append answers [join $args]
	      }

	      # linking variables and evaluating the save function.
	      set activeNivau($elmName) $counter
	      linkVars ${prefix}_${name}_$counter $elmName
	      catch {unset answers}
	      set answers ""
	      uplevel \#0 $widgetArgs(${function}__${elmName}__show)
	      unset activeNivau($elmName)
	      unlink $elmName
	      
	      # redefining the print function to its original.
	      proc print $printargs $printbody

	      # inserting the element
	      append ${prefix}_$name $answers
	      if {$childs != ""} {
		set c $counter
	      } else {
	       set c -1
	      }
	      lappend fillList(${prefix}_$name) \
		  [list $entryIndex \
		       [expr $entryIndex+[string length $answers]-1]\
		       $elmName $c]
	      incr entryIndex [string length $answers]
	    }
	  }
	  set string ""
	}
      }

      default {
	if {$slash} {
	  append string "\\"
	  set slash 0
	}
	append string $char
      }
    }
  }
  if {$child != ""} {
    error "missing values to \"$elmName\", got to element \"$child\", in default string to element \"$name\""
  }
  if {!$intext} {
    error "End of default string, when reading an element, in \"$name\""
  }
  append ${prefix}_$name $string
}
