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

# wormhole 1.4.2 (1999-Dec-10-Fri)
# Adam M. Costello <amc@cs.berkeley.edu>

# wormhole [ -port <port> ]
#
# Allows copy/paste of text across displays without trust.  We listen
# on the specified TCP port, or on a default port.  Incoming text
# (presumably sent by remote instances of this program) is shown in
# pop-up windows.
#
# To paste text to a remote host, enter the hostname, select the text,
# and press the Paste button.  The hostname may optionally be appended
# with a colon and a port number.  Instead of typing the hostname, you
# can select it from the Hosts menu, which accumulates the hosts that
# have been successfully pasted to.
#
# Warning:  Because Tcl is single-threaded, you will cause the program
# to deadlock if you try to paste to yourself.
#
# Check the GUI configuration section below for things you might want
# to customize via X resources.  (Edit your .Xresources file, not this
# script.)  There is also a wmGeometry resource (class WmGeometry) that
# gets passed to the wm geometry command if -geometry is not supplied on
# the command line.
#
# Note on the protocol:  The text is assumed to be an RFC 822 message.
# The only header field we currently pay attention to is the From field,
# which is not required to have the precise semantics required for
# email, but is shown in the popup.  The text being pasted goes in the
# body.


# Configuration:

set defaultport 50084


# GUI configuration.  The options with comments are the ones you most
# likely want to customize.  Plus maybe all the *.text options if
# English is not your first language.  And check the Tcl/Tk options(n)
# man page for more things, like fonts and colors.

foreach {pattern value comment} {

*main.feedback                1500         {milliseconds to display feedback}
*main.fullName                ""           {user's full name}
*main.paste.text              Paste        {}
*main.to.text                 to           {}
*main.target.width            12           {initial width of host entry}
*main.targets.text            Hosts        {}
*main.targets.menu.tearOff    0            {}
*main.targets.menu.transient  1            {}
*main.targets.menu.maxDepth   10           {max items in Hosts menu}
*main.targets.menu.initial    {}           {initial items in Hosts menu}
*main.targets.relief          raised       {}
*main*padX                    2            {}
*main*padY                    0            {}
*main*highlightThickness      0            {}
*Popup.fromlabel.text         From:        {}
*Popup.from.relief            flat         {}
*Popup.body.maxWidth          80           {max width of text widget in popup}
*Popup.body.maxHeight         24           {max height of text widget in popup}
*Popup.select.text            "Select all" {}
*Popup.dismiss.text           Dismiss      {}

} { option add $pattern $value startupFile }


# Main GUI:

frame .main
button .main.paste -command paste
label .main.to
entry .main.target -textvariable target
menubutton .main.targets -menu .main.targets.menu
menu .main.targets.menu

pack .main -side top -fill x
pack .main.paste .main.to -side left -fill y
pack .main.target -side left -expand 1 -fill x
pack .main.targets -side left -fill y

wm resizable . 1 0


# Handle pressing Paste:

proc paste {} {
  global target defaultport env targets

  if {[catch {selection get} selection]} {
    error "There was no selection to paste."
  }

  set t [string trim $target]

  if {! [regexp {^([^:]+)(:([0-9]+))?$} $t junk host junk port]} {
    focus .main.target
    error "You must enter a hostname or hostname:port"
  }

  if {$port == ""} { set port $defaultport }

  set channel [socket $host $port]
  set id $env(USER)@[info hostname]
  set fullname [string trim [option get .main fullName FullName]]

  if {$fullname == ""} {
    puts $channel "From: $id"
  } else {
    puts $channel "From: $fullname <$id>"
  }

  puts $channel ""
  puts -nonewline $channel $selection
  close $channel

  set feedback [option get .main feedback Feedback]

  if {$feedback > 0} {
    after $feedback [list set target $target]
    set target "[string length $selection] bytes"
  }

  set i [lsearch -exact $targets $t]
  if {$i >= 0} { set targets [lreplace $targets $i $i] }
  set targets [concat [list $t] $targets]
  updatetargets
  focus .
  return ""
}


# Update .main.targets.menu to be consistent with $targets, but first
# remove excess elements from targets:

proc updatetargets {} {
  global targets
  set maxtargets [option get .main.targets.menu maxDepth MaxDepth]
  set targets [lrange $targets 0 [expr {$maxtargets - 1}]]
  set menu .main.targets.menu
  $menu delete 0 end
  set i 0

  foreach t $targets {
    $menu add command -label $t -command [list choose $i $t]
    incr i
  }

  return ""
}


# Handle a menu selection:

proc choose {i t} {
  global target targets
  set target $t
  set targets [concat [list $t] [lreplace $targets $i $i]]
  updatetargets
  focus .
  return ""
}


# Parse command-line arguments:

proc parseargs {argv} {
  global port

  while {[llength $argv] > 0} {
    switch -glob -- [lindex $argv 0] {
        -port { if {[llength $argv] < 2} { error "-port needs an argument" }
                set port [lindex $argv 1]
                set argv [lrange $argv 2 end]
              }
           -* { error "unrecognized option [lindex $argv 0]" }
      default { error "unrecognized argument [lindex $argv 0]" }
    }
  }

  return ""
}


# getfield header fieldname
#
# Searches in $header (a valid mail header) for the field named
# $fieldname (which must not include the colon).  Everything after
# the colon up to (but not including) the final newline is returned
# (embedded newlines are left intact).  If the field is not found,
# the empty string is returned.

proc getfield {header fieldname} {
  if [regsub -nocase ^(.*\n)?$fieldname: $header "" fieldbody] {
    regsub "\n(\[^ \t]|\$).*" $fieldbody "" fieldbody
    return $fieldbody
  } else {
    return ""
  }
}


# Handle incoming text:

proc receive {channel client_addr client_port} {
  global popid
  set message [read -nonewline $channel]
  set endofheader [string first "\n\n" $message]
  set startofbody [expr {$endofheader + 2}]
  set header [string range $message 0 $endofheader]
  set body [string range $message $startofbody end]
  set from [string trim [getfield $header from]]
  regsub -all "\[ \n\t\f\r\v\]+" $from " " from
  set from [string trim $from]

  set height 0
  set width 1

  foreach line [split $body "\n"] {
    set length [string length $line]
    if {$length > $width} { set width $length }
    incr height
  }

  if {$height < 1} { set height 1 }

  # Popup GUI:

  incr popid
  set w .popup$popid
  toplevel $w -class Popup
  wm title $w "[tk appname] popup $popid"

  frame $w.toprow
  label $w.fromlabel
  entry $w.from -width 1
  text $w.body
  button $w.select -command "$w.body tag add sel 1.0 end"
  button $w.dismiss -command "destroy $w"

  pack $w.toprow -side top -fill x
  pack $w.fromlabel -in $w.toprow -side left
  pack $w.from -in $w.toprow -side left -expand 1 -fill x
  pack $w.body -side top -expand 1 -fill both
  pack $w.select -side left
  pack $w.dismiss -side right

  set maxwidth [option get $w.body maxWidth MaxWidth]
  set maxheight [option get $w.body maxHeight MaxHeight]
  if {$width > $maxwidth} { set width $maxwidth }
  if {$height > $maxheight} { set height $maxheight }
  $w.body configure -height $height -width $width

  $w.from insert end $from
  $w.from configure -state disabled
  $w.body insert end $body

  return ""
}


# Initialization:

set popid 0
set port $defaultport
parseargs $argv
socket -server receive $port

set targets [option get .main.targets.menu initial Initial]
updatetargets
if {[llength $targets] > 0} { set target [lindex $targets 0] }

if {! [info exists geometry]} {
  set geometry [option get . wmGeometry WmGeometry]

  if {$geometry != ""} {
    tkwait visibility .
    wm geometry . $geometry
  }
}