#!/usr/local/bin/tclsh
#
#	Objectify -- turn C++ classes into Tcl objects.
#
#	Wayne Christopher, faustus@cs.berkeley.edu
#	Version 0.1, May 1, 1993
#
#	Copyright (c) 1993 Wayne Christopher.  Permission is granted
#	to copy, modify and distribute, provided this notice is
#	preserved.  No warranty is provided or implied, etc, etc.

# Definitions for regexp.
set word {[a-zA-Z_][a-zA-Z0-9_]*}
set num {-?[0-9]+}
set sep {[ \t]*,[ \t]*}
set ws {[ \t]*}

# Strip the quotes off a string.
proc noq {str} { return [string trim $str \"] }

proc dump_stuff {object fp doc} {
    global object_names object_type object_tclcmd
    global object_methods object_slots_full object_slots
    
    if {$object_type($object) == "widget"} { set wid 1 } else { set wid 0 }
    
    puts stdout "Creating object $object ..."
    
    puts $fp ""
    put_config_specs $fp $object $wid
    puts $fp ""
    put_create_cmd $fp $object $wid
    puts $fp ""
    put_help_cmd $fp $object
    puts $fp ""
    put_get_cmd $fp $object
    puts $fp ""
    put_object_cmd $fp $object $wid
    puts $fp ""
    put_config_cmd $fp $object
    puts $fp ""
    
    if {$doc != ""} {
	put_documentation $doc $object $wid
    }
}    

proc put_create_cmd {fp object wid} {
    global object_tclcmd
    
    if $wid {set tkwin tkwin} else {set tkwin NULL}
    set obtype $object_tclcmd($object)
    
    puts $fp "static int ${object}ObjectCmd(ClientData clientData,"
    puts $fp "       Tcl_Interp *interp, int argc, char *argv\[\]);"
    puts $fp "static int ${object}_ConfigFunction(Tcl_Interp* interp,"
    puts $fp "       Tk_Window win, int ac, char** av, $object* object,"
    puts $fp "	     int flags, int which);"
    puts $fp ""
    puts $fp "static void"
    puts $fp "${object}DeleteProc(ClientData cld)"
    puts $fp "\{"
    puts $fp "    $object* ob = ($object *) cld;"
    puts $fp "    delete ob;"
    puts $fp "\}"
    puts $fp ""
    puts $fp "static int"
    puts $fp "${object}Cmd(ClientData cld, Tcl_Interp *interp, int ac, char **av)"
    puts $fp "\{"
    if $wid {
	puts $fp "    Tk_Window owin = (Tk_Window) cld;"
	puts $fp "    if (ac < 2) \{"
	puts $fp "        Tcl_AppendResult(interp, \"too few arguments: a window name is required\", 0);"
	puts $fp "        return (TCL_ERROR);"
	puts $fp "    \}"
	puts $fp "    Tk_Window tkwin = Tk_CreateWindowFromPath(interp, owin,"
	puts $fp "                                             av\[1\], NULL);"
	puts $fp "    $object* ob = new $object (interp, tkwin);"
	puts $fp ""
	puts $fp "    if (${object}_ConfigFunction(interp, owin,"
	puts $fp "                      ac - 2, av + 2, ob, 0, 1) != TCL_OK) \{"
	puts $fp "        Tk_DestroyWindow(tkwin);"
	puts $fp "        return (TCL_ERROR);"
	puts $fp "    \}"
	
    } else {
	puts $fp "    $object* ob = new $object (interp);"
	puts $fp "    char* obname = NULL;"
	puts $fp "    if (av\[1\] && (*av\[1\] != '-')) \{"
	puts $fp "        obname = av\[1\];"
	puts $fp "        if (Objectify_LookupName(obname)) \{"
	puts $fp "            Tcl_AppendResult(interp, \"[noq $obtype] \\\"\", obname, \"\\\" already exists\", 0);"
	puts $fp "            return (TCL_ERROR);"
	puts $fp "        \}"
	puts $fp "        av++; ac--;"
	puts $fp "    \}"
	puts $fp ""
	puts $fp "    if (${object}_ConfigFunction(interp, NULL,"
	puts $fp "                      ac - 1, av + 1, ob, 0, 1) != TCL_OK) \{"
	puts $fp "        return (TCL_ERROR);"
	puts $fp "    \}"
	
    }
    puts $fp ""
    if $wid {
	puts $fp "    Tcl_AppendResult(interp, Tk_PathName(tkwin), 0);"
	puts $fp "    Tcl_CreateCommand(interp, Tk_PathName(tkwin), ${object}ObjectCmd, (ClientData) ob, ${object}DeleteProc);"
	
    } else {
	puts $fp "    if (obname) \{"
	puts $fp "        Objectify_SetName(obname, (void *) ob);"
	puts $fp "    \} else \{"
	puts $fp "        char buf\[256\];"
	puts $fp "        Objectify_NewName($obtype, buf, (void *) ob);"
	puts $fp "        obname = buf;"
	puts $fp "    \}"
	puts $fp "    Tcl_AppendResult(interp, obname, 0);"
	puts $fp "    Tcl_CreateCommand(interp, obname, ${object}ObjectCmd, (ClientData) ob, ${object}DeleteProc);"
    }
    puts $fp "    return (TCL_OK);"
    puts $fp "\}"
}

proc put_object_cmd {fp object wid} {
    global object_methods object_parents object_tclcmd

    set num 0
    puts $fp "static int"
    puts $fp "${object}ObjectCmd(ClientData cld, Tcl_Interp *interp, int ac, char **av)"
    puts $fp "\{"
    puts $fp "    $object *ob = ($object *) cld;"
    puts $fp "    if (ac < 2) \{"
    puts $fp "        Tcl_AppendResult(interp, \"too few arguments to the \","
    puts $fp "                         av\[0\], \" object command\", 0);"
    puts $fp "        return (TCL_ERROR);"
    puts $fp "    \}"
    puts $fp "    int ret = TCL_OK;"
    puts $fp "    extern int ${object}_TryObjectCmd($object*,"
    puts $fp "             Tcl_Interp*, int, char**, int*);"
    puts $fp "    if (${object}_TryObjectCmd(ob, interp, ac, av, &ret))"
    puts $fp "        return (ret);"

    set names {}
    foreach method $object_methods($object) {
	lappend names [noq [lindex $method 0]]
    }
    
    puts $fp "    Tcl_AppendResult(interp, \"invalid method name \\\"\","
    puts $fp "                 av\[1\], \"\\\"; must be one of: $names\", 0);"
    if {$object_parents($object) != ""} {
	puts $fp "    Tcl_AppendResult(interp, \", or a method for one of the objects: $object_parents($object)\", 0);"
    }
    puts $fp "    return (TCL_ERROR);"
    puts $fp "\}"
    
    # ---------------------------------------------------------

    puts $fp ""
    puts $fp "int"
    puts $fp "${object}_TryObjectCmd($object *ob, Tcl_Interp *interp,"
    puts $fp "            int ac, char **av, int* retp)"
    puts $fp "\{"
    puts $fp "    char* com = av\[1\];"
    puts $fp "    char c = com\[0\];"
    
    # Toss in all the special ones.
    puts $fp "    if ((c == 'c') && (!strcmp(com, \"configure\") || !strcmp(com, \"config\"))) \{"
    if $wid {
	puts $fp "        *retp = ${object}_ConfigFunction(interp, ob->tkwin, ac-2, av+2,"
	puts $fp "			        ob, TK_CONFIG_ARGV_ONLY, 0);"
    } else {
	puts $fp "        *retp = ${object}_ConfigFunction(interp, NULL, ac-2, av+2,"
	puts $fp "			        ob, TK_CONFIG_ARGV_ONLY, 0);"
    }
    puts $fp "        return (1);"
    puts $fp "    \}"
    
    puts $fp "    if ((c == 'g') && !strcmp(com, \"get\")) \{"
    #puts $fp "        static int ${object}_GetFunction(Tcl_Interp* interp,"
    #puts $fp "                            Tk_Window tkwin, char* name, ${object}* ob);"
    if $wid {
	puts $fp "        *retp = ${object}_GetFunction(interp, ob->tkwin, av\[2\], ob);"
    } else {
	puts $fp "        *retp = ${object}_GetFunction(interp, NULL, av\[2\], ob);"
    }
    puts $fp "        return (1);"
    puts $fp "    \}"
    
    puts $fp "    if ((c == 'd') && !strcmp(com, \"delete\")) \{"
    puts $fp "        if (ob->BeforeDelete(interp) != TCL_OK) \{ *retp = TCL_ERROR; return (1); \}"
    if $wid {
	puts $fp "        Tcl_DeleteCommand(interp, Tk_PathName(ob->tkwin));"
	puts $fp "        Tk_DestroyWindow(ob->tkwin);"
    } else {
	puts $fp "        Tcl_DeleteCommand(interp, av\[0\]);"
    }
    set obtype $object_tclcmd($object)
    puts $fp "        Objectify_DeleteName(av\[0\]);"
    puts $fp "        return (1);"
    puts $fp "    \}"
    
    puts $fp "    if ((c == 'h') && !strcmp(com, \"help\")) \{"
    #puts $fp "        static void ${object}AppendHelp(Tcl_Interp* interp, char* what);"
    puts $fp "        if (ac < 3) \{"
    puts $fp "            ${object}AppendHelp(interp, \"summary\");"
    puts $fp "        \} else \{"
    puts $fp "            for (int i = 2; i < ac; i++) \{"
    puts $fp "                ${object}AppendHelp(interp, av\[i\]);"
    puts $fp "                if (i < ac - 1) Tcl_AppendResult(interp, \"\\n\", 0);"
    puts $fp "            \}"
    puts $fp "        \}"
    puts $fp "        return (1);"
    puts $fp "    \}"
    
    foreach method $object_methods($object) {
	incr num
	set tcl_com [string trim [lindex $method 0] \"]
	set tcl_char [string index $tcl_com 0]

	set c_com [lindex $method 1]
	
	puts $fp "    if ((c == '$tcl_char') &&"
	puts $fp "        !strcmp(com, \"$tcl_com\")) \{"
	
	if ![regexp {(.*)\((.*)\)} $c_com dummy comname args] {
	    error "Old-style method declaration!"
	}
	
	# Now we have to muck around and parse the arguments.
	# We can be arbitrarily fancy here but we won't.  Assume that
	# if there is some wierd type that we don't understand, it
	# is a custom thing.
	if $wid {
	    set stuff [parse_arglist $args ob->tkwin]
	} else {
	    set stuff [parse_arglist $args NULL]
	}
	set nargs [lindex $stuff 0]
	set arguments [lindex $stuff 1]
	set last_varargs [lindex $stuff 2]
	
	if {$last_varargs != ""} {
	    puts $fp "        if (ac < $nargs + 2) \{"
	    puts $fp "            Tcl_AppendResult(interp, \"wrong number of args: at least $nargs expected\", 0);"
	    puts $fp "            *retp = TCL_ERROR; return (1);"
	    puts $fp "        \}"
	} else {
	    puts $fp "        if (ac != $nargs + 2) \{"
	    puts $fp "            Tcl_AppendResult(interp, \"wrong number of args: $nargs expected\", 0);"
	    puts $fp "            *retp = TCL_ERROR; return (1);"
	    puts $fp "        \}"
	}
	
	set arglist ""
	set n 0
	foreach arg $arguments {
	    puts $fp $arg
	    if $n {set arglist "$arglist, "}
	    set arglist "${arglist}arg$n"
	    incr n
	}
	if {$last_varargs != ""} {
	    puts $fp "$last_varargs"
	    if $n {set arglist "$arglist, "}
	    set arglist "${arglist}rest_argc, rest_argv"
	}
	puts $fp "        *retp = ob->$comname ($arglist);"
	puts $fp "        return (1);"
	puts $fp "    \}"
    }
    
    foreach parent $object_parents($object) {
	puts $fp "    extern int ${parent}_TryObjectCmd($parent*,"
	puts $fp "          Tcl_Interp*, int, char**, int*);"
        puts $fp "    if (${parent}_TryObjectCmd(($parent *) ob, interp,"
	puts $fp "                                ac, av, retp))"
	puts $fp "        return (1);"
    }
        puts $fp "    return (0);"
    puts $fp "\}"

    puts stdout "\t$num methods"
}

# This returns a list: for each argument, a bit of code to parse that arg.
# The args are named arg0 arg1 ... argN.
# If there are varargs at the end, they are named rest_argc and rest_argv.

proc parse_arglist {arglist ww} {
    set num 0
    set argno 2
    set results {}
    set last_varargs ""
    
    set arglist [split $arglist ,]
    set nargs [llength $arglist]
    set last1 [lindex $arglist [expr {$nargs - 1}]]
    set last2 [lindex $arglist [expr {$nargs - 2}]]
    if {[regexp {^[ 	]*int.*} $last2 dummy] && \
	    [regexp {^[ 	]*char[ 	]*\*[ 	]*\*.*} \
	    $last1 dummy]} {
	incr nargs -2
        set arglist [lrange $arglist 0 [expr {$nargs - 1}]]
	set last_varargs 1
  }
    
    foreach arg $arglist {
	if {[regexp {^[ 	]*int.*} $arg dummy]} {
	    set res "        int arg$num;\n\
        if (Tcl_GetInt(interp, av\[$argno\], &arg$num) != TCL_OK)\n\
            \{ *retp = TCL_ERROR; return (1); \}"
	    incr argno
	    
	} elseif {[regexp {^[ 	]*long.*} $arg dummy]} {
	    set res "        long arg$num;\n\
        if ((av\[$argno\]\[0\] == '0') && (av\[$argno\]\[1\] == 'x')) \{ \n\
		if (sscanf(av\[$argno\], \"0x%lx\", &arg$num) != 1) \{ \n\
			Tcl_AppendResult(interp, \"bad long\", 0); \n\
			*retp = TCL_ERROR; \n\
			return (1); \n\
		\} \n\
	\} else \{ \n\
		if (sscanf(av\[$argno\], \"%ld\", &arg$num) != 1) \{ \n\
            		Tcl_AppendResult(interp, \"bad long\", 0); \n\
			*retp = TCL_ERROR; \n\
			return (1); \n\
		\} \n\
	\}"
	    incr argno
	    
	} elseif [regexp {^[ 	]*double.*} $arg dummy] {
	    set res "        double arg$num;\n\
        if (Tcl_GetDouble(interp, av\[$argno\], &arg$num) != TCL_OK)\n\
            \{ *retp = TCL_ERROR; return (1); \}"
	    incr argno
	
	} elseif [regexp {^[ 	]*float.*} $arg dummy] {
	    set res "        float arg$num; double temp$num;\n\
        if (Tcl_GetDouble(interp, av\[$argno\], &temp$num) != TCL_OK)\n\
            \{ *retp = TCL_ERROR; return (1); \}\n\
        arg$num = temp$num;"
	    incr argno
	
	} elseif [regexp {^[ 	]*char[ 	]*\*.*} $arg dummy] {
	    set res "        char* arg$num = av\[$argno\];"
	    incr argno
	    	    
	} elseif [regexp {^[ 	]*Tcl_Interp[ 	]*\*.*} $arg dummy] {
	    set res "        Tcl_Interp* arg$num = interp;"
	} else {
	    # It must be something wierd.  Assume there is a Tk_CustomOption
	    # named Foo_ConfigOption, where Foo is the first word of the
	    # thing.  If the thing is of the form Foo*, then assume the
	    # option is called FooPtr_ConfigOption.
	    if [regexp {^[ 	]*([A-Za-z_]*)[ 	]*\*.*} \
		$arg dummy thing] {
		set name ${thing}Ptr
		set type "$thing *"
	    } elseif [regexp {^[ 	]*([A-Za-z_]*).*} \
		      $arg dummy thing] {
		set name $thing
		set type $thing
	    } else {
		error "Can't parse $arg as anything.  Strange."
	    }
	    set copt ${name}_ConfigOption
	    set res "        extern Tk_CustomOption $copt;\n\
        $type arg$num;\n\
        if ((*$copt.parseProc) ($copt.clientData, interp, $ww, av\[$argno\],\n\
             (char *) &arg$num, 0) != TCL_OK) \{ *retp = TCL_ERROR; return (1); \}"
	    incr argno
	}
	
	lappend results $res
	incr num
    }
    if {$last_varargs != ""} {
	set last_varargs "        int rest_argc = ac - $argno;\n\
		char** rest_argv = av + $argno;\n"
    }
    incr argno -2
    return [list $argno $results $last_varargs]
}

proc put_config_specs {fp object wid} {
    global object_slots_full object_slots

    set num 0
    puts $fp "static Tk_ConfigSpec ${object}_ConfigSpecs\[\] = \{"
    foreach slot $object_slots_full($object) {
	incr num
	set i 0
	foreach v {type ctype var arg db class def flags cust} {
	    set $v [lindex $slot $i]; incr i
	}
	puts $fp "    \{ TK_CONFIG_$type, $arg, $db, $class,"
	puts $fp "      $def, Tk_Offset($object, $var), $flags, $cust \},"
    }
    foreach slot $object_slots($object) {
	incr num
	set i 0
	foreach v {type ctype var arg def cust} {
	    set $v [lindex $slot $i]; incr i
	}
	set flags 0
	if {[string index $arg 0] == "\""} {
	    set db \"[string range $arg 2 end]
	    set class \"[string toupper [string index $db 1]][string range $db 2 end]
	} else {
	    set db $arg
	    set class $arg
	}
	puts $fp "    \{ TK_CONFIG_$type, $arg, $db, $class,"
	puts $fp "      $def, Tk_Offset($object, $var), $flags, $cust \},"
    }
    puts $fp "    \{ TK_CONFIG_END, NULL, NULL, NULL, NULL, 0, 0 \}"
    puts $fp "\};"
    
    puts stdout "\t$num slots"
}

proc put_config_cmd {fp object} {
    global object_parents object_type
    
    puts $fp "int"
    puts $fp "${object}_ConfigSubFunc(Tcl_Interp* interp, Tk_Window win,"
    puts $fp "	        int ac, char** av, $object* object,"
    puts $fp "          int flags, int* eaten, int which)"
    puts $fp "\{"
    puts $fp "    if (Objectify_Configure(interp, win, ${object}_ConfigSpecs,"
    puts $fp "			    ac, av, (char *) object, flags,"
    puts $fp "			    eaten, which) != TCL_OK)"
    puts $fp "        return (TCL_ERROR);"
    puts $fp ""
    foreach parent $object_parents($object) {
	puts $fp "    extern int ${parent}_ConfigSubFunc(Tcl_Interp*,"
	puts $fp "	    Tk_Window, int, char**, $parent*, int, int*, int);"
	puts $fp "    if (${parent}_ConfigSubFunc(interp, win, ac, av,"
	puts $fp "				 ($parent *) object, flags,"
	puts $fp "				 eaten, which) != TCL_OK)"
	puts $fp "        return (TCL_ERROR);"
	puts $fp "   "
    }
    puts $fp "    return (TCL_OK);"
    puts $fp "\}"
    puts $fp ""
    puts $fp "static int"
    puts $fp "${object}_ConfigFunction(Tcl_Interp* interp, Tk_Window win,"
    puts $fp "             int ac, char** av, $object* object, int flags,"
    puts $fp "             int which)"
    puts $fp "\{"
    puts $fp "    int nocomplain = 0;"
    puts $fp "    if ((ac > 0) && !strcmp(av\[0\], \"-nocomplain\")) \{"
    puts $fp "        nocomplain = 1;"
    puts $fp "        ac--; av++;"
    puts $fp "    \}"
    puts $fp "    int nopts = ((ac > 1) ? (ac / 2) : 1);"
    puts $fp "    int* eaten = new int\[nopts\];"
    puts $fp "    for (int i = 0; i < nopts; i++) eaten\[i\] = 0;"
    puts $fp "    int res = ${object}_ConfigSubFunc(interp, win, ac, av,"
    puts $fp "					  object, flags, eaten, which);"
    puts $fp ""
    puts $fp "    if (ac && !nocomplain && (res == TCL_OK)) \{"
    puts $fp "        for (int i = 0; i < nopts; i++)"
    puts $fp "            if (!eaten\[i\]) \{"
    puts $fp "	              if (res == TCL_OK) Tcl_ResetResult(interp);"
    puts $fp "	              Tcl_AppendResult(interp, \"unknown option \\\"\","
    puts $fp "			           av\[2 * i\], \"\\\"\", 0);"
    puts $fp "	               res = TCL_ERROR;"
    puts $fp "	          \}"
    puts $fp "    \}"
    puts $fp "    delete \[\] eaten;"
    puts $fp "    if (res != TCL_OK) return (res);"
    puts $fp ""
    puts $fp "    if ((ac > 1) &&(object->AfterConfigure(interp) != TCL_OK)) \{"
    if {$object_type($object) == "widget"} {
	puts $fp "        if (object->tkwin && !flags) Tk_DestroyWindow(object->tkwin);"
    }
    puts $fp "        return (TCL_ERROR);"
    puts $fp "    \}"
    puts $fp "    "
    puts $fp "    return (TCL_OK);"
    puts $fp "\}"
}

proc put_get_cmd {fp object} {
    global object_parents object_type
    
    puts $fp "int"
    puts $fp "${object}_GetSubFunc(Tcl_Interp* interp, Tk_Window win,"
    puts $fp "	        char* name, $object* object, int* got)"
    puts $fp "\{"
    puts $fp "    if (Objectify_Get(interp, win, ${object}_ConfigSpecs,"
    puts $fp "			    name, (char *) object, got) != TCL_OK)"
    puts $fp "        return (TCL_ERROR);"
    puts $fp "    if (*got) return (TCL_OK);"
    puts $fp ""
    foreach parent $object_parents($object) {
	puts $fp "    extern int ${parent}_GetSubFunc(Tcl_Interp*,"
	puts $fp "	    Tk_Window, char*, $parent*, int*);"
	puts $fp "    if (${parent}_GetSubFunc(interp, win, name,"
	puts $fp "				 ($parent *) object, got) != TCL_OK)"
	puts $fp "        return (TCL_ERROR);"
	puts $fp "    if (*got) return (TCL_OK);"
	puts $fp "   "
    }
    puts $fp "    return (TCL_OK);"
    puts $fp "\}"
    puts $fp ""
    puts $fp "static int"
    puts $fp "${object}_GetFunction(Tcl_Interp* interp, Tk_Window win,"
    puts $fp "             char* name, $object* object)"
    puts $fp "\{"
    puts $fp "    int got = 0;"
    puts $fp "    int res = ${object}_GetSubFunc(interp, win, name, object, &got);"
    puts $fp ""
    puts $fp "    if (!got) \{"
    puts $fp "        Tcl_AppendResult(interp, \"unknown option \\\"\","
    puts $fp "                         name, \"\\\"\", 0);"
    puts $fp "	       res = TCL_ERROR;"
    puts $fp "    \}"
    puts $fp "    return (res);"
    puts $fp "\}"
}

# Several kinds of help commands can be given:
# help
# help summary
# help all
# help methods
# help slots
# help method-name
# help slot-name

proc put_help_cmd {fp object} {
    global object_help object_tclcmd object_class object_type
    global object_slots_full object_slots object_methods
    
    set slots {}
    set methods {}

    foreach s $object_slots($object) {
	set arg [noq [lindex $s 3]]
	set default [noq [lindex $s 4]]
	set arghelp [noq [lindex $s 6]]
	set opthelp [noq [lindex $s 7]]
	if {$arg != "NULL"} {
	    lappend slots $arg
	    set helpinfo($arg) \
		"        $arg <$arghelp> (default $default)\\n[linebreak {                } $opthelp 1]"
	}
    }
    foreach s $object_slots_full($object) {
	set arg [noq [lindex $s 3]]
	set default [noq [lindex $s 6]]
	set arghelp [noq [lindex $s 9]]
	set opthelp [noq [lindex $s 10]]
	if {$arg != "NULL"} {
	    lappend slots $arg
	    set helpinfo($arg) \
		"        $arg <$arghelp> (default $default)\\n[linebreak {                } $opthelp 1]"
	}
    }
    foreach m $object_methods($object) {
	set name [noq [lindex $m 0]]
	set args [noq [lindex $m 1]]
	set help [noq [lindex $m 2]]
	lappend methods $name
	set helpinfo($name) "        $name $args\\n[linebreak {                } $help 1]"
    }
    set helpinfo(summary) "Command: [noq $object_tclcmd($object)]\\n[linebreak {    } [noq $object_help($object)] 1]\\n\\n    Methods are: $methods\\n    Slots are: $slots"
    
    puts $fp "static void"
    puts $fp "${object}AppendHelp(Tcl_Interp* interp, char* what)"
    puts $fp "\{"
    puts $fp "    int all = !strcmp(what, \"all\");"
    puts $fp "    int one = 0;"
    puts $fp ""
    puts $fp "    if (all || !strcmp(what, \"summary\")) \{"
    puts $fp "        Tcl_AppendResult(interp, \"$helpinfo(summary)\", 0);"
    puts $fp "        if (all) Tcl_AppendResult(interp, \"\\n\\n\", 0);"
    puts $fp "        one++;"
    puts $fp "    \}"
    puts $fp "    if (!strcmp(what, \"methods\")) \{"
    puts $fp "        Tcl_AppendResult(interp, \"Methods are: $methods\", 0);"
    puts $fp "        one++;"
    puts $fp "    \}"
    puts $fp "    if (!strcmp(what, \"slots\")) \{"
    puts $fp "        Tcl_AppendResult(interp, \"Slots are: $slots\", 0);"
    puts $fp "        one++;"
    puts $fp "    \}"
    if 0 {
    foreach m $methods {
	puts $fp "    if (all || !strcmp(what, \"$m\")) \{"
	puts $fp "        Tcl_AppendResult(interp, \"$helpinfo($m)\", 0);"
	puts $fp "        if (all) Tcl_AppendResult(interp, \"\\n\", 0);"
	puts $fp "        one++;"
	puts $fp "    \}"
    }
    foreach s $slots {
	puts $fp "    if (all || !strcmp(what, \"$s\")) \{"
	puts $fp "        Tcl_AppendResult(interp, \"$helpinfo($s)\", 0);"	
	puts $fp "        if (all) Tcl_AppendResult(interp, \"\\n\", 0);"
	puts $fp "        one++;"
	puts $fp "    \}"
    }
}
    puts $fp "    if (!one)"
    puts $fp "        Tcl_AppendResult(interp, \"No information is available on \\\"\", what, \"\\\".\nTry \\\"help\\\" for a list of sub-topics.\", 0);"
    puts $fp "\}"
}

# Simple line breaking.  Will break anywhere between 72 and 80 characters.

proc linebreak {prefix string usebn} {
    regsub {[ \t]*\\\n[ \t]*} $string " " string
    set plen [string length $prefix]

    if $usebn {set bn "\\n"} else {set bn "\\n"}

    set slen [string length $string]
    set lines {}
    while {$string != ""} {
	if {$plen + [string length $string] < 72} {
	    if {$lines != ""} {
		set lines "$lines$bn$prefix$string"
	    } else {
		set lines "$prefix$string"
	    }
	    set string ""
	    break
	}
	for {set i [expr {72 - $plen}]} {$i < 80 - $plen} {incr i} {
	    set c [string index $string $i]
	    if {$c == " "} break
	}
	if {$c != " "} {
	    for {} {$i > 0} {incr i -1} {
		set c [string index $string $i]
		if {$c == " "} break
	    }
	}
	if {$c != " "} {
	    for {set i [expr {80 - $plen}]} {$i < $slen} {incr i} {
		set c [string index $string $i]
		if {$c == " "} break
	    }
	}
	if {$lines != ""} {
	    set lines "$lines$bn$prefix[string range $string 0 [expr {$i - 1}]]"
	} else {
	    set lines "$prefix[string range $string 0 [expr {$i - 1}]]"
	}
	while {[string index $string $i] == " "} {incr i}
	set string [string range $string $i end]
	set slen [string length $string]
    }
    return $lines
}

proc put_documentation {fp object wid} {
    global object_help object_tclcmd object_class object_type
    global object_slots_full object_slots object_methods
    
    puts $fp ""
    if $wid {
	puts $fp "Tcl command: [noq $object_tclcmd($object)] pathname \[ options \]"
    } else {
	puts $fp "Tcl command: [noq $object_tclcmd($object)] \[ options \]"
    }
    puts $fp "Type: $object_type($object)"
    puts $fp "C++ class: $object_class($object)"
    puts $fp [linebreak "" "Description: [noq $object_help($object)]" 0]
    puts $fp ""
    puts $fp "    Options:"
    foreach s $object_slots($object) {
	set arg [noq [lindex $s 3]]
	set default [noq [lindex $s 4]]
	set arghelp [noq [lindex $s 6]]
	set opthelp [noq [lindex $s 7]]
	if {$arg != "NULL"} {
	    puts $fp "\t$arg <$arghelp> (default $default)"
	    puts $fp [linebreak "                " $opthelp 0]
	}
    }
   foreach s $object_slots($object) {
	set arg [noq [lindex $s 3]]
	set default [noq [lindex $s 6]]
	set arghelp [noq [lindex $s 9]]
	set opthelp [noq [lindex $s 10]]
	if {$arg != "NULL"} {
	    puts $fp "\t$arg <$arghelp> (default $default)"
	    puts $fp [linebreak "                " $opthelp 0]
	}
    }
    puts $fp ""
    puts $fp "    Methods:"
    foreach m $object_methods($object) {
	set name [noq [lindex $m 0]]
	set args [noq [lindex $m 1]]
	set help [noq [lindex $m 2]]
	puts $fp "\t$name $args"
	puts $fp [linebreak "                " $help 0]
    }
}

proc do_file {file} {
    global object_names object_type object_tclcmd object_class object_methods
    global object_slots_full object_slots object_help object_parents
    
    set current_object ""
    
    set fp [open $file r]
    while 1 {
	set line [gets $fp]
	if [eof $fp] break
	
	if [regexp {.*TCL_OBJECT(\(.*)} $line dummy first] {
	    set stuff [read_args $fp $first]
	    if {[llength $stuff] != 4} {
		puts "Error: wrong number of args to TCL_OBJECT: $stuff"
		continue
	    }
	    set current_object [lindex $stuff 1]
	    lappend object_names($file) $current_object
	    set object_tclcmd($current_object) [lindex $stuff 0]
	    set object_class($current_object) [lindex $stuff 1]
	    set otype [lindex $stuff 2]
	    if [regexp {(.*)\((.*)\)} $otype dummy typename parents] {
		set object_type($current_object) $typename
		set object_parents($current_object) $parents
	    } else {
		set object_type($current_object) $otype
		set object_parents($current_object) ""
	    }
	    set object_help($current_object) [lindex $stuff 3]
	    set object_methods($current_object) {}
	    set object_slots_full($current_object) {}
	    set object_slots($current_object) {}
	}
	
	if [regexp {.*TCL_METHOD(\(.*)} $line dummy first] {
	    set stuff [read_args $fp $first]
	    if {[llength $stuff] != 3} {
		puts "Error: wrong number of args to TCL_METHOD: $stuff"
		continue
	    }
	    if {$current_object == ""} {
		puts "Error: TCL_METHOD defined outside of a TCL_OBJECT: $stuff"
		continue
	    }
	    lappend object_methods($current_object) $stuff
	}
		
	if [regexp {.*TCL_SLOT_FULL(\(.*)} $line dummy first] {
	    set stuff [read_args $fp $first]
	    if {[llength $stuff] != 11} {
		puts "Error: wrong number of args to TCL_SLOT: $stuff"
		continue
	    }
	    if {$current_object == ""} {
		puts "Error: TCL_SLOT defined outside of a TCL_OBJECT: $stuff"
		continue
	    }
	    lappend object_slots_full($current_object) $stuff
	}
		
	if [regexp {.*TCL_SLOT(\(.*)} $line dummy first] {
	    set stuff [read_args $fp $first]
	    if {[llength $stuff] != 4} {
		puts "Error: wrong number of args to TCL_SLOT2: $stuff"
		continue
	    }
	    if {$current_object == ""} {
		puts "Error: TCL_SLOT defined outside of a TCL_OBJECT: $stuff"
		continue
	    }
	    # Now fill in the missing ones...
	    set ctype [lindex $stuff 0]
	    set var [lindex $stuff 1]
	    set def [lindex $stuff 2]
	    set h1 [lindex $stuff 3]
	    set cust NULL
	    case $ctype in {
		int {set ttype INT}
		double {set ttype DOUBLE}
		char* {set ttype STRING}
		default {
		    set ttype CUSTOM
		    if [string match *\\* $ctype] {
			set cust &[string trim $ctype *]Ptr_ConfigOption
		    } else {
			set cust &${ctype}_ConfigOption
		    }
		}
	    }
	    set stuff "$ttype $ctype $var \{\"-$var\"\} \{$def\} $cust \{$h1\} \{\"\"\}"
	    lappend object_slots($current_object) $stuff
	}
    }
    close $fp
}

# This should work for multi-line definitions but I haven't tried it.

proc read_args {fp first} {
    set arglist {}
    set current ""
    set index 0
    set parens 0
    set inquotes 0
    set line $first
    
    while 1 {
	set c [string index $line $index]
	incr index
	while {$c == ""} {
	    set line [gets $fp]
	    if [eof $fp] {
		error "end of file before closing parenthesis read"
	    }
	    set c [string index $line 0]
	    set index 1	    
	}
	case $c in {
	    "(" {
		if $inquotes {
		    append current $c
		} else {
		    incr parens
		    if {$parens > 1} {append current $c}
		    set eatwhite 0
		}
	    }
	    ")" {
		if $inquotes {
		    append current $c
		} else {
		    incr parens -1
		    if {$parens == 0} {
			lappend arglist $current
			#puts stdout "read_args: got \{ $arglist \}"
			return $arglist
		    }
		    append current $c
		    set eatwhite 0
		}
	    }
	    "," {
		if {!$inquotes && ($parens == 1)} {
		    lappend arglist $current
		    set current ""
		    set eatwhite 1
		} else {
		    append current $c
		}
	    }
	    {" " "\t"} {
		if {!$eatwhite} {append current $c}
	    }
	    "\"" {
		if $inquotes {set inquotes 0} else {set inquotes 1}
		append current $c
		set eatwhite 0
	    }
	    default {
		if {$c != "\\"} {
		    append current $c
		} else {
		    if {$index != [string length $line]} {
			append current $c
		    }
		}
		set eatwhite 0
	    }
	}
    }
}

if {$argv == ""} {
    puts "Usage: objectify file.h ..."
    exit 1
}

foreach f $argv {
    if {$f == "-nd"} {
	set no_doc 1
    } else {
	do_file $f
    }
}

foreach f [array names object_names] {
    
    puts stdout "File $f, [llength $object_names($f)] objects ---------"
    
    set fbase [file root [file tail $f]]
    set fp [open ${fbase}_objects.cc w]
    
    puts $fp ""
    puts $fp "// This file was automatically created by objectify."
    puts $fp "// Do not edit."
    puts $fp ""
    puts $fp "#include \"$f\""
    puts $fp ""

    foreach ob $object_names($f) {
	puts $fp "static int ${ob}Cmd(ClientData clientData,"
        puts $fp "       Tcl_Interp *interp, int argc, char *argv\[\]);"
    }
    
    puts $fp ""
    puts $fp "void"
    puts $fp "Objectify_init_${fbase}(Tcl_Interp* interp, ClientData cld)"
    puts $fp "\{"
    foreach ob $object_names($f) {
	puts $fp "    Tcl_CreateCommand(interp, $object_tclcmd($ob), \
${ob}Cmd, cld, NULL);"   
    }
    puts $fp "\}"
    
    set doc ""
    if ![info exists no_doc] {
	set doc [open ${fbase}_objects.doc w]
    }
    set num 0
    foreach ob $object_names($f) {
	if $num {
	    puts $fp ""
	    puts $fp "// ----------------------------------------------------"
	}
	dump_stuff $ob $fp $doc
	incr num
    }
    if {$doc != ""} {
	close $doc
    }
    
    close $fp
}

exit 0
