#
# Copyright (c) 2012-2014, Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

# Commands in twapi_base module

namespace eval twapi {
    # Map of Sid integer type to Sid type name
    variable sid_type_names
    array set sid_type_names {
        1 user 
        2 group
        3 domain 
        4 alias 
        5 wellknowngroup
        6 deletedaccount
        7 invalid
        8 unknown
        9 computer
        10 label
        11 logonsession
    }

    # Cache mapping account names to SIDs. Dict keyed by system and name
    variable _name_to_sid_cache {}

    # Cache mapping SIDs to account names. Dict keyed by system and SID
    variable _sid_to_name_cache {}

    # Dictionary of FFI libraries to handles and back
    variable _ffi_paths {}
    variable _ffi_handles {}
}



# Return major minor servicepack as a quad list
proc twapi::get_os_version {} {
    array set verinfo [GetVersionEx]
    return [list $verinfo(dwMajorVersion) $verinfo(dwMinorVersion) \
                $verinfo(wServicePackMajor) $verinfo(wServicePackMinor)]
}

# Returns true if the OS version is at least $major.$minor.$sp
proc twapi::min_os_version {major {minor 0} {spmajor 0} {spminor 0}} {
    lassign  [twapi::get_os_version]  osmajor osminor osspmajor osspminor

    if {$osmajor > $major} {return 1}
    if {$osmajor < $major} {return 0}
    if {$osminor > $minor} {return 1}
    if {$osminor < $minor} {return 0}
    if {$osspmajor > $spmajor} {return 1}
    if {$osspmajor < $spmajor} {return 0}
    if {$osspminor > $spminor} {return 1}
    if {$osspminor < $spminor} {return 0}

    # Same version, ok
    return 1
}

# Convert a LARGE_INTEGER time value (100ns since 1601) to a formatted date
# time
interp alias {} twapi::large_system_time_to_secs {} twapi::large_system_time_to_secs_since_1970
proc twapi::large_system_time_to_secs_since_1970 {ns100 {fraction false}} {
    # No. 100ns units between 1601 to 1970 = 116444736000000000
    set ns100_since_1970 [expr {$ns100-116444736000000000}]

    set secs_since_1970 [expr {$ns100_since_1970/10000000}]
    if {$fraction} {
        append secs_since_1970 .[string range $ns100 end-6 end]
    }
    return $secs_since_1970
}

proc twapi::secs_since_1970_to_large_system_time {secs} {
    # No. 100ns units between 1601 to 1970 = 116444736000000000
    return [expr {($secs * 10000000) + 116444736000000000}]
}

# Map a Windows error code to a string
proc twapi::map_windows_error {code} {
    # Trim trailing CR/LF
    return [string trimright [twapi::Twapi_MapWindowsErrorToString $code] "\r\n"]
}

# Load given library
proc twapi::load_library {path args} {
    array set opts [parseargs args {
        dontresolverefs
        datafile
        alteredpath
    }]

    set flags 0
    if {$opts(dontresolverefs)} {
        setbits flags 1;                # DONT_RESOLVE_DLL_REFERENCES
    }
    if {$opts(datafile)} {
        setbits flags 2;                # LOAD_LIBRARY_AS_DATAFILE
    }
    if {$opts(alteredpath)} {
        setbits flags 8;                # LOAD_WITH_ALTERED_SEARCH_PATH
    }

    # LoadLibrary always wants backslashes
    set path [file nativename $path]
    return [LoadLibraryEx $path $flags]
}

# Free library opened with load_library
proc twapi::free_library {libh} {
    FreeLibrary $libh
}

# Format message string - will raise exception if insufficient number
# of arguments
proc twapi::_unsafe_format_message {args} {
    array set opts [parseargs args {
        module.arg
        fmtstring.arg
        messageid.arg
        langid.arg
        params.arg
        includesystem
        ignoreinserts
        width.int
    } -nulldefault -maxleftover 0]

    set flags 0

    if {$opts(module) == ""} {
        if {$opts(fmtstring) == ""} {
            # If neither -module nor -fmtstring specified, message is formatted
            # from the system
            set opts(module) NULL
            setbits flags 0x1000;       # FORMAT_MESSAGE_FROM_SYSTEM
        } else {
            setbits flags 0x400;        # FORMAT_MESSAGE_FROM_STRING
            if {$opts(includesystem) || $opts(messageid) != "" || $opts(langid) != ""} {
                error "Options -includesystem, -messageid and -langid cannot be used with -fmtstring"
            }
        }
    } else {
        if {$opts(fmtstring) != ""} {
            error "Options -fmtstring and -module cannot be used together"
        }
        setbits flags 0x800;        # FORMAT_MESSAGE_FROM_HMODULE
        if {$opts(includesystem)} {
            # Also include system in search
            setbits flags 0x1000;       # FORMAT_MESSAGE_FROM_SYSTEM
        }
    }

    if {$opts(ignoreinserts)} {
        setbits flags 0x200;            # FORMAT_MESSAGE_IGNORE_INSERTS
    }

    if {$opts(width) > 254} {
        error "Invalid value for option -width. Must be -1, 0, or a positive integer less than 255"
    }
    if {$opts(width) < 0} {
        # Negative width means no width restrictions
        set opts(width) 255;                  # 255 -> no restrictions
    }
    incr flags $opts(width);                  # Width goes in low byte of flags

    if {$opts(fmtstring) != ""} {
        return [FormatMessageFromString $flags $opts(fmtstring) $opts(params)]
    } else {
        if {![string is integer -strict $opts(messageid)]} {
            error "Unspecified or invalid value for -messageid option. Must be an integer value"
        }
        if {$opts(langid) == ""} { set opts(langid) 0 }
        if {![string is integer -strict $opts(langid)]} {
            error "Unspecfied or invalid value for -langid option. Must be an integer value"
        }

        # Check if $opts(module) is a file or module handle (pointer)
        if {[pointer? $opts(module)]} {
            return  [FormatMessageFromModule $flags $opts(module) \
                         $opts(messageid) $opts(langid) $opts(params)]
        } else {
            set hmod [load_library $opts(module) -datafile]
            trap {
                set message  [FormatMessageFromModule $flags $hmod \
                                  $opts(messageid) $opts(langid) $opts(params)]
            } finally {
                free_library $hmod
            }
            return $message
        }
    }
}

# Format message string
proc twapi::format_message {args} {
    array set opts [parseargs args {
        params.arg
        fmtstring.arg
        width.int
        ignoreinserts
    } -ignoreunknown]

    # TBD - document - if no params specified, different from params = {}

    # If a format string is specified, other options do not matter
    # except for -width. In that case, we do not call FormatMessage
    # at all
    if {[info exists opts(fmtstring)]} {
        # If -width specifed, call FormatMessage
        if {[info exists opts(width)] && $opts(width)} {
            set msg [_unsafe_format_message -ignoreinserts -fmtstring $opts(fmtstring) -width $opts(width) {*}$args]
        } else {
            set msg $opts(fmtstring)
        }
    } else {
        # Not -fmtstring, retrieve from message file
        if {[info exists opts(width)]} {
            set msg [_unsafe_format_message -ignoreinserts -width $opts(width) {*}$args]
        } else {
            set msg [_unsafe_format_message -ignoreinserts {*}$args]
        }
    }

    # If we are told to ignore inserts, all done. Else replace them except
    # that if no param list, do not replace placeholder. This is NOT
    # the same as empty param list
    if {$opts(ignoreinserts) || ![info exists opts(params)]} {
        return $msg
    }

    # TBD - cache fmtstring -> indices for performance
    set placeholder_indices [regexp -indices -all -inline {%(?:.|(?:[1-9][0-9]?(?:![^!]+!)?))} $msg]

    if {[llength $placeholder_indices] == 0} {
        # No placeholders.
        return $msg
    }

    # Use of * in format specifiers will change where the actual parameters
    # are positioned
    set num_asterisks 0
    set msg2 ""
    set prev_end 0
    foreach placeholder $placeholder_indices {
        lassign $placeholder start end
        # Append the stuff between previous placeholder and this one
        append msg2 [string range $msg $prev_end [expr {$start-1}]]
        set spec [string range $msg $start+1 $end]
        switch -exact -- [string index $spec 0] {
            % { append msg2 % }
            r { append msg2 \r }
            n { append msg2 \n }
            t { append msg2 \t }
            0 { 
                # No-op - %0 means to not add trailing newline
            }
            default {
                if {! [string is integer -strict [string index $spec 0]]} {
                    # Not a insert parameter. Just append the character
                    append msg2 $spec
                } else {
                    # Insert parameter
                    set fmt ""
                    scan $spec %d%s param_index fmt
                    # Note params are numbered starting with 1
                    incr param_index -1
                    # Format spec, if present, is enclosed in !. Get rid of them
                    set fmt [string trim $fmt "!"]
                    if {$fmt eq ""} {
                        # No fmt spec
                    } else {
                        # Since everything is a string in Tcl, we happily
                        # do not have to worry about type. However, the
                        # format spec could have * specifiers which will
                        # change the parameter indexing for subsequent
                        # arguments
                        incr num_asterisks [expr {[llength [split $fmt *]]-1}]
                        incr param_index $num_asterisks
                    }
                    # TBD - we ignore the actual format type
                    append msg2 [lindex $opts(params) $param_index]
                }                        
            }
        }                    
        set prev_end [incr end]
    }
    append msg2 [string range $msg $prev_end end]
    return $msg2
}

# Revert to process token. In base package because used across many modules
proc twapi::revert_to_self {{opt ""}} {
    RevertToSelf
}

# For backward compatibility
interp alias {} twapi::expand_environment_strings {} twapi::expand_environment_vars

proc twapi::_init_security_defs {} {
    variable security_defs

    # NOTE : the access definitions for those types that are included here
    # have been updated as of Windows 8.
    array set security_defs {

        TOKEN_ASSIGN_PRIMARY           0x00000001
        TOKEN_DUPLICATE                0x00000002
        TOKEN_IMPERSONATE              0x00000004
        TOKEN_QUERY                    0x00000008
        TOKEN_QUERY_SOURCE             0x00000010
        TOKEN_ADJUST_PRIVILEGES        0x00000020
        TOKEN_ADJUST_GROUPS            0x00000040
        TOKEN_ADJUST_DEFAULT           0x00000080
        TOKEN_ADJUST_SESSIONID         0x00000100

        TOKEN_ALL_ACCESS_WINNT         0x000F00FF
        TOKEN_ALL_ACCESS_WIN2K         0x000F01FF
        TOKEN_ALL_ACCESS               0x000F01FF
        TOKEN_READ                     0x00020008
        TOKEN_WRITE                    0x000200E0
        TOKEN_EXECUTE                  0x00020000

        SYSTEM_MANDATORY_LABEL_NO_WRITE_UP         0x1
        SYSTEM_MANDATORY_LABEL_NO_READ_UP          0x2
        SYSTEM_MANDATORY_LABEL_NO_EXECUTE_UP       0x4

        ACL_REVISION     2
        ACL_REVISION_DS  4

        ACCESS_MAX_MS_V2_ACE_TYPE               0x3
        ACCESS_MAX_MS_V3_ACE_TYPE               0x4
        ACCESS_MAX_MS_V4_ACE_TYPE               0x8
        ACCESS_MAX_MS_V5_ACE_TYPE               0x11

        STANDARD_RIGHTS_REQUIRED       0x000F0000
        STANDARD_RIGHTS_READ           0x00020000
        STANDARD_RIGHTS_WRITE          0x00020000
        STANDARD_RIGHTS_EXECUTE        0x00020000
        STANDARD_RIGHTS_ALL            0x001F0000
        SPECIFIC_RIGHTS_ALL            0x0000FFFF

        GENERIC_READ                   0x80000000
        GENERIC_WRITE                  0x40000000
        GENERIC_EXECUTE                0x20000000
        GENERIC_ALL                    0x10000000

        SERVICE_QUERY_CONFIG           0x00000001
        SERVICE_CHANGE_CONFIG          0x00000002
        SERVICE_QUERY_STATUS           0x00000004
        SERVICE_ENUMERATE_DEPENDENTS   0x00000008
        SERVICE_START                  0x00000010
        SERVICE_STOP                   0x00000020
        SERVICE_PAUSE_CONTINUE         0x00000040
        SERVICE_INTERROGATE            0x00000080
        SERVICE_USER_DEFINED_CONTROL   0x00000100
        SERVICE_ALL_ACCESS             0x000F01FF

        SC_MANAGER_CONNECT             0x00000001
        SC_MANAGER_CREATE_SERVICE      0x00000002
        SC_MANAGER_ENUMERATE_SERVICE   0x00000004
        SC_MANAGER_LOCK                0x00000008
        SC_MANAGER_QUERY_LOCK_STATUS   0x00000010
        SC_MANAGER_MODIFY_BOOT_CONFIG  0x00000020
        SC_MANAGER_ALL_ACCESS          0x000F003F

        KEY_QUERY_VALUE                0x00000001
        KEY_SET_VALUE                  0x00000002
        KEY_CREATE_SUB_KEY             0x00000004
        KEY_ENUMERATE_SUB_KEYS         0x00000008
        KEY_NOTIFY                     0x00000010
        KEY_CREATE_LINK                0x00000020
        KEY_WOW64_32KEY                0x00000200
        KEY_WOW64_64KEY                0x00000100
        KEY_WOW64_RES                  0x00000300
        KEY_READ                       0x00020019
        KEY_WRITE                      0x00020006
        KEY_EXECUTE                    0x00020019
        KEY_ALL_ACCESS                 0x000F003F

        POLICY_VIEW_LOCAL_INFORMATION   0x00000001
        POLICY_VIEW_AUDIT_INFORMATION   0x00000002
        POLICY_GET_PRIVATE_INFORMATION  0x00000004
        POLICY_TRUST_ADMIN              0x00000008
        POLICY_CREATE_ACCOUNT           0x00000010
        POLICY_CREATE_SECRET            0x00000020
        POLICY_CREATE_PRIVILEGE         0x00000040
        POLICY_SET_DEFAULT_QUOTA_LIMITS 0x00000080
        POLICY_SET_AUDIT_REQUIREMENTS   0x00000100
        POLICY_AUDIT_LOG_ADMIN          0x00000200
        POLICY_SERVER_ADMIN             0x00000400
        POLICY_LOOKUP_NAMES             0x00000800
        POLICY_NOTIFICATION             0x00001000
        POLICY_READ                     0X00020006
        POLICY_WRITE                    0X000207F8
        POLICY_EXECUTE                  0X00020801
        POLICY_ALL_ACCESS               0X000F0FFF

        DESKTOP_READOBJECTS         0x0001
        DESKTOP_CREATEWINDOW        0x0002
        DESKTOP_CREATEMENU          0x0004
        DESKTOP_HOOKCONTROL         0x0008
        DESKTOP_JOURNALRECORD       0x0010
        DESKTOP_JOURNALPLAYBACK     0x0020
        DESKTOP_ENUMERATE           0x0040
        DESKTOP_WRITEOBJECTS        0x0080
        DESKTOP_SWITCHDESKTOP       0x0100

        WINSTA_ENUMDESKTOPS         0x0001
        WINSTA_READATTRIBUTES       0x0002
        WINSTA_ACCESSCLIPBOARD      0x0004
        WINSTA_CREATEDESKTOP        0x0008
        WINSTA_WRITEATTRIBUTES      0x0010
        WINSTA_ACCESSGLOBALATOMS    0x0020
        WINSTA_EXITWINDOWS          0x0040
        WINSTA_ENUMERATE            0x0100
        WINSTA_READSCREEN           0x0200
        WINSTA_ALL_ACCESS           0x37f

        PROCESS_TERMINATE              0x0001
        PROCESS_CREATE_THREAD          0x0002
        PROCESS_SET_SESSIONID          0x0004
        PROCESS_VM_OPERATION           0x0008
        PROCESS_VM_READ                0x0010
        PROCESS_VM_WRITE               0x0020
        PROCESS_DUP_HANDLE             0x0040
        PROCESS_CREATE_PROCESS         0x0080
        PROCESS_SET_QUOTA              0x0100
        PROCESS_SET_INFORMATION        0x0200
        PROCESS_QUERY_INFORMATION      0x0400
        PROCESS_SUSPEND_RESUME         0x0800

        THREAD_TERMINATE               0x00000001
        THREAD_SUSPEND_RESUME          0x00000002
        THREAD_GET_CONTEXT             0x00000008
        THREAD_SET_CONTEXT             0x00000010
        THREAD_SET_INFORMATION         0x00000020
        THREAD_QUERY_INFORMATION       0x00000040
        THREAD_SET_THREAD_TOKEN        0x00000080
        THREAD_IMPERSONATE             0x00000100
        THREAD_DIRECT_IMPERSONATION    0x00000200
        THREAD_SET_LIMITED_INFORMATION   0x00000400
        THREAD_QUERY_LIMITED_INFORMATION 0x00000800

        EVENT_MODIFY_STATE             0x00000002
        EVENT_ALL_ACCESS               0x001F0003

        SEMAPHORE_MODIFY_STATE         0x00000002
        SEMAPHORE_ALL_ACCESS           0x001F0003

        MUTANT_QUERY_STATE             0x00000001
        MUTANT_ALL_ACCESS              0x001F0001

        MUTEX_MODIFY_STATE             0x00000001
        MUTEX_ALL_ACCESS               0x001F0001

        TIMER_QUERY_STATE              0x00000001
        TIMER_MODIFY_STATE             0x00000002
        TIMER_ALL_ACCESS               0x001F0003

        FILE_READ_DATA                 0x00000001
        FILE_LIST_DIRECTORY            0x00000001
        FILE_WRITE_DATA                0x00000002
        FILE_ADD_FILE                  0x00000002
        FILE_APPEND_DATA               0x00000004
        FILE_ADD_SUBDIRECTORY          0x00000004
        FILE_CREATE_PIPE_INSTANCE      0x00000004
        FILE_READ_EA                   0x00000008
        FILE_WRITE_EA                  0x00000010
        FILE_EXECUTE                   0x00000020
        FILE_TRAVERSE                  0x00000020
        FILE_DELETE_CHILD              0x00000040
        FILE_READ_ATTRIBUTES           0x00000080
        FILE_WRITE_ATTRIBUTES          0x00000100

        FILE_ALL_ACCESS                0x001F01FF
        FILE_GENERIC_READ              0x00120089
        FILE_GENERIC_WRITE             0x00120116
        FILE_GENERIC_EXECUTE           0x001200A0

        DELETE                         0x00010000
        READ_CONTROL                   0x00020000
        WRITE_DAC                      0x00040000
        WRITE_OWNER                    0x00080000
        SYNCHRONIZE                    0x00100000

        MAXIMUM_ALLOWED                0x02000000

        COM_RIGHTS_EXECUTE 1
        COM_RIGHTS_EXECUTE_LOCAL 2
        COM_RIGHTS_EXECUTE_REMOTE 4
        COM_RIGHTS_ACTIVATE_LOCAL 8
        COM_RIGHTS_ACTIVATE_REMOTE 16
    }

    if {[min_os_version 6]} {
        array set security_defs {
            PROCESS_QUERY_LIMITED_INFORMATION      0x00001000
            PROCESS_ALL_ACCESS             0x001fffff
            THREAD_ALL_ACCESS              0x001fffff
        }
    } else {
        array set security_defs {
            PROCESS_ALL_ACCESS             0x001f0fff
            THREAD_ALL_ACCESS              0x001f03ff
        }
    }

    # Make next call a no-op
    proc _init_security_defs {} {}
}

# Map a set of access right symbols to a flag. Concatenates
# all the arguments, and then OR's the individual elements. Each
# element may either be a integer or one of the access rights
proc twapi::_access_rights_to_mask {args} {
    _init_security_defs

    proc _access_rights_to_mask args {
        variable security_defs
        set rights 0
        foreach right [concat {*}$args] {
            # The mandatory label access rights are not in security_defs
            # because we do not want them to mess up the int->name mapping
            # for DACL's
            set right [dict* {
                no_write_up 1
                system_mandatory_label_no_write_up 1
                no_read_up 2
                system_mandatory_label_no_read_up  2
                no_execute_up 4
                system_mandatory_label_no_execute_up 4
            } $right]
            if {![string is integer $right]} {
                if {[catch {set right $security_defs([string toupper $right])}]} {
                    error "Invalid access right symbol '$right'"
                }
            }
            set rights [expr {$rights | $right}]
        }
        return $rights
    }
    return [_access_rights_to_mask {*}$args]
}


# Map an access mask to a set of rights
proc twapi::_access_mask_to_rights {access_mask {type ""}} {
    _init_security_defs

    proc _access_mask_to_rights {access_mask {type ""}} {
        variable security_defs

        set rights [list ]

        if {$type eq "mandatory_label"} {
            if {$access_mask & 1} {
                lappend rights system_mandatory_label_no_write_up
            }
            if {$access_mask & 2} {
                lappend rights system_mandatory_label_no_read_up
            }
            if {$access_mask & 4} {
                lappend rights system_mandatory_label_no_execute_up
            }
            return $rights
        }

        # The returned list will include rights that map to multiple bits
        # as well as the individual bits. We first add the multiple bits
        # and then the individual bits (since we clear individual bits
        # after adding)

        #
        # Check standard multiple bit masks
        #
        foreach x {STANDARD_RIGHTS_REQUIRED STANDARD_RIGHTS_READ STANDARD_RIGHTS_WRITE STANDARD_RIGHTS_EXECUTE STANDARD_RIGHTS_ALL SPECIFIC_RIGHTS_ALL} {
            if {($security_defs($x) & $access_mask) == $security_defs($x)} {
                lappend rights [string tolower $x]
            }
        }

        #
        # Check type specific multiple bit masks.
        #
        
        set type_mask_map {
            file {FILE_ALL_ACCESS FILE_GENERIC_READ FILE_GENERIC_WRITE FILE_GENERIC_EXECUTE}
            process {PROCESS_ALL_ACCESS}
            pipe {FILE_ALL_ACCESS}
            policy {POLICY_READ POLICY_WRITE POLICY_EXECUTE POLICY_ALL_ACCESS}
            registry {KEY_READ KEY_WRITE KEY_EXECUTE KEY_ALL_ACCESS}
            service {SERVICE_ALL_ACCESS}
            thread {THREAD_ALL_ACCESS}
            token {TOKEN_READ TOKEN_WRITE TOKEN_EXECUTE TOKEN_ALL_ACCESS}
            desktop {}
            winsta {WINSTA_ALL_ACCESS}
        }
        if {[dict exists $type_mask_map $type]} {
            foreach x [dict get $type_mask_map $type] {
                if {($security_defs($x) & $access_mask) == $security_defs($x)} {
                    lappend rights [string tolower $x]
                }
            }
        }

        #
        # OK, now map individual bits

        # First map the common bits
        foreach x {DELETE READ_CONTROL WRITE_DAC WRITE_OWNER SYNCHRONIZE} {
            if {$security_defs($x) & $access_mask} {
                lappend rights [string tolower $x]
                resetbits access_mask $security_defs($x)
            }
        }

        # Then the generic bits
        foreach x {GENERIC_READ GENERIC_WRITE GENERIC_EXECUTE GENERIC_ALL} {
            if {$security_defs($x) & $access_mask} {
                lappend rights [string tolower $x]
                resetbits access_mask $security_defs($x)
            }
        }

        # Then the type specific
        set type_mask_map {
            file { FILE_READ_DATA FILE_WRITE_DATA FILE_APPEND_DATA
                FILE_READ_EA FILE_WRITE_EA FILE_EXECUTE
                FILE_DELETE_CHILD FILE_READ_ATTRIBUTES
                FILE_WRITE_ATTRIBUTES }
            pipe { FILE_READ_DATA FILE_WRITE_DATA FILE_CREATE_PIPE_INSTANCE
                FILE_READ_ATTRIBUTES FILE_WRITE_ATTRIBUTES }
            service { SERVICE_QUERY_CONFIG SERVICE_CHANGE_CONFIG
                SERVICE_QUERY_STATUS SERVICE_ENUMERATE_DEPENDENTS
                SERVICE_START SERVICE_STOP SERVICE_PAUSE_CONTINUE
                SERVICE_INTERROGATE SERVICE_USER_DEFINED_CONTROL }
            registry { KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY
                KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK
                KEY_WOW64_32KEY KEY_WOW64_64KEY KEY_WOW64_RES }
            policy { POLICY_VIEW_LOCAL_INFORMATION POLICY_VIEW_AUDIT_INFORMATION
                POLICY_GET_PRIVATE_INFORMATION POLICY_TRUST_ADMIN
                POLICY_CREATE_ACCOUNT POLICY_CREATE_SECRET
                POLICY_CREATE_PRIVILEGE POLICY_SET_DEFAULT_QUOTA_LIMITS
                POLICY_SET_AUDIT_REQUIREMENTS POLICY_AUDIT_LOG_ADMIN
                POLICY_SERVER_ADMIN POLICY_LOOKUP_NAMES }
            process { PROCESS_TERMINATE PROCESS_CREATE_THREAD
                PROCESS_SET_SESSIONID PROCESS_VM_OPERATION
                PROCESS_VM_READ PROCESS_VM_WRITE PROCESS_DUP_HANDLE
                PROCESS_CREATE_PROCESS PROCESS_SET_QUOTA
                PROCESS_SET_INFORMATION PROCESS_QUERY_INFORMATION
                PROCESS_SUSPEND_RESUME} 
            thread { THREAD_TERMINATE THREAD_SUSPEND_RESUME
                THREAD_GET_CONTEXT THREAD_SET_CONTEXT
                THREAD_SET_INFORMATION THREAD_QUERY_INFORMATION
                THREAD_SET_THREAD_TOKEN THREAD_IMPERSONATE
                THREAD_DIRECT_IMPERSONATION
                THREAD_SET_LIMITED_INFORMATION
                THREAD_QUERY_LIMITED_INFORMATION }
            token { TOKEN_ASSIGN_PRIMARY TOKEN_DUPLICATE TOKEN_IMPERSONATE
                TOKEN_QUERY TOKEN_QUERY_SOURCE TOKEN_ADJUST_PRIVILEGES
                TOKEN_ADJUST_GROUPS TOKEN_ADJUST_DEFAULT TOKEN_ADJUST_SESSIONID }
            desktop { DESKTOP_READOBJECTS DESKTOP_CREATEWINDOW
                DESKTOP_CREATEMENU DESKTOP_HOOKCONTROL
                DESKTOP_JOURNALRECORD DESKTOP_JOURNALPLAYBACK
                DESKTOP_ENUMERATE DESKTOP_WRITEOBJECTS DESKTOP_SWITCHDESKTOP }
            windowstation { WINSTA_ENUMDESKTOPS WINSTA_READATTRIBUTES
                WINSTA_ACCESSCLIPBOARD WINSTA_CREATEDESKTOP
                WINSTA_WRITEATTRIBUTES WINSTA_ACCESSGLOBALATOMS
                WINSTA_EXITWINDOWS WINSTA_ENUMERATE WINSTA_READSCREEN }
            winsta { WINSTA_ENUMDESKTOPS WINSTA_READATTRIBUTES
                WINSTA_ACCESSCLIPBOARD WINSTA_CREATEDESKTOP
                WINSTA_WRITEATTRIBUTES WINSTA_ACCESSGLOBALATOMS
                WINSTA_EXITWINDOWS WINSTA_ENUMERATE WINSTA_READSCREEN }
            com { COM_RIGHTS_EXECUTE COM_RIGHTS_EXECUTE_LOCAL 
                COM_RIGHTS_EXECUTE_REMOTE COM_RIGHTS_ACTIVATE_LOCAL 
                COM_RIGHTS_ACTIVATE_REMOTE 
            }
        }

        if {[min_os_version 6]} {
            dict lappend type_mask_map process PROCESS_QUERY_LIMITED_INFORMATION
        }

        if {[dict exists $type_mask_map $type]} {
            foreach x [dict get $type_mask_map $type] {
                if {$security_defs($x) & $access_mask} {
                    lappend rights [string tolower $x]
                    # Reset the bit so is it not included in unknown bits below
                    resetbits access_mask $security_defs($x)
                }
            }
        }

        # Finally add left over bits if any
        for {set i 0} {$i < 32} {incr i} {
            set x [expr {1 << $i}]
            if {$access_mask & $x} {
                lappend rights [hex32 $x]
            }
        }

        return $rights
    }

    return [_access_mask_to_rights $access_mask $type]
}

# Map the symbolic CreateDisposition parameter of CreateFile to integer values
proc twapi::_create_disposition_to_code {sym} {
    if {[string is integer -strict $sym]} {
        return $sym
    }
    # CREATE_NEW          1
    # CREATE_ALWAYS       2
    # OPEN_EXISTING       3
    # OPEN_ALWAYS         4
    # TRUNCATE_EXISTING   5
    return [dict get {
        create_new 1
        create_always 2
        open_existing 3
        open_always 4
        truncate_existing 5} $sym]
}

# Wrapper around CreateFile
proc twapi::create_file {path args} {
    array set opts [parseargs args {
        {access.arg {generic_read}}
        {share.arg {read write delete}}
        {inherit.bool 0}
        {secd.arg ""}
        {createdisposition.arg open_always}
        {flags.int 0}
        {templatefile.arg NULL}
    } -maxleftover 0]

    set access_mode [_access_rights_to_mask $opts(access)]
    set share_mode [_share_mode_to_mask $opts(share)]
    set create_disposition [_create_disposition_to_code $opts(createdisposition)]
    return [CreateFile $path \
                $access_mode \
                $share_mode \
                [_make_secattr $opts(secd) $opts(inherit)] \
                $create_disposition \
                $opts(flags) \
                $opts(templatefile)]
}

# Map a set of share mode symbols to a flag. Concatenates
# all the arguments, and then OR's the individual elements. Each
# element may either be a integer or one of the share modes
proc twapi::_share_mode_to_mask {modelist} {
    # Values correspond to FILE_SHARE_* defines
    return [_parse_symbolic_bitmask $modelist {read 1 write 2 delete 4}]
}

# Construct a security attributes structure out of a security descriptor
# and inheritance. The command is here because we do not want to
# have to load the twapi_security package for the common case of
# null security attributes.
proc twapi::_make_secattr {secd inherit} {
    if {$inherit} {
        set sec_attr [list $secd 1]
    } else {
        if {[llength $secd] == 0} {
            # If a security descriptor not specified, keep
            # all security attributes as an empty list (ie. NULL)
            set sec_attr [list ]
        } else {
            set sec_attr [list $secd 0]
        }
    }
    return $sec_attr
}

# Returns the sid, domain and type for an account
proc twapi::lookup_account_name {name args} {
    variable _name_to_sid_cache

    # Fast path - no options specified and cached
    if {[llength $args] == 0 && [dict exists $_name_to_sid_cache "" $name]} {
        return [lindex [dict get $_name_to_sid_cache "" $name] 0]
    }

    array set opts [parseargs args \
                        [list all \
                             sid \
                             domain \
                             type \
                             [list system.arg ""]\
                            ]]

    if {! [dict exists $_name_to_sid_cache $opts(system) $name]} {
        dict set _name_to_sid_cache $opts(system) $name [LookupAccountName $opts(system) $name]
    }    
    lassign [dict get $_name_to_sid_cache $opts(system) $name] sid domain type

    set result [list ]
    if {$opts(all) || $opts(domain)} {
        lappend result -domain $domain
    }
    if {$opts(all) || $opts(type)} {
        variable sid_type_names
        if {[info exists sid_type_names($type)]} {
            lappend result -type $sid_type_names($type)
        } else {
            # Could be the "logonid" dummy type we added above
            lappend result -type $type
        }
    }

    if {$opts(all) || $opts(sid)} {
        lappend result -sid $sid
    }

    # If no options specified, only return the sid/name
    if {[llength $result] == 0} {
        return $sid
    }

    return $result
}


# Returns the name, domain and type for an account
proc twapi::lookup_account_sid {sid args} {
    variable _sid_to_name_cache

    # Fast path - no options specified and cached
    if {[llength $args] == 0 && [dict exists $_sid_to_name_cache "" $sid]} {
        return [lindex [dict get $_sid_to_name_cache "" $sid] 0]
    }

    array set opts [parseargs args \
                        [list all \
                             name \
                             domain \
                             type \
                             [list system.arg ""]\
                            ]]

    if {[dict exists $_sid_to_name_cache $opts(system) $sid]} {
        lassign [dict get $_sid_to_name_cache $opts(system) $sid] name domain type
    } else {
        # Not in cache. Need to look up

        trap {
            set data [LookupAccountSid $opts(system) $sid]
            lassign $data name domain type
        } onerror {TWAPI_WIN32 1332} {
            # Win10 resolves this, Win7 does not. Emulate Win10
            if {![string match -nocase "S-1-5-5-*" $sid]} {
                rethrow
            }
            # Name is formed similar to how Win10 does it
            set name "LogonSessionId_[string map {- _} [string range $sid 8 end]]"
            set domain "NT AUTHORITY"
            set type 11
            set data [list $name $domain $type]
        }
        dict set _sid_to_name_cache $opts(system) $sid $data
    }


    set result [list ]
    if {$opts(all) || $opts(domain)} {
        lappend result -domain $domain
    }
    if {$opts(all) || $opts(type)} {
        variable sid_type_names
        if {[info exists sid_type_names($type)]} {
            lappend result -type $sid_type_names($type)
        } else {
            lappend result -type $type
        }
    }

    if {$opts(all) || $opts(name)} {
        lappend result -name $name
    }

    # If no options specified, only return the sid/name
    if {[llength $result] == 0} {
        return $name
    }

    return $result
}

# Returns the sid for a account - may be given as a SID or name
proc twapi::map_account_to_sid {account args} {
    array set opts [parseargs args {system.arg} -nulldefault]

    # Treat empty account as null SID (self)
    if {[string length $account] == ""} {
        return ""
    }

    if {[is_valid_sid_syntax $account]} {
        return $account
    } else {
        return [lookup_account_name $account -system $opts(system)]
    }
}


# Returns the name for a account - may be given as a SID or name
proc twapi::map_account_to_name {account args} {
    array set opts [parseargs args {system.arg} -nulldefault]

    if {[is_valid_sid_syntax $account]} {
        return [lookup_account_sid $account -system $opts(system)]
    } else {
        # Verify whether a valid account by mapping to an sid
        if {[catch {map_account_to_sid $account -system $opts(system)}]} {
            # As a special case, change LocalSystem to SYSTEM. Some Windows
            # API's (such as services) return LocalSystem which cannot be
            # resolved by the security functions. This name is really the
            # same a the built-in SYSTEM
            if {$account == "LocalSystem"} {
                return "SYSTEM"
            }
            error "Unknown account '$account'"
        } 
        return $account
    }
}

# Return the user account for the current process
proc twapi::get_current_user {{format -samcompatible}} {

    set return_sid false
    switch -exact -- $format {
        -fullyqualifieddn {set format 1}
        -samcompatible {set format 2}
        -display {set format 3}
        -uniqueid {set format 6}
        -canonical {set format 7}
        -userprincipal {set format 8}
        -canonicalex {set format 9}
        -serviceprincipal {set format 10}
        -dnsdomain {set format 12}
        -sid {set format 2 ; set return_sid true}
        default {
            error "Unknown user name format '$format'"
        }
    }

    set user [GetUserNameEx $format]

    if {$return_sid} {
        return [map_account_to_sid $user]
    } else {
        return $user
    }
}

# Get a new uuid
proc twapi::new_uuid {{opt ""}} {
    if {[string length $opt]} {
        if {[string equal $opt "-localok"]} {
            set local_ok 1
        } else {
            error "Invalid or unknown argument '$opt'"
        }
    } else {
        set local_ok 0
    }
    return [UuidCreate $local_ok] 
}
proc twapi::nil_uuid {} {
    return [UuidCreateNil]
}

proc twapi::new_guid {} {
    return [canonicalize_guid [new_uuid]]
}

# Get a handle to a LSA policy. TBD - document
proc twapi::get_lsa_policy_handle {args} {
    array set opts [parseargs args {
        {system.arg ""}
        {access.arg policy_read}
    } -maxleftover 0]

    set access [_access_rights_to_mask $opts(access)]
    return [Twapi_LsaOpenPolicy $opts(system) $access]
}

# Close a LSA policy handle. TBD - document
proc twapi::close_lsa_policy_handle {h} {
    LsaClose $h
    return
}

# Eventlog stuff in the base package

namespace eval twapi {
    # Keep track of event log handles - values are "r" or "w"
    variable eventlog_handles
    array set eventlog_handles {}
}

# Open an eventlog for reading or writing
proc twapi::eventlog_open {args} {
    variable eventlog_handles

    array set opts [parseargs args {
        system.arg
        source.arg
        file.arg
        write
    } -nulldefault -maxleftover 0]
    if {$opts(source) == ""} {
        # Source not specified
        if {$opts(file) == ""} {
            # No source or file specified, default to current event log 
            # using executable name as source
            set opts(source) [file rootname [file tail [info nameofexecutable]]]
        } else {
            if {$opts(write)} {
                error "Option -file may not be used with -write"
            }
        }
    } else {
        # Source explicitly specified
        if {$opts(file) != ""} {
            error "Option -file may not be used with -source"
        }
    }

    if {$opts(write)} {
        set handle [RegisterEventSource $opts(system) $opts(source)]
        set mode write
    } else {
        if {$opts(source) != ""} {
            set handle [OpenEventLog $opts(system) $opts(source)]
        } else {
            set handle [OpenBackupEventLog $opts(system) $opts(file)]
        }
        set mode read
    }

    set eventlog_handles($handle) $mode
    return $handle
}

# Close an event log opened for writing
proc twapi::eventlog_close {hevl} {
    variable eventlog_handles

    if {[_eventlog_valid_handle $hevl read]} {
        CloseEventLog $hevl
    } else {
        DeregisterEventSource $hevl
    }

    unset eventlog_handles($hevl)
}


# Log an event
proc twapi::eventlog_write {hevl id args} {
    _eventlog_valid_handle $hevl write raise

    array set opts [parseargs args {
        {type.arg information {success error warning information auditsuccess auditfailure}}
        {category.int 1}
        loguser
        params.arg
        data.arg
    } -nulldefault]


    switch -exact -- $opts(type) {
        success          {set opts(type) 0}
        error            {set opts(type) 1}
        warning          {set opts(type) 2}
        information      {set opts(type) 4}
        auditsuccess     {set opts(type) 8}
        auditfailure     {set opts(type) 16}
        default {error "Invalid value '$opts(type)' for option -type"}
    }
    
    if {$opts(loguser)} {
        set user [get_current_user -sid]
    } else {
        set user ""
    }

    ReportEvent $hevl $opts(type) $opts(category) $id \
        $user $opts(params) $opts(data)
}


# Log a message 
proc twapi::eventlog_log {message args} {
    array set opts [parseargs args {
        system.arg
        source.arg
        {type.arg information}
        {category.int 0}
    } -nulldefault]

    set hevl [eventlog_open -write -source $opts(source) -system $opts(system)]

    trap {
        eventlog_write $hevl 1 -params [list $message] -type $opts(type) -category $opts(category)
    } finally {
        eventlog_close $hevl
    }
    return
}

proc twapi::make_logon_identity {username password domain} {
    if {[concealed? $password]} {
        return [list $username $domain $password]
    } else {
        return [list $username $domain [conceal $password]]
    }
}

proc twapi::read_credentials {args} {
    # DEPRECATED
    array set opts [parseargs args {
        target.arg
        winerror.int
        username.arg
        password.arg
        persist.bool
        {type.sym generic {domain 0 generic 0x40000 runas 0x80000}}
        {forceui.bool 0 0x80}
        {showsaveoption.bool true}
        {expectconfirmation.bool 0 0x20000}
    } -maxleftover 0 -nulldefault]

    if {$opts(persist) && ! $opts(expectconfirmation)} {
        badargs! "Option -expectconfirmation must be specified as true if -persist is true"
    }

    # 0x8 -> CREDUI_FLAGS_EXCLUDE_CERTIFICATES (needed for console)
    set flags [expr {0x8 | $opts(forceui) | $opts(expectconfirmation)}]

    if {$opts(persist)} {
        if {! $opts(showsaveoption)} {
            incr flags 0x1000;  # CREDUI_FLAGS_PERSIST
        }
    } else {
        incr flags 0x2;         # CREDUI_FLAGS_DO_NOT_PERSIST
        if {$opts(showsaveoption)} {
            incr flags 0x40;    # CREDUI_FLAGS_SHOW_SAVE_CHECK_BOX
        }
    }

    incr flags $opts(type)

    return [CredUICmdLinePromptForCredentials $opts(target) NULL $opts(winerror) $opts(username) $opts(password) $opts(persist) $flags]
}

proc twapi::credentials_dialog {args} {
    # DEPRECATED
    array set opts [parseargs args {
        target.arg
        winerror.int
        username.arg
        password.arg
        persist.bool
        {type.sym generic {domain 0 generic 0x40000 runas 0x80000}}
        {forceui.bool 0 0x80}
        {showsaveoption.bool true}
        {expectconfirmation.bool 0 0x20000}
        {fillusername.bool 0 0x800}
        {filllocaladmins.bool 0 0x4}
        {notifyfail.bool 0 0x1}
        {passwordonly.bool 0 0x200}
        {requirecertificate.bool 0 0x10}
        {requiresmartcard.bool 0 0x100}
        {validateusername.bool 0 0x400}
        {parent.arg NULL}
        message.arg
        caption.arg
        {bitmap.arg NULL}
    } -maxleftover 0 -nulldefault]

    if {$opts(persist) && ! $opts(expectconfirmation)} {
        badargs! "Option -willconfirm must be specified as true if -persist is true"
    }

    set flags [expr { 0x8 | $opts(forceui) | $opts(notifyfail) | $opts(expectconfirmation) | $opts(fillusername) | $opts(filllocaladmins)}]

    if {$opts(persist)} {
        if {! $opts(showsaveoption)} {
            incr flags 0x1000;  # CREDUI_FLAGS_PERSIST
        }
    } else {
        incr flags 0x2;         # CREDUI_FLAGS_DO_NOT_PERSIST
        if {$opts(showsaveoption)} {
            incr flags 0x40;    # CREDUI_FLAGS_SHOW_SAVE_CHECK_BOX
        }
    }

    incr flags $opts(type)

    return [CredUIPromptForCredentials [list $opts(parent) $opts(message) $opts(caption) $opts(bitmap)] $opts(target) NULL $opts(winerror) $opts(username) $opts(password) $opts(persist) $flags]
}

proc twapi::confirm_credentials {target valid} {
    # DEPRECATED
    return [CredUIConfirmCredentials $target $valid]
}


proc twapi::_make_cred_persist_flags {persist showsave} {
    # Use cases -
    #  (1) credentials to be persisted WITHOUT showing save option to user
    #  (2) credentials to be persisted AFTER showing save option to user
    #  (3) credentials NOT to be persisted, user not shown save option
    #  (4) credentials NOT to be persisted, but user shown save option
    # In case (4), caller has to decide what to do with the credentials if
    # user selects to save (e.g. save elsewhere)
    # If credentials are to be persisted, caller MUST call cred_confirm later
    
    if {$persist} {
        # Note CREDUI_FLAGS_EXPECT_CONFIRMATION (0x20000) must be specified
        # whenever CREDUI_FLAGS_DO_NOT_PERSIST is not specified
        if {$showsave} {
            # (2) CREDUI_FLAGS_EXPECT_CONFIRMATION
            return 0x20000
        } else {
            # (1) CREDUI_FLAGS_PERSIST | CREDUI_FLAGS_EXPECT_CONFIRMATION
            return 0x21000
        }
    } else {
        if {$showsave} {
            # (4) CREDUI_FLAGS_DO_NOT_PERSIST | CREDUI_FLAGS_SHOW_SAVE_CHECK_BOX
            return 0x42
        } else {
            # (3) CREDUI_FLAGS_DO_NOT_PERSIST
            return 0x02
        }
    }
}

proc twapi::cred_prompt_console {target args} {
    # Not documented because Windows seems to ignore on Win10 at least -
    #  -password, -winerror
    array set opts [parseargs args {
        {forceui.bool 0 0x80}
        password.arg
        persist.bool
        {showsaveoption.bool 0}
        {type.sym generic {domain 0 generic 0x40000 runas 0x80000}}
        username.arg
        winerror.int
    } -maxleftover 0 -nulldefault]

    if {$target eq ""} {
        error "Target must not be an empty string."
    }

    if {$opts(forceui) && $opts(type) != 0x40000} {
        error "The -forceui option can only be set if -type is \"generic\"."
    }

    if {$opts(type) == 0x80000 && $opts(username) eq ""} {
        # CredUIPromptForCredentials crashes
        error "The -username option must not be an empty string if -type is \"runas\"."
    }

    set flags [_make_cred_persist_flags $opts(persist) $opts(showsaveoption)]

    # 0x8 -> CREDUI_FLAGS_EXCLUDE_CERTIFICATES (needed for console)
    set flags [expr {0x8 | $flags | $opts(type) | $opts(forceui)}]

    return [CredUICmdLinePromptForCredentials $target NULL $opts(winerror) $opts(username) $opts(password) $opts(persist) $flags]
}

proc twapi::cred_prompt_gui {target args} {
    # Not documented because Windows seems to ignore on Win10 at least -
    #  -passwordonly, -notifyfail, -winerror
    array set opts [parseargs args {
        {bitmap.arg NULL}
        caption.arg
        {excludecertificates.bool 0 0x8}
        {filllocaladmins.bool 0 0x4}
        {completeusername.bool 0 0x800}
        {forceui.bool 0 0x80}
        {keepusername.bool 0 0x100000}
        message.arg
        {notifyfail.bool 0 0x1}
        {parent.arg NULL}
        password.arg
        {passwordonly.bool 0 0x200}
        persist.bool
        {requirecertificate.bool 0 0x10}
        {requiresmartcard.bool 0 0x100}
        {showsaveoption.bool 0}
        {type.sym generic {domain 0 generic 0x40000 runas 0x80000}}
        username.arg
        {validateusername.bool 0 0x400}
        winerror.int
    } -maxleftover 0 -nulldefault]

    if {$target eq ""} {
        error "Target must not be an empty string."
    }

    if {$opts(forceui) && $opts(type) != 0x40000} {
        error "The -forceui option can only be set if -type is \"generic\"."
    }

    if {$opts(type) == 0x80000 && $opts(username) eq ""} {
        # CredUIPromptForCredentials crashes
        error "The -username option must not be an empty string if -type is \"runas\"."
    }

    set flags [_make_cred_persist_flags $opts(persist) $opts(showsaveoption)]
    set flags [expr {
                     $flags |
                     $opts(excludecertificates) |
                     $opts(filllocaladmins) |
                     $opts(completeusername) |
                     $opts(forceui) |
                     $opts(keepusername) |
                     $opts(notifyfail) |
                     $opts(passwordonly) |
                     $opts(requirecertificate) |
                     $opts(requiresmartcard) |
                     $opts(type) |
                     $opts(validateusername)
                 }]

    return [CredUIPromptForCredentials [list $opts(parent) $opts(message) $opts(caption) $opts(bitmap)] $target NULL $opts(winerror) $opts(username) $opts(password) $opts(persist) $flags]
}

proc twapi::cred_confirm {target valid} {
    return [CredUIConfirmCredentials $target $valid]
}

# Validate a handle for a mode. Always raises error if handle is invalid
# If handle valid but not for that mode, will raise error iff $raise_error
# is non-empty. Returns 1 if valid, 0 otherwise
proc twapi::_eventlog_valid_handle {hevl mode {raise_error ""}} {
    variable eventlog_handles
    if {![info exists eventlog_handles($hevl)]} {
        error "Invalid event log handle '$hevl'"
    }

    if {[string compare $eventlog_handles($hevl) $mode]} {
        if {$raise_error != ""} {
            error "Eventlog handle '$hevl' not valid for $mode"
        }
        return 0
    } else {
        return 1
    }
}

### Common disk related

# Map bit mask to list of drive letters
proc twapi::_drivemask_to_drivelist {drivebits} {
    set drives [list ]
    set i 0
    foreach drive {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} {
        if {$drivebits == 0} break
        set drivemask [expr {1 << $i}]
        if {[expr {$drivebits & $drivemask}]} {
            lappend drives $drive:
            set drivebits [expr {$drivebits & ~ $drivemask}]
        }
        incr i
    }
    return $drives
}

### Type casts
proc twapi::tclcast {type val} {
    # Only permit these because wideInt, for example, cannot be reliably
    # converted -> it can return an int instead.
    set types {"" empty null bstr int boolean double string list dict}
    if {$type ni $types} {
        badargs! "Bad cast to \"$type\". Must be one of: $types"
    }
    return [Twapi_InternalCast $type $val]
}

if {[info commands ::lmap] eq "::lmap"} {
    proc twapi::safearray {type l} {
        set type [dict! {
            variant ""
            boolean boolean
            bool boolean
            int  int
            i4   int
            double double
            r8   double
            string string
            bstr string
        } $type]
        return [lmap val $l {tclcast $type $val}]
    }
} else {
    proc twapi::safearray {type l} {
        set type [dict! {
            variant ""
            boolean boolean
            bool boolean
            int  int
            i4   int
            double double
            r8   double
            string string
            bstr string
        } $type]
        set l2 {}
        foreach val $l {
            lappend l2 [tclcast $type $val]
        }
        return $l2
    }
}

namespace eval twapi::recordarray {}

proc twapi::recordarray::size {ra} {
    return [llength [lindex $ra 1]]
}

proc twapi::recordarray::fields {ra} {
    return [lindex $ra 0]
}

proc twapi::recordarray::index {ra row args} {
    set r [lindex $ra 1 $row]
    if {[llength $r] == 0} {
        return $r
    }
    ::twapi::parseargs args {
        {format.arg list {list dict}}
        slice.arg
    } -setvars -maxleftover 0

    set fields [lindex $ra 0]
    if {[info exists slice]} {
        set new_fields {}        
        set new_r {}
        foreach field $slice {
            set i [twapi::enum $fields $field]
            lappend new_r [lindex $r $i]
            lappend new_fields [lindex $fields $i]
        }
        set r $new_r
        set fields $new_fields
    }

    if {$format eq "list"} {
        return $r
    } else {
        return [::twapi::twine $fields $r]
    }
}

proc twapi::recordarray::range {ra low high} {
    return [list [lindex $ra 0] [lrange [lindex $ra 1] $low $high]]
}

proc twapi::recordarray::column {ra field args} {
    # TBD - time to see if a script loop would be faster
    ::twapi::parseargs args {
        filter.arg
    } -nulldefault -maxleftover 0 -setvars
    _recordarray -slice [list $field] -filter $filter -format flat $ra
}

proc twapi::recordarray::cell {ra row field} {
    return [lindex [lindex $ra 1 $row] [twapi::enum [lindex $ra 0] $field]]
}

proc twapi::recordarray::get {ra args} {
    ::twapi::parseargs args {
        {format.arg list {list dict flat}}
        key.arg
    } -ignoreunknown -setvars

    # format & key are options just to stop them flowing down to _recordarray
    # We do not pass it in

    return [_recordarray {*}$args $ra]
}

proc twapi::recordarray::getlist {ra args} {
    # key is an option just to stop in flowing down to _recordarray
    # We do not pass it in

    if {[llength $args] == 0} {
        return [lindex $ra 1]
    }

    ::twapi::parseargs args {
        {format.arg list {list dict flat}}
        key.arg
    } -ignoreunknown -setvars


    return [_recordarray {*}$args -format $format $ra]
}

proc twapi::recordarray::getdict {ra args} {
    ::twapi::parseargs args {
        {format.arg list {list dict}}
        key.arg
    } -ignoreunknown -setvars

    if {![info exists key]} {
        set key [lindex $ra 0 0]
    }

    # Note _recordarray has different (putting it politely) semantics
    # of how -format and -key option are handled so the below might
    # look a bit strange in that we pass -format as list and get
    # back a dict
    return [_recordarray {*}$args -format $format -key $key $ra]
}

proc twapi::recordarray::iterate {arrayvarname ra args} {

    if {[llength $args] == 0} {
        badargs! "No script supplied"
    }

    set body [lindex $args end]
    set args [lrange $args 0 end-1]

    upvar 1 $arrayvarname var

    # TBD - Can this be optimized by prepending a ::foreach to body
    # and executing that in uplevel 1 ?

    foreach rec [getlist $ra {*}$args -format dict] {
        array set var $rec
        set code [catch {uplevel 1 $body} result]
        switch -exact -- $code {
            0 {}
            1 {
                return -errorinfo $::errorInfo -errorcode $::errorCode -code error $result
            }
            3 {
                return;          # break
            }
            4 {
                # continue
            }
            default {
                return -code $code $result
            }
        }
    }
    return
}

proc twapi::recordarray::rename {ra renames} {
    set new_fields {}
    foreach field [lindex $ra 0] {
        if {[dict exists $renames $field]} {
            lappend new_fields [dict get $renames $field]
        } else {
            lappend new_fields $field
        }
    }
    return [list $new_fields [lindex $ra 1]]
}

proc twapi::recordarray::concat {args} {
    if {[llength $args] == 0} {
        return {}
    }
    set args [lassign $args ra]
    set fields [lindex $ra 0]
    set values [list [lindex $ra 1]]
    set width [llength $fields]
    foreach ra $args {
        foreach fld1 $fields fld2 [lindex $ra 0] {
            if {$fld1 ne $fld2} {
                twapi::badargs! "Attempt to concat record arrays with different fields ([join $fields ,] versus [join [lindex $ra 0] ,])"
            }
        }
        lappend values [lindex $ra 1]
    }

    return [list $fields [::twapi::lconcat {*}$values]]
}

namespace eval twapi::recordarray {
    namespace export cell column concat fields get getdict getlist index iterate range rename size
    namespace ensemble create
}

proc twapi::_parse_ctype {def parse_mode} {
    variable _struct_defs
    
    # parse_mode is "struct", "param" or "function"

    if {![regexp -expanded {
        ^
        \s*
        (.+[^[:alnum:]_]) # type
        ([[:alnum:]_]+)   # name
        \s*
        (\[.+\])?         # array size
        \s*$
    } $def ->  type name array]} {
        error "Invalid C type definition $def"
    }
        
    set child {}
    switch -regexp -matchvar matchvar -- [string trim $type] {
        {^void$} {
            if {$parse_mode ne "function"} {
                error "Type void cannot be used for structs and parameters."
            }
            set type void
        }
        {^char$} {set type i1}
        {^BYTE$} -
        {^unsigned char$} {set type ui1}
        {^short$} {set type i2}
        {^WORD$} -
        {^unsigned\s+short$} {set type ui2}
        {^BOOLEAN$} {set type bool}
        {^LONG$} -
        {^int$} {set type i4}
        {^UINT$} -
        {^ULONG$} -
        {^DWORD$} -
        {^unsigned\s+int$} {set type ui4}
        {^__int64$} {set type i8}
        {^unsigned\s+__int64$} {set type ui8}
        {^double$} {set type r8}
        {^float$} {set type r4}
        {^LPCSTR$} -
        {^LPSTR$} -
        {^char\s*\*$} {set type lpstr}
        {^LPCWSTR$} -
        {^LPWSTR$} -
        {^WCHAR\s*\*$} {set type lpwstr}
        {^HANDLE$} {set type handle}
        {^PSID$} {set type psid}
        {^struct\s+([[:alnum:]_]+)$} {
            if {$parse_mode ne "struct"} {
                error "Structure types not allowed for parameters and return values."
            }
            # Embedded struct. It should be defined already. Calling
            # it with no args returns its definition but doing that
            # to retrieve the definition could be a security hole
            # (could be passed any Tcl command!) if unwary apps
            # pass in input from unknown sources. So we explicitly
            # remember definitions instead.
            set child_name [lindex $matchvar 1]
            if {![info exists _struct_defs($child_name)]} {
                error "Unknown struct $child_name"
            }
            set child $_struct_defs($child_name)
            set type struct
        }
        default {error "Unknown type $type"}
    }
    set count 0
    if {$array ne ""} {
        set count [string trim [string range $array 1 end-1]]
        if {![string is integer -strict $count]} {
            error "Non-integer array size"
        }
        if {$parse_mode ne "struct"} {
            error "Arrays not allowed for parameters and return values."
        }
    }

    if {[string equal -nocase $name "cbSize"] &&
        $type in {i4 ui4} && $count == 0} {
        set type cbsize
    }

    return [list $name $type $count $child]
}

proc twapi::_parse_cproto {s} {
    variable _struct_defs
    
    # Get rid of comments
    regsub -all {(/\*.* \*/){1,1}?} $s {} s
    regsub -line -all {//.*$} $s { } s

    if {![regexp -expanded {
        ^
        \s*
        (?:(_cdecl|_stdcall)\s+)?
        ([[:alnum:]_][[:space:][:alnum:]_]*) # Function type and name
        \s*
        \(              # Beginning of parameters
        ([^\)]*)        # Parameter definition string
        \)              # End of parameters
        \s*$            # End of prototype
    } $s -> callconv fntypeandname paramstr]} {
        error "Invalid C prototype \"$s\""
    }

    regsub -all {\s+} $fntypeandname " "
    set fntype [_parse_ctype $fntypeandname function]
    set params {}
    foreach def [split $paramstr ","] {
        lappend params [_parse_ctype $def param]
    }

    return [list $callconv $fntype [lindex $fntype 0] $params]
}

# Return a suitable cstruct definition based on a C definition
proc twapi::struct {struct_name s} {
    variable _struct_defs

    if {0} {
        TBD - Commented out because nested structs do not currently
        handle namespaces. However this means structs are effectively
        global even if the corresponding command is not.
        set struct_name [callerns $struct_name]
    }
    
    regsub -all {(/\*.* \*/){1,1}?} $s {} s
    regsub -line -all {//.*$} $s { } s
    set l {}
    foreach def [split $s ";"] {
        set def [string trim $def]
        if {$def eq ""} continue
        lappend l [_parse_ctype $def struct]
    }

    set proc_body [format {
        set def %s
        if {[llength $args] == 0} {
            return $def
        } else {
            return [list $def $args]
        }
    } [list $l]]
    uplevel 1 [list proc $struct_name args $proc_body]
    set _struct_defs($struct_name) $l
    return
}


proc twapi::ffi_load {path} {
    variable _ffi_paths
    variable _ffi_handles

    # Note we do NOT normalize path as we leave it to the OS to do so.
    # We also do not canonicalize it (e.g. all lower case).
    # This means there may be multiple handles for a single shared lib
    # but that's ok.
    
    if {[dict exists $_ffi_paths $path]} {
        set h [dict get $_ffi_paths $path]
        if {![dict exists $_ffi_handles $h]} {
            error "Internal error: Handle $h not found in FFI table."
        }
        dict with _ffi_handles $h {
            if {$Path ne $path} {
                error "Internal error: Handle $h not assigned to $path"
            }
            incr NRefs
        }
    } else {
        set h [load_library $path]
        dict set _ffi_paths $path $h
        dict set _ffi_handles $h Path $path
        dict set _ffi_handles $h NRefs 1
    }
    return $h
}

proc twapi::ffi_unload {h} {
    variable _ffi_handles
    variable _ffi_paths

    if {![dict exists $_ffi_handles $h]} {
        error "FFI handle $h does not exist."
    }

    dict with _ffi_handles $h {
        if {[incr NRefs -1] <= 0} {
            dict unset _ffi_paths $Path
            dict unset _ffi_handles $h
        }
    }

    return
}

proc twapi::ffi_cfuncs {dllh cprotos {ns ::}} {
    variable _ffi_handles

    if {![dict exists $_ffi_handles $dllh]} {
    #    error "Unknown FFI handle \"$dllh\"."
    }

    set l {}
    foreach cproto [split $cprotos ";"] {
        set cproto [string trim $cproto]
        if {$cproto eq ""} continue
        lappend l [_parse_cproto $cproto]
    }
    set cprotos $l

    set def {
        proc %NAME% {%PARAMNAMES%} {
            if {![dict exists $%TWAPINS%::_ffi_handles %DLLH%]} {
                error "Attempt to call function in unloaded library."
            }
            %TWAPINS%::%CALL% %FNADDR% %FNTYPE% %PARAMS% [list %PARAMREFS%]
        }
    }

    if {$::tcl_platform(pointerSize) == 8} {
        # Win64 has single calling convention
        set callmap {"" ffi_call _cdecl ffi_call _stdcall ffi_call}
    } else {
        set callmap {"" ffi_call _cdecl ffi_call _stdcall ffi_stdcall}
    } 

    foreach cproto $cprotos {
        lassign $cproto callconv fntype fnname params
        set call [dict get $callmap $callconv]
            
        set fnaddr [GetProcAddress $dllh $fnname]
        if {[pointer_null? $fnaddr]} {
            error "Entry point $fnname not found in shared library."
        }
        set paramnames {}
        set paramrefs {}
        foreach arg $params {
            set name [lindex $arg 0]
            lappend paramnames $name
            lappend paramrefs \$$name
        }

        # Note that fntype is doubly listified because the C ffi expects
        # it in same format as params, ie. a list of type definitions
        # _parse_cproto however returns it as a single type definition
        append defs [string map [list \
                                     %CALL%    $call \
                                     %DLLH%    [list $dllh] \
                                     %NAME%    ${ns}::$fnname \
                                     %PARAMNAMES% [join $paramnames { }] \
                                     %PARAMREFS% [join $paramrefs { }] \
                                     %TWAPINS% [namespace current] \
                                     %FNADDR%  [list $fnaddr] \
                                     %FNTYPE%  [list [list $fntype]] \
                                     %PARAMS%  [list $params]] \
                         $def] \n
    }
    
    uplevel 1 $defs 
}


if {[twapi::min_os_version 6]} {
    twapi::ffi_cfuncs [twapi::ffi_load kernel32.dll] {
        UINT GetErrorMode();
        UINT SetErrorMode(UINT mode);
    } ::twapi
}

