PC World 2000 December/PCWorld_2000-12_cd.bin/Komunikace/Comanche/plugins/apache/apacheDumper.tcl

Text File | 2000-11-02 | 15.6 KB | 589 lines

# Things we want to take into account
# - How to deal with ncluded files
# - How to deal with name based virtual hosts
# - How to deal with some directives being disabled

# Included file
#   - Up to a certain point included files are as if they were
#   in the same file, so we could in theory just process it as usual
#
#   - Name based virtual hosts.
#     If we could deliver the parsing in chunks (list of lines) and return
# in chunks, we could:  solve the virtual host stuff and also more easy for
# saving Include files
#
#  Available vars:
#  currentXmlDirectives: List with all xmlDirectives
#                 not yet dumped for the currentScope
#  currentContainer: currentContainer
#
#  currentContainerStack
#  xmlDirectivesStack     (to move up and down between sections)
#
#  parseFile [split [read httpd.conf] \n]
#  parseFile $httpd.conf
#
#
# parseText --
#
#  while [llength $lines] {
#      set data [getLine $lines]
#      set info [type $data]
#
#      # info contains: {type extra_data}
#
#      switch [lindex $info 1] {
#     comment {
#        append buffer
#     } include {
#        # needs to be defined
#     } beginningOfSection {
#        get all lines until end of section
#        processSection
#     } directive {
#        processDirective
#     }
#      }
#  }
#
#
#  processDirective {} {
#      # Belongs to a disabled module?
#      #     yes -> return
#      #     no -> continue
#      # Exists specialCase?
#      # Exists entry in xmlDirectives?
#      # Exists unknown?
#      # If not, ignore it
#
#  }



class apachePrettyDumper {
    variable specialCaseMapping
    variable specialCaseDirectiveMapping
    variable currentXmlDirectives
    variable currentContainer
    variable currentContainerStack
    variable containerList
    variable containerListStack
    variable xmlDirectivesStack
    variable xmlConfDoc

    # need to know if directives enabled or not

    public variable moduleManager

    # For include files
    variable currentFile

    # In Apache all the includes are relative to serveroot, so we do not really need
    # currentFile

    public variable includeroot

    constructor {} {

    # Have to made them global, if inherited
    # by sambaParser does not work

    set currentContainerStack [stack ::#auto]
    set xmlDirectivesStack [stack ::#auto]
    set containerListStack [stack ::#auto]
    }
    method parseText {lines}
    method isSpecialCase
    method setSpecialCase
    method setSpecialCaseDirectiveMapping
    method getLine
    method getTypeOfLine
    method processDirective
    method processSection
    method getXmlDirectivesWithThatName
    method dumpDirective
    method dumpSpecialCase
    method dumpContainer
    method dump
    method dumpFile
    method dumpRest
    method getSection
}

body apachePrettyDumper::dump { xmlConfDocument fileName } {
    # XXX Catch here when file not writable
    if ![file writable $fileName] {
       MessageDlg .d -message "File $fileName not writable by current user!" -title Error -type ok -icon error
       return
    }
    # Set up currentXmlDirectives
    set xmlConfDoc $xmlConfDocument
    set currentContainer [$xmlConfDoc getRootContainer]
    set containerList [$xmlConfDoc getContainers $currentContainer]
    set currentXmlDirectives [$xmlConfDoc getDirectives $currentContainer]
    set currentFile $fileName
    if [catch {dumpFile $fileName 1} kk] {
       MessageDlg .d -message "Error ocurred when writing configuration file\n$kk" -title Error -type ok -icon error
       return
    }
}

# Main tells if it is the main httpd.conf so anything that remains, we dump there

body apachePrettyDumper::dumpFile { fileName {main 0}} {
    set currentFile $fileName
    set f [open $fileName r]
    set text [read $f]
    close $f
    set result [parseText [split $text \n ]]
    if $main {
    append result [dumpRest]
    }
    set f [open $fileName w]
    puts $f $result
    close $f
}

body apachePrettyDumper::parseText { lineList } {
    set result {}
    while {[llength $lineList]} {
    set data [getLine lineList]
    set info [getTypeOfLine $data]
    # info contains: {type ?extra_data?}

    switch [lindex $info 0] {
        comment {
        append result $data\n
        } include {
        set includeFile [lindex $info 1]
        set tmpFile $currentFile
        switch [file pathtype $includeFile] {
            absolute {

            # Do nothing, we can open it

            $this dumpFile $includeFile
            } relative {

            # Ok, we need to prepend the conf directives dir

            set includeFile [file join $includeroot $includeFile]
            if ![file exists $includeFile] {
                puts "Include file $includeFile could not be processed. \
                    Check that it exists and has the right permissions"
            } else {
                  $this dumpFile $includeFile
                  }
            } volumerelative {

            # Um, unsure about what volume relative is.

            puts "Include path was volume relative"
            } default {
            error "Unknown path type"
            }
        }
        set currentFile $tmpFile
        } beginSection {

        # sectionInfo = {value class}

        set sectionInfo [lrange $info 1 2]

        # Returns the lines belonging to the section and
        # the rest

        set sectionResult [getSection $sectionInfo $lineList]
        foreach {section lineList} $sectionResult break;
        append result [processSection $sectionInfo $section]
        } directive {
        append result [processDirective $data]
        } default {
        error "Encountered unexpected [lindex $info 0]"
        }

    }
     }

    return $result
}


# getSection --
#    We have detected the beginning of a section. Now we want to return the lines
# inside the section. It is necessary to abstract this interface, as Samba does not
# mark the end of a section.
#
# sectionInfo
# lineList
#
# returns
#    sectionLines : lines belonging to the section
#    rest:  rest of lines

body apachePrettyDumper::getSection {sectionInfo lineList} {
    set data [getLine lineList]
    set info [getTypeOfLine $data]
    set section {}
    set sectionLines {}
    # Only interested in endOfSection of same type, so we can anidate requests

    # We need to take into account recursive sections, like ifModule sections
    # Any time we encounter a section of the same type we are configuring, count increments
    # Any time we encounter a endSection we decrement
    # To get out of the loop count must be 0

    set sectionTypeMain [string tolower [lindex $sectionInfo 1]]
    set typeOfLine [lindex $info 0]
    set sectionType [string tolower [lindex $info 1]]
    set count 0
    while {![expr [string match $typeOfLine endSection] \
        && [ string match $sectionTypeMain $sectionType ] && !$count]} {
    lappend sectionLines $data
    set data [getLine lineList]
    set info [getTypeOfLine $data]
    set typeOfLine [lindex $info 0]
    set sectionType [string tolower [lindex $info 1]]
    if {[expr [string match $typeOfLine beginSection] && [string match $sectionTypeMain $sectionType]]} {
        incr count
    }
    if {[expr [string match $typeOfLine endSection] && [string match $sectionTypeMain $sectionType ]]} {
       if {$count > 1} {
          incr count -1
       }
    }
    }
    return [list $sectionLines $lineList ]
}

body apachePrettyDumper::dumpRest {} {
    set result \n

    # Now we have left the ones that were not found in the template

    foreach directive $currentXmlDirectives {
    set dirName [string tolower [$directive getName]]

    # Skip disabled directives

     if ![$moduleManager isDirectiveEnabled $dirName] {
        continue
     }
    if [$directive doYouBelongTo unknownDirective] {
        debug "dumping unknown in dumpRest $directive - [$directive getValue]"
        append result [$directive getValue]\n
    } elseif [info exists specialCaseMapping($dirName)] {
        append result [dumpSpecialCase $dirName $directive]
    } else {
        append result [dumpDirective $directive]
    }
    }

    # Same goes with containers

    foreach one $containerList {
    append result [dumpContainer $one]
    set idx [lsearch -exact $containerList $one]
    set containerList [lreplace $containerList $idx $idx]
    }
    return $result
}

body apachePrettyDumper::dumpContainer {container} {
    set result {}
    append result "<[$container getClasses] [$container getName]>\n"
    foreach directive [$xmlConfDoc getDirectives $container] {
    set dirName [string tolower [$directive getName]]
     if [$directive doYouBelongTo unknownDirective] {
         append result [$directive getValue]\n
     } elseif [info exists specialCaseMapping($dirName)] {
        append result [dumpSpecialCase $dirName $directive]
    } else {
        append result [dumpDirective $directive]
    }
    }
    foreach childContainer [$xmlConfDoc getContainers $container] {
    append result [ dumpContainer $childContainer]
    }
    append result "</[$container getClasses]>\n"
    return $result
}

# sectionInfo is a list containing {value class}

body apachePrettyDumper::processSection {sectionInfo data} {

    set result {}
    set value [lindex $sectionInfo 0]
    set class [lindex $sectionInfo 1]

    # Save previous state

    $xmlDirectivesStack push $currentXmlDirectives
    $currentContainerStack push $currentContainer

    # Search for containers with same class and value
    #      How many?
    #          0 -> Do nothing
    #          1 -> Just use that one
    #          >1 -> Is a virtual host?
    #                check serverName
    #                    matches?
    #                    Yes: use that
    #                    none matches: forget

    set matchingContainers {}
    foreach one $containerList {
    set containerClass [$one getClasses]
    if [string match $containerClass $class] {
        if  [string match [$one getName] $value] {
        lappend matchingContainers $one
        }
    }
    }

    switch [llength $matchingContainers] {
    0 {

        # Do nothing

    } 1 {

        set matchingContainer $matchingContainers

        # Remove container from list

        set idx [lsearch -exact $containerList $matchingContainer]
        set containerList [lreplace $containerList $idx $idx]
        $containerListStack push $containerList

        set currentXmlDirectives [$xmlConfDoc getDirectives $matchingContainer]
        set currentContainer $matchingContainer
        set containerList [$xmlConfDoc getContainers $matchingContainer]

        append result "<[$matchingContainer getClasses] [$matchingContainer getName]>\n"

        append result [parseText $data]
        append result [dumpRest]
        append result "</[$matchingContainer getClasses]>\n"

        set containerList [$containerListStack pop]
    } default {

        set commented {

        # By now, just ignore
        # To-do finish this
        # Address name based virtualhost

        if [string match $class virtualhost] {
            # Check for servernames
        }
        }
    }
    }

    set currentXmlDirectives [$xmlDirectivesStack pop]
    set currentContainer [$currentContainerStack pop]


    return $result
}

body apachePrettyDumper::getLine { lineList } {
    upvar $lineList list
    set result [lindex $list 0]
    set list [lrange $list 1 end]
    return $result
}

body apachePrettyDumper::getTypeOfLine { line } {
    set data [string trim $line]
    if {[regexp "^#+" $data] || ![string length $data]} {
    return comment
    } elseif [regexp -nocase "^include (.*)" $data dummy fileName] {
    return [list include $fileName]
    } elseif [regexp "^ *</(.*)>+$" $data dummy class ] {
    return [list endSection $class]
    } elseif [regexp "^ *<+.*>+$" $data] {
    regexp {<([^ ]*) (.*)>}  $data dummy class value
    return [list beginSection  $value [string tolower $class]]
    } else {
    return directive
    }

}

body apachePrettyDumper::processDirective {data} {

    set result {}

    # TODO: check if belongs to disabled module and return if so.

    set dirName [string tolower \
        [lindex [set elements \
        [ ::apacheparserutils::getElements $data ]] 0]]

    if [string match serverroot $dirName] {

    # join is necessary to handle spaces on Windows

    set includeroot [join [lindex $elements 1]]
    }

    if ![$moduleManager isDirectiveEnabled $dirName] {
    return {}
    }

    if [ isSpecialCase $dirName ] {

    set xuiDirectiveName [string tolower $specialCaseDirectiveMapping($dirName)]

    # check if currentXMLDirectives contains xuiDirective associated
    # with this special case

    if [llength [set xuiDirective [ getXmlDirectivesWithThatName $xuiDirectiveName ]]] {

        # yes -> process it append to result
        #        delete from currentXml

        set result [dumpSpecialCase $xuiDirectiveName $xuiDirective]
        set idx [lsearch -exact $currentXmlDirectives $xuiDirective]
        set currentXmlDirectives [lreplace $currentXmlDirectives $idx $idx]
        return $result
    } else {

        # no -> We already processed it return nothing

        return {}
    }

    }

    if [llength [set list [ getXmlDirectivesWithThatName $dirName ]]] {

    # yes --> process it append to result
    #         delete from currentXmlDirectives

    # switch depending if unknown or not

    foreach one $list {
        if [$one doYouBelongTo unknownDirective] {
        append result [$one getValue]\n
        } else {
        append result [dumpDirective $one]
        }
        set idx [lsearch -exact $currentXmlDirectives $one]
        set currentXmlDirectives [lreplace $currentXmlDirectives $idx $idx]
    }
    return $result
    }


    # If we are here it was not found, so we ignore it

    return {}

}

body apachePrettyDumper::getXmlDirectivesWithThatName {dirName} {
    set result {}
    foreach one $currentXmlDirectives {
    if ![string compare [string tolower [$one getName]] $dirName] {
        lappend result $one
    }
    }
    return $result
}

body apachePrettyDumper::dumpDirective {directive} {
    set result {}
    if [$directive doYouBelongTo unknownDirective] {
    set result "[$directive getValue]\n"
    return $result
    }
    set dirName [string tolower [$directive getName]]
    switch [$directive getXuiClass] {
    string - number  {
        set value [$directive getValue]
        if [string compare $value [$directive getDefault]] {
        set value [$directive getValue]
        if {[$directive doYouBelongTo file] || \
            [$directive doYouBelongTo directory] } {
            if [regexp {\ } $value] {
            set value "\"$value\""
            }
        }
        append result "$dirName $value\n"
        }
    } boolean {
        set value [$directive getValue]
        if [string compare $value [$directive getDefault]] {
        switch $value {
            0 {
            append result "$dirName off\n"
            } 1 {
            append result "$dirName on\n"
            }
        }
        }
    } choice {

        # TO-DO: Check if it is multiple choice

        if ![string match [$directive getName] [$directive getDefault]] {
        append result \
            "$dirName [$directive getSelected]\n"
        }
    } default {
        error "No special case and not recognized in dumping\
            [$directive getXuiClass] [$directive getName]"
    }
    }
    if ![string length [string trim $result]] {
    return {}
    } else {
    return $result
    }
}


body apachePrettyDumper::dumpSpecialCase {dirName directive} {
    set result [$specialCaseMapping($dirName) $directive]
    if ![string length [string trim $result]] {
    return {}
    } else {
    return $result
    }
}

body apachePrettyDumper::isSpecialCase {dirName} {
    return [info exists specialCaseDirectiveMapping($dirName)]
}

body apachePrettyDumper::setSpecialCase { procedure args } {

    # Maps xuiObjects -> procedures to dump them

    foreach xuiDirectiveName $args {
    set specialCaseMapping([string tolower $xuiDirectiveName]) \
        $procedure
    }
}

# Sets mapping between directives that are found in httpd.conf and their corresponding
# xuiObject directive. Example, allow and deny httpd.conf directives map to access directive

body apachePrettyDumper::setSpecialCaseDirectiveMapping \
    { xuiDirectiveName args } {
    foreach one $args {
    set specialCaseDirectiveMapping([string tolower $one]) \
        $xuiDirectiveName
    }

}