#!/usr/sww/bin/wish -f
#
#	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 object_slot1s
    
    if {$object_type($object) == "widget"} { set wid 1 } else { set wid 0 }
    
    puts stdout "Creating object $object ..."

    set generate_configure 0
    set generate_delete 0
    set generate_help 0
    foreach method $object_methods($object) {
	case [noq [lindex $method 0]] in {
	    configure {set generate_configure 1}
	    delete {set generate_delete 1}
	    help {set generate_help 1}
	}
    }
    
    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 ""

    if $generate_configure {
	if $wid {
	    put_config_cmd $fp $object
	} else {
	    put_ob_config_cmd $fp $object
	}
	puts $fp ""
    }
    
    if $generate_delete {
	put_delete_cmd $fp $object
	puts $fp ""
    }
    
    if $generate_help {
	put_help_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 ""
    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 args\", 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 (Tk_ConfigureWidget(interp, owin, ${object}_ConfigSpecs,"
	puts $fp "                           ac - 2, av + 2, (char *) ob, 0) != 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 (Obj_ConfigureWidget(interp, ${object}_ConfigSpecs,"
	puts $fp "                            ac - 1, av + 1, (char *) ob, 0) != TCL_OK) \{"
	puts $fp "        return (TCL_ERROR);"
	puts $fp "    \}"
	
    }
    puts $fp "    if (ob->AfterConfigure(interp) != TCL_OK) \{"
    if $wid { puts $fp "        Tk_DestroyWindow(tkwin);" }
    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

    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 ""
    puts $fp "    char* com = av\[1\];"
    puts $fp "    char c = com\[0\];"
    puts $fp "    int length = strlen(com);"
    foreach method $object_methods($object) {
	incr num
	set tcl_com [lindex $method 0]
	set tcl_com [string range $tcl_com 1 [expr {[string length $tcl_com] - 2}]]
	set c_com [lindex $method 1]
	set min [lindex $method 2]
	set max [lindex $method 3]
	
	puts $fp "    if ((c == '[string index $tcl_com 0]') && !strncmp(com, \"$tcl_com\", length)) \{"
	if {$min > 0} {
	    puts $fp "        if (ac < [expr {2 + $min}]) \{"
	    puts $fp "            Tcl_AppendResult(interp, \"too few arguments to \","
	    puts $fp "                             \"$tcl_com: $min minimum\", 0);"
	    puts $fp "            return (TCL_ERROR);"
	    puts $fp "        \}"
	}
	if {$max >= 0} {
	    puts $fp "        if (ac > [expr {2 + $max}]) \{"
	    puts $fp "            Tcl_AppendResult(interp, \"too many arguments to \","
	    puts $fp "                             \"$tcl_com: $max maximum\", 0);"
	    puts $fp "            return (TCL_ERROR);"
	    puts $fp "        \}"
	}
	puts $fp "        return (ob->$c_com (interp, ac - 2, av + 2));"
	puts $fp "    \}"
    }
    puts $fp ""

    set names {}
    foreach method $object_methods($object) {
	lappend names [noq [lindex $method 0]]
    }
    
    puts $fp "    Tcl_AppendResult(interp, \"invalid method name \\\"\", com, \"\\\"; must be one of: $names\", 0);"
    
    puts $fp "    return (TCL_ERROR);"
    puts $fp "\}"
    
    puts stdout "\t$num methods"
}

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} {
    puts $fp "int"
    puts $fp "$object::ConfigureCmd(Tcl_Interp* interp, int ac, char** av)"
    puts $fp "\{"
    puts $fp "    if (ac == 0) \{"
    puts $fp "        return (Tk_ConfigureInfo(interp, tkwin, ${object}_ConfigSpecs,"
    puts $fp "                                 (char *) this, NULL, 0));"
    puts $fp "    \} else if (ac == 1) \{"
    puts $fp "        return (Tk_ConfigureInfo(interp, tkwin, ${object}_ConfigSpecs,"
    puts $fp "                                 (char *) this, av\[0\], 0));"
    puts $fp "    \} else \{"
    puts $fp "        if (Tk_ConfigureWidget(interp, tkwin, ${object}_ConfigSpecs,"
    puts $fp "                               ac, av, (char *) this,"
    puts $fp "                               TK_CONFIG_ARGV_ONLY) != TCL_OK)"
    puts $fp "            return (TCL_ERROR);"
    puts $fp "        return (AfterConfigure(interp));"
    puts $fp "    \}"
    puts $fp "\}"
}

proc put_ob_config_cmd {fp object} {
    puts $fp "int"
    puts $fp "$object::ConfigureCmd(Tcl_Interp* interp, int ac, char** av)"
    puts $fp "\{"
    puts $fp "    if (ac == 0) \{"
    puts $fp "        return (Obj_ConfigureInfo(interp, ${object}_ConfigSpecs,"
    puts $fp "                                 (char *) this, NULL, 0));"
    puts $fp "    \} else if (ac == 1) \{"
    puts $fp "        return (Obj_ConfigureInfo(interp, ${object}_ConfigSpecs,"
    puts $fp "                                 (char *) this, av\[0\], 0));"
    puts $fp "    \} else \{"
    puts $fp "        if (Obj_ConfigureWidget(interp, ${object}_ConfigSpecs,"
    puts $fp "                               ac, av, (char *) this,"
    puts $fp "                               TK_CONFIG_ARGV_ONLY) != TCL_OK)"
    puts $fp "            return (TCL_ERROR);"
    puts $fp "        return (AfterConfigure(interp));"
    puts $fp "    \}"
    puts $fp "\}"
}

proc put_delete_cmd {fp object} {
    global object_tclcmd object_type
    
    puts $fp "int"
    puts $fp "$object::DeleteCmd(Tcl_Interp* interp, int ac, char** av)"
    puts $fp "\{"
    if {$object_type($object) == "widget"} {
	puts $fp "    Tcl_DeleteCommand(interp, Tk_PathName(tkwin));"
	puts $fp "    Tk_DestroyWindow(tkwin);"
    } else {
	puts $fp "    char buf\[64\];"
	puts $fp "    sprintf(buf, \"[noq $object_tclcmd($object)]_%x\", (int) this);"
	puts $fp "    Tcl_DeleteCommand(interp, buf);"
    }
    puts $fp "    return (TCL_OK);"
    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 "\}"
    puts $fp ""    
    puts $fp "int"
    puts $fp "$object::HelpCmd(Tcl_Interp* interp, int ac, char** av)"
    puts $fp "\{"
    puts $fp "    if (!ac) \{"
    puts $fp "        ${object}AppendHelp(interp, \"summary\");"
    puts $fp "    \} else \{"
    puts $fp "        for (int i = 0; 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 (TCL_OK);"
    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
    
    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 object_type($current_object) [lindex $stuff 2]
	    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_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
	}
    }
    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
