#! /bin/sh
#
# This file implements a "make" program.  Unlike the usual make, this
# version of "make" reads Makefile.tcl instead of Makefile, and interprets
# Makefile.tcl as a TCL script.  Two new TCL commands are defined which
# can be used in Makefile.tcl to construct the dependency tree:
#
#    Make               This command tells how to construct an object from
#                       its component parts.
#
#    Shell              The argument to this command is a shell command that
#                       is executed to build some component of the system.
#
# After executing all of Makefile.tcl, this program walks the dependency 
# tree created by Makefile.tcl and executes all commands necessary to 
# build the target(s) specified on the command line.  If this program 
# is invoked with no arguments, then the first object named in any
# "Make" command in Makefile.tcl is built.
#
# The Makefile.tcl file can contain any TCL code the user desires.  However,
# this file defines several private variables and procedures that the
# Makefile.tcl file should avoid using.  All private variables and
# procedures begin with the prefix "make_".  "Make" and "Shell" are the
# only publicly accessible procedures defined.
#

# The preceding comment was copied intact from the "tclmake" program.
# Tclmake, like regular make, is a command-line oriented tool.  This file,
# however, implements a GUI builder program.  The makefile looks the same.
# (i.e. tclmake and tkmake can use the same makefiles)  But tkmake gives
# a nice GUI interface.

# Check to make sure we have at a working "wish"
wish <<\END_OF_SCRIPT || \
(echo 'You must have the program "wish" installed on your system in order
to use tkmake.' >&2; exit 1)
exit 0
END_OF_SCRIPT

# No go ahead and run the large TCL script that actually implements the
# new make.
exec wish <<\END_OF_TCL_SCRIPT
option add *highlightThickness 0
option add *Entry.font fixed
wm title . TkMake
wm iconname . TkMake

#
# Implement the "Make" command.
#
#    Make TARGET from DEPENDENCY
#    Make TARGET using CODE
#    Make TARGET from DEPENDENCY using CODE
#
# All this command does is stuff information into global variables
# for later use by "make_build".  Basically, it does this:
#
#    set make_from(TARGET) DEPENDENCY
#    set make_using(TARGET) CODE
#
# Note that both TARGET and DEPENDENCY can be lists.
#
proc Make {targets args} {
  global make_from make_using

  # Add the target(s) to the "make" menu, if the are not already there.
  foreach t $targets {
    if {![info exists make_from($t)] && ![info exists make_using($t)]} {
      .menubar.make.m add command -label $t -command "make_Build $t"
    }
  }

  # Process the "from" section of the command 
  if \"[lindex $args 0]\"==\"from\" {
    set list [lindex $args 1]
    foreach t $targets {
      if ![info exists make_from($t)] {
        set make_from($t) $list
      } else {
        set make_from($t) [concat $make_from($t) $list]
      }
    }
    set args [lrange $args 2 end]
  }

  # Process the "using" section
  if \"[lindex $args 0]\"==\"using\" {
    set list [lindex $args 1]
    foreach t $targets {
      set make_using($t) $list
    }
    set args [lrange $args 2 end]
  } else {
    foreach t $targets {
      if {![info exists make_using($t)]} {
        set make_using($t) {}
      }
    }
  }

  # Report a syntax error
  if [llength $args]>0 {
    make_error "Bad arguments to \"Make\": $args"
  }
}

# Report an error
#
proc make_error {msg} {
  make_Output "$msg\n" 1
  global make_quiet
  if {!$make_quiet} {
    make_Output "** End make in [pwd] **\n" 1
  }
  global make_error_count
  incr make_error_count
}

# Implement the "Shell" command.  This command works like "exec" except:
#
#     * Variables in the argument to Shell are expanded as if they were
#       global variables before the command is executed.
#
#     * The command is executed by a real shell, not by execve().
#
#     * If the Shell command occurs within the "using" clause of a "Make"
#       command, then the variable $source in the argument is expanded
#       to a list of every DEPENDENCY.  Similarly, $target is expanded
#       to the current TARGET for the Make command.
#
#     * The command is printed on standard output before it is executed.
#       The output of the command also goes to standard output during
#       execution.
#
proc Shell {cmd} {
  global make_quiet make_error_count
  if {$make_error_count} return
  set cmd [uplevel #0 set make_bogus \"$cmd\"]
  if !$make_quiet {make_Output "[string trim $cmd]\n" 0}
  set exec_cmd [format {exec sh -c {(%s) 2>&1}} $cmd]
  update
  set retcode [catch $exec_cmd output]
  if {[string length $output]>0} {
    make_Output "[string trim $output]\n" 0
  }
  if {$retcode!=0} {
    global make_error_count
    incr make_error_count
    make_Output "Command Failed!\n" 1
  }
}

# The following command builds the object named in its argument.  It
# returns success or failure, as appropriate.  This function may call
# itself recursively to build other objects that depend on the object
# named in the argument.
#
# This routine is for internal use only.
#
proc make_build {make_t} {
  global make_from make_using make_busy make_verbose make_done make_error_count

  # early out if the target has already been built.
  if [info exists make_done($make_t)] return

  # Block infinite recursion
  if [info exists make_busy($make_t)] {
    make_error "$make_t depends upon itself"
    return
  }
  set make_busy($make_t) 1

  if $make_verbose {make_Output "begin building $make_t\n" 1}

  # The "make_d" variable holds a list of dependencies.
  if [info exists make_from($make_t)] {
    set make_d $make_from($make_t)
  } else {
    set make_d {}
  }

  set make_build_flag 0;         # This flag is 1 if a rebuild is necessary

  # Check to see if any dependencies need to be built first
  foreach d $make_d {
    make_build $d
    if {$make_error_count} return
  }

  # Check to see if the target is older than any dependency
  if ![file exists $make_t] {
    set make_build_flag 1
  } else {
    set t_time [file mtime $make_t]
    foreach d $make_d {
      if {[file exists $d] && $t_time<[file mtime $d]} {
        set make_build_flag 1
        break
      }
    }
  }

  # Do the build, if necessary
  if {$make_build_flag} {
    if ![info exists make_using($make_t)] {
      make_error "Don't know how to make $make_t"
      return
    } else {
      global target source make_quiet
      set target $make_t
      set source {}
      foreach make_x $make_d {lappend source $make_x}
      if {!$make_quiet} {make_Output "** $make_t **\n" 1}
      catch "exec rm -f {$make_t}"
      if [catch {uplevel #0 $make_using($make_t)} msg] {
        catch "exec rm -f {$make_t}"
        make_error "$msg\nMake failed for target $make_t"
        return
      }
    }
  }

  # clean up
  if $make_verbose {make_Output "finished building $make_t\n" 1}
  unset make_busy($make_t)
  set make_done($make_t) 1
}

# Set the default values for verbosity flags
set make_verbose 0
set make_quiet 0
set make_verbosity normal
set make_error_count 0

# A function to tell about this program
#
proc make_AboutMessage {} {
  catch {destroy .about}
  toplevel .about
  wm title .about "About TkMake"
  wm iconname .about "AboutTkMake"
  label .about.title -text {TkMake}\
    -font -adobe-times-bold-i-normal--24-240-75-75-p-128-iso8859-1
  pack .about.title -side top -pady 15
  message .about.subtitle -width 10c -justify center \
    -font -adobe-times-bold-i-normal-*-14-140-75-75-p-77-iso8859-1 \
    -text "A project builder utility written\nin pure Tcl/Tk"
  pack .about.subtitle -side top -pady 10 -padx 15
  message .about.msg -width 10c -text "
By D. Richard Hipp
Hipp, Wyrick & Company, Inc.
6200 Maple Cove Lane
Charlotte, NC 28269
704-948-4565
drh@vnet.net" \
    -font -adobe-times-medium-r-normal-*-12-120-75-75-p-64-iso8859-1
  pack .about.msg -padx 15 -anchor w
  button .about.dismiss -text {Dismiss} -command {destroy .about}
  pack .about.dismiss -pady 8
  wm withdraw .about
  update idletasks
  set x [expr [winfo rootx .] + ([winfo width .]-[winfo reqwidth .about])/2]
  set y [expr [winfo rooty .] + ([winfo height .]-[winfo reqheight .about])/2]
  wm geometry .about +$x+$y
  wm deiconify .about
}


##### Construct the menu bar
#
frame .menubar -bd 2 -relief raised
pack .menubar -side top -fill x

menubutton .menubar.file -text File -menu .menubar.file.m -pady 0
pack .menubar.file -side left -padx 10
menu .menubar.file.m
  .menubar.file.m add command -label {Reread Makefile} \
     -command make_ReinitMakefile
  .menubar.file.m add command -label {Shell} -command make_ShellOut
  .menubar.file.m add separator
  .menubar.file.m add command -label {Quit} -command {destroy .}

menubutton .menubar.edit -text Edit -menu .menubar.edit.m -pady 0
pack .menubar.edit -side left -padx 10
menu .menubar.edit.m
  .menubar.edit.m add command -label {Copy} \
     -command make_EditCopy

menubutton .menubar.options -text Options -menu .menubar.options.m -pady 0
pack .menubar.options -side left -padx 10
menu .menubar.options.m
  .menubar.options.m add command -label {Edit Configuration...} \
     -command make_EditConfiguration
  .menubar.options.m add cascade -label {Font Size} \
    -menu .menubar.options.m.fontsize
  menu .menubar.options.m.fontsize
  foreach i {Tiny Small Short Normal Large {Very Large} Huge} {
    .menubar.options.m.fontsize add radiobutton -label $i \
       -value $i -variable make_Font -command "make_ChangeFont \"$i\""
  }
  .menubar.options.m add cascade -label Verbosity -menu .menubar.options.m.verb
  menu .menubar.options.m.verb
  .menubar.options.m.verb add radiobutton -label Verbose \
     -variable make_verbosity -value verbose
  .menubar.options.m.verb add radiobutton -label Normal \
     -variable make_verbosity -value normal
  .menubar.options.m.verb add radiobutton -label Quiet \
     -variable make_verbosity -value quiet

menubutton .menubar.make -text Make -menu .menubar.make.m -pady 0
pack .menubar.make -side left -padx 10
menu .menubar.make.m -tearoff 0

menubutton .menubar.help -text Help -menu .menubar.help.menu -pady 0
pack .menubar.help -side left -padx 5
menu .menubar.help.menu
  .menubar.help.menu add command -label {About This Program} \
     -command make_AboutMessage
  .menubar.help.menu add command -label {Instructions} \
     -command make_ShowInstructions

######
# These are all the valid fonts.
#
set make_F(Tiny) -schumacher-clean-medium-r-normal-*-6-60-75-75-c-40-iso8859-1
set make_F(Small) -schumacher-clean-medium-r-normal-*-8-80-75-75-c-50-iso8859-1
set make_F(Short) -schumacher-clean-medium-r-normal-*-10-100-75-75-c-60-iso8859-1
set make_F(Normal) -misc-fixed-medium-r-semicondensed-*-13-120-75-75-c-60-iso8859-1
set make_F(Large) -misc-fixed-medium-r-normal-*-14-130-75-75-c-70-iso8859-1
set make_F(Very\ Large) -misc-fixed-medium-r-normal-*-15-140-75-75-c-90-iso8859-1
set make_F(Huge) -misc-fixed-medium-r-normal-*-20-200-75-75-c-100-iso8859-1
set make_Font Normal

# Change the font of the text widget
#
proc make_ChangeFont {newFont} {
  global make_F make_Font
  .t config -font $make_F($newFont)
  set make_Font $newFont
}

# A routine for dispensing the selection.  The selection is always owned
# by the window ".".  Its value is stored in the variable "Selection"
#
set make_Selection {}
selection handle . make_RetrieveSelection
proc make_RetrieveSelection {offset max} {
  global make_Selection
  return [string range $make_Selection $offset [expr {$offset+$max}]]
}

# This routine is called whenever "." owns the selection but another
# window claims ownership.
#
proc make_LoseSelection {} {
  global make_Selection
  set make_Selection {}
}

# Copy the text selected in the text widget into the Selection variable,
# then claim ownership of the selection.
#
proc make_EditCopy {} {
  global make_Selection
  catch {
    set make_Selection [.t get sel.first sel.last]
    selection own . make_LoseSelection
  }
}

# Attempt to launch a shell in the working directory.
# We try to launch tkterm first, but if that fails we
# try xterm as a backup.
#
proc make_ShellOut {} {
  if {[catch {exec tkterm &}]} {
    catch {exec xterm &}
  }
}

##### Construct the text widget with its scrollbar
#
text .t -bd 1 -relief raised -yscrollcommand {.sb set} \
  -height 24 -width 80 -exportselection 0 \
  -wrap char -padx 2 -pady 2 \
  -font $make_F($make_Font) -highlightthickness 0
scrollbar .sb -command {.t yview} -orient vertical \
  -highlightthickness 0 -bd 1 -relief raised
.t tag config bold -foreground navyblue
pack .t -side left -fill both -expand 1
pack .sb -side left -fill y

# Build the given target.  This is the top-level function.   It clears
# the canvas then calls the make_build routine to do the work.
#
proc make_Build {target} {
  global make_verbosity make_quiet make_verbose make_busy make_done
  global make_error_count
  .t delete 1.0 end
  if {"$make_verbosity"=="quiet"} {
    set make_verbose 0
    set make_quiet 1
  } elseif {"$make_verbosity"=="normal"} {
    set make_verbose 0
    set make_quiet 0
  } else {
    set make_verbose 1
    set make_quiet 0
  }
  catch {unset make_busy}
  catch {unset make_done}
  set make_error_count 0
  update
  make_ReadMakefile
  make_build $target
  if {$make_error_count} {
    make_Output "**** Errors in Make Attempt ****\n" 1
  } else {
    make_Output "**** Build Completed With No Errors ****\n" 1
  }
}

# Read the TkMake configuration file.
#
proc make_ReadConfiguration {} {
  catch {uplevel #0 {source Makefile.config}}
}

# Write the TkMake configuration file.
#
proc make_WriteConfiguration {} {
  global Parameter
  if {[catch {set f [open Makefile.config w]}]} {
    return
  }
  foreach i [array names Parameter] {
    global $i
    if {![info exists $i]} {set $i {}}
    puts $f "set $i [list [set $i]]"
  }
  close $f
}

# Edit the configuration variables
#
proc make_EditConfiguration {} {
  global Parameter make_ConfigWidget
  catch {destroy .c}
  toplevel .c
  wm title .c {TkMake Configuration Editor}
  wm iconname .c {TkMake}
  
  frame .c.b -bd 1 -relief raised
  pack .c.b -side bottom -fill x -expand 1
  button .c.b.quit -text Cancel -command {destroy .c}
  button .c.b.ok -text OK -command {make_UnloadConfiguration; destroy .c}
  button .c.b.revert -text Revert -command {make_LoadConfiguration}
  button .c.b.save -text Save -command {make_UnloadConfiguration}
  pack .c.b.quit .c.b.revert .c.b.save .c.b.ok -side left -pady 5 -padx 10

  set j 0
  catch {unset make_ConfigWidget}
  foreach i [lsort [array names Parameter]] {
    incr j
    set f [frame .c.x$j -bd 1 -relief raised]
    pack $f -side top -fill x -expand 1
    message $f.m -width 15c -text $Parameter($i) -anchor w -justify left
    pack $f.m -side top -fill x -expand 1
    frame $f.space -height 5
    pack $f.space -side bottom
    frame $f.f
    pack $f.f -side bottom -fill x -expand 1 -padx 5
    label $f.f.l -text $i=
    set make_ConfigWidget($i) [entry $f.f.e -bd 1 -relief sunken]
    pack $f.f.l -side left
    pack $f.f.e -side left -fill x -expand 1
  }

  make_LoadConfiguration
}

# Load the configuration information into the configuration editor
#
proc make_LoadConfiguration {} {
  if {![winfo exists .c]} return
  global make_ConfigWidget
  foreach i [array names make_ConfigWidget] {
    $make_ConfigWidget($i) delete 0 end
    global $i
    if {[info exists $i]} {
      $make_ConfigWidget($i) insert end [set $i]
    }
  }
}

# Unload the configuration information into the configuration editor
#
proc make_UnloadConfiguration {} {
  if {![winfo exists .c]} return
  global make_ConfigWidget
  foreach i [array names make_ConfigWidget] {
    global $i
    if {[info exists $i]} {
      set $i [$make_ConfigWidget($i) get]
    }
  }
  make_WriteConfiguration
}

# Read the Makefile
#
proc make_ReadMakefile {} {
  global errorInfo make_error_count
  if {[catch {uplevel #0 {source Makefile.tcl}} errmsg]} {
    make_Output [string trim $errorInfo]\n 0
    make_Output "Can't read Makefile.tcl!\n" 1
    incr make_error_count
  }
  make_ReadConfiguration
}

# Read the Makefile and also display the Instructions if it
# is defined.
#
proc make_ReinitMakefile {} {
  global make_error_count
  set make_error_count 0
  .t delete 1.0 end
  make_ReadMakefile
  if {$make_error_count==0} make_ShowInstructions
}

# Show the instructions
#
proc make_ShowInstructions {} {
  global Instructions
  .t delete 1.0 end
  if {[info exists Instructions]} {
    make_Output $Instructions 0
  } else {
    make_Output \
{No instructions are specified in this makefile.

To specify instructions in a makefile, set the variable ``Instructions''
to the text of the instructions.} 0
  }
}

# Write text to the end of the text widget, then adjust the scroll
# position so that the text is visible.
#
proc make_Output {text highlight} {
  if {$highlight} {
    .t insert end $text bold
  } else {
    .t insert end $text
  }
  .t yview {end -1 lines}
}

# Read the makefile for the first time. 
#
make_ReinitMakefile

END_OF_TCL_SCRIPT
