#----------------------------->  Perl - script  <-----------------------------#
#- Copyright (C) 199x by International Computer Science Institute            -#
#- This file is part of the GNU Sather package. It is free software; you may -#
#- redistribute  and/or modify it under the terms of the  GNU General Public -#
#- License (GPL)  as  published  by the  Free  Software  Foundation;  either -#
#- version 2 of the license, or (at your option) any later version.          -#
#- This  program  is distributed  in the  hope that it will  be  useful, but -#
#- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY -#
#- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/GPL for more details.        -#
#- The license text is also available from:  Free Software Foundation, Inc., -#
#- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA                     -#
#------------->  Please email comments to <bug-sather@gnu.org>  <-------------#

# Script run through the browser that dumps the pre-html information

proc debugPuts { msg } {
#	puts "\nDebug Browser/Web/dump-pre-html-info:${msg}"
}

proc classListInit { } {
    # Create the gModToClasses mapping.
    # mod to classes is a mapping from modules to the classes in them	

    global gModToClasses 
    debugPuts "Initializing class list"
    set classesRet [tkkit_cb allClasses]
    set unsorted [lindex ${classesRet} 0]
    # First go through and just fill in empty entries into gModToClasses, or it
    # won't work later on
    # gModToClasses is a mapping from modulename -> list of classes
    set commandLineModuleName "CommandLine.module"
    foreach class $unsorted {
	set mod [lindex $class 3]
	if { ${mod} == "" } {
	    set gModToClasses($commandLineModuleName) {}
	} else {
	    set gModToClasses($mod) {}
	}
    }
    # Put each class under its appropriate module in gModToClasses 
    # (should really be module table)
    foreach class $unsorted {
	# Get the class name
	set cnm [lindex $class 0]
	# and the file location
	set fileloc [lindex $class 1]
	# and the module in which the class cnm is found
	set mod [lindex $class 3]
	# If the module name is the empty string, assume it is
	# specified directly on the command line
	if { $mod == "" } {   set mod $commandLineModuleName }
	set clist $gModToClasses($mod)
	# puts "$cnm $fileloc $mod Classes:$clist"
	# Set the module's entry to include the class cnm
	if { $clist == {} } {
	    set gModToClasses($mod) [list $cnm ]
	} else {
	    set clist2 [concat $clist [list $cnm]]
	    set gModToClasses($mod) $clist2
	}
    }
    
}


proc dumpState { } {
    # Dumps information about classes that may be used
    # by other code to process the sather code.
    # Iterates overa all classes and dumps the "classInfo" that
    # is provided by the browser
    # Resulting file is of the form:
    #  set gModToClasses(./../Misc/Misc.module) { I_INTERVAL MATRIX }
    #  set gClassDef(I_INTERVAL)   {  ./../Misc/i_interval.sa 5 { 
    #	   { size:INT ./../Misc/i_interval.sa 15 nnnrnnn } 
    #	   { union(I_INTERVAL):I_INTERVAL ./../Misc/i_interval.sa 88 nnnnnnn } 
    #  etc.
    #    } 
    # } 
    #   set gAllClasses { { nodename filename linenumber modulename } 
    #        etc. }

    global gModToClasses

    set res ""
    set gAllClasses [tkkit_cb allClasses]
    set sorted [lsort -increasing -ascii $gAllClasses]
    # First dump an outer file of class names
    set mainfl [open "gen_bs_info_raw_dump.tcl" w]
    puts ${mainfl} "${res} set gAllClasses ${gAllClasses} \n"
    puts "Starting to dump classes"
    set unsortedModules [array names gModToClasses]
    set sortedModules [lsort -increasing -ascii $unsortedModules ]
    foreach module $sortedModules {
	debugPuts "Module:${module}"
	set res  "${res} set gModToClasses($module) { $gModToClasses($module) }\n"
	set classes [lsort -increasing -ascii $gModToClasses($module)]
	debugPuts "dump-pre-html-info: Dumping browser info about "
	dumpGraphs ${classes}
	foreach cl ${classes} {
	    set classNm ${cl}
	    set cdef [tkkit_cb getClassInfo ${classNm}]
	    puts stdout "${cl}" nonewline
	    set res "${res} set gClassDef($classNm) { $cdef }\n"
	}
	# End of a module
	regsub -all {[\$]} $res "\\\$" newRes
	puts $mainfl "$newRes"
    }
    puts "Done with dumping classes ..."
    global gAncs
    global gDescs
    puts	"Dumping ancestors/descendants..."
    set rels [tkkit_cb getRelatives]
    set actualRels [lindex ${rels} 0 ]
    foreach class ${actualRels} {
	set res  ""
	set className [lindex ${class} 0]
	set classAncestors [lindex ${class} 1]
	set classDescendants [lindex ${class} 2]
	set res "${res} set gAncs($className) \{ ${classAncestors} \}\n"
	set res "${res} set gDescs($className) \{ ${classDescendants} \} \n"
	regsub -all {[\$]} $res "\\\$" newRes	
	puts ${mainfl} "$newRes"
    }
    puts "Done dumping."
    close $mainfl
    # Generate dotty graphs for each of the abstract classes

}

proc dumpGraphs { classes } {
    global gNoShowTestClasses

    set gHome [tkkit_cb getHome]

    tkkit_cb setBoolVar gShowConcrete 1
    tkkit_cb setBoolVar gShowAbstract 1
    tkkit_cb setBoolVar gShowModule 0
    tkkit_cb setBoolVar gShowConcreteEdges 0
    tkkit_cb setBoolVar gShowAbstractEdges 1
    set gNoShowTestClasses 0

    foreach class ${classes} {
	set res ""
	set className ${class}
	if { [isAbstract ${className}] } {
	    tkkit_cb setCurClassName ${className}
	    set graphInfo [tkkit_cb getRestrictedLayout " " ]
	    set cleanName [satherCleanName ${className}]
	    set fileName "dotty-${cleanName}.gr"
	    puts stdout "(dotty)" nonewline
	    set fl [open ${fileName} "w"]
	    puts ${fl} ${graphInfo}
	    close ${fl}
	}
    }
}

proc satherCleanName { nodeName } {
    # Replace all the dangerous characters that sather uses
    # in class names
    regsub {\$} ${nodeName} {dol} newName
    regsub {\{} ${newName} {LB} newName2
    regsub {\}} ${newName2} {RB} newName3
    regsub {\}} ${newName2} {RB} newName3
    regsub {\\} ${newName3}  slash newName4
    regsub {\.} ${newName4} dot newName5
    return ${newName5}
}

proc isAbstract { nodeName } {
    set abs [string first "\$" ${nodeName}]
    # possible to return abs != -1 itself?
    if { $abs != -1 } {
	return true
    } else {
	return false
    }
    
}
classListInit
dumpState







