#! /bin/sh
# \
PATH=/opt/tcl849/bin:$PATH exec tclsh $0 -- ${1+"$@"}

#############################################################################
proc main {} {
    global argv prog

    # Get rid of leading "--", if present.
    if {[string compare [lindex $argv 0] "--"] == 0} { nextarg }

    # Initialize the script configuration
    initConfig

    # Initialize the diff-output interpreter.
    diffInterpInit

    if {[catch {doArguments} result]} {
	puts "$prog: $result"
	puts "\tUse the -h option for usage information."
	exit 1
    }

    # Adjust our configuration to accord with the user-entered options.
    fixupOptions

    # Sort out CVS, RCS, and plain filenames, and return the names
    # (after reading CVS or RCS files into temp files).
    foreach {file1 file2} [getFiles $argv] {break}

    if {[string compare $file1 "-"] == 0 && [string compare $file2 "-"] == 0 } {
	die 1 "Can't use '-' for both file1 and file2."
    }

    if {[catch { diff_any2files $file1 $file2 } result]} {
	# We expect to get here most often with "broken pipe", but we don't
	# want to print "error writing 'file1': broken pipe", which is what we
	# see.  So if there is a POSIX/EPIPE error, then put just the terse message;
	# else put the result string.
	if {[lrange $::errorCode 0 1] eq [list POSIX EPIPE]} {
	    puts stderr [lindex $::errorCode 2]
	} else {
	    puts stderr $result
	}
    }
}

#############################################################################
proc synopsis {} {
    global prog Option
    catch {puts \
"Usage:
	$prog \[Options] file1 file2

or:	$prog \[Options] -Xrev file
or:	$prog \[Options] -Xrev1 -Xrev2 file
where X is C (CVS revision), D (CVS date), or R (RCS revision).
Note: in this case, `file' may not be a directory.
Special cases: -CC and -RR mean current cvs and rcs revision, respectively.

$prog does a side-by-side differencing of the two files file1 and file2.
If one of the filenames is \"-\", it means stdin.   Note: by default,
tabs are expanded before comparing and printing; see the -tab option.

If file1 and file2 are directories, $prog is recursive applied to all
files therein." }
}

#############################################################################
proc usage {} {
    global prog Option

    synopsis
    catch {puts "
Options:
  -Annn,-Bnnn,-b,-i,-s,-t,-w ...are flags passed to \"diff\".
  -help		...means to print this message, then exit.

  -all		...show all lines, not just differences.
  -eqlhs	...same as -all, but only print the LHS of equal lines.
  -number	...number the lines.
  -indent	...pass files through `indent' before comparing.
  -tab		...do _not_ expand tabs before diff'ing and printing.

  -date		...label each file with its date, and flag the newer.
  -ignorebadlinks ...when comparing directories, ignore any symlinks
		  pointing to non-existent files.
  -nofollow	...do not follow symlinks, but compare the pointed-at names.
  -pattern xxx	...only compare files matching glob pattern xxx; to match
  		any of several patterns, use multiple -pattern options.
		(All subdirectories are entered, regardless of name.)

  -lhs		...print only the left-hand side of the default output.
  -rhs		...print only the right-hand side of the default output.
  -truncate	...don't truncate text to align change bars or to fit screen.
  -separate	...don't separate each differing region with blank lines.
  -changebar	...shorthand for -rhs -truncate.
  -cb		...shorthand for -changebar.

  -highlight	...disable highlighting of lines with differences; default is
		   to highlight if printing all lines, not if diffs only.
  +highlight	...enable highlighting of lines with differences.
  -space n	...Replace each run of n spaces with a single space;
		   implies -b; n is limited to 2 .. 20.
  -len mmm,nnn	...size of left,right-side panels\
				(this tty's default: $Option(LW),$Option(RW))
  -fg color	...for terminals with ANSI color.  \"color\" is the color code
		    used for marking differences.  Valid names are
		    red, green, yellow, blue, magenta, cyan, white.
		    These names are mapped into ANSI color codes 0..7,
		    respectively; if your terminal doesn't use this mapping,
		    the displayed colors won't match the names.  If you know
		    the color code you desire, you can use 0..7 directly.
  -bg color	like -fg, but the background for differences.
  -black,-red,-green,-yellow,-blue,-magenta,-cyan,-white
		...shorthand for -fg <color>.
  -debug	...print debug info.
  -save		...don't delete any intermediate files that were created.
  -S fname	...Starts a directory diff in the middle,
			beginning with file fname.

"}
}

#############################################################################
#
# Print $msg; if $args contains "usage", print usage; if $args contains
# "reminder", print reminder of how to get help; then exit with $status.
# As a side effect, if "reminder" is in use, the message is surrounded
# with "*** ... ***"
#
proc die {status msg args} {
    global prog Option file1 file2 IsTemp

    if {$IsTemp(1) && !$Option(SaveIntermediate)} { catch {file delete $file1} }
    if {$IsTemp(2) && !$Option(SaveIntermediate)} { catch {file delete $file2} }

    set reminder [expr [lsearch $args "reminder"] >= 0]
    if {"$msg" != ""} {
	if $reminder {
	    puts stderr "$prog: *** $msg ***\n"
	} else {
	    puts stderr "$prog: $msg"
	}
    }
    if {[lsearch $args "reminder"] >= 0} {
	synopsis
	puts ""
	puts "Use  $prog -h  for details."
    }
    if {[lsearch $args "usage"] >= 0} {
	usage
    }
    exit $status
}

#############################################################################
proc file2handle {name} {
    if {"$name" == "-"} {
	set handle stdin
    } elseif {[catch {open $name r} handle]} {
	return -code error $handle
    }
    return $handle
}

#############################################################################
proc tmpfile {base} {
    set i 0
    set dir [file dirname $base]
    set tail [file tail $base]
    while {[file exists [set f "$dir/tmp_$tail.$i"]]} { incr i }
    return $f
}

#############################################################################
#
# Returns a two-elt list with the rows and columns of the screen.
#
proc screensize {} {
    # Use stty -a

    # If stty returns info about stdin, this will work:
    if {[catch {exec stty -a} tty]} {
	# Nope, didn't work.  Maybe this stty returns info about stdout,
	# printing to stderr:
	if {[catch {exec stty -a >/dev/tty} tty]} {
	    if {[string compare $::errorCode NONE] == 0} {
		; # Not an error; output came on stderr so catch returns !0
	    } else {
		# Errors both ways; maybe stdin and stdout aren't attached to
		# tty.  Give default values.
		return [list 24 80]
	    }
	}
    }

    # If here, info must be in tty.  Format is nnn rows[.] or rows [=] nnn.
    if {[regexp -- {[^a-zA-Z0-9]rows[ \t]*=?[ \t]([0-9]+)} $tty junk rows]} {
	; # OK
    } elseif {[regexp -- "(\[0-9]+)\[ \t]*rows\[^a-zA-Z0-9]" $tty junk rows]} {
	; # OK
    } else {
	set rows 24
    }
    if {[regexp -- {[^a-zA-Z0-9]columns[ \t]*=?[ \t]([0-9]+)} $tty junk cols]} {
	; # OK
    } elseif {[regexp -- \
		    "(\[0-9]+)\[ \t]*columns\[^a-zA-Z0-9]" $tty junk cols]} {
	; # OK
    } else {
	set cols 80
    }
    return [list $rows $cols]

}

#############################################################################
#
# basiccmd is like "cvs xxx -r rev -p"
# basicname is a filename for which revision rev is desired.
# rev is a revision number, used to create a meaningful tmpfilename.
# We paste the two pieces together, start the command, and copy
# the output to a tmpfile.  We return the name of the tmpfile.
#
proc cmd2tmpfile {basiccmd basicname rev} {
    global Option

    set file [tmpfile $basicname-$rev]
    set cmd [concat $basiccmd $basicname]
    if $::debug {
	puts "DEBUG cmd2tmpfile(): cmd=$cmd"
    }
    if {[catch {eval exec $cmd > $file} result]} {
	if {[string compare $::errorCode NONE] == 0} {
	    # There was output to stderr; this is expected from commands
	    # like "co -p ...".  Ignore it.
	} else {
	    catch {file delete $file} x
	    die 1 "Can't execute `$cmd':\n$result"
	}
    }

    return $file
}

#############################################################################
# 
# Initialize the runtime configuration
#
proc initConfig {} {
    global prog debug IsTemp Option ColorName ColorCode EQFormat Format Tput
    global argv0 DiffingDirs

    catch {unset ::env(LS_COLORS)}

    set debug 0
    set prog [lindex [split $argv0 /] end]

    set IsTemp(1) 0
    set IsTemp(2) 0

    set DiffingDirs 0

    array set Option {
	DiffFlags	{}
	StartFile	""
	versioned	""
	date		0
	nofollow	0
	ignorebadlinks	0
	pattern		""
	LHS		0
	RHS		0
	UseNumber	0
	NoExpandTab	0
	SubstSpaces	0
	NoTruncate	0
	NoBlankLine	0
	ChangeBar	0
	UseIndent	0
	IndentFlags	"-st -bap -ncdb -eei -nfc1 -nip -i2"
	ShowEqual	0
	EqLHS		0
	SaveIntermediate	0
	HighLight	-1
    }
    array set ColorName { bg "-"	fg "-" }

    # These may not be the right mappings from color code (0..7) to color,
    # but they are the common default setting.
    array set ColorCode {
	black		0
	red		1
	green		2
	yellow		3
	blue		4
	magenta		5
	cyan		6
	white		7
	"0"		0
	"1"		1
	"2"		2
	"3"		3
	"4"		4
	"5"		5
	"6"		6
	"7"		7
	"-"		-
    }

    foreach {::Screen(rows) ::Screen(columns)} [screensize] { }

    # Left, right column width (if not numbering).
    set Option(LW) [expr $::Screen(columns)/2  - 3]
    set Option(RW) $Option(LW)
}

#############################################################################
#
# Return the first element from $argv; decrement argc and left-shift argv
# before returning.
#
proc nextarg {} {
    global argc argv
    set arg [lindex $argv 0]
    set argv [lrange $argv 1 end]
    incr argc -1
    return $arg
}

#############################################################################
#
#	matchopt opt fullname [vname [value]]
#
# Matches an option $opt (usually, the string entered by the user
# on the command line) with the fullname that it's supposed to match.
# For example,
#       matchOpt -a -absorb
# checks that the first argument, "-a", equals or is an initial substring of
# the second argument, "-absorb".  Special case: if the second option begins
# with "+/-", then the first arg can begin with "+" or "-".  For example,
#	fullname "+/-absorb"
# matches options -a, +a, -abs, +absorb, etc.
#
# There are two optional trailing args:
#	[vname [value]]
# where vname is the name of a variable within the scope of the caller, and
# value is any string.
#
# If the option matches, then
#	o if no trailing args are given, matchOpt returns 1;
#	o otherwise, if both args are given, vname is set to value;
#	o otherwise, if fullname begins +/-, vname is set to 1 or 0 according
#		as $opt begins "+" or "-";
#	o otherwise, vname is set to 1.
#
# If an option doesn't match, an "Unknown option" error is generated.
# If there are too many args, a "wrong # args" error is generated.
#
proc matchOpt {opt fullname args} {
    switch -glob -- $fullname {
	+/-* {
	    set name [string range $fullname 3 end] ; # fullname w/o "+/-"
	    if {[string match $opt* -$name]} {
		switch [llength $args] {
		0 { return 1 }
		1 { uplevel set [lindex $args 0] 0 }
		2 { uplevel set [lindex $args 0] [lindex $args 1] }
		default { error "wrong # args: should be\
			    \"matchOpt optval optname ?vname? ?value?\"" }
		}
	    } elseif {[string match $opt* +$name]} {
		switch [llength $args] {
		0 { return 1 }
		1 { uplevel set [lindex $args 0] 1 }
		2 { uplevel set [lindex $args 0] [lindex $args 1] }
		default { error "wrong # args: should be\
			    \"matchOpt optval optname ?vname? ?value?\"" }
		}
	    } else {
		error "Unknown option $opt"
	    }
	}
	default {
	    if {[string match $opt* $fullname]} {
		switch [llength $args] {
		0 { return 1 }
		1 { uplevel set [lindex $args 0] 1 }
		2 { uplevel set [lindex $args 0] [lindex $args 1] }
		default { error "wrong # args: should be\
				\"matchOpt optval optname ?vname? ?value?\"" }
		}
	    } else {
		error "Unknown option $opt"
	    }
	}
    }
}


#############################################################################
#
# Check for options and/or keys.
#
proc doArguments {} {
    global argc argv prog
    global Option ColorName debug

    while {[llength $argv]} {
	set opt [nextarg]
	set savethisarg 1
	switch -glob -- $opt {
	-C* -
	-R*	{
		    set savethisarg 0
		    if {[string length $opt] == 2 && $argc < 2} {
			set rev [nextarg]
		    } else {
			set rev [string range $opt 2 end]
		    }
		    switch -glob -- $opt {
			-CC { set cmd [list cvs -q update -p] }
			-C* {
			    switch -regexp -- $rev {
			    ^[0-9.]+$ { set flag "-r" }
			    default { set flag "-D" }
			    }
			    set cmd [list cvs -q update -p $flag $rev]
			    }
			-RR { set cmd [list co -p] }
			-R* { set cmd [list co -p -r$rev] }
			default { die 10 "Internal error at C/D/R switch!" }
		    }
		    lappend Option(versioned) $cmd
		    lappend Option(revision) $rev
		}
	-D*	{
		    set savethisarg 0
		    if {[string length $opt] == 2} {
			set rev [nextarg]
		    } else {
			set rev [string range $opt 2 end]
		    }
		    set cmd [list cvs -q update -p -D $rev]
		    lappend Option(versioned) $cmd
		    lappend Option(revision) $rev
		}
	-a*	{ matchOpt $opt -all Option(ShowEqual) }
	-e*	{ matchOpt $opt -eqlhs Option(EqLHS) }
	-A*	{ lappend Option(DiffFlags) $opt }
	-B*	{ lappend Option(DiffFlags) $opt }
	-b	{ lappend Option(DiffFlags) -b }
	-bg	{ set ColorName(bg) [nextarg] }
	-bla*	{ matchOpt $opt -black ColorName(fg) black }
	-blu*	{ matchOpt $opt -blue ColorName(fg) blue }
	-cb	{ set Option(ChangeBar) 1 }
	-ch*	{ matchOpt $opt -changebar Option(ChangeBar) }
	-c*	{ matchOpt $opt -cyan ColorName(fg) cyan }
	-da*	{ matchOpt $opt -date Option(date) }
	-de*	{ matchOpt $opt -debug debug }
	-fg	{ set ColorName(fg) [nextarg] }
	-g*	{ matchOpt $opt -green ColorName(fg) green }
	-h -
	-he*	{ matchOpt $opt -help ; usage ; exit 0 }
	-hil*	-
	+hil*	{ matchOpt $opt +/-hilight Option(HighLight) }
	-hig*	-
	+hig*	{ matchOpt $opt +/-highlight Option(HighLight) }
	-i	{ lappend Option(DiffFlags) -i }
	-ig*	{ matchOpt $opt -ignorebadlinks Option(ignorebadlinks) }
	-in*	{ matchOpt $opt -indent Option(UseIndent) }
	-le*	{ matchOpt $opt -len ;
		    set n [scan [nextarg] "%d,%d" Option(LW) Option(RW)]
		    switch $n {
		    1 { set Option(RW) $Option(LW) }
		    2 { }
		    * { usage ; exit 1 }
		    }
		}
	-lh*	{ matchOpt $opt -lhs Option(LHS) }
	-m*	{ matchOpt $opt -magenta ColorName(fg) magenta }
	-nof*	{ matchOpt $opt -nofollow Option(nofollow) }
	-nu*	{ matchOpt $opt -number Option(UseNumber) }
	-p*	{ if {[matchOpt $opt -pattern]} {
			lappend Option(pattern) [nextarg]
		    }
		}
	-re*	{ matchOpt $opt -red ColorName(fg) red }
	-rh*	{ matchOpt $opt -rhs Option(RHS) }
	-S	{ set Option(StartFile) [lindex [file split [nextarg]] end] }
	-s	{ lappend Option(DiffFlags) -s }
	-sa*	{ matchOpt $opt -save Option(SaveIntermediate) }
	-se*	{ matchOpt $opt -separate Option(NoBlankLine) }
	-sp*	{ matchOpt $opt -space Option(SubstSpaces) ;
		    set n [nextarg]
		    set n [expr ($n < 2) ? 2 : ($n > 20) ? 20 : $n]
		    set s "                                      "
		    set Option(Spaces) [string range $s 0 [expr $n - 1]]
		}
	-t	{ lappend Option(DiffFlags) -t }
	-ta*	{ matchOpt $opt -tab Option(NoExpandTab) }
	-tr*	{ matchOpt $opt -truncate Option(NoTruncate) }
	-w	{ lappend Option(DiffFlags) -w }
	-wh*	{ matchOpt $opt -white ColorName(fg) white }
	-y*	{ matchOpt $opt -yellow ColorName(fg) yellow }
	-*	{ error "Unknown option $opt" }
	default	{ set argv [concat $opt $argv] ; return }
	}
    }
}

#############################################################################
#
# Look at all the options that were entered on the command line,
# and adjust our configuration to suit.
#
proc fixupOptions {} {
    global prog debug IsTemp Option ColorName ColorCode EQFormat Tput
    global Format

    # Supply default pattern, if none given.
    if {$Option(pattern) eq ""} {
	set Option(pattern) [list *]
    }

    # Fix up the inverted options:
    set Option(follow) [expr !$Option(nofollow)]
    unset Option(nofollow)

    set Option(BlankLine) [expr !$Option(NoBlankLine)]
    unset Option(NoBlankLine)

    set Option(ExpandTab) [expr !$Option(NoExpandTab)]
    unset Option(NoExpandTab)

    set Option(Truncate) [expr !$Option(NoTruncate)]
    unset Option(NoTruncate)

    # Translate the jumbo option:
    if $Option(ChangeBar) {
	array set Option { RHS 1   Truncate 0 }
    }

    if {$Option(LHS) && $Option(RHS)} {
	die 1 "Options -lhs and -rhs\
	    (or -lhs and -changebar) can't appear together" reminder
    }

    # Default for -highlight is 1 if showing equal lines, else 0.
    if {$Option(HighLight) == -1} {
	set Option(HighLight) [expr $Option(ShowEqual) || $Option(EqLHS)]
    }

    if {$Option(HighLight) && [string compare $ColorName(fg) "-"] == 0} {
	set Tput(enter) [exec tput bold]
	set Tput(exit) [exec tput rmso]
	if {![string compare $Tput(enter) ""] ||
					![string compare $Tput(exit) ""]} {
	    array set Tput { enter ""   exit "" }
	}
    }

    set EQFormat ""
    if {$Option(EqLHS)} {
	set Option(ShowEqual) 1

	set lw [expr 2*$Option(LW)]
	set EQFormat "%s%-$lw.${lw}s%s %s"
    }

    if $Option(SubstSpaces) {
	set Option(ExpandTab) 1
	lappend Option(DiffFlags) -b
    }

    # The non-numbering formats:
    if {$Option(LHS)} {
	set lw [expr 2*$Option(LW) - 5]
	set Format(number) "%4s: %s%-$lw.${lw}s%s %s"

	set lw [expr 2*$Option(LW)]
	set Format(nonumber) "%s%-$lw.${lw}s%s %s"

    } elseif {$Option(RHS)} {
	set rw [expr 2*$Option(RW) - 5]
	set Format(number) "%s%4s: %s%-$rw.${rw}s%s"

	set rw [expr 2*$Option(RW)]
	set Format(nonumber) "%s %s%-$rw.${rw}s%s"

    } else {
	set lw [expr $Option(LW) - 5]
	set rw $lw
	set Format(number) "%4s: %s%-$lw.${lw}s%s %s%4s: %s%-$rw.${rw}s%s"

	set lw $Option(LW)
	set rw $lw
	set Format(nonumber) "%s%-$lw.${lw}s%s %s %s%-$rw.${rw}s%s"
    }

    if !{$Option(Truncate)} {
	# Strip out the fixed-width formatting elements 
	regsub -all {[0-9]+\.[0-9]+} $Format(number) "" Format(number)
	regsub -all {[0-9]+\.[0-9]+} $Format(nonumber) "" Format(nonumber)
	regsub -all {[0-9]+\.[0-9]+} $EQFormat "" EQFormat
    }

    set bgname $ColorName(bg)
    if {![info exists ColorCode($bgname)]} {
	die 1 "No such color as `$bgname'."
    }
    set fgname $ColorName(fg)
    if {![info exists ColorCode($fgname)]} {
	die 1 "No such color as `$fgname'."
    }

    set Esc "\033\["
    if $::debug {
	puts "DEBUG Option(ShowEqual) $Option(ShowEqual)\
			    Option(HighLight) $Option(HighLight)"
	puts "DEBUG bg: ColorCode($bgname) = $ColorCode($bgname)\
			    fg: ColorCode($fgname) = $ColorCode($fgname)"
    }
    switch -glob -- "$ColorCode($bgname),$ColorCode($fgname)" {
	"-,-" {
		if {!$Option(HighLight)} {
		    set Tput(enter) ""
		    set Tput(exit) ""
		}
	    }
	"-,*" {
	    set Tput(enter) \
	    		[format "%s%dm" $Esc [expr $ColorCode($fgname) + 30]]
	    set Tput(exit)  "${Esc}0m"
	    }
	"*,-" {
	    set Tput(enter) \
	    		[format "%s%dm" $Esc [expr $ColorCode($bgname) + 40]]
	    set Tput(exit)  "${Esc}0m"
	    }
	"*,*" {
	    set Tput(enter) \
	    		[format "%s%d;%dm" $Esc \
				    [expr $ColorCode($bgname) + 40] \
				    [expr $ColorCode($fgname) + 30]]
	    set Tput(exit)  "${Esc}0m"
	    }
    }
}

#############################################################################
#
# Input: the filename part of the argv list (ie 1 or 2 filenames).
# Sort out CVS and RCS requests, extract CVS or RCS files as needed,
# and return two filenames.
#
proc getFiles {argv} {
    global Option IsTemp
    set n_versioned [llength $Option(versioned)]

    if {$n_versioned > 2} {
	die 1 "Can't have more that two -C, -D, and/or -R options." reminder
    } elseif {$n_versioned && [llength $argv] != 1} {
	die 1 "Specify exactly one filename\
				with -C, -D, and -R options." reminder
    } elseif {$n_versioned == 0 && [llength $argv] != 2} {
	die 1 "Wrong number of filename arguments." reminder
    }

    #
    # Assertion: n_versioned is in the range 0..2
    #
    if {$n_versioned == 0} {
	set file1 [lindex $argv 0]
	set file2 [lindex $argv 1]
    } else {
	# n_versioned is 1 (-Xrev file) or 2 (-Xrev1 -Xrev2 file).
	# Either way, the "file" part is now in argv[0].

	set fname [lindex $argv 0]
	if {[file isdirectory $fname]} {
	    die 1 "Filename can't be a directory when\
				using -C, -D, and -R options." reminder
	}

	# File1:
	set IsTemp(1) 1
	set rev [lindex $Option(revision) 0]		; # desired revision.
	set file1 [cmd2tmpfile [lindex $Option(versioned) 0] $fname $rev]

	# File2:
	if {$n_versioned == 1} {
	    # Only one revision requested; second file is the on-disk copy.
	    set file2 $fname
	} else {
	    set IsTemp(2) 1
	    set rev [lindex $Option(revision) 1]	; # desired revision.
	    set file2 [cmd2tmpfile [lindex $Option(versioned) 1] $fname $rev]
	}
    }

    list $file1 $file2
}

#############################################################################
#
# read lines up to eof or dot, and return number of lines (not
# including the dot-line).
#
proc eatLines {handle} {
    set nfollow 0
    while {([gets $handle line] >= 0) && ([string compare $line .])} {
	incr nfollow
    }
    return $nfollow
}

#############################################################################
#
# A routine to mark up metainfo for display
#
proc metamark {str} {
    return "*** $str"
}

#############################################################################
#
# A comparison for sorting elements like {number ....} into ascending order.
#
proc compare {e1 e2} {
    set i [lindex $e1 0]
    set j [lindex $e2 0]
    if {$i < $j} {return -1} elseif {$i > $j} {return 1} else {return 0}
}

#############################################################################
#
# Initializer for diffInterp; call once before using diffInterp.
#
proc diffInterpInit {} {
    set num {[0-9]+}
    set numnum "($num)(,($num))?"
    set ::PAT(a) "($num)a"
    set ::PAT(c) "${numnum}c"
    set ::PAT(d) "${numnum}d"
    set ::PAT(s) "${numnum}s"
    set ::PAT(B) "Binary files .* differ"
    set ::PAT(F) "Files .* and .* are identical"
}

#############################################################################
#
# A proc to interpret the results of diff -e.
# Output: a list; each elt is {N1 N2 operator number-of-following-lines}.
#
proc diffInterp {handle} {
    global PAT

    set diffs {}
    set ln 0
    while {[gets $handle line] >= 0} {
	incr ln
	if {[regexp $PAT(a) $line a n1]} {
	    lappend diffs [list $n1 $n1 "a" [eatLines $handle]]

	} elseif {[regexp $PAT(c) $line a n1 b n2]} {
	    if {[string compare $n2 ""] == 0} {set n2 $n1}
	    lappend diffs [list $n1 $n2 "c" [eatLines $handle]]

	} elseif {[regexp $PAT(d) $line a n1 b n2]} {
	    if {[string compare $n2 ""] == 0} {set n2 $n1}
	    lappend diffs [list $n1 $n2 "d" 0]

	} elseif {[regexp $PAT(s) $line a n1 b n2]} {
	    ; # ignore "s" commands

	} elseif {[regexp $PAT(B) $line a n1 b n2]} {
	    ; # Binary files differ...
	    lappend diffs [list 0 0 "B" 0]

	} elseif {[regexp $PAT(F) $line a n1 b n2]} {
	    ; # Files ... are identical
	    lappend diffs [list 0 0 "F" 0]

	} else {
	    puts "Invalid diff output @ line $ln: `$line'"
	}
    }
    catch {close $handle}
    return [lsort -command compare $diffs]
}

#############################################################################
#
# A proc to print lines from the two lists.
# n1 and n2 are the number of lines to print from files 1 and two.  If
# n1 != n2, the shorter list is padded with blank lines until they match.
# Separator is " " if matching lines are being printed, else anything.
# isfile[12] is "F" if the lines should come from the file, else blank
# lines will be printed.
#
# If global variable PutLines_msg has some text in it, and we are printing
# some lines, then we print the message first and blank
# out the PutLines_msg variable.
#
proc putLines {isfile1 n1 separator isfile2 n2} {
    global Last1 Last2 Contents1 Contents2
    global EQFormat Format Option Tput
    global debug
    global PutLines_msg

    if $::debug {
	puts "*** Last1=$Last1 $isfile1 N1=$n1 $separator \
				Last2=$Last2 $isfile2 N2=$n2 ***"
    }
    if {$n1 == 0 && $n2 == 0} {
	return;
    }

    if {$Option(UseNumber)} {
	set thisFmt $Format(number)
    } else {
	set thisFmt $Format(nonumber)
    }
    set forceLHS 0
    if {[string compare $separator " "] == 0} {
	if {!$Option(ShowEqual)} {
	    if {[string compare $isfile1 F] == 0} { incr Last1 $n1 }
	    if {[string compare $isfile2 F] == 0} { incr Last2 $n2 }
	    return;
	} else {
	    set On ""
	    set Off ""
	    if {$Option(EqLHS)} {
		set thisFmt $EQFormat
		set forceLHS 1
	    }
	}
    } else {
	set On $Tput(enter)
	set Off $Tput(exit)
    }
    if $Option(BlankLine) {
	puts ""
    }

    if {[string compare $isfile1 F] == 0} {
	# idx1 is the first index into list.  Note that the index counts from 0,
	# but the last-line counter (Last1) counts from one.
	set idx1 $Last1
	incr Last1 $n1
	set lines1 [lrange $Contents1 $idx1 [expr $Last1 - 1]]
	set Lnum1 [expr $idx1 + 1]
    } else {
	set idx1 ""
	set lines1 ""
	set Lnum1 ""
    }
    if {[string compare $isfile2 F] == 0} {
	# idx2 is the first index into list.  Note that the index counts from 0,
	# but the last-line counter (Last2) counts from one.
	set idx2 $Last2
	incr Last2 $n2
	set lines2 [lrange $Contents2 $idx2 [expr $Last2 - 1]]
	set Lnum2 [expr $idx2 + 1]
    } else {
	set idx2 ""
	set lines2 ""
	set Lnum2 ""
    }
    if $::debug {
	puts "<<< idx:$idx1,Last1:$Last1,Lnum1:$Lnum1,nl:[llength $lines1]  \
		:::: idx2:$idx2,Last2:$Last2,Lnum1:$Lnum1,nl:[llength $lines1]"
    }

    if {[llength $lines1] || [llength $lines2]} {
	if {[string compare $PutLines_msg ""]} {
	    puts $PutLines_msg
	    set PutLines_msg ""
	}
    }

    if {$Option(UseNumber)} {
	if {$forceLHS || $Option(LHS)} {
	    foreach l1 $lines1 l2 $lines2 {
		if {$Lnum1 > $Last1} {set Lnum1 ""}
		if {$Lnum2 > $Last2} {set Lnum2 ""}
		puts [format $thisFmt $Lnum1 $On $l1 $Off $separator ]
		if {[string compare $Lnum1 ""]} {incr Lnum1}
		if {[string compare $Lnum2 ""]} {incr Lnum2}
	    }
	} elseif {$Option(RHS)} {
	    foreach l1 $lines1 l2 $lines2 {
		if {$Lnum1 > $Last1} {set Lnum1 ""}
		if {$Lnum2 > $Last2} {set Lnum2 ""}
		puts [format $thisFmt $separator $Lnum2 $On $l2 $Off]
		if {[string compare $Lnum1 ""]} {incr Lnum1}
		if {[string compare $Lnum2 ""]} {incr Lnum2}
	    }
	} else {
	    foreach l1 $lines1 l2 $lines2 {
		if {$Lnum1 > $Last1} {set Lnum1 ""}
		if {$Lnum2 > $Last2} {set Lnum2 ""}
		puts [format $thisFmt $Lnum1 $On $l1 $Off \
					    $separator $Lnum2 $On $l2 $Off]
		if {[string compare $Lnum1 ""]} {incr Lnum1}
		if {[string compare $Lnum2 ""]} {incr Lnum2}
	    }
	}
    } else {
	if {$forceLHS || $Option(LHS)} {
	    foreach l1 $lines1 l2 $lines2 {
		puts [format $thisFmt $On $l1 $Off $separator ]
	    }
	} elseif {$Option(RHS)} {
	    foreach l1 $lines1 l2 $lines2 {
		puts [format $thisFmt $separator $On $l2 $Off ]
	    }
	} else {
	    foreach l1 $lines1 l2 $lines2 {
		puts [format $thisFmt $On $l1 $Off $separator $On $l2 $Off ]
	    }
	}
    }
}

#############################################################################
#
# Format an mtime for simple display.
#
proc format_time {t} {
    clock format $t -format "%Y-%m-%d %T"
}

#############################################################################
#
# Compare two symlinks
#
proc compare_symlinks {file1 file2} {
    global Option Contents1 Contents2 Last1 Last2

    set link1 [file readlink $file1]
    set link2 [file readlink $file2]

    if $::debug {
	puts "DEBUG file1 <$file1>  link1 <$link1>"
	puts "DEBUG file2 <$file2>  link2 <$link2>"
    }

    if {$link1 eq $link2} {
	# Links are the same.
	return
    } else {
	puts [metamark "Symlinks $file1 $file2"]
	set Contents1 [list "-> $link1"]
	set Contents2 [list "-> $link2"]
	# putLines needs line numbers initialized because it's really
	# set up to handle lines of text:
	set Last1 0
	set Last2 0

	# Next, temporarily disable optional line numbering, so that putLines
	# doesn't print a symlink value with a "line number":
	set save_usenumber $Option(UseNumber)
	set Option(UseNumber) 0
	set ::PutLines_msg ""

	# Format and emit the comparison:
	putLines F 1 ! F 1

	# Restore UseNumber option:
	set $Option(UseNumber) $save_usenumber
    }
}

#############################################################################
#
# Difference two non-directory files
#
proc diff_filepair {file1 file2} {
    global Option Last1 Last2 Contents1 Contents2

    if {[catch {file2handle $file1} handle1]} {
	puts [metamark $handle1]
	return
    }
    if {[catch {file2handle $file2} handle2]} {
	puts [metamark $handle2]
	return
    }

    if $::debug {
	puts "DEBUG file1 <$file1>  handle1 <$handle1>"
	puts "DEBUG file2 <$file2>  handle2 <$handle2>"
    }

    # Read the two files.
    if {[string compare $handle1 stdin] == 0 && 
			[string compare $handle2 stdin] == 0 } {
	die 1 "Can't use stdin for both file1 and file2."
    }

    switch "$Option(UseIndent),$Option(ExpandTab)" {
	1,1 {
		if $Option(SubstSpaces) {
		    set cmd [list exec indent $Option(IndentFlags) <@%s | \
				    expand | sed -e "s/$Option(Spaces)/ /g"]
		    set tag "read+indent+expand+respace"
		} else {
		    set cmd "exec indent $Option(IndentFlags) <@%s | expand"
		    set tag "read+indent+expand"
		}
	    }
	1,0 {
		set cmd "exec indent $Option(IndentFlags) <@%s"
		set tag "read+indent"
	    }
	0,1 {
		if $Option(SubstSpaces) {
		    set cmd [list exec expand <@%s | \
					sed -e "s/$Option(Spaces)/ /g"]
		    set tag "read+expand+respace"
		} else {
		    set cmd "exec expand <@%s"
		    set tag "read+expand"
		}
	    }
	default {
		set cmd "read %s"
		set tag "read"
	    }
    }

    regsub %s $cmd $handle1 command
    if $::debug { puts "DEBUG: COMMAND: --> $command <--" }
    if {[catch $command Contents1]} {
	puts stderr "$prog: $tag $file1 -- the command\n\t$command\n\
			    \t...returned error code: $::errorCode"
    }
    regsub %s $cmd $handle2 command
    if $::debug { puts "DEBUG: COMMAND: --> $command <--" }
    if {[catch $command Contents2]} {
	puts stderr "$prog: $tag $file2 -- the command\n\t$command\n\
			    \t...returned error code: $::errorCode"
    }

    close $handle1
    close $handle2
    set Contents1 [split $Contents1 \n]
    set Contents2 [split $Contents2 \n]

    # Build up the diff command
    set cmd "|diff $Option(DiffFlags) -e"
    set nlead [string length $cmd]
    set leader [string repeat " " $nlead]
    set ls_msg ""
    if {[string compare $handle1 stdin] == 0} {
	append cmd " - $file2"
	append cmd " <<$Contents1"
	if {$::Option(date)} {
	    set date2 [format_time [file mtime $file2]]
	    set ls_msg "$leader - $date2"
	}
    } elseif {[string compare $handle2 stdin] == 0} {
	append cmd " $file1 -"
	append cmd " <<$Contents2"
	if {$::Option(date)} {
	    set date1 [format_time [file mtime $file1]]
	    set ls_msg "$leader $date1 -"
	}
    } else {
	append cmd " $file1 $file2"
	if {$::Option(date)} {
	    set date1 [format_time [set m1 [file mtime $file1]]]
	    set date2 [format_time [set m2 [file mtime $file2]]]
	    set m [string length [metamark ""]]
	    set n2 [expr {($::Screen(columns) / 2) - 5}]
	    if {$::DiffingDirs} {
		set n1 [expr {$n2 - $m - $nlead}]
		set ls_msg "$leader "
	    } else {
		set n1 [expr {$n2 - $m}]
		set ls_msg ""
	    }
	    if {$m1 > $m2} {
		set mid "<<NEWER"
	    } elseif {$m1 < $m2} {
		set mid "NEWER>>"
	    } else {
		set mid "<SAME>"
	    }
	    append ls_msg [format "%-${n1}s %s %${n2}s" $date1 $mid $date2]
	}
    }
    if {$::DiffingDirs} {
	set ::PutLines_msg [metamark [string range $cmd 1 end]]
	if {$ls_msg ne ""} {
	    append ::PutLines_msg \n [metamark $ls_msg]
	}
    } elseif {$ls_msg ne ""} {
	set ::PutLines_msg [metamark $ls_msg]
    } else {
	set ::PutLines_msg ""
    }

    if {[catch {open $cmd r} DiffHandle]} {
	puts "Can't execute [string range $cmd 1 end]: $DiffHandle"
	return
    }

    # Interpret the results and print the parallel diff
    set Last1 0	; # last line printed or skipped from file1.
    set Last2 0	; # last line printed or skipped from file2.
    if {[catch {
	foreach diff [diffInterp $DiffHandle] {
	    foreach {line1 line2 action nlines} $diff {}	; # "lassign"
	    # At this point, the diff is obviously running.  Therefore we
	    # can unlink the files, if they were temporaries.  Sure, this
	    # will cost us extra tests, but they will be small potatoes
	    # compared to this pretty smart time to try to unlink the files.
	    if $::debug {
		puts "@@@ line1,2:$line1,$line2\
				action:$action nlines:$nlines @@@"
	    }
	    switch $action {
		a { set nmatch [expr $line1 - $Last1] }
		B { set nmatch 0 }
		F { set nmatch 0 }
		default {
		    set nmatch [expr $line1 - $Last1 - 1]
		}
	    }
	    putLines F $nmatch " " F $nmatch
	    set m [expr $line2 + 1 - $line1]
	    switch $action {
	    "a" { putLines ""  $nlines >  F $nlines }
	    "c" { putLines  F  $m      !  F $nlines }
	    "d" { putLines  F  $m      < "" $m }
	    "B" { puts [metamark "Binary files $file1 and $file2 differ"] }
	    "F" { puts [metamark "Files $file1 and $file2 are identical"] }
	    default { die 3 "Internal err in $prog: unexpected action $action" }
	    }
	}
    } result]} {
	# An error here is a big deal -- it isn't supposed to happen under
	# normal execution.  We expect to get here most often with "broken
	# pipe" (e.g. pdiff | more, and the user exits "more" a bit early),
	# but we don't want to print "error writing 'file1': broken pipe",
	# which is what we see.  So if there is a POSIX/EPIPE error, then put
	# just the terse message; else put the result string.
	if {[lrange $::errorCode 0 1] eq [list POSIX EPIPE]} {
	    puts stderr [lindex $::errorCode 2]
	} else {
	    puts stderr $result
	}
	die 1 ""
    }
    set n1 [expr [llength $Contents1] - $Last1]
    set n2 [expr [llength $Contents2] - $Last2]
    if {$n1 > 0 || $n2 > 0} {
	catch {putLines F $n1 " " F $n2}
    }
}

#############################################################################
#
# Figure out how to handle any pair of files.
#
# Caller should [catch] any call to this command.
#
proc diff_any2files {file1 file2} {
    global IsTemp Option

    if {$Option(follow)} {
	file stat $file1 stat1
    } else {
	file lstat $file1 stat1
    }
    if {$Option(follow)} {
	file stat $file2 stat2
    } else {
	file lstat $file2 stat2
    }
    switch -exact -- $stat1(type) {
    directory {set type1 dir}
    link {set type1 link}
    default {set type1 nondir}
    }
    switch -exact -- $stat2(type) {
    directory {set type2 dir}
    link {set type2 link}
    default {set type2 nondir}
    }
    set types "$type1/$type2"
    switch -exact -- $types {
	dir/dir		{ 
			    set ::DiffingDirs 1
			    diff_dirpair $file1 $file2
			}
	dir/nondir	{ puts [metamark "$file1 is a directory,\
						but $file2 is not."] }
	nondir/dir	{ puts [metamark "$file1 is not a directory,\
						but $file2 is."] }
	nondir/nondir	{ diff_filepair $file1 $file2
			  if {$IsTemp(1) && !$Option(SaveIntermediate)} {
			    catch {file delete $file1}
			  }
			  if {$IsTemp(2) && !$Option(SaveIntermediate)} {
			    catch {file delete $file2}
			  }
			}
	link/nondir	{ puts [metamark "$file1 is a symlink,\
						but $file2 is not."] }
	link/dir	{ puts [metamark "$file1 is a symlink,\
					but $file2 is a directory."] }
	nondir/link	{ puts [metamark "$file1 is not a symlink,\
						but $file2 is."] }
	dir/link	{ puts [metamark "$file1 is a directory,\
					    but $file2 is a symlink."] }
	link/link	{ compare_symlinks $file1 $file2 }
	default		{ die 12 "Internal error at switch $types!" }
    }
}

#############################################################################
#
# Glob a directory.  Return three of lists: 
# o  if Option(follow) is in effect (default), we follow symlinks, and:
#	- the first list is all non-directory files;
#	- the second list is all directory files;
#	- the third list is empty.
# o  otherwise, we do not follow symlinks, but compare the link values:
#	- the first list is all non-directory, non-symlink files;
#	- the second list is all directory files;
#	- the third list is all symlink files.
#
# An error is generated if "cd $dir" fails.
#
proc glob_dir {dir} {
    global Option
    set saved_dir [pwd]
    cd $dir 
    file stat . x
    set dev_ino "$x(dev),$x(ino)"
    if {[info exists ::Visited($dev_ino)]} {
	# Already visited this directory.
	cd $saved_dir
	return -code error "Symbolic link loop?  Already visited this\
				directory under the name $::Visited($dev_ino)"
    }
    set ::Visited($dev_ino) $dir
    set links [list]
    set nondirs [list]
    # Collect all directories, regardless of what -pattern says:
    set dirs [glob -nocomplain -type d *]
    foreach f [eval glob -nocomplain $Option(pattern)] {
        if {$Option(follow)} {
	    if {[catch {file stat $f x} r]} {
		if {$Option(ignorebadlinks) &&
		    [lrange $::errorCode 0 1] eq [list POSIX ENOENT]} {
		    # ignore this symlink pointing to non-existent file.
		    continue
		} else {
		    cd $saved_dir
		    return -code error "can't stat $f: $r"
		}
	    }
	} else {
	    if {[catch {file lstat $f x} r]} {
		cd $saved_dir
		return -code error "can't lstat $f: $r"
	    }
	}
	if {$x(type) eq "directory"} {
	    lappend dirs $f
	} elseif {$x(type) eq "link"} {
	    lappend links $f
	} else {
	    lappend nondirs $f
	}
    }
    cd $saved_dir

    # Directories may not be unique, because we did a glob for directories,
    # so make them unique now...
    list $nondirs [lsort -unique $dirs] $links
}

#############################################################################
#
# Difference a directory pair
#
proc diff_dirpair {dir1 dir2} {

    # Glob in dir1; collect files into the dirs and non-dirs arrays.
    if {[catch {foreach {nd d lk} [glob_dir $dir1] {break}} reason]} {
	puts [metamark "Can't glob $dir1: $reason"]
	return
    }
    foreach f $nd { set type($f) nondir}
    foreach f $d { set type($f) dir}
    foreach f $lk { set type($f) link}

    # Glob in dir2; collect files into the dirs and non-dirs arrays.
    if {[catch {foreach {nd d lk} [glob_dir $dir2] {break}}]} {
	puts [metamark "Can't glob $dir2: $reason"]
	return
    }
    foreach f $nd { append type($f) /nondir }
    foreach f $d { append type($f) /dir }
    foreach f $lk { append type($f) /link}

    # Do all files in non-directories; then descend directories
    set filenames [lsort -ascii [array names type]]
    foreach f $filenames {
	if {[string compare $f $::Option(StartFile)] < 0} {
	    continue
	} else {
	    set ::Option(StartFile) ""
	}
	set file1 [file join $dir1 $f]
	set file2 [file join $dir2 $f]
	switch -exact -- $type($f) {
	dir		-
	link		-
	nondir		{ puts [metamark "Only in $dir1: $f"] }
	/dir		-
	/link		-
	/nondir		{ puts [metamark "Only in $dir2: $f"] }
	nondir/nondir	{ diff_filepair $file1 $file2 }
	dir/nondir	{ puts [metamark "$file1 is a directory,\
						but $file2 is not."] }
	nondir/dir	{ puts [metamark "$file1 is not a directory,\
						but $file2 is."] }
	dir/dir		{ # Skip (process later) }
	link/nondir	{ puts [metamark "$file1 is a symlink,\
						but $file2 is not."] }
	link/dir	{ puts [metamark "$file1 is a symlink,\
					but $file2 is a directory."] }
	nondir/link	{ puts [metamark "$file1 is not a symlink,\
						but $file2 is."] }
	dir/link	{ puts [metamark "$file1 is a directory,\
					    but $file2 is a symlink."] }
	link/link	{ compare_symlinks $file1 $file2 }
	default		{ die 11 "Internal error at switch $type($f)!" }
	}
    }
    # Now we've done all combos except directories that have to be
    # descended.
    foreach f $filenames {
	switch -exact -- $type($f) {
	dir/dir { diff_dirpair [file join $dir1 $f] [file join $dir2 $f] }
	default { }
	}
    }
}

###########################################################################

main
die 0 ""