#========================================================================

#========================================================================
# Don't modify the file to clean here.  Instead, set the "CLEANFILES"
# variable in configure.in
#========================================================================

clean:
	-test -z "$(BINARIES)" || rm -f $(BINARIES)
	-rm -f *.$(OBJEXT) core *.core
	-test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)

distclean: clean
	-rm -f *.tab.c
	-rm -f $(CONFIG_CLEAN_FILES)

#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
# Generated by GNU Autoconf 2.63 for twapi 4.5.2.
#
# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
# 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.
## --------------------- ##
## M4sh Initialization.  ##

MFLAGS=
MAKEFLAGS=
SHELL=${CONFIG_SHELL-/bin/sh}

# Identity of this package.
PACKAGE_NAME='twapi'
PACKAGE_TARNAME='twapi'
PACKAGE_VERSION='4.5.2'
PACKAGE_STRING='twapi 4.5.2'
PACKAGE_BUGREPORT=''

# Factoring default headers for most tests.
ac_includes_default="\
#include <stdio.h>
#ifdef HAVE_SYS_TYPES_H
# include <sys/types.h>

#
# Report the --help message.
#
if test "$ac_init_help" = "long"; then
  # Omit some internal or obsolete options to make the list less imposing.
  # This message is too long to be a string in the A/UX 3.1 sh.
  cat <<_ACEOF
\`configure' configures twapi 4.5.2 to adapt to many kinds of systems.

Usage: $0 [OPTION]... [VAR=VALUE]...

To assign environment variables (e.g., CC, CFLAGS...), specify them as
VAR=VALUE.  See below for descriptions of some of the useful variables.

Defaults for the options are specified in brackets.

  cat <<\_ACEOF
_ACEOF
fi

if test -n "$ac_init_help"; then
  case $ac_init_help in
     short | recursive ) echo "Configuration of twapi 4.5.2:";;
   esac
  cat <<\_ACEOF

Optional Features:
  --disable-option-checking  ignore unrecognized --enable/--with options
  --disable-FEATURE       do not include FEATURE (same as --enable-FEATURE=no)
  --enable-FEATURE[=ARG]  include FEATURE [ARG=yes]

    cd "$ac_pwd" || { ac_status=$?; break; }
  done
fi

test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
  cat <<\_ACEOF
twapi configure 4.5.2
generated by GNU Autoconf 2.63

Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
  exit
fi
cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.

It was created by twapi $as_me 4.5.2, which was
generated by GNU Autoconf 2.63.  Invocation command line was

  $ $0 $@

_ACEOF
exec 5>>config.log
{

exec 6>&1

# Save the log message, to keep $[0] and so on meaningful, and to
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
This file was extended by twapi $as_me 4.5.2, which was
generated by GNU Autoconf 2.63.  Invocation command line was

  CONFIG_FILES    = $CONFIG_FILES
  CONFIG_HEADERS  = $CONFIG_HEADERS
  CONFIG_LINKS    = $CONFIG_LINKS
  CONFIG_COMMANDS = $CONFIG_COMMANDS
  $ $0 $@

$config_files

Report bugs to <bug-autoconf@gnu.org>."

_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_version="\\
twapi config.status 4.5.2
configured by $0, generated by GNU Autoconf 2.63,
  with options \\"`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\"

Copyright (C) 2008 Free Software Foundation, Inc.
This config.status script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it."

# This initializes the environment with PACKAGE_NAME and PACKAGE_VERSION
# set as provided.  These will also be added as -D defs in your Makefile
# so you can encode the package version directly into the source files.
# This will also define a special symbol for Windows (BUILD_sample in
# this case) so that we create the export library with the dll.
#-----------------------------------------------------------------------

AC_INIT([twapi], [4.5.2])

#--------------------------------------------------------------------
# Call TEA_INIT as the first TEA_ macro to set up initial vars.
# This will define a ${TEA_PLATFORM} variable == "unix" or "windows"
# as well as PKG_LIB_FILE and PKG_STUB_LIB_FILE.
# --------------------------------------------------------------------

	    twapi/base/threadpool.c
	    twapi/base/trap.c
	    twapi/base/twapi.c
	    twapi/base/twine.c
	    twapi/base/util.c
	    twapi/base/win.c
	    twapi/base/winchars.c

	    twapi/account/account.c

	    twapi/apputil/apputil.c

	    twapi/clipboard/clipboard.c

	    twapi/com/com.c

/*

 Package: dyncall
 Library: dyncall
 File: dyncall/dyncall.h
 Description: public header for library dyncall
 License:

   Copyright (c) 2007-2015 Daniel Adler <dadler@uni-goettingen.de>,
                           Tassilo Philipp <tphilipp@potion-studios.com>

   Permission to use, copy, modify, and distribute this software for any
   purpose with or without fee is hereby granted, provided that the above
   copyright notice and this permission notice appear in all copies.

   THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES

  dyncall C API

  REVISION
  2015/07/08 added SYS_PPC64 system call
  2015/01/16 added SYS_PPC32 system call
  2007/12/11 initial

*/

#ifndef DYNCALL_H
#define DYNCALL_H

#include "dyncall_types.h"

#ifdef __cplusplus
extern "C" {
#endif

typedef struct DCCallVM_    DCCallVM;
typedef struct DCstruct_    DCstruct;

/* Supported Calling Convention Modes */

#define DC_CALL_C_DEFAULT               0

DC_API void       dcCallStruct    (DCCallVM* vm, DCpointer funcptr, DCstruct* s, DCpointer returnValue);

DC_API DCint      dcGetError      (DCCallVM* vm);

#define DEFAULT_ALIGNMENT 0
DC_API DCstruct*  dcNewStruct      (DCsize fieldCount, DCint alignment);
DC_API void       dcStructField    (DCstruct* s, DCint type, DCint alignment, DCsize arrayLength);
DC_API void       dcSubStruct      (DCstruct* s, DCsize fieldCount, DCint alignment, DCsize arrayLength);
/* Each dcNewStruct or dcSubStruct call must be paired with a dcCloseStruct. */
DC_API void       dcCloseStruct    (DCstruct* s);
DC_API DCsize     dcStructSize     (DCstruct* s);
DC_API DCsize     dcStructAlignment(DCstruct* s);
DC_API void       dcFreeStruct     (DCstruct* s);

DC_API DCstruct*  dcDefineStruct  (const char* signature);


#ifdef __cplusplus
}
#endif

#endif /* DYNCALL_H */

/*

 Package: dyncall
 Library: dyncall
 File: dyncall/dyncall_config.h
 Description: Macro configuration file for non-standard C types
 License:

   Copyright (c) 2007-2015 Daniel Adler <dadler@uni-goettingen.de>,
                           Tassilo Philipp <tphilipp@potion-studios.com>

   Permission to use, copy, modify, and distribute this software for any
   purpose with or without fee is hereby granted, provided that the above
   copyright notice and this permission notice appear in all copies.

   THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES

/*

 Package: dyncall
 Library: dyncall
 File: dyncall/dyncall_macros.h
 Description: Platform detection macros
 License:

   Copyright (c) 2007-2015 Daniel Adler <dadler@uni-goettingen.de>,
                           Tassilo Philipp <tphilipp@potion-studios.com>

   Permission to use, copy, modify, and distribute this software for any
   purpose with or without fee is hereby granted, provided that the above
   copyright notice and this permission notice appear in all copies.

   THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES

#endif



/* Architecture. */

/* Check architecture. */
#if defined(_M_X64_) || defined(_M_AMD64) || defined(__amd64__) || defined(__amd64) || defined(__x86_64__) || defined(__x86_64)
# define DC__Arch_AMD64
#elif defined(_M_IX86) || defined(__i386__) || defined(__i486__) || defined(__i586__) || defined(__i686__) || defined(__386__) || defined(__i386)
# define DC__Arch_Intel_x86
#elif defined(_M_IA64) || defined(__ia64__)
# define DC__Arch_Itanium
#elif defined(_M_PPC) || defined(__powerpc__) || defined(__powerpc) || defined(__POWERPC__) || defined(__ppc__) || defined(__power__)
# if defined(__ppc64__) || defined(_ARCH_PPC64) || defined(__power64__) || defined(__powerpc64__)

# define DC__Arch_MIPS
#elif defined(__arm__)
# define DC__Arch_ARM
#elif defined(__aarch64__)
# define DC__Arch_ARM64
#elif defined(__sh__)
# define DC__Arch_SuperH
#elif defined(__sparcv9) || defined(__sparc64__) || ( defined(__sparc) && defined(__arch64__) )
/* this could be needed on Linux/GNU sparc64 in the future: || ( defined(__sparc) && defined(__arch64__) ) */
# define DC__Arch_Sparcv9
#elif defined(__sparc)
# define DC__Arch_Sparc
#endif

/*

 Package: dyncall
 Library: dyncall
 File: dyncall/dyncall_types.h
 Description: Typedefs
 License:

   Copyright (c) 2007-2015 Daniel Adler <dadler@uni-goettingen.de>,
                           Tassilo Philipp <tphilipp@potion-studios.com>

   Permission to use, copy, modify, and distribute this software for any
   purpose with or without fee is hereby granted, provided that the above
   copyright notice and this permission notice appear in all copies.

   THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES

/*

  dyncall argument- and return-types

  REVISION
  2007/12/11 initial

*/

#ifndef DYNCALL_TYPES_H
#define DYNCALL_TYPES_H

#include <stddef.h>

#include "dyncall_config.h"

#ifdef __cplusplus
extern "C" {
#endif

typedef void            DCvoid;
typedef DC_BOOL         DCbool;
typedef char            DCchar;
typedef unsigned char   DCuchar;
typedef short           DCshort;
typedef unsigned short  DCushort;

		SHLIB_CFLAGS=""
		SHLIB_SUFFIX=".dll"
		DL_OBJS=""
		DL_LIBS=""
		TCL_LIB_VERSIONS_OK=nodots
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.dll'
		UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a'
	    else
		LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
	    fi
	    AS_IF([test $doRpath = yes], [
		CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'])
	    LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
	    AS_IF([test "`uname -m`" = "alpha"], [CFLAGS="$CFLAGS -mieee"])
	    AS_IF([test $do64bit = yes], [

                                      errorbuf, ARRAYSIZE(errorbuf),
                                      provider, ARRAYSIZE(provider));

        /* First write the win32 error message */
        Twapi_AppendSystemError(interp, error);

        /* If we had a extended error and we got it successfully
         * (wneterror would be NO_ERROR) append the WNet message
         */
        if (wneterror == NO_ERROR) {
            Tcl_Obj *resultObj = ObjDuplicate(ObjGetResult(interp));
            Tcl_DString ds;
            Tcl_Obj *msgObj;

            Tcl_DStringInit(&ds);

            return GetLastError();
	allocFunc = MemLifoDefaultAlloc;
	freeFunc = MemLifoDefaultFree;
    } else {
        MEMLIFO_ASSERT(freeFunc);	/* If allocFunc was not 0, freeFunc
					   should not be either */
    }

    if (chunk_sz < 1000)
        chunk_sz = 1000;

    /* Allocate a chunk and allocate space for the lifo descriptor from it */
    c = allocFunc(chunk_sz, allocator_data, &actual_chunk_sz);
    if (c == 0) {
        if (flags & MEMLIFO_F_PANIC_ON_FAIL)

	    return 0;
        }

	c->lc_end = ADDPTR(c, chunk_sz, void*);

	c->lc_prev = m->lm_chunks;	/* Place on the list of chunks */
	m->lm_chunks = c;

	m->lm_last_alloc = ALIGNPTR(c, sizeof(*c), void*);
        m->lm_freeptr = ALIGNPTR(m->lm_last_alloc, sz, void*);
        /* Notice that when we have to allocate a new chunk, we do not
         * give more than caller asked (modulo some rounding)
         */
        if (actual_szP)
            *actual_szP = PTRDIFF32(m->lm_freeptr, m->lm_last_alloc);

	c = l->lifo_allocFn(l->lifo_chunk_size,
                            l->lifo_allocator_data,
                            &chunk_sz);
	if (c == 0) {
            if (l->lifo_flags & MEMLIFO_F_PANIC_ON_FAIL)
                Tcl_Panic("Attempt to allocate %lu bytes for memlifo", l->lifo_chunk_size);
	    return 0;
        }
	c->lc_end = ADDPTR(c, chunk_sz, void*);

	/*
	 * Place on the list of chunks. Note however, that we do NOT
	 * modify m->lm_chunkList since that should hold the original lifo
	 * state. We'll put this chunk on the list headed by the new mark.
	 */
	c->lc_prev = m->lm_chunks;	/* Place on the list of chunks */

	n = ALIGNPTR(c, sizeof(*c), MemLifoMark*);
	n->lm_chunks = c;

	n->lm_freeptr = ALIGNPTR(n, sizeof(*n), void*);
    }

#ifdef MEMLIFO_DEBUG
    n->lm_magic = MEMLIFO_MARK_MAGIC;
    n->lm_seq = m->lm_seq + 1;
#endif

	end = n->lm_big_blocks;
	while (c1 != end) {
	    MEMLIFO_ASSERT(c1);
	    c2 = c1->lc_prev;
	    l->lifo_freeFn(c1, l->lifo_allocator_data);
	    c1 = c2;
	}

	/* Free up chunks. Once chunks are freed up, do NOT access m since
	 * it might have been freed as well.
	 */
	c1 = m->lm_chunks;
	end = n->lm_chunks;
	while (c1 != end) {
	    MEMLIFO_ASSERT(c1);

        return TCL_OK;

syntax_error:
    ObjSetResult(interp, Tcl_ObjPrintf("Invalid time list '%s'", ObjToString(timeObj)));
    return TCL_ERROR;
}

TWAPI_EXTERN Tcl_Obj *ObjFromFILETIME(const FILETIME *ftimeP)
{
    LARGE_INTEGER large;
    large.LowPart = ftimeP->dwLowDateTime;
    large.HighPart = ftimeP->dwHighDateTime;
    return ObjFromLARGE_INTEGER(large);
}

    }

    /* Add the final terminating null */
    *dst++ = 0;

    *multiszPtrPtr = buf;
    if (nbytesP)
        *nbytesP = (int) (sizeof(*dst) * (dst - buf));
    return TCL_OK;
}

/* Like ObjToMultiSzEx but uses the SWS. Caller responsible for SWS storage */
TWAPI_EXTERN
TCL_RESULT ObjToMultiSzSWS (
     Tcl_Interp *interp,

/*
 * Copyright (c) 2004-2020, Ashok P. Nadkarni
 * All rights reserved.
 *
 * See the file LICENSE for license
 */


#include "twapi.h"
#include "twapi_wm.h"

#ifndef TWAPI_SINGLE_MODULE
static HMODULE gModuleHandle;     /* DLL handle to ourselves */
#endif

        break;
    case 13:
        if (TwapiGetArgs(interp, objc, objv, GETHWND(hwnd), ARGEND) != TCL_OK)
            return TCL_ERROR;
        result.value.ival = OpenClipboard(hwnd);
        result.type = TRT_EXCEPTION_ON_FALSE;
        break;
    case 14:
        result.value.uval = GetClipboardSequenceNumber();
        result.type = TRT_DWORD;
        break;
    }

    return TwapiSetResult(interp, &result);
}


static int TwapiClipboardInitCalls(Tcl_Interp *interp, TwapiInterpContext *ticP)
{
    static struct alias_dispatch_s ClipAliasDispatch[] = {
        DEFINE_ALIAS_CMD(Twapi_EnumClipboardFormats, 1),
        DEFINE_ALIAS_CMD(CloseClipboard, 2),
        DEFINE_ALIAS_CMD(EmptyClipboard, 3),
        DEFINE_ALIAS_CMD(GetOpenClipboardWindow, 4),
        DEFINE_ALIAS_CMD(get_open_clipboard_window, 4),
        DEFINE_ALIAS_CMD(GetClipboardOwner, 5),
        DEFINE_ALIAS_CMD(get_clipboard_owner, 5),
        DEFINE_ALIAS_CMD(Twapi_ClipboardMonitorStart, 6),
        DEFINE_ALIAS_CMD(Twapi_ClipboardMonitorStop, 7),
        DEFINE_ALIAS_CMD(IsClipboardFormatAvailable, 8),
        DEFINE_ALIAS_CMD(GetClipboardData, 9),
        DEFINE_ALIAS_CMD(GetClipboardFormatName, 10),
        DEFINE_ALIAS_CMD(SetClipboardData, 11),
        DEFINE_ALIAS_CMD(RegisterClipboardFormat, 12),
        DEFINE_ALIAS_CMD(OpenClipboard, 13),
        DEFINE_ALIAS_CMD(GetClipboardSequenceNumber, 14),
        DEFINE_ALIAS_CMD(get_clipboard_sequence, 14),
    };


    Tcl_CreateObjCommand(interp, "twapi::ClipCall", Twapi_ClipboardCallObjCmd, ticP, NULL);

    TwapiDefineAliasCmds(interp, ARRAYSIZE(ClipAliasDispatch), ClipAliasDispatch, "twapi::ClipCall");

# Tcl Windows API (TWAPI) 4.5.2

This is the release version of TWAPI 4.5.2.

  * Project home page is at https://twapi.sourceforge.net
  * V4.5 documentation is at https://twapi.magicsplat.com/v4.5

## Supported platforms

TWAPI 4.5 requires

  * Windows XP (32-bit only) or later (32- or 64- bit)
  * Tcl 8.6 (32- or 64-bit)

## Changes since 4.4



For a complete list, including INCOMPATIBLE CHANGES, see 
https://twapi.magicsplat.com/v4.5/versionhistory.html

## Distributions

TWAPI is distributed in multiple formats.
See https://twapi.magicsplat.com/v4.5/installation.html for the details
and the pros and cons of each format.

## TWAPI Summary

The Tcl Windows API (TWAPI) extension provides
access to over 600 functions in the Windows API
from within the Tcl scripting language.

[comment {-*- tcl -*- doctools manpage}]
[manpage_begin "Clipboard" n ""]
[copyright "2004-2009 Ashok P. Nadkarni"]
[moddesc "Clipboard access"]
[titledesc "Commands related to accessing the clipboard"]
[require twapi_clipboard]
[description]

[para]
This module provides procedures to read and write the clipboard as well





as to monitor changes. Tcl/Tk has a [cmd clipboard]
command that provides similar functionality. The [cmd TWAPI] commands
are useful in two circumstances:
[list_begin bullet]
[bullet]The Tcl [cmd clipboard] command is not available
in console-based Tcl programs that do not load [cmd Tk]. The [cmd TWAPI]
command may be used to access the clipboard in this case.
[bullet]More control is desired over the specific format of the data stored
into the clipboard.
[list_end]
In other cases, the Tcl/Tk [cmd clipboard] command should be preferred.

[section "Clipboard ownership"]

Access to the clipboard requires it to be first opened with
[uri #open_clipboard [cmd open_clipboard]] and closed afterwards with
[uri #close_clipboard [cmd close_clipboard]]. However, several commands will
do this on behalf of the caller if the clipboard was not already opened.

[para]
The [uri #get_clipboard_owner [cmd get_clipboard_owner]] and
[uri #get_open_clipboard_window [cmd get_open_clipboard_window]] return
information about the clipboard owner and the window
that has the clipboard open.

[section "Clipboard formats"]

Data may be stored in the clipboard in any number for formats
identified by integer values. When reading clipboard data, applications
must check in what formats the current clipboard data is currently
available and specify one of these formats when reading the

[uri \#read_clipboard_text [cmd read_clipboard_text]] or
[uri \#read_clipboard_paths [cmd read_clipboard_paths]].

[section "Monitoring clipboard changes"]
An application can monitor the clipboard by calling
[uri #start_clipboard_monitor [cmd start_clipboard_monitor]] to set up a notification
callback that is invoked when the contents of the clipboard change.
The clipboard also maintains a sequence number that is incremented on every
change. This sequence number can be retrieved with
[uri #get_clipboard_sequence [cmd get_clipboard_sequence]].


[section Commands]
[list_begin definitions]

[call [cmd clipboard_format_available] [arg FORMAT]]
Returns 1 if the clipboard contains data in the specified format, and
0 otherwise. This command does not require the clipboard to have been

The clipboard must have been
previously opened with [uri \#open_clipboard [cmd open_clipboard]].

[call [cmd get_clipboard_formats]]
Returns a list of the formats currently available in the clipboard. The
clipboard must have been opened before this function is called.

[call [cmd get_clipboard_owner]]
Returns the window handle of the window that owns the clipboard. This is
the window associated with the last call to [cmd EmptyClipboard] and is
generally the window that last wrote to the clipboard. The returned window
handle may be NULL if the clipboard is not currently owned.

[call [cmd get_clipboard_sequence]]
Returns the current clipboard sequence number. This number is incremented
every time the clipboard changes and can therefore be used by applications
that track the clipboard to figure out if the contents have changed.

[call [cmd get_open_clipboard_window]]
Returns the window handle of the window that has the clipboard open.
This may be NULL if no window has the clipboard open or if the current
[cmd OpenClipboard] call specified a NULL window handle.

[call [cmd get_registered_clipboard_format_name] [arg FORMAT]]
Returns the name associated with a registered clipboard format. [arg FORMAT]
identifies the format and must correspond to a registered format. An
exception will be raised if [arg FORMAT] is a standard Windows format or
a unregistered private format.

[call [cmd open_clipboard]]

<ul>
  <li>Follow the links on the left for the <a href="overview.html">documentation</a></li>
  <li>Go to the <a href="https://sourceforge.net/project/showfiles.php?group_id=90123">download page</a></li>
  <li>Visit the <a href="https://sourceforge.net/projects/twapi">SourceFourge</a> project</li>
  <li>Browse the <a href="https://sourceforge.net/p/twapi/code/">source repository</a></li>
  <li>Documentation for older versions:
    <!-- NOTE: Explicit HTTP links because older doc versions do not support https due to http links to yahoo yui css -->
    <a href="http://twapi.magicsplat.com/v4.4/index.html">4.4</a>
    <a href="http://twapi.magicsplat.com/v4.3/index.html">4.3</a>
    <a href="http://twapi.magicsplat.com/v4.2/index.html">4.2</a>
    <a href="http://twapi.magicsplat.com/v4.1/index.html">4.1</a>
    <a href="http://twapi.magicsplat.com/v4.0/index.html">4.0</a>
    <a href="http://twapi.magicsplat.com/v3.1/index.html">3.1</a>
    <a href="http://twapi.magicsplat.com/v3.0/index.html">3.0</a>
    <a href="http://twapi.magicsplat.com/v2.2/index.html">2.2</a>

[comment {-*- tcl -*- doctools manpage}]
[manpage_begin "Overview" n ""]
[copyright "2003-2020 Ashok P. Nadkarni"]
[moddesc "TWAPI Version 4.4 Overview"]
[titledesc "Tcl Windows API V4.5 overview"]
[description]
[para]

The Tcl Windows API (TWAPI) extension provides access to functions in the
Windows API from within the Tcl scripting language.

[para]

[para]
[uri \#process_exists [cmd process_exists]]
checks for the existence of a process. The command
[uri \#process_waiting_for_input [cmd process_waiting_for_input]]
can be used to check if a process is waiting
for input, and more specifically if it has finished initialization.

[para]
[uri \#get_process_memory_info [cmd get_process_memory_info]]
retrieves the memory statistics for a process.

[para]
[uri \#get_process_modules [cmd get_process_modules]]
retrieves information pertaining to the
modules and DLL's loaded into a process. The commands
[uri #get_module_handle [cmd get_module_handle]] and
[uri #get_module_handle_from_address [cmd get_module_handle_from_address]]
retrieve handles to individual modules in the current process.

If no options are specified, information for the current process is returned.
A different process may be specified using its PID with the [cmd -pid] option,
or with a handle to it through the [cmd -hprocess] option.
[nl]
See
[uri security.html#get_token_integrity [cmd get_token_integrity]] for
details on the other options, return value and semantics of this command.

[call [cmd get_process_memory_info] [opt [arg PID]]]

Returns a dictionary containing memory statistics for the process with
the specified PID. If no argument is provided, returns the statistics
for the current process. The returned dictionary has the following keys:

[list_begin opt]
[opt_def [cmd -pagefaults]]
Number of page faults for the process.
[opt_def [cmd -pagefilebytes]]
Returns total number of bytes in use for this process in all the
system paging files.
[opt_def [cmd -pagefilebytespeak]]
Returns the maximum number of bytes that have been used for this
process in the system paging file since the process started.
[opt_def [cmd -poolnonpagedbytes]]
Returns the number of bytes of nonpaged pool memory in use for the process.
[opt_def [cmd -poolnonpagedbytes]]
Returns the peak number of bytes of nonpaged pool memory in use for the process.
[opt_def [cmd -poolpagedbytes]]
Returns the number of bytes of paged pool memory in use for the process.
[opt_def [cmd -poolpagedbytespeak]]
Returns the peak number of bytes of paged pool memory in use for the process.
[opt_def [cmd -privateusage]]
Total amount of private memory that the memory manager has committed for
the process.
[opt_def [cmd -workingset]]
Returns the number of bytes currently in the process' working set.
[opt_def [cmd -workingsetpeak]]
Returns the maximum number of bytes in the process' working set since
it began execution.
[list_end]

[call [cmd get_process_modules] [arg PID] [opt [arg options]]]
This command returns information about the modules loaded in the
process with id [arg PID]. If no options are specified, the command
returns a list of handles to the modules.
[nl]
If any options are specified, the returned information is a

[uri \#set_file_times [cmd set_file_times]] and
allow retrieval and setting of the times associated with a file.

[para]
The command [uri #flush_channel [cmd flush_channel]] flushes
operating system buffers associated with a Tcl channel to disk.

[para]
The commands
[uri \#find_file_open [cmd file_file_open]],
[uri \#find_file_next [cmd file_file_next]] and
[uri \#find_file_close [cmd file_file_close]]
can be used to incrementally iterate through directory or file system contents
while retrieving file meta-information.

[section Commands]
[list_begin definitions]

[call [cmd begin_filesystem_monitor] [arg PATH] [arg SCRIPT] [opt [arg options]]]

Registers [arg SCRIPT] to be invoked when the specified types of changes
occur in the directory of subtree matching [arg PATH].

returned by [uri \#begin_filesystem_monitor [cmd begin_filesystem_monitor]].

[call [cmd drive_ready] [arg DRIVE]]
Returns 1 if the specified drive is ready and 0 otherwise
(for example if the drive media is not inserted). The drive must
exist else an error is raised.

[call [cmd find_file_close] [arg FFTOKEN]]
Closes a token previously returned by
[uri \#find_file_open [cmd find_file_open]].

[call [cmd find_file_next] [arg FFTOKEN] [arg VARNAME]]

Each call returns the next entry from file iteration corresponding to
[arg FFTOKEN] which must be a token returned by
[uri \#find_file_open [cmd find_file_open]].
If there are additional entries in the iteration, the command returns a
boolean true value and stores the entry in a variable [arg VARNAME] in the
caller's context. If no more entries remain the command returns a boolean
false.

The entry stored in [arg VARNAME] is in the form of a dictionary with
the following keys.

[list_begin opt]
[opt_def atime] Last access time as 100ns units since Jan 1, 1601.
[opt_def attrs] Bit mask of file attributes. This can be decoded with the
[uri \#map_file_attributes [cmd map_file_attributes]] command.
[opt_def ctime] Creation time as 100ns units since Jan 1, 1601.
[opt_def mtime] Last modification time as 100ns units since Jan 1, 1601.
[opt_def size] File size. This will always be 0 for directories.
[opt_def name] File name.
[opt_def altname] Alternate name (generally, the short name) of file, if any.
The [cmd -detail] option to the [uri \#find_file_open [cmd find_file_open]]
must be specified as [const full] for this to be retrieved. The element
will be present bu empty if the option was specified as [const basic] or
if there is no alternate name.
[list_end]

Any additional dictionary keys should be ignored.

[call [cmd find_file_open] [arg PATH] [opt "[cmd -detail] [const basic|full]"]]

Returns a token that can be used to iterate through files with the
[uri \#find_file_next [cmd find_file_next]] command. The iteration
will include all files that match [arg PATH] which may include wildcard
patterns in the filename component. The wildcards are as interpreted
by Windows and different from the patterns expected by the Tcl [cmd glob]
command.

The [cmd -detail] option may be specified as [const basic] (default) or
[const full]. See the [uri \#find_file_next [cmd find_file_next]]
command for the difference.

The returned token must be closed by calling
[uri \#find_file_close [cmd find_file_close]].

[call [cmd find_logical_drives] [opt "[cmd -type] [arg DRIVETYPELIST]"]]

Returns a list of the logical drives in the system. If option [cmd -type]
not specified, all drives in the system are returned. Otherwise, only drives
whose type is in [arg DRIVETYPELIST] are returned.
[arg DRIVETYPELIST] must be a subset of the
values returned by the [uri \#get_drive_type [cmd get_drive_type]] command.

may also be removed using the [cmd unmap_drive_local] command.
[nl]
The following options may be specified with the command:
[list_begin opt]
[opt_def [cmd -raw]] Specifies that [arg PATH] is a raw path specification that
includes the device name as opposed to a drive letter.
[list_end]

[call [cmd decode_file_attributes] [arg ATTRS]]
Decodes the bitmask [arg ATTRS] as returned in file entries by the
[uri \#find_file_next [cmd find_file_next]] command. The return value
is a list of elements from amongst
[const archive], [const compressed], [const device], [const directory],
[const encrypted], [const hidden], [const integrity], [const normal],
[const not], [const no], [const offline], [const readonly], [const recall],
[const recall], [const reparse], [const sparse], [const system],
[const temporary], [const virtual]. Any bits not recognized will be returned
as numeric values.

[call [cmd mount_volume] [arg MOUNTPOINTPATH] [arg VOLNAME]]
Mounts the volume specified by [arg VOLNAME] at the mount point specified
by [arg MOUNTPOINTPATH]. The directory [arg MOUNTPOINTPATH] must be empty.
[arg VOLNAME] must be of the form [const \\\\?\\VOLUME{[arg GUID]}\\].

If any volume is already mounted at [arg MOUNTPOINTPATH], it will be silently

[comment {-*- tcl -*- doctools manpage}]
[manpage_begin "SSL/TLS" n ""]
[copyright "2013-2020 Ashok P. Nadkarni"]
[moddesc "Transport Layer Security"]
[titledesc "Secure Sockets Layer and Transport Layer Security Channels"]
[require twapi_crypto]
[description]
[para]

[emph "This module is still experimental and liable to change."]

[para]
This package provides a Tcl channel facility that implements
the Secure Sockets Layer / Transport Layer Security
(collectively referred to as TLS) on top
of the Windows Security Service
Provider Interface (SSPI) interface.

[section "TLS channels"]

The [uri #tls_socket [cmd tls_socket]] command creates a new TCP/IP based
client connection or a listening server socket.

The [uri #starttls [cmd starttls]] command wraps an existing Tcl
bidirectional channel into a TLS channel.

The [uri #tls_handshake [cmd tls_handshake]] command completes
negotiation on a TLS channel. The current channel state can be retrieved
with [uri #tls_state [cmd tls_state]].

Channels are closed using either the [uri #tls_close [cmd tls_close]] command or

the Tcl [cmd close] command. The former permits half-closing of the output side
of the channel which the latter does not allow for reflected channels.

[section "Error handling"]

Errors that occur in the background are reported by [cmd twapi_tls] by
calling the internal command [uri #tls_background_error [cmd tls_background_error]].
This command may be overridden by applications.

[section Commands]

[list_begin definitions]
[call [cmd starttls] [arg CHAN] [opt [cmd -server]] [opt [arg options]]]
Returns a new TLS channel that wraps an existing channel [arg CHAN].
[arg CHAN] must be in an open state.
Caller should use the returned channel and must not access [arg CHAN]
directly after the command returns, [emph "even on errors"].
By default, the returned
channel is for the client end of the connection.
If the option [cmd -server] is specified the channel corresponds
to the server end. This impacts how authentication and certificate
validation is handled.
[nl]
The newly returned channel has the same settings for
[cmd -buffering], [cmd -buffersize], [cmd -encoding], [cmd -eofchar]
and [cmd -translation] as the wrapped channel [arg CHAN]. The
setting for [cmd -blocking] is also preserved.
[emph {
    However, any read or write handlers are not copied to the
    new channel.
}] The caller must recreate them with [cmd {chan configure}].
[nl]
The command supports the following options:
[list_begin opt]
[opt_def [cmd -credentials] [arg CREDENTIALS]]
Specifies the credentials to be used for the connection.
See [uri #tls_socket [cmd tls_socket]] for details.
[opt_def [cmd -peersubject] [arg PEERNAME]]
Specifies the subject name to be verified on the remote certificate.
Must be specified for client side connections and
must not be specified for server-side connections.
[opt_def [cmd -verifier] [arg VERIFYCOMMAND]]
Specifies a callback to invoke to verify remote credentials.
See [uri #tls_socket [cmd tls_socket]] for details.
[list_end]

[call [cmd tls_background_error] [arg MESSAGE] [arg OPTIONDICT]]

This command is internally called by [cmd twapi_tls] to report errors in event
handler during negotiation etc. The default implementation simply raises an
exception which causes the event loop to report the error via the [cmd bgerror]
mechanism. An application may override this if it so chooses, for example to log
or change the message etc.. However, the application defined command must also
raise an exception but has the option of doing so with a different message,
error code and options dictionary. If the application defined command returns
normally, [cmd twapi_tls] will itself raise the original exception.

[nl]
The command is passed the original error message as [arg MESSAGE] and the
error options dictionary as [arg OPTIONDICT].

[call [cmd tls_close] [arg CHAN] [opt [arg DIRECTION]]]
Closes the specified TLS channel. This command is similar to the
standard Tcl [cmd close] command except that the latter does not permit
half-closing of TLS channels as they are implemented using Tcl's
reflected channel framework.

Only used for client-side connections to verify the name in the
certificate returned by the remote server. If unspecified, defaults
to [arg REMOTEADDR]. This option is silently ignored for server-side
connections.
[opt_def [cmd -requestclientcert]]
Indicates that the client should be asked to send its certificate.
Only applicable to server side sockets and is ignored if
[cmd -server] is not specified.
[emph {
    Note that this option only results in the client being requested
    for its certificate. Unlike server certificates, client certificates
    are not validated by default.
}]
Applications must themselves check that a certificate was received
and validate it, generally by specifying a verification callback
via the [cmd -verifier] option.
[opt_def [cmd -verifier] [arg VERIFYCOMMAND]]
Specifies a callback to invoke to verify remote credentials.
The [arg VERIFYCOMMAND] command prefix is invoked with two additional
parameters - the channel and a handle to the
[uri sspi.html "security context"] for the connection. If the command
returns a [const true] value, the connection is completed. For any other
values or errors, the connection is aborted. The callback can
retrieve the remote certificate from the passed
security context with the
[uri sspi.html#sspi_remote_cert [cmd sspi_remote_cert]] command
and use [uri crypto.html#cert_tls_verify [cmd cert_tls_verify]]
to validate it.
[nl]
For client-side
connections, if this option is specified and is not empty, automatic
verification of the server certificate is not done. For server-side

[comment {-*- tcl -*- doctools manpage}]
[manpage_begin "Version History" "n" ""]
[copyright "2003-2020 Ashok P. Nadkarni"]
[moddesc "TWAPI Version History"]
[titledesc "Tcl Windows API extension version history"]
[description]
[para]
Summarizes the list of changes for each version of TWAPI.

[section "Version 4.5.2"]
[list_begin bullet]
[bullet]
Added [uri storage.html#find_file_open [cmd find_file_open]] and related
commands.

[bullet]
Added [uri clipboard.html#get_clipboard_sequence [cmd get_clipboard_sequence]],
[uri clipboard.html#get_clipboard_owner [cmd get_clipboard_owner]],
[uri clipboard.html#get_open_clipboard_window [cmd get_open_clipboard_window]].

[bullet]
Added [uri process.html#get_process_memory_info [cmd get_process_memory_info]].

[bullet]
Added [uri tls.html#tls_background_error [cmd tls_background_error]].

[list_end]

[section "Version 4.4.0"]
[list_begin bullet]
[bullet]
Added [uri registry.html [cmd registry]] module.

[bullet]

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

/*
 * TBD - replace use of string object cache with TwapiGetAtom
 * TBD - replace CALL_ with DEFINE_ALIAS_CMD oR DEFINE_FNCODE_CMD
 * TBD - replace dict ops with list ops if possible
 * TBD - TraceMessage
 * TBD - Once XP is dropped, get rid of global gETWContext and use
 * the Context field in EVENT_TRACE_LOGFILE (OpenTrace) for this purpose.
 */
/* References:
   "Using TdhFormatProperty to Consume Event Data". More involved
   than just calling TdhGetPropertySize. Do we need to copy
   that code ?
   Also see https://github.com/microsoft/windows-container-tools/tree/master/LogMonitor
   and
   https://github.com/microsoft/onnxruntime/blob/master/onnxruntime/tool/etw/eparser.cc
   and
   https://fossies.org/linux/pcp/src/pmdas/etw/tdhconsume.c
   and
   https://github.com/microsoft/krabsetw
   for similar log file parsing.
*/

#include "twapi.h"
#include <evntrace.h>

#include <ntverp.h>             /* Needed for VER_PRODUCTBUILD SDK version */

#if (VER_PRODUCTBUILD < 7600) || (_WIN32_WINNT <= 0x600)

    TDH_CONTEXT_TYPE ParameterType;
    ULONG ParameterSize;
} TDH_CONTEXT;

typedef enum _DECODING_SOURCE {
  DecodingSourceXMLFile  = 0,
  DecodingSourceWbem     = 1,
  DecodingSourceWPP      = 2,
  DecodingSourceTlg      = 3
} DECODING_SOURCE;

typedef enum _TEMPLATE_FLAGS
{
    TEMPLATE_EVENT_DATA = 1,
    TEMPLATE_USER_DATA = 2
} TEMPLATE_FLAGS;

    Tcl_Obj *keyObj;
};

/* Event Trace Consumer Support */
struct TwapiETWContext {
    TwapiInterpContext *ticP;

    TRACEHANDLE traceH;








    /*
     * when non-NULL, an ObjIncrRefs must have been done on eventsObj
     * with a corresponding ObjDecrRefs when setting to NULL
     */
    Tcl_Obj *eventsObj;         /* Collects events within a single buffer */


    /*
     * If a callback is supplied, callback holds it.
     * If no callback is supplied, we collect the buffer descriptor
     * and events list in listObj and return it to caller.
     */
    union {
        struct {
            Tcl_Obj *cmdObj;    /* Callback command (list) */
            int      cmdlen;    /* Number of elements in cmdObj. */
            TCL_RESULT return_code; /* Return code from callback */
        } callback;
        Tcl_Obj     *listObj;   /* List of buffer descriptor, event list pairs */
    } u;
    int   callback_specified;   /* Tag for above union - 0 -> not callback, non-0 - callback */
    ULONG pointer_size;         /* Used if event itself does not specify */
    ULONG timer_resolution;
    ULONG user_mode;
    DWORD last_winerr;          /* Last Windows error seen */
    DWORD error_count;          /* Number of events dropped because of error */
    DWORD property_error_count; /* Number of properties ignored */
} gETWContext;                  /* IMPORTANT : Sync access via gETWCS */


CRITICAL_SECTION gETWCS; /* Access to gETWContext */

/* Used for testing old MOF based APIs on newer Windows OS'es */
static int gForceMofAPI = 0;

/*

  PEVENT_TRACE evP
)
{
    Tcl_Obj *objs[5];

    /* Called back from Win32 ProcessTrace call. Assumed that gETWContext is locked */




    if (evP->Header.Class.Type == EVENT_TRACE_TYPE_INFO &&
        IsEqualGUID(&evP->Header.Guid, &EventTraceGuid)) {
        /* If further events do not indicate pointer size, we will use this size*/
        gETWContext.pointer_size = ((TRACE_LOGFILE_HEADER *) evP->MofData)->PointerSize;
    }



    objs[0] = ObjFromEVENT_TRACE_HEADER(&evP->Header);
    objs[1] = ObjFromULONG(evP->InstanceId);
    objs[2] = ObjFromULONG(evP->ParentInstanceId);
    objs[3] = ObjFromGUID(&evP->ParentGuid);
    if (evP->MofData && evP->MofLength)
        objs[4] = ObjFromByteArray(evP->MofData, evP->MofLength);
    else

    objs[9] = ObjFromEVENT_DESCRIPTOR(&evhP->EventDescriptor);
    objs[10] = ObjFromGUID(&evhP->ProviderId);

    return ObjNewList(ARRAYSIZE(objs), objs);
}


static WIN32_ERROR TwapiTdhPropertyArraySize(TwapiInterpContext *ticP,
                                            EVENT_RECORD *evrP,
                                            TRACE_EVENT_INFO *teiP,
                                            USHORT prop_index, USHORT *countP)
{
    EVENT_PROPERTY_INFO *epiP;
    DWORD winerr;
    USHORT ref_index;
    union {
        USHORT ushort_val;
        ULONG ulong_val;
    } ref_value;
    ULONG ref_value_size;
    PROPERTY_DATA_DESCRIPTOR pdd;
    TDH_CONTEXT tdhctx;

    epiP = &teiP->EventPropertyInfoArray[prop_index];
    if ((epiP->Flags & PropertyParamCount) == 0) {
        *countP = epiP->count; /* Size of array is directly specified */
        return ERROR_SUCCESS;
    }

    tdhctx.ParameterValue = TwapiCalcPointerSize(evrP);
    tdhctx.ParameterType = TDH_CONTEXT_POINTERSIZE;
    tdhctx.ParameterSize = 0;   /* Reserved value */

    /* Size of array is indirectly specified through some other property */
    TWAPI_ASSERT(epiP->NameOffset != 0);

    ref_index = epiP->countPropertyIndex;
    pdd.PropertyName = (ULONGLONG)(teiP->EventPropertyInfoArray[ref_index].NameOffset + (char*) teiP);
    pdd.ArrayIndex = ULONG_MAX; /* Since index property is not an array */
    pdd.Reserved = 0;
    winerr = TdhGetPropertySize(evrP, 1, &tdhctx, 1, &pdd, &ref_value_size);
    if (winerr != ERROR_SUCCESS)
        return winerr;
    if (ref_value_size != 2 && ref_value_size != 4)
        return ERROR_INVALID_DATA; /* Indirect property index size is not 2 or 4. */
    winerr = TdhGetProperty(evrP, 1, &tdhctx, 1, &pdd, ref_value_size, (PBYTE)&ref_value);

    if (winerr != ERROR_SUCCESS)
        return winerr;

    if (ref_value_size == 2)
        *countP = ref_value.ushort_val;
    else {
        if (ref_value.ulong_val > teiP->PropertyCount)

            return ERROR_INVALID_DATA; /* Property index out of bounds. */

        *countP = (USHORT) ref_value.ulong_val;
    }

    return ERROR_SUCCESS;
}


static Tcl_Obj *TwapiMapTDHProperty(EVENT_MAP_INFO *emiP, ULONG val)
{
    ULONG i, bitmask;
    Tcl_Obj *objP;

    if (emiP->Flag == EVENTMAP_INFO_FLAG_MANIFEST_PATTERNMAP ||

    /* No map value for whatever reason, return as integer */
    return ObjFromDWORD(val);
}


/* Given the raw bytes for a TDH property, return the Tcl_Obj */
static WIN32_ERROR TwapiTdhPropertyValue(
    TwapiInterpContext *ticP,
    EVENT_RECORD *evrP,
    EVENT_PROPERTY_INFO *epiP,
    void *bytesP,               /* Raw bytes */
    ULONG prop_size,            /* Number of bytes */
    EVENT_MAP_INFO *emiP,       /* Value map, may be NULL */
    Tcl_Obj **valueObjP

    ULONG remain = prop_size;
    DWORD dw;
    Tcl_Interp *interp = ticP->interp;


#define EXTRACT(var_, type_) \
    do { \
        if (prop_size < sizeof(type_)) return ERROR_INVALID_DATA;        \
        var_ = *(type_ UNALIGNED *) bytesP; \
    } while (0)

    switch (epiP->nonStructType.InType) {
    case TDH_INTYPE_NULL:
        *valueObjP = ObjFromEmptyString(); /* TBD - use a NULL obj type*/
        return ERROR_SUCCESS;
    case TDH_INTYPE_UNICODESTRING:
        u.string.s = bytesP;
        u.string.len = -1;
        break;
    case TDH_INTYPE_ANSISTRING:
        u.string.s = bytesP;
        u.string.len = -1;

    case TDH_INTYPE_UINT64: EXTRACT(u.i64, unsigned __int64); break;
    case TDH_INTYPE_FLOAT:  EXTRACT(u.dbl, float); break;
    case TDH_INTYPE_DOUBLE: EXTRACT(u.dbl, double); break;

    case TDH_INTYPE_BOOLEAN:
        EXTRACT(u.i64, int);
        *valueObjP = ObjFromBoolean(u.i64 != 0);
        return ERROR_SUCCESS;

    case TDH_INTYPE_BINARY:
        u.bin = bytesP;
        break;
    case TDH_INTYPE_GUID:
        if (prop_size < sizeof(GUID))
            return ERROR_INVALID_DATA;
        *valueObjP = ObjFromGUID(bytesP);
        return ERROR_SUCCESS;
    case TDH_INTYPE_POINTER:
    case TDH_INTYPE_HEXINT32:
    case TDH_INTYPE_HEXINT64:
        if (prop_size == 4)
            *valueObjP = ObjFromULONGHex(*(unsigned int UNALIGNED *)bytesP);
        else if (prop_size == 8)
            *valueObjP = ObjFromULONGLONGHex(*(unsigned __int64 UNALIGNED *)bytesP);
        else
            return ERROR_INVALID_DATA;
        return ERROR_SUCCESS;

    case TDH_INTYPE_FILETIME:
        EXTRACT(ftime, FILETIME);
        if (! FileTimeToSystemTime(&ftime, &u.stime)) {
            /* Failed to convert to system time, return as file time */
            *valueObjP = ObjFromFILETIME(&ftime);
            return ERROR_SUCCESS;
        }
        break;

    case TDH_INTYPE_SYSTEMTIME:
        EXTRACT(u.stime, SYSTEMTIME);
        break;

    case TDH_INTYPE_SIZET:
        if (prop_size == 4)
            *valueObjP = ObjFromULONG(*(unsigned int UNALIGNED *)bytesP);
        else if (prop_size == 8)
            *valueObjP = ObjFromULONGLONG(*(unsigned __int64 UNALIGNED *)bytesP);
        else
            return ERROR_INVALID_DATA;
        return ERROR_SUCCESS;

    case TDH_INTYPE_HEXDUMP:
        EXTRACT(dw, DWORD);
        remain -= sizeof(DWORD);
        *valueObjP = ObjFromByteArray(sizeof(DWORD)+(BYTE*)bytesP,
                                      remain < dw ? remain : dw);
        return ERROR_SUCCESS;

    case TDH_INTYPE_WBEMSID:
        /* TOKEN_USER structure followed by SID. Sizeof TOKEN_USER
           depends on 32/64 bittedness of event stream. */
        if (evrP->EventHeader.Flags & EVENT_HEADER_FLAG_32_BIT_HEADER)
            dw = 4;
        else if (evrP->EventHeader.Flags & EVENT_HEADER_FLAG_64_BIT_HEADER)
            dw = 8;
        else
            dw = gETWContext.pointer_size;
        dw *= 2; /* sizeof(TOKEN_USER) == 16 on 64bit arch, 8 on 32bit */
        if (prop_size < (dw+sizeof(SID)))
            return ERROR_INVALID_DATA;
        bytesP = dw + (char*) bytesP;
        prop_size -= dw;
        /* FALLTHROUGH */

    case TDH_INTYPE_SID:
        if (TwapiValidateSID(NULL, bytesP, prop_size) != TCL_OK ||

            ObjFromSID(NULL, bytesP, valueObjP) != TCL_OK)
            return ERROR_INVALID_SID;
        return ERROR_SUCCESS;

    default:
        return ERROR_UNSUPPORTED_TYPE;

    }


    /* Now format based on output type */
    switch (epiP->nonStructType.InType) {
    case TDH_INTYPE_FILETIME:
    case TDH_INTYPE_SYSTEMTIME:

    case TDH_INTYPE_DOUBLE:
        *valueObjP = ObjFromDouble(u.dbl);
        break;

    case TDH_INTYPE_BINARY:
        if (epiP->nonStructType.OutType == TDH_OUTTYPE_IPV6) {
            if (remain != 16)
                return ERROR_INVALID_DATA;
            *valueObjP = ObjFromIPv6Addr(u.bin, 0);
            if (*valueObjP == NULL)
                return ERROR_INVALID_DATA;
        } else {
            *valueObjP = ObjFromByteArray(u.bin, remain);
        }
        break;

    default:
        return ERROR_NOT_SUPPORTED;
    }

    return ERROR_SUCCESS;

}

#ifdef NOTNEEDED
This function copied from GetPropertyLength in SDK Docs
not needed unless using  TdhFormatProperty ?
Moreover does not seem to return correct value for UNICODE strings
(null terminated)
    Moreover does TdhGetPropertySize not already to all this?
static WIN32_ERROR TwapiTdhPropertySize(
    EVENT_RECORD *evrP,
    TRACE_EVENT_INFO *teiP,
    USHORT prop_index,
    ULONG *sizeP)
{
    const EVENT_PROPERTY_INFO *epiP = &teiP->EventPropertyInfoArray[prop_index];
    WIN32_ERROR winerr;
    if (epiP->Flags & PropertyParamLength) {
        /*
         * The length of the property is given by the value of another property.
         */
        UINT32 len32 = 0;
        UINT16 len16 = 0;
        DWORD len_index = epiP->lengthPropertyIndex;
        PROPERTY_DATA_DESCRIPTOR pdd;
        ZeroMemory(&pdd, sizeof(pdd));
        /* TBD - need to check len_index validity? */
        pdd.PropertyName =
            (ULONGLONG) ((char*)(teiP) + teiP->EventPropertyInfoArray[len_index].NameOffset);
        pdd.ArrayIndex = ULONG_MAX;
        winerr = TdhGetPropertySize(evrP, 0, NULL, 1, &pdd, &len32);
        if (winerr == ERROR_SUCCESS) {
            if (len32 == 2) {
                winerr = TdhGetProperty(evrP, 0, NULL, 1, &pdd, len32, (PBYTE)&len16);
                if (winerr == ERROR_SUCCESS)
                    *sizeP = len16;
            } else if (len32 == 4) {
                winerr = TdhGetProperty(evrP, 0, NULL, 1, &pdd, len32, (PBYTE)&len32);
                if (winerr == ERROR_SUCCESS) {
                    *sizeP = len32;
                }
            } else {
                winerr = ERROR_EVT_INVALID_EVENT_DATA; /* Length should be 2/4 byte integer */
            }
        }
    }
    else {
        if (epiP->length > 0) {
            *sizeP = epiP->length;
            winerr = ERROR_SUCCESS;
        }
        else {
            /* Need to special case IPv6 addresses stored as binary */
            /* TBD - do we need to check if it is nonStructType first ? */
            if (epiP->nonStructType.InType == TDH_INTYPE_BINARY &&
                epiP->nonStructType.OutType == TDH_OUTTYPE_IPV6) {
                *sizeP = sizeof(IN6_ADDR);
                winerr = ERROR_SUCCESS;
            }
            else if ((epiP->Flags & PropertyStruct) == PropertyStruct ||
                     epiP->nonStructType.InType == TDH_INTYPE_UNICODESTRING ||
                     epiP->nonStructType.InType == TDH_INTYPE_ANSISTRING) {
                /* TBD - this case already covered above unless length is 0? */
                /* In otherwords, here epiP->length will always be 0? */
                *sizeP = epiP->length;
                winerr = ERROR_SUCCESS;
            }
            else {
                winerr = ERROR_EVT_INVALID_EVENT_DATA;
            }
        }
    }
    return winerr;
}
#endif

/* Uses ticP->memlifo, caller responsible for memory management always */
static WIN32_ERROR TwapiDecodeEVENT_PROPERTY_INFO(
    TwapiInterpContext *ticP,
    EVENT_RECORD *evrP,
    TRACE_EVENT_INFO *teiP,
    USHORT prop_index,
    LPWSTR struct_name,         /* If non-NULL, property is actually member
                                   of a struct of this name */
    USHORT struct_index,        /* Index of owning struct property when
                                   prop_index is a struct member
                                 */
    Tcl_Obj **propnameObjP,
    Tcl_Obj **propvalObjP
    )
{
    EVENT_PROPERTY_INFO *epiP;
    Tcl_Obj **valueObjs;
    USHORT nvalues, array_index;

    WIN32_ERROR winerr;
    Tcl_Interp *interp = ticP->interp;
    MemLifo *memlifoP = ticP->memlifoP;
    void *pv;
    TDH_CONTEXT tdhctx;
    PROPERTY_DATA_DESCRIPTOR pdd[2];
    int pdd_count;
    ULONG prop_size;
    ULONGLONG prop_name;

    epiP = &teiP->EventPropertyInfoArray[prop_index];

    if (epiP->NameOffset == 0) {
        /* Should not happen. */
        return ERROR_INVALID_DATA;
    }

    tdhctx.ParameterValue = TwapiCalcPointerSize(evrP);
    tdhctx.ParameterType = TDH_CONTEXT_POINTERSIZE;
    tdhctx.ParameterSize = 0;   /* Reserved value */

    nvalues = 0;
    winerr = TwapiTdhPropertyArraySize(ticP, evrP, teiP, prop_index, &nvalues);
    if (winerr != ERROR_SUCCESS)
        return winerr;

    prop_name = (ULONGLONG)(epiP->NameOffset + (char*) teiP);

    /* Special case arrays of UNICHAR and ANSICHAR. These are actually strings*/
    if ((epiP->Flags & PropertyStruct) == 0 &&
        epiP->nonStructType.OutType == TDH_OUTTYPE_STRING &&
        (epiP->nonStructType.InType == TDH_INTYPE_UNICODECHAR ||
         epiP->nonStructType.InType == TDH_INTYPE_ANSICHAR)) {
        pdd[0].PropertyName = prop_name;
        pdd[0].ArrayIndex = ULONG_MAX; /* We want size of whole array */
        pdd[0].Reserved = 0;
        winerr = TdhGetPropertySize(evrP, 1, &tdhctx, 1, pdd, &prop_size);
        if (winerr == ERROR_SUCCESS) {
            /* Do we need to check for presence of map info here ? */
            pv = MemLifoPushFrame(memlifoP, prop_size, NULL);
            winerr = TdhGetProperty(evrP, 1, &tdhctx, 1, pdd, prop_size, pv);
            if (winerr == ERROR_SUCCESS) {
                *propvalObjP  = ObjNewList(1, NULL);
                *propnameObjP = ObjFromWinChars((WCHAR *)(prop_name));
                if (epiP->nonStructType.InType == TDH_INTYPE_UNICODECHAR)
                    ObjAppendElement(NULL, *propvalObjP,
                                     ObjFromWinCharsLimited(pv, prop_size/sizeof(WCHAR), NULL));
                else
                    ObjAppendElement(NULL, *propvalObjP,
                                     ObjFromStringLimited(pv, prop_size, NULL));
            }
            MemLifoPopFrame(memlifoP);
        }
        return winerr;
    }

    valueObjs = nvalues ?
        MemLifoAlloc(memlifoP, nvalues * sizeof(*valueObjs), NULL)
        : NULL;

    for (array_index = 0; array_index < nvalues; ++array_index) {
        Tcl_Obj *valueObj = NULL;
        if (epiP->Flags & PropertyStruct) {
            /* Property is a struct */
            USHORT member_index     = epiP->structType.StructStartIndex;
            ULONG member_index_bound = member_index + epiP->structType.NumOfStructMembers;
            valueObj = ObjNewList(2 * epiP->structType.NumOfStructMembers, NULL);
            if (member_index_bound > teiP->TopLevelPropertyCount) {

                winerr = ERROR_INVALID_DATA; /* Property index is out of bounds */

            } else {
                while (member_index < member_index_bound) {
                    Tcl_Obj *membernameObj, *membervalObj;
                    winerr = TwapiDecodeEVENT_PROPERTY_INFO(ticP, evrP, teiP, member_index, (LPWSTR)(epiP->NameOffset + (char *) teiP), array_index, &membernameObj, &membervalObj);
                    if (winerr != ERROR_SUCCESS)
                        break;
                    ObjAppendElement(NULL, valueObj, membernameObj);
                    ObjAppendElement(NULL, valueObj, membervalObj);
                    ++member_index;
                }
            }
        } else {

                pdd[0].PropertyName = prop_name;
                pdd[0].ArrayIndex = array_index;
                pdd[0].Reserved = 0;

                /* TBD - sample in MSDN docs (not sdk sample) says tdh
                   cannot handle IPv6 data and skips event. Check on this */
            }
            /* TBD https://fossies.org/linux/pcp/src/pmdas/etw/tdhconsume.c claims
               TdhGetPropertySize fails on Windows2008 and instead loops doing
               TdhGetProperty instead increasin buffer size on ERROR_INSUFFICIENT_BUFFER.
               So we only call it to get an initial estimate and then loop
               increasing buffer size if buffer size is not enough.
             */
            winerr = TdhGetPropertySize(evrP, 1, &tdhctx, pdd_count, pdd, &prop_size);
            if (winerr == ERROR_SUCCESS) {
                ULONG map_size;
                EVENT_MAP_INFO *mapP = NULL;

                /* Since we might be looping, alloc and release memory in
                   every iteration.
                   Not necessary for correctness since caller will pop memlifo
                   frame anyway so in error case, we don't bother to pop
                   the frame */
                pv = MemLifoPushFrame(memlifoP, prop_size, NULL);
                if (epiP->nonStructType.MapNameOffset == 0)
                    mapP = NULL;
                else {
                    map_size = 0;
                    winerr = TdhGetEventMapInformation(evrP, (LPWSTR) (epiP->nonStructType.MapNameOffset + (char *)teiP), NULL, &map_size);
                    if (winerr == ERROR_INSUFFICIENT_BUFFER) {
                        mapP = MemLifoAlloc(memlifoP, map_size, NULL);
                        winerr = TdhGetEventMapInformation(evrP, (LPWSTR) (epiP->nonStructType.MapNameOffset + (char *)teiP), mapP, &map_size);

                    }
                }
                if (winerr == ERROR_SUCCESS) {
                    winerr = TdhGetProperty(evrP, 1, &tdhctx, pdd_count, pdd, prop_size, pv);
                    if (winerr == ERROR_SUCCESS)
                        winerr = TwapiTdhPropertyValue(ticP, evrP, epiP, pv, prop_size, mapP, &valueObj);
                }
                MemLifoPopFrame(memlifoP);
            }


        }

        if (winerr != ERROR_SUCCESS) {
            if (valueObj)
                ObjDecrRefs(valueObj);
            ObjDecrArrayRefs(array_index, valueObjs);
            return winerr;
        }
        valueObjs[array_index] = valueObj;
    }

    *propvalObjP  = ObjNewList(nvalues, valueObjs);
    *propnameObjP = ObjFromWinChars((WCHAR *)(epiP->NameOffset + (char*)teiP));
    return ERROR_SUCCESS;
}


/* Uses memlifo frame. Caller responsible for cleanup */
static WIN32_ERROR TwapiTdhGetEventInformation(TwapiInterpContext *ticP, EVENT_RECORD *evrP, Tcl_Obj **teiObjP)
{
    DWORD sz, winerr;
    Tcl_Obj *objs[15];
    TCL_RESULT status;
    TRACE_EVENT_INFO *teiP;
    EVENT_DESCRIPTOR *edP;
    TDH_CONTEXT tdhctx;
    int i, classic;
    Tcl_Obj *emptyObj;

    if (winerr != ERROR_SUCCESS) {
        /* Dummy up data */
        for (i = 0; i < ARRAYSIZE(objs); ++i)
            objs[i] = emptyObj;
        switch (evrP->EventHeader.EventProperty) {
        case EVENT_HEADER_PROPERTY_XML: i = DecodingSourceXMLFile; break;
        case EVENT_HEADER_PROPERTY_LEGACY_EVENTLOG: i = DecodingSourceWbem; break;
        case EVENT_HEADER_PROPERTY_FORWARDED_XML: /*  FALLTHRU */
        default : i = -1; break;
        }
        objs[1] = ObjFromLong(i); /* Decoding source */
        objs[12] = ObjNewList(2, NULL);
        ObjAppendElement(NULL, objs[12], STRING_LITERAL_OBJ("_userdata"));
        ObjAppendElement(NULL, objs[12], ObjFromByteArray(evrP->UserData, evrP->UserDataLength));
        *teiObjP = ObjNewList(ARRAYSIZE(objs), objs);
        ObjDecrRefs(emptyObj);
        return ERROR_SUCCESS;
    }

    edP = &teiP->EventDescriptor;

    classic = (teiP->DecodingSource == DecodingSourceWbem);








#define OFFSET_TO_OBJ(field_) (teiP->field_ ? ObjFromWinCharsNoTrailingSpace((LPWSTR)(teiP->field_ + (char*)teiP)) : emptyObj)

    /* Provider GUID and EventDescriptor are already returned as part
       of EVENT_HEADER. We prefer to do it there so that we can return
       partial info even when the TdhGetEventInformation call fails
       due to the MOF not having been registered
       objs[] = ObjFromGUID(&teiP->ProviderGuid);
       objs[] = ObjFromEVENT_DESCRIPTOR(&teiP->EventDescriptor);
    */

    objs[0] = ObjFromGUID(&teiP->ProviderGuid);
    objs[1] = ObjFromGUID(&teiP->EventGuid); /* TBD - why not just NULL GUID */

    objs[2] = ObjFromLong(teiP->DecodingSource);
    objs[3] = OFFSET_TO_OBJ(ProviderNameOffset);
    objs[4] = TwapiTEIWinCharsObj(teiP, teiP->LevelNameOffset, edP->Level);
    objs[5] = TwapiTEIWinCharsObj(teiP, teiP->ChannelNameOffset, edP->Channel);
    if (teiP->KeywordsNameOffset)
        objs[6] = ObjFromMultiSz((LPWSTR) (teiP->KeywordsNameOffset + (char*)teiP), -1);
    else
        objs[6] = emptyObj;
    objs[7] = TwapiTEIWinCharsObj(teiP, teiP->TaskNameOffset, edP->Task);
    objs[8] = TwapiTEIWinCharsObj(teiP, teiP->OpcodeNameOffset, edP->Opcode);
    objs[9] = OFFSET_TO_OBJ(EventMessageOffset);
    objs[10] = OFFSET_TO_OBJ(ProviderMessageOffset);
    if (classic) {
        objs[11] = OFFSET_TO_OBJ(ActivityIDNameOffset);
        objs[12] = OFFSET_TO_OBJ(RelatedActivityIDNameOffset);
    } else {
        /*  TBD - check in debugger what this field contains. They are aliased
         as EventNameOffset and EventAttributesOffset */
        objs[11] = emptyObj;
        objs[12] = emptyObj;
    }

    objs[13] = ObjNewList(2 * teiP->TopLevelPropertyCount, NULL);
    if (evrP->EventHeader.Flags & EVENT_HEADER_FLAG_STRING_ONLY) {
        ObjAppendElement(NULL, objs[13], STRING_LITERAL_OBJ("_stringdata"));
        ObjAppendElement(NULL, objs[13],
                         ObjFromWinCharsLimited(evrP->UserData,
                                               evrP->UserDataLength/sizeof(WCHAR), NULL));
    } else {
        USHORT i;

        for (i = 0; i < teiP->TopLevelPropertyCount; ++i) {
            Tcl_Obj *propnameObj, *propvalObj;
            winerr = TwapiDecodeEVENT_PROPERTY_INFO(ticP, evrP, teiP, i, NULL, 0, &propnameObj, &propvalObj);
            if (winerr != ERROR_SUCCESS) {
#if 1
                /*  Ignore property errors */
                gETWContext.property_error_count += 1;
                gETWContext.last_winerr = winerr;
                winerr = ERROR_SUCCESS;
#else
                // Ignore property errors
                /* Cannot use ObjDecrArrayRefs here to free objs[] because
                   it contains multiple occurences of emptyObj. Explicitly
                   build a list and free it */
                ObjDecrRefs(ObjNewList(ARRAYSIZE(objs), objs));
                if (emptyObj)
                    ObjDecrRefs(emptyObj); /* For the additional IncrRefs above */
                return winerr;
#endif
            } else {
                ObjAppendElement(NULL, objs[13], propnameObj);
                ObjAppendElement(NULL, objs[13], propvalObj);
            }
        }
    }
    objs[14] = ObjFromDWORD(teiP->Flags);

    *teiObjP = ObjNewList(ARRAYSIZE(objs), objs);
    ObjDecrRefs(emptyObj);

    return ERROR_SUCCESS;
}

static VOID WINAPI TwapiETWEventRecordCallback(PEVENT_RECORD evrP)
{
    int i;
    Tcl_Obj *recObjs[4];
    Tcl_Obj *objs[3];
    MemLifoMarkHandle mark;
    TwapiInterpContext *ticP;
    WIN32_ERROR winerr;

    /* Called back from Win32 ProcessTrace call. Assumed that gETWContext is locked */
    TWAPI_ASSERT(gETWContext.ticP != NULL);
    TWAPI_ASSERT(gETWContext.ticP->interp != NULL);

    if ((evrP->EventHeader.Flags & EVENT_HEADER_FLAG_TRACE_MESSAGE) != 0) {
        gETWContext.last_winerr  = ERROR_NOT_SUPPORTED;
        gETWContext.error_count += 1;

        /* - Handle simple WPP case */
        /*     if (EVENT_HEADER_FLAG_STRING_ONLY == */
        /*         666     (pEvent->EventHeader.Flags & EVENT_HEADER_FLAG_STRING_ONLY)) { */
        /*         667     printf("Embedded: %s\n", (char *)pEvent->UserData); */
        /*         668     }  */
        return; // Ignore WPP events. - TBD
    }

    if (evrP->EventHeader.EventDescriptor.Opcode == EVENT_TRACE_TYPE_INFO &&
        IsEqualGUID(&evrP->EventHeader.ProviderId, &EventTraceGuid)) {
        /*
         * This event is generated per log file. If an individual event do not
         * indicate pointer size, we will use this size.
         */

        case EVENT_HEADER_EXT_TYPE_STACK_TRACE32:
        case EVENT_HEADER_EXT_TYPE_STACK_TRACE64:
        default:
            break;              /* Skip/ignore */
        }
    }

    winerr = TwapiTdhGetEventInformation(ticP, evrP, &recObjs[3]);
    if (winerr == ERROR_SUCCESS)
        ObjAppendElement(ticP->interp, gETWContext.eventsObj, ObjNewList(ARRAYSIZE(recObjs), recObjs));
    else {
        ObjDecrArrayRefs(3, recObjs);
        gETWContext.last_winerr = winerr;
        gETWContext.error_count += 1;
    }

    MemLifoPopMark(mark);
    return;
}


ULONG WINAPI TwapiETWBufferCallback(

    TWAPI_ASSERT(gETWContext.ticP != NULL);
    TWAPI_ASSERT(gETWContext.ticP->interp != NULL);
    interp = gETWContext.ticP->interp;

    if (Tcl_InterpDeleted(interp))
        return FALSE;




    TWAPI_ASSERT(gETWContext.eventsObj);

    if (! gETWContext.callback_specified) {
        /* We are simply collecting events without invoking callback */
        TWAPI_ASSERT(gETWContext.u.listObj != NULL);
    } else {
        /*
         * Construct a command to call with the event.
         * gETWContext.buffer_cmdObj could be a shared object, either
         * initially itself or result in a shared object in the callback.
         * So we need to check for that and Dup it if necessary
         */

        if (Tcl_IsShared(gETWContext.u.callback.cmdObj)) {
            evalObj = ObjDuplicate(gETWContext.u.callback.cmdObj);
            ObjIncrRefs(evalObj);
        } else
            evalObj = gETWContext.u.callback.cmdObj;
    }

    objs[0] = etlP->LogFileName ? ObjFromWinChars(etlP->LogFileName) : ObjFromEmptyString();
    objs[1] = etlP->LoggerName ? ObjFromWinChars(etlP->LoggerName) : ObjFromEmptyString();
    objs[2] = ObjFromULONGLONG(etlP->CurrentTime);
    objs[3] = ObjFromLong(etlP->BuffersRead);
    //  ObjFromLong(etlP->LogFileMode) - docs say do not use
    objs[4] = ObjFromTRACE_LOGFILE_HEADER(&etlP->LogfileHeader);
    objs[5] = ObjFromLong(etlP->BufferSize);
    objs[6] = ObjFromLong(etlP->Filled);
    // Docs say unused -  ObjFromLong(etlP->EventsLost));
    objs[7] = ObjFromLong(etlP->IsKernelTrace);

    bufObj = ObjNewList(ARRAYSIZE(objs), objs);
    ObjIncrRefs(bufObj);

    if (gETWContext.callback_specified) {
        args[0] = bufObj;
        args[1] = gETWContext.eventsObj;
        Tcl_ListObjReplace(interp, evalObj, gETWContext.u.callback.cmdlen, ARRAYSIZE(args), ARRAYSIZE(args), args);
        code = Tcl_EvalObjEx(gETWContext.ticP->interp, evalObj, TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);

        /* Get rid of the command obj if we created it */
        if (evalObj != gETWContext.u.callback.cmdObj)
            ObjDecrRefs(evalObj);
    } else {
        /* No callback. Just collect */
        ObjAppendElement(NULL, gETWContext.u.listObj, bufObj);
        ObjAppendElement(NULL, gETWContext.u.listObj, gETWContext.eventsObj);
        code = TCL_OK;
    }


    ObjDecrRefs(bufObj); /* Matches Incr above */
    ObjDecrRefs(gETWContext.eventsObj); /* Matches Incr on creation */
    gETWContext.eventsObj = ObjNewList(0, NULL);/* For next set of events */
    ObjIncrRefs(gETWContext.eventsObj);

    switch (code) {
    case TCL_BREAK:
        /* Any other value - not an error, but stop processing */
        return FALSE;
    case TCL_OK:
        return TRUE;
    case TCL_ERROR:
    default:
        /* Should only happen for callback case */
        TWAPI_ASSERT(gETWContext.callback_specified);
        gETWContext.u.callback.return_code = TCL_ERROR;
        ObjDecrRefs(gETWContext.eventsObj);
        gETWContext.eventsObj = NULL;
        return FALSE;



    }
}

TCL_RESULT Twapi_TdhEnumerateProvidersObjCmd(ClientData clientdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
{
    TwapiInterpContext *ticP = clientdata;
    MemLifo *memlifoP = ticP->memlifoP;

TCL_RESULT Twapi_ProcessTrace(ClientData clientdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
{
    TwapiInterpContext *ticP = (TwapiInterpContext*) clientdata;
    int i;
    FILETIME start, end, *startP, *endP;
    struct TwapiETWContext etwc;
    int callback_cmdlen;
    DWORD winerr;
    Tcl_Obj **htraceObjs;
    TRACEHANDLE htraces[8];
    int       ntraces;

    if (objc != 5)
        return TwapiReturnError(interp, TWAPI_BAD_ARG_COUNT);

    if (ObjGetElements(interp, objv[1], &ntraces, &htraceObjs) != TCL_OK)
        return TCL_ERROR;

    for (i = 0; i < ntraces; ++i) {
        if (ObjToTRACEHANDLE(interp, htraceObjs[i], &htraces[i]) != TCL_OK)
            return TCL_ERROR;
    }

    /* Verify callback command prefix is a list. If empty, data
     * is returned instead.
     */
    if (ObjListLength(interp, objv[2], &callback_cmdlen) != TCL_OK)
        return TCL_ERROR;

    if (Tcl_GetCharLength(objv[3]) == 0)
        startP = NULL;
    else if (ObjToFILETIME(interp, objv[3], &start) != TCL_OK)
            return TCL_ERROR;
    else

    if (gETWContext.ticP != NULL) {
        LeaveCriticalSection(&gETWCS);
        ObjSetStaticResult(interp, "Recursive call to ProcessTrace");
        return TCL_ERROR;
    }

    gETWContext.traceH = htraces[0];

    if (callback_cmdlen) {
        gETWContext.callback_specified     = 1;
        gETWContext.u.callback.cmdlen      = callback_cmdlen;
        gETWContext.u.callback.cmdObj = ObjDuplicate(objv[2]);
        ObjIncrRefs(gETWContext.u.callback.cmdObj);
        gETWContext.u.callback.return_code = 0;
    }
    else {
        gETWContext.callback_specified = 0;
        gETWContext.u.listObj = ObjNewList(0, NULL);
        ObjIncrRefs(gETWContext.u.listObj);
    }
    gETWContext.eventsObj = ObjNewList(0, NULL);
    ObjIncrRefs(gETWContext.eventsObj);

    gETWContext.ticP = ticP;
    gETWContext.pointer_size = sizeof(void*); /* Default unless otherwise indicated */
    gETWContext.error_count = 0;
    gETWContext.property_error_count = 0;
    gETWContext.last_winerr = ERROR_SUCCESS;

    winerr = ProcessTrace(htraces, ntraces, startP, endP);

    /* Copy and reset context before unlocking */
    etwc = gETWContext;
    if (gETWContext.callback_specified)
        gETWContext.u.callback.cmdObj = NULL;
    else
        gETWContext.u.listObj = NULL;

    gETWContext.eventsObj = NULL;

    gETWContext.ticP = NULL;
    /* NOTE: gETWContext.last_winerr should be preserved till next call */

    LeaveCriticalSection(&gETWCS);

    if (etwc.eventsObj)
        ObjDecrRefs(etwc.eventsObj);

    if (etwc.callback_specified) {

        ObjDecrRefs(etwc.u.callback.cmdObj);



        /*
         * A winerr of ERROR_CANCELLED means the callback returned TCL_BREAK
         * to terminate the processing. That is not treated as an error
         */
        if (winerr && winerr != ERROR_CANCELLED)
            return Twapi_AppendSystemError(interp, winerr);
        if (etwc.u.callback.return_code == TCL_ERROR) {

            /* Interp should already contain error message */
            return TCL_ERROR;

        } else {
            /* Erase any left over result from callback */
            Tcl_ResetResult(interp);
            return TCL_OK;
        }
    } else {
        /* Not a call back */
        if (winerr) {
            ObjDecrRefs(etwc.u.listObj);
            return Twapi_AppendSystemError(interp, winerr);
        }
        ObjSetResult(interp, etwc.u.listObj);
        ObjDecrRefs(etwc.u.listObj); /* NOTE: do AFTER setting result */
        return TCL_OK;
    }
}

TCL_RESULT Twapi_ParseEventMofData(ClientData clientdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
{
    int       i, eaten, remain;
    Tcl_Obj **types;            /* Field types */
    int       ntypes;           /* Number of fields/types */

    case 4:
        CHECK_NARGS_RANGE(interp, objc, 1, 2);
        if (objc == 2) {
            CHECK_INTEGER_OBJ(interp, gForceMofAPI, objv[1]);
        }
        objP = ObjFromLong(gForceMofAPI);
        break;
    case 5:
        CHECK_NARGS(interp, objc, 1);
        objP = ObjNewList(8, NULL);
        ObjAppendElement(interp, objP, STRING_LITERAL_OBJ("error_count"));
        ObjAppendElement(interp, objP, ObjFromWideInt(gETWContext.error_count));
        ObjAppendElement(interp, objP, STRING_LITERAL_OBJ("property_error_count"));
        ObjAppendElement(interp, objP, ObjFromWideInt(gETWContext.property_error_count));
        ObjAppendElement(interp, objP, STRING_LITERAL_OBJ("last_winerr"));
        ObjAppendElement(interp, objP, ObjFromWideInt(gETWContext.last_winerr));
        ObjAppendElement(interp, objP, STRING_LITERAL_OBJ("last_winerr_text"));
        ObjAppendElement(interp, objP, Twapi_MapWindowsErrorToString(gETWContext.last_winerr));
        break;
    default:
        return TwapiReturnError(interp, TWAPI_INVALID_FUNCTION_CODE);
    }

    if (objP)
        ObjSetResult(interp, objP);
    return TCL_OK;

    };

    struct fncode_dispatch_s EtwCallDispatch[] = {
        DEFINE_FNCODE_CMD(etw_provider_enable_flags, 1),     /* TBD docs */
        DEFINE_FNCODE_CMD(etw_provider_enable_level, 2),     /* TBD docs */
        DEFINE_FNCODE_CMD(etw_provider_enabled, 3),          /* TBD docs */
        DEFINE_FNCODE_CMD(etw_force_mof, 4),
        DEFINE_FNCODE_CMD(etw_errors, 5), /* TBD docs and test */
    };

    TwapiDefineTclCmds(interp, ARRAYSIZE(EtwDispatch), EtwDispatch, ticP);
    TwapiDefineFncodeCmds(interp, ARRAYSIZE(EtwCallDispatch), EtwCallDispatch, Twapi_ETWCallObjCmd);


    /* Create the underlying call dispatch commands */

TWAPI_EXTERN int ObjToVT(Tcl_Interp *interp, Tcl_Obj *obj, VARTYPE *vtP);
TWAPI_EXTERN Tcl_Obj *ObjFromBSTR (BSTR bstr);
TWAPI_EXTERN int ObjToBSTR (Tcl_Interp *, Tcl_Obj *, BSTR *);
TWAPI_EXTERN int ObjToRangedInt(Tcl_Interp *, Tcl_Obj *obj, int low, int high, int *iP);
TWAPI_EXTERN Tcl_Obj *ObjFromSYSTEMTIME(const SYSTEMTIME *timeP);
TWAPI_EXTERN int ObjToSYSTEMTIME(Tcl_Interp *interp, Tcl_Obj *timeObj, LPSYSTEMTIME timeP);
TWAPI_EXTERN Tcl_Obj *ObjFromFILETIME(const FILETIME *ftimeP);
TWAPI_EXTERN int ObjToFILETIME(Tcl_Interp *interp, Tcl_Obj *obj, FILETIME *cyP);
TWAPI_EXTERN Tcl_Obj *ObjFromTIME_ZONE_INFORMATION(const TIME_ZONE_INFORMATION *tzP);
TWAPI_EXTERN TCL_RESULT ObjToTIME_ZONE_INFORMATION(Tcl_Interp *interp, Tcl_Obj *tzObj, TIME_ZONE_INFORMATION *tzP);
TWAPI_EXTERN Tcl_Obj *ObjFromCY(const CY *cyP);
TWAPI_EXTERN int ObjToCY(Tcl_Interp *interp, Tcl_Obj *obj, CY *cyP);
TWAPI_EXTERN Tcl_Obj *ObjFromDECIMAL(DECIMAL *cyP);
TWAPI_EXTERN int ObjToDECIMAL(Tcl_Interp *interp, Tcl_Obj *obj, DECIMAL *cyP);

TWAPI_MAJOR=4
TWAPI_MINOR=5
TWAPI_BUILD=2
# RELEASETYPE: a is alpha, b is beta, . is release
TWAPI_RELEASETYPE = .

TWAPI_VERSION = $(TWAPI_MAJOR).$(TWAPI_MINOR)$(TWAPI_RELEASETYPE)$(TWAPI_BUILD)

/*
 * Copyright (c) 2003-2015, Ashok P. Nadkarni
 * All rights reserved.
 *
 * See the file LICENSE for license
 */

/* Define interface to Windows API related to process information */

/*  TBD - Vista and later - use QueryFullProcessImageName to get process image
    name since GetProcessImageName etc. have issues. See end of Jobs chapter
    in Richter's Windows via C/C++ */

#include "twapi.h"

#ifndef TWAPI_SINGLE_MODULE
static HMODULE gModuleHandle;     /* DLL handle to ourselves */
#endif

#ifndef MODULENAME

        DEFINE_FNCODE_CMD(GetModuleInformation, 10),
        DEFINE_FNCODE_CMD(Twapi_GetProcessList, 11),
        DEFINE_FNCODE_CMD(SetProcessWorkingSetSize, 12),
        DEFINE_FNCODE_CMD(SetThreadExecutionState, 13),
        DEFINE_FNCODE_CMD(ProcessIdToSessionId, 14),
        DEFINE_FNCODE_CMD(OpenProcess, 15),
        DEFINE_FNCODE_CMD(OpenThread, 16),
        DEFINE_FNCODE_CMD(GetProcessMemoryInfo, 17),
        DEFINE_FNCODE_CMD(IsWow64Process, 18),
        DEFINE_FNCODE_CMD(ResumeThread, 19),
        DEFINE_FNCODE_CMD(SuspendThread, 20),
        DEFINE_FNCODE_CMD(GetPriorityClass, 21),
        DEFINE_FNCODE_CMD(Twapi_NtQueryInformationProcessBasicInformation, 22),
        DEFINE_FNCODE_CMD(Twapi_NtQueryInformationThreadBasicInformation, 23),
        DEFINE_FNCODE_CMD(GetThreadPriority, 24),
        DEFINE_FNCODE_CMD(GetExitCodeProcess, 25),
        DEFINE_FNCODE_CMD(GetProcessImageFileName, 26),
        DEFINE_FNCODE_CMD(GetDeviceDriverBaseName, 27),
        DEFINE_FNCODE_CMD(GetDeviceDriverFileName, 28),
        DEFINE_FNCODE_CMD(WaitForInputIdle, 29),
        DEFINE_FNCODE_CMD(SetPriorityClass, 30),
        DEFINE_FNCODE_CMD(SetThreadPriority, 31),
        DEFINE_FNCODE_CMD(TerminateProcess, 32),
        DEFINE_FNCODE_CMD(GetModuleHandleEx, 33),

                         GETHKEY(hkey),
                         GETOBJ(subkeyObj), GETOBJ(objP),
                         ARGEND) != TCL_OK)
            return TCL_ERROR;
        else {
            FARPROC func = Twapi_GetProc_RegDeleteKeyValueW_advapi32();
            if (func == NULL) {
                func = Twapi_GetProc_RegDeleteKeyValueW_kernel32();
                if (func == NULL)
                    func = Twapi_GetProc_SHDeleteValueW();
            }
            if (func == NULL)
                result.value.ival = ERROR_PROC_NOT_FOUND;
            else {
                result.value.ival

}

static int TwapiShellInitCalls(Tcl_Interp *interp, TwapiInterpContext *ticP)
{
    static struct fncode_dispatch_s ShellDispatch[] = {
        DEFINE_FNCODE_CMD(Twapi_ReadShortcut, 2),
        DEFINE_FNCODE_CMD(Twapi_InvokeUrlShortcut, 3),
        DEFINE_FNCODE_CMD(SHInvokePrinterCommand, 4), // Deprecated in lieu of ShellExecute
        DEFINE_FNCODE_CMD(Twapi_GetShellVersion, 5),
        DEFINE_FNCODE_CMD(SHGetFolderPath, 6),
        DEFINE_FNCODE_CMD(SHGetSpecialFolderPath, 7),
        DEFINE_FNCODE_CMD(SHGetPathFromIDList, 8), // TBD - Tcl
        DEFINE_FNCODE_CMD(SHGetSpecialFolderLocation, 9),
        DEFINE_FNCODE_CMD(Shell_NotifyIcon, 10),
        DEFINE_FNCODE_CMD(Twapi_ReadUrlShortcut, 11),

/*
 * Copyright (c) 2003-2020, Ashok P. Nadkarni
 * All rights reserved.
 *
 * See the file LICENSE for license
 */

#include "twapi.h"
#include "twapi_storage.h"

#ifndef TWAPI_SINGLE_MODULE
static HMODULE gModuleHandle;     /* DLL handle to ourselves */
#endif

#ifndef MODULENAME
#define MODULENAME "twapi_storage"
#endif

/* File and disk related */

static Tcl_Obj *ObjFromWIN32_FIND_DATA(const WIN32_FIND_DATAW *findP)
{
    Tcl_Obj *objs[9];
    LARGE_INTEGER i64;
    objs[0] = ObjFromDWORD(findP->dwFileAttributes);
    objs[1] = ObjFromFILETIME(&findP->ftCreationTime);
    objs[2] = ObjFromFILETIME(&findP->ftLastAccessTime);
    objs[3] = ObjFromFILETIME(&findP->ftLastWriteTime);
    i64.LowPart = findP->nFileSizeLow;
    i64.HighPart = findP->nFileSizeHigh;
    objs[4] = ObjFromLARGE_INTEGER(i64);
    objs[5] = ObjFromDWORD(findP->dwReserved0);
    objs[6] = ObjFromDWORD(findP->dwReserved1);
    objs[7] = ObjFromWinChars(findP->cFileName);
    objs[8] = ObjFromWinChars(findP->cAlternateFileName);
    return ObjNewList(ARRAYSIZE(objs), objs);
}

int Twapi_GetFileType(Tcl_Interp *interp, HANDLE h)
{
    DWORD file_type = GetFileType(h);
    if (file_type == FILE_TYPE_UNKNOWN) {
        /* Is it really an error ? */
        DWORD winerr = GetLastError();

    ObjSetResult(interp, ObjNewList(3, objv));
    return TCL_OK;
}

static int Twapi_StorageCallObjCmd(ClientData clientdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
{
    LPWSTR s, s2;
    DWORD dw, dw2, dw3;
    HANDLE h;
    TwapiResult result;
    WCHAR buf[MAX_PATH+1];
    LARGE_INTEGER largeint;
    FILETIME ft[3];
    FILETIME *ftP[3];
    WIN32_FIND_DATAW finder;
    Tcl_Obj *objs[3];
    int i;
    int func = PtrToInt(clientdata);

    --objc;
    ++objv;

                         GETINT(dw), ARGSKIP, ARGSKIP, ARGEND) != TCL_OK)
            return TCL_ERROR;
        result.type = TRT_EXCEPTION_ON_FALSE;
        result.value.ival =
            DefineDosDeviceW(dw, ObjToWinChars(objv[1]),
                             ObjToLPWSTR_NULL_IF_EMPTY(objv[2]));
        break;
    case 24:
        CHECK_NARGS(interp, objc, 5);
        /* Note retrieve Unicode arg last to avoid shimmering disaster */
        CHECK_DWORD_OBJ(interp, dw, objv[1]);
        CHECK_DWORD_OBJ(interp, dw2, objv[2]);
        /* objv[3] currently ignored */
        CHECK_DWORD_OBJ(interp, dw3, objv[4]);
        s = ObjToWinChars(objv[0]);
        h = FindFirstFileExW(s, dw, &finder, dw2, NULL, dw3);
        if (h == INVALID_HANDLE_VALUE)
            result.type = TRT_GETLASTERROR;
        else {
            objs[0] = ObjFromOpaque(h, "FindFirstFileExW");
            objs[1] = ObjFromWIN32_FIND_DATA(&finder);
            result.type = TRT_OBJV;
            result.value.objv.objPP = objs;
            result.value.objv.nobj  = 2;
        }
        break;
    case 25:
        if (TwapiGetArgs(interp, objc, objv, GETHANDLET(h, FindFirstFileExW), ARGEND)
            != TCL_OK)
            return TCL_ERROR;
        result.value.ival = FindNextFile(h, &finder);
        if (result.value.ival) {
            result.value.obj = ObjFromWIN32_FIND_DATA(&finder);
            result.type = TRT_OBJ;
        }
        else {
            result.value.ival = GetLastError();
            if (result.value.ival == ERROR_NO_MORE_FILES)
                result.type = TRT_EMPTY;
            else
                result.type = TRT_EXCEPTION_ON_ERROR;
        }
        break;
    case 26:
        if (TwapiGetArgs(interp, objc, objv, GETHANDLET(h, FindFirstFileExW), ARGEND)
            != TCL_OK)
            return TCL_ERROR;
        result.type = TRT_EXCEPTION_ON_FALSE;
        result.value.ival = FindClose(h);
        break;
    }

    return TwapiSetResult(interp, &result);
}


static int TwapiStorageInitCalls(Tcl_Interp *interp, TwapiInterpContext *ticP)

        DEFINE_FNCODE_CMD(GetFileTime, 17),
        DEFINE_FNCODE_CMD(FlushFileBuffers, 18),
        DEFINE_FNCODE_CMD(MoveFileEx, 19), // TBD - Tcl
        DEFINE_FNCODE_CMD(SetVolumeLabel, 20),
        DEFINE_FNCODE_CMD(SetVolumeMountPoint, 21),
        DEFINE_FNCODE_CMD(SetFileTime, 22),
        DEFINE_FNCODE_CMD(DefineDosDevice, 23),
        DEFINE_FNCODE_CMD(FindFirstFileEx, 24),
        DEFINE_FNCODE_CMD(FindNextFile, 25),
        DEFINE_FNCODE_CMD(FindClose, 26),
    };

    TwapiDefineFncodeCmds(interp, ARRAYSIZE(StorDispatch), StorDispatch, Twapi_StorageCallObjCmd);
    Tcl_CreateObjCommand(interp, "twapi::Twapi_RegisterDirectoryMonitor", Twapi_RegisterDirectoryMonitorObjCmd, ticP, NULL);
    Tcl_CreateObjCommand(interp, "twapi::Twapi_UnregisterDirectoryMonitor", Twapi_UnregisterDirectoryMonitorObjCmd, ticP, NULL);

    return TCL_OK;

#
# Copyright (c) 2006-2018 Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

# TBD - tests  comobj? works with derived classes of Automation


# TBD - object identity comparison
#   - see http://blogs.msdn.com/ericlippert/archive/2005/04/26/412199.aspx
# TBD - we seem to resolve UDT's every time a COM method is actually invoked.
# Optimize by doing it when prototype is stored or only the first time it
# is called.
# TBD - optimize by caching UDT's within a type library when the library

    # TDH based event definitions

    record tdh_event { header buffer_context extended_data data }

    record tdh_event_header { flags event_property tid pid timestamp
        kernel_time user_time processor_time activity_id descriptor provider_guid}
    record tdh_event_buffer_context { processor logger_id }
    record tdh_event_data {provider_guid event_guid decoder provider_name level_name channel_name keyword_names task_name opcode_name message localized_provider_name activity_id related_activity_id properties flags}

    record tdh_event_data_descriptor {id version channel level opcode task keywords}

    # Definitions for EVENT_TRACE_LOGFILE
    record tdh_buffer { logfile logger current_time buffers_read header buffer_size filled kernel_trace }

    record tdh_logfile_header { size major_version minor_version sub_version subminor_version provider_version processor_count end_time resolution max_file_size logfile_mode buffers_written pointer_size events_lost cpu_mhz timezone boot_time perf_frequency start_time reserved_flags buffers_lost }

    set private_session [expr {0x800 & [etw_trace_logfile_header logfile_mode $bufhdr]}]
    set pointer_size [etw_trace_logfile_header pointer_size $bufhdr]

    set formatted_events {}
    foreach event $events {
        array set fields [tdh_event $event]
        set formatted_event [tdh_event_header descriptor $fields(header)]
        # Do not select provider_guid from header as for TDH it needs to come
        # from the provider_guid in the data portion.
        lappend formatted_event {*}[tdh_event_header select $fields(header) {timestamp tid pid}]
        lappend formatted_event {*}[tdh_event_data select $fields(data) provider_guid]
        if {$private_session} {
            lappend formatted_event [expr {[tdh_event_header processor_time $fields(header)] * $timer_resolution}] 0
        } else {
            lappend formatted_event [expr {[tdh_event_header user_time $fields(header)] * $timer_resolution}] [expr {[tdh_event_header kernel_time $fields(header)] * $timer_resolution}]
        }
        lappend formatted_event {*}[tdh_event_data select $fields(data) {provider_name event_guid channel_name level_name opcode_name task_name keyword_names properties message}] [dict* $fields(extended_data) sid ""]

                set events [etw_format_events $formatter $bufd $events]
                foreach event [recordarray getlist $events -format dict -filter $opts(filter)] {
                    if {$max >= 0 && [set $counter_varname] >= $max} {
                        return -code break
                    }
                    array set fields $event
                    if {"-message" in $opts(fields)} {
                        if {$fields(-message) ne ""} {
                            set fields(-message) [etw_format_event_message $fields(-message) $fields(-properties)]
                        } else {
                            set fields(-message) "Properties: $fields(-properties)"
                        }
                    }
                    if {"-properties" in $opts(fields)} {
                        set fmtdata $fields(-properties)
                        if {[dict exists $fmtdata mofdata]} {
                            # Only show 32 bytes
                            binary scan [string range [dict get $fmtdata mofdata] 0 31] H* hex
                            dict set fmtdata mofdata [regsub -all (..) $hex {\1 }]

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

namespace eval twapi {
    record IP_ADAPTER_ADDRESSES_XP {
        -ipv4ifindex -adaptername -unicastaddresses -anycastaddresses

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






namespace eval twapi {}


# Create a process
# TBD Use https://blogs.msdn.microsoft.com/twistylittlepassagesallalike/2011/04/23/everyone-quotes-command-line-arguments-the-wrong-way/
# to construct -cmdline value
proc twapi::create_process {path args} {

    }


    set matches [recordarray get [get_multiple_process_info -matchpids $all_pids {*}$popts] -filter $filter_expr]
    return [recordarray column $matches -pid]
}

proc twapi::get_process_memory_info {{pid {}}} {
    variable my_process_handle

    if {$pid eq "" || $pid == [pid]} {
        set hpid $my_process_handle
    } else {
        set hpid [get_process_handle $pid -access {process_query_information process_vm_read}]
    }

    try {
        # Note: -pagefileusage and -privateusage are same according to SDK.
        # However for Win7 and earlier, -pagefileusage is always set to 0.
        # We return what was given and not try to fix it up.
        return [twine {
            -pagefaults -workingsetpeak -workingset
            -poolpagedbytespeak -poolpagedbytes
            -poolnonpagedbytespeak -poolnonpagedbytes
            -pagefilebytes -pagefilebytespeak -privatebytes
        } [GetProcessMemoryInfo $hpid]]
    } finally {
        if {$hpid != $my_process_handle} {
            CloseHandle $hpid
        }
    }
}

# Return list of modules handles for a process
proc twapi::get_process_modules {pid args} {
    variable my_process_handle

    array set opts [parseargs args {handle name path base size entry all}]

    set flags 0
    if {$opts(allowui)} {setbits flags 1}
    if {! [info exists opts(verb)]} {
        setbits flags 2
        set opts(verb) ""
    }


    Twapi_InvokeUrlShortcut $link $opts(verb) $flags $opts(hwin)
}

# Send a file to the recycle bin
proc twapi::recycle_file {fn args} {
    return [recycle_files [list $fn] {*}$args]
}

# Send multiple files to the recycle bin - from Alexandru
# This is much faster than "recycle_file"!

proc twapi::recycle_files {fns args} {
    array set opts [parseargs args {
        confirm.bool
        showerror.bool
    } -maxleftover 0 -nulldefault]

    if {$opts(confirm)} {

    }]

    return [expr {[lindex [Twapi_SHFileOperation 0 3 $fns __null__ $flags ""] 0] ? false : true}]
}

proc twapi::shell_execute args {
    # TBD - Document following shell_execute options after testing.

    # [opt_def [cmd -connect] [arg BOOLEAN]]
    # [opt_def [cmd -hicon] [arg HANDLE]]
    # [opt_def [cmd -hkeyclass] [arg BOOLEAN]]
    # [opt_def [cmd -hotkey] [arg HOTKEY]]
    # [opt_def [cmd -nozonechecks] [arg BOOLEAN]]

    array set opts [parseargs args {

    }
}

proc twapi::flush_channel {chan} {
    flush $chan
    FlushFileBuffers [get_tcl_channel_handle $chan write]
}

proc twapi::find_file_open {path args} {
    variable _find_tokens
    variable _find_counter
    parseargs args {
        {detail.arg basic {basic full}}
    } -setvars -maxleftover 0

    set detail_level [expr {$detail eq "basic" ? 1 : 0}]
    if {[min_os_version 6 1]} {
        set flags 2;            # FIND_FIRST_EX_LARGE_FETCH - Win 7
    } else {
        set flags 0
    }
    # 0 -> search op. Could be specified as 1 to limit search to
    # directories but that is only advisory and does not seem to work
    # in many cases. So don't bother making it an option.
    lassign [FindFirstFileEx $path $detail_level 0 "" $flags] handle entry
    set token ff#[incr _find_counter]
    set _find_tokens($token) [list Handle $handle Entry $entry]
    return $token
}

proc twapi::find_file_close {token} {
    variable _find_tokens
    if {[info exists _find_tokens($token)]} {
        FindClose [dict get $_find_tokens($token) Handle]
        unset _find_tokens($token)
    }
    return
}

proc twapi::decode_file_attributes {attrs} {
    return [_make_symbolic_bitmask $attrs {
        archive               0x20
        compressed            0x800
        device                0x40
        directory             0x10
        encrypted             0x4000
        hidden                0x2
        integrity_stream      0x8000
        normal                0x80
        not_content_indexed   0x2000
        no_scrub_data         0x20000
        offline               0x1000
        readonly              0x1
        recall_on_data_access 0x400000
        recall_on_open        0x40000
        reparse_point         0x400
        sparse_file           0x200
        system                0x4
        temporary             0x100
        virtual               0x10000
    }]
}

proc twapi::find_file_next {token varname} {
    variable _find_tokens
    if {![info exists _find_tokens($token)]} {
        return false
    }
    if {[dict exists $_find_tokens($token) Entry]} {
        set entry [dict get $_find_tokens($token) Entry]
        dict unset _find_tokens($token) Entry
    } else {
        set entry [FindNextFile [dict get $_find_tokens($token) Handle]]
    }
    if {[llength $entry]} {
        upvar 1 $varname result
        set result [twine {attrs ctime atime mtime size reserve0 reserve1 name altname} $entry]
        return true
    } else {
        return false
    }
}

# Utility functions

proc twapi::_drive_rootpath {drive} {
    if {[_is_unc $drive]} {
        # UNC
        return "[string trimright $drive ]\\"

#
# Copyright (c) 2012-2020, Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license
namespace eval twapi::tls {
    # Each element of _channels is dictionary with the following keys
    #  Socket - the underlying socket. This key will not exist if
    #   socket has been closed.
    #  State - SERVERINIT, CLIENTINIT, LISTENERINIT, OPEN, NEGOTIATING, CLOSED
    #  Type - SERVER, CLIENT, LISTENER
    #  Blocking - 0/1 indicating whether blocking or non-blocking channel

}

proc twapi::tls::blocking {chan mode} {
    debuglog [info level 0]

    variable _channels

    dict set _channels($chan) Blocking $mode


    if {![dict exists $_channels($chan) Socket]} {
        # We do not currently generate an error because the Tcl socket
        # command does not either on a fconfigure when remote has
        # closed connection
        return
    }
    set so [dict get $_channels($chan) Socket]
    fconfigure $so -blocking $mode

    # There is an issue with Tcl sockets created with -async switching
    # from blocking->non-blocking->blocking and writing to the socket
    # before connection is fully open. The internal buffers containing
    # data that was written before the connection was open do not get
    # flushed even if there was an explicit flush call by the application.
    # Doing a flush after changing blocking mode seems to fix this
    # problem. TBD - check if still the case
    flush $so

    # TBD - Should we change handlers BEFORE flushing?

    # The flush may recursively call event handler (possibly) which
    # may change state so have to retrieve values from _channels again.
    if {![dict exists $_channels($chan) Socket]} {
        return
    }
    set so [dict get $_channels($chan) Socket]

    if {[dict get $_channels($chan) Blocking] == 0} {
        # Non-blocking
        # Since we need to negotiate TLS we always have socket event
        # handlers irrespective of the state of the watch mask
        chan event $so readable [list [namespace current]::_so_read_handler $chan]
        chan event $so writable [list [namespace current]::_so_write_handler $chan]
    } else {
        chan event $so readable {}
        chan event $so writable {}

    }
    return
}

proc twapi::tls::watch {chan watchmask} {
    debuglog [info level 0]
    variable _channels

    dict set _channels($chan) WatchMask $watchmask

    if {"read" in $watchmask} {
        # Post a read even if we already have input or if the
        # underlying socket has gone away.
        # TBD - do we have a mechanism for continuously posting
        # events when socket has gone away ? Do we even post once
        # when socket is closed (on error for example)
        if {[string length [dict get $_channels($chan) Input]] || ![dict exists $_channels($chan) Socket]} {
            _post_read_event $chan
        }
        # Turn read handler back on in case it had been turned off.
        chan event [dict get $_channels($chan) Socket] readable [list [namespace current]::_so_read_handler $chan]
    }


    if {"write" in [dict get $_channels($chan) WatchMask]} {
        # We will mark channel as writable even if we are still
        # initializing. This is to deal with the case where
        # the -async option is used and caller waits for the
        # writable event to do the actual write (which will then
        # trigger the negotiation if needed)
        if {[dict get $_channels($chan) State] in {OPEN SERVERINIT CLIENTINIT NEGOTIATING}} {
            _post_write_event $chan
        }

        # TBD - do we need to turn write handler back on?
    }

    return
}

proc twapi::tls::read {chan nbytes} {
    variable _channels

    if {[info exists _channels($chan)] &&
        [dict get $_channels($chan) Type] eq "SERVER" &&
        [dict get $_channels($chan) State] eq "CLOSED"} {
        close $chan;            # Really close
    }
}

if {[llength [info commands ::twapi::tls_background_error]] == 0} {
    proc twapi::tls_background_error {result ropts} {

        return -options $ropts $result
    }
}

proc twapi::tls::_negotiate_from_handler {chan} {
    # Called from socket read / write handlers if
    # negotiation is still in progress.
    # Returns the error code from next step of
    # negotiation.

        }
        if {"write" in [dict get $_channels($chan) WatchMask]} {
            _post_write_event $chan
        }
        # For SERVER sockets, force error because no other way
        # to record some error happened.
        if {[dict get $_channels($chan) Type] eq "SERVER"} {
            ::twapi::tls_background_error $result $ropts
            # Above should raise an error, else do it ourselves
            # since stack needs to be rewound
            return -options $ropts $result
        }
        return 0
    }
    return 1
}

proc twapi::tls::_so_read_handler {chan} {

        twapi::write_clipboard_paths $paths
        twapi::read_clipboard_paths
    } -result [list [file normalize foo] [file normalize [info nameofexecutable]]]


    ################################################################

    test get_clipboard_sequence-1.0 {
        Clipboard sequence number
    } -body {
        set oldseq [twapi::get_clipboard_sequence]
        twapi::write_clipboard_text "This is plain text"
        set newseq [twapi::get_clipboard_sequence]
        expr {$newseq >= [incr oldseq]}
    } -result 1

    ################################################################
    test start_clipboard_monitor-1.0 {
        Monitor the clipboard
    } -constraints {
        userInteraction
    } -body {
        set ::clipboard_changed false
        set ::cl_win [::twapi::start_clipboard_monitor "set ::clipboard_changed true"]

    } -body {
        ::twapi::stop_clipboard_monitor $::cl_win
        set ::clipboard_changed false
        copy2clip "clipboard monitor"
        update;                 # So callback runs if still registered
        set ::clipboard_changed
    } -result false

    ################################################################

    test get_clipboard_owner-1.0 {
        Get clipboard owner
    } -body {
        twapi::get_clipboard_owner
    } -match handle -result HWND

    ################################################################

    test get_open_clipboard_window-1.0 {
        Get open clipboard owner
    } -setup {
        twapi::open_clipboard
    } -cleanup {
        twapi::close_clipboard
    } -body {
        twapi::get_clipboard_owner
    } -match handle -result HWND

    ################################################################

    ::tcltest::cleanupTests
}

namespace delete ::twapi::clipboard::test

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

# This file contains tests for commands from the process.tcl

    test unload_user_profile-1.0 {
    } -constraints {
        TBD
    } -body {
        TBD
    }

    ################################################################
    proc memory_info_check {pid meminfo} {
        array set procinfo $meminfo
        set result ""
        foreach field {
            -workingsetpeak -workingset
            -poolpagedbytes -poolnonpagedbytes
            -pagefilebytes -pagefilebytespeak
        } {
            set checkval [get_process_field $pid $field]
            if {![approx $checkval $procinfo($field)]} {
                append result "Mismatch in $field. $checkval !~ $procinfo($field).\n"
            }
        }
        if {![string is entier $procinfo(-pagefaults)]} {
            append result "Invalid -pagefault field.\n"
        }
        if {$procinfo(-poolpagedbytespeak) < $procinfo(-poolpagedbytes)} {
            append result "-poolpagedbytespeak < -poolpagedbytes. ($procinfo(-poolpagedbytespeak) < $procinfo(-poolpagedbytes)).\n"
        }
        if {$procinfo(-poolnonpagedbytespeak) < $procinfo(-poolnonpagedbytes)} {
            append result "-poolnonpagedbytespeak < -poolnonpagedbytes. ($procinfo(-poolnonpagedbytespeak) < $procinfo(-poolnonpagedbytes)).\n"
        }
        if {$procinfo(-privatebytes) > $procinfo(-pagefilebytespeak)} {
            append result "-privatebytes > -pagefilebytespeak. ($procinfo(-privatebytes) > $procinfo(-pagefilebytespeak)).\n"
        }
        return $result
    }
    test get_process_memory_info-1.0 {
        get_process_memory_info - no args
    } -constraints {
        nt
    } -body {
        memory_info_check [pid] [twapi::get_process_memory_info]
    } -result ""

    test get_process_memory_info-1.1 {
        get_process_memory_info current process
    } -constraints {
        nt
    } -body {
        memory_info_check [pid] [twapi::get_process_memory_info [pid]]
    } -result ""

    test get_process_memory_info-1.2 {
        get_process_memory_info another process
    } -constraints {
        nt
    } -body {
        set pid [get_explorer_pid]
        memory_info_check $pid [twapi::get_process_memory_info $pid]
    } -result ""
    ################################################################

}
::tcltest::cleanupTests
namespace delete ::twapi::process::test

MTL=midl.exe
MTL_PROJ=/nologo /D "NDEBUG" /mktyplib203 /win32
RSC=rc.exe
RSC_PROJ=/l 0x409 /fo"$(INTDIR)\rctest.res" /d "NDEBUG"
BSC32=bscmake.exe
BSC32_FLAGS=/nologo /o"$(OUTDIR)\rctest.bsc"
BSC32_SBRS= \

LINK32=link.exe
LINK32_FLAGS=kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /dll /incremental:no /pdb:"$(OUTDIR)\rctest.pdb" /machine:$(CPU) /out:"$(OUTDIR)\rctest.dll" /implib:"$(OUTDIR)\rctest.lib"

!if "$(CPU)" == "AMD64"
LINK32_FLAGS = $(LINK32_FLAGS) bufferoverflowU.lib
!endif

                }
            } msg]} {
                lappend mismatches "$drive error: $msg"
            }
        }
        set mismatches
    } -result {}

    ################################################################

    test find_file-1.0 {
        find_file_open/next/close vs glob
    } -body {
        set tok [twapi::find_file_open C:/*]
        set files [list ]
        while {[twapi::find_file_next $tok finfo]} {
            lappend files [dict get $finfo name]
            #set attrs [twapi::decode_file_attributes [dict get $finfo attrs]]
            #puts [dict get $finfo name]:$attrs
        }
        twapi::find_file_close $tok
        lsort $files
    } -result [lsort [concat [glob -directory C:/ -tails *] [glob -directory C:/ -types hidden -tails *]]]

    test find_file-1.1 {
        find_file_open/next/close size
    } -body {
        set tok [twapi::find_file_open C:/*]
        set mismatch ""
        while {[twapi::find_file_next $tok finfo]} {
            set path [file join c:/ [dict get $finfo name]]
            if {"directory" in [twapi::decode_file_attributes [dict get $finfo attrs]]} {
               set expected_size 0
            } else {
                set expected_size [file size $path]
            }
            if {[dict get $finfo size] != $expected_size} {
                append mismatch "File size mismatch for $path.\n"
            }
        }
        twapi::find_file_close $tok
        set mismatch
    } -result ""

    test find_file-1.2 {
        find_file_open/next/close time stamps
    } -body {
        # TBD - Only basic test because times do not match for whatever reason
        # between FindFile* and GetFileTime (or file size command) though
        # verified as correctly retrieved.
        set tok [twapi::find_file_open [info nameofexecutable]]
        set mismatch ""
        while {$mismatch eq "" && [twapi::find_file_next $tok finfo]} {
            foreach t {ctime mtime atime} {
                if {![string is entier [dict get $finfo $t]]} {
                    append mismatch "File time stamp not a integer."
                }
            }
        }
        twapi::find_file_close $tok
        set mismatch
    } -result ""

    test find_file-1.3.0 {
        find_file_open/next/close altname without -detail
    } -body {
        set tok [twapi::find_file_open $::env(programfiles)]
        twapi::find_file_next $tok finfo
        twapi::find_file_close $tok
        list [dict get $finfo name] [dict get $finfo altname]
    } -result [list [file tail [file attributes $::env(programfiles) -longname]] {}]

    test find_file-1.3.1 {
        find_file_open/next/close altname -detail basic
    } -body {
        set tok [twapi::find_file_open $::env(programfiles) -detail basic]
        twapi::find_file_next $tok finfo
        twapi::find_file_close $tok
        list [dict get $finfo name] [dict get $finfo altname]
    } -result [list [file tail [file attributes $::env(programfiles) -longname]] {}]

    test find_file-1.3.2 {
        find_file_open/next/close altname -detail full
    } -body {
        set tok [twapi::find_file_open $::env(programfiles) -detail full]
        twapi::find_file_next $tok finfo
        twapi::find_file_close $tok
        list [dict get $finfo name] [dict get $finfo altname]
    } -result [list [file tail [file attributes $::env(programfiles) -longname]] [file tail [file attributes $::env(programfiles) -shortname]]]

    test find_file-1.4.0 {
        find_file_open/next/close attrs archive hidden system
    } -body {
        set tok [twapi::find_file_open c:/pagefile.sys]
        twapi::find_file_next $tok finfo
        twapi::find_file_close $tok
        set attrs [twapi::decode_file_attributes [dict get $finfo attrs]]
        lsort $attrs
    } -result {archive hidden system}

    test find_file-1.4.1 {
        find_file_open/next/close other attributes
    } -constraints {
        TBD
    } -body {
        set tok [twapi::find_file_open $::env(systemroot)]
        twapi::find_file_next $tok finfo
        twapi::find_file_close $tok
        set attrs [twapi::decode_file_attributes [dict get $finfo attrs]]
        lsort $attrs
    } -result {archive hidden system}

    ################################################################

    ::tcltest::cleanupTests
}

namespace delete ::twapi::disk::test