home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1998 March / Macworld (1998-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / textManip.tcl < prev    next >
Encoding:
Text File  |  1997-12-08  |  26.6 KB  |  1,038 lines  |  [TEXT/ALFA]
  1. #===========================================================================
  2. # Information about a selection or window.
  3. #===========================================================================
  4. proc wordCount {} {
  5.     if {[set chars [expr [selEnd] - [getPos]]]} {
  6.         set lines [expr [lindex [posToRowCol [selEnd]] 0] - [lindex [posToRowCol [getPos]] 0]]
  7.         set text [getSelect]
  8.     } else {
  9.         set chars [maxPos]
  10.         set lines [lindex [posToRowCol $chars] 0]
  11.         set text [getText 0 [maxPos]]
  12.     }
  13.     regsub -all {[!=;.,\(\#\=\):\{\"\}]} $text " " text
  14.     set words [llength $text]
  15.     alertnote [format "%d chars, %d words, %d lines" $chars $words $lines]
  16. }
  17.  
  18.  
  19. # FILE: sortLines.tcl
  20. #
  21. # last update: 8/12/97 {10:22:25 am}
  22. #
  23. # This version of sortLines has the option of ignoring blanks/whitespace (-b)
  24. # and case-insensitive sorting (-i), or reverse sorting:
  25. #     sortLines [-b] [-i] [-r]
  26.  
  27. # COPYRIGHT:
  28. #
  29. #    Copyright © 1992,1993 by David C. Black All rights reserved.
  30. #    Portions copyright © 1990, 1991, 1992 Pete Keleher. All Rights Reserved.
  31. #
  32. #    Redistribution and use in source and binary forms are permitted
  33. #    provided that the above copyright notice and this paragraph are
  34. #    duplicated in all such forms and that any documentation,
  35. #    advertising materials, and other materials related to such
  36. #    distribution and use acknowledge that the software was developed
  37. #    by David C. Black.
  38. #
  39. #    THIS SOFTWARE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
  40. #    IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
  41. #    WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
  42. #
  43. ################################################################################
  44.  
  45. # AUTHOR
  46. #
  47. #    David C. Black
  48. #    GEnie:    D.C.Black
  49. #    Internet: black@mpd.tandem.com (preferred)
  50. #    USnail:   6217 John Chisum Lane, Austin, TX 78749
  51. #
  52. ################################################################################
  53.  
  54. proc reverseSort {} {sortLines -r}
  55.  
  56. proc sortLines {args} {
  57.     set b_flag [lsearch $args "-b"]
  58.     if {$b_flag != -1} {
  59.         set args [lreplace $args $b_flag $b_flag]
  60.     }
  61.     incr b_flag
  62.  
  63.     set i_flag [lsearch $args "-i"]
  64.     if {$i_flag != -1} {
  65.         set args [lreplace $args $i_flag $i_flag]
  66.     }
  67.     incr i_flag
  68.     
  69.     if {[lsearch $args "-r"] >= 0} {
  70.         set mode "-decreas"
  71.     } else {
  72.         set mode "-increas"
  73.     }
  74.     
  75.     set start [getPos]
  76.     set end  [selEnd]
  77.     if {$start == $end} {
  78.         alertnote "You must highlight the section you wish to sort."
  79.         return
  80.     }
  81.     if {[lookAt [expr $end-1]] != "\r"} {
  82.         alertnote "The selection must consist only of complete lines."
  83.         return
  84.     }
  85.     set text [split [getText $start [expr $end-1]] "\r"]
  86.     if {$b_flag > 0 || $i_flag > 0} {
  87.         foreach line $text {
  88.             if {$i_flag > 0} {
  89.                 set key [string tolower $line]
  90.             } else {
  91.                 set key $line
  92.             }
  93.             if {$b_flag > 0} {
  94.                 regsub -all "\[ \t\]+" $key " " key
  95.             }
  96.             set orig($key) $line
  97.             lappend list $key
  98.         }
  99.         #endforeach
  100.         unset text
  101.         foreach key [lsort $mode $list] {
  102.             lappend text $orig($key)
  103.         }
  104.         #endforeach
  105.     } else {
  106.         set text [lsort $mode $text]
  107.     }
  108.     set text [join $text "\r"]
  109.     replaceText $start [expr $end-1] $text
  110.     select $start $end
  111. }
  112.  
  113. # Test case:
  114. #
  115. # a  black
  116. # a black cat
  117. # A  black dog
  118.  
  119.  
  120.  
  121. #================================================================================
  122. # Block shift left and right.
  123. #================================================================================
  124.  
  125. proc shiftLeft {} {
  126.     global shiftChar
  127.     doShiftLeft "\t"
  128.     
  129. }
  130. proc shiftLeftSpace {} {
  131.     global shiftChar
  132.     doShiftLeft " "
  133. }
  134.  
  135. proc doShiftLeft {shiftChar} {
  136.      set start [lineStart [getPos]]
  137.      set end [nextLineStart [expr [selEnd] - 1]]
  138.     if {$start >= $end} {set end [nextLineStart $start]}
  139.     
  140.     set text [split [getText $start [expr $end - 1]] "\r"]
  141.     
  142.     set textout ""
  143.     
  144.     foreach line $text {
  145.         if {[string index $line 0] == $shiftChar} {
  146.             lappend textout [string range $line 1 end]
  147.         } else {
  148.             lappend textout $line
  149.         }
  150.     }
  151.  
  152.     set text [join $textout "\r"]    
  153.     replaceText $start [expr $end - 1] $text
  154.     select $start [expr 1 + $start + [string length $text]]
  155. }
  156.  
  157.  
  158. proc shiftRight {} {
  159.     global shiftChar
  160.     doShiftRight "\t"
  161.     
  162. }
  163. proc shiftRightSpace {} {
  164.     global shiftChar
  165.     doShiftRight " "
  166. }
  167. proc doShiftRight {shiftChar} {
  168.     set start [lineStart [getPos]]
  169.     set end [nextLineStart [expr [selEnd] - 1]]
  170.     if {$start >= $end} {set end [nextLineStart $start]}
  171.     
  172.     set text [split [getText $start [expr $end - 1]] "\r"]
  173.     
  174.     set textout ""
  175.     
  176.     foreach line $text {
  177.         lappend textout $shiftChar$line
  178.     }
  179.     
  180.     set text [join $textout "\r"]    
  181.     replaceText $start [expr $end - 1] $text
  182.     select $start [expr 1 + $start + [string length $text]]
  183. }
  184.  
  185.  
  186.  
  187.  
  188.  
  189. proc selectAll {} {
  190.     select 0 [maxPos]
  191. }
  192.  
  193. # Select the next or current word. If word already selected, will go to next.
  194. proc hiliteWord {} {
  195.     if {[getPos]!=[selEnd]}    forwardChar
  196.     forwardWord
  197.     set start [getPos]
  198.     backwardWord
  199.     select $start [getPos]
  200. }
  201.  
  202. proc twiddle {} {
  203.     set pos [getPos]
  204.     if {!$pos} return
  205.     if {$pos == [maxPos] || $pos == [expr [nextLineStart $pos] -1]} {
  206.         set incr -1
  207.     } else {
  208.         set incr 0
  209.     }
  210.     if {[string length [set text [getSelect]]]} {
  211.         if {[string length $text] == 1} {
  212.             return
  213.         } else {
  214.             set sel [expr [selEnd] + $incr]
  215.             set one [lookAt [expr $sel -1]]
  216.             set two [lookAt $pos]
  217.             replaceText $pos $sel "$one[getText [expr $pos+1] [expr $sel -1]]$two"
  218.             select $pos $sel
  219.             return
  220.         }
  221.     }
  222.     incr pos $incr
  223.     set one [lookAt $pos]
  224.     set two [lookAt [expr $pos-1]]
  225.     replaceText [expr $pos-1] [expr $pos + 1] "$one$two"
  226.     select  [expr $pos-1] [expr $pos + 1]
  227. }
  228.  
  229. proc twiddleWords {} {
  230.     global wordBreakPreface wordBreak
  231.     set pos [getPos]
  232.     if {$pos == [maxPos] || $pos == [expr [nextLineStart $pos] -1]} {
  233.         set eol 1
  234.     } else {
  235.         set eol 0
  236.     }
  237.     if {[getPos] != [selEnd]} {
  238.         set start1 [getPos]; set end2 [selEnd]
  239.         select $start1
  240.         forwardWord; set end1 [getPos]
  241.         goto $end2
  242.         backwardWord; set start2 [getPos]
  243.     } else {
  244.         if {$eol} {
  245.             backwardWord; set pos [getPos]
  246.         }
  247.         select $pos
  248.         backwardWord; set start1 [getPos]
  249.         forwardWord; set end1 [getPos]
  250.         goto $pos
  251.         forwardWord; set end2 [getPos]
  252.         backwardWord; set start2 [getPos]
  253.     }        
  254.  
  255.     if {$start1 != $start2} {
  256.         set mid [getText $end1 $start2]
  257.         replaceText $start1 $end2 "[getText $start2 $end2]$mid[getText $start1 $end1]"
  258.         select $start1 $end2
  259.     }
  260. }
  261.  
  262. # proc commentLine {} {insertPrefix}
  263. proc commentLine {} {
  264.     global mode
  265.     if { $mode != "C" && $mode != "C++" } {
  266.         insertPrefix
  267.     } else {
  268.         set ext  [file extension [win::CurrentTail]]
  269.         if { $ext == ".h" || $ext == ".c" } {
  270.             beginningOfLine
  271.             insertText "/* "
  272.             endOfLine
  273.             insertText " */"
  274.             beginningOfLine
  275.         } else {
  276.             insertPrefix
  277.         } 
  278.     }
  279. }
  280.  
  281. proc uncommentLine {} {removePrefix}
  282. proc insertPrefix {} {doPrefix insert}
  283. proc removePrefix {} {doPrefix remove}
  284. proc doPrefix {which} {
  285.     global prefixString
  286.     if {[set start [getPos]] == [set end [selEnd]]} {
  287.         set end [nextLineStart $start]
  288.     }
  289.     set start [lineStart $start]
  290.     set text [getText $start $end]
  291.     replaceText $start $end [doPrefixText $which $prefixString $text]
  292.     select $start [getPos]
  293. }
  294. proc quoteChar {} {
  295.     message "Literal keystroke to be inserted:"
  296.     insertText [getChar]
  297. }
  298.  
  299. proc setPrefix {} {
  300.     global prefixString
  301.     if {[catch {prompt "New Prefix String:" $prefixString} res] == 1} return
  302.     set prefixString $res
  303. }
  304.  
  305. proc setSuffix {} {
  306.     global suffixString
  307.     if {[catch {prompt "New Suffix String:" $suffixString} res] == 1} return
  308.     set suffixString $res
  309. }
  310.  
  311. proc insertSuffix {} {doSuffix insert}
  312. proc removeSuffix {} {doSuffix remove}
  313. proc doSuffix {which} {
  314.     global suffixString
  315.     set pts [getEndpts]
  316.     set start [lindex $pts 0]
  317.     set end [lindex $pts 1]
  318.     set start [lineStart $start]
  319.     set end [nextLineStart [expr $end-1]]
  320.     set text [getText $start $end]
  321.     set text [doSuffixText $which $suffixString $text]
  322.     replaceText $start $end $text
  323.     select $start [getPos]
  324. }
  325.  
  326. proc commentBox {} {
  327.  
  328. # Preliminaries
  329.     if [commentGetRegion Box] { return }
  330.     
  331.     set commentList [commentCharacters Box]
  332.     if { [llength $commentList] == 0 } { return }
  333.     
  334.     set begComment [lindex $commentList 0]
  335.     set begComLen [lindex $commentList 1]
  336.     set endComment [lindex $commentList 2]
  337.     set endComLen [lindex $commentList 3]
  338.     set fillChar [lindex $commentList 4]
  339.     set spaceOffset [lindex $commentList 5]
  340.  
  341.     set aSpace " "
  342.  
  343. # First make sure we grab a full block of lines and adjust highlight
  344.  
  345.     set start [getPos]
  346.     set start [lineStart $start]
  347.     set end [selEnd]
  348.     set end [nextLineStart [expr $end-1]]
  349.     select $start $end
  350.  
  351. # Now get rid of any tabs
  352.     
  353.     if { $end < [maxPos] } {
  354.         createTMark stopComment [expr $end+1]
  355.         tabsToSpaces
  356.         gotoTMark stopComment
  357.         set end [expr [getPos]-1]
  358.         removeTMark stopComment
  359.     } else {
  360.         tabsToSpaces
  361.         set end [maxPos]
  362.     }
  363.     select $start $end
  364.     set text [getText $start $end]
  365.     
  366. # Next turn it into a list of lines--possibly drop an empty 'last line'
  367.  
  368. # VMD May'95: changed this code segment because it
  369. # previously had problems with empty lines in the
  370. # middle of the text to be commented
  371.  
  372.     set lineList [split $text "\r"]
  373.     set ll [llength $lineList]
  374.     if { [lindex $lineList [expr $ll -1] ] == {} } {
  375.         set lineList [lrange $lineList 0 [expr $ll -2] ]
  376.     }
  377.     set numLines [llength $lineList]
  378.  
  379. # end changes.
  380.     
  381. # Find the longest line length and determine the new line length
  382.  
  383.     set maxLength 0
  384.     foreach thisLine $lineList {
  385.         set thisLength [string length $thisLine]
  386.         if { $thisLength > $maxLength } { 
  387.             set maxLength $thisLength 
  388.         }
  389.     }
  390.     set newLength [expr $maxLength + 2 + 2*$spaceOffset]
  391.     
  392. # Now create the top & bottom bars and a blank line
  393.  
  394.     set topBar $begComment
  395.     for { set i 0 } { $i < [expr $newLength - $begComLen] } { incr i } {
  396.         set topBar $topBar$fillChar
  397.     }
  398.     set botBar ""
  399.     for { set i 0 } { $i < [expr $newLength - $endComLen] } { incr i } {
  400.         set botBar $botBar$fillChar
  401.     }
  402.     set botBar $botBar$endComment
  403.     set blankLine $fillChar
  404.     for { set i 0 } { $i < [expr $newLength - 2] } { incr i } {
  405.         set blankLine $blankLine$aSpace
  406.     }
  407.     set blankLine $blankLine$fillChar
  408.     
  409. # For each line add stuff on left and spaces and stuff on right for box sides
  410. # and concatenate everything into 'text'.  Start with topBar; end with botBar
  411.  
  412.     set text $topBar\r$blankLine\r
  413.     
  414.     set frontStuff $fillChar
  415.     set backStuff $fillChar
  416.     for { set i 0 } { $i < $spaceOffset } { incr i } {
  417.         set frontStuff $frontStuff$aSpace  
  418.         set backStuff $aSpace$backStuff
  419.     }
  420.     set backStuffLen [string length $backStuff]
  421.     
  422.     for { set i 0 } { $i < $numLines } { incr i } {
  423.         set thisLine [lindex $lineList $i ]
  424.         set thisLine $frontStuff$thisLine
  425.         set thisLength [string length $thisLine]
  426.         set howMuchPad [expr $newLength - $thisLength - $backStuffLen]
  427.         for { set j 0 } { $j < $howMuchPad } { incr j } {
  428.             set thisLine $thisLine$aSpace 
  429.         }
  430.         set thisLine $thisLine$backStuff
  431.         set text $text$thisLine\r
  432.     }
  433.     
  434.     set text $text$blankLine\r$botBar\r
  435.     
  436. # Now replace the old stuff, turn spaces to tabs, and highlight
  437.  
  438.     replaceText    $start $end    $text
  439.     set    end    [expr $start+[string length $text]]
  440.     frontSpacesToTabs $start $end
  441. }
  442.  
  443. proc uncommentBox {} {
  444.  
  445. # Preliminaries
  446.     if [commentGetRegion Box 1] { return }
  447.     
  448.     set commentList [commentCharacters Box]
  449.     if { [llength $commentList] == 0 } { return }
  450.     
  451.     set    begComment [lindex $commentList    0]
  452.     set    begComLen [lindex $commentList 1]
  453.     set    endComment [lindex $commentList    2]
  454.     set    endComLen [lindex $commentList 3]
  455.     set    fillChar [lindex $commentList 4]
  456.     set    spaceOffset    [lindex    $commentList 5]
  457.  
  458.     set aSpace " "
  459.     set aTab \t
  460.  
  461. # First make sure we grab a full block of lines
  462.  
  463.     set start [getPos]
  464.     set start [lineStart $start]
  465.     set end [selEnd]
  466.     set end [nextLineStart [expr $end-1]]
  467.     set text [getText $start $end]
  468.  
  469. # Make sure we're at the start and end of the box
  470.  
  471.     set startOK [string first $begComment $text]
  472.     set endOK [string last $endComment $text]
  473.     set textLength [string length $text]
  474.     if { $startOK != 0 || ($endOK != [expr $textLength-$endComLen-1] || $endOK == -1) } {
  475.         alertnote "You must highlight the entire comment box, including the borders."
  476.         return
  477.     }
  478.     
  479. # Now get rid of any tabs
  480.     
  481.     if { $end < [maxPos] } {
  482.         createTMark stopComment [expr $end+1]
  483.         tabsToSpaces
  484.         gotoTMark stopComment
  485.         set end [expr [getPos]-1]
  486.         removeTMark stopComment
  487.     } else {
  488.         tabsToSpaces
  489.         set end [maxPos]
  490.     }
  491.     select $start $end
  492.     set text [getText $start $end]
  493.     
  494. # Next turn it into a list of lines--possibly drop an empty 'last line'
  495.  
  496. # VMD May'95: changed this code segment because it
  497. # previously had problems with empty lines in the
  498. # middle of the text to be commented
  499.  
  500.     set lineList [split $text "\r"]
  501.     set ll [llength $lineList]
  502.     if { [lindex $lineList [expr $ll -1] ] == {} } {
  503.         set lineList [lrange $lineList 0 [expr $ll -2] ]
  504.     }
  505.     set numLines [llength $lineList]
  506.  
  507. # end changes.
  508.     
  509. # Delete the first and last lines, recompute number of lines
  510.  
  511.     set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
  512.     set lineList [lreplace $lineList 0 0 ]
  513.     set numLines [llength $lineList]
  514.     
  515. # Eliminate 2nd and 2nd-to-last lines if they are empty
  516.  
  517.     set eliminate $fillChar$aSpace$aTab
  518.     set thisLine [lindex $lineList [expr $numLines-1]]
  519.     set thisLine [string trim $thisLine $eliminate]
  520.     if { [string length $thisLine] == 0 } {
  521.         set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
  522.     }
  523.     set thisLine [lindex $lineList 0]
  524.     set thisLine [string trim $thisLine $eliminate]
  525.     if { [string length $thisLine] == 0 } {
  526.         set lineList [lreplace $lineList 0 0 ]
  527.     }
  528.     set numLines [llength $lineList]    
  529.     
  530. # For each line trim stuff on left and spaces and stuff on right and splice
  531.  
  532.     set dropFromLeft [expr $spaceOffset+1]
  533.     set text ""
  534.     for { set i 0 } { $i < $numLines } { incr i } {
  535.         set thisLine [lindex $lineList $i]
  536.         set thisLine [string trimright $thisLine $eliminate]
  537.         set thisLine [string range $thisLine $dropFromLeft end]
  538.         set text $text$thisLine\r
  539.     }
  540.         
  541. # Now replace the old stuff, convert spaces back to tabs
  542.  
  543.     replaceText    $start $end    $text
  544.     set end [expr $start+[string    length $text]]
  545.     frontSpacesToTabs $start $end
  546. }
  547.  
  548. ## 
  549.  # -------------------------------------------------------------------------
  550.  #     
  551.  # "commentCharacters" --
  552.  #    
  553.  #    Adds the 'general' purpose characters which
  554.  #    are    used to    check if we're in a    comment    block.
  555.  #    Also has a check for an array entry like this:
  556.  #    
  557.  #    set C++::commentCharacters(General) [list "*" "//"]
  558.  #    
  559.  #    or
  560.  #    
  561.  #    set commentCharacters(C++:General) [list "*" "//"]
  562.  #    
  563.  #    If such an entry exists, it is returned.  This allows mode authors
  564.  #    to keep everything self-contained.
  565.  # -------------------------------------------------------------------------
  566.  ##
  567. proc commentCharacters {purpose} {
  568.     global mode commentCharacters
  569.     global ${mode}::commentCharacters
  570.     # allows a mode to define these things itself.
  571.     if [info exists ${mode}::commentCharacters(${purpose})] {
  572.         return [set ${mode}::commentCharacters(${purpose})]
  573.     }    
  574.     if [info exists commentCharacters(${mode}:${purpose})] {
  575.         return $commentCharacters(${mode}:${purpose})
  576.     }    
  577.     switch -- $purpose {
  578.         "General" {
  579.             switch -- $mode {
  580.                 "TeX" {return "%" }
  581.                 "Text" {return "!" }
  582.                 "Fort" {return "C" }
  583.                 "Scil" {return "//" }
  584.                 "Perl" -
  585.                 "Tcl" {return "\#" }
  586.                 "C" {return "*" }
  587.                 "Java" -
  588.                 "C++" {return [list "*" "//"] }
  589.                 "HTML" {return "<!--"}
  590.                 default {
  591.                     return
  592.                 }
  593.             }
  594.         }        
  595.         "Paragraph" {        
  596.             switch -- $mode {
  597.                 "TeX" {return [list "%% " " %%" " % "] }
  598.                 "Text" {return [list "!! " " !!" " ! "] }
  599.                 "Fort" {return [list "CC " " CC" " C "] }
  600.                 "Scil" {return [list "//" "//" "//"] }
  601.                 "Perl" -
  602.                 "Tcl" {return [list "## " " ##" " # "] }
  603.                 "Java" -
  604.                 "C" -
  605.                 "C++" {return [list "/* " " */" " * "] }
  606.                 "HTML" { return [list "<!--" "-->" "|" ] }
  607.                 default {
  608.                     alertnote "I don't know what comments should look like in this mode.  Sorry."
  609.                     return
  610.                 }
  611.             }
  612.         }
  613.         "Box" {
  614.         switch -- $mode {
  615.                 "TeX" {return [list "%" 1 "%" 1 "%" 3] }
  616.                 "Text" {return [list "!" 1 "!" 1 "!" 3] }
  617.                 "Fort" {return [list "C" 1 "C" 1 "C" 3] }
  618.                 "Scil" {return [list "//" 2 "//"  2 "//" 3] }
  619.                 "Perl" -
  620.                 "Tcl" {return [list "#" 1 "#" 1 "#" 3] }
  621.                 "Java" -
  622.                 "C" -
  623.                 "C++" {return [list "/*" 2 "*/" 2 "*" 3] }
  624.                 "HTML" { return [list "<!--" 4 "-->" 3 "|" 3] }
  625.                 default {
  626.                     alertnote "I don't know what comments should look like in this mode.  Sorry."
  627.                     return
  628.                 }
  629.             }    
  630.         }
  631.     }    
  632.  
  633. }
  634.  
  635. ## 
  636.  # Default is to look for a    paragraph to comment out.
  637.  # If sent '1',    then we    look for a commented region    to 
  638.  # uncomment.
  639.  ##
  640. proc commentGetRegion { purpose {uncomment 0 } } {
  641.     if {[getPos] != [selEnd]} {
  642.         watchCursor
  643.         return 0    
  644.     }
  645.  
  646.     # there's no selection, so we try and generate one
  647.     
  648.     set pos [getPos]
  649.     if $uncomment {
  650.         # uncommenting
  651.         set commentList [commentCharacters $purpose]
  652.         if { [llength $commentList] == 0 } { return 1}
  653.         switch -- $purpose {
  654.             "Box" {
  655.                 set begComment [lindex $commentList 0]
  656.                 set begComLen [lindex $commentList 1]
  657.                 set endComment [lindex $commentList 2]
  658.                 set endComLen [lindex $commentList 3]
  659.                 set fillChar [lindex $commentList 4]
  660.                 set spaceOffset [lindex $commentList 5]
  661.                 
  662.                 # get length of current line
  663.                 set line [getText [lineStart $pos] [nextLineStart $pos] ]
  664.                 set c [string trimleft $line]
  665.                 set slen [expr [string length $line] - [string length $c] ]
  666.                 set start [string range $line 0 [expr $slen -1 ] ]
  667.                 
  668.                 set pos [getPos]
  669.                 
  670.                 if { $start == "" } {
  671.                     set p $pos
  672.                     while { [string first $fillChar $line] == 0 && \
  673.                         [expr [string last $fillChar $line] + [string length $fillChar]] \
  674.                         >= [string length [string trimright $line]] } {
  675.                         set p [nextLineStart $p]
  676.                         set line [getText [lineStart $p] [nextLineStart $p]]
  677.                     }
  678.                     set end [lineStart $p]
  679.                     
  680.                     set p $pos
  681.                     set line "${fillChar}"
  682.                     while { [string first $fillChar $line] == 0 && \
  683.                         [expr [string last $fillChar $line] + [string length $fillChar]] \
  684.                         >= [string length [string trimright $line]] } {
  685.                         set p [prevLineStart $p]
  686.                         set line [getText [prevLineStart $p] [lineStart $p] ]
  687.                     }
  688.                     set begin [prevLineStart $p]
  689.                     
  690.                 } else {
  691.                     set line "$start"
  692.                     set p $pos
  693.                     while { [string range $line 0 [expr $slen -1] ] == "$start" } {
  694.                         set p [nextLineStart $p]
  695.                         set line [getText [lineStart $p] [nextLineStart $p]]
  696.                     }
  697.                     set end [prevLineStart $p]
  698.                     
  699.                     set p $pos
  700.                     set line "$start"
  701.                     while { [string range $line 0 [expr $slen -1] ] == "$start" } {
  702.                         set p [prevLineStart $p]
  703.                         set line [getText [prevLineStart $p] [lineStart $p] ]
  704.                     }
  705.                     set begin [lineStart $p]
  706.                 }
  707.  
  708.                 set beginline [getText $begin [nextLineStart  $begin]]
  709.                 if { [string first "$begComment" "$beginline" ] != $slen } {
  710.                     message "First line failed"
  711.                     return 1
  712.                 }
  713.                 
  714.                 set endline [getText $end [nextLineStart $end]]
  715.                 set epos [string last "$endComment" "$endline"]
  716.                 incr epos [string length $endComment]
  717.                 set s [string range $endline $epos end ]
  718.                 set s [string trimright $s]
  719.                 
  720.                 if { $s != "" } {
  721.                     message "Last line failed"
  722.                     return 1
  723.                 }
  724.                 
  725.                 set end [nextLineStart $end]
  726.                 select $begin $end
  727.                 #alertnote "Sorry auto-box selection not yet implemented"
  728.             }
  729.             "Paragraph" {
  730.                 set begComment [lindex $commentList 0]
  731.                 set endComment [lindex $commentList 1]
  732.                 set fillChar [lindex $commentList 2]
  733.                 
  734.                 ## 
  735.                  # basic idea is search    back and forwards for lines
  736.                  # that    don't begin    the    same way and then see if they
  737.                  # match the idea of the beginning and end of a    block
  738.                  ##
  739.                 
  740.                 set line [getText [lineStart $pos] [nextLineStart $pos] ]
  741.                 set chk [string range $line 0 [string first $fillChar $line]]
  742.                 if { [string trimleft $chk] != "" } {
  743.                     message "Not in a comment block"
  744.                     return 1
  745.                 }
  746.                 regsub -all {    } $line " " line
  747.                 set p [string first "$fillChar" "$line"]
  748.                 set start [string range "$line" 0 [expr $p + [string length $fillChar] -1 ]]
  749.                 set ll [commentGetFillLines $start]
  750.                 set begin [lindex $ll 0]
  751.                 set end [lindex $ll 1]
  752.                 
  753.                 set beginline [getText $begin [nextLineStart  $begin]]
  754.                 if { [string first "$begComment" "$beginline" ] != $p } {
  755.                     message "First line failed"
  756.                     return 1
  757.                 }
  758.                 
  759.                 set endline [getText $end [nextLineStart $end]]
  760.                 set epos [string last "$endComment" "$endline"]
  761.                 incr epos [string length $endComment]
  762.                 set s [string range $endline $epos end ]
  763.                 set s [string trimright $s]
  764.                 
  765.                 if { $s != "" } {
  766.                     message "Last line failed"
  767.                     return 1
  768.                 }
  769.                 #goto $end
  770.                 set end [nextLineStart $end]
  771.                 select $begin $end
  772.             }
  773.         }
  774.     } else {
  775.         # commenting out
  776.         set searchString {^[ \t]*$}
  777.         set searchResult1 [search -s -f 0 -r 1 -n $searchString $pos]
  778.         set searchResult2 [search -s -f 1 -r 1 -n $searchString $pos]
  779.         if {[llength $searchResult1]} {
  780.             set posStart [expr [lindex $searchResult1 1] +1]
  781.         } else {
  782.             set posStart 0
  783.         }
  784.         if {[llength $searchResult2]} {
  785.             set posEnd [lindex $searchResult2 0]
  786.         } else {
  787.             set posEnd [expr [maxPos] +1]
  788.             goto [maxPos]
  789.             insertText "\n"
  790.         }
  791.         select $posStart $posEnd
  792.     }
  793.     
  794.      set str "Do you wish to "
  795.      if $uncomment { append str "uncomment" } else { append str "comment out" }
  796.      append str " this region?"
  797.     return ![dialog::yesno $str]
  798. }
  799.  
  800.  
  801. proc prevLineStart { pos } {
  802.     return [lineStart [expr [lineStart $pos]-1]]
  803. }
  804.  
  805. proc commentSameStart { line start } {
  806.     regsub -all {    } "$line" " " line
  807.     if { [string first "$start" "$line"] == 0 } {
  808.         return 1
  809.     } else {
  810.         return 0
  811.     }
  812. }
  813.  
  814. proc commentGetFillLines { start } {
  815.     set pos [getPos]
  816.     regsub -all {[\t]} $start " " start
  817.     set line "$start"
  818.     
  819.     set p $pos
  820.     while { [commentSameStart "$line" "$start"] } {
  821.         set p [nextLineStart $p]
  822.         set line [getText [lineStart $p] [nextLineStart $p]]
  823.     }
  824.     set end [lineStart $p]
  825.     
  826.     set p $pos
  827.     set line "$start"
  828.     while { [commentSameStart "$line" "$start"] } {
  829.         set p [prevLineStart $p]
  830.         set line [getText [prevLineStart $p] [lineStart $p] ]
  831.     }
  832.     set begin [prevLineStart $p]
  833.     return [list $begin $end]
  834. }
  835.  
  836. ## 
  837.  # Author: Vince Darley    <mailto:darley@fas.harvard.edu> 
  838.  ##
  839.  
  840. proc commentParagraph {} {
  841.  
  842. # Preliminaries
  843.     if [commentGetRegion Paragraph] { return }
  844.     
  845.     set commentList [commentCharacters Paragraph]
  846.     if { [llength $commentList] == 0 } { return }
  847.     
  848.     set begComment [lindex $commentList 0]
  849.     set endComment [lindex $commentList 1]
  850.     set fillChar [lindex $commentList 2]
  851.     
  852.  
  853. # First make sure we grab a full block of lines and adjust highlight
  854.  
  855.     set start [getPos]
  856.     set start [lineStart $start]
  857.     set end [selEnd]
  858.     set end [nextLineStart [expr $end-1]]
  859.     select $start $end
  860.  
  861. # Now get rid of any tabs
  862.     
  863.     if { $end < [maxPos] } {
  864.         createTMark stopComment [expr $end+1]
  865.         tabsToSpaces
  866.         gotoTMark stopComment
  867.         set end [expr [getPos]-1]
  868.         removeTMark stopComment
  869.     } else {
  870.         tabsToSpaces
  871.         set end [maxPos]
  872.     }
  873.     select $start $end
  874.     set text [getText $start $end]
  875.     
  876. # Next turn it into a list of lines--possibly drop an empty 'last line'
  877.  
  878.     set lineList [split $text "\r"]
  879.     set ll [llength $lineList]
  880.     if { [lindex $lineList [expr $ll -1] ] == {} } {
  881.         set lineList [lrange $lineList 0 [expr $ll -2] ]
  882.     }
  883.     set numLines [llength $lineList]
  884.  
  885. # Find left margin for these lines
  886.     set lmargin 100
  887.     for { set i 0 } { $i < $numLines } { incr i } {
  888.         set l [lindex $lineList $i]
  889.         set lm [expr [string length $l] - [string length [string trimleft $l]]]
  890.         if { $lm < $lmargin } { set lmargin $lm }
  891.     }
  892.     set ltext ""
  893.     for { set i 0 } { $i < $lmargin } { incr i } {
  894.         append ltext " "
  895.     }
  896.     
  897. # For each line add stuff on left and concatenate everything into 'text'. 
  898.  
  899.     set text ${ltext}${begComment}\r
  900.     
  901.     for { set i 0 } { $i < $numLines } { incr i } {
  902.         append text ${ltext}${fillChar}[string range [lindex $lineList $i ] $lmargin end]\r
  903.     }
  904.     append text ${ltext}${endComment}\r
  905.     
  906. # Now replace the old stuff, turn spaces to tabs, and highlight
  907.  
  908.     replaceText    $start $end    $text
  909.     set    end    [expr $start+[string length $text]]
  910.     frontSpacesToTabs $start $end
  911. }
  912.  
  913. ## 
  914.  # Author: Vince Darley    <mailto:vince@das.harvard.edu> 
  915.  ##
  916.  
  917. proc uncommentParagraph {} {
  918.  
  919. # Preliminaries
  920.     if [commentGetRegion Paragraph 1] { return }
  921.     
  922.     set commentList [commentCharacters Paragraph]
  923.     if { [llength $commentList] == 0 } { return }
  924.     
  925.     set begComment [lindex $commentList 0]
  926.     set endComment [lindex $commentList 1]
  927.     set fillChar [lindex $commentList 2]
  928.  
  929.     set aSpace " "
  930.     set aTab \t
  931.  
  932. # First make sure we grab a full block of lines and adjust highlight
  933.  
  934.     set start [getPos]
  935.     set start [lineStart $start]
  936.     set end [selEnd]
  937.     set end [nextLineStart [expr $end-1]]
  938.     select $start $end
  939.     set text [getText $start $end]
  940.  
  941. # Find left margin for these lines
  942.     set l [string range $text 0 [string first "\r" $text] ]
  943.     set lmargin [expr [string length $l] - [string length [string trimleft $l]]]
  944.  
  945. # Make sure we're at the start and end of the paragraph
  946.  
  947.     set startOK [string first $begComment $text]
  948.     set endOK [string last $endComment $text]
  949.     set textLength [string length $text]
  950.     if { $startOK != $lmargin || ($endOK != [expr $textLength-[string length $endComment]-1] || $endOK == -1) } {
  951.         alertnote "You must highlight the entire comment paragraph, including the tail ends."
  952.         return
  953.     }
  954.  
  955. # Now get rid of any tabs
  956.     
  957.     if { $end < [maxPos] } {
  958.         createTMark stopComment [expr $end+1]
  959.         tabsToSpaces
  960.         gotoTMark stopComment
  961.         set end [expr [getPos]-1]
  962.         removeTMark stopComment
  963.     } else {
  964.         tabsToSpaces
  965.         set end [maxPos]
  966.     }
  967.     select $start $end
  968.     set text [getText $start $end]
  969.     
  970. # Next turn it into a list of lines--possibly drop an empty 'last line'
  971.  
  972.     set lineList [split $text "\r"]
  973.     set ll [llength $lineList]
  974.     if { [lindex $lineList [expr $ll -1] ] == {} } {
  975.         set lineList [lrange $lineList 0 [expr $ll -2] ]
  976.     }
  977.     set numLines [llength $lineList]
  978.     
  979. # Delete the first and last lines, recompute number of lines
  980.  
  981.     set lineList [lreplace $lineList [expr $numLines-1] [expr $numLines-1] ]
  982.     set lineList [lreplace $lineList 0 0 ]
  983.     set numLines [llength $lineList]
  984.  
  985. # get the left margin
  986.     set lmargin [string first $fillChar [lindex $lineList 0]]
  987.     set ltext ""
  988.     for { set i 0 } { $i < $lmargin } { incr i } {
  989.         append ltext " "
  990.     }
  991.  
  992. # For each line trim stuff on left and spaces and stuff on right and splice
  993.     set eliminate $fillChar$aSpace$aTab
  994.     set dropFromLeft [expr [string length $fillChar] + $lmargin]
  995.     set text ""
  996.     for { set i 0 } { $i < $numLines } { incr i } {
  997.         set thisLine [lindex $lineList $i]
  998.         set thisLine [string trimright $thisLine $eliminate]
  999.         set thisLine ${ltext}[string range $thisLine $dropFromLeft end]
  1000.         set text $text$thisLine\r
  1001.     }
  1002.     
  1003. # Now replace the old stuff, turn spaces to tabs, and highlight
  1004.  
  1005.  
  1006.     replaceText    $start $end    $text
  1007.     set    end    [expr $start+[string length $text]]
  1008.     frontSpacesToTabs $start $end
  1009. }
  1010.  
  1011.  
  1012. proc frontTabsToSpaces { start end } {
  1013.     select $start $end
  1014.     tabsToSpaces
  1015. }
  1016.  
  1017. proc frontSpacesToTabs { start end } {
  1018.     getWinInfo a
  1019.     set sp [string range "              " 1 $a(tabsize) ]
  1020.     set from [lindex [posToRowCol $start] 0]
  1021.     set to [lindex [posToRowCol $end] 0]
  1022.     while {$from <= $to} {
  1023.         set pos [rowColToPos $from 0]
  1024.         # get the leading whitespace of the current line
  1025.         set res [search -s -n -f 1 -r 1 "^\[ \t\]*" $pos]
  1026.         regsub -all "($sp| +\t)" [eval getText $res] "\t" front
  1027.         eval replaceText $res [list $front]
  1028.         incr from
  1029.     }
  1030. }
  1031.  
  1032. proc forwardDeleteWhitespace {} {
  1033.     set p [lindex [search -s -n -f 1 -r 1 {[^ \t\r\n\]} [getPos]] 0]
  1034.     if {$p != ""} {
  1035.         deleteText [getPos] $p
  1036.     }
  1037. }
  1038.