#!/bin/sh
# This grossness allows wish to be anywhere in PATH: \
exec wish "$0" ${1+"$@"}

# butler 0.5.1 (2002-May-29-Wed)
# by Adam M. Costello http://www.cs.berkeley.edu/~amc/
# with contributions from Seth Golub http://www.aigeek.com/

# butler [ -c <configfile> ]
#
# There is a resource, butler.wmGeometry (class WmGeometry), whose value
# is passed to wm geometry.  It defaults to +0+0.

# Config file format:
#
# The config file is a Tcl list of items, one for each button.  Each
# item must be a list of two or three or four elements: a button name,
# a command, an optional default value, and an optional preprocessing
# intruction.
#
# Each command must be a list of arguments (the first of which is the
# command pathname), or the empty list if no command is needed (perhaps
# the preprocessing instruction accomplishes everything).  Note that the
# commands are NOT interpreted by your shell.
#
# Each argument of each non-empty command will have "**" globally
# replaced by $selection, which is the current selection.  If the
# current selection is empty, and there is a third element (default
# value), then $selection will be that default value instead.
#
# If there is a fourth element (preprocessing instruction), then the
# instruction is eval'ed just before the substitution takes place.  The
# instruction can refer to $selection and $env(), and should restrict
# its side effects to altering those variables and possibly exporting
# a selection.  The utility procedures killwhite, extractURL, and
# export_selection (see below) are available for use in preprocessing
# instructions.


# Configuration:

option add *main.Button.Pad 0 startupFile
option add *main.Button.highlightThickness 0 startupFile


# killwhite removes all whitespace from $selection.

proc killwhite {} {
  upvar selection selection
  regsub -all "\[ \n\t\f\r\v\]" $selection "" selection
}


# export_selection takes ownership of the selection and sets it to the
# current value of $selection, or to its argument if there is one.

proc export_selection {args} {
  if {[llength $args] > 0} {
    set selection [lindex $args 0]
  } else {
    upvar selection selection
  }

  .hidden delete 0 end
  .hidden insert 0 $selection
  .hidden selection range 0 end
}


# extractURL returns a URL extracted (by heuristics) from $selection.

proc extractURL {} {
  upvar selection selection

  # URL schemes defined in RFC 1738:
  set schemes ftp|http|gopher|mailto|news|nntp|telnet|wais|file|prospero

  # Other schemes seen by the author:
  set schemes $schemes|tn3270|https

  # Characters plausible inside a URL:
  set urlcharguts \ "'<>
  set urlchar \[^$urlcharguts\]
  set nonurlchar \[$urlcharguts\]

  # Typical first and last characters of a URL:
  set firstguts A-Za-z
  set first \[$firstguts\]
  set nonfirst \[^$firstguts\]
  set last \[A-Za-z0-9_/\]

  # Change all carriage returns to newlines, and all other white
  # characters to spaces, to make later regular expressions simpler.
  regsub -all \r $selection "\n" selection
  regsub -all \[\t\f\v\] $selection " " selection

  # Repair URLs divided across lines:
  regsub -all " *\n *" $selection {} selection

  # Look for <URL> or "URL" or 'URL' or (URL), otherwise use various
  # heuristics.

  expr {
    [regsub ^.*<(($schemes):$urlchar+)>.*\$ $selection \\1 selection] ||
    [regsub ^.*"(($schemes):$urlchar+)".*\$ $selection \\1 selection] ||
    [regsub ^.*'(($schemes):$urlchar+)'.*\$ $selection \\1 selection] ||
    [regsub ^.*\\((($schemes):$urlchar+)\\).*\$ $selection \\1 selection] ||
    [regsub ^.*(($schemes):$urlchar*$last).*\$ $selection \\1 selection] ||
    [regsub ^((.*\[^A-Za-z0-9\])?)((www|ftp)\\.$urlchar+$last).*\$ \
            $selection \\3 selection] ||
    [regsub ^(.*$nonurlchar$nonfirst*)?($first$urlchar*\\.$urlchar+$last).*\$ \
            $selection \\2 selection]
  }

  # Escape commas and right parentheses, which confuse Netscape's remote
  # command syntax:
  regsub -all , $selection %2C selection
  regsub -all \\) $selection %29 selection
}


proc fail {msg} {
  puts stderr $msg
  exit 1
}


# Where is the config file kept?
#   First check command line for -c <filename>
#   Next try $BUTLER environment variable
#   Lastly, default to ~/.butler

proc read_config {} {
  global argc argv argv0 env

  if {$argc == 2 && "-c" == [lindex $argv 0]} {
    set config_file [lindex $argv 1]
  } elseif {$argc != 0} {
    fail "usage:\n$argv0 \[ -c <configfile> \]"
  } elseif {[info exists env(BUTLER)]} { 
    set config_file $env(BUTLER)
  } else {
    set config_file $env(HOME)/.butler
  }
    
  if {! [file readable $config_file]} {
    fail "File not found or not readable: $config_file"
  }

  set fileId [open $config_file]
  set config [read $fileId]
  close $fileId
  return $config
}


proc grab_selection {} {
  if {[catch {selection get STRING} text]} { return "" }
  return $text
}


# Protect characters in a subspec from interpretation by regsub.

proc litsub {subspec} {
  regsub -all {&|\\} $subspec {\\&} subspec
  return $subspec
}


proc do {cmd def prep} {
  set selection [grab_selection]

  if {$selection == ""} {
    set selection $def
  }

  global env
  eval $prep
  set newcmd {}

  foreach arg $cmd {
    regsub -all {\*\*} $arg [litsub $selection] newarg
    lappend newcmd $newarg
  }

  if {[llength $newcmd] > 0} { eval exec $newcmd & }
}


# Main section:

frame .main
entry .hidden
pack .main -fill both -expand 1
set buttonnum 0

foreach item [read_config] {
  incr buttonnum
  set name [lindex $item 0]
  set cmd  [lindex $item 1]
  set def  [lindex $item 2]

  if {[llength $item] < 4} {
    set prep {}
  } else {
    set prep [lindex $item 3]
  }

  button .main.button$buttonnum -text $name -command [list do $cmd $def $prep]
  pack   .main.button$buttonnum -fill both -expand 1
}

# If -geometry was passed to wish, let it override wmGeometry, otherwise
# use wmGeometry:

if {! [info exists geometry]} {
  set geometry [option get . wmGeometry WmGeometry]
  if {$geometry == ""} { set geometry +0+0 }
  tkwait visibility .
  wm geometry . $geometry
}