package provide MegaWidget 1.0

proc MegaWidget { hWnd } {
    variable widgetClasses

    # Get the namespace for the mega-widget from the caller

    set NS [uplevel namespace current]

    # If the widget has already been turned into a mega-widget, just insert
    # the new namespace into the top of the search list and return.

    if {[info exist widgetClasses($hWnd)]} {
        set widgetClasses($hWnd) [linsert $widgetClasses($hWnd) 0 $NS]
        return
    }

    # The widget has yet been turned into a mega-widget.  Store the
    # caller's namespace as the first in the search list.

    set widgetClasses($hWnd) $NS

    # Rename the widget command to something in this procedure's namespace
    # so that calls to the widget command are not sent to the widget directly.

    rename ::$hWnd [namespace current]::mega$hWnd

    # Set up binding to clear the search list for the widget and delete
    # the replacement procedure for the widget command.  Make sure that
    # the widget generating the event is the same as the widget that was
    # turned into a mega-widget: this allows a toplevel to be turned
    # into mega-widget too (otherwise, it will get <Destroy> events from
    # child windows).

    set template {
        if {[string match %W @HWND@]} {
            namespace eval @MYNS@ array unset widgetClasses %W
            rename %W {}
        }
    }

    regsub -all {@HWND@} $template $hWnd template
    regsub -all {@MYNS@} $template [namespace current] template

    bind $hWnd <Destroy> $template

    # Create a new top-level procedure with the same name as the widget.
    # This procedure will scan through the search list for a namespace
    # containing a procedure by the same name as the first argument passed
    # to this new procedure.

    set template {
        global errorInfo errorCode
        variable widgetClasses

        set hWnd @HWND@

        foreach NS $@MYNS@::widgetClasses($hWnd) {
            if {[namespace inscope $NS info proc $command] == $command} {
                set rc [catch { uplevel [set NS]::$command $hWnd $args } result]
                set ei $errorInfo
                set ec $errorCode
                break
            }
        }

        if {![info exist rc]} {
            set rc [catch { uplevel @MYNS@::mega$hWnd $command $args } result]
            set ei $errorInfo
            set ec $errorCode
        }
        return -code $rc -errorinfo $ei -errorcode $ec $result
    }

    regsub -all {@HWND@} $template $hWnd template
    regsub -all {@MYNS@} $template [namespace current] template

    proc ::$hWnd { command args } $template
}

# Example:
#
# namespace eval MyWidget {
#     proc MyWidget { hWnd args } [
#
#         # Main frame for the mega-widget
#
#         frame $hWnd
#
#         # ... other widgets created/packed in the main frame
#
#         # Turn created frame into a mega-widget.
#
#         MegaWidget $hWnd
#         return $hWnd
#     }
#
#     proc dosomething { hWnd args } {
#         # ...
#     }
#
#     proc dosomethingelse { hWnd args } {
#         # ...
#     }
# }
#
# MyWidget::MyWidget .mw
# .mw dosomething -option value ...
# .mw dosomethingelse -option value ...