PC World 1997 November/PCWorld_1997-11_cd.bin/software/programy/komix/DATA.Z/stregenera.tcl

Text File | 1996-11-22 | 10KB | 363 lines

#---------------------------------------------------------------------------
#
#      (c)     Cadre Technologies Inc.    1996
#
#      File:           @(#)stregenera.tcl    /main/hindenburg/2
#      Author:         <generated>
#      Description:
#---------------------------------------------------------------------------
# SccsId = @(#)stregenera.tcl    /main/hindenburg/2   22 Nov 1996 Copyright 1996 Cadre Technologies Inc.

# Start user added include file section
# End user added include file section

require "regenerato.tcl"

# This class is the entry point of the Smalltalk
# regenerator.

Class STRegenerator : {Regenerator} {
    constructor
    method destructor
    method regenerate
    method countExclamationMarks
    method isCategoryHeader
    method processCategoryHeader
    method processMethod
    method getLine
    method isCommentLine
    method parseInitialize
    method parseFile

    # Current parsing state, one of initial, inCategory,
    # inMethod, inMethodBody, skippingGeneratedMethod.
    #
    attribute state

    # Indicates whether the last line that was read
    # started in a single quote delimited string.
    #
    attribute startInSingleQuote

    # Indicates whether the last line that was read
    # ended in a single quote delimited string.
    #
    attribute endInSingleQuote

    # Indicates whether the last line that was read
    # started in a double quote delimited string.
    #
    attribute startInDoubleQuote

    # Indicates whether the last line that was read
    # ended in a double quote delimited string.
    #
    attribute endInDoubleQuote

    # Name of the class currently in regeneration.
    #
    attribute currentClassName

    # Name of the class implementation
    # currently in regeneration.
    #
    attribute currentClassImplementation

    # Category Type currently in regeneration:
    # Class or Instance.
    #
    attribute currentCategoryType
}

constructor STRegenerator {class this} {
    set this [Regenerator::constructor $class $this]
    # Start constructor user section
    # End constructor user section
    return $this
}

method STRegenerator::destructor {this} {
    # Start destructor user section
    # End destructor user section
    $this Regenerator::destructor
}


# Regeneration entry point.
#
method STRegenerator::regenerate {this class fileObject} {
    set fileHandler [STFileHandler new]
    $this fileObject $fileObject
    $this fileDesc [$fileHandler openFile $class [$fileHandler stType]]
    if { [$this fileDesc] != "" } {
    $this parseFile
    $fileHandler closeFile [$this fileDesc]
    }
}


# Count the exclamation marks in <line>, from right to left.
# Returns 0 when the line ends in a string.
# Stops counting when a character other than <space> or
# ! is encountered. Returns the count and
# strips the found exclamation marks
# from <line>.
#
method STRegenerator::countExclamationMarks {this line} {
    upvar $line l
    if { (![regexp {!} $l]) || [$this endInDoubleQuote] || [$this endInSingleQuote] } {
    return 0
    }
    set l [string trimright $l]
    set index [expr [string length $l]-1]
    set count 0
    while { ($index >= 0) && ([regexp {[! ]} [string index $l $index] ch]) } {
    set index [expr $index-1]
    if { $ch == "!" } {
        set count [expr $count+1]
    }
    }
    set l [string range $l 0 $index]
    return $count
}


# Returns whether <line> contains a category header.
#
method STRegenerator::isCategoryHeader {this line} {
    if { [string first methodsFor $line] != -1 } {
    return 1
    }
    return 0
}


# Processes <line> (which is a category header).
# Sets currentClassName, currentCategoryType
# and currentClassImplementation.
#
method STRegenerator::processCategoryHeader {this line} {
    regsub -all "!" $line "" tokenList
    if { [llength $tokenList] < 3 } {
    puts "ERROR: bad category header found while regenerating [$this currentClassName]"
    return
    }
    $this currentClassName [lindex $tokenList 0]

    if { [lindex $tokenList 1] == "class" } {
    $this currentCategoryType "Class"
    } else {
    $this currentCategoryType "Instance"
    }

    $this currentClassImplementation [[$this fileObject] getImplementation [$this currentClassName]]
}


# Processes the method found with
# header <header>, temporaries <temporaries> and
# body <expression>:
# Determines selector and arguments, gets a
# method implementation, warns if the method
# is obsolete.
# Adds temporaries, removes code before
# user code marker if it exists and the marker itself.
# Adds the user added code as one expression.
#
method STRegenerator::processMethod {this header temporaries expression} {
    set selector ""
    set isArgument 0
    set arguments [List new]
    foreach part $header {
    if { !$isArgument } {
        set selector "$selector$part"
        set isArgument 1
    } else {
        $arguments append $part
        set isArgument 0
    }
    }

    # do workaround for - as method name: - as parameter is not allowed in tcl
    if { $selector == "-" } {
    set selector "operator-"
    }

    set impl [[$this currentClassImplementation] get[$this currentCategoryType]MethodImplementation $selector ""]

    if { $impl == "" } {
    puts "WARNING: method $selector is obsolete"
    set impl [[$this currentClassImplementation] get[$this currentCategoryType]MethodImplementation $selector obsolete]
    # for obsolete methods we need to insert the argument names
    $arguments foreach argument {
        $impl addArgument $argument
    }
    $impl hasUserCodePart 1
    }

    # do temporaries
    if { $temporaries != "" } {
    regsub -all {\|} [string trim $temporaries] "" tempList
    foreach temporary $tempList {
        $impl addTemporary $temporary
    }
    }

    # delete code before user code marker from expression
    set userMarkerIndex [string first [$globals startUserCodeMarker] $expression]
    if { $userMarkerIndex != -1 } {
    set restIndex [expr $userMarkerIndex+[string length [$globals startUserCodeMarker]]+1]
    set expression [string range $expression $restIndex end]
    }

    if { $expression != "" } {
        $impl addExpression $expression
        $impl hasUserCode 1
    }
}


# Reads <line> from file with descriptor fileDesc,
# returns 0 if end of file.
# Updates the start/end in single/double quote
# attributes based on the contents of
# <line>.
#
method STRegenerator::getLine {this line} {
    upvar $line l
    set l [gets [$this fileDesc]]
    if [eof [$this fileDesc]] {
    return 0
    }

    # update count stuff
    $this startInSingleQuote [$this endInDoubleQuote]
    $this startInDoubleQuote [$this endInDoubleQuote]
    # get only the 's and "'s
    regsub -all {[^"']} $l "" newLine
    foreach char [split $newLine {}] {
    if { $char == "\"" } {
        if { ![$this endInSingleQuote] } {
        $this endInDoubleQuote [expr 1-[$this endInDoubleQuote]]
        }
    } else {
        if { ![$this endInDoubleQuote] } {
        $this endInSingleQuote [expr 1-[$this endInSingleQuote]]
        }
    }
    }
    return 1
}


# Returns whether <line> is a comment line.
#
method STRegenerator::isCommentLine {this line} {
    if { [$this startInDoubleQuote] || [$this endInDoubleQuote] } {
    return 1
    }

    if { [string index [string trim $line] 0] == "\"" } {
    return 1
    }

    return 0
}


# Initializes the parse variables.
#
method STRegenerator::parseInitialize {this} {
    $this startInSingleQuote 0
    $this endInSingleQuote 0
    $this startInDoubleQuote 0
    $this endInDoubleQuote 0
    $this state initial
}


# This method is the parser. Parses the file
# and adds regenerated method bodies.
#
method STRegenerator::parseFile {this} {
    $this parseInitialize

    set line ""
    while { [$this getLine line] } {
    case [$this state] in {
        {initial} {
        if [$this isCategoryHeader $line] {
            $this processCategoryHeader $line
            $this state inCategory
        }
        }
        {inCategory} {
        if { ([string trim $line] != "" ) && (![$this isCommentLine $line]) } {
            set count [$this countExclamationMarks line]
            if $count {
            $this state initial
            } else {
            $this state inMethod
            set methodHeader $line
            set expression ""
            set temporaries ""
            }
        }
        }
        {inMethod} {
        set count [$this countExclamationMarks line]
        if { [string trim $line] == "\"Generated\"" } {
            $this state skippingGeneratedMethod
            continue
        }
        if { ([string trim $line] != "" ) && (![$this isCommentLine $line]) } {
            if { [string index [string trim $line] 0] == "|" } {
            set temporaries [string trim $line]
            } else {
            set expression $line
            }

            $this state inMethodBody
        }
        if $count {
            $this processMethod $methodHeader $temporaries $expression
            if { $count == 1 } {
            $this state inCategory
            } else {
            $this state initial
            }
        }
        }
        {inMethodBody} {
        set count [$this countExclamationMarks line]
        if { $expression != "" } {
            set expression "$expression\n$line"
        } else {
            set expression $line
        }
        if $count {
            $this processMethod $methodHeader $temporaries $expression
            if { $count == 1 } {
            $this state inCategory
            } else {
            $this state initial
            }
        }
        }
        {skippingGeneratedMethod} {
        set count [$this countExclamationMarks line]
        if $count {
            if { $count == 1 } {
            $this state inCategory
            } else {
            $this state initial
            }
        }
        }
    }
    }
}

# Do not delete this line -- regeneration end marker