# use_main.tcl
# 
# Copyright (c) 1994 R"udiger Franke
# All Rights Reserved.
# 
# Redistribution and use in any form, with or without modification, 
# is permitted, provided that the following conditions are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in other form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. All advertising materials mentioning features or use of this software
#    must display the following acknowledgement:
#       This product includes software developed by R"udiger Franke.
# 4. The name of the author may not be used to endorse or promote products
#    derived from this software without specific prior written permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
# IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
# NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
# THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

#
# constructor for "use_main"
#
proc use_main {w  args} {
  upvar #0 $w this

  # user initializations

  global use
  # data initializations

  set this(use_main) $w
  set this(frame0) $w.frame0
  set this(menubutton1) $w.frame0.menubutton1
  set this(mselect) $w.frame0.menubutton1.mselect
  set this(menubutton2) $w.frame0.menubutton2
  set this(mtarget) $w.frame0.menubutton2.mtarget
  set this(menubutton0) $w.frame0.menubutton0
  set this(mfile) $w.frame0.menubutton0.mfile
  set this(frame1) $w.frame1
  set this(components) $w.frame1.components
  set this(frame2) $w.frame2
  set this(label0) $w.frame2.label0
  set this(label1) $w.frame2.label1
  set this(label2) $w.frame2.label2
  set this(label3) $w.frame2.label3
  
  # widget creations

  frame $this(use_main) -class Use_main
  frame $this(frame0)  \
    -borderwidth "2" \
    -relief "raised"
  menubutton $this(menubutton1)  \
    -menu "$this(mselect)" \
    -text "Selected" \
    -underline "0"
  menu $this(mselect) 
  $this(mselect) add command \
    -label Close \
    -underline 0 \
    -command "$w compclose"
  $this(mselect) add command \
    -label Open \
    -underline 0 \
    -command "$w compopen"
  $this(mselect) add separator
  $this(mselect) add command \
    -label Quit \
    -underline 0 \
    -command "$w compquit"
  
  menubutton $this(menubutton2)  \
    -menu "$this(mtarget)" \
    -text "Target" \
    -underline "0"
  menu $this(mtarget) 
  $this(mtarget) add command \
    -label "Working Directory..." \
    -underline 8 \
    -command "dselect $w.dselect \{$w wdinstall\} {Working Directory: }"
  $this(mtarget) add command \
    -label "Make Index" \
    -underline 5 \
    -command "$w trgmkindex"
  $this(mtarget) add separator
  $this(mtarget) add command \
    -label {Target Application...} \
    -underline 7 \
    -command "appselect $w.appselect \{$w trginstall\} {Target Application: }"
  $this(mtarget) add command \
    -label "Command Line..." \
    -underline 0 \
    -command "
       set shell \[use_unique .shell\]
       use_ontop \$shell use_atools atools {Application Editor} {Command Line}
     "
  $this(mtarget) add command \
    -label "Startup Code..." \
    -underline 0 \
    -command "
       set shell \[use_unique .shell\]
       use_ontop \$shell use_atools atools {Application Editor} {Startup Code}
     "
  $this(mtarget) add command \
    -label "Restart" \
    -underline 0 \
    -command "$w trgrestart"
  $this(mtarget) add separator
  $this(mtarget) add command \
    -label "Concat Script" \
    -underline 1 \
    -command "$w trgconcat"
  
  menubutton $this(menubutton0)  \
    -menu "$this(mfile)" \
    -text "File" \
    -underline "0"
  menu $this(mfile) 
  $this(mfile) add command \
    -label {New Component...} \
    -underline {0} \
    -command "$w compcreate"
  $this(mfile) add command \
    -label {Palettes...} \
    -underline {0} \
    -command "$w palraise"
  #$this(mfile) add separator
  $this(mfile) add command \
    -label "Reinit Entities" \
    -underline 0 \
    -command "$w entreinit"
  $this(mfile) add separator
  $this(mfile) add command \
    -label Exit \
    -underline 0 \
    -command "exit"
  
  frame $this(frame1)  \
    -borderwidth "2" \
    -relief "sunken"
  use_palette $this(components)  \
    -borderwidth "2m"
  frame $this(frame2) 
  label $this(label0)  \
    -anchor "w" \
    -text "Target Application: "
  label $this(label1)  \
    -anchor "w" \
    -text "Working Directory: "
  label $this(label2)  \
    -anchor "w" \
    -textvariable "use(target)"
  label $this(label3)  \
    -anchor "w" \
    -textvariable "use(wd)"
  
  # widget layouting

  pack $this(menubutton0) -side left -fill y
  pack $this(menubutton2) -side left -fill y
  pack $this(menubutton1) -side left -fill y
  
  pack $this(components) -anchor w
  blt_table $this(frame2) \
    $this(label1) 0,0 -anchor w \
    $this(label3) 0,1 -fill x \
    $this(label0) 1,0 -anchor w \
    $this(label2) 1,1 -fill x
  blt_table column $this(frame2) configure 0 -resize none
  pack $this(frame0) -fill both
  pack $this(frame2) -fill both
  pack $this(frame1) -fill both -expand true
  
  useCreateComponent use_main $w $args

  # user additions

  set this(icon,selected) {}
  $this(components) ncolumns 5
  
  bind $this(frame1) <Button-1> "$w icondeselect"
  
  # create interpreter for testing out entities
  $w entcreate
  
  # create a palette for widgets
  $w palcreate
  

  return $w
}

#
# method "_compdestroyed"
#
proc use_main::_compdestroyed {w icon} {
  upvar #0 $w this

  global use
  
  set compname [useWidgetInfo $icon -text]
  
  # destroy according icon
  
  $this(components) release $icon
  destroy $icon
  if {$icon == $this(icon,selected)} {
    set this(icon,selected) {}
  }
  
  # clear up data
  
  unset this(icon,$use(tree,$compname))
  unset use(tree,$compname)
  
}

#
# method "_comprenamed"
#
proc use_main::_comprenamed {w tree name1 name2 op} {
  upvar #0 $w this

  global use
  
  set icon $this(icon,$tree)
  set oldname [useWidgetInfo $icon -text]
  set newname [$tree compname]
  
  $icon configure -text $newname
  
  set use(tree,$newname) $tree
  unset use(tree,$oldname)
  
}

#
# method "_destroyed"
#
proc use_main::_destroyed {w } {
  upvar #0 $w this

  # destroy entity application 
  # (catch that as as own application could have been destroyed)
  # exit application
  
  global use
  catch {send $use(entities) "destroy ."}
  
}

#
# method "compclose"
#
proc use_main::compclose {w } {
  upvar #0 $w this

  if {$this(icon,selected) == {}} {
    return
  }
  
  global use
  
  set compname [useWidgetInfo $this(icon,selected) -text]
  $use(tree,$compname) close
  
}

#
# method "compcreate"
#
proc use_main::compcreate {w } {
  upvar #0 $w this

  # create a new widget tree
  
  set shell [use_unique .use_shell]
  use_ontop $shell use_wtree tree {Component Tree}
  
  # create an icon for it
  # (that time just a label with components name)
  
  global use
  
  set icon $this(components)$shell
  label $icon  -borderwidth 1  -relief raised
  
  $this(components) insert $icon
  
  bind $icon <Button-1>  "$w iconselect $icon"
  
  blt_drag&drop source $icon config  -packagecmd "$w package_use_component $icon"
  blt_drag&drop source $icon handler use_component dd_send_use_component
  
  # integrate new component, watch for it's state
  #  - store tree beloning to a components name in global "use" array
  #  - trace components name (_comprenamed)
  #  - destroy icon for when component tree is destroyed (_compdestroyed)
  
  set compname [$shell.tree compname]
  $icon configure -text $compname
  
  set use(tree,$compname) $shell.tree
  set this(icon,$shell.tree) $icon
  
  global $shell.tree
  trace variable $shell.tree(compname) w "$w _comprenamed $shell.tree"
  bind $shell <Destroy>  "+trace vdelete $shell.tree(compname) w \"$w _comprenamed $shell.tree\""
  
  bind $shell <Destroy>  "+after 1 \{$w _compdestroyed $icon\}"
}

#
# method "compopen"
#
proc use_main::compopen {w } {
  upvar #0 $w this

  if {$this(icon,selected) == {}} {
    return
  }
  
  global use
  
  set compname [useWidgetInfo $this(icon,selected) -text]
  $use(tree,$compname) open
  
}

#
# method "compquit"
#
proc use_main::compquit {w } {
  upvar #0 $w this

  if {$this(icon,selected) == {}} {
    return
  }
  
  global use
  
  set compname [useWidgetInfo $this(icon,selected) -text]
  destroy $use(tree,$compname)
  
}

#
# method "entcreate"
#
proc use_main::entcreate {w } {
  upvar #0 $w this

  #
  # create additional interpreter for testing out interface components
  #  - store its name in global variable use(entities)
  #  - overload it's "exit"
  #
  
  global use
  
  set use(entities) [use_mainwin -name [winfo name .]_entities]
  $w useinstall $use(entities)
  send $use(entities) {wm withdraw .}
  send $use(entities) "
    proc exit {} \{
      send [winfo name .] \
        {topmessage ._d_ USE {Entity application called \"exit\".}}
    \}
  "
}

#
# method "entreinit"
#
proc use_main::entreinit {w } {
  upvar #0 $w this

  global use
  
  catch {send $use(entities) "destroy ."}
  $w entcreate
  
  # install working directory in entities interpreter
  
  if {[string trim $use(wd)] == {}} {
    return
  }
  send $use(entities) "
    if \{\[lsearch \$auto_path $use(wd)\] < 0\} \{
      lappend auto_path $use(wd)
    \}
  "
}

#
# method "icondeselect"
#
proc use_main::icondeselect {w } {
  upvar #0 $w this

  if {$this(icon,selected) != {}} {
    useToggleColors $this(icon,selected)
  }
  set this(icon,selected) {}
  
}

#
# method "iconselect"
#
proc use_main::iconselect {w icon} {
  upvar #0 $w this

  if {$this(icon,selected) != {}} {
    useToggleColors $this(icon,selected)
  }
  useToggleColors $icon
  set this(icon,selected) $icon
  
}

#
# method "package_use_component"
#
proc use_main::package_use_component {w icon token} {
  upvar #0 $w this

  if {[winfo children $token] == ""} {
    label $token.dd_use_component
    pack $token.dd_use_component
  }
  set compname [useWidgetInfo $icon -text]
  $token.dd_use_component configure \
    -text $compname
  
  return $compname
  
}

#
# method "paladd"
#
proc use_main::paladd {w title widgets} {
  upvar #0 $w this

  set wpath [use_unique $w.palettes.pal]
  use_wpalette $wpath $title $widgets
  pack $wpath -fill both -expand true -padx 1m -pady 1m
}

#
# method "palcreate"
#
proc use_main::palcreate {w } {
  upvar #0 $w this

  toplevel $w.palettes
  wm title $w.palettes Palettes
  wm protocol $w.palettes WM_DELETE_WINDOW "wm withdraw $w.palettes"
}

#
# method "palraise"
#
proc use_main::palraise {w } {
  upvar #0 $w this

  wm deiconify $w.palettes
  blt_win raise $w.palettes
}

#
# method "trgconcat"
#
proc use_main::trgconcat {w } {
  upvar #0 $w this

  global use
  global use_library
  
  # some checks
  
  if {[string trim $use(target)] == {}} {
    set use(target) noname
  }
  set program $use(wd)\/[lindex $use(target) 0]
  use_bakfile $program
  
  set startup $use(wd)\/startup
  if {![file executable $startup]} {
    error "no startup script."
  }
  
  # modify cursor
  
  $w configure -cursor watch
  update idletasks
  $w configure -cursor {}
  
  set sid [open $startup r]
  
  # write file head
  # (first line with interpreter, top comments; init useBuiltInCode)
  
  set pid [open $program w]
  set nchars [gets $sid line]
  while {[string index $line 0] == "#" && $nchars >= 0} {
    puts $pid $line
    set nchars [gets $sid line]
  }
  puts $pid "\nset useBuiltInCode 1\n"
  
  # cat use_basic.tcl onto target script
  # write filehead, skip copyright, write rest
  
  set cid [open $use_library/use_basic.tcl r]
  set cline "#"
  while {[string index $cline 0] == "#"} {
    gets $cid cline
    puts $pid $cline
  }
  set cline "#"
  while {[string index $cline 0] == "#"} {
    gets $cid cline
  }
  puts $pid [read $cid nonewline]
  close $cid
  
  # cat all resing files onto target script
  # skip file heads
  
  set bakdir [pwd]
  cd $use(wd)
  if {[catch {glob *.tcl} components] == 0} {
    foreach comp $components {
      set cid [open $comp]
      set cline "#"
      while {[string index $cline 0] == "#"} {
        gets $cid cline
      }
      puts $pid $cline
      puts $pid [read $cid nonewline]
      close $cid
    }
  }
  cd $bakdir
  
  # append resting startup script
  
  while {$nchars >= 0} {
    puts $pid $line
    set nchars [gets $sid line]
  }
  close $pid
  
  close $sid
  
  # make result executable
  
  exec chmod +x $program
  
}

#
# method "trginstall"
#
proc use_main::trginstall {w interp} {
  upvar #0 $w this

  global use
  
  $w useinstall $interp
  set use(target) $interp
  if {[info exists use(wd)] && [string trim $use(wd)] != {}} {
    $w wdinstall $use(wd)
  }
}

#
# method "trgmkindex"
#
proc use_main::trgmkindex {w } {
  upvar #0 $w this

  global use
  
  $w configure -cursor watch
  update idletasks
  $w configure -cursor {}
  
  set bakdir [pwd]
  cd $use(wd)
  auto_mkindex [pwd] *.tcl startup
  cd $bakdir
}

#
# method "trgrestart"
#
proc use_main::trgrestart {w } {
  upvar #0 $w this

  global use
  
  # check existence of a startup script
  
  set startup $use(wd)\/startup
  if {![file executable $startup]} {
    error "no startup script to execute."
  }
  
  # exit current target
  
  catch {send $use(target) "after 1 exit"}
  
  # start a new target process
  
  if {[string trim $use(target)] == {}} {
    set use(target) noname
  }
  exec $startup -name [lindex $use(target) 0] &
  
}

#
# method "useinstall"
#
proc use_main::useinstall {w interp} {
  upvar #0 $w this

  # check existence of basic use procedures and send them if not exist
  
  if {[catch {send $interp "info procs useCreateComponent"} result] != 0
      || $result != {}} {
    return
  }
  foreach proc {useCreateComponent useCallMethod} {
    send $interp "
      proc $proc \{[info args $proc]\} \{[info body $proc]\}
    "
  }
}

#
# method "wdinstall"
#
proc use_main::wdinstall {w newdir} {
  upvar #0 $w this

  global use
  
  if {[string trim $newdir] == {}} {
    return
  }
  
  # append newdir to target's auto_path
  
  if {[catch {send $use(target) "winfo exists ."}] == 0} {
    send $use(target) "
      if \{\[lsearch \$auto_path $newdir\] < 0\} \{
        lappend auto_path $newdir
      \}
    "
  }
  
  send $use(entities) "
    if \{\[lsearch \$auto_path $newdir\] < 0\} \{
      lappend auto_path $newdir
    \}
  "
  
  # make newdir to current working directory
  
  set use(wd) $newdir
}

