#
# Operations for Tcl procedure/comment manipulation in Text widgets.
# Also works for PERL and Makefiles.
#


# Returns 'sub' if file is PERL, ':' if file is a Makefile (or variant, such
# as an Imakefile), or 'proc' if file is Tcl.
proc th_language_function {w} {
  global TH
  if {[catch "set TH(File,$w)"]} {return "proc"
  } elseif {[string tolower [file extension $TH(File,$w)]] == ".pl"} {return "sub"
  } elseif {[string first "makefile" [string tolower [file tail $TH(File,$w)]]] >= 0} {return ":"
  } else {return "proc"}
}

# Procedure boundary routines
# Given index, these deal with Tcl procedures, and return an index, or ""
# if unsuccessful.

proc th_proc_begin {w index} {
  set function_begin [th_language_function $w]
  set trace [$w index "$index lineend +1c"]
  while {[set trace [$w search -backward -- $function_begin "$trace-1c" 1.0]] != ""} {
    scan [$w index $trace] "%d.%d" row column
    if {($column == 0)} {return $trace} else {
      if {$function_begin == ":"} {
        if {([string first [$w get "$trace +1c"] " \t\n"] >= 0) &&
		([string first [$w get "$trace linestart"] "# \t\n"] < 0)} {
          return "$trace linestart"}
  }}}
  return ""
}

proc th_proc_end {w index} {
  if {[set index [th_proc_begin $w $index]] == ""} {return ""}
  set begin $index
  set ob "\{"  ; set cb "\}"
  switch [th_language_function $w] {
    ":" {
      if {[set end [$w search -forward -regexp {$^} $begin end]] == ""} {
        return end} else {return $end}
  } "sub" {set arg_end $begin
  } "proc" {
      if {[set arg_start [$w search -forward -- $ob $begin end]] == ""} {
        return ""}
      if {[set arg_end [th_Text_right_exp $w $arg_start $ob $cb 1]] == ""} {
        return ""}
  }}
  if {[set body_start [$w search -forward -- $ob $arg_end end]] == ""} {return}
  if {[set end [th_Text_right_exp $w $body_start $ob $cb 1]] == ""} {return}
  return $end
}

proc th_proc_next {w index} {
  set function_begin [th_language_function $w]
  set trace $index
  while {[set trace [$w search -forward -- $function_begin "$trace +1c" end]] != ""} {
    scan [$w index $trace] "%d.%d" row column
    if {($column == 0)} {return $trace} else {
      if {$function_begin == ":"} {
        if {[$w compare $trace > "$index lineend"] &&
        	([string first [$w get "$trace +1c"] " \t\n"] >= 0) &&
		([string first [$w get "$trace linestart"] "# \t\n"] < 0)} {
          return "$trace linestart"}
  }}}
  return ""
}

proc th_proc_prev {w index} {
  if {[set begin [th_proc_begin $w $index]] == ""} {return ""}
  if {[$w compare $begin != $index]} {
    return $begin 
  } else {return [th_proc_begin $w "$index -1c"]
}}


# Comment boundary routines
# Like the procedure routines, but these deal with Tcl comments.

proc th_tclcomment_begin {w index} {
  scan [$w index $index] "%d.%d" i dummy
  if {[$w get "$i.0"] != "#"} {return ""}
  for {} {$i > 0} {incr i -1} {
    if {([$w get "$i.0"] == "#") && ([$w get "$i.0 -1 line"] != "#")} {
      return "$i.0"
  }}
  if {[$w get 1.0] == "#"} {return 1.0} else {return ""}
}

proc th_tclcomment_end {w index} {
  scan [$w index $index] "%d.%d" i dummy
  scan [$w index end] "%d.%d" e dummy
  if {[$w get "$i.0"] != "#"} {return ""}
  for {} {$i < $e} {incr i} {
    if {([$w get "$i.0"] != "#")} {return $i.0}}
  if {[$w get "$e.0"] == "#"} {return end} else {return ""}
}

proc th_tclcomment_next {w index} {
  scan [$w index $index] "%d.%d" i dummy
  scan [$w index end] "%d.%d" e dummy
  for {} {$i < $e} {incr i} {
    if {([$w get "$i.0"] != "#") &&
      ([$w get "$i.0 +1l"] == "#")} {return "$i.0 +1l"}}
  return ""
}

proc th_tclcomment_prev {w index} {
  if {[set begin [th_tclcomment_begin $w $index]] == ""} {return ""}
  if {[$w compare $begin != $index]} {
    return $begin 
  } else {return [th_tclcomment_begin $w "$index -1c"]
}}


# Adjusts selected region to fit in $length columns, so that no lines wrap
# If unspecified, length defaults to window width.
proc th_tclcomment_format {w start end {length ""}} {
  if {[catch {$w index sel.first}]} {
    set selected 0
    if {[set start [th_tclcomment_begin $w insert]] == ""} {bell ; return}
    if {[$w compare [set end [th_tclcomment_end $w $start]] < insert]} {bell ; return}
  } else {
    set start sel.first ; set end sel.last
    set selected 1
  }
  set chars [$w get $start $end]
  $w mark set th_tclcomment_end $end ; $w mark gravity th_tclcomment_end right
  if {($length == "")} {set length [$w cget -width]}

  set prefix ""
  for {set i 0} {[string first [$w get "$start +$i c"] "# "] >= 0} {incr i} {
    append prefix [$w get "$start +$i c"]
  }
  th_Text_delete_prefix $w $start th_tclcomment_end $prefix
  th_Text_format $w $start th_tclcomment_end [expr $length - [string length $prefix]]
  th_Text_add_prefix $w $start th_tclcomment_end $prefix

  if $selected {set end sel.last} else {set end [th_tclcomment_end $w $start]}
  set e [$w index th_tclcomment_end] ; $w mark unset th_tclcomment_end
  th_Text_undoable_replace $w $start $e $chars "Reformat"
}

