MacFormat 1999 April/macformat-075.iso/Shareware Plus/Applications/Alpha/Tcl/SystemCode/CorePackages/procUtils.tcl

Text File | 1998-12-05 | 5.1 KB | 197 lines | [TEXT/ALFA]

## -*-Tcl-*-
 # ###################################################################
 #  Vince's Additions - an extension package for Alpha
 #
 #  FILE: "procUtils.tcl"
 #                                    created: 2/8/97 {6:18:16 pm}
 #                                last update: 5/12/1998 {11:08:36 pm}
 #  Author: Vince Darley
 #  E-mail: <[e-mail]>
 #    mail: Division of Engineering and Applied Sciences, Harvard University
 #          Oxford Street, Cambridge MA 02138, USA
 #     www: <http://www.fas.harvard.edu/~darley/>
 #
 # Copyright (c) 1997-1998  Vince Darley, all rights reserved
 #
 # ###################################################################
 ##

namespace eval procs {}
proc procs::patchOriginalsFromFile {f {alerts 1} {keepwin ""}} {
    set openWins [winNames -f]
    # get fixed procs
    uplevel \#0 [list source $f]
    # use 'c' to store comments before each proc
    set procs [procs::listInFile $f c]
    # replace all Alpha's originals
    foreach p $procs {
        if {[catch {procs::replace $p 0 1 c}]} {
            # should not happen
            lappend failed $p
        }
    }
    set nowOpen [winNames -f]
    foreach f [lremove -l $nowOpen $openWins] {
        if {$f != $keepwin} {
            bringToFront $f
            goto [minPos]
            killWindow
        }
    }
    if {[info exists failed]} {
        userMessage $alerts "Couldn't find: $failed, this is BAD."
    }
    userMessage $alerts "Replaced [llength $procs] procs successfully."
}

proc procs::listInFile {f {comments ""}} {
    if {$comments != ""} { upvar $comments c }
    # open the window
    file::openQuietly $f
    # get procs in order
    set pos [minPos]
    set markExpr "^\[ \t\]*proc"
    set procs ""
    while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
        set start [lindex $res 0]
        set end [nextLineStart $start]
        set text [lindex [getText $start $end] 1]
        set pos $end
        lappend procs $text
        set c($text) [getText [procs::getCommentPos $start] $start]
    }
    killWindow
    return $procs
}

##
 # -------------------------------------------------------------------------
 #
 # "procs::getCommentPos" --
 #
 #  'p' should be the start of a proc.  This looks for a comment which
 #  precedes that procedure.  It returns the start of such a comment,
 #  or 'p' if none was found.  Blank lines are not allowed.
 # -------------------------------------------------------------------------
 ##
proc procs::getCommentPos {p} {
    set q [prevLineStart $p]
    while {[pos::compare $p > [minPos]]} {
    set pp [lindex [search -n -s -f 1 -m 0 -r 1 -l $p -- "\[ \t\]*#" $q] 0]
    if {$pp == "" || ([pos::compare $pp != $q])} {
        break
    }
    set p $q
    set q [prevLineStart $q]
    }
    return $p
}

proc procs::generate {p} {
    set a "proc $p \{"
    foreach arg [info args $p] {
        if {[info default $p $arg v]} {
            append a "\{[list $arg $v]\} "
        } else {
            append a "$arg "
        }
    }
    set a [string trimright $a]
    append a "\} \{"
    append a [info body $p]
    append a "\}"
    regsub -all "\n" $a "\r" a
    return $a
}

proc procs::replace {p {ask 1} {addAfterLast 0} {comment ""}} {
    if {$comment != ""} { upvar $comment c }
    set f [procs::find $p]
    if {$f != ""} {file::openQuietly $f}
    if {[info exists c($p)] && $c($p) != ""} {
    set newp "$c($p)[procs::generate $p]"
    } else {
    set newp [procs::generate $p]
    }
    if {[catch {set a [search -s -f 1 -r 1 -m 0 "^\[ \t\]*proc\[ \t\]+${p}\[ \t\]" 0]}]} {
    if {!$addAfterLast} {
        if {$ask} {
        alertnote "Failed to find proc"
        }
        error "Failed to find proc"
    } else {
        # we just add it after the last one
        insertText "\r" $newp "\r\r"
        saveUnmodified
        return
    }
    }
    goto [lindex $a 0]
    set entire [procs::findEnclosing [lindex $a 1]]
    if {[info exists c($p)] && $c($p) != ""} {
    set entire [list [procs::getCommentPos [lindex $entire 0]] [lindex $entire 1]]
    }
    eval select $entire
    if {$newp == [getSelect]} {
    message "No change"
    return
    }
    if {$ask} {
    if {![dialog::yesno "Replace this proc?"]} {
        error "Cancelled"
    }
    }
    eval replaceText $entire [list $newp]
    saveUnmodified
}

# If the first brace after 'proc' ends the current line, then
# assume the argument was a single arg with no braces.
proc procs::findEnclosing { pos {type "proc"} {may_move 0}} {
    set start [lindex [search -s -m 0 -r 1 -f 0 "^\[ \t\]*;?($type) " $pos] 0]

    # find the parameter block
    set p1 [lindex [search -s -f 1 "\{" $start] 0]
    set p [matchIt "\{" [pos::math $p1 + 1]]
    if { [string trim [getText $p1 [nextLineStart $p1]]] == "\{" } {
        if {[pos::compare $p < $pos]} {
            error "couldn't get proc"
        } else {
            return [list $start [pos::math $p + 1]]
        }
    }

    # find the body
    set p [lindex [search -s -f 1 "\{" $p] 0]
    # this should not fail.
    if {[catch {set p [matchIt "\{" [pos::math $p + 1]]}]} {
    # work around Alpha bug
    set rem [getPos]
    goto $start
    endOfLine
    balance
    set p [selEnd]
    if {!$may_move} {goto $rem}
    } else {
    set p [pos::math $p + 1]
    }
    if {[pos::compare $p < $pos] } { error "couldn't get proc" }
    return [list $start $p]
}

proc procs::findEnclosingName {pos} {
    set p [lindex [procs::findEnclosing $pos] 0]
    return [lindex [string trim [getText $p [nextLineStart $p]] "\{ \t\r"] 1]
}