#!/usr/sww/bin/wish -f
#
#	Objectify -- turn C++ classes into Tcl objects.
#
#	Wayne Christopher, faustus@cs.berkeley.edu
#	Version 0.2, Nov 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 object_slot1s
    
    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_object_cmd $fp $object $wid
    puts $fp ""
    put_help_cmd $fp $object
    puts $fp ""
    put_get_cmd $fp $object
    puts $fp ""
    put_config_cmd $fp $object
    puts $fp ""
    
    put_documentation $doc $object $wid
}

proc put_create_cmd {fp object wid} {
    global object_tclcmd
    
    if $wid {set tkwin tkwin} else {set tkwin NULL}
    
    puts $fp "static Tcl_CmdProc ${object}ObjectCmd;"
    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 ""
	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 "    char buf\[64\];"
	puts $fp "    sprintf(buf, \"[noq $object_tclcmd($object)]_%x\", (int) ob);"
	puts $fp "    Tcl_AppendResult(interp, buf, 0);"
	puts $fp "    Tcl_CreateCommand(interp, buf, ${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\];"
    puts $fp "    int length = strlen(com);"
    
    # Toss in all the special ones.
    puts $fp "    if ((c == 'c') && !strcmp(com, \"configure\")) \{"
    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 "        char buf\[64\];"
	puts $fp "        sprintf(buf, \"[noq $object_tclcmd($object)]_%x\", (int) ob);"
	puts $fp "        Tcl_DeleteCommand(interp, buf);"
    }
    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]
	set min [lindex $method 2]
	set max [lindex $method 3]
	
	puts $fp "    if ((c == '$tcl_char') &&"
	puts $fp "        !strcmp(com, \"$tcl_com\")) \{"
	if {$min > 0} {
	    puts $fp "        if (ac < [expr {2 + $min}]) \{"
	    puts $fp "            Tcl_AppendResult(interp,"
	    puts $fp "                         \"too few arguments to \","
	    puts $fp "                         \"$tcl_com: $min minimum\", 0);"
	    puts $fp "            *retp = TCL_ERROR; return (1);"
	    puts $fp "        \}"
	}
	if {$max >= 0} {
	    puts $fp "        if (ac > [expr {2 + $max}]) \{"
	    puts $fp "            Tcl_AppendResult(interp,"
	    puts $fp "                         \"too many arguments to \","
	    puts $fp "                         \"$tcl_com: $max maximum\", 0);"
	    puts $fp "           *retp = TCL_ERROR; return (1);" 
	    puts $fp "        \}"
	}
	if [regexp {(.*)\((.*)\)} $c_com dummy comname args] {
	    # 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.
	    # We really should make sure the min and max parameters are
	    # consistent here.  *****
	    if $wid {
		set arguments [parse_arglist $args ob->tkwin]
	    } else {
		set arguments [parse_arglist $args NULL]
	    }
	    set nargs [lindex $arguments 0]
	    set arguments [lindex $arguments 1]
	    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 num 0
	    foreach arg $arguments {
		puts $fp $arg
		if $num {set arglist "$arglist, "}
		set arglist "${arglist}arg$num"
		incr num
	    }
	    puts $fp "        *retp = ob->$comname ($arglist);"
	} else {
	    puts $fp "        *retp = ob->$c_com (interp, ac - 2, av + 2);"
	}
	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

proc parse_arglist {arglist ww} {
    set num 0
    set argno 2
    set results {}
    foreach arg [split $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 {^[ 	]*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_Option, where Foo is the first word of the
	    # thing.  If the thing is of the form Foo*, then assume the
	    # option is called FooPtr_Option.
	    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}_Option
	    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
    }
    incr argno -2
    return [list $argno $results]
}

proc put_config_specs {fp object wid} {
    global object_slots object_slot1s

    set num 0
    puts $fp "static Tk_ConfigSpec ${object}_ConfigSpecs\[\] = \{"
    foreach slot $object_slots($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_slot1s($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 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 && (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 object_slot1s object_methods
    
    set slots {}
    set methods {}

    foreach s $object_slot1s($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($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 min [noq [lindex $m 2]]
	set max [noq [lindex $m 3]]
	set args [noq [lindex $m 4]]
	set help [noq [lindex $m 5]]
	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 "    \}"
    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 object_slot1s 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_slot1s($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 min [noq [lindex $m 2]]
	set max [noq [lindex $m 3]]
	set args [noq [lindex $m 4]]
	set help [noq [lindex $m 5]]
	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 object_slot1s 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($current_object) {}
	    set object_slot1s($current_object) {}
	}
	
	if {[regexp {.*TCL_METHOD(\(.*)} $line dummy first] ||
	    [regexp {.*TCL_METHOD_PARENT(\(.*)} $line dummy first]} {
	    set stuff [read_args $fp $first]
	    if {[llength $stuff] != 6} {
		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_METHOD1(\(.*)} $line dummy first] ||
	    [regexp {.*TCL_METHOD1_PARENT(\(.*)} $line dummy first]} {
	    set stuff [read_args $fp $first]
	    if {[llength $stuff] != 4} {
		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) [list [lindex $stuff 0] \
						     [lindex $stuff 1] -1 -1 \
						     [lindex $stuff 2] \
						     [lindex $stuff 3]]
	}	
	
	if {[regexp {.*TCL_SLOT(\(.*)} $line dummy first] ||
	    [regexp {.*TCL_SLOT_PARENT(\(.*)} $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($current_object) $stuff
	}
	
	if {[regexp {.*TCL_SLOT1(\(.*)} $line dummy first] ||
	    [regexp {.*TCL_SLOT1_PARENT(\(.*)} $line dummy first]} {
	    set stuff [read_args $fp $first]
	    if {[llength $stuff] != 8} {
		puts "Error: wrong number of args to TCL_SLOT1: $stuff"
		continue
	    }
	    if {$current_object == ""} {
		puts "Error: TCL_SLOT1 defined outside of a TCL_OBJECT: $stuff"
		continue
	    }
	    lappend object_slot1s($current_object) $stuff
	}
	
	if [regexp {.*TCL_SLOT2(\(.*)} $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_SLOT2 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]
	    case $ctype in {
		int {set ttype INT}
		double {set ttype DOUBLE}
		char* {set ttype STRING}
		default {error "Can't use type \"$ctype\" with SLOT2"}
	    }
	    set stuff "$ttype $ctype $var \{\"-$var\"\} \{$def\} NULL \{$h1\} \{\"\"\}"
	    lappend object_slot1s($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
	    }
	}
    }
}

foreach f $argv {
    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 ""
    puts $fp "extern \"C\" int Obj_ConfigureWidget(Tcl_Interp *interp, Tk_ConfigSpec *specs,"
    puts $fp "                     int argc, char **argv, char *widgRec, int flags);"
    puts $fp "extern \"C\" int Obj_ConfigureInfo(Tcl_Interp *interp, Tk_ConfigSpec *specs,"
    puts $fp "                     char *widgRec, char *argvName, int flags);"
    puts $fp ""

    foreach ob $object_names($f) {
	puts $fp "static Tcl_CmdProc ${ob}Cmd;"
    }
    
    puts $fp ""
    puts $fp "void"
    puts $fp "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 [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
    }
    close $fp
    close $doc
}

exit 0
